gesture

proc gesture_init {w} {
    bind $w <1>               "gesture_start $w %x %y"
    bind $w <B1-Motion>       "gesture_move $w %x %y"
    bind $w <ButtonRelease-1> "gesture_end $w"
 }

 proc gesture_start {w x y} {
    global $w.GestureX $w.GestureY $w.Dirs
    set $w.GestureX $x
    set $w.GestureY $y
    set $w.Dirs ""
 }

 proc gesture_move {w x y} {
    global $w.GestureX $w.GestureY $w.Dirs
    set dx [expr {$x-[set $w.GestureX]}]
    set dy [expr {$y-[set $w.GestureY]}]
    if {abs($dx)+abs($dy) < 20} return
    if {[expr {abs(abs($dx)-abs($dy))}] < 10} return
    set dir [expr {abs($dx) > abs($dy) ? ($dx>0?"R":"L") : ($dy>0?"D":"U")}]
    if {$dir != [lindex [set $w.Dirs] end]} {
        lappend $w.Dirs $dir
    }
    $w create line [set $w.GestureX] [set $w.GestureY] $x $y -tags GESTURE
    set $w.GestureX $x
    set $w.GestureY $y
 }

 proc gesture_end {w} {
    global $w.Dirs
    $w delete GESTURE
    puts [set $w.Dirs]
 }

 pack [label .l -textvariable .c.Dirs] -fill both
 pack [canvas .c] -fill both -expand 1
 gesture_init .c