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