where-vessels: can acquire

diff --git a/yarrg/where-vessels b/yarrg/where-vessels
index c0252a09a2981f4e49c91835897cb75d7044e2ee..8886c7997aeb24de0adccb7a480803b3f6cf0d31 100755 (executable)
--- a/yarrg/where-vessels
+++ b/yarrg/where-vessels
@@ -278,6 +278,8 @@ proc chart-got/league {x1 y1 x2 y2 kind} {
 proc draw {} {
     global chart count isleloc canvas
     
+    $canvas delete all
+
     foreach l [split $chart "\n"] {
 #      debug "CHART-GOT $l"
        set proc [lindex $l 0]
@@ -320,7 +322,7 @@ proc draw {} {
 #---------- user interface ----------
 
 proc widgets-setup {} {
-    global canvas debug
+    global canvas debug acqdeffont
 
     frame .f -border 1 -relief groove
     set canvas .f.c
@@ -344,6 +346,20 @@ proc widgets-setup {} {
     button .ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2}
     pack .ctrl.zoom.out .ctrl.zoom.in -side left
 
+    frame .ctrl.acquire
+    button .ctrl.acquire.do -text Acquire -command acquire
+
+    frame .ctrl.acquire.resframe -width 120 -height 32
+    button .ctrl.acquire.resframe.res -text {} -anchor nw \
+       -padx 1 -pady 1 -borderwidth 0 -justify left
+    glset acqdeffont [.ctrl.acquire.resframe.res cget -font]
+    place .ctrl.acquire.resframe.res -relx 0.5 -y 0 -anchor n
+    #  -relheight 1.0 -relwidth 1.0
+
+    pack .ctrl.acquire.do -side top
+    pack .ctrl.acquire.resframe -side top -expand y -fill both
+    pack .ctrl.acquire -side top
+
     wm geometry . 1024x480
 }
 
@@ -353,7 +369,37 @@ proc zoom {extail} {
     debug "ZOOM $scale $nscale"
     if {$nscale < 1 || $nscale > 200} return
     set scale $nscale
-    $canvas delete all
+    draw
+}
+
+proc acquire_showerror {} {
+    global acqerr
+    tk_messageBox -type ok \
+       -title "where-vessels: clipboard parsing error" \
+       -message $acqerr
+}
+
+proc acquire {} {
+    global clipboard acqdeffont acqerr
+    set old $clipboard
+    if {[catch {
+       set clipboard [clipboard get]
+       parse-clipboard
+       .ctrl.acquire.resframe.res configure \
+           -background blue -disabledforeground black -font $acqdeffont \
+           -state disabled -command {} \
+           -text " acquired ok "
+    } emsg]} {
+       set acqerr "clipboard parsing failed: $emsg"
+       puts stderr $acqerr
+       regsub -all {.{18}} "error: [string trim $emsg]" "&\n" ewrap
+       .ctrl.acquire.resframe.res configure \
+           -background red -foreground white -font fixed \
+           -state normal -command acquire_showerror \
+           -text $ewrap
+       set clipboard $old
+       parse-clipboard
+    }
     draw
 }