Here's another Tcl application that demonstrates Tcl's interactive
feedback. Move the mouse around inside the square and watch those eyes
follow your mouse cursor. Then give those eyes a rest when you move
the mouse out of the square.
P.S. Yes, those eyes really do blink!
Source
set cx 400
set cy 400
set r 15
if {[info exists embed_args(width)]} { set cx $embed_args(width) }
if {[info exists embed_args(height)]} { set cy $embed_args(height) }
if {[info exists embed_args(radius)]} { set r $embed_args(radius) }
if {![info exists embed_args(eyeColor)]} { set embed_args(eyeColor) black }
canvas .c -width $cx -height $cy -bg white
pack .c
set eye1(x) [expr $cx/2-4*$r]
set eye1(y) [expr $cy/2]
set eye2(x) [expr $cx/2+4*$r]
set eye2(y) [expr $cy/2]
proc makeeye {x y} {
global r embed_args
set b [.c create oval [expr $x-3*$r] [expr $y-4*$r] [expr $x+3*$r] \
[expr $y+4*$r] -width 3 -fill white -outline black]
set a [.c create oval [expr $x-$r] [expr $y-$r] [expr $x+$r] [expr $y+$r] \
-fill $embed_args(eyeColor) -outline {}]
.c bind $a <Enter> ".c itemconfig $a -fill red"
.c bind $a <Leave> ".c itemconfig $a -fill $embed_args(eyeColor)"
return [list $a $b]
}
proc moveeye {eyename x y} {
global r embed_args
upvar #0 $eyename eye
set x [expr $x-$eye(x)]
set y [expr $y-$eye(y)]
set l [expr sqrt($x*$x+$y*$y)]
if $l<$r {
set cx $x
set cy $y
} else {
set cx [expr $r*$x/$l]
set cy [expr $r*$y/$l]
}
.c coords $eye(id) [expr $cx-$r+$eye(x)] [expr $cy-$r+$eye(y)] \
[expr $cx+$r+$eye(x)] [expr $cy+$r+$eye(y)]
}
proc blink {} {
global eyesOpen bigEye blinklist blinklength blinkindex eye1 eye2
if {$eyesOpen == 1} {
set eyesOpen 0
.c itemconfigure $bigEye(0) -fill black
.c itemconfigure $bigEye(1) -fill black
.c lower $eye1(id)
.c lower $eye2(id)
after 200 blink
} else {
set delay [lindex $blinklist $blinkindex]
incr blinkindex
if {$blinkindex >= $blinklength} {
set blinkindex 0
}
set eyesOpen 1
.c itemconfigure $bigEye(0) -fill white
.c itemconfigure $bigEye(1) -fill white
.c raise $eye1(id)
.c raise $eye2(id)
after $delay blink
}
}
set blinklist {
500 5000 2000 3000 10000 2000 3000 2000 500 200 3000 500 1000
2000 300 300 2000 8000 2000 400 400 2000
}
set blinklength [llength $blinklist]
set blinkindex 0
set eyesOpen 1
set eye [makeeye $eye1(x) $eye1(y)]
set eye1(id) [lindex $eye 0]
set bigEye(0) [lindex $eye 1]
set eye [makeeye $eye2(x) $eye2(y)]
set eye2(id) [lindex $eye 0]
set bigEye(1) [lindex $eye 1]
bind all <Motion> "moveeye eye1 %x %y; moveeye eye2 %x %y"
after 1000 blink
