renovate data-map to take any number of inputs/outputs
Joe Groff
parent
d2c1f7c9c1
commit
e35614e805
|
|
@ -40,6 +40,13 @@ IN: alien.data.map.tests
|
|||
] 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
|
||||
|
|
@ -51,4 +58,35 @@ IN: alien.data.map.tests
|
|||
[ 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
|
||||
] unit-test
|
||||
|
||||
: vmerge-transpose ( a b c d -- ac bd ac bd )
|
||||
[ (vmerge) ] bi-curry@ bi* ; inline
|
||||
|
||||
[
|
||||
B{
|
||||
1 10 11 15
|
||||
2 20 22 25
|
||||
3 30 33 35
|
||||
4 40 44 45
|
||||
5 50 55 55
|
||||
6 60 66 65
|
||||
7 70 77 75
|
||||
8 80 88 85
|
||||
9 90 99 95
|
||||
10 100 110 105
|
||||
11 110 121 115
|
||||
12 120 132 125
|
||||
13 130 143 135
|
||||
14 140 154 145
|
||||
15 150 165 155
|
||||
16 160 176 165
|
||||
}
|
||||
] [
|
||||
B{ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 }
|
||||
B{ 10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 }
|
||||
B{ 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 176 }
|
||||
B{ 15 25 35 45 55 65 75 85 95 105 115 125 135 145 155 165 }
|
||||
[ vmerge-transpose vmerge-transpose ]
|
||||
data-map( uchar-16 uchar-16 uchar-16 uchar-16 -- uchar-16[4] )
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,69 +1,112 @@
|
|||
! (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 ;
|
||||
USING: accessors alien alien.c-types alien.data alien.parser arrays
|
||||
byte-arrays combinators effects.parser 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
|
||||
: <displaced-direct-array> ( displacement bytes length type -- direct-array )
|
||||
[ <displaced-alien> ] 2dip <c-direct-array> ; 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
|
||||
TUPLE: data-map-param
|
||||
{ c-type read-only }
|
||||
{ count fixnum read-only }
|
||||
{ orig read-only }
|
||||
{ bytes c-ptr read-only }
|
||||
{ byte-length fixnum read-only }
|
||||
{ iter-length fixnum read-only }
|
||||
{ iter-count fixnum read-only } ;
|
||||
|
||||
: <displaced-direct-array> ( byte-array displacement length type -- direct-array )
|
||||
[ swap <displaced-alien> ] 2dip <c-direct-array> ; inline
|
||||
ERROR: bad-data-map-param param remainder ;
|
||||
|
||||
:: 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
|
||||
M: data-map-param length
|
||||
iter-count>> ; inline
|
||||
|
||||
out-count out-type heap-size * :> out-size
|
||||
out-size iter-count * :> out-byte-length
|
||||
out-byte-length out-bytes-quot call :> out-bytes
|
||||
M: data-map-param nth-unsafe
|
||||
{
|
||||
[ iter-length>> * >fixnum ]
|
||||
[ bytes>> ]
|
||||
[ count>> ]
|
||||
[ c-type>> ]
|
||||
} cleave <displaced-direct-array> ; inline
|
||||
|
||||
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
|
||||
INSTANCE: data-map-param immutable-sequence
|
||||
|
||||
PRIVATE>
|
||||
: c-type-count ( in/out -- c-type count iter-length )
|
||||
dup array? [ unclip swap product >fixnum ] [ 1 ] if
|
||||
2dup swap heap-size * >fixnum ; inline
|
||||
|
||||
MACRO: data-map ( in-type in-count out-type out-count -- )
|
||||
'[ [ (byte-array) ] _ _ _ _ data-map-loop ] ;
|
||||
MACRO:: >param ( in -- quot: ( array -- param ) )
|
||||
in c-type-count :> iter-length :> count :> c-type
|
||||
|
||||
MACRO: data-map! ( in-type in-count out-type out-count -- )
|
||||
'[ swap [ [ nip >c-ptr ] curry _ _ _ _ data-map-loop drop ] keep ] ;
|
||||
[
|
||||
[ c-type count ] dip
|
||||
[ ]
|
||||
[ >c-ptr ]
|
||||
[ byte-length ] tri
|
||||
iter-length
|
||||
2dup /i
|
||||
data-map-param boa
|
||||
] ;
|
||||
|
||||
<PRIVATE
|
||||
MACRO:: alloc-param ( out -- quot: ( len -- param ) )
|
||||
out c-type-count :> iter-length :> count :> c-type
|
||||
|
||||
: c-type-parsed ( accum c-type -- accum )
|
||||
dup array? [ unclip swap product ] [ 1 ] if
|
||||
[ parsed ] bi@ ;
|
||||
[
|
||||
[ c-type count ] dip
|
||||
[
|
||||
iter-length * >fixnum [ (byte-array) dup ] keep
|
||||
iter-length
|
||||
] keep
|
||||
data-map-param boa
|
||||
] ;
|
||||
|
||||
MACRO: unpack-params ( ins -- )
|
||||
[ c-type-count drop nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
|
||||
|
||||
MACRO: pack-params ( outs -- )
|
||||
[ ] [ c-type-count drop nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
|
||||
fry [ call ] compose ;
|
||||
|
||||
:: [data-map] ( ins outs param-quot -- quot )
|
||||
ins length :> #ins
|
||||
outs length :> #outs
|
||||
#ins #outs + :> #params
|
||||
|
||||
[| quot |
|
||||
param-quot call
|
||||
[
|
||||
[ [ ins unpack-params quot call ] #outs ndip outs pack-params ]
|
||||
#params neach
|
||||
] #outs nkeep
|
||||
[ orig>> ] #outs napply
|
||||
] ;
|
||||
|
||||
MACRO: data-map ( ins outs -- )
|
||||
2dup
|
||||
[
|
||||
[ [ '[ _ >param ] ] map '[ _ spread ] ]
|
||||
[ length dup '[ _ ndup _ nmin-length ] compose ] bi
|
||||
]
|
||||
[ [ '[ _ alloc-param ] ] map '[ _ cleave ] ] bi* compose
|
||||
[data-map] ;
|
||||
|
||||
MACRO: data-map! ( ins outs -- )
|
||||
2dup append [ '[ _ >param ] ] map '[ _ spread ] [data-map] ;
|
||||
|
||||
: parse-data-map-effect ( accum -- accum )
|
||||
")" parse-effect
|
||||
[ in>> [ parse-c-type ] map parsed ]
|
||||
[ out>> [ parse-c-type ] map parsed ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: data-map(
|
||||
scan-c-type c-type-parsed
|
||||
"--" expect scan-c-type c-type-parsed ")" expect
|
||||
\ data-map parsed ;
|
||||
parse-data-map-effect \ data-map parsed ;
|
||||
|
||||
SYNTAX: data-map!(
|
||||
scan-c-type c-type-parsed
|
||||
"--" expect scan-c-type c-type-parsed ")" expect
|
||||
\ data-map! parsed ;
|
||||
parse-data-map-effect \ data-map! parsed ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue