extra/nurbs/nurbs.factor

   1 ! Copyright (C) 2009 Joe Groff
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: accessors alien.c-types grouping kernel locals math
   4 math.order ranges math.vectors math.vectors.homogeneous
   5 sequences specialized-arrays ;
   6 SPECIALIZED-ARRAY: alien.c-types:float
   7 IN: nurbs
   8
   9 TUPLE: nurbs-curve
  10     { order integer }
  11     control-points
  12     knots
  13     (knot-constants) ;
  14
  15 : ?recip ( n -- 1/n )
  16     dup zero? [ recip ] unless ;
  17
  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
  24
  25     knot_i+k-1 knot_i   - ?recip :> c1
  26     knot_i+1   knot_i+k - ?recip :> c2
  27
  28     knot_i   c1 * neg :> c3
  29     knot_i+k c2 * neg :> c4
  30
  31     c1 c2 c3 c4 float-array{ } 4sequence ;
  32
  33 : order-knot-constants ( curve order -- knot-constants )
  34     2dup [ knots>> length ] dip - <iota>
  35     [ order-index-knot-constants ] 2with map ;
  36
  37 : knot-constants ( curve -- knot-constants )
  38     2 over order>> [a..b]
  39     [ order-knot-constants ] with map ;
  40
  41 : update-knots ( curve -- curve )
  42     dup knot-constants >>(knot-constants) ;
  43
  44 : <nurbs-curve> ( order control-points knots -- nurbs-curve )
  45     f nurbs-curve boa update-knots ;
  46
  47 : knot-interval ( nurbs-curve t -- index )
  48     [ knots>> ] dip [ > ] curry find drop 1 - ;
  49
  50 : clip-range ( from to sequence -- from' to' )
  51     length min [ 0 max ] dip ;
  52
  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 *
  56     + ;
  57
  58 : eval-curve ( base-values control-points -- value )
  59     [ n*v ] 2map { 0.0 0.0 0.0 } [ v+ ] binary-reduce h>v ;
  60
  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
  66
  67     knot-constants bases [ t eval-base ] 2map :> values'
  68     order curve order>> =
  69     [ values' from to curve control-points>> subseq eval-curve ]
  70     [ curve t interval 1 - values' order 1 + eval-bases ] if ;
  71
  72 : eval-nurbs ( nurbs-curve t -- value )
  73     2dup knot-interval 1 - { 1.0 } 2 eval-bases ;