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

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -136,8 +136,6 @@ M: object xyz ;
     \ +-integer-fixnum inlined?
 ] unit-test
 
-[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
-
 [ t ] [
     [
         [ no-cond ] 1

basis/math/vectors/vectors.factor

@@ -62,6 +62,9 @@ IN: math.vectors
     [ first vnlerp ] [ second vnlerp ] bi-curry
     [ 2bi@ ] [ call ] bi* ;
 
+: v~ ( a b epsilon -- ? )
+    [ ~ ] curry 2all? ;
+
 HINTS: vneg { array } ;
 HINTS: norm-sq { array } ;
 HINTS: norm { array } ;

extra/math/affine-transforms/affine-transforms.factor

@@ -65,9 +65,6 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0
     } 2cleave
     [ [ 2array ] 2bi@ ] dip <affine-transform> ;
 
-: v~ ( a b epsilon -- ? )
-    [ ~ ] curry 2all? ;
-
 : a~ ( a b epsilon -- ? )
     {
         [ [ [ x>>      ] bi@ ] dip v~ ]

extra/math/vectors/homogeneous/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/math/vectors/homogeneous/homogeneous-tests.factor

@@ -0,0 +1,15 @@
+! (c)2009 Joe Groff bsd license
+USING: math.vectors.homogeneous tools.test ;
+IN: math.vectors.homogeneous.tests
+
+[ { 1.0 2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h+ ] unit-test
+[ { 1.0 -2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h- ] unit-test
+[ { 2.0 2.0 2.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 2.0 } h+ ] unit-test
+[ { 1.0 2.0 2.0 } ] [ { 1.0 0.0 2.0 } { 0.0 2.0 2.0 } h+ ] unit-test
+
+[ { 2.0 4.0 2.0 } ] [ 2.0 { 1.0 2.0 2.0 } n*h ] unit-test
+[ { 2.0 4.0 2.0 } ] [ { 1.0 2.0 2.0 } 2.0 h*n ] unit-test
+
+[ { 0.5 1.5 } ] [ { 1.0 3.0 2.0 } h>v ] unit-test
+[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test
+[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test

extra/math/vectors/homogeneous/homogeneous.factor

@@ -0,0 +1,36 @@
+! (c)2009 Joe Groff bsd license
+USING: kernel math math.vectors sequences ;
+IN: math.vectors.homogeneous
+
+: (homogeneous-xyz) ( h -- xyz )
+    1 head* ; inline
+: (homogeneous-w) ( h -- w )
+    peek ; inline
+
+: h+ ( a b -- c )
+    2dup [ (homogeneous-w) ] bi@ over =
+    [ [ [ (homogeneous-xyz) ] bi@ v+ ] dip suffix ] [ 
+        drop
+        [ [ (homogeneous-xyz) ] [ (homogeneous-w)   ] bi* v*n    ]
+        [ [ (homogeneous-w)   ] [ (homogeneous-xyz) ] bi* n*v v+ ]
+        [ [ (homogeneous-w)   ] [ (homogeneous-w)   ] bi* * suffix ] 2tri
+    ] if ;
+
+: n*h ( n h -- nh ) 
+    [ (homogeneous-xyz) n*v ] [ (homogeneous-w) suffix ] bi ;
+
+: h*n ( h n -- nh )
+    swap n*h ;
+
+: hneg ( h -- -h )
+    -1.0 swap n*h ;
+
+: h- ( a b -- c )
+    hneg h+ ;
+
+: v>h ( v -- h )
+    1.0 suffix ;
+
+: h>v ( h -- v )
+    [ (homogeneous-xyz) ] [ (homogeneous-w) ] bi v/n ;
+

extra/math/vectors/homogeneous/summary.txt

@@ -0,0 +1 @@
+Homogeneous coordinate math

extra/nurbs/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/nurbs/nurbs-tests.factor

@@ -0,0 +1,32 @@
+! (c)2009 Joe Groff bsd license
+USING: literals math math.functions math.vectors namespaces
+nurbs tools.test ;
+IN: nurbs.tests
+
+SYMBOL: test-nurbs
+
+CONSTANT:  √2/2 $[ 0.5 sqrt     ]
+CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
+
+! unit circle as NURBS
+3 {
+    { 1.0 0.0 1.0 }
+    { $ √2/2 $ √2/2 $ √2/2 }
+    { 0.0 1.0 1.0 }
+    { $ -√2/2 $ √2/2 $ √2/2 }
+    { -1.0 0.0 1.0 }
+    { $ -√2/2 $ -√2/2 $ √2/2 }
+    { 0.0 -1.0 1.0 }
+    { $ √2/2 $ -√2/2 $ √2/2 }
+    { 1.0 0.0 1.0 }
+} { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set
+
+[ t ] [ test-nurbs get 0.0   eval-nurbs {   1.0   0.0 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.25  eval-nurbs {   0.0   1.0 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.5   eval-nurbs {  -1.0   0.0 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.75  eval-nurbs {   0.0  -1.0 } 0.00001 v~ ] unit-test
+
+[ t ] [ test-nurbs get 0.125 eval-nurbs { $  √2/2 $  √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $  √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.875 eval-nurbs { $  √2/2 $ -√2/2 } 0.00001 v~ ] unit-test

extra/nurbs/nurbs.factor

@@ -0,0 +1,73 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays grouping kernel locals math math.order
+math.ranges math.vectors math.vectors.homogeneous sequences
+specialized-arrays.float ;
+IN: nurbs
+
+TUPLE: nurbs-curve
+    { order integer }
+    control-points 
+    knots
+    (knot-constants) ;
+
+: ?recip ( n -- 1/n )
+    dup zero? [ recip ] unless ;
+
+:: order-index-knot-constants ( curve order index -- knot-constants )
+    curve knots>> :> knots
+    index order 1 - + knots nth :> knot_i+k-1
+    index             knots nth :> knot_i
+    index order +     knots nth :> knot_i+k
+    index 1 +         knots nth :> knot_i+1
+
+    knot_i+k-1 knot_i   - ?recip :> c1
+    knot_i+1   knot_i+k - ?recip :> c2
+
+    knot_i   c1 * neg :> c3
+    knot_i+k c2 * neg :> c4
+
+    c1 c2 c3 c4 float-array{ } 4sequence ;
+
+: order-knot-constants ( curve order -- knot-constants )
+    2dup [ knots>> length ] dip - iota
+    [ order-index-knot-constants ] with with map ;
+
+: knot-constants ( curve -- knot-constants )
+    2 over order>> [a,b]
+    [ order-knot-constants ] with map ;
+
+: update-knots ( curve -- curve )
+    dup knot-constants >>(knot-constants) ;
+
+: <nurbs-curve> ( order control-points knots -- nurbs-curve )
+    f nurbs-curve boa update-knots ;
+
+: knot-interval ( nurbs-curve t -- index )
+    [ knots>> ] dip [ > ] curry find drop 1 - ;
+
+: clip-range ( from to sequence -- from' to' )
+    length min [ 0 max ] dip ;
+
+:: eval-base ( knot-constants bases t -- base )
+    knot-constants first t * knot-constants third + bases first *
+    knot-constants second t * knot-constants fourth + bases second *
+    + ;
+
+: (eval-curve) ( base-values control-points -- value )
+    [ n*v ] 2map { 0.0 0.0 0.0 } [ v+ ] binary-reduce h>v ;
+
+:: (eval-bases) ( curve t interval values order -- values' )
+    order 2 - curve (knot-constants)>> nth :> all-knot-constants
+    interval order interval + all-knot-constants clip-range :> to :> from
+    from to all-knot-constants subseq :> knot-constants
+    values { 0.0 } { 0.0 } surround 2 <clumps> :> bases
+
+    knot-constants bases [ t eval-base ] 2map :> values'
+    order curve order>> =
+    [ values' from to curve control-points>> subseq (eval-curve) ]
+    [ curve t interval 1 - values' order 1 + (eval-bases) ] if ;
+
+: eval-nurbs ( nurbs-curve t -- value )
+    2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ;
+
+

extra/nurbs/summary.txt

@@ -0,0 +1 @@
+NURBS curve evaluation