[Keith Vetter] 2003-03-07 - one feature often noted as missing from tk the ability of the canvas to do cubic splines. Here is a routine '''Cubic::CubicSpline''' that takes a list of (x,y) values of control points and returns a list points on the cubic spline curve that's suitable to be used by: ''canvas create line [[Cubic::CubicSplint $xy]] ...'' Greg Blair extended the code here in [Tension Splines] by adding several new splines with more controls. ---- ##+########################################################################## # # CubicSpline -- routines to generate the coordinates of a cubic spline # given a list of control points. Also included is demo/test harness # by Keith Vetter # # Revisions: # KPV Mar 07, 2003 - initial revision # namespace eval Cubic {} ##+########################################################################## # # CubicSpline - returns the x,y coordinates of the cubic spline using # xy control points. # xy => {{x0 y0} {x1 y1} .... {xn yn}} # # XY points MUST BE SORTED by increasing x # proc Cubic::CubicSpline {xy {PRECISION 10}} { set np [expr {[llength $xy] / 2}] if {$np <= 1} return set idx 0 foreach {x y} $xy { set X($idx) $x set Y($idx) $y incr idx } for {set i 1; set last $X(0)} {$i < $np} {set last $X($i); incr i} { set h($i) [expr {double($X($i) - $last)}] if {$h($i) == 0} return if {$h($i) < 0} return ;# ERROR not sorted } if {$np > 2} { for {set i 1} {$i < $np-1} {incr i} { set i2 [expr {$i + 1}] set i0 [expr {$i - 1}] set diag($i) [expr {($h($i) + $h($i2))/3.0}] set sup($i) [expr {$h($i2) / 6.0}] set sub($i) [expr {$h($i) / 6.0}] set a($i) [expr {($Y($i2) - $Y($i))/$h($i2) - \ ($Y($i) - $Y($i0)) / $h($i)}] } Cubic::SolveTridiag sub diag sup a [expr {$np - 2}] } set a(0) [set a([expr {$np - 1}]) 0] # Now generate the point list set xy [list $X(0) $Y(0)] for {set i 1} {$i < $np} {incr i} { set i0 [expr {$i - 1}] for {set j 1} {$j <= $PRECISION} {incr j} { set t1 [expr {($h($i) * $j) / $PRECISION}] set t2 [expr {$h($i) - $t1}] set y [expr {((-$a($i0)/6 * ($t2 + $h($i)) * $t1 + \ $Y($i0))* $t2 + (-$a($i)/6 * \ ($t1+$h($i)) * $t2 + $Y($i)) * $t1)/$h($i)}] set t [expr {$X($i0) + $t1}] lappend xy $t $y } } return $xy } ##+########################################################################## # SolveTriDiag -- solves the linear system for tridiagoal NxN matrix A # using Gaussian elimination (no pivoting). Since A is sparse, we pass # in three diagonals: # sub(i) => a(i,i-1) diag(i) => a(i,i) sup(i) => a(i,i+1) # # Result is returned in b[1:n] # proc Cubic::SolveTridiag {N_sub N_diag N_sup N_b n} { upvar 1 $N_sub sub upvar 1 $N_diag diag upvar 1 $N_sup sup upvar 1 $N_b b # Factorization and forward substitution for {set i 2} {$i <= $n} {incr i} { set i0 [expr {$i - 1}] set sub($i) [expr {$sub($i) / $diag($i0)}] set diag($i) [expr {$diag($i) - $sub($i) * $sup($i0)}] set b($i) [expr {$b($i) - $sub($i) * $b($i0)}] } set b($n) [expr {$b($n) / $diag($n)}] for {set i [expr {$n - 1}]} {$i >= 1} {incr i -1} { set i2 [expr {$i + 1}] set b($i) [expr {($b($i) - $sup($i) * $b($i2)) / $diag($i)}] } } ---- Now to demonstrate and test the code you can use the following: ---- ################################################################ ################################################################ # # Test harness and demo code # package require Tk set S(title) "Cubic Spline" set S(r) 5 ;# Control point size set S(w) 5 ;# Line width set S(precision) 10 set INITPOINTS {-200 0 -80 -125 30 100 200 0} proc DoDisplay {} { global S INITPOINTS wm title . $S(title) pack [frame .ctrl -relief ridge -bd 2 -padx 5 -pady 5] \ -side right -fill both -ipady 5 pack [frame .screen -bd 2 -relief raised] -side top -fill both -expand 1 canvas .c -relief raised -borderwidth 0 -height 500 -width 500 pack .c -in .screen -side top -fill both -expand 1 bind all {console show} bind .c {ReCenter %W %h %w} .c bind p [list MouseMove %x %y] DoCtrlFrame AddCtrlPoint $INITPOINTS update } proc DoCtrlFrame {} { button .add -text "Add Point" -command AddCtrlPoint -bd 4 button .dele -text "Delete Point" -command DeleteCtrlPoint -bd 4 button .clear -text "Clear Points" -command ClearCtrlPoint .add configure -font "[font actual [.add cget -font]] -weight bold" .dele configure -font [.add cget -font] .clear configure -font [.add cget -font] scale .prec -orient h -variable S(precision) -font [.add cget -font] \ -label Precision: -relief ridge -from 1 -to 20 -command DrawCurve button .about -text About -command About grid .add -in .ctrl -row 1 -sticky ew grid .dele -in .ctrl -row 2 -sticky ew grid .clear -in .ctrl -row 3 -sticky ew -pady 10 grid .prec -in .ctrl -row 4 -sticky ew -pady 30 grid rowconfigure .ctrl 50 -weight 1 grid .about -in .ctrl -row 100 -sticky ew } proc ReCenter {W h w} { ;# Called by configure event foreach h2 [expr {$h / 2}] w2 [expr {$w / 2}] break $W config -scrollregion [list -$w2 -$h2 $w2 $h2] } proc MakeBox {x y r} { return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]] } proc MouseMove {X Y} { regexp {p([0-9]+)} [.c itemcget current -tag] => who set X [.c canvasx $X] ; set Y [.c canvasy $Y] foreach x $::P($who,x) y $::P($who,y) break foreach ::P($who,x) $X ::P($who,y) $Y break .c move p$who [expr {$X - $x}] [expr {$Y - $y}] DrawCurve } proc AddCtrlPoint {{xy {}}} { global P S set np [llength [array names P *x]] if {$xy == {}} { set w [expr {[winfo width .c] - 50}] set xy [list [expr {$w * rand() - $w/2}] [expr {50 * rand() - 25}]] } foreach {x y} $xy { set P($np,x) $x set P($np,y) $y .c create oval [MakeBox $x $y $S(r)] -tag [list p p$np] -fill yellow incr np } DrawCurve } proc DeleteCtrlPoint {} { global P set np [llength [array names P *x]] if {$np == 0} return incr np -1 # Always delete the rightmost control point # swap RIGHTMOST and NP then delete NP set rightmost [lindex [lindex [SortPoints] end] end] .c delete p$rightmost .c itemconfig p$np -tag [list p p$rightmost] set P($rightmost,x) $P($np,x) set P($rightmost,y) $P($np,y) unset P($np,x) unset P($np,y) DrawCurve } proc ClearCtrlPoints {} { global P .c delete p catch {unset P} DrawCurve } proc SortPoints {} { global P set np [llength [array names P *x]] set xy {} for {set i 0} {$i < $np} {incr i} { lappend xy [list $P($i,x) $P($i,y) $i] } set xy2 [lsort -real -index 0 $xy] return $xy2 } proc DrawCurve {args} { global S set xy {} foreach pt [SortPoints] { ;# Flatten point list foreach {x y} $pt break lappend xy $x $y } set xy [Cubic::CubicSpline $xy $::S(precision)] .c delete cubic if {$xy == {}} return .c create line $xy -tag cubic -width $::S(w) .c lower cubic } proc About {} { set msg "Cubic Splines\nby Keith Vetter, March 2003" tk_messageBox -title About -message $msg } ################################################################ ################################################################ DoDisplay DrawCurve ---- [Lars H]: A very nice little application, but not at all what my entry on the [Tk 9.0 WishList] was about. The problem is not to compute the control points of the splines, but to make the canvas understand something like a [Postscript] path (list of knot and control point coordinates for cubic Bezier polynomials). In want of support for this in the [canvas] widget, one could make do with some Tcl procedures for translating such a cubic path to something that the canvas can understand. I suppose this is the kind of thing that should go into [tklib]. In the above code, the part of [[Cubic::CubicSpline]] that comes after ''Now generate the point list'' does such a conversion, but it is rather crude. Approximation with polygons is not bad as such (indeed, it is what Postscript does internally when it flattens paths), but in general one would want the number of line segments to be adjusted to the actual curve, so that the "precision" really would give a bound on the approximation error. I don't know how one would achieve this effectively, but there are probably good algorithms in the literature. ---- [[ [Category Graphics] | [Category Mathematics] ]]