data-map general-purpose binary mapping combinator

extra/alien/data/map/authors.txt

@@ -0,0 +1 @@
+Joe Groff

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

@@ -0,0 +1,54 @@
+! (c)Joe Groff bsd license
+USING: alien.data.map generalizations kernel math.vectors
+math.vectors.conversion math.vectors.simd
+specialized-arrays tools.test ;
+FROM: alien.c-types => uchar short int float ;
+SIMDS: float int short uchar ;
+SPECIALIZED-ARRAYS: int float float-4 uchar-16 ;
+IN: alien.data.map.tests
+
+[ float-array{ 1.0 1.0 3.0 3.0 5.0 5.0 } ]
+[
+    int-array{ 1 3 5 } [ dup ] data-map( int -- float[2] )
+    byte-array>float-array
+] unit-test
+
+[ float-array{ 1.0 1.0 3.0 3.0 5.0 5.0 0.0 0.0 } ]
+[
+    int-array{ 1 3 5 } float-array{ 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 }
+    [ dup ] data-map!( int -- float[2] )
+] unit-test
+
+[
+    B{
+        127 191 255 63
+        255 25 51 76
+        76 51 229 127
+        25 255 255 255
+    } 
+] [
+    float-array{
+        0.5 0.75 1.0 0.25
+        1.0 0.1 0.2 0.3
+        0.3 0.2 0.9 0.5
+        0.1 1.0 1.5 2.0
+    } [
+        [ 255.0 v*n float-4 int-4 vconvert ] 4 napply 
+        [ int-4 short-8 vconvert ] 2bi@
+        short-8 uchar-16 vconvert
+    ] data-map( float-4[4] -- uchar-16 )
+] unit-test
+
+[
+    float-array{
+        0.5 0.75 1.0 0.25
+        1.0 0.1 0.2 0.3
+        0.3 0.2 0.9 0.5
+        0.1 1.0 1.5 2.0
+        5.0
+    } [
+        [ 255.0 v*n float-4 int-4 vconvert ] 4 napply 
+        [ int-4 short-8 vconvert ] 2bi@
+        short-8 uchar-16 vconvert
+    ] data-map( float-4[4] -- uchar-16 )
+] [ bad-data-map-input-length? ] must-fail-with

extra/alien/data/map/map.factor

@@ -0,0 +1,69 @@
+! (c)Joe Groff bsd license
+USING: alien alien.c-types alien.data alien.parser arrays
+byte-arrays fry generalizations kernel lexer locals macros math
+math.ranges parser sequences sequences.private ;
+IN: alien.data.map
+
+ERROR: bad-data-map-input-length byte-length iter-size remainder ;
+
+<PRIVATE
+
+: even-/i ( d d -- q )
+    2dup [ >fixnum ] bi@ /mod
+    [ 2nip ]
+    [ bad-data-map-input-length ] if-zero ; inline
+
+:: data-map-length ( array type count -- byte-length iter-size iter-count )
+    array byte-length >fixnum
+    type heap-size count *
+    2dup even-/i ; inline
+
+: <displaced-direct-array> ( byte-array displacement length type -- direct-array )
+    [ swap <displaced-alien> ] 2dip <c-direct-array> ; inline
+
+:: data-map-loop ( input loop-quot out-bytes-quot in-type in-count out-type out-count -- out-bytes )
+    input in-type in-count data-map-length
+        :> iter-count :> in-size :> in-byte-length
+    input >c-ptr :> in-bytes
+
+    out-count out-type heap-size * :> out-size
+    out-size iter-count * :> out-byte-length
+    out-byte-length out-bytes-quot call :> out-bytes
+
+    0 in-byte-length 1 - >fixnum in-size >fixnum <range>
+    0 out-byte-length 1 - >fixnum out-size >fixnum <range>
+    [| in-base out-base |
+        in-bytes in-base in-count in-type <displaced-direct-array>
+        in-count firstn-unsafe
+        loop-quot call
+        out-bytes out-base out-count out-type <displaced-direct-array>
+        out-count set-firstn-unsafe
+    ] 2each
+    out-bytes ; inline
+
+PRIVATE>
+
+MACRO: data-map ( in-type in-count out-type out-count -- )
+    '[ [ (byte-array) ] _ _ _ _ data-map-loop ] ;
+
+MACRO: data-map! ( in-type in-count out-type out-count -- )
+    '[ swap [ [ nip >c-ptr ] curry _ _ _ _ data-map-loop drop ] keep ] ;
+
+<PRIVATE
+
+: c-type-parsed ( accum c-type -- accum )
+    dup array? [ unclip swap product ] [ 1 ] if
+    [ parsed ] bi@ ;
+
+PRIVATE>
+
+SYNTAX: data-map(
+    scan-c-type c-type-parsed
+    "--" expect scan-c-type c-type-parsed ")" expect
+    \ data-map parsed ;
+
+SYNTAX: data-map!(
+    scan-c-type c-type-parsed
+    "--" expect scan-c-type c-type-parsed ")" expect
+    \ data-map! parsed ;
+

extra/alien/data/map/summary.txt

@@ -0,0 +1 @@
+Combinators for mapping over packed binary data