ZHUOWARE BACKYARD - NOTE INDEX|ZHUOWARE BACKYARD TOP|ZHUOWARE表ページ

cbspline in tcl/tk

Mar. 28, 2013 by Zhuo

Abstract

I have implemented a minimum cubic-basis-spline module in tcl/tk, with a sample script to show the usage. Using this module, you can simply specify the number of interpolating points to get a set of parameters, then can use it to convert a list of numeric values to its interpolated version. Applying this interpolation on x and y coordinates separately, you will have a smoother polyline in place of the original. The reason I implemented this was that both spline.tcl and math::interpolate in tcllib required x and y coordinates, but x must be in an ascending order; Neither interpolated my spiral polyline of which x coordinates increased and decreased. Now I think "x coordinates" in the module APIs mentioned above were actually a list of "knots" to introduce non-uniformity to the spline (though neither seemed to be a NURBS inplementation). I need to study more. //
最小限のcubic basis splineモジュールをtcl/tkで書いてみました.使い方を示すサンプルスクリプトもつけました. これを使えば,まず補間点数を指定してパラメータを取得し,つぎにそれを使って,数値のならびを,補間されたバージョンに変換することができます. この補間をx座標とy座標に別々に適用すれば,元の折れ線のかわりにより滑らかな折れ線を得ることができます. このモジュールを実装したのは,spline.tclも,tcllibの math::interpolateも,xとy座標を受け取ってはくれるものの,xは単調増加でなければならないとあったからです.いずれも,私のうずまき状の折れ線-- x座標が増えたり減ったりする -- を補間してくれませんでした. もっとも今考えてみると,上にのべたmoduleのAPIの"x座標"というのは実はスプラインに不均一さを導入する「節点」のリストだったのかもしれません(いずれのモジュールも,NURBSの実装ではないようでしたが).もっと勉強しなくてはなりません.

Rev. 1.0. download

Rev. 1.0. contents

cbspline1.0 directory
cbspline1.0 package. Copy this directory into your Tcl library directory. //
cbspline1.0 パッケージ. このディレクトリを,Tclライブラリのディレクトリにコピーしてください.
cbspline_test.tcl
A test GUI for cbspline.tcl. Simply run this to see what you can realize using cbspline1.0.//
cbspline.tclのテストGUI. これを走らせれば,cbspline1.0で何ができるかわかるでしょう.
readme.txt
A brief description on the installation and the trial run. //
インストール・実験方法を記したテキスト.
Needless to say you need a Tcl/Tk environment installed on your computer to try this package. I tested this module with ActiveTcl Community Edition 8.4.19.5. For your convenience, the tcl script in the package and the test GUI script are shown below. //
言うまでもなく,このパッケージを試すにはコンピュータにTcl/Tk環境がインストールされている必要があります.私はActiveTcl Community Edition 8.4.19.5でこのモジュールをテストしました. 利便性を考え,パッケージのtclスクリプトとテストGUIのスクリプトを以下に示しています.

cbspline.tcl

#
# cbspline.tcl   Cubic Basis Spline  by zhuo
#
# Usage:  Do the following in your script.
#   0) Place this code with pkgIndex.tcl  in a Tcl library directory.
#   1) Import this package into your script by:
#       package require cbspline
#   2) As a preparation, create "bases" data by specifying the number 
#      of division; for instance, if you want to have 8 interpolated
#      points for one control point, pass 8 to this function:
#       set bases8 [cbspline::makeBases 8]
#   3) Now you can get an interpolated list out of the original, by:
#       set result [cbspline::interpolate $controlPoints $bases8]
#   4) For 2-dimensional polylines, do interpolation for x and y 
#      coordinates independently;

namespace eval cbspline {
}

######################################################################
# generate bases according to the number of division  ..
# return value (for the case nDiv = 10)
# { #body
#   b0 b1 b2 b3  # for t = 0.0
#   b0 b1 b2 b3  # for t = 0.1
#      :
#   b0 b1 b2 b3  # for t = 0.9
# }
# { b0 b1 b2 b3  } # for t = 1.0 (tail)

######################################################################
proc cbspline::makeBases {nDiv} {
    set div_1 [expr {1.0/$nDiv}]
    for { set idx 0 } { $idx <= $nDiv } { incr idx } {
	set t1 [expr {$idx * $div_1}]
	set t2 [expr {$t1*$t1}]
	set t3 [expr {$t2*$t1}]
	lappend bases \
	    [expr {(-$t3 + 3.0*$t2 - 3.0*$t1 + 1.0)/6.0}] \
	    [expr {(3.0*$t3 - 6.0*$t2 + 4.0)/6.0}] \
	    [expr {(-3.0*$t3 + 3.0*$t2 + 3.0 * $t1 + 1.0)/6.0}] \
	    [expr {$t3/6.0}]
    }
    return [list [lrange $bases 0 end-4] [lrange $bases end-3 end]]
}

#  *  *  x1   x2    x3    x4    x5  *  *
#  0  1   2                5 
proc cbspline::interpolate { list bases } {
    set basisBody [lindex $bases 0]
    set basisTail [lindex $bases 1]
    set nPnts [llength $list]
    set list [concat [lindex $list 0] [lindex $list 0] $list [lindex $list end] [lindex $list end]]
    
    for {set idx 0} {$idx <= $nPnts} {incr idx} {
	foreach {c0 c1 c2 c3} [lrange $list $idx [expr {$idx+3}]] {
	    foreach {b0 b1 b2 b3} $basisBody {
		lappend out [expr {$c0*$b0+$c1*$b1+$c2*$b2+$c3*$b3}]
	    }
	}
    }
    foreach {b0 b1 b2 b3} $basisTail {
	lappend out [expr {$c0*$b0+$c1*$b1+$c2*$b2+$c3*$b3}]
    }
    return $out
}

package provide cbspline 1.00

cbspline_test.tcl

######################################################################
# cbspline.tcl :: TEST CODE
# Mar. 2013 by zhuo
######################################################################

package require cbspline

########################################
# MODEL
########################################
set ::m(idcnt) 0
proc mId {} {
    set id $::m(idcnt)
    incr ::m(idcnt)
    return $id
}

proc mCreateSpline {xs ys div canv splEdgeColor splNodeColor refEdgeColor refNodeColor} {
    set tag "spl[mId]"
    if { [catch {set bases $::m(bases,$div)} msg] } {
	set bases [cbspline::makeBases $div]
	set ::m(bases,$div) $bases
    }
    set ::m($tag,xs) $xs
    set ::m($tag,ys) $ys
    set ::m($tag,div) $div
    set ::v($tag,canv) $canv
    vNewLine $tag crv [cbspline::interpolate $xs $bases] [cbspline::interpolate $ys $bases] $splEdgeColor $splNodeColor 0
    vNewLine $tag ref $xs $ys $refEdgeColor $refNodeColor 1
    return $tag
}

proc mSetNthNode {tag idx x y} {
    lset ::m($tag,xs) $idx $x
    lset ::m($tag,ys) $idx $y
    set bases $::m(bases,$::m($tag,div))
    vUpdateLine $tag crv [cbspline::interpolate $::m($tag,xs) $bases] [cbspline::interpolate $::m($tag,ys) $bases]
    vUpdateLine $tag ref $::m($tag,xs) $::m($tag,ys)
}


########################################
# VIEW
########################################
#isActive : when set to 1, nodes get mouse-draggable.
proc vNewLine {tag label xs ys edgeColor nodeColor isActive} {
    foreach x $xs y $ys { lappend coord $x $y }
    set canv $::v($tag,canv)
    $canv delete $tag,$label
    $canv create line $coord -width 1 -fill $edgeColor -tags "$tag,$label $tag,$label,edge"
    set idx 0
    foreach {x y} $coord {
	$canv move [$canv create rectangle -2 -2 2 2 -fill $nodeColor -outline "" \
			-tags "$tag,$label $tag,$label,node,$idx"] $x $y
	if $isActive {
	    $canv bind $tag,$label,node,$idx  "mSetNthNode $tag $idx %x %y"
	}
	incr idx
    }
}	

proc vUpdateLine {tag label xs ys} {
    foreach x $xs y $ys { lappend coord $x $y }
    set canv $::v($tag,canv)
    $canv coords $tag,$label,edge $coord
    set idx 0
    foreach {x y} $coord {
	$canv coord $tag,$label,node,$idx -2 -2 2 2
	$canv move $tag,$label,node,$idx $x $y
	incr idx
    }
}

########################################
# GUI
########################################
canvas .c -width 960 -height 640 -bg black
pack .c

# In this code, data of each spline are stored in array ::attr.
set XS0 { 100 200 150 350 500 600 600 500 }
set YS0 { 100 150 200 300 300 200 100  50 }

set XS1 { 100 200 150 350 500 600 600 500 }
set YS1 { 400 450 500 600 600 500 400 350 }

set spl0 [mCreateSpline $XS0 $YS0 8 .c yellow green red blue]
set spl1 [mCreateSpline $XS1 $YS1 4 .c yellow green red blue]