Cross Eyed?

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