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