yarrg/where-vessels

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