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