factor: trim using lists

[factor.git] / extra / jamshred / oint / oint.factor

diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor
index d50a93a3d2473500d1e155af1b86251af0e8e915..2e772c2f22cc73289590700184357dcfd15cf95d 100644 (file)
--- a/extra/jamshred/oint/oint.factor
+++ b/extra/jamshred/oint/oint.factor
@@ -1,6 +1,7 @@
-! Copyright (C) 2007 Alex Chapman
+! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+USING: accessors arrays kernel math math.functions math.vectors
+random sequences ;
 IN: jamshred.oint
 
 ! An oint is a point with three linearly independent unit vectors
@@ -12,7 +13,36 @@ TUPLE: oint location forward up left ;
 C: <oint> oint
 
 : rotation-quaternion ( theta axis -- quaternion )
-    swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
+    swap 2 / dup cos swap sin rot n*v first3 rect> [ rect> ] dip 2array ;
+
+<PRIVATE
+
+! inline old math.quaternions to get this to work, eww.
+
+: ** ( x y -- z ) conjugate * ; inline
+
+: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
+
+: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
+
+: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
+
+: q* ( u v -- u*v )
+    [ q*a ] [ q*b ] 2bi 2array ;
+
+: v>q ( v -- q )
+    first3 rect> [ 0 swap rect> ] dip 2array ;
+
+: q>v ( q -- v )
+    first2 [ imaginary-part ] dip >rect 3array ;
+
+: qconjugate ( u -- u' )
+    first2 [ conjugate ] [ neg  ] bi* 2array ;
+
+: qrecip ( u -- 1/u )
+    qconjugate dup norm-sq v/n ;
+
+PRIVATE>
 
 : rotate-vector ( q qrecip v -- v )
     v>q swap q* q* q>v ;
@@ -33,14 +63,17 @@ C: <oint> oint
     over forward>> rotate-oint ;
 
 : random-float+- ( n -- m )
-    #! find a random float between -n/2 and n/2
-    dup 10000 * >fixnum random 10000 / swap 2 / - ;
+    ! find a random float between -n/2 and n/2
+    dup 10000 * >integer random 10000 / swap 2 / - ;
 
 : random-turn ( oint theta -- )
     2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
 
+: location+ ( v oint -- )
+    [ location>> v+ ] [ location<< ] bi ;
+
 : go-forward ( distance oint -- )
-    [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
+    [ forward>> n*v ] [ location+ ] bi ;
 
 : distance-vector ( oint oint -- vector )
     [ location>> ] bi@ swap v- ;
@@ -49,16 +82,22 @@ C: <oint> oint
     distance-vector norm ;
 
 : scalar-projection ( v1 v2 -- n )
-    #! the scalar projection of v1 onto v2
-    tuck v. swap norm / ;
+    ! the scalar projection of v1 onto v2
+    [ vdot ] [ norm ] bi / ;
 
 : proj-perp ( u v -- w )
     dupd proj v- ;
 
 : perpendicular-distance ( oint oint -- distance )
-    tuck distance-vector swap 2dup left>> scalar-projection abs
+    [ distance-vector ] keep 2dup left>> scalar-projection abs
     -rot up>> scalar-projection abs + ;
 
 :: reflect ( v n -- v' )
-    #! bounce v on a surface with normal n
-    v v n v. n n v. / 2 * n n*v v- ;
+    ! bounce v on a surface with normal n
+    v v n vdot n n vdot / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+    over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+    [ location>> ] bi@ half-way ;