basis/images/normalization/normalization.factor

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