AMG: This script simulates pulling (or pushing!) a chain or string. The chain is attached to the mouse pointer. Just move the mouse to move the chain. The important property of the chain is that its length never changes (unless perhaps you add the -smooth true option to the line creation, in which case it might change a small amount).
The length of the chain and the number of vertices are configurable. For a "string" (smooth chain), set $vertices to one plus $length; this makes each segment (link) of the chain one pixel in length. Or make the number of vertices very small (at least two) to see the jointed chain-like behavior.
package require Tcl 8.5
package require Tk
namespace path {::tcl::mathop ::tcl::mathfunc}
proc chain {w x1 y1} {
set length 400
set vertices 401
if {[llength [$w find withtag chain]] == 0} {
$w create line {*}[lrepeat $vertices $x1 $y1] -tags chain
} else {
set coords [list $x1 $y1]
set seglen [/ $length [- $vertices 1]]
foreach {x0 y0} [lrange [$w coords chain] 2 end] {
set xd [- $x1 $x0]
set yd [- $y1 $y0]
if {$xd == 0 && $yd == 0} {
return
}
set nd [/ $seglen [hypot $xd $yd]]
set x1 [- $x1 [* $xd $nd]]
set y1 [- $y1 [* $yd $nd]]
lappend coords $x1 $y1
}
$w coords chain {*}$coords
}
}
canvas .c -width 500 -height 500 -highlightthickness 0
pack .c -fill both -expand true
bind .c <Motion> {chain %W %x %y}AMG: You are invited to add more realistic physics properties and constraints to this simulation, for instance a minimum bend radius.
slebetman Here's one in Tcl 8.4 in case, like me, you don't have 8.5. (And can the TCT please release 8.5 already? There are already too many 8.5 specific code floating around here and c.l.c for me to ignore.).
package require Tk
proc chain {w x1 y1} {
set length 400
set vertices 401
if {[llength [$w find withtag chain]] == 0} {
$w create line [string repeat "$x1 $y1 " $vertices] -tags chain
} else {
set coords [list $x1 $y1]
set seglen [expr {$length/($vertices-1)}]
foreach {x0 y0} [lrange [$w coords chain] 2 end] {
set xd [expr {$x1-$x0}]
set yd [expr {$y1-$y0}]
if {$xd == 0 && $yd == 0} {
return
}
set nd [expr {$seglen/hypot($xd,$yd)}]
set x1 [expr {$x1-($xd*$nd)}]
set y1 [expr {$y1-($yd*$nd)}]
lappend coords $x1 $y1
}
$w coords chain $coords
}
}
canvas .c -width 500 -height 500 -highlightthickness 0
pack .c -fill both -expand true
bind .c <Motion> {chain %W %x %y}See also TclSpringies : A simple mass and spring simulator.