Merge branch 'master' of git://factorcode.org/git/factor
commit
66d81e5c32
|
@ -172,7 +172,7 @@ HELP: ndip
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: nkeep
|
HELP: nkeep
|
||||||
{ $values { "quot" quotation } { "n" integer } }
|
{ $values { "n" integer } }
|
||||||
{ $description "A generalization of " { $link keep } " that can work "
|
{ $description "A generalization of " { $link keep } " that can work "
|
||||||
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
||||||
"saved, the quotation called, and the items restored."
|
"saved, the quotation called, and the items restored."
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
! (c)Joe Groff bsd license
|
! (c)Joe Groff bsd license
|
||||||
USING: alien.data.map fry generalizations kernel math.vectors
|
USING: alien.data.map fry generalizations kernel locals math.vectors
|
||||||
math.vectors.conversion math math.vectors.simd
|
math.vectors.conversion math math.vectors.simd
|
||||||
specialized-arrays tools.test ;
|
specialized-arrays tools.test ;
|
||||||
FROM: alien.c-types => uchar short int float ;
|
FROM: alien.c-types => uchar short int float ;
|
||||||
|
@ -19,6 +19,13 @@ IN: alien.data.map.tests
|
||||||
[ dup ] data-map!( int -- float[2] )
|
[ dup ] data-map!( int -- float[2] )
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
:: float-pixels>byte-pixels-locals ( floats scale bias -- bytes )
|
||||||
|
floats [
|
||||||
|
[ scale 255.0 * v*n bias 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 ) ; inline
|
||||||
|
|
||||||
: float-pixels>byte-pixels* ( floats scale bias -- bytes )
|
: float-pixels>byte-pixels* ( floats scale bias -- bytes )
|
||||||
'[
|
'[
|
||||||
[ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
|
[ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
|
||||||
|
@ -29,6 +36,22 @@ IN: alien.data.map.tests
|
||||||
: float-pixels>byte-pixels ( floats -- bytes )
|
: float-pixels>byte-pixels ( floats -- bytes )
|
||||||
1.0 0.0 float-pixels>byte-pixels* ;
|
1.0 0.0 float-pixels>byte-pixels* ;
|
||||||
|
|
||||||
|
[
|
||||||
|
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
|
||||||
|
} 1.0 0.0 float-pixels>byte-pixels-locals
|
||||||
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
B{
|
B{
|
||||||
127 191 255 63
|
127 191 255 63
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! (c)Joe Groff bsd license
|
! (c)Joe Groff bsd license
|
||||||
USING: accessors alien alien.c-types alien.data alien.parser arrays
|
USING: accessors alien alien.c-types alien.data alien.parser arrays
|
||||||
byte-arrays combinators effects.parser fry generalizations kernel
|
byte-arrays combinators effects.parser fry generalizations kernel
|
||||||
lexer locals macros math math.ranges parser sequences sequences.private ;
|
lexer locals macros make math math.ranges parser sequences sequences.private ;
|
||||||
IN: alien.data.map
|
IN: alien.data.map
|
||||||
|
|
||||||
ERROR: bad-data-map-input-length byte-length iter-size remainder ;
|
ERROR: bad-data-map-input-length byte-length iter-size remainder ;
|
||||||
|
@ -39,27 +39,23 @@ INSTANCE: data-map-param immutable-sequence
|
||||||
dup array? [ unclip swap product >fixnum ] [ 1 ] if
|
dup array? [ unclip swap product >fixnum ] [ 1 ] if
|
||||||
2dup swap heap-size * >fixnum ; inline
|
2dup swap heap-size * >fixnum ; inline
|
||||||
|
|
||||||
MACRO:: >param ( in -- quot: ( array -- param ) )
|
MACRO: >param ( in -- quot: ( array -- param ) )
|
||||||
in c-type-count :> iter-length :> count :> c-type
|
c-type-count '[
|
||||||
|
[ _ _ ] dip
|
||||||
[
|
|
||||||
[ c-type count ] dip
|
|
||||||
[ ]
|
[ ]
|
||||||
[ >c-ptr ]
|
[ >c-ptr ]
|
||||||
[ byte-length ] tri
|
[ byte-length ] tri
|
||||||
iter-length
|
_
|
||||||
2dup /i
|
2dup /i
|
||||||
data-map-param boa
|
data-map-param boa
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
MACRO:: alloc-param ( out -- quot: ( len -- param ) )
|
MACRO: alloc-param ( out -- quot: ( len -- param ) )
|
||||||
out c-type-count :> iter-length :> count :> c-type
|
c-type-count dup '[
|
||||||
|
[ _ _ ] dip
|
||||||
[
|
|
||||||
[ c-type count ] dip
|
|
||||||
[
|
[
|
||||||
iter-length * >fixnum [ (byte-array) dup ] keep
|
_ * >fixnum [ (byte-array) dup ] keep
|
||||||
iter-length
|
_
|
||||||
] keep
|
] keep
|
||||||
data-map-param boa
|
data-map-param boa
|
||||||
] ;
|
] ;
|
||||||
|
@ -76,14 +72,17 @@ MACRO: pack-params ( outs -- )
|
||||||
outs length :> #outs
|
outs length :> #outs
|
||||||
#ins #outs + :> #params
|
#ins #outs + :> #params
|
||||||
|
|
||||||
[| quot |
|
[
|
||||||
param-quot call
|
param-quot %
|
||||||
[
|
[
|
||||||
[ [ ins unpack-params quot call ] #outs ndip outs pack-params ]
|
[
|
||||||
#params neach
|
[ ins , \ unpack-params , \ @ , ] [ ] make ,
|
||||||
] #outs nkeep
|
#outs , \ ndip , outs , \ pack-params ,
|
||||||
[ orig>> ] #outs napply
|
] [ ] make ,
|
||||||
] ;
|
#params , \ neach ,
|
||||||
|
] [ ] make , #outs , \ nkeep ,
|
||||||
|
[ orig>> ] , #outs , \ napply ,
|
||||||
|
] [ ] make fry \ call suffix ;
|
||||||
|
|
||||||
MACRO: data-map ( ins outs -- )
|
MACRO: data-map ( ins outs -- )
|
||||||
2dup
|
2dup
|
||||||
|
|
Loading…
Reference in New Issue