extra/nurbs/nurbs.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors arrays grouping kernel locals math math.order
   3 math.ranges math.vectors math.vectors.homogeneous sequences
   4 specialized-arrays.float ;
   5 IN: nurbs
   6
   7 TUPLE: nurbs-curve
   8     { order integer }
   9     control-points
  10     knots
  11     (knot-constants) ;
  12
  13 : ?recip ( n -- 1/n )
  14     dup zero? [ recip ] unless ;
  15
  16 :: order-index-knot-constants ( curve order index -- knot-constants )
  17     curve knots>> :> knots
  18     index order 1 - + knots nth :> knot_i+k-1
  19     index             knots nth :> knot_i
  20     index order +     knots nth :> knot_i+k
  21     index 1 +         knots nth :> knot_i+1
  22
  23     knot_i+k-1 knot_i   - ?recip :> c1
  24     knot_i+1   knot_i+k - ?recip :> c2
  25
  26     knot_i   c1 * neg :> c3
  27     knot_i+k c2 * neg :> c4
  28
  29     c1 c2 c3 c4 float-array{ } 4sequence ;
  30
  31 : order-knot-constants ( curve order -- knot-constants )
  32     2dup [ knots>> length ] dip - iota
  33     [ order-index-knot-constants ] with with map ;
  34
  35 : knot-constants ( curve -- knot-constants )
  36     2 over order>> [a,b]
  37     [ order-knot-constants ] with map ;
  38
  39 : update-knots ( curve -- curve )
  40     dup knot-constants >>(knot-constants) ;
  41
  42 : <nurbs-curve> ( order control-points knots -- nurbs-curve )
  43     f nurbs-curve boa update-knots ;
  44
  45 : knot-interval ( nurbs-curve t -- index )
  46     [ knots>> ] dip [ > ] curry find drop 1 - ;
  47
  48 : clip-range ( from to sequence -- from' to' )
  49     length min [ 0 max ] dip ;
  50
  51 :: eval-base ( knot-constants bases t -- base )
  52     knot-constants first t * knot-constants third + bases first *
  53     knot-constants second t * knot-constants fourth + bases second *
  54     + ;
  55
  56 : (eval-curve) ( base-values control-points -- value )
  57     [ n*v ] 2map { 0.0 0.0 0.0 } [ v+ ] binary-reduce h>v ;
  58
  59 :: (eval-bases) ( curve t interval values order -- values' )
  60     order 2 - curve (knot-constants)>> nth :> all-knot-constants
  61     interval order interval + all-knot-constants clip-range :> to :> from
  62     from to all-knot-constants subseq :> knot-constants
  63     values { 0.0 } { 0.0 } surround 2 <clumps> :> bases
  64
  65     knot-constants bases [ t eval-base ] 2map :> values'
  66     order curve order>> =
  67     [ values' from to curve control-points>> subseq (eval-curve) ]
  68     [ curve t interval 1 - values' order 1 + (eval-bases) ] if ;
  69
  70 : eval-nurbs ( nurbs-curve t -- value )
  71     2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ;
  72
  73