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