1 ! (c)Joe Groff bsd license
2 USING: accessors classes.struct kernel locals math
3 math.matrices.simd math.vectors math.vectors.simd sequences
4 sequences.private specialized-arrays typed ;
5 QUALIFIED-WITH: alien.c-types c
7 SPECIALIZED-ARRAY: float-4
13 INSTANCE: matrix4 immutable-sequence
15 M: matrix4 length drop 4 ; inline
16 M: matrix4 nth-unsafe rows>> nth-unsafe ; inline
17 M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
20 :: 2map-rows ( a b quot -- c )
38 c2 c rows>> set-second
40 c4 c rows>> set-fourth
44 :: map-rows ( a quot -- c )
58 c2 c rows>> set-second
60 c4 c rows>> set-fourth
66 TYPED: m4+ ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v+ ] 2map-rows ;
67 TYPED: m4- ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v- ] 2map-rows ;
68 TYPED: m4* ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v* ] 2map-rows ;
69 TYPED: m4/ ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v/ ] 2map-rows ;
71 TYPED: m4*n ( a: matrix4 b: float -- c: matrix4 ) [ v*n ] curry map-rows ;
72 TYPED: m4/n ( a: matrix4 b: float -- c: matrix4 ) [ v/n ] curry map-rows ;
73 TYPED: n*m4 ( a: matrix4 b: float -- c: matrix4 ) [ n*v ] with map-rows ;
74 TYPED: n/m4 ( a: matrix4 b: float -- c: matrix4 ) [ n/v ] with map-rows ;
76 TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
88 a1 { 0 0 0 0 } vshuffle b1 v* :> c1a
89 a2 { 0 0 0 0 } vshuffle b1 v* :> c2a
90 a3 { 0 0 0 0 } vshuffle b1 v* :> c3a
91 a4 { 0 0 0 0 } vshuffle b1 v* :> c4a
93 a1 { 1 1 1 1 } vshuffle b2 v* c1a v+ :> c1b
94 a2 { 1 1 1 1 } vshuffle b2 v* c2a v+ :> c2b
95 a3 { 1 1 1 1 } vshuffle b2 v* c3a v+ :> c3b
96 a4 { 1 1 1 1 } vshuffle b2 v* c4a v+ :> c4b
98 a1 { 2 2 2 2 } vshuffle b3 v* c1b v+ :> c1c
99 a2 { 2 2 2 2 } vshuffle b3 v* c2b v+ :> c2c
100 a3 { 2 2 2 2 } vshuffle b3 v* c3b v+ :> c3c
101 a4 { 2 2 2 2 } vshuffle b3 v* c4b v+ :> c4c
103 a1 { 3 3 3 3 } vshuffle b4 v* c1c v+ :> c1
104 a2 { 3 3 3 3 } vshuffle b4 v* c2c v+ :> c2
105 a3 { 3 3 3 3 } vshuffle b4 v* c3c v+ :> c3
106 a4 { 3 3 3 3 } vshuffle b4 v* c4c v+ :> c4
108 c1 c rows>> set-first
109 c2 c rows>> set-second
110 c3 c rows>> set-third
111 c4 c rows>> set-fourth
115 CONSTANT: identity-matrix4
118 float-4{ 1.0 0.0 0.0 0.0 }
119 float-4{ 0.0 1.0 0.0 0.0 }
120 float-4{ 0.0 0.0 1.0 0.0 }
121 float-4{ 0.0 0.0 0.0 1.0 }
125 TYPED:: scale-matrix4 ( factors: float-4 -- matrix: matrix4 )
126 matrix4 (struct) :> c
128 factors { t t t f } vmask :> factors'
129 factors' { 0 3 3 3 } vshuffle :> c1
130 factors' { 3 1 3 3 } vshuffle :> c2
131 factors' { 3 3 2 3 } vshuffle :> c3
132 float-4{ 0.0 0.0 0.0 1.0 } :> c4
134 c1 c rows>> set-first
135 c2 c rows>> set-second
136 c3 c rows>> set-third
137 c4 c rows>> set-fourth
141 : ortho-matrix4 ( factors -- matrix )
142 float-4{ 1.0 1.0 1.0 1.0 } swap v/ scale-matrix4 ; inline
144 TYPED:: translation-matrix4 ( offset: float-4 -- matrix: matrix4 )
145 matrix4 (struct) :> c
147 float-4{ 0.0 0.0 0.0 1.0 } :> c4
148 { t t t f } offset c4 v? :> offset'
149 offset' { 3 3 3 0 } vshuffle { t f f t } vmask :> c1
150 offset' { 3 3 3 1 } vshuffle { f t f t } vmask :> c2
151 offset' { 3 3 3 2 } vshuffle { f f t t } vmask :> c3
153 c1 c rows>> set-first
154 c2 c rows>> set-second
155 c3 c rows>> set-third
156 c4 c rows>> set-fourth