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 ;