diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 4ba8e1d3d9..4a76a20598 100644 --- a/basis/math/matrices/matrices.factor +++ b/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 ; \ No newline at end of file + [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ; diff --git a/extra/math/matrices/simd/simd-tests.factor b/extra/math/matrices/simd/simd-tests.factor index 949ff9e667..5bd61adefd 100644 --- a/extra/math/matrices/simd/simd-tests.factor +++ b/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 diff --git a/extra/math/matrices/simd/simd.factor b/extra/math/matrices/simd/simd.factor index c5113d4502..f3be087980 100644 --- a/extra/math/matrices/simd/simd.factor +++ b/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 ) -! matrix4 (struct) :> c -! float-4{ 1.0 -1.0 1.0 0.0 } :> triangle-sign -! -! theta cos float-4-with :> cc -! theta sin 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+ 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 ) +TYPED:: rotation-matrix4 ( axis: float-4 theta: float -- matrix: matrix4 ) + ! 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 + matrix4 (struct) :> triangle-m + theta cos :> c + theta sin :> s + 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 ; diff --git a/extra/typed/typed.factor b/extra/typed/typed.factor index f9dbbad61a..3060adea54 100644 --- a/extra/typed/typed.factor +++ b/extra/typed/typed.factor @@ -1,6 +1,6 @@ ! (c)Joe Groff bsd license -USING: accessors combinators combinators.short-circuit -definitions effects fry hints kernel kernel.private namespaces +USING: accessors arrays combinators combinators.short-circuit +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 ; + : 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 ;