Version 0 of Tkeyes

Updated 2012-07-30 01:45:37 by pooryorick

xeyes clone for Tk

#! /bin/env tclsh

proc eyes {canvas cx cy radius {xmove 1} {ymove 1}} {
        set state state::[clock clicks]
        namespace eval $state {
                variable pupilfactor .4
                variable wobble .25 
        }
        set ${state}::xmove $xmove
        set ${state}::ymove $ymove
        set ${state}::radius $radius
        set eyedist [expr {$radius * 1.25}]
        set ecx [expr {$cx - $eyedist}]
        eye $state $canvas $ecx $cy left
        set ecx [expr {$cx + $eyedist}]
        eye $state $canvas $ecx $cy right

        return $state
}

proc eye {state canvas x y tag} {
        namespace upvar $state radius radius
        namespace upvar $state pupilfactor pupilfactor
        $canvas create oval [expr $x - $radius] [expr {$y - $radius}] \
                [expr $x + $radius] [expr {$y + $radius}] -fill white \
                -tags ${tag}eye

        set pupilradius [expr {$radius * $pupilfactor}]
        set ${state}::pupilradius $pupilradius

        $canvas create oval [expr {$x - $pupilradius}] [expr {$y - $pupilradius}] \
                [expr {$x + $pupilradius}] [expr {$y + $pupilradius}] -fill black \
                -tags ${tag}pupil

}

proc distance {xfrom yfrom xto yto} {
        if {$xfrom > $xto} {
                foreach {xfrom xto} [list $xto $xfrom] {}
                set xsign -1
        } else {
                set xsign 1
        }
        if {$yfrom > $yto} {
                foreach {yfrom yto} [list $yto $yfrom] {}
                set ysign -1
        } else {
                set ysign 1
        }
        set xlen [expr {($xto - $xfrom) * $xsign}]
        set ylen [expr {($yto - $yfrom) * $ysign}]
        return [list $xlen $ylen [expr sqrt($xlen**2 + $ylen**2)]]
}

proc center {x1 y1 x2 y2} {
        set res [list [expr $x1 + ($x2 - $x1)/2] [expr $y1 + ($y2 - $y1)/2]]
        return $res
}

proc movement {state canvas eye pupil mx my} {
        namespace upvar $state radius radius 
        namespace upvar $state pupilradius pupilradius
        namespace upvar $state wobble wobble
        namespace upvar $state xmove myxmove
        namespace upvar $state xmove myymove

        if {$wobble} {
                set xmove [expr {rand()>0.5?$wobble:-$wobble}] 
                set ymove [expr {rand()>0.5?$wobble:-$wobble}] 
        } else {
                set xmove 0
                set ymove 0
        }

        set eyecenter [center {*}[$canvas coords $eye]]
        foreach {eyecenterx eyecentery} $eyecenter {}
        set pupilcenter [center {*}[$canvas coords $pupil]]
        foreach {pupilcenterx pupilcentery} $pupilcenter {}

        foreach {xdist ydist hypotenuse} [distance {*}$eyecenter $mx $my] {
                set base [expr {abs($xdist)}]
                set height [expr {abs($ydist)}]
        }
        set newhypotenuse [expr {$radius - $pupilradius}]

        if {$hypotenuse <= $newhypotenuse} {        
                set xtarget $mx
                set ytarget $my
        } else {
                #find the target point on $newradius
                if {$base} {
                        set sine [expr {abs(sin(atan(double($height) / $base)))}]
                        set cosine [expr {abs(cos(atan(double($height) / $base)))}]
                        set newheight [expr {$sine * $newhypotenuse}]
                        set newbase [expr {$cosine * $newhypotenuse}]
                } else {
                        set newheight $newhypotenuse
                        set newbase $base 
                }
                if {$mx < $eyecenterx} {
                        set xtarget [expr $eyecenterx - $newbase]
                } else {
                        set xtarget [expr $eyecenterx + $newbase]
                }
                if {$my < $eyecentery} {
                        set ytarget [expr $eyecentery - $newheight]
                } else {
                        set ytarget [expr $eyecentery + $newheight]
                }
        }
        #$canvas coords target [list [expr {$xtarget -1}] [expr {$ytarget -1}] \
        #    [expr {$xtarget +1}] [expr {$ytarget+1}]]
        #$canvas coords los {*}$eyecenter $mx $my

        if {$pupilcenterx < $xtarget && ($pupilcenterx+1 <= $xtarget)} {
                set xmove $myxmove 
        } elseif {$pupilcenterx > $xtarget && ($pupilcenterx-1 >= $xtarget)} {
                set xmove [expr {-$myxmove}]
        }
        if {$pupilcentery < $ytarget && ($pupilcentery+1 <= $ytarget)} {
                set ymove $myymove
        } elseif {$pupilcentery > $ytarget && ($pupilcentery-1 >=$ytarget)} {
                set ymove [expr {-$myymove}]
        }
        return [list $xmove $ymove]
}

proc moveit {state epoch canvas} {
        lassign [winfo pointerxy .] mx my
        set offsetx [winfo rootx $canvas]
        set offsety [winfo rooty $canvas]
        set mx [expr {$mx - $offsetx}]
        set my [expr {$my - $offsety}]
        if {$epoch != $::epoch} {
                return 0
        }
        set again 0
        foreach {eye pupil} {righteye rightpupil lefteye leftpupil} {
                foreach {xmove ymove} [movement $state $canvas $eye $pupil $mx $my] {}
                if {$xmove || $ymove} {
                        $canvas move $pupil $xmove $ymove
                        set again 1
                }
        }
        update idletasks
        if {$again} {
                after 0 [list moveit $state $epoch $canvas]
        }
}

variable height 800
variable width 800 
package require Tk

#this didn't work
#wm attributes . -alpha .25

canvas .canvas1 -height $height -width $width -bg black
grid .canvas1

namespace eval state {}

set mystate [eyes .canvas1 [expr {$width / 2}] [expr {$height /2}] [expr {$width * .10}]]
bind . <Motion> {moveit $mystate [incr epoch] .canvas1}