yarrg/where-vessels

   1 #!/usr/bin/wish
   2
   3 set us Aristarchus
   4
   5 proc manyset {list args} {
   6     foreach val $list var $args {
   7         upvar 1 $var my
   8         set my $val
   9     }
  10 }
  11
  12 set itemre { (\w+) = ([^=]*) }
  13 set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
  14 puts $manyitemre
  15
  16 set vn [open vessel-notes]
  17 while {[gets $vn l] >= 0} {
  18         regsub -all {\t+} $l "\t" l
  19         manyset [split $l "\t"] vname vid owner note
  20         set nk $vid.$vname
  21         puts "SET NOTE $nk"
  22         set notes($nk) [list $owner $note]
  23 }
  24 close $vn
  25
  26 proc vessel {vin} {
  27         global us
  28         upvar #0 $vin vi
  29         switch -exact $vi(vesselClass) {
  30                 smsloop         { set sz 00sl }
  31                 lgsloop         { set sz 01ct }
  32                 dhow            { set sz 02dh }
  33                 longship        { set sz 03ls }
  34                 baghlah         { set sz 04bg }
  35                 merchbrig       { set sz 05mb }
  36                 warbrig         { set sz 06wb }
  37                 xebec           { set sz 07xe }
  38                 warfrig         { set sz 08wf }
  39                 merchgal        { set sz 09mg }
  40                 grandfrig       { set sz 10gf }
  41                 default         { error "$vi(vesselClass) ?" }
  42         }
  43         set abbrev $sz
  44         switch -exact $vi(vesselSubclass) {
  45                 null            { }
  46                 icy             { append abbrev F }
  47                 default         { error "$vi(vesselSubclass) ?" }
  48         }
  49         switch -exact $vi(isLocked)/$vi(isBattleReady) {
  50                 true/false      { append abbrev 2- }
  51                 false/false     { append abbrev 1+ }
  52                 false/true      { append abbrev 0* }
  53                 default         { error "$vi(isLocked)/$vi(isBattleReady) ?" }
  54         }
  55         switch -exact $vi(inPort) {
  56                 true            { }
  57                 false           { append abbrev ? }
  58                 default         { error "$vi(inPort) ?" }
  59         }
  60         set nk $vi(vesselId).$vi(vesselName)
  61         upvar #0 notes($nk) note
  62         if {[info exists note]} {
  63                 manyset $note owner xabbrev
  64                 if {![string compare $owner $us]} {
  65                         append abbrev =
  66                 } else {
  67                         append abbrev -
  68                 }
  69                 append abbrev $xabbrev
  70                 unset note
  71         } else {
  72 #               puts "UNKNOWN $nk"
  73         }
  74         set kk "$vi(islandName) $abbrev"
  75         upvar #0 count($kk) k
  76         if {![info exists k]} { set k 0 }
  77         incr k
  78 }
  79
  80 set cl [open clipboard]
  81 while {[gets $cl l] >= 0} {
  82 #       puts "========"
  83         catch { unset vi }
  84         while 1 {
  85                 if {![regexp -expanded $manyitemre $l dummy \
  86                         thiskey thisval rhs]} { error "$l ?" }
  87 #               puts "KEY $thiskey VAL $thisval"
  88                 set vi($thiskey) $thisval
  89                 if {![string length $rhs]} break
  90                 regsub {^, } $rhs {} rhs
  91                 set l "\[$rhs\]"
  92         }
  93         vessel vi
  94 }
  95 close $cl
  96
  97 set chart [open |[list perl -we {
  98         use strict;
  99         use CommodsScrape;
 100         use IO::File;
 101         use IO::Handle;
 102         yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
 103                 sub { sprintf "%d %d", @_; },
 104                 sub { printf "archlabel %d %d %s\n", @_; },
 105                 sub { printf "island %s %s\n", @_; },
 106                 sub { printf "league %s %s %s.\n", @_; },
 107                 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
 108                         );
 109         STDOUT->error and die $!;
 110 }] r]
 111
 112 frame .f -border 1 -relief groove
 113 set canvas .f.c
 114 canvas $canvas
 115 #$canvas configure -width 1000 -height 800
 116 pack $canvas -expand 1 -fill both
 117 pack .f -expand 1 -fill both
 118
 119 set scale 15
 120
 121 proc coord {c} {
 122         global scale
 123         return [expr {$c * $scale}]
 124 }
 125
 126 proc chart-got/archlabel {args} { }
 127 proc chart-got/island {x y args} {
 128 #       puts "ISLE $x $y $args"
 129         global canvas isleloc
 130         set isleloc($args) [list $x $y]
 131         set sz 5
 132 #       $canvas create oval \
 133 #               [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
 134 #               [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
 135 #               -fill blue
 136         $canvas create text [coord $x] [coord $y] \
 137                 -text $args -anchor s
 138 }
 139 proc chart-got/league {x1 y1 x2 y2 kind} {
 140 #       puts "LEAGUE $x1 $y1 $x2 $y2 $kind"
 141         global canvas
 142         set l [$canvas create line \
 143                 [coord $x1] [coord $y1] \
 144                 [coord $x2] [coord $y2]]
 145         if {![string compare $kind .]} {
 146                 $canvas itemconfigure $l -dash .
 147         }
 148 }
 149
 150 while {[gets $chart l] >= 0} {
 151 #       puts "CHART-GOT $l"
 152         set proc [lindex $l 0]
 153         eval chart-got/$proc [lrange $l 1 end]
 154 }
 155
 156 puts WILLSHOW
 157
 158 set lastislandname {}
 159 foreach key [lsort [array names count]] {
 160         set c $count($key)
 161 #       puts "SHOWING $key $c"
 162         regexp {^(.*) (\S+)$} $key dummy islandname abbrev
 163         if {[string compare $lastislandname $islandname]} {
 164                 manyset $isleloc($islandname) x y
 165                 set x [coord $x]
 166                 set y [coord $y]
 167                 set lastislandname $islandname
 168 #               puts "START Y $y"
 169         }
 170         set text $abbrev
 171         regsub -all {[0-9]} $text {} text
 172         if {$c > 1} {
 173                 set text [format "%2d%s" $c $text]
 174         } else {
 175                 set text [format "  %s" $text]
 176         }
 177         set id [$canvas create text $x $y \
 178                 -anchor nw -font fixed \
 179                 -text $text]
 180         set bbox [$canvas bbox $id]
 181         set bid [eval $canvas create rectangle $bbox -fill white]
 182         $canvas lower $bid $id
 183         manyset $bbox dummy dummy dummy y
 184 #       puts "NEW Y $y"
 185 }
 186
 187 foreach nk [lsort [array names $note]] {
 188         puts "IGNORED NOTE $nk"
 189 }
 190
 191 #puts "[$canvas bbox all]"