WIP where-vessels: Can produce some kind of map

diff --git a/yarrg/where-vessels b/yarrg/where-vessels
new file mode 100755 (executable)
index 0000000..a827892
--- /dev/null
+++ b/yarrg/where-vessels
@@ -0,0 +1,191 @@
+#!/usr/bin/wish
+
+set us Aristarchus
+
+proc manyset {list args} {
+    foreach val $list var $args {
+        upvar 1 $var my
+        set my $val
+    }
+}
+
+set itemre { (\w+) = ([^=]*) }
+set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
+puts $manyitemre
+
+set vn [open vessel-notes]
+while {[gets $vn l] >= 0} {
+       regsub -all {\t+} $l "\t" l
+       manyset [split $l "\t"] vname vid owner note
+       set nk $vid.$vname
+       puts "SET NOTE $nk"
+       set notes($nk) [list $owner $note]
+}
+close $vn
+
+proc vessel {vin} {
+       global us
+       upvar #0 $vin vi
+       switch -exact $vi(vesselClass) {
+               smsloop         { set sz 00sl }
+               lgsloop         { set sz 01ct }
+               dhow            { set sz 02dh }
+               longship        { set sz 03ls }
+               baghlah         { set sz 04bg }
+               merchbrig       { set sz 05mb }
+               warbrig         { set sz 06wb }
+               xebec           { set sz 07xe }
+               warfrig         { set sz 08wf }
+               merchgal        { set sz 09mg }
+               grandfrig       { set sz 10gf }
+               default         { error "$vi(vesselClass) ?" }
+       }
+       set abbrev $sz
+       switch -exact $vi(vesselSubclass) {
+               null            { }
+               icy             { append abbrev F }
+               default         { error "$vi(vesselSubclass) ?" }
+       }
+       switch -exact $vi(isLocked)/$vi(isBattleReady) {
+               true/false      { append abbrev 2- }
+               false/false     { append abbrev 1+ }
+               false/true      { append abbrev 0* }
+               default         { error "$vi(isLocked)/$vi(isBattleReady) ?" }
+       }
+       switch -exact $vi(inPort) {
+               true            { }
+               false           { append abbrev ? }
+               default         { error "$vi(inPort) ?" }
+       }
+       set nk $vi(vesselId).$vi(vesselName)
+       upvar #0 notes($nk) note
+       if {[info exists note]} {
+               manyset $note owner xabbrev
+               if {![string compare $owner $us]} {
+                       append abbrev =
+               } else {
+                       append abbrev -
+               }
+               append abbrev $xabbrev
+               unset note
+       } else {
+#              puts "UNKNOWN $nk"
+       }
+       set kk "$vi(islandName) $abbrev"
+       upvar #0 count($kk) k
+       if {![info exists k]} { set k 0 }
+       incr k
+}
+
+set cl [open clipboard]
+while {[gets $cl l] >= 0} {
+#      puts "========"
+       catch { unset vi }
+       while 1 {
+               if {![regexp -expanded $manyitemre $l dummy \
+                       thiskey thisval rhs]} { error "$l ?" }
+#              puts "KEY $thiskey VAL $thisval"
+               set vi($thiskey) $thisval
+               if {![string length $rhs]} break
+               regsub {^, } $rhs {} rhs
+               set l "\[$rhs\]"
+       }
+       vessel vi
+}
+close $cl
+
+set chart [open |[list perl -we {
+       use strict;
+       use CommodsScrape;
+       use IO::File;
+       use IO::Handle;
+       yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
+               sub { sprintf "%d %d", @_; },
+               sub { printf "archlabel %d %d %s\n", @_; },
+               sub { printf "island %s %s\n", @_; },
+               sub { printf "league %s %s %s.\n", @_; },
+               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
+
+set scale 15
+
+proc coord {c} {
+       global scale
+       return [expr {$c * $scale}]
+}
+
+proc chart-got/archlabel {args} { }
+proc chart-got/island {x y args} {
+#      puts "ISLE $x $y $args"
+       global canvas isleloc
+       set isleloc($args) [list $x $y]
+       set sz 5
+#      $canvas create oval \
+#              [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
+#              [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
+#              -fill blue
+       $canvas create text [coord $x] [coord $y] \
+               -text $args -anchor s
+}
+proc chart-got/league {x1 y1 x2 y2 kind} {
+#      puts "LEAGUE $x1 $y1 $x2 $y2 $kind"
+       global canvas
+       set l [$canvas create line \
+               [coord $x1] [coord $y1] \
+               [coord $x2] [coord $y2]]
+       if {![string compare $kind .]} {
+               $canvas itemconfigure $l -dash .
+       }
+}
+
+while {[gets $chart l] >= 0} {
+#      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 c $count($key)
+#      puts "SHOWING $key $c"
+       regexp {^(.*) (\S+)$} $key dummy islandname abbrev
+       if {[string compare $lastislandname $islandname]} {
+               manyset $isleloc($islandname) x y
+               set x [coord $x]
+               set y [coord $y]
+               set lastislandname $islandname
+#              puts "START Y $y"
+       }
+       set text $abbrev
+       regsub -all {[0-9]} $text {} text
+       if {$c > 1} {
+               set text [format "%2d%s" $c $text]
+       } else {
+               set text [format "  %s" $text]
+       }
+       set id [$canvas create text $x $y \
+               -anchor nw -font fixed \
+               -text $text]
+       set bbox [$canvas bbox $id]
+       set bid [eval $canvas create rectangle $bbox -fill white]
+       $canvas lower $bid $id
+       manyset $bbox dummy dummy dummy y
+#      puts "NEW Y $y"
+}
+
+foreach nk [lsort [array names $note]] {
+       puts "IGNORED NOTE $nk"
+}
+
+#puts "[$canvas bbox all]"