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