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