Source code:
#-------------------------------------------------------- # An "animated puppy" application on the canvas widget. # The user drags a bone with the mouse, the puppy's eyes # follow it and pants. An example of how to create interactive # pictures on the canvas widget. By Hattie Schroeder. # # Copyright (c) 1997 Eolas Technologies Inc. # Freely modifiable/redistributable under the "Standard Tcl License" # See http://www.eolas.com/tcl/license.txt for details #-------------------------------------------------------- #-------------------------------------------------------- # Colors the tongue, moves eyes #-------------------------------------------------------- proc move_eyes { x y } { tongue .c coords eyel 155 155 165 165 .c coords eyer 205 155 215 165 if {$x > 225} { set x 5 } elseif {$x > 150} { set x 0 } else { set x -5 } if {$y > 175} { set y 5 } elseif { $y > 150} { set y 0 } else { set y -5 } .c move eyel $x $y .c move eyer $x $y } #-------------------------------------------------------- # Moves bone with the x y coordinates of the mouse. #-------------------------------------------------------- proc move_bone { x y } { global draglocation move_eyes $x $y set dx [expr $x - $draglocation(x)] set dy [expr $y - $draglocation(y)] .c move bone $dx $dy set draglocation(x) $x set draglocation(y) $y } #-------------------------------------------------------- # Picks up the bone and moves the eyes #-------------------------------------------------------- proc grab_bone { x y } { global draglocation move_eyes $x $y set draglocation(x) $x set draglocation(y) $y } #-------------------------------------------------------- # Colors the tongue and hides it again. #-------------------------------------------------------- proc pant { } { no_tongue for {set i 100} {$i < 1000} {incr i 100} { after $i {tongue} incr i 100 after $i { no_tongue} } } #-------------------------------------------------------- # Procedures to color or hide the tongue #-------------------------------------------------------- proc no_tongue { } { .c itemconfigure tongue -outline white \ -fill white .c itemconfigure tongueline -fill white } proc tongue { } { .c itemconfigure tongue -outline black \ -fill red .c itemconfigure tongueline -fill black } #--------------------------------------------------- # Creates the parent canvas widget. #---------------------------------------------------- canvas .c -height 500 -width 500 -background white pack .c #----------------------------------------------------- # Creates the eyes. Notice the patch is listed last in # the display list with the command ".c lower patch", so # it won't cover up the other elements of the eye. #----------------------------------------------------- .c create oval 150 150 175 175 -outline black -fill white .c create oval 200 150 225 175 -outline black -fill white .c create oval 155 155 165 165 -fill black -tag eyel .c create oval 205 155 215 165 -fill black -tag eyer .c create oval 140 130 180 200 -outline black \ -fill black -tag patch .c lower patch #----------------------------------------------------- # Creates the tongue. The parts of the tongue are # initially the same color as the background. The # procedures of the application will # change their color, causing them to appear. #----------------------------------------------------- .c create arc 180 215 200 245 -style pieslice \ -extent 180 -start 180 -tag tongue \ -outline white -fill white .c create line 190 235 190 245 -tag tongueline \ -fill white #----------------------------------------------- # Creates the smile #------------------------------------------------- .c create arc 150 200 225 230 -style arc \ -extent 180 -start 180 -tag smile \ -outline black #------------------------------------------------ # Creates the nose. The nostrils are 4 pixels wide. # Notice the -smooth attribute determines the # polygon will be curved. #------------------------------------------------- .c create polygon 180 188 180 184 184 180 188 180 190\ 184 192 180 196 180 200 184 200 188 \ -outline black -fill black -smooth 1 .c create oval 184 184 188 188 -fill white .c create oval 192 184 196 188 -fill white .c create line 190 188 190 215 #-------------------------------------------------- # Creates the ears. #--------------------------------------------------- .c create polygon 100 140 110 130 120 130 130 135 140 140 140 150 120 145 125 190 120 200 110 210 100 210 90 200 -fill black -smooth 1 .c create polygon 230 140 250 130 260 130 270 140 280 200 270 210 260 210 250 200 245 190 250 145 230 150 -fill black -smooth 1 #------------------------------------------------- # Creates the bone #-------------------------------------------------- .c create polygon \ 5 10 10 5 15 5 20 10 20 15 45 15 45 10 \ 50 5 55 5 60 10 60 15 55 20 60 25 60 30 \ 55 35 50 35 45 30 45 25 20 25 20 30\ 15 35 10 35 5 30 5 25 10 20 5 15 \ -fill white -outline black -tag bone -smooth 1 #------------------------------------------------- # Bindings for the bone polygon #-------------------------------------------------- .c bind bone {grab_bone %x %y} .c bind bone {move_bone %x %y} .c bind bone {pant}