(August 2014), pw
Here is an extension to the Tk canvas that facilitates animating canvas items, and it also includes a collection of easing functions. All of the functions currently listed at http://easings.net/ are implemented.
Here is the code: https://gist.github.com/paulwal/0cdb41cab88bc655d003
And here is a fancy demo showing off the various easing functions:
proc orbit {c i sector} {
switch -- $sector {
nw {$c animate $i -xamount -150 -duration 1000 -easing outquad -command [list orbit $c $i sw]
$c animate $i -yamount 40 -duration 1000 -easing inquad
}
sw {$c animate $i -xamount 150 -duration 1000 -easing inquad -command [list orbit $c $i se]
$c animate $i -yamount 40 -duration 1000 -easing outquad
}
ne {$c animate $i -xamount -150 -duration 1000 -easing inquad -command [list orbit $c $i nw]
$c animate $i -yamount -40 -duration 1000 -easing outquad
}
se {$c animate $i -xamount 150 -duration 1000 -easing outquad -command [list orbit $c $i ne]
$c animate $i -yamount -40 -duration 1000 -easing inquad
}
}
}
proc shake {c times easing {amount 50}} {
if { $times == 0 } {return}
$c animate all -xamount $amount -duration 100 -easing $easing -command [list shake $c [expr {$times-1}] $easing [expr {-$amount}]]
return
}
proc bounce {direction c item easing} {
if { $direction eq "down" } {$c animate $item -yamount 130 -duration 800 -easing $easing -command [list bounce up $c $item $easing]}
if { $direction eq "up" } {$c animate $item -yamount -130 -duration 800 -easing $easing -command [list bounce down $c $item $easing]}
}
proc ra {c id easing} {
if { [$c find withtag $id] ne "" } {
$c animate $id -xamount [expr {int((rand()*50)+(rand()*-50))}] -yamount [expr {int((rand()*30)+(rand()*-30))}] -duration [expr {int(rand()*1000)+200}] -command [list ra $c $id $easing] -easing $easing
}
}
proc spawn {c amount easing} {
for {set i 0} {$i < $amount} {incr i} {
set id [$c create oval {750 510 760 520} -fill [random_color] -width 0]
ra $c $id $easing
after [expr {int(rand()*10000)+200}] [list $c delete $id]
}
return
}
proc bubbles {c amount} {
set y1 [winfo height $c]
set y2 [expr {$y1+5}]
for {set i 0} {$i < $amount} {incr i} {
set x1 [expr {int(rand()*([winfo width $c]/4))+([winfo width $c]/8*3)}]
set x2 [expr {$x1+5}]
set item [$c create oval $x1 $y1 $x2 $y2 -fill {} -outline "#ddd" -width 2]
$c animate $item -easing inquad -yamount -[expr {$y1-30}] -duration [expr {int(rand()*5000)+2000}] -command [list $c delete $item]
}
return
}
# Returns a random 8-bit hex color.
proc random_color {} {
return [rgb_to_hex "[expr {int(rand()*65536)}] [expr {int(rand()*65536)}] [expr {int(rand()*65536)}]"]
}
# Convert a list of 16-bit RGB values to an 8-bit hex color.
proc rgb_to_hex {rgb} {
lassign $rgb r g b
set r [format %02x [expr {$r/256}]]
set g [format %02x [expr {$g/256}]]
set b [format %02x [expr {$b/256}]]
return #$r$g$b
}
proc demo {} {
toplevel .t
wm title .t "Animation Demo"
set f [ttk::frame .t.f]
set c [canvas .t.c -bg grey -highlightthickness 0 -width 950 -height 600]
ttk::button $f.b1 -text "Camera Shake" -command [list shake $c 8 outquad]
ttk::button $f.b2 -text "Bubbles" -command [list bubbles $c 10]
ttk::button $f.b3 -text "Spawn" -command [list spawn $c 10 OUTQUAD]
pack $f.b3 $f.b2 $f.b1 -side right -padx 10
pack $f -fill x
pack $c -fill both -expand true
set x 30
set y 15
set index 0
foreach easing [$c easings] {
$c create text $x $y -text $easing
set i [$c create oval [expr {$x-10}] [expr {$y+15}] [expr {$x+10}] [expr {$y+35}] -fill [random_color] -tags ball]
bounce down $c $i $easing
incr x 75
incr index
if { $index % 12 == 0 } {
set x 30
incr y 180
}
}
orbit $c [$c create oval {750 500 762 512} -fill "#333" -width 0] nw
orbit $c [$c create oval {750 520 762 532} -fill "#ddd" -width 0] se
return
}
demopw Run the code at the above link and then run the above demo code. There are 36 simultaneous animations in the demo until you start clicking buttons. My old Core2Duo CPU can handle roughly 100 simultaneous animations before it chokes. The framerate can also be reduced to improve performance. The main bottleneck appears to be in number-crunching the easing functions. I may convert this to a C extension at some point if there is a significant enough performance boost.
#! /bin/env tclsh
package require Tk
proc animate {} {
set i [ expr { $::cnt % 15 } ]
if {$i > 8} { set i [ expr { 15 - $i } ] }
set tag t$i
puts $tag
.c raise bg
.c raise $tag
incr ::cnt
after $::interval animate
}
set ::cnt 0
set ::interval 200
canvas .c -width 20 -height 20
.c create rect 0 0 20 20 -fill gray
.c create oval -5 -5 25 25 -fill gray -tags { bg }
.c create oval 0 0 0 0 -fill green -tags {t0 }
.c create oval 0 0 5 5 -fill green -tags { t1 }
.c create oval 0 0 10 10 -fill green -tags { t2 }
.c create oval 0 0 15 15 -fill green -tags { t3 }
.c create oval 0 0 20 20 -fill green -tags { t4 }
.c create oval 5 5 20 20 -fill green -tags { t5 }
.c create oval 10 10 20 20 -fill green -tags { t6 }
.c create oval 15 15 20 20 -fill green -tags { t7 }
.c create oval 20 20 20 20 -fill green -tags { t8 }
.c raise off
bind .c <Map> animate
pack .c -expand 1Slightly changed to show selection by tag combinations:
package require Tk
proc animate1 {} {
set i [ expr { $::cnt % 18 } ] ; incr ::cnt
.c raise screen
if {$i < 9} {
set tags [ list green && step$i ]
} else {
set tags [ list blue && step[ expr { 17 - $i } ] ]
}
puts $tags
.c raise $tags
after $::interval animate1
}
set ::cnt 0
set ::interval 200
set ::coords_bg {
-5 -5 25 25
}
set ::coords_ball {
{ 0 20 2 18 }
{ 0 20 5 15 } { 0 20 10 10 } { 0 20 15 5 }
{ 0 20 20 0 }
{ 5 20 20 5 } { 10 20 20 10 } { 15 20 20 15 }
{ 18 18 20 20 }
}
canvas .c -width 20 -height 20
# create a screen to hide the nonvisible parts
.c create rect $::coords_bg -fill gray -tag screen
# create the animation elements
foreach color {blue green} {
set idx 0
foreach coord $::coords_ball {
.c create oval $coord -fill $color -tags [ list $color step$idx ]
incr idx
}
puts idx:$idx
}
bind .c <Map> animate1
pack .c -expand 1EKB That's fun!
HJG Changed old "repeat" to "animate".
RAI Circles are fun, but here's a running guy:
#! /bin/env tclsh
package require Tk
proc animate2 {} {
set ::cnt [ expr { ($::cnt+1) % $::total } ]
.c raise BACKDROP
.c raise step$::cnt
after $::interval animate2
}
######################################################################
# draw a bunch of objects. make sure that all have -tags $::t
######################################################################
proc makeFrame {tag params} {
set ::t $tag ;# current tag
foreach {x0 y0 up kx ky fx fy k2x k2y f2x f2y ex ey hx hy} $params {} ;# funky tcl trick for assignment
set waist [list $x0 [expr $y0 + $up]]
set neck [add $waist [list -7 -15]] ; limb $waist $neck blue
set head [add $neck [list -2 -4]] ; limb $head [add $head [list -5 -5]] pink
set knee [add $waist [list $kx $ky]] ; limb $waist $knee blue
set foot [add $knee [list $fx $fy]] ; limb $knee $foot blue
set knee [add $waist [list $k2x $k2y]] ; limb $waist $knee blue
set foot [add $knee [list $f2x $f2y]] ; limb $knee $foot blue
set elbow [add $neck [list $ex $ey]] ; limb $neck $elbow white
set hand [add $elbow [list $hx $hy]] ; limb $elbow $hand white
}
proc x {lst} {lindex $lst 0}
proc y {lst} {lindex $lst 1}
proc add {xy1 xy2} {
return [list [expr [x $xy1]+[x $xy2]] [expr [y $xy1]+[y $xy2]]]
}
proc line {xy1 xy2 width color} {
set id [.c create line [x $xy1] [y $xy1] [x $xy2] [y $xy2] \
-width $width -capstyle round -fill $color -tags $::t ]
.c addtag limb withtag $id
if {$color == "black" } { .c addtag outline withtag $id }
if {$color == "black" } { .c lower $id 1 }
}
proc limb {xy xy2 color} {
line $xy $xy2 9 black
line $xy $xy2 6 $color
}
proc makeGiant {} {
.c config -width 400 -height 400
.c scale all 0 0 4 4
.c itemconfig limb -width 25
.c itemconfig outline -width 35
pack unpack .b
}
############################################################
# parameters for each frame. input to proc makeFrame
# x0 y0 up kx ky fx fy k2x k2y f2x f2y ex ey hx hy
set ::params {
{ 55 60 0 0 15 0 20 -8 13 13 15 7 10 -15 4}
{ 55 60 -1 2 14 9 10 -11 9 2 16 3 11 -15 1}
{ 55 60 -2 5 14 18 9 -14 5 -8 18 -2 12 -15 -2}
{ 55 60 -1 -1 13 15 12 -7 10 -4 19 3 11 -15 2}
{ 55 60 0 -8 13 13 15 0 15 0 20 7 10 -15 4}
{ 55 60 -1 -11 9 3 17 3 14 9 10 9 6 -4 9}
{ 55 60 -2 -14 5 -8 18 5 14 18 9 12 2 -7 13}
{ 55 60 -1 -7 10 -4 19 -3 14 15 12 9 6 -11 9}
}
set ::total [llength $::params]
set ::width 100
set ::height 100
set ::cnt 0
set ::interval 100
canvas .c -width $::width -height $::height
# create the animation frames
set idx 0
foreach p $::params {
makeFrame step$idx $p
incr idx
}
.c create rect 0 0 $::width $::height -fill gray -tag BACKDROP
.c scale 1 50 50 2 2 ;# make it bigger
.c create oval 10 10 30 30 -outline {} -fill yellow -tag BACKDROP ;# sun
.c create line 20 20 30 30 -fill yellow -tag BACKDROP ;# sun
.c create line 20 20 20 35 -fill yellow -tag BACKDROP ;# sun
.c create line 20 20 35 20 -fill yellow -tag BACKDROP ;# sun
.c create line 20 20 10 35 -fill yellow -tag BACKDROP ;# sun
.c create line 20 20 35 10 -fill yellow -tag BACKDROP ;# sun
button .b -text "make giant" -command makeGiant
bind .c <Map> animate2
pack .c .banalognoise: RAI, The running man didn't work for me; did Tcl 8.6 break it?
AMG: Worked fine for me in 8.6.1.
RLE (2014-09-29): Works for me in 8.6.1 as well (Slackware 14.1).