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         update
 139         debug "FETCHING NOTES $notes_loc"
 140         set req [::http::geturl $notes_loc]
 141         switch -glob [::http::status $req].[::http::ncode $req] {
 142             ok.200 { }
 143             ok.* { error "retrieving vessel-notes: [::http::code $req]" }
 144             * { error "Retrieving vessel-notes: [::http::error $req]" }
 145         }
 146         set newdata [::http::data $req]
 147         ::http::cleanup $req
 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
 161     set lno 0
 162     foreach l [split $notes_data "\n"] {
 163         incr lno
 164         errexpect-setline $lno $l
 165         set l [string trim $l]
 166         if {![string length $l]} continue
 167         if {[regexp {^\#} $l]} continue
 168         if {![regexp -expanded \
 169                   {^ (\d+) (?: \s+([^=]*?) )? \s* =
 170                       (?: \s* (\S+)
 171                        (?: \s+ (\S+) )?)? $} \
 172                   $l dummy vid vname owner note]} {
 173               errexpect-error "badly formatted"
 174         }
 175         set vname [string trim $vname]
 176         if {[info exists notes($vid)]} {
 177             errexpect-error "duplicate vesselid $vid"
 178         }
 179         set notes($vid) [list $lno $vname $owner $note]
 180     }
 181 }
 182
 183 proc note-info {lno vid name description} {
 184     global note_infos
 185     lappend note_infos [list $lno $vid $name $description]
 186 }
 187
 188 proc display-note-infos {} {
 189     global note_infos note_missings notes
 190
 191     set nmissing [llength $note_missings]
 192     debug "display-note-infos $nmissing [array size notes]"
 193
 194     if {[llength $note_infos]} {
 195         set tiny "[llength $note_infos] warnings"
 196     } elseif {$nmissing && [array size notes]} {
 197         set tiny "$nmissing missing"
 198     } else {
 199         return
 200     }
 201
 202     set infodata {}
 203
 204     foreach info $note_infos {
 205         manyset $info lno vid name description
 206         append infodata "vessel"
 207         append infodata " $vid"
 208         if {[string length $name]} { append infodata " $name" }
 209         append infodata ": " $description "\n"
 210     }
 211
 212     if {$nmissing} {
 213         append infodata "$nmissing vessels not mentioned in notes:\n"
 214         set last_island {}
 215         foreach info [lsort $note_missings] {
 216             manyset $info island name vid
 217             if {[string compare $island $last_island]} {
 218                 append infodata "# $island:\n"
 219                 set last_island $island
 220             }
 221             append infodata [format "%-9d %-29s =\n" $vid $name]
 222         }
 223     }
 224
 225     parser-control-failed-core .ctrl.notes notes \
 226         white blue 0 \
 227         $tiny \
 228         "[llength $note_infos] warnings;\
 229          $nmissing vessels missing" \
 230         "Full description of warnings and missing vessels:" \
 231         $infodata
 232 }
 233
 234 #---------- loading and parsing the clipboard (vessel locations) ----------
 235
 236 proc vessel {vin} {
 237     global pirate notes_used note_missings newnotes
 238     upvar 1 $vin vi
 239     set abbrev {}
 240     switch -exact [errexpect-arrayget vi inPort] {
 241         true            { }
 242         false           { append abbrev ? }
 243         default         { errexpect-error "unexpected inPort" }
 244     }
 245     switch -exact [errexpect-arrayget vi vesselClass] {
 246         smsloop         { set sz 00sl }
 247         lgsloop         { set sz 01ct }
 248         dhow            { set sz 02dh }
 249         longship        { set sz 03ls }
 250         baghlah         { set sz 04bg }
 251         merchbrig       { set sz 05mb }
 252         warbrig         { set sz 06wb }
 253         xebec           { set sz 07xe }
 254         warfrig         { set sz 08wf }
 255         merchgal        { set sz 09mg }
 256         grandfrig       { set sz 10gf }
 257         default         { errexpect-error "unknown class" }
 258     }
 259     append abbrev $sz
 260     switch -exact [errexpect-arrayget vi vesselSubclass] {
 261         null            { }
 262         icy             { append abbrev F }
 263         default         { errexpect-error "unknown subclass ?" }
 264     }
 265     switch -exact [errexpect-arrayget vi isLocked]/[ \
 266                    errexpect-arrayget vi isBattleReady] {
 267         true/false      { append abbrev 2- }
 268         false/false     { append abbrev 1+ }
 269         false/true      { append abbrev 0* }
 270         default         { errexpect-error "unexpected isLocked/isBattleReady" }
 271     }
 272     set vid [errexpect-arrayget vi vesselId]
 273     upvar #0 notes($vid) note
 274     set realname [errexpect-arrayget vi vesselName]
 275     set island [errexpect-arrayget vi islandName]
 276
 277     set owner {}
 278     set xabbrev {}
 279     if {[info exists note]} {
 280         manyset $note lno notename owner xabbrev
 281         if {[string compare -nocase $realname $notename]} {
 282             note-info $lno $vid $realname \
 283                 "notes say name is $notename - perhaps renamed"
 284         }
 285         if {[string length $owner]} {
 286             if {![string compare $owner $pirate]} {
 287                 append abbrev =
 288             } else {
 289                 append abbrev -
 290             }
 291         }
 292         append abbrev $xabbrev
 293         set notes_used($vid) 1
 294
 295     } else {
 296         lappend note_missings [list $island $realname $vid]
 297     }
 298     lappend newnotes [list $vid $realname $owner $xabbrev]
 299
 300     set kk "$island $abbrev"
 301     upvar #0 count($kk) k
 302     if {![info exists k]} { set k 0 }
 303     incr k
 304 }
 305
 306 set clipboard {}
 307 proc parse-clipboard {} {
 308     global clipboard count notes notes_used newnotes
 309
 310     catch { unset count }
 311     catch { unset notes_used }
 312     glset note_infos {}
 313     glset note_missings {}
 314
 315     set newnotes {}
 316
 317     set itemre { (\w+) = ([^=]*) }
 318     set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
 319     debug $manyitemre
 320
 321     set lno 0
 322     foreach l [split $clipboard "\n"] {
 323         incr lno
 324         errexpect-setline $lno $l
 325         if {![string length $l]} continue
 326         catch { unset vi }
 327         while 1 {
 328                 if {![regexp -expanded $manyitemre $l dummy \
 329                         thiskey thisval rhs]} {
 330                     errexpect-error "badly formatted"
 331                 }
 332                 set vi($thiskey) $thisval
 333                 if {![string length $rhs]} break
 334                 regsub {^, } $rhs {} rhs
 335                 set l "\[$rhs\]"
 336         }
 337         vessel vi
 338     }
 339
 340     if {[llength $newnotes]} {
 341         foreach vid [lsort [array names notes]] {
 342             if {![info exists notes_used($vid)]} {
 343                 manyset $notes($vid) lno notename
 344                 note-info $lno $vid $notename \
 345                     "vessel in notes no longer found"
 346             }
 347         }
 348     }
 349 }
 350
 351 proc load-clipboard-file {fn} {
 352     set f [open $fn]
 353     glset clipboard [read $f]
 354     close $f
 355 }
 356
 357
 358 #---------- loading and parsing the chart ----------
 359
 360 proc load-chart {} {
 361     global chart scraper
 362     debug "FETCHING CHART"
 363     set chart [eval exec $scraper [list | perl -we {
 364         use strict;
 365         use CommodsScrape;
 366         use IO::File;
 367         use IO::Handle;
 368         yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
 369                 sub { sprintf "%d %d", @_; },
 370                 sub { printf "archlabel %d %d %s\n", @_; },
 371                 sub { printf "island %s %s\n", @_; },
 372                 sub { printf "league %s %s %s.\n", @_; },
 373                 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
 374                         );
 375         STDOUT->error and die $!;
 376     }]]
 377 }
 378
 379
 380 set scale 16
 381
 382 proc coord {c} {
 383         global scale
 384         return [expr {$c * $scale}]
 385 }
 386
 387 proc chart-got/archlabel {args} { }
 388 proc chart-got/island {x y args} {
 389 #       debug "ISLE $x $y $args"
 390         global canvas isleloc
 391         set isleloc($args) [list $x $y]
 392         set sz 5
 393 #       $canvas create oval \
 394 #               [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
 395 #               [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
 396 #               -fill blue
 397         $canvas create text [coord $x] [coord $y] \
 398                 -text $args -anchor s
 399 }
 400 proc chart-got/league {x1 y1 x2 y2 kind} {
 401 #       debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
 402         global canvas
 403         set l [$canvas create line \
 404                 [coord $x1] [coord $y1] \
 405                 [coord $x2] [coord $y2]]
 406         if {![string compare $kind .]} {
 407                 $canvas itemconfigure $l -dash .
 408         }
 409 }
 410
 411 proc draw {} {
 412     global chart count isleloc canvas
 413
 414     $canvas delete all
 415
 416     foreach l [split $chart "\n"] {
 417 #       debug "CHART-GOT $l"
 418         set proc [lindex $l 0]
 419         eval chart-got/$proc [lrange $l 1 end]
 420     }
 421
 422     set lastislandname {}
 423     foreach key [lsort [array names count]] {
 424         set c $count($key)
 425 #       debug "SHOWING $key $c"
 426         regexp {^(.*) (\S+)$} $key dummy islandname abbrev
 427         if {[string compare $lastislandname $islandname]} {
 428                 manyset $isleloc($islandname) x y
 429                 set x [coord $x]
 430                 set y [coord $y]
 431                 set lastislandname $islandname
 432 #               debug "START Y $y"
 433         }
 434         set text $abbrev
 435         regsub -all {[0-9]} $text {} text
 436         if {$c > 1} {
 437                 set text [format "%2d%s" $c $text]
 438         } else {
 439                 set text [format "  %s" $text]
 440         }
 441         set id [$canvas create text $x $y \
 442                 -anchor nw -font fixed \
 443                 -text $text]
 444         set bbox [$canvas bbox $id]
 445         set bid [eval $canvas create rectangle $bbox -fill white]
 446         $canvas lower $bid $id
 447         manyset $bbox dummy dummy dummy y
 448 #       debug "NEW Y $y"
 449     }
 450
 451     panner::updatecanvas-bbox .ctrl.pan
 452 }
 453
 454
 455 #---------- parser error reporting ----------
 456
 457 proc parser-control-create {w base invokebuttontext etl_title} {
 458     frame $w
 459     button $w.do -text $invokebuttontext -command invoke_$base
 460
 461     frame $w.resframe -width 120 -height 32
 462     button $w.resframe.res -text {} -anchor nw \
 463         -padx 1 -pady 1 -borderwidth 0 -justify left
 464     glset deffont_$base [$w.resframe.res cget -font]
 465     place $w.resframe.res -relx 0.5 -y 0 -anchor n
 466
 467     pack $w.do -side top
 468     pack $w.resframe -side top -expand y -fill both
 469
 470     set eb .err_$base
 471     toplevel $eb
 472     wm withdraw $eb
 473     wm title $eb "where-vessels - $etl_title"
 474
 475     label $eb.title -text $etl_title
 476     pack $eb.title -side top
 477
 478     button $eb.close -text Close -command [list wm withdraw $eb]
 479     pack $eb.close -side bottom
 480
 481     frame $eb.emsg -bd 2 -relief groove
 482     label $eb.emsg.lab -text "Error:"
 483     text $eb.emsg.text -height 1
 484     pack $eb.emsg.text -side bottom
 485     pack $eb.emsg.lab -side left
 486
 487     pack $eb.emsg -side top -pady 2
 488
 489     frame $eb.text -bd 2 -relief groove
 490     pack $eb.text -side bottom -pady 2
 491
 492     label $eb.text.lab
 493
 494     text $eb.text.text -width 85 \
 495         -xscrollcommand [list $eb.text.xscroll set] \
 496         -yscrollcommand [list $eb.text.yscroll set]
 497     $eb.text.text tag configure error \
 498         -background red -foreground white
 499
 500     scrollbar $eb.text.xscroll -orient horizontal \
 501         -command [list $eb.text.text xview]
 502     scrollbar $eb.text.yscroll -orient vertical \
 503         -command [list $eb.text.text yview]
 504
 505     grid configure $eb.text.lab -row 0 -column 0 -sticky w
 506     grid configure $eb.text.text -row 1 -column 0
 507     grid configure $eb.text.yscroll -sticky ns -row 1 -column 1
 508     grid configure $eb.text.xscroll -sticky ew -row 2 -column 0
 509 }
 510
 511 proc parser-control-ok-core {w base background show} {
 512     debug "parser-control-ok-core $w $base $background $show"
 513     upvar #0 deffont_$base deffont
 514     $w.resframe.res configure \
 515         -background $background -disabledforeground black -font $deffont \
 516         -state disabled -command {} \
 517         -text $show
 518 }
 519 proc parser-control-ok {w base show} {
 520     parser-control-ok-core $w $base green $show
 521 }
 522 proc parser-control-none {w base show} {
 523     parser-control-ok-core $w $base blue $show
 524 }
 525 proc parser-control-failed-core {w base foreground background smallfont
 526                                  tiny summary fulldesc fulldata} {
 527     debug "parser-control-failed-core $w $base $summary $fulldesc"
 528     upvar #0 deffont_$base deffont
 529     set eb .err_$base
 530
 531     $eb.emsg.text delete 0.0 end
 532     $eb.emsg.text insert end $summary
 533
 534     $eb.text.lab configure -text $fulldesc
 535     $eb.text.text delete 0.0 end
 536     $eb.text.text insert end $fulldata
 537
 538     regsub -all {.{18}} $tiny "&\n" ewrap
 539
 540     if {$smallfont} {
 541         set font fixed
 542     } else {
 543         set font $deffont
 544     }
 545
 546     $w.resframe.res configure \
 547         -background $background -foreground $foreground -font $font \
 548         -state normal -command [list wm deiconify $eb] \
 549         -text $ewrap
 550 }
 551
 552 proc parser-control-failed-expected {w base emsg lno ei fulldesc newdata} {
 553     set eb .err_$base
 554
 555     set line [lindex [split $ei "\n"] 0]
 556     debug "parser-control-failed-expected: $w $base: $lno: $emsg\n $line"
 557
 558     parser-control-failed-core $w $base \
 559         white red 1 \
 560         "err: [string trim $emsg]: \"$line\"" \
 561         "at line $lno: $emsg" \
 562         $fulldesc $newdata
 563
 564     $eb.text.text tag add error $lno.0 $lno.end
 565     $eb.text.text see $lno.0
 566 }
 567 proc parser-control-failed-unexpected {w base emsg ei} {
 568     global errorInfo
 569     parser-control-failed-core $w $base \
 570         black yellow 1 \
 571         $emsg $emsg "Details and stack trace:" $ei
 572 }
 573
 574 proc reparse {base varname old fulldesc okshow noneshow parse ok} {
 575     upvar #0 $varname var
 576     manyset [errexpect-catch {
 577         uplevel 1 $parse
 578         if {[string length [string trim $var]]} {
 579             parser-control-ok .ctrl.$base $base $okshow
 580         } else {
 581             parser-control-none .ctrl.$base $base $noneshow
 582         }
 583     }] failed emsg lno ei
 584     if {$failed} {
 585         parser-control-failed-expected .ctrl.$base $base \
 586             $emsg $lno $ei $fulldesc $var
 587         set var $old
 588         uplevel 1 $parse
 589     } else {
 590         uplevel 1 $ok
 591     }
 592 }
 593
 594 #---------- main user interface ----------
 595
 596 proc widgets-setup {} {
 597     global canvas debug pirate ocean
 598
 599     frame .f -border 1 -relief groove
 600     set canvas .f.c
 601     canvas $canvas
 602     pack $canvas -expand 1 -fill both
 603     pack .f -expand 1 -fill both -side left
 604
 605     frame .ctrl
 606     pack .ctrl -side right
 607
 608     debug "BBOX [$canvas bbox all]"
 609
 610     panner::canvas-scroll-bbox .f.c
 611     panner::create .ctrl.pan .f.c 120 120 $debug
 612
 613     pack .ctrl.pan -side top -pady 10 -padx 5
 614     frame .ctrl.zoom
 615     pack .ctrl.zoom -side top
 616
 617     button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
 618     button .ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2}
 619     pack .ctrl.zoom.out .ctrl.zoom.in -side left
 620
 621     parser-control-create .ctrl.acquire \
 622         acquire Acquire \
 623         "Clipboard parsing error" \
 624
 625     pack .ctrl.acquire -side top -pady 2
 626
 627     parser-control-create .ctrl.notes \
 628         notes "Reload notes" \
 629         "Vessel notes loading report" \
 630
 631     pack .ctrl.notes -side top -pady 2
 632
 633     wm geometry . 1024x480
 634     wm title . "where-vessels - $pirate on the $ocean ocean"
 635 }
 636
 637 proc zoom {extail} {
 638     global scale canvas
 639     set nscale [expr "\$scale $extail"]
 640     debug "ZOOM $scale $nscale"
 641     if {$nscale < 1 || $nscale > 200} return
 642     set scale $nscale
 643     draw
 644 }
 645
 646 proc invoke_acquire {} {
 647     global clipboard errorInfo
 648     set old $clipboard
 649
 650     if {[catch {
 651         set clipboard [clipboard get]
 652     } emsg]} {
 653         parser-control-failed-unexpected .ctrl.acquire acquire \
 654             $emsg "fetching clipboard:\n\n$errorInfo"
 655         return
 656     }
 657
 658     reparse acquire \
 659         clipboard $old "Clipboard contents:" { acquired ok } { no vessels } {
 660             parse-clipboard
 661         } {
 662             display-note-infos
 663         }
 664     draw
 665 }
 666
 667 proc invoke_notes {} {
 668     global notes_data errorInfo notes_loc
 669     set old $notes_data
 670
 671     if {[catch {
 672         load-notes
 673     } emsg]} {
 674         parser-control-failed-unexpected .ctrl.notes notes \
 675             $emsg "loading $notes_loc:\n\n$errorInfo"
 676         return
 677     }
 678
 679     reparse notes \
 680         notes_data $old "Vessel notes:" "loaded ok" { no notes } {
 681             parse-notes
 682             parse-clipboard
 683         } {
 684             display-note-infos
 685         }
 686     draw
 687 }
 688
 689 #---------- main program ----------
 690
 691 parseargs
 692 argdefaults
 693 httpclientsetup where-vessels
 694 load-chart
 695 widgets-setup
 696
 697 set notes_data {}
 698 after idle invoke_notes
 699
 700 draw