extra/math/splines/splines.factor

   1 ! Copyright (C) 2010 Erik Charlebois
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators kernel locals math math.combinatorics
   4 math.polynomials opengl.gl sequences ui.gadgets ui.gadgets.panes
   5 ui.render arrays grouping math.vectors assocs
   6 ui.gestures ;
   7 FROM: sequences => change-nth ;
   8 IN: math.splines
   9
  10 <PRIVATE
  11 :: bernstein-polynomial-ith ( n i -- p )
  12     n i nCk { 0 1 } i p^ { 1 -1 } n i - p^ p* n*p ;
  13
  14 :: hermite-polynomial ( p0 m0 p1 m1 -- poly )
  15     p0
  16     m0
  17     -3 p0 * -2 m0 * + 3 p1 * + m1 neg +
  18     2 p0 * m0 + -2 p1 * + m1 +
  19     4array ;
  20
  21 :: kochanek-bartels-coefficients ( tension bias continuity -- s1 d1 s2 d2 )
  22     1 tension -
  23     [
  24         1 bias +
  25         [ 1 continuity + * * 2 / ]
  26         [ 1 continuity - * * 2 / ] 2bi
  27     ]
  28     [
  29         1 bias -
  30         [ 1 continuity - * * 2 / ]
  31         [ 1 continuity + * * 2 / ] 2bi
  32     ] bi ;
  33
  34 :: kochanek-bartels-tangents ( points m0 mn c1 c2 -- tangents )
  35     points 3 clump [
  36         first3 :> ( pi-1 pi pi+1 )
  37         pi pi-1 v- c1 v*n
  38         pi+1 pi v- c2 v*n v+
  39     ] map
  40     m0 prefix
  41     mn suffix ;
  42 PRIVATE>
  43
  44 :: <bezier-curve> ( control-points -- polynomials )
  45     control-points
  46     [ length 1 - ]
  47     [ first length [ { 0 } ] replicate ]
  48     bi :> ( n acc )
  49
  50     control-points [| pt i |
  51         n i bernstein-polynomial-ith :> poly
  52         pt [| v j |
  53             j acc [ v poly n*p p+ ] change-nth
  54         ] each-index
  55     ] each-index
  56     acc ;
  57
  58 :: <cubic-hermite-curve> ( p0 m0 p1 m1 -- polynomials )
  59     p0 length iota [
  60         {
  61             [ p0 nth ] [ m0 nth ]
  62             [ p1 nth ] [ m1 nth ]
  63         } cleave
  64         hermite-polynomial
  65     ] map ;
  66
  67 <PRIVATE
  68 : (cubic-hermite-spline) ( point-in-out-triplets -- polynomials-sequence )
  69     2 clump [
  70         first2 [ first2 ] [ [ first ] [ third ] bi ] bi* <cubic-hermite-curve>
  71     ] map ;
  72 PRIVATE>
  73
  74 : <cubic-hermite-spline> ( point-tangent-pairs -- polynomials-sequence )
  75     2 clump [ first2 [ first2 ] bi@ <cubic-hermite-curve> ] map ;
  76
  77 :: <kochanek-bartels-curve> ( points m0 mn tension bias continuity -- polynomials-sequence )
  78     tension bias continuity kochanek-bartels-coefficients :> ( s1 d1 s2 d2 )
  79     points m0 mn
  80     [ s1 s2 kochanek-bartels-tangents ]
  81     [ d1 d2 kochanek-bartels-tangents ] 3bi :> ( in out )
  82     points in out [ 3array ] 3map (cubic-hermite-spline) ;
  83
  84 : <catmull-rom-spline> ( points m0 mn -- polynomials-sequence )
  85     0 0 0 <kochanek-bartels-curve> ;