Merge branch 'master' of git://factorcode.org/git/factor

basis/math/matrices/matrices.factor

@@ -104,6 +104,8 @@ IN: math.matrices
 : m.v ( m v -- v ) [ v. ] curry map ;
 : m.  ( m m -- m ) flip [ swap m.v ] curry map ;
 
+: m~  ( m m epsilon -- ? ) [ v~ ] curry 2all? ;
+
 : mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
 : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
 : mnorm ( m -- n ) dup mmax abs m/n ;
@@ -139,4 +141,4 @@ PRIVATE>
     
 : m^n ( m n -- n ) 
     make-bits over first length identity-matrix
-    [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
+    [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;

extra/math/matrices/simd/simd-tests.factor

@@ -1,7 +1,8 @@
 ! (c)Joe Groff bsd license
 USING: classes.struct math.matrices.simd math.vectors.simd
-specialized-arrays tools.test ;
+literals math.constants math.functions specialized-arrays tools.test ;
 QUALIFIED-WITH: alien.c-types c
+FROM: math.matrices => m~ ;
 SIMD: c:float
 SPECIALIZED-ARRAY: float-4
 IN: math.matrices.simd.tests
@@ -39,6 +40,19 @@ IN: math.matrices.simd.tests
     }
 ] [ float-4{ 3.0 4.0 2.0 0.0 } translation-matrix4 ] unit-test
 
+[ t ] [
+    float-4{ $[ 1/2. sqrt ] 0.0 $[ 1/2. sqrt ] 0.0 } pi rotation-matrix4
+    S{ matrix4 f
+        float-4-array{
+            float-4{  0.0  0.0  1.0 0.0 }
+            float-4{  0.0 -1.0  0.0 0.0 }
+            float-4{  1.0  0.0  0.0 0.0 }
+            float-4{  0.0  0.0  0.0 1.0 }
+        }
+    }
+    1.0e-7 m~ 
+] unit-test
+
 [
     S{ matrix4 f
         float-4-array{
@@ -169,3 +183,16 @@ IN: math.matrices.simd.tests
     n*m4
 ] unit-test
 
+[
+    S{ matrix4 f
+        float-4-array{
+            float-4{ 1/2. 0.0   0.0    0.0  }
+            float-4{ 0.0  1/2.  0.0    0.0  }
+            float-4{ 0.0  0.0  -6/4. -10/4. }
+            float-4{ 0.0  0.0  -1.0    0.0  }
+        }
+    }
+] [
+    float-4{ 2.0 2.0 0.0 0.0 } 1.0 5.0
+    frustum-matrix4
+] unit-test

extra/math/matrices/simd/simd.factor

@@ -1,5 +1,5 @@
 ! (c)Joe Groff bsd license
-USING: accessors classes.struct kernel locals math
+USING: accessors classes.struct kernel locals math math.functions
 math.matrices.simd math.vectors math.vectors.simd sequences
 sequences.private specialized-arrays typed ;
 QUALIFIED-WITH: alien.c-types c
@@ -157,30 +157,60 @@ TYPED:: translation-matrix4 ( offset: float-4 -- matrix: matrix4 )
 
     c ;
 
-! TYPED:: rotation-matrix4 ( axis: float-4 theta: float -- matrix: matrix4 )
+TYPED:: rotation-matrix4 ( axis: float-4 theta: float -- matrix: matrix4 )
-!     matrix4 (struct) :> c
+    !   x*x + c*(1.0 - x*x)   x*y*(1.0 - c) - s*z   x*z*(1.0 - c) + s*y   0
-!     float-4{  1.0 -1.0  1.0 0.0 } :> triangle-sign
+    !   x*y*(1.0 - c) + s*z   y*y + c*(1.0 - y*y)   y*z*(1.0 - c) - s*x   0
-! 
+    !   x*z*(1.0 - c) - s*y   y*z*(1.0 - c) + s*x   z*z + c*(1.0 - z*z)   0
-!     theta cos float-4-with :> cc
+    !   0                     0                     0                     1
-!     theta sin float-4-with :> ss
+    matrix4 (struct) :> triangle-m
-!     1.0 float-4-with :> ones
+    theta cos :> c
-!     ones cc v- :> 1-c
+    theta sin :> s
-!     axis axis v* :> axis2
-! 
-!     axis2 cc ones axis2 v- v* v+ ones
-!     [ { t t t f } ] 2dip v? :> diagonal
-! 
-!     axis { 0 0 1 3 } vshuffle axis { 1 2 2 3 } vshuffle v* 1-c v* :> triangle-a
-!     ss { 2 1 0 3 } vshuffle triangle-sign * :> triangle-b
-!     triangle-a triangle-b + :> triangle-lo
-!     triangle-a triangle-b - :> triangle-hi
-! 
-!     ... ;
-! !   x*x + c*(1.0 - x*x)   x*y*(1.0 - c) - s*z   x*z*(1.0 - c) + s*y   0
-! !   x*y*(1.0 - c) + s*z   y*y + c*(1.0 - y*y)   y*z*(1.0 - c) - s*x   0
-! !   x*z*(1.0 - c) - s*y   y*z*(1.0 - c) + s*x   z*z + c*(1.0 - z*z)   0
-! !   0                     0                     0                     1
-! 
-! TYPED:: frustum-matrix4 ( xy: float-4 near: float far: float -- matrix: matrix4 )
 
+    float-4{  1.0 -1.0  1.0 0.0 } :> triangle-sign
+
+    c float-4-with :> cc
+    s float-4-with :> ss
+    1.0 float-4-with :> ones
+    ones cc v- :> 1-c
+    axis axis v* :> axis2
+
+    axis2 cc ones axis2 v- v* v+ :> diagonal
+
+    axis { 0 0 1 3 } vshuffle axis { 1 2 2 3 } vshuffle v* 1-c v*
+    { t t t f } vmask :> triangle-a
+    ss { 2 1 0 3 } vshuffle triangle-sign v* :> triangle-b
+    triangle-a triangle-b v+ :> triangle-lo
+    triangle-a triangle-b v- :> triangle-hi
+
+    diagonal scale-matrix4 :> diagonal-m
+    triangle-hi { 3 0 1 3 } vshuffle :> tri1
+    triangle-hi { 3 3 2 3 } vshuffle
+    triangle-lo { 0 3 3 3 } vshuffle v+ :> tri2
+    triangle-lo { 1 2 3 3 } vshuffle :> tri3
+    tri1 triangle-m rows>> set-first
+    tri2 triangle-m rows>> set-second
+    tri3 triangle-m rows>> set-third
+    float-4 new triangle-m rows>> set-fourth
+
+    diagonal-m triangle-m m4+ ;
+
+TYPED:: frustum-matrix4 ( xy: float-4 near: float far: float -- matrix: matrix4 )
+    matrix4 (struct) :> c
+
+    float-4{ 0.0 0.0 -1.0 0.0 } :> c4
+
+    near near near far + 2 near far * * float-4-boa :> num
+    { t t f f } xy near far - float-4-with v? :> denom
+    num denom v/ :> fov
+
+    fov { 0 0 0 0 } vshuffle { t f f f } vmask :> c1
+    fov { 1 1 1 1 } vshuffle { f t f f } vmask :> c2
+    fov { 2 2 2 3 } vshuffle { f f t t } vmask :> c3
+
+    c1 c rows>> set-first
+    c2 c rows>> set-second
+    c3 c rows>> set-third
+    c4 c rows>> set-fourth
+
+    c ;
 

extra/typed/typed.factor

@@ -1,6 +1,6 @@
 ! (c)Joe Groff bsd license
-USING: accessors combinators combinators.short-circuit
+USING: accessors arrays combinators combinators.short-circuit
-definitions effects fry hints kernel kernel.private namespaces
+definitions effects fry hints math kernel kernel.private namespaces
 parser quotations see.private sequences words
 locals locals.definitions locals.parser ;
 IN: typed
@@ -49,8 +49,11 @@ ERROR: output-mismatch-error < type-mismatch-error ;
     [ nip effect-in-types swap '[ _ declare @ ] ]
     [ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ;
 
+: typed-gensym ( parent-word -- word )
+    name>> "( typed " " )" surround f <word> ;
+
 : define-typed-gensym ( word def effect -- gensym )
-    [ 3drop gensym dup ]
+    [ 2drop typed-gensym dup ]
     [ [ swap ] dip typed-gensym-quot ]
     [ 2nip ] 3tri define-declared ;
 
@@ -90,3 +93,4 @@ M: typed-lambda-word definer drop \ TYPED:: \ ; ;
 M: typed-word definition "typed-def" word-prop ;
 M: typed-word declarations. "typed-word" word-prop declarations. ;
 
+M: typed-word subwords "typed-word" word-prop 1array ;