X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?a=blobdiff_plain;f=yarrg%2Fwhere-vessels;h=50c38b3595e0f399ba4f8e61590bb06136bba099;hb=ca7f7a582f148a9e7d5e182451b59c4b2b151389;hp=a8278925d0bf2302f6ce1d0904db604744329e58;hpb=c915c378bbed129861c419f671913f0113150007;p=ypp-sc-tools.web-live.git

diff --git a/yarrg/where-vessels b/yarrg/where-vessels
index a827892..50c38b3 100755
--- a/yarrg/where-vessels
+++ b/yarrg/where-vessels
@@ -1,14 +1,40 @@
 #!/usr/bin/wish
 
-set us Aristarchus
+source yarrglib.tcl
+source panner.tcl
 
-proc manyset {list args} {
-    foreach val $list var $args {
-        upvar 1 $var my
-        set my $val
+set pirate { }
+
+proc badusage {m} {
+    puts stderr "where-vessels: bad usage: $m"
+    exit 1
+}
+
+set ai 0
+proc nextarg {} {
+    global ai argv
+    if {$ai >= [llength $argv]} {
+	badusage "option [lindex $argv [expr {$ai-1}]] needs a value"
     }
+    set v [lindex $argv $ai]
+    incr ai
+    return $v
 }
 
+while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
+    incr ai
+    switch -exact -- $arg {
+	-- { break }
+	--pirate { set pirate [string totitle [nextarg]] }
+	--ocean { set ocean [string totitle [nextarg]] }
+	--clipboard-file { set clipboard_file [nextarg] }
+	--notes { set notes_loc [nextarg] }
+	default { badusage "unknown option $arg" }
+    }
+}
+set argv [lrange $argv $ai end]
+if {[llength $argv]} { badusage "non-option args not allowed" }
+    
 set itemre { (\w+) = ([^=]*) }
 set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
 puts $manyitemre
@@ -24,7 +50,7 @@ while {[gets $vn l] >= 0} {
 close $vn
 
 proc vessel {vin} {
-	global us
+	global pirate
 	upvar #0 $vin vi
 	switch -exact $vi(vesselClass) {
 		smsloop		{ set sz 00sl }
@@ -61,7 +87,7 @@ proc vessel {vin} {
 	upvar #0 notes($nk) note
 	if {[info exists note]} {
 		manyset $note owner xabbrev
-		if {![string compare $owner $us]} {
+		if {![string compare $owner $pirate]} {
 			append abbrev =
 		} else {
 			append abbrev -
@@ -94,7 +120,7 @@ while {[gets $cl l] >= 0} {
 }
 close $cl
 
-set chart [open |[list perl -we {
+set chart [exec perl -we {
 	use strict;
 	use CommodsScrape;
 	use IO::File;
@@ -107,16 +133,16 @@ set chart [open |[list perl -we {
 		sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
 			);
 	STDOUT->error and die $!;
-}] r]
+}]
 
 frame .f -border 1 -relief groove
 set canvas .f.c
 canvas $canvas
 #$canvas configure -width 1000 -height 800
 pack $canvas -expand 1 -fill both
-pack .f -expand 1 -fill both
+pack .f -expand 1 -fill both -side left
 
-set scale 15
+set scale 16
 
 proc coord {c} {
 	global scale
@@ -147,16 +173,17 @@ proc chart-got/league {x1 y1 x2 y2 kind} {
 	}
 }
 
-while {[gets $chart l] >= 0} {
+proc draw {} {
+    global chart count isleloc canvas
+    
+    foreach l [split $chart "\n"] {
 #	puts "CHART-GOT $l"
 	set proc [lindex $l 0]
 	eval chart-got/$proc [lrange $l 1 end]
-}
-
-puts WILLSHOW
+    }
 
-set lastislandname {}
-foreach key [lsort [array names count]] {
+    set lastislandname {}
+    foreach key [lsort [array names count]] {
 	set c $count($key)
 #	puts "SHOWING $key $c"
 	regexp {^(.*) (\S+)$} $key dummy islandname abbrev
@@ -182,10 +209,41 @@ foreach key [lsort [array names count]] {
 	$canvas lower $bid $id
 	manyset $bbox dummy dummy dummy y
 #	puts "NEW Y $y"
+    }
 }
 
+draw
+
 foreach nk [lsort [array names $note]] {
 	puts "IGNORED NOTE $nk"
 }
 
+frame .ctrl
+pack .ctrl -side right
+
+panner::canvas-scroll-bbox .f.c
+panner::create .ctrl.pan .f.c 120 120
+
+pack .ctrl.pan -side top -pady 10 -padx 5
+frame .ctrl.zoom
+pack .ctrl.zoom -side top
+
+proc zoom {extail} {
+    global scale canvas
+    set nscale [expr "\$scale $extail"]
+    puts "ZOOM $scale $nscale"
+    if {$nscale < 1 || $nscale > 200} return
+    set scale $nscale
+    $canvas delete all
+    draw
+    panner::updatecanvas-bbox .ctrl.pan
+}
+
+button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
+button .ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2}
+pack .ctrl.zoom.out .ctrl.zoom.in -side left
+
+#. configure -width 640 -height 480
+wm geometry . 1024x480
+
 #puts "[$canvas bbox all]"