yarrg/where-vessels

   1 #!/usr/bin/wish
   2 # show your vessels on a map
   3
   4 # This is part of ypp-sc-tools, a set of third-party tools for assisting
   5 # players of Yohoho Puzzle Pirates.
   6 #
   7 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
   8 #
   9 # This program is free software: you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation, either version 3 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21 #
  22 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
  23 # are used without permission.  This program is not endorsed or
  24 # sponsored by Three Rings.
  25
  26
  27
  28 source yarrglib.tcl
  29 source panner.tcl
  30 package require http
  31
  32 #---------- general utilities ----------
  33
  34 set debug 0
  35 proc debug {m} {
  36     global debug
  37     if {$debug} { puts "DEBUG $m" }
  38 }
  39
  40 proc badusage {m} {
  41     puts stderr "where-vessels: bad usage: $m"
  42     exit 1
  43 }
  44
  45 proc glset {n val} {
  46     upvar #0 $n var
  47     set var $val
  48 }
  49
  50 #---------- argument parsing ----------
  51
  52 proc nextarg {} {
  53     global ai argv
  54     if {$ai >= [llength $argv]} {
  55         badusage "option [lindex $argv [expr {$ai-1}]] needs a value"
  56     }
  57     set v [lindex $argv $ai]
  58     incr ai
  59     return $v
  60 }
  61
  62 set notes_loc vessel-notes
  63 set scraper {./yppedia-ocean-scraper --chart}
  64
  65 proc parseargs {} {
  66     global ai argv
  67     global debug scraper
  68     set ai 0
  69
  70     while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
  71         incr ai
  72         switch -exact -- $arg {
  73             -- { break }
  74             --pirate { glset pirate [string totitle [nextarg]] }
  75             --ocean { glset ocean [string totitle [nextarg]] }
  76             --clipboard-file { load-clipboard-file [nextarg] }
  77             --local-html-dir { lappend scraper --local-html-dir=[nextarg] }
  78             --notes { glset notes_loc [nextarg] }
  79             --debug { incr debug }
  80             default { badusage "unknown option $arg" }
  81         }
  82     }
  83     set argv [lrange $argv $ai end]
  84     if {[llength $argv]} { badusage "non-option args not allowed" }
  85 }
  86
  87 proc argdefaults {} {
  88     global ocean notes_loc pirate scraper
  89     if {![info exists ocean] || ![info exists pirate]} {
  90         set cmd {./yarrg --find-window-only --quiet}
  91         if {[info exists ocean]} { lappend cmd --ocean $ocean }
  92         if {[info exists pirate]} { lappend cmd --pirate $pirate }
  93         manyset [split [eval exec $cmd] " "] ocean pirate
  94     }
  95     lappend scraper $ocean
  96 }
  97
  98
  99 #---------- loading and parsing the vessel notes ----------
 100
 101 proc load-notes {} {
 102     global notes_loc notes
 103     catch { unset notes }
 104     if {[regexp {^\w+\:} $notes_loc]} {
 105         vwait idletasks
 106         debug "FETCHING NOTES"
 107         ::http::geturl $notes_loc
 108         switch -glob [::http::status].[::http::ncode] {
 109             ok.200 { }
 110             ok.* { error "retrieving vessel-notes $url: [::http::code]" }
 111             * { error "retrieving vessel-notes $url: [::http::error]" }
 112         }
 113         set notes_data [::http::data]
 114         ::http::cleanup
 115     } else {
 116         set vn [open $notes_loc]
 117         set notes_data [read $vn]
 118         close $vn
 119     }
 120     foreach l [split $notes_data "\n"] {
 121         regsub -all {\t+} $l "\t" l
 122         manyset [split $l "\t"] vname vid owner note
 123         set nk $vid.$vname
 124         debug "SET NOTE $nk"
 125         set notes($nk) [list $owner $note]
 126     }
 127 }
 128
 129
 130 #---------- loading and parsing the clipboard (vessel locations) ----------
 131
 132 proc vessel {vin} {
 133         global pirate notes_used
 134         upvar 1 $vin vi
 135         switch -exact $vi(vesselClass) {
 136                 smsloop         { set sz 00sl }
 137                 lgsloop         { set sz 01ct }
 138                 dhow            { set sz 02dh }
 139                 longship        { set sz 03ls }
 140                 baghlah         { set sz 04bg }
 141                 merchbrig       { set sz 05mb }
 142                 warbrig         { set sz 06wb }
 143                 xebec           { set sz 07xe }
 144                 warfrig         { set sz 08wf }
 145                 merchgal        { set sz 09mg }
 146                 grandfrig       { set sz 10gf }
 147                 default         { error "$vi(vesselClass) ?" }
 148         }
 149         set abbrev $sz
 150         switch -exact $vi(vesselSubclass) {
 151                 null            { }
 152                 icy             { append abbrev F }
 153                 default         { error "$vi(vesselSubclass) ?" }
 154         }
 155         switch -exact $vi(isLocked)/$vi(isBattleReady) {
 156                 true/false      { append abbrev 2- }
 157                 false/false     { append abbrev 1+ }
 158                 false/true      { append abbrev 0* }
 159                 default         { error "$vi(isLocked)/$vi(isBattleReady) ?" }
 160         }
 161         switch -exact $vi(inPort) {
 162                 true            { }
 163                 false           { append abbrev ? }
 164                 default         { error "$vi(inPort) ?" }
 165         }
 166         set nk $vi(vesselId).$vi(vesselName)
 167         upvar #0 notes($nk) note
 168         if {[info exists note]} {
 169             manyset $note owner xabbrev
 170             if {![string compare $owner $pirate]} {
 171                 append abbrev =
 172             } else {
 173                 append abbrev -
 174             }
 175             append abbrev $xabbrev
 176             set notes_used($nk) 1
 177         } else {
 178             debug "UNKNOWN $nk"
 179         }
 180         set kk "$vi(islandName) $abbrev"
 181         upvar #0 count($kk) k
 182         if {![info exists k]} { set k 0 }
 183         incr k
 184 }
 185
 186 set clipboard {}
 187 proc parse-clipboard {} {
 188     global clipboard count notes notes_used
 189
 190     catch { unset count }
 191     catch { unset notes_used }
 192
 193     set itemre { (\w+) = ([^=]*) }
 194     set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
 195     debug $manyitemre
 196
 197     foreach l [split $clipboard "\n"] {
 198         if {![string length $l]} continue
 199         catch { unset vi }
 200         while 1 {
 201                 if {![regexp -expanded $manyitemre $l dummy \
 202                         thiskey thisval rhs]} { error "$l ?" }
 203                 set vi($thiskey) $thisval
 204                 if {![string length $rhs]} break
 205                 regsub {^, } $rhs {} rhs
 206                 set l "\[$rhs\]"
 207         }
 208         vessel vi
 209     }
 210
 211     foreach nk [lsort [array names notes]] {
 212         if {![info exists notes_used($nk)]} {
 213             debug "IGNORED NOTE $nk"
 214         }
 215     }
 216 }
 217
 218 proc load-clipboard-file {fn} {
 219     set f [open $fn]
 220     glset clipboard [read $f]
 221     close $f
 222 }
 223
 224
 225 #---------- loading and parsing the chart ----------
 226
 227 proc load-chart {} {
 228     global chart scraper
 229     debug "FETCHING CHART"
 230     set chart [eval exec $scraper [list | perl -we {
 231         use strict;
 232         use CommodsScrape;
 233         use IO::File;
 234         use IO::Handle;
 235         yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
 236                 sub { sprintf "%d %d", @_; },
 237                 sub { printf "archlabel %d %d %s\n", @_; },
 238                 sub { printf "island %s %s\n", @_; },
 239                 sub { printf "league %s %s %s.\n", @_; },
 240                 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
 241                         );
 242         STDOUT->error and die $!;
 243     }]]
 244 }
 245
 246
 247 set scale 16
 248
 249 proc coord {c} {
 250         global scale
 251         return [expr {$c * $scale}]
 252 }
 253
 254 proc chart-got/archlabel {args} { }
 255 proc chart-got/island {x y args} {
 256 #       debug "ISLE $x $y $args"
 257         global canvas isleloc
 258         set isleloc($args) [list $x $y]
 259         set sz 5
 260 #       $canvas create oval \
 261 #               [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
 262 #               [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
 263 #               -fill blue
 264         $canvas create text [coord $x] [coord $y] \
 265                 -text $args -anchor s
 266 }
 267 proc chart-got/league {x1 y1 x2 y2 kind} {
 268 #       debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
 269         global canvas
 270         set l [$canvas create line \
 271                 [coord $x1] [coord $y1] \
 272                 [coord $x2] [coord $y2]]
 273         if {![string compare $kind .]} {
 274                 $canvas itemconfigure $l -dash .
 275         }
 276 }
 277
 278 proc draw {} {
 279     global chart count isleloc canvas
 280
 281     $canvas delete all
 282
 283     foreach l [split $chart "\n"] {
 284 #       debug "CHART-GOT $l"
 285         set proc [lindex $l 0]
 286         eval chart-got/$proc [lrange $l 1 end]
 287     }
 288
 289     set lastislandname {}
 290     foreach key [lsort [array names count]] {
 291         set c $count($key)
 292 #       debug "SHOWING $key $c"
 293         regexp {^(.*) (\S+)$} $key dummy islandname abbrev
 294         if {[string compare $lastislandname $islandname]} {
 295                 manyset $isleloc($islandname) x y
 296                 set x [coord $x]
 297                 set y [coord $y]
 298                 set lastislandname $islandname
 299 #               debug "START Y $y"
 300         }
 301         set text $abbrev
 302         regsub -all {[0-9]} $text {} text
 303         if {$c > 1} {
 304                 set text [format "%2d%s" $c $text]
 305         } else {
 306                 set text [format "  %s" $text]
 307         }
 308         set id [$canvas create text $x $y \
 309                 -anchor nw -font fixed \
 310                 -text $text]
 311         set bbox [$canvas bbox $id]
 312         set bid [eval $canvas create rectangle $bbox -fill white]
 313         $canvas lower $bid $id
 314         manyset $bbox dummy dummy dummy y
 315 #       debug "NEW Y $y"
 316     }
 317
 318     panner::updatecanvas-bbox .ctrl.pan
 319 }
 320
 321
 322 #---------- user interface ----------
 323
 324 proc widgets-setup {} {
 325     global canvas debug acqdeffont
 326
 327     frame .f -border 1 -relief groove
 328     set canvas .f.c
 329     canvas $canvas
 330     pack $canvas -expand 1 -fill both
 331     pack .f -expand 1 -fill both -side left
 332
 333     frame .ctrl
 334     pack .ctrl -side right
 335
 336     debug "BBOX [$canvas bbox all]"
 337
 338     panner::canvas-scroll-bbox .f.c
 339     panner::create .ctrl.pan .f.c 120 120 $debug
 340
 341     pack .ctrl.pan -side top -pady 10 -padx 5
 342     frame .ctrl.zoom
 343     pack .ctrl.zoom -side top
 344
 345     button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
 346     button .ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2}
 347     pack .ctrl.zoom.out .ctrl.zoom.in -side left
 348
 349     frame .ctrl.acquire
 350     button .ctrl.acquire.do -text Acquire -command acquire
 351
 352     frame .ctrl.acquire.resframe -width 120 -height 32
 353     button .ctrl.acquire.resframe.res -text {} -anchor nw \
 354         -padx 1 -pady 1 -borderwidth 0 -justify left
 355     glset acqdeffont [.ctrl.acquire.resframe.res cget -font]
 356     place .ctrl.acquire.resframe.res -relx 0.5 -y 0 -anchor n
 357     #   -relheight 1.0 -relwidth 1.0
 358
 359     pack .ctrl.acquire.do -side top
 360     pack .ctrl.acquire.resframe -side top -expand y -fill both
 361     pack .ctrl.acquire -side top
 362
 363     wm geometry . 1024x480
 364 }
 365
 366 proc zoom {extail} {
 367     global scale canvas
 368     set nscale [expr "\$scale $extail"]
 369     debug "ZOOM $scale $nscale"
 370     if {$nscale < 1 || $nscale > 200} return
 371     set scale $nscale
 372     draw
 373 }
 374
 375 proc acquire_showerror {} {
 376     global acqerr
 377     tk_messageBox -type ok \
 378         -title "where-vessels: clipboard parsing error" \
 379         -message $acqerr
 380 }
 381
 382 proc acquire {} {
 383     global clipboard acqdeffont acqerr errorInfo
 384     set old $clipboard
 385     if {[catch {
 386         set clipboard [clipboard get]
 387         parse-clipboard
 388         .ctrl.acquire.resframe.res configure \
 389             -background blue -disabledforeground black -font $acqdeffont \
 390             -state disabled -command {} \
 391             -text " acquired ok "
 392     } emsg]} {
 393         set acqerr "clipboard parsing failed: $emsg"
 394         puts stderr $acqerr
 395         append acqerr "\n$errorInfo"
 396         regsub -all {.{18}} "error: [string trim $emsg]" "&\n" ewrap
 397         .ctrl.acquire.resframe.res configure \
 398             -background red -foreground white -font fixed \
 399             -state normal -command acquire_showerror \
 400             -text $ewrap
 401         set clipboard $old
 402         parse-clipboard
 403     }
 404     draw
 405 }
 406
 407
 408 #---------- main program ----------
 409
 410 parseargs
 411 argdefaults
 412 httpclientsetup where-vessels
 413 load-chart
 414 widgets-setup
 415
 416 load-notes
 417 parse-clipboard
 418
 419 draw