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-arrayget-boolean {arrayvar key} {
  70     switch -exact [uplevel 1 [list errexpect-arrayget $arrayvar $key]] {
  71         true    { return 1 }
  72         false   { return 0 }
  73         default { errexpect-error "unexpected $key" }
  74     }
  75 }
  76
  77 proc errexpect-catch {code} {
  78     global errorInfo errorCode
  79     set rc [catch {
  80         uplevel 1 $code
  81     } rv]
  82     debug "ERREXPECT CATCH |$rc|$rv|$errorCode|$errorInfo|"
  83     if {$rc==1 && ![string compare YARRG-ERREXPECT [lindex $errorCode 0]]} {
  84         return [list 1 $rv [lindex $errorCode 1] $errorInfo]
  85     } elseif {$rc==0} {
  86         return [list 0 $rv]
  87     } else {
  88         return -code $rc -errorinfo $errorInfo -errorcode $errorCode $rv
  89     }
  90 }
  91
  92 #---------- argument parsing ----------
  93
  94 proc nextarg {} {
  95     global ai argv
  96     if {$ai >= [llength $argv]} {
  97         badusage "option [lindex $argv [expr {$ai-1}]] needs a value"
  98     }
  99     set v [lindex $argv $ai]
 100     incr ai
 101     return $v
 102 }
 103
 104 set notes_loc vessel-notes
 105 set scraper {./yppedia-ocean-scraper --chart}
 106
 107 proc parseargs {} {
 108     global ai argv
 109     global debug scraper
 110     set ai 0
 111
 112     while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
 113         incr ai
 114         switch -exact -- $arg {
 115             -- { break }
 116             --pirate { glset pirate [string totitle [nextarg]] }
 117             --ocean { glset ocean [string totitle [nextarg]] }
 118             --clipboard-file { load-clipboard-file [nextarg] }
 119             --local-html-dir { lappend scraper --local-html-dir=[nextarg] }
 120             --notes { glset notes_loc [nextarg] }
 121             --debug { incr debug }
 122             default { badusage "unknown option $arg" }
 123         }
 124     }
 125     set argv [lrange $argv $ai end]
 126     if {[llength $argv]} { badusage "non-option args not allowed" }
 127 }
 128
 129 proc argdefaults {} {
 130     global ocean notes_loc pirate scraper
 131     if {![info exists ocean] || ![info exists pirate]} {
 132         set cmd {./yarrg --find-window-only --quiet}
 133         if {[info exists ocean]} { lappend cmd --ocean $ocean }
 134         if {[info exists pirate]} { lappend cmd --pirate $pirate }
 135         manyset [split [eval exec $cmd] " "] ocean pirate
 136         if {![llength $ocean] || ![llength $pirate]} {
 137             error "$ocean $pirate ?"
 138         }
 139     }
 140     lappend scraper $ocean
 141 }
 142
 143
 144 #---------- loading and parsing the vessel notes ----------
 145
 146 proc load-notes {} {
 147     global notes_loc notes_data
 148     if {[regexp {^\w+\:} $notes_loc]} {
 149         update
 150         debug "FETCHING NOTES $notes_loc"
 151         set req [::http::geturl $notes_loc]
 152         switch -glob [::http::status $req].[::http::ncode $req] {
 153             ok.200 { }
 154             ok.* { error "retrieving vessel-notes: [::http::code $req]" }
 155             * { error "Retrieving vessel-notes: [::http::error $req]" }
 156         }
 157         set newdata [::http::data $req]
 158         ::http::cleanup $req
 159     } else {
 160         debug "READING NOTES $notes_loc"
 161         set vn [open $notes_loc]
 162         set newdata [read $vn]
 163         close $vn
 164     }
 165     set notes_data $newdata
 166 }
 167
 168 proc parse-notes {} {
 169     global notes_data notes
 170     catch { unset notes }
 171
 172     set lno 0
 173     foreach l [split $notes_data "\n"] {
 174         incr lno
 175         errexpect-setline $lno $l
 176         set l [string trim $l]
 177         if {![string length $l]} continue
 178         if {[regexp {^\#} $l]} continue
 179         if {![regexp -expanded \
 180                   {^ (\d+) (?: \s+([^=]*?) )? \s* =
 181                       (?: \s* (\S+)
 182                        (?: \s+ (\S+) )?)? $} \
 183                   $l dummy vid vname owner note]} {
 184               errexpect-error "badly formatted"
 185         }
 186         set vname [string trim $vname]
 187         if {[info exists notes($vid)]} {
 188             errexpect-error "duplicate vesselid $vid"
 189         }
 190         set notes($vid) [list $lno $vname $owner $note]
 191     }
 192 }
 193
 194 proc note-info {lno vid name island description} {
 195     global note_infos
 196     lappend note_infos [list $lno $vid $name $island $description]
 197 }
 198
 199 proc display-note-infos {} {
 200     global note_infos note_missings notes
 201
 202     set nmissing [llength $note_missings]
 203     debug "display-note-infos $nmissing [array size notes]"
 204
 205     if {[llength $note_infos]} {
 206         set tiny "[llength $note_infos] warning(s)"
 207     } elseif {$nmissing && [array size notes]} {
 208         set tiny "$nmissing missing"
 209     } else {
 210         return
 211     }
 212
 213     set infodata {}
 214
 215     foreach info $note_infos {
 216         manyset $info lno vid name island description
 217         append infodata "vessel"
 218         append infodata " $vid"
 219         if {[string length $name]} { append infodata " $name" }
 220         if {[string length $island]} { append infodata " ($island)" }
 221         append infodata ": " $description "\n"
 222     }
 223
 224     if {$nmissing} {
 225         if {[string length $infodata]} { append infodata "\n" }
 226         append infodata "$nmissing vessel(s) not mentioned in notes:\n"
 227         set last_island {}
 228         foreach info [lsort $note_missings] {
 229             manyset $info island name vid
 230             if {[string compare $island $last_island]} {
 231                 append infodata "# $island:\n"
 232                 set last_island $island
 233             }
 234             append infodata [format "%-9d %-29s =\n" $vid $name]
 235         }
 236     }
 237
 238     parser-control-failed-core .cp.ctrl.notes notes \
 239         white blue 0 \
 240         $tiny \
 241         "[llength $note_infos] warning(s);\
 242          $nmissing vessel(s) missing" \
 243         "Full description of warnings and missing vessels:" \
 244         $infodata
 245 }
 246
 247 #---------- vessel properties ----------
 248
 249 proc vesselclasses-init {} {
 250     global vc_game2code vc_code2abbrev vc_code2full vc_codes
 251     set vcl {
 252         smsloop         am      sl      Sloop
 253         lgsloop         bm      ct      Cutter
 254         dhow            cm      dh      Dhow
 255         longship        dm      ls      Longship
 256         baghlah         em      bg      Baghlah
 257         junk            eo      jk      Junk
 258         merchbrig       fm      mb      {Merchant Brig}
 259         warbrig         gm      wb      {War Brig}
 260         xebec           hm      xe      Xebec
 261         merchgal        jm      mg      {Merchant Galleon}
 262         warfrig         im      wf      {War Frigate}
 263         grandfrig       km      gf      {Grand Frigate}
 264     }
 265     set vc_codes {}
 266     foreach {game code abbrev full} $vcl {
 267         lappend vc_codes $code
 268         set vc_game2code($game) $code
 269         set vc_code2abbrev($code) $abbrev
 270         set vc_code2full($code) $full
 271         load-icon $abbrev
 272     }
 273
 274     load-icon atsea
 275     foreach a {battle borrow dot} {
 276         foreach b {ours dot query} {
 277             load-icon-combine $a $b
 278         }
 279     }
 280 }
 281
 282 proc load-icon {icon} {
 283     image create bitmap icon/$icon -file icons/$icon.xbm
 284 }
 285
 286 proc load-icon-combine {args} {
 287     set cmd {}
 288     set delim "pnmcat -lr "
 289     foreach icon $args {
 290         append cmd $delim " <(xbmtopbm icons/$icon.xbm)"
 291         set delim " <(pbmmake -white 1 1)"
 292     }
 293     append cmd " | pbmtoxbm"
 294     debug "load-icon-combine $cmd"
 295     image create bitmap icon/[join $args +] -data [exec bash -c $cmd]
 296 }
 297
 298 proc code-lockown2icon {lockown} {
 299     manyset [split $lockown ""] lock notown
 300     return icon/[
 301                  lindex {battle borrow dot} $lock
 302                 ]+[
 303                    lindex {ours dot query} $notown
 304                   ]
 305 }
 306
 307 proc canvas-horiz-stack {xvar xoff y bind type args} {
 308     upvar 1 $xvar x
 309     upvar 1 canvas canvas
 310     set id [eval $canvas create $type [expr {$x+$xoff}] $y $args]
 311     set bbox [$canvas bbox $id]
 312     set x [lindex $bbox 2]
 313     $canvas bind $id <ButtonPress> $bind
 314     return $id
 315 }
 316
 317 proc code2canvas {code canvas x yvar qty qtylen bind} {
 318     global vc_code2abbrev
 319     upvar 1 $yvar y
 320
 321     manyset [split $code _] inport class subclass lockown xabbrev
 322
 323     set stackx $x
 324     incr stackx 2
 325     set imy [expr {$y+2}]
 326
 327     if {!$inport} { incr qtylen -1 }
 328     if {$qtylen<=0} { set qtylen {} }
 329     set qty [format "%${qtylen}s" $qty]
 330
 331     set qtyid [canvas-horiz-stack stackx 0 $y $bind \
 332                    text -anchor nw -font fixed -text $qty]
 333
 334     if {!$inport} {
 335         canvas-horiz-stack stackx 0 $imy $bind \
 336             image -anchor nw -image icon/atsea
 337         incr stackx
 338     }
 339
 340     canvas-horiz-stack stackx -1 $imy $bind \
 341             image -anchor nw -image icon/$vc_code2abbrev($class)
 342
 343     if {[string length $subclass]} {
 344         canvas-horiz-stack stackx 0 $y $bind \
 345             text -anchor nw -font fixed -text \
 346             $subclass
 347     }
 348
 349     incr stackx
 350     canvas-horiz-stack stackx 0 $imy $bind \
 351         image -anchor nw -image [code-lockown2icon $lockown]
 352     incr stackx
 353
 354     if {[string length $xabbrev]} {
 355         canvas-horiz-stack stackx 0 $y $bind \
 356             text -anchor nw -font fixed -text \
 357             $xabbrev
 358     }
 359
 360     set bbox [$canvas bbox $qtyid]
 361     set ny [lindex $bbox 3]
 362     set bid [$canvas create rectangle \
 363                  $x $y $stackx $ny \
 364                  -fill white]
 365
 366     set y $ny
 367     $canvas lower $bid $qtyid
 368
 369     $canvas bind $bid <ButtonPress> $bind
 370 }
 371
 372 proc show-report-decode {code} {
 373     global vc_code2full
 374
 375     manyset [split $code _] inport classcode subclass lockown xabbrev
 376     manyset [split $lockown ""] lock notown
 377
 378     report-set inport [lindex {{At Sea} {In port}} $inport]
 379     report-set class $vc_code2full($classcode)
 380
 381     switch -exact $subclass {
 382         {} { report-set subclass {Ordinary} }
 383         E { report-set subclass {Emerald class} }
 384         F { report-set subclass {Frost class} }
 385         R { report-set subclass {Rogue class} }
 386         V { report-set subclass {Verdant class} }
 387         I { report-set subclass {Inferno class} }
 388         default { report-set subclass "Subclass \"$subclass\"" }
 389     }
 390
 391     report-set lock [lindex {
 392         {Battle ready} {Unlocked} {Locked}
 393     } $lock]
 394
 395     switch -exact $notown {
 396         0 { report-set own "Yours" }
 397         1 { report-set own "Other pirate's" }
 398         2 { report-set own "Owner unknown" }
 399         default { report-set own "?? $notown" }
 400     }
 401
 402     if {[string length $xabbrev]} {
 403         report-set xabbrev "Notes flags: $xabbrev"
 404     } else {
 405         report-set xabbrev "No flags in notes"
 406     }
 407 }
 408
 409 #---------- filtering ----------
 410
 411 set filters {}
 412
 413 proc filter-values/size {} { global vc_codes; return $vc_codes }
 414 proc filter-icon/size {code} {
 415     upvar #0 vc_code2abbrev($code) abb
 416     return icon/$abb
 417 }
 418 proc filter-default/size {code} { return 1 }
 419 proc filter-says-yes/size {codel} {
 420     set sizecode [lindex $codel 1]
 421     upvar #0 filter_size($sizecode) yes
 422     return $yes
 423 }
 424
 425 proc filter-values/lockown {} {
 426     foreach lv {0 1 2} {
 427         foreach ov {0 1 2} {
 428             lappend vals "$lv$ov"
 429         }
 430     }
 431     return $vals
 432 }
 433 proc filter-icon/lockown {lockown} { return [code-lockown2icon $lockown] }
 434 proc filter-default/lockown {lockown} {
 435     return [regexp {^[01]|^2[^1]} $lockown]
 436 }
 437 proc filter-says-yes/lockown {codel} {
 438     set lockown [lindex $codel 3]
 439     upvar #0 filter_lockown($lockown) yes
 440     return $yes
 441 }
 442
 443 proc filter-validate/xabbre {re} {
 444     if {[catch {
 445         regexp -- $re {}
 446     } emsg]} {
 447         regsub {^.*:\s*} $emsg {} emsg
 448         regsub {^.*(.{30})$} $emsg {\1} emsg
 449         return $emsg
 450     }
 451     return {}
 452 }
 453 proc filter-says-yes/xabbre {codel} {
 454     global filter_xabbre
 455     set xabbrev [lindex $codel 4]
 456     return [regexp -- $filter_xabbre $xabbrev]
 457 }
 458
 459 proc filter-tickbox-flip {fil} {
 460     upvar #0 filter_$fil vars
 461     set values [filter-values/$fil]
 462     foreach val $values {
 463         set vars($val) [expr {!$vars($val)}]
 464     }
 465     redraw-needed
 466 }
 467
 468 proc make-tickbox-filter {fil label rows inrow} {
 469     upvar #0 filter_$fil vars
 470     set fw [make-filter tickbox $fil $label frame]
 471     set values [filter-values/$fil]
 472     set nvalues [llength $values]
 473     if {!$inrow} {
 474         set inrow [expr {($nvalues + $rows) / $rows}]
 475     }
 476     set noicons [catch { info args filter-icon/$fil }]
 477     for {set ix 0} {$ix < $nvalues} {incr ix} {
 478         set val [lindex $values $ix]
 479         set vars($val) [filter-default/$fil $val]
 480         checkbutton $fw.$ix -variable filter_${fil}($val) \
 481             -font fixed -command redraw-needed
 482         if {!$noicons} {
 483             $fw.$ix configure -image [filter-icon/$fil $val] -height 16
 484         } else {
 485             $fw.$ix configure -text [filter-map/$fil $val]
 486         }
 487         grid configure $fw.$ix -sticky sw \
 488             -row [expr {$ix / $inrow}] \
 489             -column [expr {$ix % $inrow}]
 490     }
 491     button $fw.invert -text flip -command [list filter-tickbox-flip $fil] \
 492         -padx 0 -pady 0
 493     grid configure $fw.invert -sticky se \
 494         -row [expr {$rows-1}] \
 495         -column [expr {$inrow-1}]
 496 }
 497
 498 proc entry-filter-changed {fw fil n1 n2 op} {
 499     global errorInfo
 500     upvar #0 filter_$fil realvar
 501     upvar #0 filterentered_$fil entryvar
 502     global def_background
 503     debug "entry-filter-changed $fw $fil $entryvar"
 504     if {[catch {
 505         set error [filter-validate/$fil $entryvar]
 506         if {[string length $error]} {
 507             $fw.error configure -text $error -foreground white -background red
 508         } else {
 509             $fw.error configure -text { } -background $def_background
 510             set realvar $entryvar
 511             redraw-needed
 512         }
 513     } emsg]} {
 514         puts stderr "FILTER CHECK ERROR $emsg $errorInfo"
 515     }
 516 }
 517
 518 proc make-entry-filter {fil label def} {
 519     global filterentered_$fil
 520     upvar #0 filter_$fil realvar
 521     set realvar $def
 522     set fw [make-filter entry $fil $label frame]
 523     entry $fw.entry -textvariable filterentered_$fil
 524     label $fw.error
 525     glset def_background [$fw.error cget -background]
 526     trace add variable filterentered_$fil write \
 527         [list entry-filter-changed $fw $fil]
 528     pack $fw.entry $fw.error -side top -anchor w
 529 }
 530
 531 proc make-filter {kind fil label ekind} {
 532     global filters
 533     label .filter.lab_$fil -text $label -justify left
 534     $ekind .filter.$fil
 535     lappend filters $fil
 536     set nfilters [llength $filters]
 537     grid configure .filter.lab_$fil -row $nfilters -column 0 -sticky nw -pady 4
 538     grid configure .filter.$fil -row $nfilters -column 1 -sticky w -pady 3
 539     return .filter.$fil
 540 }
 541
 542 proc make-filters {} {
 543     make-tickbox-filter size Size 2 0
 544     make-tickbox-filter lockown "Lock/\nowner" 2 6
 545     make-entry-filter xabbre "Flags\n regexp" {}
 546 }
 547
 548 proc filterstyle-changed {n1 n2 op} {
 549     global filterstyle
 550     debug "filterstyle-changed $filterstyle"
 551     redraw-needed
 552 }
 553
 554 proc filters-say-yes {code} {
 555     global filters filterstyle
 556     debug "filters-say-yes $code"
 557     set codel [split $code _]
 558     set lockown [lindex $codel 3]
 559     switch -exact $filterstyle {
 560         0 { return 1 }
 561         1 { return [filter-default/lockown $lockown] }
 562         2 { return [regexp {^.0} $lockown] }
 563         3 { }
 564         default { error $filterstyle }
 565     }
 566
 567     foreach fil $filters {
 568         if {![filter-says-yes/$fil $codel]} { return 0 }
 569     }
 570     return 1
 571 }
 572
 573 #---------- loading and parsing the clipboard (vessel locations) ----------
 574
 575 proc vessel {vin} {
 576     global pirate notes_used note_missings newnotes
 577     upvar 1 $vin vi
 578
 579     set codel {}
 580     lappend codel [errexpect-arrayget-boolean vi inPort]
 581
 582     set gameclass [errexpect-arrayget vi vesselClass]
 583     upvar #0 vc_game2code($gameclass) class
 584     if {![info exists class]} { errexpect-error "unexpected vesselClass"}
 585     lappend codel $class
 586
 587     set subclass [errexpect-arrayget vi vesselSubclass]
 588     switch -exact $subclass {
 589         null            { lappend codel {} }
 590         celtic          { lappend codel E }
 591         icy             { lappend codel F }
 592         rogue           { lappend codel R }
 593         verdant         { lappend codel V }
 594         inferno         { lappend codel I }
 595         default         { lappend codel ($subclass) }
 596     }
 597
 598     switch -exact [errexpect-arrayget vi isLocked]/[ \
 599                    errexpect-arrayget vi isBattleReady] {
 600         true/false      { set lock 2 }
 601         false/false     { set lock 1 }
 602         false/true      { set lock 0 }
 603         default         { errexpect-error "unexpected isLocked/isBattleReady" }
 604     }
 605
 606     set vid [errexpect-arrayget vi vesselId]
 607     upvar #0 notes($vid) note
 608     set realname [errexpect-arrayget vi vesselName]
 609     set island [errexpect-arrayget vi islandName]
 610
 611     set owner {}
 612     set xabbrev {}
 613     if {[info exists note]} {
 614         manyset $note lno notename owner xabbrev
 615         if {[string compare -nocase $realname $notename]} {
 616             note-info $lno $vid $realname $island \
 617                 "notes say name is $notename"
 618         }
 619         if {[string length $owner]} {
 620             if {![string compare $owner $pirate]} {
 621                 set notown 0
 622             } else {
 623                 set notown 1
 624             }
 625         } else {
 626             set notown 2
 627         }
 628         append abbrev $xabbrev
 629         set notes_used($vid) 1
 630
 631     } else {
 632         set notown 2
 633         lappend note_missings [list $island $realname $vid]
 634     }
 635
 636     lappend codel "$lock$notown" $xabbrev
 637     lappend newnotes [list $vid $realname $owner $xabbrev]
 638     set kk "$island [join $codel _]"
 639     upvar #0 found($kk) k
 640     lappend k [list $vid $realname $owner]
 641
 642     debug "CODED $kk $vid $realname"
 643 }
 644
 645 set clipboard {}
 646 proc parse-clipboard {} {
 647     global clipboard found notes notes_used newnotes
 648
 649     catch { unset found }
 650     catch { unset notes_used }
 651     glset note_infos {}
 652     glset note_missings {}
 653
 654     set newnotes {}
 655
 656     set itemre { (\w+) = ([^=]*) }
 657     set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
 658     debug $manyitemre
 659
 660     set lno 0
 661     foreach l [split $clipboard "\n"] {
 662         incr lno
 663         errexpect-setline $lno $l
 664         if {![string length $l]} continue
 665         catch { unset vi }
 666         while 1 {
 667                 if {![regexp -expanded $manyitemre $l dummy \
 668                         thiskey thisval rhs]} {
 669                     errexpect-error "badly formatted"
 670                 }
 671                 set vi($thiskey) $thisval
 672                 if {![string length $rhs]} break
 673                 regsub {^, } $rhs {} rhs
 674                 set l "\[$rhs\]"
 675         }
 676         vessel vi
 677     }
 678
 679     if {[llength $newnotes]} {
 680         foreach vid [lsort [array names notes]] {
 681             if {![info exists notes_used($vid)]} {
 682                 manyset $notes($vid) lno notename
 683                 note-info $lno $vid $notename {} \
 684                     "vessel in notes no longer found"
 685             }
 686         }
 687     }
 688 }
 689
 690 proc load-clipboard-file {fn} {
 691     set f [open $fn]
 692     glset clipboard [read $f]
 693     close $f
 694 }
 695
 696
 697 #---------- loading and parsing the chart ----------
 698
 699 proc load-chart {} {
 700     global chart scraper
 701     debug "FETCHING CHART"
 702     set chart [eval exec $scraper [list | perl -we {
 703         use strict;
 704         use CommodsScrape;
 705         use IO::File;
 706         use IO::Handle;
 707         yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
 708                 sub { sprintf "%d %d", @_; },
 709                 sub { printf "archlabel %d %d %s\n", @_; },
 710                 sub { printf "island %s %s\n", @_; },
 711                 sub { printf "league %s %s %s.\n", @_; },
 712                 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
 713                         );
 714         STDOUT->error and die $!;
 715     }]]
 716 }
 717
 718
 719 set scale 16
 720
 721 proc coord {c} {
 722         global scale
 723         return [expr {$c * $scale}]
 724 }
 725
 726 proc chart-got/archlabel {args} { }
 727 proc chart-got/island {x y args} {
 728 #       debug "ISLE $x $y $args"
 729         global canvas isleloc
 730         set isleloc($args) [list $x $y]
 731         set sz 5
 732 #       $canvas create oval \
 733 #               [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
 734 #               [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
 735 #               -fill blue
 736         $canvas create text [coord $x] [coord $y] \
 737                 -text $args -anchor s
 738 }
 739 proc chart-got/league {x1 y1 x2 y2 kind} {
 740 #       debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
 741         global canvas
 742         set l [$canvas create line \
 743                 [coord $x1] [coord $y1] \
 744                 [coord $x2] [coord $y2]]
 745         if {![string compare $kind .]} {
 746                 $canvas itemconfigure $l -dash .
 747         }
 748 }
 749
 750 proc redraw-needed {} {
 751     global redraw_after
 752     debug "REDRAW NEEDED"
 753     if {[info exists redraw_after]} return
 754     set redraw_after [after 250 draw]
 755 }
 756
 757 proc draw {} {
 758     global chart found isleloc canvas redraw_after islandnames
 759
 760     catch { after cancel $redraw_after }
 761     catch { unset redraw_after }
 762
 763     $canvas delete all
 764
 765     foreach l [split $chart "\n"] {
 766 #       debug "CHART-GOT $l"
 767         set proc [lindex $l 0]
 768         eval chart-got/$proc [lrange $l 1 end]
 769     }
 770
 771     set islandnames {}
 772     set lastislandname {}
 773     foreach key [lsort [array names found]] {
 774         set c [llength $found($key)]
 775 #       debug "SHOWING $key $c"
 776         regexp {^(.*) (\S+)$} $key dummy islandname code
 777
 778         if {![filters-say-yes $code]} continue
 779
 780         if {[string compare $lastislandname $islandname]} {
 781                 manyset $isleloc($islandname) x y
 782                 set x [coord $x]
 783                 set y [coord $y]
 784                 set lastislandname $islandname
 785                 lappend islandnames $islandname
 786 #               debug "START Y $y"
 787         }
 788
 789         if {$c > 1} { set qty [format %d $c] } else { set qty {} }
 790         code2canvas $code $canvas $x y $qty 2 \
 791             [list show-report $islandname $code]
 792 #       debug "NEW Y $y"
 793     }
 794
 795     panner::updatecanvas-bbox .cp.ctrl.pan
 796
 797     islandnames-update
 798 }
 799
 800
 801 #---------- parser error reporting ----------
 802
 803 proc parser-control-create {w base invokebuttontext etl_title} {
 804     frame $w
 805     button $w.do -text $invokebuttontext -command invoke_$base -pady 3
 806
 807     frame $w.resframe -width 120 -height 32
 808     button $w.resframe.res -text {} -anchor nw \
 809         -padx 1 -pady 1 -borderwidth 0 -justify left
 810     glset deffont_$base [$w.resframe.res cget -font]
 811     place $w.resframe.res -relx 0.5 -y 0 -anchor n
 812
 813     pack $w.do -side top
 814     pack $w.resframe -side top -expand y -fill both
 815
 816     set eb .err_$base
 817     toplevel $eb
 818     wm withdraw $eb
 819     wm title $eb "where-vessels - $etl_title"
 820     wm protocol $eb WM_DELETE_WINDOW [list wm withdraw $eb]
 821
 822     label $eb.title -text $etl_title
 823     pack $eb.title -side top
 824
 825     button $eb.close -text Close -command [list wm withdraw $eb]
 826     pack $eb.close -side bottom
 827
 828     frame $eb.emsg -bd 2 -relief groove
 829     label $eb.emsg.lab -anchor nw -text "Error:"
 830     text $eb.emsg.text -height 1
 831     pack $eb.emsg.text -side bottom -fill x
 832     pack $eb.emsg.lab -side left
 833
 834     pack $eb.emsg -side top -pady 2 -fill x
 835
 836     frame $eb.text -bd 2 -relief groove
 837     pack $eb.text -side bottom -pady 2 -fill both -expand y
 838
 839     label $eb.text.lab -anchor nw
 840
 841     text $eb.text.text -width 85 \
 842         -xscrollcommand [list $eb.text.xscroll set] \
 843         -yscrollcommand [list $eb.text.yscroll set]
 844     $eb.text.text tag configure error \
 845         -background red -foreground white
 846
 847     scrollbar $eb.text.xscroll -orient horizontal \
 848         -command [list $eb.text.text xview]
 849     scrollbar $eb.text.yscroll -orient vertical \
 850         -command [list $eb.text.text yview]
 851
 852     grid configure $eb.text.lab -row 0 -column 0 -sticky w -columnspan 2
 853     grid configure $eb.text.text -row 1 -column 0 -sticky news
 854     grid configure $eb.text.yscroll -sticky ns -row 1 -column 1
 855     grid configure $eb.text.xscroll -sticky ew -row 2 -column 0
 856     grid rowconfigure $eb.text 0 -weight 0
 857     grid rowconfigure $eb.text 1 -weight 1
 858     grid rowconfigure $eb.text 2 -weight 0
 859     grid columnconfigure $eb.text 0 -weight 1
 860     grid columnconfigure $eb.text 1 -weight 0
 861 }
 862
 863 proc parser-control-ok-core {w base background show} {
 864     debug "parser-control-ok-core $w $base $background $show"
 865     upvar #0 deffont_$base deffont
 866     $w.resframe.res configure \
 867         -background $background -disabledforeground black -font $deffont \
 868         -state disabled -command {} \
 869         -text $show
 870 }
 871 proc parser-control-ok {w base show} {
 872     parser-control-ok-core $w $base green $show
 873 }
 874 proc parser-control-none {w base show} {
 875     parser-control-ok-core $w $base blue $show
 876 }
 877 proc parser-control-failed-core {w base foreground background smallfont
 878                                  tiny summary fulldesc fulldata} {
 879     debug "parser-control-failed-core $w $base $summary $fulldesc"
 880     upvar #0 deffont_$base deffont
 881     set eb .err_$base
 882
 883     $eb.emsg.text delete 0.0 end
 884     $eb.emsg.text insert end $summary
 885
 886     $eb.text.lab configure -text $fulldesc
 887     $eb.text.text delete 0.0 end
 888     $eb.text.text insert end $fulldata
 889
 890     regsub -all {.{18}} $tiny "&\n" ewrap
 891
 892     if {$smallfont} {
 893         set font fixed
 894     } else {
 895         set font $deffont
 896     }
 897
 898     $w.resframe.res configure \
 899         -background $background -foreground $foreground -font $font \
 900         -state normal -command [list wm deiconify $eb] \
 901         -text $ewrap
 902 }
 903
 904 proc parser-control-failed-expected {w base emsg lno ei fulldesc newdata} {
 905     set eb .err_$base
 906
 907     set line [lindex [split $ei "\n"] 0]
 908     debug "parser-control-failed-expected: $w $base: $lno: $emsg\n $line"
 909
 910     parser-control-failed-core $w $base \
 911         white red 1 \
 912         "err: [string trim $emsg]: \"$line\"" \
 913         "at line $lno: $emsg" \
 914         $fulldesc $newdata
 915
 916     $eb.text.text tag add error $lno.0 $lno.end
 917     $eb.text.text see $lno.0
 918 }
 919 proc parser-control-failed-unexpected {w base emsg ei} {
 920     global errorInfo
 921     parser-control-failed-core $w $base \
 922         black yellow 1 \
 923         $emsg $emsg "Details and stack trace:" $ei
 924 }
 925
 926 proc reparse {base varname old fulldesc okshow noneshow parse ok} {
 927     upvar #0 $varname var
 928     manyset [errexpect-catch {
 929         uplevel 1 $parse
 930         if {[string length [string trim $var]]} {
 931             parser-control-ok .cp.ctrl.$base $base $okshow
 932         } else {
 933             parser-control-none .cp.ctrl.$base $base $noneshow
 934         }
 935     }] failed emsg lno ei
 936     if {$failed} {
 937         parser-control-failed-expected .cp.ctrl.$base $base \
 938             $emsg $lno $ei $fulldesc $var
 939         set var $old
 940         uplevel 1 $parse
 941     } else {
 942         uplevel 1 $ok
 943     }
 944 }
 945
 946 #---------- island names selection etc. ----------
 947
 948 proc islandnames-update {} {
 949     global islandnames
 950     .islands.count configure -text [format "ships at %d island(s)" \
 951                                         [llength $islandnames]]
 952 }
 953
 954 proc islandnames-select {} {
 955     .islands.clip configure -relief sunken -state disabled
 956     selection own -command islandnames-deselect .islands.clip
 957 }
 958 proc islandnames-deselect {} {
 959     .islands.clip configure -relief raised -state normal
 960 }
 961
 962 proc islandnames-handler {offset maxchars} {
 963     global islandnames
 964     return [string range [join $islandnames ", "] \
 965                 $offset [expr {$offset+$maxchars-1}]]
 966 }
 967
 968 #---------- main user interface ----------
 969
 970 proc widgets-setup {} {
 971     global canvas debug pirate ocean filterstyle
 972
 973     wm geometry . 1024x600
 974     wm title . "where-vessels - $pirate on the $ocean ocean"
 975
 976     #----- map -----
 977
 978     frame .f -border 1 -relief groove
 979     set canvas .f.c
 980     canvas $canvas
 981     pack $canvas -expand 1 -fill both
 982     pack .f -expand 1 -fill both -side left
 983
 984     #----- control panels and filter -----
 985
 986     frame .cp
 987     frame .filter -relief groove -bd 2 -padx 1
 988     frame .islands -pady 2
 989     pack .cp .filter .islands -side top
 990
 991     set filterstyle 1
 992     trace add variable filterstyle write filterstyle-changed
 993
 994     frame .filter.title
 995     label .filter.title.title -text Show
 996     pack .filter.title.title -side left
 997     for {set fing 0} {$fing < 4} {incr fing} {
 998         radiobutton .filter.title.f$fing \
 999             -variable filterstyle -value $fing \
1000             -text [lindex {All Useable Mine These:} $fing]
1001         pack .filter.title.f$fing -side left
1002     }
1003
1004     grid configure .filter.title -row 0 -column 0 -columnspan 2
1005
1006     #----- control panel -----
1007
1008     frame .cp.ctrl
1009     pack .cp.ctrl -side left -anchor n
1010
1011     debug "BBOX [$canvas bbox all]"
1012
1013     panner::canvas-scroll-bbox .f.c
1014     panner::create .cp.ctrl.pan .f.c 120 120 $debug
1015
1016     pack .cp.ctrl.pan -side top -pady 0 -padx 5
1017     frame .cp.ctrl.zoom
1018     pack .cp.ctrl.zoom -side top
1019
1020     button .cp.ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2} -pady 0
1021     button .cp.ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2} -pady 0
1022     pack .cp.ctrl.zoom.out .cp.ctrl.zoom.in -side left
1023
1024     parser-control-create .cp.ctrl.acquire \
1025         acquire Acquire \
1026         "Clipboard parsing error" \
1027
1028     pack .cp.ctrl.acquire -side top -pady 2
1029
1030     parser-control-create .cp.ctrl.notes \
1031         notes "Reload notes" \
1032         "Vessel notes loading report" \
1033
1034     pack .cp.ctrl.notes -side top -pady 2
1035
1036     #----- island name count and copy -----
1037
1038     label .islands.count
1039     button .islands.clip -text "copy island names" -pady 2 -padx 2 \
1040          -command islandnames-select
1041     selection handle .islands.clip islandnames-handler
1042     pack .islands.count .islands.clip -side left
1043
1044     #----- decoding etc. report -----
1045
1046     frame .cp.report
1047     pack .cp.report -side left -anchor n
1048
1049     label .cp.report.island -text { }
1050
1051     canvas .cp.report.abbrev -width 1 -height 15
1052
1053     frame .cp.report.code
1054     label .cp.report.code.lab -text Code:
1055     glset report_code { }
1056     entry .cp.report.code.code -state readonly \
1057         -textvariable report_code -width 15
1058     pack .cp.report.code.lab .cp.report.code.code -side left
1059     frame .cp.report.details -bd 2 -relief groove -padx 2 -pady 2
1060
1061     listbox .cp.report.list -height 5
1062
1063     pack .cp.report.island .cp.report.abbrev .cp.report.details \
1064         .cp.report.list -side top
1065     #pack .cp.report.code -side top
1066     pack configure .cp.report.details -fill x
1067
1068     foreach sw {inport class subclass lock own xabbrev} {
1069         label .cp.report.details.$sw -text { }
1070         pack .cp.report.details.$sw -side top -anchor w
1071     }
1072 }
1073
1074 proc report-set {sw val} { .cp.report.details.$sw configure -text $val }
1075
1076 proc show-report {islandname code} {
1077     .cp.report.island configure -text $islandname
1078
1079     .cp.report.abbrev delete all
1080     set y 2
1081     code2canvas $code .cp.report.abbrev 5 y {} 0 {}
1082     manyset [.cp.report.abbrev bbox all] minx dummy maxx dummy
1083     .cp.report.abbrev configure -width [expr {$maxx-$minx+4}]
1084
1085     glset report_code $code
1086     show-report-decode $code
1087
1088     set kk "$islandname $code"
1089     upvar #0 found($kk) k
1090
1091     .cp.report.list delete 0 end
1092
1093     foreach entry $k {
1094         manyset $entry vid name owner
1095         lappend owned($owner) $name
1096     }
1097
1098     foreach owner [lsort [array names owned]] {
1099         if {[string length $owner]} {
1100             set owndesc "$owner's"
1101         } else {
1102             set owndesc "Owner unknown"
1103         }
1104         .cp.report.list insert end "$owndesc:"
1105         foreach name $owned($owner) {
1106             .cp.report.list insert end " $name"
1107         }
1108     }
1109 }
1110
1111 proc zoom {extail} {
1112     global scale canvas
1113     set nscale [expr "\$scale $extail"]
1114     debug "ZOOM $scale $nscale"
1115     if {$nscale < 1 || $nscale > 200} return
1116     set scale $nscale
1117     draw
1118 }
1119
1120 proc invoke_acquire {} {
1121     global clipboard errorInfo
1122     set old $clipboard
1123
1124     if {[catch {
1125         set clipboard [clipboard get]
1126     } emsg]} {
1127         parser-control-failed-unexpected .cp.ctrl.acquire acquire \
1128             $emsg "fetching clipboard:\n\n$errorInfo"
1129         return
1130     }
1131
1132     reparse acquire \
1133         clipboard $old "Clipboard contents:" { acquired ok } { no vessels } {
1134             parse-clipboard
1135         } {
1136             display-note-infos
1137         }
1138     draw
1139 }
1140
1141 proc invoke_notes {} {
1142     global notes_data errorInfo notes_loc
1143     set old $notes_data
1144
1145     if {[catch {
1146         load-notes
1147     } emsg]} {
1148         parser-control-failed-unexpected .cp.ctrl.notes notes \
1149             $emsg "loading $notes_loc:\n\n$errorInfo"
1150         return
1151     }
1152
1153     reparse notes \
1154         notes_data $old "Vessel notes:" "loaded ok" { no notes } {
1155             parse-notes
1156             parse-clipboard
1157         } {
1158             display-note-infos
1159         }
1160     draw
1161 }
1162
1163 #---------- main program ----------
1164
1165 parseargs
1166 vesselclasses-init
1167 argdefaults
1168 httpclientsetup where-vessels
1169 load-chart
1170 widgets-setup
1171 make-filters
1172
1173 set notes_data {}
1174 if {[catch { parse-clipboard } emsg]} {
1175     puts stderr "$emsg\n$errorInfo"
1176     exit 1
1177 }
1178 after idle invoke_notes
1179
1180 draw