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 endpointsJKB 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