vectored struct functor

extra/classes/struct/vectored/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/classes/struct/vectored/summary.txt

@@ -0,0 +1 @@
+Derive a tuple of specialized arrays from a struct class

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 <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

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
+
+<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 ;