extra/images/normalization/normalization.factor

   1 ! Copyright (C) 2009 Doug Coleman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors grouping sequences combinators math
   4 byte-arrays fry specialized-arrays.direct.ushort
   5 specialized-arrays.uint specialized-arrays.ushort
   6 specialized-arrays.float images half-floats ;
   7 IN: images.normalization
   8
   9 <PRIVATE
  10
  11 : add-dummy-alpha ( seq -- seq' )
  12     3 <groups> [ 255 suffix ] map concat ;
  13
  14 : normalize-floats ( float-array -- byte-array )
  15     [ 255.0 * >integer ] B{ } map-as ;
  16
  17 GENERIC: normalize-component-type* ( image component-type -- image )
  18 GENERIC: normalize-component-order* ( image component-order -- image )
  19
  20 : normalize-component-order ( image -- image )
  21     dup component-type>> '[ _ normalize-component-type* ] change-bitmap
  22     dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
  23
  24 M: float-components normalize-component-type*
  25     drop byte-array>float-array normalize-floats ;
  26 M: half-components normalize-component-type*
  27     drop byte-array>half-array normalize-floats ;
  28
  29 : ushorts>ubytes ( bitmap -- bitmap' )
  30     byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
  31
  32 M: ushort-components normalize-component-type*
  33     drop ushorts>ubytes ;
  34
  35 M: ubyte-components normalize-component-type*
  36     drop ;
  37
  38 M: RGBA normalize-component-order* drop ;
  39
  40 : BGR>RGB ( bitmap -- pixels )
  41     3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
  42
  43 : BGRA>RGBA ( bitmap -- pixels )
  44     4 <sliced-groups>
  45     [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
  46
  47 M: BGRA normalize-component-order*
  48     drop BGRA>RGBA ;
  49
  50 M: RGB normalize-component-order*
  51     drop add-dummy-alpha ;
  52
  53 M: BGR normalize-component-order*
  54     drop BGR>RGB add-dummy-alpha ;
  55
  56 : ARGB>RGBA ( bitmap -- bitmap' )
  57     4 <groups> [ unclip suffix ] map B{ } join ; inline
  58
  59 M: ARGB normalize-component-order*
  60     drop ARGB>RGBA ;
  61
  62 M: ABGR normalize-component-order*
  63     drop ARGB>RGBA BGRA>RGBA ;
  64
  65 : fix-XBGR ( bitmap -- bitmap' )
  66     dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
  67
  68 M: XBGR normalize-component-order*
  69     drop fix-XBGR ABGR normalize-component-order* ;
  70
  71 : fix-BGRX ( bitmap -- bitmap' )
  72     dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
  73
  74 M: BGRX normalize-component-order*
  75     drop fix-BGRX BGRA normalize-component-order* ;
  76
  77 : normalize-scan-line-order ( image -- image )
  78     dup upside-down?>> [
  79         dup dim>> first 4 * '[
  80             _ <groups> reverse concat
  81         ] change-bitmap
  82         f >>upside-down?
  83     ] when ;
  84
  85 PRIVATE>
  86
  87 : normalize-image ( image -- image )
  88     [ >byte-array ] change-bitmap
  89     normalize-component-order
  90     normalize-scan-line-order
  91     RGBA >>component-order ;