Animations on a Canvas

(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
}
demo

pw 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 1

Slightly 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 1

EKB 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 .b

analognoise: 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).