steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2009-07-02 23:09:58 -05:00
parent 788ea7790b ad2bffd4da
commit 92b7f32aaa
2 changed files with 69 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
basis/math/matrices/matrices.factor
View File

@ -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 ;

4
extra/variants/variants-docs.factor
View File

@ -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 "<tuple>" } " 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 "<tuple>" } " 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