RAI My son recently discovered an animation program called "Pivot Stickfigure Animator" by Peter Bone.
http://www.geocities.com/peter_bone_uk/pivot.html
http://groups.msn.com/Pivotanimation
At first it looked like something that could be written in just a few lines of Tcl, but after working on it for a bit I believe there is more involved. The code below only covers the "Poser" part of the program:
console show
canvas .c -width 600 -height 600
pack .c
proc makeLine {x1y1 x2y2} {
foreach {x1 y1} $x1y1 {}
foreach {x2 y2} $x2y2 {}
set id [.c create line $x1 $y1 $x2 $y2 -width 10 -capstyle round]
.c addtag stick withtag $id
set ::list_of_attachments($id) ""
set ::center($id.xy) "$x1 $y1"
set ::end($id.xy) "$x2 $y2"
set h0 [makeHandle $x2 $y2]
mount $h0 $id
return $id
}
proc getCenter {id} { return $::center($id.xy) }
proc setCenter {id x y} { set ::center($id.xy) "$x $y" }
proc getEnd {id} { return $::end($id.xy) }
proc setEnd {id x y} { set ::end($id.xy) "$x $y" }
proc rotateSome {id a xc yc} {
rotateOneSome $id $a $xc $yc
foreach child $::list_of_attachments($id) {
rotateSome $child $a $xc $yc
}
}
proc rotateOneSome {id a xc yc} {
set cosa [expr {cos($a)}]
set sina [expr {sin($a)}]
foreach {x1 y1} [getCenter $id] {}
set dx [expr $x1-$xc]
set dy [expr $y1-$yc]
set newx1 [expr {$cosa*$dx - $sina*$dy + $xc}]
set newy1 [expr {$cosa*$dy + $sina*$dx + $yc}]
foreach {x2 y2} [getEnd $id] {}
set dx [expr $x2-$xc]
set dy [expr $y2-$yc]
set newx2 [expr {$cosa*$dx - $sina*$dy + $xc}]
set newy2 [expr {$cosa*$dy + $sina*$dx + $yc}]
setCenter $id $newx1 $newy1
setEnd $id $newx2 $newy2
.c coords $id $newx1 $newy1 $newx2 $newy2
set handle [getHasMount $id]
if {$handle != -1} {
.c coords $handle $newx2 $newy2 $newx2 $newy2
}
}
proc makeHandle {x1 y1 {color orange} } {
set id [.c create line $x1 $y1 $x1 $y1 -width 10 -capstyle round -fill $color]
set ::list_of_attachments($id) ""
.c addtag drag1 withtag $id
.c addtag handle withtag $id
return $id
}
proc raiseHandles {} {
.c raise handle
}
proc mount {h1 l1} {
set ::mounted_on($h1) $l1
set ::has_mount($l1) $h1
}
proc getMountedOn {id} {
if { ![info exists ::mounted_on($id) ] } { return -1}
return $::mounted_on($id)
}
proc getHasMount {id} {
if { ![info exists ::has_mount($id) ] } { return -1}
return $::has_mount($id)
}
proc attach {l1 l0} {
set ::attached_on($l1) $l0
lappend ::list_of_attachments($l0) $l1
}
proc getAttachedOn {id} {
return $::attached_on($id)
}
proc canvas_movable w {
$w bind drag1 <Button-1> "handle_press %W %x %y"
$w bind drag1 <B1-Motion> {handle_motion %W [%W canvasx %x] [%W canvasy %y]}
}
proc handle_press {W x y} {
set ::g(id) [$W find withtag current]
set mountedOn [getMountedOn $::g(id)]
foreach {xc yc} [getCenter $mountedOn] {}
set ::g(x) [$W canvasx $x]
set ::g(y) [$W canvasy $y]
set dx [expr $x-$xc]
set dy [expr $y-$yc]
set ::g(a) [expr atan2($dy,$dx)]
}
proc handle_motion {w xn yn} {
set mountedOn [getMountedOn $::g(id)]
if { $mountedOn == -1 } {
$w move $::g(id) [expr {$xn-$::g(x)}] [expr {$yn-$::g(y)}]
set ::g(x) $xn
set ::g(y) $yn
} else {
foreach {xc yc} [getCenter $mountedOn] {}
set dx [expr {$xn-$xc}]
set dy [expr {$yn-$yc}]
set a [expr {atan2($dy,$dx)}]
set da [expr {$a - $::g(a)}]
rotateSome $mountedOn $da $xc $yc
foreach {xf yf} [getEnd $mountedOn] {}
$w move $::g(id) [expr {$xf-$::g(x)}] [expr {$yf-$::g(y)}]
set ::g(x) $xf
set ::g(y) $yf
set ::g(a) [expr $::g(a) + $da]
}
}
.c focus ""
canvas_movable .c
# create a simple figure. (need to make a gui editor)
set waist "300 300"
set neck "300 200"
set torso [makeLine $waist $neck]
set head [makeLine $neck "286 152"]
attach $head $torso
set rUpperArm [makeLine $neck "375 266"]
attach $rUpperArm $torso
set rLowerArm [makeLine [getEnd $rUpperArm] "401 362"]
attach $rLowerArm $rUpperArm
set lUpperArm [makeLine $neck "222 263"]
attach $lUpperArm $torso
set lLowerArm [makeLine [getEnd $lUpperArm] "201 361"]
attach $lLowerArm $lUpperArm
set rUpperLeg [makeLine $waist "340 392"]
#attach $rUpperLeg $torso
set rLowerLeg [makeLine [getEnd $rUpperLeg] "341 492"]
attach $rLowerLeg $rUpperLeg
set lUpperLeg [makeLine $waist "263 393"]
#attach $lUpperLeg $torso
set lLowerLeg [makeLine [getEnd $lUpperLeg] "264 493"]
attach $lLowerLeg $lUpperLeg
raiseHandlesNext up...
(1) saving the figure to a file
(2) saving multiple poses to a file
(3) replaying the poses