Version 6 of mouse gesture

Updated 2010-11-02 22:17:49 by AK

if 0 { Zarutian - Mouse gesture is an user interface interaction that invokes a command. Like in the Opera browser when you draw an L with the mouse while holding down the left mouse button you close the current tab.

Any ideas how to implement mouse gestures in tcl/tk? RS Why, of course - bind to <B1-Motion> to collect mouse pointer x/y coordinates; bind to <ButtonRelease-1> to analyze the coordinate list. One might look at ReadME - a simple online character recognizer for more ideas...

Zarutian Below is a working base for mouse-gesturing

EF I have made available a low-level library that performs mouse gesture recognition. The algorithm isn't as detailed as the one below, but it does its job. You can get it from my home page [L1 ] }

 proc mousegesture_Init {w {colour black}} {
   bind $w <1>               [list mousegesture_start %W %x %y $colour]
   bind $w <B1-Motion>       [list mousegesture_move %W %x %y ]
   bind $w <ButtonRelease-1> [list mousegesture_end %W %x %y ]
 }
 proc mousegesture_start {w x y color} {
   set ::_id [$w create line $x $y $x $y -fill $color]
   set ::_mousegesture_coords [list [list $x $y]]
 }
 proc mousegesture_move {w x y} {
   $w coords $::_id [concat [$w coords $::_id] $x $y]
   lappend ::_mousegesture_coords [list $x $y]
 }
 proc mousegesture_end {w x y} {
   $w delete $::_id
   set coords [mousegesture_proccess [set ::_mousegesture_coords]]

   foreach coord $coords {
     set x [lindex $coord 0]
     set y [lindex $coord 1]
     $w create rect [expr $x - 5] [expr $y - 5] [expr $x + 5] [expr $y + 5] -fill blue
   }
 }

 proc mousegesture_proccess {coords} {
   # version 0.3 of this proc
   # does:
   #  1. re-quantanize the coords to lower resolution
   #  2. dedect endpoints (like the three in the shape of "v")
   #puts "coords before anything: $coords"
   set coords [mousegesture_requantanize $coords 10]
   #puts "coords after requantanize: $coords"
   set coords [remove_duplicates $coords]
   #puts "coords after removeing duplicates: $coords"
   set coords [mousegesture_dedectEndpoints $coords]
   #puts "coords after dedecting endpoints: $coords"
   return $coords
 }

 proc mousegesture_requantanize {coords size_tolerance} {
   # doesnt work as intented but is definetly a keeper
   # the culprit was lsort right before the proc returned the result
   #  I only wanted to remove duplicates ;-)
   set new_coords [list]
   foreach coord $coords {
     set x [lindex $coord 0]
     set y [lindex $coord 1]
     while {($x % $size_tolerance) != 0} { incr x +1 }
     while {($y % $size_tolerance) != 0} { incr y +1 }
     lappend new_coords [list $x $y]
   }
   return [lsort -unique [set new_coords]]
 }

 proc mousegesture_requantanize {coords size_tolerance} {
   # size_tolerance might require a little tuneing
   # $delta ætti að helminga til að færa hnitin í miðju en ekki út í kant uppi og hægra meiginn
   set new_coords [list]
   foreach coord $coords {
     set x [lindex $coord 0]
     set y [lindex $coord 1]
     if {[set delta [expr ($x % $size_tolerance)]] != 0} { set x [expr $x - $delta] }
     if {[set delta [expr ($y % $size_tolerance)]] != 0} { set y [expr $y - $delta] }    
     lappend new_coords [list $x $y]
   }
   return [set new_coords]
 }
 proc remove_duplicates {list} {
   # remove duplicates but otherwise perserve the ordering of the list
   set new_list [list]
   foreach item $list {
     if {![info exists temp($item)]} {
       lappend new_list $item
       set temp($item) 1
     }
   }
   return $new_list
 } 

 proc mousegesture_dedectEndpoints {coords} {
   # did we change direction? if so then add where we changed direction to the list
   # this proc is close but yet so even far
   # should be rewritten
   set new_coords [list]
   set last_x 0
   set last_y 0
   set last_dir_x 0
   set last_dir_y 0
   foreach coord $coords {
     set x [lindex $coord 0]
     set y [lindex $coord 1]
     set dir_x [expr ($x < $last_x) ? -1 : +1 ]
     set dir_x [expr ($x == $last_x) ? 0 : $dir_x ]
     set dir_y [expr ($y < $last_y) ? -1 : +1 ]
     set dir_y [expr ($x == $last_y) ? 0 : $dir_y ]
     if {($dir_x != $last_dir_x) || ($dir_y != $last_dir_y)} {
       lappend new_coords [list $last_x $last_y ]
     }
     # puts "($coord) $dir_x $dir_y $last_dir_x $last_dir_y"

     set last_dir_x $dir_x
     set last_dir_y $dir_y
    set last_x $x
    set last_y $y
  }
  lappend new_coords [lindex $coords end]
  return [lrange $new_coords 1 end]
 }

 pack [canvas .c -bg white] -fill both -expand 1
 mousegesture_Init .c
 # the blue rectangles are centered on the coords of the endpoints

JKB I recently started looking at using mouse gestures in a canvas and knocked up the following simple prototype. It's not in a proper package or even a namespace, but I think the algorithm works and it demonstrates just how short Tcl/Tk can make things.

 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