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
14 CONSTANT: don't-care 127
15 CONSTANT: fill-value 255
17 : permutation ( src dst -- seq )
18 swap '[ _ index [ don't-care ] unless* ] { } map-as
19 4 don't-care pad-tail ;
21 : pad4 ( seq -- newseq ) 4 fill-value pad-tail ;
23 : shuffle ( seq permutation -- newseq )
25 dup 4 >= [ drop fill-value ] [ _ nth ] if
28 :: permute ( bytes width stride src-order dst-order -- new-bytes )
29 src-order name>> :> src
30 dst-order name>> :> dst
33 src length group width head
34 [ pad4 src dst permutation shuffle dst length head ] map concat
37 : stride ( image -- n )
38 [ bitmap>> length ] [ dim>> second ] bi / ;
40 : (reorder-components) ( image src-order dest-order -- image )
41 [ [ ] [ dim>> first ] [ stride ] tri ] 2dip
42 '[ _ _ _ _ permute ] change-bitmap ;
44 GENERIC: normalize-component-type* ( image component-type -- image )
46 : normalize-floats ( float-array -- byte-array )
47 [ 255.0 * >integer ] B{ } map-as ;
49 M: float-components normalize-component-type*
50 drop float cast-array normalize-floats ;
52 M: half-components normalize-component-type*
53 drop half cast-array normalize-floats ;
55 : ushorts>ubytes ( bitmap -- bitmap' )
56 ushort cast-array [ -8 shift ] B{ } map-as ; inline
58 M: ushort-components normalize-component-type*
61 M: ubyte-components normalize-component-type*
64 : normalize-scan-line-order ( image -- image' )
66 dup dim>> first 4 * '[
67 _ <groups> reverse concat
72 : validate-request ( src-order dst-order -- src-order dst-order )
74 [ { DEPTH DEPTH-STENCIL INTENSITY } member? ] bi@
75 or [ "Invalid component-order" throw ] when
80 : reorder-components ( image component-order -- image' )
82 dup component-type>> '[ _ normalize-component-type* ] change-bitmap
85 validate-request [ (reorder-components) ] keep >>component-order ;
87 : normalize-image ( image -- image' )
88 [ >byte-array ] change-bitmap
89 RGBA reorder-components
90 normalize-scan-line-order ;