extra/alien/data/map/map-tests.factor

   1 ! (c)Joe Groff bsd license
   2 USING: alien.data alien.data.map fry generalizations kernel locals math.vectors
   3 math.vectors.conversion math math.vectors.simd math.ranges sequences
   4 specialized-arrays tools.test ;
   5 FROM: alien.c-types => uchar short int float ;
   6 SPECIALIZED-ARRAYS: int float float-4 uchar-16 ;
   7 IN: alien.data.map.tests
   8
   9 [ float-array{ 1.0 1.0 3.0 3.0 5.0 5.0 } ]
  10 [
  11     int-array{ 1 3 5 } [ dup ] data-map( int -- float[2] )
  12     float cast-array
  13 ] unit-test
  14
  15 [
  16     float-4-array{
  17         float-4{ 0.0 0.0 0.0 0.0 }
  18         float-4{ 1.0 1.0 1.0 1.0 }
  19         float-4{ 2.0 2.0 2.0 2.0 }
  20     }
  21 ] [
  22     3 iota [ float-4-with ] data-map( object -- float-4 )
  23     float-4 cast-array
  24 ] unit-test
  25
  26 [
  27     float-4-array{
  28         float-4{ 0.0 1.0  2.0  3.0 }
  29         float-4{ 4.0 5.0  6.0  7.0 }
  30         float-4{ 8.0 9.0 10.0 11.0 }
  31     }
  32 ] [
  33     12 iota [ float-4-boa ] data-map( object[4] -- float-4 )
  34     float-4 cast-array
  35 ] unit-test
  36
  37 [ float-array{ 1.0 1.0 3.0 3.0 5.0 5.0 0.0 0.0 } ]
  38 [
  39     int-array{ 1 3 5 } float-array{ 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 }
  40     [ dup ] data-map!( int -- float[2] )
  41 ] unit-test
  42
  43 :: float-pixels>byte-pixels-locals ( floats scale bias -- bytes )
  44     floats [
  45         [ scale 255.0 * v*n bias 255.0 * v+n float-4 int-4 vconvert ] 4 napply
  46         [ int-4 short-8 vconvert ] 2bi@
  47         short-8 uchar-16 vconvert
  48     ] data-map( float-4[4] -- uchar-16 ) ; inline
  49
  50 : float-pixels>byte-pixels* ( floats scale bias -- bytes )
  51     '[
  52         [ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
  53         [ int-4 short-8 vconvert ] 2bi@
  54         short-8 uchar-16 vconvert
  55     ] data-map( float-4[4] -- uchar-16 ) ; inline
  56
  57 : float-pixels>byte-pixels ( floats -- bytes )
  58     1.0 0.0 float-pixels>byte-pixels* ;
  59
  60 [
  61     B{
  62         127 191 255 63
  63         255 25 51 76
  64         76 51 229 127
  65         25 255 255 255
  66     }
  67 ] [
  68     float-array{
  69         0.5 0.75 1.0 0.25
  70         1.0 0.1 0.2 0.3
  71         0.3 0.2 0.9 0.5
  72         0.1 1.0 1.5 2.0
  73     } 1.0 0.0 float-pixels>byte-pixels-locals
  74 ] unit-test
  75
  76 [
  77     B{
  78         127 191 255 63
  79         255 25 51 76
  80         76 51 229 127
  81         25 255 255 255
  82     }
  83 ] [
  84     float-array{
  85         0.5 0.75 1.0 0.25
  86         1.0 0.1 0.2 0.3
  87         0.3 0.2 0.9 0.5
  88         0.1 1.0 1.5 2.0
  89     } float-pixels>byte-pixels
  90 ] unit-test
  91
  92 [
  93     B{
  94         127 191 255 63
  95         255 25 51 76
  96         76 51 229 127
  97         25 255 255 255
  98     }
  99 ] [
 100     float-array{
 101         0.5 0.75 1.0 0.25
 102         1.0 0.1 0.2 0.3
 103         0.3 0.2 0.9 0.5
 104         0.1 1.0 1.5 2.0
 105         5.0
 106     } [
 107         [ 255.0 v*n float-4 int-4 vconvert ] 4 napply
 108         [ int-4 short-8 vconvert ] 2bi@
 109         short-8 uchar-16 vconvert
 110     ] data-map( float-4[4] -- uchar-16 )
 111 ] unit-test
 112
 113 : vmerge-transpose ( a b c d -- ac bd ac bd )
 114     [ (vmerge) ] bi-curry@ bi* ; inline
 115
 116 CONSTANT: plane-count 4
 117
 118 : fold-rgba-planes ( r g b a -- rgba )
 119     [ vmerge-transpose vmerge-transpose ]
 120     data-map( uchar-16 uchar-16 uchar-16 uchar-16 -- uchar-16[plane-count] ) ;
 121
 122 [
 123     B{
 124          1  10  11  15
 125          2  20  22  25
 126          3  30  33  35
 127          4  40  44  45
 128          5  50  55  55
 129          6  60  66  65
 130          7  70  77  75
 131          8  80  88  85
 132          9  90  99  95
 133         10 100 110 105
 134         11 110 121 115
 135         12 120 132 125
 136         13 130 143 135
 137         14 140 154 145
 138         15 150 165 155
 139         16 160 176 165
 140     }
 141 ] [
 142     B{   1   2   3   4   5   6   7   8   9  10  11  12  13  14  15  16 }
 143     B{  10  20  30  40  50  60  70  80  90 100 110 120 130 140 150 160 }
 144     B{  11  22  33  44  55  66  77  88  99 110 121 132 143 154 165 176 }
 145     B{  15  25  35  45  55  65  75  85  95 105 115 125 135 145 155 165 }
 146     fold-rgba-planes
 147 ] unit-test
 148
 149 : data-map-compiler-bug-test ( n -- byte-array )
 150     [ 0.0 1.0 1.0 ] dip /f <range>
 151     [ ] data-map( object -- float ) ;
 152
 153 [ float-array{ 0.0 0.5 1.0 } ]
 154 [ 2 data-map-compiler-bug-test float cast-array ]
 155 unit-test