diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 73f8410790..cb2c40ca0a 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -30,7 +30,9 @@ IN: generalizations.tests [ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer +[ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test +{ 2 1 2 3 4 5 } [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test [ "HELLO" ] [ "hello" [ >upper ] 1 napply ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 9354b89974..2ae076655e 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -77,8 +77,8 @@ MACRO: ntuck ( n -- ) MACRO: ndip ( n -- ) [ [ dip ] curry ] n*quot [ call ] compose ; -MACRO: nkeep ( quot n -- ) - tuck '[ _ ndup _ _ ndip ] ; +MACRO: nkeep ( n -- ) + dup '[ [ _ ndup ] dip _ ndip ] ; MACRO: ncurry ( n -- ) [ curry ] n*quot ; diff --git a/extra/alien/data/map/map-tests.factor b/extra/alien/data/map/map-tests.factor index e4e1aa6d18..f8c7cb0914 100644 --- a/extra/alien/data/map/map-tests.factor +++ b/extra/alien/data/map/map-tests.factor @@ -1,6 +1,6 @@ ! (c)Joe Groff bsd license -USING: alien.data.map generalizations kernel math.vectors -math.vectors.conversion math.vectors.simd +USING: alien.data.map fry generalizations kernel math.vectors +math.vectors.conversion math math.vectors.simd specialized-arrays tools.test ; FROM: alien.c-types => uchar short int float ; SIMDS: float int short uchar ; @@ -19,6 +19,16 @@ IN: alien.data.map.tests [ dup ] data-map!( int -- float[2] ) ] unit-test +: float-pixels>byte-pixels* ( floats scale bias -- bytes ) + '[ + [ _ 255.0 * v*n _ 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 -- bytes ) + 1.0 0.0 float-pixels>byte-pixels* ; + [ B{ 127 191 255 63 @@ -32,11 +42,7 @@ IN: alien.data.map.tests 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 ) + } float-pixels>byte-pixels ] unit-test [ @@ -63,6 +69,10 @@ IN: alien.data.map.tests : vmerge-transpose ( a b c d -- ac bd ac bd ) [ (vmerge) ] bi-curry@ bi* ; inline +: fold-rgba-planes ( r g b a -- rgba ) + [ vmerge-transpose vmerge-transpose ] + data-map( uchar-16 uchar-16 uchar-16 uchar-16 -- uchar-16[4] ) ; + [ B{ 1 10 11 15 @@ -87,6 +97,5 @@ IN: alien.data.map.tests 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] ) + fold-rgba-planes ] unit-test diff --git a/extra/classes/struct/vectored/authors.txt b/extra/classes/struct/vectored/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/classes/struct/vectored/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/classes/struct/vectored/summary.txt b/extra/classes/struct/vectored/summary.txt new file mode 100644 index 0000000000..d4e5fc3ec4 --- /dev/null +++ b/extra/classes/struct/vectored/summary.txt @@ -0,0 +1 @@ +Derive a tuple of specialized arrays from a struct class diff --git a/extra/classes/struct/vectored/vectored-tests.factor b/extra/classes/struct/vectored/vectored-tests.factor new file mode 100644 index 0000000000..1b3aa86eff --- /dev/null +++ b/extra/classes/struct/vectored/vectored-tests.factor @@ -0,0 +1,73 @@ +! (c)2009 Joe Groff bsd license +USING: accessors alien.c-types classes.struct classes.struct.vectored +kernel sequences specialized-arrays tools.test ; +SPECIALIZED-ARRAYS: int ushort float ; +IN: classes.struct.vectored.tests + +STRUCT: foo + { x int } + { y float } + { z ushort } + { w ushort } ; + +SPECIALIZED-ARRAY: foo +VECTORED-STRUCT: foo + +[ + T{ vectored-foo + { x int-array{ 0 1 0 0 } } + { y float-array{ 0.0 2.0 0.0 0.0 } } + { z ushort-array{ 0 3 0 0 } } + { w ushort-array{ 0 4 0 0 } } + } +] [ S{ foo f 1 2.0 3 4 } 4 [ set-second ] keep ] unit-test + +[ + T{ vectored-foo + { x int-array{ 0 1 2 3 } } + { y float-array{ 0.0 0.5 1.0 1.5 } } + { z ushort-array{ 10 20 30 40 } } + { w ushort-array{ 15 25 35 45 } } + } +] [ + foo-array{ + S{ foo { x 0 } { y 0.0 } { z 10 } { w 15 } } + S{ foo { x 1 } { y 0.5 } { z 20 } { w 25 } } + S{ foo { x 2 } { y 1.0 } { z 30 } { w 35 } } + S{ foo { x 3 } { y 1.5 } { z 40 } { w 45 } } + } struct-transpose +] unit-test + +[ + foo-array{ + S{ foo { x 0 } { y 0.0 } { z 10 } { w 15 } } + S{ foo { x 1 } { y 0.5 } { z 20 } { w 25 } } + S{ foo { x 2 } { y 1.0 } { z 30 } { w 35 } } + S{ foo { x 3 } { y 1.5 } { z 40 } { w 45 } } + } +] [ + T{ vectored-foo + { x int-array{ 0 1 2 3 } } + { y float-array{ 0.0 0.5 1.0 1.5 } } + { z ushort-array{ 10 20 30 40 } } + { w ushort-array{ 15 25 35 45 } } + } struct-transpose +] unit-test + +[ 30 ] [ + T{ vectored-foo + { x int-array{ 0 1 2 3 } } + { y float-array{ 0.0 0.5 1.0 1.5 } } + { z ushort-array{ 10 20 30 40 } } + { w ushort-array{ 15 25 35 45 } } + } third z>> +] unit-test + +[ S{ foo { x 2 } { y 1.0 } { z 30 } { w 35 } } ] [ + T{ vectored-foo + { x int-array{ 0 1 2 3 } } + { y float-array{ 0.0 0.5 1.0 1.5 } } + { z ushort-array{ 10 20 30 40 } } + { w ushort-array{ 15 25 35 45 } } + } third vectored-element> +] unit-test diff --git a/extra/classes/struct/vectored/vectored.factor b/extra/classes/struct/vectored/vectored.factor new file mode 100644 index 0000000000..16ff95b1c0 --- /dev/null +++ b/extra/classes/struct/vectored/vectored.factor @@ -0,0 +1,117 @@ +! (c)2009 Joe Groff bsd license +USING: accessors classes.struct classes.tuple combinators fry +functors kernel locals macros math parser quotations sequences +sequences.private slots specialized-arrays words ; +IN: classes.struct.vectored + +> "-array" append swap lookup ] bi ; +: -of ( type -- array-type ) + [ define-array-vocab ] [ name>> "<" "-array>" surround swap lookup ] bi ; +: (array-class)-of ( type -- array-type ) + [ define-array-vocab ] [ name>> "(" "-array)" surround swap lookup ] bi ; + +: >vectored-slot ( struct-slot offset -- tuple-slot ) + { + [ drop name>> ] + [ nip ] + [ drop type>> array-class-of dup initial-value ] + [ 2drop t ] + } 2cleave slot-spec boa ; + +MACRO: first-slot ( struct-class -- quot: ( struct -- value ) ) + struct-slots first name>> reader-word 1quotation ; + +MACRO: set-vectored-nth ( struct-class -- quot: ( value i vector -- ) ) + struct-slots [ + name>> reader-word 1quotation dup + '[ _ [ ] _ tri* set-nth-unsafe ] + ] map '[ _ 3cleave ] ; + +MACRO: ( struct-class -- quot: ( n -- slots... ) ) + struct-slots [ type>> -of 1quotation ] map + '[ _ cleave ] ; + +MACRO: (vectored-slots) ( struct-class -- quot: ( n -- slots... ) ) + struct-slots [ type>> (array-class)-of 1quotation ] map + '[ _ cleave ] ; + +MACRO: (vectored-element>) ( struct-class -- quot: ( elt -- struct ) ) + [ struct-slots [ name>> reader-word 1quotation ] map ] keep + '[ _ cleave _ ] ; + +SLOT: (n) +SLOT: (vectored) + +FUNCTOR: define-vectored-accessors ( S>> (>>S) T -- ) + +WHERE + +M: T S>> + [ (n)>> ] [ (vectored)>> S>> ] bi nth-unsafe ; inline +M: T (>>S) + [ (n)>> ] [ (vectored)>> S>> ] bi set-nth-unsafe ; inline + +;FUNCTOR + +PRIVATE> + +GENERIC: struct-transpose ( structstruct -- ssttrruucctt ) +GENERIC: vectored-element> ( elt -- struct ) + +FUNCTOR: define-vectored-struct ( T -- ) + +T-array [ T array-class-of ] + +vectored-T DEFINES-CLASS vectored-${T} +vectored-T-element DEFINES-CLASS vectored-${T}-element + + DEFINES +(vectored-T) DEFINES (vectored-${T}) + +WHERE + +vectored-T tuple T struct-slots [ >vectored-slot ] map-index define-tuple-class + +TUPLE: vectored-T-element + { (n) fixnum read-only } + { (vectored) vectored-T read-only } ; + +T struct-slots [ + name>> [ reader-word ] [ writer-word ] bi + vectored-T-element define-vectored-accessors +] each + +M: vectored-T-element vectored-element> + T (vectored-element>) ; inline + +M: vectored-T nth-unsafe + vectored-T-element boa ; inline + +M: vectored-T length + T first-slot length ; inline + +M: vectored-T set-nth-unsafe + T set-vectored-nth ; inline + +INSTANCE: vectored-T sequence + +: ( n -- vectored-T ) + T vectored-T boa ; inline + +: (vectored-T) ( n -- vectored-T ) + T (vectored-slots) vectored-T boa ; inline + +M: vectored-T struct-transpose + [ vectored-element> ] T-array new map-as ; inline + +M: T-array struct-transpose + dup length [ nip iota ] [ drop ] [ nip (vectored-T) ] 2tri + [ [ [ nth ] [ set-nth ] bi-curry* bi ] 2curry each ] keep ; inline + +;FUNCTOR + +SYNTAX: VECTORED-STRUCT: + scan-word define-vectored-struct ; diff --git a/extra/math/matrices/simd/simd-tests.factor b/extra/math/matrices/simd/simd-tests.factor index 965c2bddb5..25482c8e1e 100644 --- a/extra/math/matrices/simd/simd-tests.factor +++ b/extra/math/matrices/simd/simd-tests.factor @@ -229,3 +229,13 @@ IN: math.matrices.simd.tests float-4{ 2.0 2.0 0.0 0.0 } 1.0 5.0 frustum-matrix4 ] unit-test + +[ float-4{ 3.0 4.0 5.0 1.0 } ] +[ float-4{ 1.0 1.0 1.0 1.0 } translation-matrix4 float-4{ 2.0 3.0 4.0 1.0 } m4.v ] unit-test + +[ float-4{ 2.0 2.5 3.0 1.0 } ] +[ + float-4{ 1.0 1.0 1.0 1.0 } translation-matrix4 + float-4{ 0.5 0.5 0.5 1.0 } scale-matrix4 m4. + float-4{ 2.0 3.0 4.0 1.0 } m4.v +] unit-test