basis/images/normalization/normalization.factor

   1 ! Copyright (C) 2009 Doug Coleman, Keith Lazuka
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.data byte-arrays
   4 combinators fry grouping images kernel locals math math.vectors
   5 sequences specialized-arrays math.floats.half ;
   6 FROM: alien.c-types => float ;
   7 SPECIALIZED-ARRAY: half
   8 SPECIALIZED-ARRAY: float
   9 SPECIALIZED-ARRAY: ushort
  10 IN: images.normalization
  11
  12 <PRIVATE
  13
  14 CONSTANT: don't-care 127
  15 CONSTANT: fill-value 255
  16
  17 : permutation ( src dst -- seq )
  18     swap '[ _ index [ don't-care ] unless* ] { } map-as
  19     4 don't-care pad-tail ;
  20
  21 : pad4 ( seq -- newseq ) 4 fill-value pad-tail ;
  22
  23 : shuffle ( seq permutation -- newseq )
  24     swap '[
  25         dup 4 >= [ drop fill-value ] [ _ nth ] if
  26     ] B{ } map-as ;
  27
  28 :: permute ( bytes width stride src-order dst-order -- new-bytes )
  29     src-order name>> :> src
  30     dst-order name>> :> dst
  31     bytes stride group
  32     [
  33         src length group width head
  34         [ pad4 src dst permutation shuffle dst length head ] map concat
  35     ] map concat ;
  36
  37 : stride ( image -- n )
  38     [ bitmap>> length ] [ dim>> second ] bi / ;
  39
  40 : (reorder-components) ( image src-order dest-order -- image )
  41     [ [ ] [ dim>> first ] [ stride ] tri ] 2dip
  42     '[ _ _ _ _ permute ] change-bitmap ;
  43
  44 GENERIC: normalize-component-type* ( image component-type -- image )
  45
  46 : normalize-floats ( float-array -- byte-array )
  47     [ 255.0 * >integer ] B{ } map-as ;
  48
  49 M: float-components normalize-component-type*
  50     drop float cast-array normalize-floats ;
  51
  52 M: half-components normalize-component-type*
  53     drop half cast-array normalize-floats ;
  54
  55 : ushorts>ubytes ( bitmap -- bitmap' )
  56     ushort cast-array [ -8 shift ] B{ } map-as ; inline
  57
  58 M: ushort-components normalize-component-type*
  59     drop ushorts>ubytes ;
  60
  61 M: ubyte-components normalize-component-type*
  62     drop ;
  63
  64 : normalize-scan-line-order ( image -- image' )
  65     dup upside-down?>> [
  66         dup dim>> first 4 * '[
  67             _ <groups> reverse concat
  68         ] change-bitmap
  69         f >>upside-down?
  70     ] when ;
  71
  72 : validate-request ( src-order dst-order -- src-order dst-order )
  73     [
  74         [ { DEPTH DEPTH-STENCIL INTENSITY } member? ] bi@
  75         or [ "Invalid component-order" throw ] when
  76     ] 2keep ;
  77
  78 PRIVATE>
  79
  80 : reorder-components ( image component-order -- image' )
  81     [
  82         dup component-type>> '[ _ normalize-component-type* ] change-bitmap
  83         dup component-order>>
  84     ] dip
  85     validate-request [ (reorder-components) ] keep >>component-order ;
  86
  87 : normalize-image ( image -- image' )
  88     [ >byte-array ] change-bitmap
  89     RGBA reorder-components
  90     normalize-scan-line-order ;
  91