#!/bin/sh
exec wish "$0" ${1+"$@"}
package require Tkspline
package require Tclpathplan
set splinecolor orange
set showmouse off
proc nextpoint {vc c wx wy} {
global id mode oldx oldy gain0 angle0 index grid
set x [$c canvasx $wx]
set y [$c canvasy $wy]
set gx [expr $grid * int(($x / $grid) + 0.5)]
set gy [expr $grid * int(($y / $grid) + 0.5)]
switch $mode {
draw {
if [info exists id] {
$c insert $id 0 [list $gx $gy]
} {
set id [$c create polygon $gx $gy $gx $gy \
-fill red -outline }
}
stretch {
if [info exists id] {
$c insert $id $index [list $gx $gy]
} {
set id [$c find withtag current]
if {$id == {}} {
unset id
} {
set index [$c index $id @$x,$y]
$c dchars $id $index
$c insert $id $index [list $gx $gy]
}
}
}
collapse {
set id [$c find withtag current]
if {$id != {}} {
set index [$c index $id @$x,$y]
if {[llength [$c coords $id]] > 4} {$c dchars $id $index}
$vc coords [lindex [$c gettags $id] 0] [$c coords $id]
}
unset id
}
clone {
if [info exists id] {
set tag [$vc insert [$c coords $id]]
$c addtag $tag withtag $id
}
set t [$c find withtag current]
if {$t != {}} {
set id [$c create [$c type $t] [$c coords $t]]
foreach config [$c itemconfigure $t] {
foreach {config . . . val} $config {break}
if {$config != "-tags"} {
$c itemconfigure $id $config $val
}
}
set oldx $gx
set oldy $gy
}
}
move {
set id [$c find withtag current]
if {$id == {}} {
$c scan mark $wx $wy
} {
set oldx $gx
set oldy $gy
}
}
scale {
set id [$c find withtag current]
if {$id == {}} {
unset id
} {
foreach {oldx oldy} \
[$vc center [lindex [$c gettags $id] 0]] {break}
set dx [expr $oldx-$x]
set dy [expr $oldy-$y]
set gain0 [expr sqrt($dx*$dx+$dy*$dy)]
}
}
rotate {
set id [$c find withtag current]
if {$id == {}} {
unset id
} {
foreach {oldx oldy} [$vc center [lindex [$c gettags $id] 0]] {
break
}
set angle0 [expr atan2($x-$oldx, $oldy-$y)]
}
}
path {
if [info exists id] {
set path [$c coords $id]
if [catch {$vc path $path} path] {
puts $path
} {
$c coords $id $path
$c itemconfigure $id -fill red
set id [$c create line $x $y $x $y \
-fill red -state disabled]
}
} {
set id [$c create line $gx $gy $gx $gy \
-fill red -state disabled]
}
}
bpath {
if [info exists id] {
set path [$c coords $id]
if [catch {$vc bpath $path} path] {
puts $path
} {
$c coords $id $path
$c itemconfigure $id -fill orange
set id [$c create line $x $y $x $y \
-smooth spline -fill orange -state disabled]
}
} {
set id [$c create line $gx $gy $gx $gy \
-smooth spline -fill orange -state disabled]
}
}
delete {
$vc remove [lindex [$c gettags current] 0]
$c delete current
}
triangulate {
global mode
if {[$vc bind triangle] == {}} {
$vc bind triangle {
if {$mode == "triangulate"} {
$c create polygon %t -tag triangles \
-fill {} -outline white -width 2
} {
$c create polygon %t -tag triangles \
-fill {} -outline white -width 2 -state hidden
}
}
}
if {$mode == "triangulate"} {
$c itemconfigure triangles -state normal
} {
$c itemconfigure triangles -state hidden
}
set t [$vc find $x $y]
if {$t != {}} {
$vc triangulate $t
}
}
id {
set t [$vc find $x $y]
if {$t == {}} {
puts "at: $x $y ....nothing"
} {
puts "at: $x $y\nid: $t\ncoords: [$vc coords $t]"
}
}
}
}
proc lastpoint {vc c args} {
global id mode
if [info exists id] {
switch $mode {
draw {
$c itemconfigure $id -fill darkgreen \
-outline yellow -activeoutline set tag [$vc insert [$c coords $id]]
$c addtag $tag withtag $id
}
clone {
set tag [$vc insert [$c coords $id]]
$c addtag $tag withtag $id
}
move - stretch - rotate - scale {
set t [lindex [$c gettags $id] 0]
if {$t != {} && $t != "current"} {
$vc coords $t [$c coords $id]
}
}
path {
set path [$c coords $id]
if [catch {$vc path $path} path] {
puts $path
$c delete $id
} {
$c coords $id $path
$c itemconfigure $id -fill
}
}
bpath {
set path [$c coords $id]
if [catch {$vc bpath $path} path] {
puts $path
$c delete $id
} {
$c coords $id $path
$c itemconfigure $id -fill red
}
}
}
$c configure -scrollregion [$c bbox all]
unset id
}
}
proc motion {vc c wx wy} {
global id mode oldx oldy gain0 angle0 index grid showmouse
set x [$c canvasx $wx]
set y [$c canvasy $wy]
if {$showmouse == "on"} {
puts -nonewline stderr "\r$x,$y [list [$vc find $x $y]] "
}
if [info exists id] {
switch $mode {
draw {
set gx [expr $grid * int(($x / $grid) + 0.5)]
set gy [expr $grid * int(($y / $grid) + 0.5)]
$c dchars $id 0
$c insert $id 0 [list $gx $gy]
}
path {
$c dchars $id 0
$c insert $id 0 [list $x $y]
}
bpath {
$c dchars $id 0
$c insert $id 0 [list $x $y]
}
move - clone {
if {$id == {}} {
$c scan dragto $wx $wy 1
} {
set gx [expr $grid * int(($x / $grid) + 0.5)]
set gy [expr $grid * int(($y / $grid) + 0.5)]
$c move $id [expr $gx - $oldx] [expr $gy - $oldy]
set oldx $gx
set oldy $gy
}
}
stretch {
set gx [expr $grid * int(($x / $grid) + 0.5)]
set gy [expr $grid * int(($y / $grid) + 0.5)]
$c dchars $id $index
$c insert $id $index [list $gx $gy]
}
scale {
set t [lindex [$c gettags $id] 0]
set dx [expr $x-$oldx]
set dy [expr $y-$oldy]
set gain [expr sqrt($dx*$dx+$dy*$dy)/20]
$c coords $id [$vc scale $t $gain]
}
rotate {
set t [lindex [$c gettags $id] 0]
set alpha [expr atan2($x-$oldx,$oldy-$y) - $angle0]
$c coords $id [$vc rotate $t $alpha]
}
}
}
}
proc clearpaths {vc c} {
catch { $c delete triangles }
foreach i [$c find all] {
set t [$c type $i]
if {$t == "line"} {$c delete $i}
}
}
proc clearall {vc c} {
catch { $c delete triangles }
foreach i [$c find all] {
if {[$c type $i] == "polygon"} {$vc remove [lindex [$c gettags $i] 0]}
$c delete $i
}
}
proc loadpaths {vc c file} {
if [catch {open $file r} f] {
error "unable to open file for read: $file"
}
clearpaths $vc $c
while {![eof $f]} {
set path [gets $f]
if {$path == {}} {continue}
if [catch {$vc bpath $path} path] {
puts $path
} {
$c create line $path \
-smooth spline -fill }
}
close $f
$c configure -scrollregion [$c bbox all]
}
proc loadvconfig {vc c file} {
if [catch {open $file r} f] {
error "unable to open file for read: $file"
}
clearall $vc $c
while {![eof $f]} {
set coords [string trim [gets $f]]
if {$coords == {}} {continue}
set tag [$vc insert $coords]
$c create polygon $coords \
-tag $tag \
-fill darkgreen \
-outline yellow \
-activeoutline }
close $f
$c configure -scrollregion [$c bbox all]
}
proc savepaths {vc c file} {
if [catch {open $file w} f] {
error "unable to open file for write: $file"
}
foreach i [$c find all] {
set t [$c type $i]
if {$t == "line"} {
set path [$c coords $i]
set l [llength $path]
set x1 [lindex $path 0]
set y1 [lindex $path 1]
set x2 [lindex $path [incr l -2]]
set y2 [lindex $path [incr l]]
puts $f "$x1 $y1 $x2 $y2"
}
}
close $f
}
proc savevconfig {vc c file} {
if [catch {open $file w} f] {
error "unable to open file for write: $file"
}
foreach id [$vc list] {
puts $f [$vc coords $id]
}
close $f
}
proc nextfile {} {
global filename
set filename [file join [file dirname $filename] [file tail $filename]]
set files [glob [file join [file dirname $filename] *[file extension $filename]]]
set filename [lindex $files [expr ([lsearch $files $filename] + 1) % [llength $files]]]
}
set vc [vgpane]
set mode draw
set filename "pathplan_data/unknown.dat"
frame .fl
set a [frame .fl.a]
set b [frame .fl.b]
set c [canvas $a.c \
-relief sunken \
-borderwidth 2 \
-bg lightblue \
-xscrollcommand "$b.h set" \
-yscrollcommand "$a.v set"]
scrollbar $b.h -command "$c xview" -orient horiz
scrollbar $a.v -command "$c yview"
frame $b.pad \
-width [expr [$a.v cget -width] + \
[$a.v cget -bd]*2 + [$a.v cget -highlightthickness]*2 ] \
-height [expr [$b.h cget -width] + \
[$b.h cget -bd]*2 + [.fl.b.h cget -highlightthickness]*2 ]
frame .fr
frame .fr.bpath
pack [radiobutton .fr.bpath.bpath -text "bezier path" -value bpath \
-highlightthickness 0 -anchor w -variable mode] \
-side left -anchor w -fill x
pack [scale .fr.grid -orient horizontal -label grid -variable grid \
-highlightthickness 0 -from 1 -to 100] \
[radiobutton .fr.draw -text draw -value draw \
-highlightthickness 0 -anchor w -variable mode] \
[radiobutton .fr.stretch -text stretch -value stretch \
-highlightthickness 0 -anchor w -variable mode] \
[radiobutton .fr.collapse -text collapse -value collapse \
-highlightthickness 0 -anchor w -variable mode] \
[radiobutton .fr.clone -text clone -value clone \
-highlightthickness 0 -anchor w -variable mode] \
[radiobutton .fr.move -text move -value move \
-highlightthickness 0 -anchor w -variable mode] \
[radiobutton .fr.rotate -text rotate -value rotate \
-highlightthickness 0 -anchor w -variable mode] \
[radiobutton .fr.scale -text scale -value scale \
-highlightthickness 0 -anchor w -variable mode] \
[radiobutton .fr.delete -text delete -value delete \
-highlightthickness 0 -anchor w -variable mode] \
[radiobutton .fr.path -text path -value path \
-highlightthickness 0 -anchor w -variable mode] \
.fr.bpath \
[radiobutton .fr.id -text id -value id \
-highlightthickness 0 -anchor w -variable mode] \
[radiobutton .fr.triangulate -text triangulate -value triangulate \
-highlightthickness 0 -anchor w -variable mode] \
-anchor w -fill x
frame .fr.load
pack [button .fr.load.load -text load \
-highlightthickness 0 -command "loadvconfig $vc $c \$filename"] \
[button .fr.load.paths -text loadpaths \
-highlightthickness 0 -command "loadpaths $vc $c \$filename"] \
-side left -fill x -expand true
frame .fr.save
pack [button .fr.save.save -text save \
-highlightthickness 0 -command "savevconfig $vc $c \$filename"] \
[button .fr.save.paths -text savepaths \
-highlightthickness 0 -command "savepaths $vc $c \$filename"] \
-side left -fill x -expand true
frame .fr.clear
pack [button .fr.clear.all -text clear -command "clearall $vc $c" \
-highlightthickness 0] \
[button .fr.clear.paths -text clearpaths -command "clearpaths $vc $c" \
-highlightthickness 0] \
-side left -fill x -expand true
frame .fr.file
pack [entry .fr.file.name -textvar filename -highlightthickness 0] \
-side left -fill x -expand true
pack [button .fr.file.next -text next \
-highlightthickness 0 -command "nextfile"] \
-side left
frame .fr.quitdebug
pack [button .fr.quitdebug.debug -text debug \
-highlightthickness 0 -command "$vc debug"] \
[button .fr.quitdebug.quit -text quit \
-highlightthickness 0 -command "exit"] \
-side left -fill x -expand true
pack .fr.quitdebug .fr.clear .fr.save .fr.load .fr.file \
[label .fr.flabel -anchor w -text "file"] \
[entry .fr.coordinates -textvar coordinates -highlightthickness 0] \
[label .fr.clabel -anchor w -text "coordinates"] \
-side bottom -fill x -expand true
pack $a.v -side right -fill y
pack $c -side left -fill both -expand true
pack $b.h -side left -fill x -expand true
pack $b.pad -side right
pack $b -side bottom -fill x
pack $a -side top -fill both -expand true
pack .fl -side left -fill both -expand true
pack .fr -side left -fill y
bind $c <1> "nextpoint $vc $c %x %y"
bind $c <2> "lastpoint $vc $c"
bind $c <Motion> "motion $vc $c %x %y"
trace variable mode w "lastpoint $vc $c"
bind .fr.file.name <Return> {
.fr.loadsave.load flash
loadvconfig $vc $c $filename
}
bind .fr.coordinates <Return> {
if {$coordinates == {}} {continue}
set coords [split $coordinates]
set coordinates {}
switch $mode {
draw {
if [catch {$vc insert $coords} tag] {
puts $tag
} {
$c create polygon $coords \
-fill darkgreen \
-outline yellow \
-activeoutline -tag $tag
}
}
path {
if [catch {$vc path $coords} coords] {
puts $coords
} {
$c create line $coords -fill }
}
bpath {
if [catch {$vc bpath $coords} coords] {
puts $coords
} {
$c create line $coords \
-smooth spline -fill orange -state disabled
}
}
}
}
proc balloon_help {w msg} {
bind $w <Enter> "after 1000 \"balloon_help_aux %W [list $msg]\""
bind $w <Leave> "after cancel \"balloon_help_aux %W [list $msg]\"
catch {destroy %W.balloon_help}"
}
proc balloon_help_aux {w msg} {
set t $w.balloon_help
catch {destroy $t}
toplevel $t
wm overrideredirect $t 1
pack [label $t.l -text $msg -relief groove -bd 1 -bg yellow] -fill both
wm geometry $t +[expr [winfo rootx $w]+([winfo width $w]/2)]+[expr \
[winfo rooty $w]+([winfo height $w]/2)]
}
balloon_help .fr.grid "set grid size for draw operations"
balloon_help .fr.draw "draw a region. B1 foreach vertex except B2 for last"
balloon_help .fr.stretch "B1 to stretch a vertex, next B1 inserts new vertex. B2 to end"
balloon_help .fr.collapse "B1 collapses a vertex"
balloon_help .fr.clone "each B1 creates a new clone of a region, B2 to end"
balloon_help .fr.move "B1 to move, B2 to end"
balloon_help .fr.rotate "B1 to rotate, B2 to end"
balloon_help .fr.scale "B1 to scale, B2 to end"
balloon_help .fr.delete "B1 to delete a region"
balloon_help .fr.path "B1 starts a euclidean shortest path, B2 to end"
balloon_help .fr.bpath.bpath "B1 starts a bezier spline path, B2 to end"
balloon_help .fr.triangulate "B1 to display triangulation of a polygon"
balloon_help .fr.id "print the identifier of a region"
balloon_help .fr.coordinates "text entry of coordinates, alternative to button operations"
balloon_help .fr.file.name "current file name, or enter new name"
balloon_help .fr.file.next "next file with same directory and extension"
balloon_help .fr.save.paths "save paths to file"
balloon_help .fr.load.paths "load paths from file"
balloon_help .fr.save.save "save regions to file"
balloon_help .fr.load.load "load regions from file"
balloon_help .fr.clear.all "clear canvas of all regions and paths"
balloon_help .fr.clear.paths "clear canvas of all paths"
balloon_help .fr.quitdebug.quit "quit this application"
balloon_help .fr.quitdebug.debug "dump the vconfig"