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 #---------- expecting certain errors ----------
  51
  52 proc errexpect-setline {lno line} {
  53     glset errexpect_lno $lno
  54     glset errexpect_line $line
  55 }
  56
  57 proc errexpect-error {m} {
  58     global errexpect_line errexpect_lno
  59     error $m "$errexpect_line\n" [list YARRG-ERREXPECT $errexpect_lno]
  60 }
  61
  62 proc errexpect-arrayget {arrayvar key} {
  63     upvar 1 $arrayvar av
  64     upvar 1 ${arrayvar}($key) v
  65     if {[info exists v]} { return $v }
  66     errexpect-error "undefined $key"
  67 }
  68
  69 proc errexpect-catch {code} {
  70     global errorInfo errorCode
  71     set rc [catch {
  72         uplevel 1 $code
  73     } rv]
  74     debug "ERREXPECT CATCH |$rc|$rv|$errorCode|$errorInfo|"
  75     if {$rc==1 && ![string compare YARRG-ERREXPECT [lindex $errorCode 0]]} {
  76         return [list 1 $rv [lindex $errorCode 1] $errorInfo]
  77     } elseif {$rc==0} {
  78         return [list 0 $rv]
  79     } else {
  80         return -code $rc -errorinfo $errorInfo -errorcode $errorCode $rv
  81     }
  82 }
  83
  84 #---------- argument parsing ----------
  85
  86 proc nextarg {} {
  87     global ai argv
  88     if {$ai >= [llength $argv]} {
  89         badusage "option [lindex $argv [expr {$ai-1}]] needs a value"
  90     }
  91     set v [lindex $argv $ai]
  92     incr ai
  93     return $v
  94 }
  95
  96 set notes_loc vessel-notes
  97 set scraper {./yppedia-ocean-scraper --chart}
  98
  99 proc parseargs {} {
 100     global ai argv
 101     global debug scraper
 102     set ai 0
 103
 104     while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
 105         incr ai
 106         switch -exact -- $arg {
 107             -- { break }
 108             --pirate { glset pirate [string totitle [nextarg]] }
 109             --ocean { glset ocean [string totitle [nextarg]] }
 110             --clipboard-file { load-clipboard-file [nextarg] }
 111             --local-html-dir { lappend scraper --local-html-dir=[nextarg] }
 112             --notes { glset notes_loc [nextarg] }
 113             --debug { incr debug }
 114             default { badusage "unknown option $arg" }
 115         }
 116     }
 117     set argv [lrange $argv $ai end]
 118     if {[llength $argv]} { badusage "non-option args not allowed" }
 119 }
 120
 121 proc argdefaults {} {
 122     global ocean notes_loc pirate scraper
 123     if {![info exists ocean] || ![info exists pirate]} {
 124         set cmd {./yarrg --find-window-only --quiet}
 125         if {[info exists ocean]} { lappend cmd --ocean $ocean }
 126         if {[info exists pirate]} { lappend cmd --pirate $pirate }
 127         manyset [split [eval exec $cmd] " "] ocean pirate
 128     }
 129     lappend scraper $ocean
 130 }
 131
 132
 133 #---------- loading and parsing the vessel notes ----------
 134
 135 proc load-notes {} {
 136     global notes_loc notes_data
 137     if {[regexp {^\w+\:} $notes_loc]} {
 138         vwait idletasks
 139         debug "FETCHING NOTES $notes_loc"
 140         ::http::geturl $notes_loc
 141         switch -glob [::http::status].[::http::ncode] {
 142             ok.200 { }
 143             ok.* { error "retrieving vessel-notes $url: [::http::code]" }
 144             * { error "retrieving vessel-notes $url: [::http::error]" }
 145         }
 146         set newdata [::http::data]
 147         ::http::cleanup
 148     } else {
 149         debug "READING NOTES $notes_loc"
 150         set vn [open $notes_loc]
 151         set newdata [read $vn]
 152         close $vn
 153     }
 154     set notes_data $newdata
 155 }
 156
 157 proc parse-notes {} {
 158     global notes_data notes
 159     catch { unset notes }
 160     foreach l [split $notes_data "\n"] {
 161         regsub -all {\t+} $l "\t" l
 162         manyset [split $l "\t"] vname vid owner note
 163         set nk $vid.$vname
 164         debug "SET NOTE $nk"
 165         set notes($nk) [list $owner $note]
 166     }
 167 }
 168
 169
 170 #---------- loading and parsing the clipboard (vessel locations) ----------
 171
 172 proc vessel {vin} {
 173     global pirate notes_used
 174     upvar 1 $vin vi
 175     switch -exact [errexpect-arrayget vi vesselClass] {
 176         smsloop         { set sz 00sl }
 177         lgsloop         { set sz 01ct }
 178         dhow            { set sz 02dh }
 179         longship        { set sz 03ls }
 180         baghlah         { set sz 04bg }
 181         merchbrig       { set sz 05mb }
 182         warbrig         { set sz 06wb }
 183         xebec           { set sz 07xe }
 184         warfrig         { set sz 08wf }
 185         merchgal        { set sz 09mg }
 186         grandfrig       { set sz 10gf }
 187         default         { errexpect-error "unknown class" }
 188     }
 189     set abbrev $sz
 190     switch -exact [errexpect-arrayget vi vesselSubclass] {
 191         null            { }
 192         icy             { append abbrev F }
 193         default         { errexpect-error "unknown subclass ?" }
 194     }
 195     switch -exact [errexpect-arrayget vi isLocked]/[ \
 196                    errexpect-arrayget vi isBattleReady] {
 197         true/false      { append abbrev 2- }
 198         false/false     { append abbrev 1+ }
 199         false/true      { append abbrev 0* }
 200         default         { errexpect-error "unexpected isLocked/isBattleReady" }
 201     }
 202     switch -exact [errexpect-arrayget vi inPort] {
 203         true            { }
 204         false           { append abbrev ? }
 205         default         { errexpect-error "unexpected inPort" }
 206     }
 207     set nk [errexpect-arrayget vi vesselId].[errexpect-arrayget vi vesselName]
 208     upvar #0 notes($nk) note
 209     if {[info exists note]} {
 210         manyset $note owner xabbrev
 211         if {![string compare $owner $pirate]} {
 212             append abbrev =
 213         } else {
 214             append abbrev -
 215         }
 216         append abbrev $xabbrev
 217         set notes_used($nk) 1
 218     } else {
 219         debug "UNKNOWN $nk"
 220     }
 221     set kk "[errexpect-arrayget vi islandName] $abbrev"
 222     upvar #0 count($kk) k
 223     if {![info exists k]} { set k 0 }
 224     incr k
 225 }
 226
 227 set clipboard {}
 228 proc parse-clipboard {} {
 229     global clipboard count notes notes_used
 230
 231     catch { unset count }
 232     catch { unset notes_used }
 233
 234     set itemre { (\w+) = ([^=]*) }
 235     set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
 236     debug $manyitemre
 237
 238     set lno 0
 239     foreach l [split $clipboard "\n"] {
 240         incr lno
 241         errexpect-setline $lno $l
 242         if {![string length $l]} continue
 243         catch { unset vi }
 244         while 1 {
 245                 if {![regexp -expanded $manyitemre $l dummy \
 246                         thiskey thisval rhs]} {
 247                     errexpect-error "badly formatted"
 248                 }
 249                 set vi($thiskey) $thisval
 250                 if {![string length $rhs]} break
 251                 regsub {^, } $rhs {} rhs
 252                 set l "\[$rhs\]"
 253         }
 254         vessel vi
 255     }
 256
 257     foreach nk [lsort [array names notes]] {
 258         if {![info exists notes_used($nk)]} {
 259             debug "IGNORED NOTE $nk"
 260         }
 261     }
 262 }
 263
 264 proc load-clipboard-file {fn} {
 265     set f [open $fn]
 266     glset clipboard [read $f]
 267     close $f
 268 }
 269
 270
 271 #---------- loading and parsing the chart ----------
 272
 273 proc load-chart {} {
 274     global chart scraper
 275     debug "FETCHING CHART"
 276     set chart [eval exec $scraper [list | perl -we {
 277         use strict;
 278         use CommodsScrape;
 279         use IO::File;
 280         use IO::Handle;
 281         yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
 282                 sub { sprintf "%d %d", @_; },
 283                 sub { printf "archlabel %d %d %s\n", @_; },
 284                 sub { printf "island %s %s\n", @_; },
 285                 sub { printf "league %s %s %s.\n", @_; },
 286                 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
 287                         );
 288         STDOUT->error and die $!;
 289     }]]
 290 }
 291
 292
 293 set scale 16
 294
 295 proc coord {c} {
 296         global scale
 297         return [expr {$c * $scale}]
 298 }
 299
 300 proc chart-got/archlabel {args} { }
 301 proc chart-got/island {x y args} {
 302 #       debug "ISLE $x $y $args"
 303         global canvas isleloc
 304         set isleloc($args) [list $x $y]
 305         set sz 5
 306 #       $canvas create oval \
 307 #               [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
 308 #               [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
 309 #               -fill blue
 310         $canvas create text [coord $x] [coord $y] \
 311                 -text $args -anchor s
 312 }
 313 proc chart-got/league {x1 y1 x2 y2 kind} {
 314 #       debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
 315         global canvas
 316         set l [$canvas create line \
 317                 [coord $x1] [coord $y1] \
 318                 [coord $x2] [coord $y2]]
 319         if {![string compare $kind .]} {
 320                 $canvas itemconfigure $l -dash .
 321         }
 322 }
 323
 324 proc draw {} {
 325     global chart count isleloc canvas
 326
 327     $canvas delete all
 328
 329     foreach l [split $chart "\n"] {
 330 #       debug "CHART-GOT $l"
 331         set proc [lindex $l 0]
 332         eval chart-got/$proc [lrange $l 1 end]
 333     }
 334
 335     set lastislandname {}
 336     foreach key [lsort [array names count]] {
 337         set c $count($key)
 338 #       debug "SHOWING $key $c"
 339         regexp {^(.*) (\S+)$} $key dummy islandname abbrev
 340         if {[string compare $lastislandname $islandname]} {
 341                 manyset $isleloc($islandname) x y
 342                 set x [coord $x]
 343                 set y [coord $y]
 344                 set lastislandname $islandname
 345 #               debug "START Y $y"
 346         }
 347         set text $abbrev
 348         regsub -all {[0-9]} $text {} text
 349         if {$c > 1} {
 350                 set text [format "%2d%s" $c $text]
 351         } else {
 352                 set text [format "  %s" $text]
 353         }
 354         set id [$canvas create text $x $y \
 355                 -anchor nw -font fixed \
 356                 -text $text]
 357         set bbox [$canvas bbox $id]
 358         set bid [eval $canvas create rectangle $bbox -fill white]
 359         $canvas lower $bid $id
 360         manyset $bbox dummy dummy dummy y
 361 #       debug "NEW Y $y"
 362     }
 363
 364     panner::updatecanvas-bbox .ctrl.pan
 365 }
 366
 367
 368 #---------- user interface ----------
 369
 370 proc widgets-setup {} {
 371     global canvas debug acquire_deffont
 372
 373     frame .f -border 1 -relief groove
 374     set canvas .f.c
 375     canvas $canvas
 376     pack $canvas -expand 1 -fill both
 377     pack .f -expand 1 -fill both -side left
 378
 379     frame .ctrl
 380     pack .ctrl -side right
 381
 382     debug "BBOX [$canvas bbox all]"
 383
 384     panner::canvas-scroll-bbox .f.c
 385     panner::create .ctrl.pan .f.c 120 120 $debug
 386
 387     pack .ctrl.pan -side top -pady 10 -padx 5
 388     frame .ctrl.zoom
 389     pack .ctrl.zoom -side top
 390
 391     button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
 392     button .ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2}
 393     pack .ctrl.zoom.out .ctrl.zoom.in -side left
 394
 395     parser-control-create .ctrl.acquire \
 396         acquire Acquire \
 397         "Clipboard parsing error" \
 398
 399     pack .ctrl.acquire -side top -pady 2
 400
 401     parser-control-create .ctrl.notes \
 402         notes "Reload notes" \
 403         "Vessel notes loading error" \
 404
 405     pack .ctrl.notes -side top -pady 2
 406
 407     wm geometry . 1024x480
 408 }
 409
 410 proc parser-control-create {w base invokebuttontext etl_title} {
 411     frame $w
 412     button $w.do -text $invokebuttontext -command invoke_$base
 413
 414     frame $w.resframe -width 120 -height 32
 415     button $w.resframe.res -text {} -anchor nw \
 416         -padx 1 -pady 1 -borderwidth 0 -justify left
 417     glset deffont_$base [$w.resframe.res cget -font]
 418     place $w.resframe.res -relx 0.5 -y 0 -anchor n
 419
 420     pack $w.do -side top
 421     pack $w.resframe -side top -expand y -fill both
 422
 423     set eb .err_$base
 424     toplevel $eb
 425     wm withdraw $eb
 426     wm title $eb "$etl_title - where-vessels"
 427
 428     label $eb.title -text $etl_title
 429     pack $eb.title -side top
 430
 431     button $eb.close -text Close -command [list wm withdraw $eb]
 432     pack $eb.close -side bottom
 433
 434     frame $eb.emsg -bd 2 -relief groove
 435     label $eb.emsg.lab -text "Error:"
 436     text $eb.emsg.text -height 1
 437     pack $eb.emsg.text -side bottom
 438     pack $eb.emsg.lab -side left
 439
 440     pack $eb.emsg -side top -pady 2
 441
 442     frame $eb.text -bd 2 -relief groove
 443     pack $eb.text -side bottom -pady 2
 444
 445     label $eb.text.lab
 446
 447     text $eb.text.text \
 448         -xscrollcommand [list $eb.text.xscroll set] \
 449         -yscrollcommand [list $eb.text.yscroll set]
 450     $eb.text.text tag configure error \
 451         -background red -foreground white
 452
 453     scrollbar $eb.text.xscroll -orient horizontal \
 454         -command [list $eb.text.text xview]
 455     scrollbar $eb.text.yscroll -orient vertical \
 456         -command [list $eb.text.text yview]
 457
 458     grid configure $eb.text.lab -row 0 -column 0 -sticky w
 459     grid configure $eb.text.text -row 1 -column 0
 460     grid configure $eb.text.yscroll -sticky ns -row 1 -column 1
 461     grid configure $eb.text.xscroll -sticky ew -row 2 -column 0
 462 }
 463
 464 proc parser-control-ok-core {w base background show} {
 465     debug "parser-control-ok-core $w $base $background $show"
 466     upvar #0 deffont_$base deffont
 467     $w.resframe.res configure \
 468         -background $background -disabledforeground black -font $deffont \
 469         -state disabled -command {} \
 470         -text $show
 471 }
 472 proc parser-control-ok {w base show} {
 473     parser-control-ok-core $w $base green $show
 474 }
 475 proc parser-control-none {w base show} {
 476     parser-control-ok-core $w $base blue $show
 477 }
 478 proc parser-control-failed-core {w base tiny summary fulldesc fulldata} {
 479     debug "parser-control-failed-core $w $base $summary $fulldesc"
 480     set eb .err_$base
 481
 482     $eb.emsg.text delete 0.0 end
 483     $eb.emsg.text insert end $summary
 484
 485     $eb.text.lab configure -text $fulldesc
 486     $eb.text.text delete 0.0 end
 487     $eb.text.text insert end $fulldata
 488
 489     regsub -all {.{18}} $tiny "&\n" ewrap
 490
 491     $w.resframe.res configure \
 492         -background red -foreground white -font fixed \
 493         -state normal -command [list wm deiconify $eb] \
 494         -text $ewrap
 495 }
 496
 497 proc parser-control-failed-expected {w base emsg lno ei fulldesc newdata} {
 498     set eb .err_$base
 499
 500     set line [lindex [split $ei "\n"] 0]
 501     debug "parser-control-failed-expected: $w $base: $lno: $emsg\n $line"
 502
 503     parser-control-failed-core $w $base \
 504         "err: [string trim $emsg]: \"$line\"" \
 505         "at line $lno: $emsg" \
 506         $fulldesc $newdata
 507
 508     $eb.text.text tag add error $lno.0 $lno.end
 509     $eb.text.text see $lno.0
 510 }
 511
 512 proc zoom {extail} {
 513     global scale canvas
 514     set nscale [expr "\$scale $extail"]
 515     debug "ZOOM $scale $nscale"
 516     if {$nscale < 1 || $nscale > 200} return
 517     set scale $nscale
 518     draw
 519 }
 520
 521 proc reparse {base varname fulldesc okshow noneshow set parse} {
 522     upvar #0 $varname var
 523     set old $var
 524     uplevel 1 $set
 525     manyset [errexpect-catch {
 526         uplevel 1 $parse
 527         if {[string length [string trim $var]]} {
 528             parser-control-ok .ctrl.$base $base $okshow
 529         } else {
 530             parser-control-none .ctrl.$base $base $noneshow
 531         }
 532     }] failed emsg lno ei
 533     if {$failed} {
 534         parser-control-failed-expected .ctrl.$base $base \
 535             $emsg $lno $ei $fulldesc $var
 536         set var $old
 537         uplevel 1 $parse
 538     }
 539 }
 540
 541 proc invoke_acquire {} {
 542     global clipboard
 543     reparse acquire \
 544         clipboard "Clipboard contents:" { acquired ok } { no vessels } \
 545         { set clipboard [clipboard get] } \
 546         { parse-clipboard }
 547     draw
 548 }
 549
 550 proc invoke_notes {} {
 551     global notes_data errorInfo notes_loc
 552
 553     reparse notes notes_data "Vessel notes:" "notes reloaded" { no notes } \
 554         {
 555             if {[catch {
 556                 load-notes
 557             } emsg]} {
 558                 parser-control-failed-core .ctrl.notes notes \
 559                     $emsg $emsg "Details and stack trace:" \
 560                     "loading $notes_loc:\n\n$errorInfo"
 561                 return
 562             }
 563         } \
 564         { parse-notes }
 565     draw
 566 }
 567
 568 #---------- main program ----------
 569
 570 parseargs
 571 argdefaults
 572 httpclientsetup where-vessels
 573 load-chart
 574 widgets-setup
 575
 576 load-notes
 577 parse-notes
 578 parse-clipboard
 579
 580 draw