Cross Eyed?

[Sun Home | Tcl Plugin | Demos]

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!

The Source

set cx $embed_args(width)
set cy $embed_args(height)
if {[info exists embed_args(radius)]} {
   set r $embed_args(radius)
} else {
   set r 15
}
if {![info exists embed_args(eyeColor)]} {
   set embed_args(eyeColor) black
}
canvas .c -width $cx -height $cy -bg gray75
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