1 ! (c)2009 Joe Groff bsd license
2 USING: accessors alien.c-types arrays grouping kernel locals
3 math math.order math.ranges math.vectors
4 math.vectors.homogeneous sequences specialized-arrays ;
5 FROM: alien.c-types => float ;
6 SPECIALIZED-ARRAY: float
16 dup zero? [ recip ] unless ;
18 :: order-index-knot-constants ( curve order index -- knot-constants )
19 curve knots>> :> knots
20 index order 1 - + knots nth :> knot_i+k-1
21 index knots nth :> knot_i
22 index order + knots nth :> knot_i+k
23 index 1 + knots nth :> knot_i+1
25 knot_i+k-1 knot_i - ?recip :> c1
26 knot_i+1 knot_i+k - ?recip :> c2
29 knot_i+k c2 * neg :> c4
31 c1 c2 c3 c4 float-array{ } 4sequence ;
33 : order-knot-constants ( curve order -- knot-constants )
34 2dup [ knots>> length ] dip - iota
35 [ order-index-knot-constants ] 2with map ;
37 : knot-constants ( curve -- knot-constants )
39 [ order-knot-constants ] with map ;
41 : update-knots ( curve -- curve )
42 dup knot-constants >>(knot-constants) ;
44 : <nurbs-curve> ( order control-points knots -- nurbs-curve )
45 f nurbs-curve boa update-knots ;
47 : knot-interval ( nurbs-curve t -- index )
48 [ knots>> ] dip [ > ] curry find drop 1 - ;
50 : clip-range ( from to sequence -- from' to' )
51 length min [ 0 max ] dip ;
53 :: eval-base ( knot-constants bases t -- base )
54 knot-constants first t * knot-constants third + bases first *
55 knot-constants second t * knot-constants fourth + bases second *
58 : (eval-curve) ( base-values control-points -- value )
59 [ n*v ] 2map { 0.0 0.0 0.0 } [ v+ ] binary-reduce h>v ;
61 :: (eval-bases) ( curve t interval values order -- values' )
62 order 2 - curve (knot-constants)>> nth :> all-knot-constants
63 interval order interval + all-knot-constants clip-range :> ( from to )
64 from to all-knot-constants subseq :> knot-constants
65 values { 0.0 } { 0.0 } surround 2 <clumps> :> bases
67 knot-constants bases [ t eval-base ] 2map :> values'
69 [ values' from to curve control-points>> subseq (eval-curve) ]
70 [ curve t interval 1 - values' order 1 + (eval-bases) ] if ;
72 : eval-nurbs ( nurbs-curve t -- value )
73 2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ;