[ 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 } ;
} 2cleave
[ [ 2array ] 2bi@ ] dip <affine-transform> ;
-: v~ ( a b epsilon -- ? )
- [ ~ ] curry 2all? ;
-
: a~ ( a b epsilon -- ? )
{
[ [ [ x>> ] bi@ ] dip v~ ]
--- /dev/null
+! (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
--- /dev/null
+! (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 ;
+
--- /dev/null
+Homogeneous coordinate math
--- /dev/null
+! (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
--- /dev/null
+! (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) ;
+
+
--- /dev/null
+NURBS curve evaluation