extra/classes/struct/vectored/vectored.factor

   1 ! Copyright (C) 2009 Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors classes.struct classes.tuple combinators
   4 functors kernel math parser quotations sequences
   5 sequences.private slots specialized-arrays words ;
   6 IN: classes.struct.vectored
   7
   8 <PRIVATE
   9
  10 : array-class-of ( type -- array-type )
  11     [ define-array-vocab ] [ name>> "-array" append swap lookup-word ] bi ;
  12 : <array-class>-of ( type -- array-type )
  13     [ define-array-vocab ] [ name>> "<" "-array>" surround swap lookup-word ] bi ;
  14 : (array-class)-of ( type -- array-type )
  15     [ define-array-vocab ] [ name>> "(" "-array)" surround swap lookup-word ] bi ;
  16
  17 : >vectored-slot ( struct-slot offset -- tuple-slot )
  18     {
  19         [ drop name>> ]
  20         [ nip ]
  21         [ drop type>> array-class-of dup initial-value drop ]
  22         [ 2drop t ]
  23     } 2cleave slot-spec boa ;
  24
  25 MACRO: first-slot ( struct-class -- quot: ( struct -- value ) )
  26     struct-slots first name>> reader-word 1quotation ;
  27
  28 MACRO: set-vectored-nth ( struct-class -- quot: ( value i vector -- ) )
  29     struct-slots [
  30         name>> reader-word 1quotation dup
  31         '[ _ [ ] _ tri* set-nth-unsafe ]
  32     ] map '[ _ 3cleave ] ;
  33
  34 MACRO: <vectored-slots> ( struct-class -- quot: ( n -- slots... ) )
  35     struct-slots [ type>> <array-class>-of 1quotation ] map
  36     '[ _ cleave ] ;
  37
  38 MACRO: (vectored-slots) ( struct-class -- quot: ( n -- slots... ) )
  39     struct-slots [ type>> (array-class)-of 1quotation ] map
  40     '[ _ cleave ] ;
  41
  42 MACRO: (vectored-element>) ( struct-class -- quot: ( elt -- struct ) )
  43     [ struct-slots [ name>> reader-word 1quotation ] map ] keep
  44     '[ _ cleave _ boa ] ;
  45
  46 SLOT: (n)
  47 SLOT: (vectored)
  48
  49 <FUNCTOR: define-vectored-accessors ( S>> S<< T -- )
  50
  51 WHERE
  52
  53 M: T S>>
  54     [ (n)>> ] [ (vectored)>> S>> ] bi nth-unsafe ; inline
  55 M: T S<<
  56     [ (n)>> ] [ (vectored)>> S>> ] bi set-nth-unsafe ; inline
  57
  58 ;FUNCTOR>
  59
  60 PRIVATE>
  61
  62 GENERIC: struct-transpose ( structstruct -- ssttrruucctt )
  63 GENERIC: vectored-element> ( elt -- struct )
  64
  65 <FUNCTOR: define-vectored-struct ( T -- )
  66
  67 T-array [ T array-class-of ]
  68
  69 vectored-T         DEFINES-CLASS vectored-${T}
  70 vectored-T-element DEFINES-CLASS vectored-${T}-element
  71
  72 <vectored-T>       DEFINES <vectored-${T}>
  73 (vectored-T)       DEFINES (vectored-${T})
  74
  75 WHERE
  76
  77 vectored-T tuple T struct-slots [ >vectored-slot ] map-index define-tuple-class
  78
  79 TUPLE: vectored-T-element
  80     { (n)        fixnum     read-only }
  81     { (vectored) vectored-T read-only } ;
  82
  83 T struct-slots [
  84     name>> [ reader-word ] [ writer-word ] bi
  85     vectored-T-element define-vectored-accessors
  86 ] each
  87
  88 M: vectored-T-element vectored-element>
  89     T (vectored-element>) ; inline
  90
  91 M: vectored-T nth-unsafe
  92     vectored-T-element boa ; inline
  93
  94 M: vectored-T length
  95     T first-slot length ; inline
  96
  97 M: vectored-T set-nth-unsafe
  98     T set-vectored-nth ; inline
  99
 100 INSTANCE: vectored-T sequence
 101
 102 : <vectored-T> ( n -- vectored-T )
 103     T <vectored-slots> vectored-T boa ; inline
 104
 105 : (vectored-T) ( n -- vectored-T )
 106     T (vectored-slots) vectored-T boa ; inline
 107
 108 M: vectored-T struct-transpose
 109     [ vectored-element> ] T-array new map-as ; inline
 110
 111 M: T-array struct-transpose
 112     dup length [ nip <iota> ] [ drop ] [ nip (vectored-T) ] 2tri
 113     [ [ [ nth ] [ set-nth ] bi-curry* bi ] 2curry each ] keep ; inline
 114
 115 ;FUNCTOR>
 116
 117 SYNTAX: VECTORED-STRUCT:
 118     scan-word define-vectored-struct ;