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