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

Clean up cross product

db4
Slava Pestov 2008-03-13 03:36:13 -05:00
parent f341b2a02c
commit 37d5ca384e
1 changed files with 13 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
extra/math/matrices/matrices.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions USING: arrays kernel sequences math math.functions
math.vectors ; math.vectors combinators.cleave ;
IN: math.matrices IN: math.matrices
! Matrices ! Matrices
@ -33,23 +33,22 @@ IN: math.matrices
: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ; : mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ; : mnorm ( m -- n ) dup mmax abs m/n ;
: cross-i ( vec1 vec2 -- i ) <PRIVATE
over third over second * >r
swap second swap third * r> - ;
: cross-j ( vec1 vec2 -- j ) : x first ; inline
over first over third * >r : y second ; inline
swap third swap first * r> - ; : z third ; inline
: cross-k ( vec1 vec2 -- k ) : i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
over first over second * >r : j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
swap second swap first * r> - ; : k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
: cross ( vec1 vec2 -- vec3 ) PRIVATE>
[ cross-i ] 2keep [ cross-j ] 2keep cross-k 3array ;
: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
: proj ( v u -- w ) : proj ( v u -- w )
[ [ v. ] keep norm-sq / ] keep n*v ; [ [ v. ] [ norm-sq ] bi / ] keep n*v ;
: (gram-schmidt) ( v seq -- newseq ) : (gram-schmidt) ( v seq -- newseq )
[ dupd proj v- ] each ; [ dupd proj v- ] each ;