yarrg/where-vessels

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