diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index d6bee78c14..95a52d4655 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays columns kernel math math.bits -math.order math.vectors sequences sequences.private fry ; +USING: accessors arrays columns kernel locals math math.bits +math.functions math.order math.vectors sequences +sequences.private fry ; IN: math.matrices ! Matrices @@ -12,6 +13,70 @@ IN: math.matrices #! Make a nxn identity matrix. dup [ [ = 1 0 ? ] with map ] curry map ; +:: rotation-matrix3 ( axis theta -- matrix ) + theta cos :> c + theta sin :> s + axis first3 :> z :> y :> x + x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array + x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array + x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array + 3array ; + +:: rotation-matrix4 ( axis theta -- matrix ) + theta cos :> c + theta sin :> s + axis first3 :> z :> y :> x + x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array + x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array + x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array + { 0.0 0.0 0.0 1.0 } 4array ; + +:: translation-matrix4 ( offset -- matrix ) + offset first3 :> z :> y :> x + { + { 1.0 0.0 0.0 x } + { 0.0 1.0 0.0 y } + { 0.0 0.0 1.0 z } + { 0.0 0.0 0.0 1.0 } + } ; + +: >scale-factors ( number/sequence -- x y z ) + dup number? [ dup dup ] [ first3 ] if ; + +:: scale-matrix3 ( factors -- matrix ) + factors >scale-factors :> z :> y :> x + { + { x 0.0 0.0 } + { 0.0 y 0.0 } + { 0.0 0.0 z } + } ; + +:: scale-matrix4 ( factors -- matrix ) + factors >scale-factors :> z :> y :> x + { + { x 0.0 0.0 0.0 } + { 0.0 y 0.0 0.0 } + { 0.0 0.0 z 0.0 } + { 0.0 0.0 0.0 1.0 } + } ; + +: ortho-matrix4 ( dim -- matrix ) + [ recip ] map scale-matrix4 ; + +:: frustum-matrix4 ( xy-dim near far -- matrix ) + xy-dim first2 :> y :> x + near x /f :> xf + near y /f :> yf + near far + near far - /f :> zf + 2 near far * * near far - /f :> wf + + { + { xf 0.0 0.0 0.0 } + { 0.0 yf 0.0 0.0 } + { 0.0 0.0 zf wf } + { 0.0 0.0 -1.0 0.0 } + } ; + ! Matrix operations : mneg ( m -- m ) [ vneg ] map ; diff --git a/extra/variants/variants-docs.factor b/extra/variants/variants-docs.factor index 8ba1623f2e..f9b62e11f3 100644 --- a/extra/variants/variants-docs.factor +++ b/extra/variants/variants-docs.factor @@ -13,7 +13,7 @@ VARIANT: class-name . . ; "> } -{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots are able to recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "" } " is defined as well." } +{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "" } " is defined as well." } { $examples { $code <" USING: kernel variants ; IN: scratchpad @@ -26,7 +26,7 @@ VARIANT: list HELP: match { $values { "branches" array } } -{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with an empty stack. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." } +{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." } { $examples { $example <" USING: kernel math prettyprint variants ; IN: scratchpad