--- /dev/null
+! (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 <vectored-foo> [ 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
--- /dev/null
+! (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
+
+<PRIVATE
+
+: array-class-of ( type -- array-type )
+ [ define-array-vocab ] [ name>> "-array" append swap lookup ] bi ;
+: <array-class>-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: <vectored-slots> ( struct-class -- quot: ( n -- slots... ) )
+ struct-slots [ type>> <array-class>-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 _ <struct-boa> ] ;
+
+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
+
+<vectored-T> DEFINES <vectored-${T}>
+(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
+
+: <vectored-T> ( n -- vectored-T )
+ T <vectored-slots> 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 ;