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 {}
 105 set scraper {./yppedia-ocean-scraper --chart}
 106 set info_cache _vessel-info-cache
 107 set info_source rsync.yarrg.chiark.net::yarrg/vessel-info
 108 set filter_lockown_separate 0
 109
 110 proc parseargs {} {
 111     global ai argv
 112     global debug scraper
 113     set ai 0
 114
 115     while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
 116         incr ai
 117         switch -exact -- $arg {
 118             -- { break }
 119             --pirate { glset pirate [string totitle [nextarg]] }
 120             --ocean { glset ocean [string totitle [nextarg]] }
 121             --clipboard-file { load-clipboard-file [nextarg] }
 122             --local-html-dir { lappend scraper --local-html-dir=[nextarg] }
 123             --notes { glset notes_loc [nextarg] }
 124             --vessel-info-source { glset info_source [nextarg] }
 125             --filter-separate-lock-owner { glset filter_lockown_separate 1 }
 126             --debug { incr debug }
 127             default { badusage "unknown option $arg" }
 128         }
 129     }
 130     set argv [lrange $argv $ai end]
 131     if {[llength $argv]} { badusage "non-option args not allowed" }
 132 }
 133
 134 proc have-notes {} {
 135     global notes_loc
 136     return [string length $notes_loc]
 137 }
 138 proc have-ownership {} {
 139     return [expr {[have-notes] && [string length $pirate]}]
 140 }
 141
 142 proc argdefaults {} {
 143     global ocean notes_loc pirate scraper
 144     if {![info exists ocean] ||
 145         (![info exists pirate] && [string length $notes_loc])} {
 146         set cmd {./yarrg --find-window-only --quiet}
 147         if {[info exists ocean]} { lappend cmd --ocean $ocean }
 148         if {[info exists pirate]} { lappend cmd --pirate $pirate }
 149         manyset [split [eval exec $cmd] " "] ocean pirate
 150         if {![llength $ocean] || ![llength $pirate]} {
 151             error "$ocean $pirate ?"
 152         }
 153     }
 154     if {![info exists pirate]} {
 155         set pirate {}
 156     }
 157     if {![have-notes]} {
 158         glset filter_lockown_separate 1
 159     }
 160
 161     lappend scraper $ocean
 162 }
 163
 164
 165 #---------- loading and parsing the vessel notes ----------
 166
 167 proc load-notes {} {
 168     global notes_loc notes_data
 169     if {[regexp {^\w+\:} $notes_loc]} {
 170         update
 171         debug "FETCHING NOTES $notes_loc"
 172         set req [::http::geturl $notes_loc]
 173         switch -glob [::http::status $req].[::http::ncode $req] {
 174             ok.200 { }
 175             ok.* { error "retrieving vessel-notes: [::http::code $req]" }
 176             * { error "Retrieving vessel-notes: [::http::error $req]" }
 177         }
 178         set newdata [::http::data $req]
 179         ::http::cleanup $req
 180     } else {
 181         debug "READING NOTES $notes_loc"
 182         set vn [open $notes_loc]
 183         set newdata [read $vn]
 184         close $vn
 185     }
 186     set notes_data $newdata
 187 }
 188
 189 proc parse-notes {} {
 190     global notes_data notes
 191     catch { unset notes }
 192
 193     set lno 0
 194     foreach l [split $notes_data "\n"] {
 195         incr lno
 196         errexpect-setline $lno $l
 197         set l [string trim $l]
 198         if {![string length $l]} continue
 199         if {[regexp {^\#} $l]} continue
 200         if {![regexp -expanded \
 201                   {^ (\d+) (?: \s+([^=]*?) )? \s* =
 202                       (?: \s* (\S+)
 203                        (?: \s+ (\S+) )?)? $} \
 204                   $l dummy vid vname owner note]} {
 205               errexpect-error "badly formatted"
 206         }
 207         set vname [string trim $vname]
 208         if {[info exists notes($vid)]} {
 209             errexpect-error "duplicate vesselid $vid"
 210         }
 211         set notes($vid) [list $lno $vname $owner $note]
 212     }
 213 }
 214
 215 proc note-info {lno vid name island description} {
 216     global note_infos
 217     lappend note_infos [list $lno $vid $name $island $description]
 218 }
 219
 220 proc display-note-infos {} {
 221     global note_infos note_missings notes
 222
 223     set nmissing [llength $note_missings]
 224     debug "display-note-infos $nmissing [array size notes]"
 225
 226     if {[llength $note_infos]} {
 227         set tiny "[llength $note_infos] warning(s)"
 228     } elseif {$nmissing && [array size notes]} {
 229         set tiny "$nmissing missing"
 230     } else {
 231         return
 232     }
 233
 234     set infodata {}
 235
 236     foreach info $note_infos {
 237         manyset $info lno vid name island description
 238         append infodata "vessel"
 239         append infodata " $vid"
 240         if {[string length $name]} { append infodata " $name" }
 241         if {[string length $island]} { append infodata " ($island)" }
 242         append infodata ": " $description "\n"
 243     }
 244
 245     if {$nmissing} {
 246         if {[string length $infodata]} { append infodata "\n" }
 247         append infodata "$nmissing vessel(s) not mentioned in notes:\n"
 248         set last_island {}
 249         foreach info [lsort $note_missings] {
 250             manyset $info island name vid
 251             if {[string compare $island $last_island]} {
 252                 append infodata "# $island:\n"
 253                 set last_island $island
 254             }
 255             append infodata [format "%-9d %-29s =\n" $vid $name]
 256         }
 257     }
 258
 259     parser-control-failed-core .cp.ctrl.notes notes \
 260         white blue 0 \
 261         $tiny \
 262         "[llength $note_infos] warning(s);\
 263          $nmissing vessel(s) missing" \
 264         "Full description of warnings and missing vessels:" \
 265         $infodata
 266 }
 267
 268 #---------- vessel info and icons ----------
 269
 270 proc info-cache-update {} {
 271     global info_source info_cache
 272     file mkdir $info_cache
 273     exec sh -c "cp -u icons/* $info_cache/."
 274
 275     if {[string length $info_source]} {
 276         set cmdl [list \
 277                   rsync -udLKtOzm \
 278                   --exclude=*~ --exclude=*.bak --exclude=.* --exclude=*.tmp \
 279                   $info_source/ $info_cache 2>@ stderr]
 280         debug "INFO-CACHE $cmdl"
 281         eval exec $cmdl
 282     }
 283
 284     set f [open $info_cache/vessel-info]
 285     glset vessel_size_data [read $f]
 286     close $f
 287 }
 288
 289 proc vesselinfo-init {} {
 290     global vc_game2code vc_code2abbrev vc_code2full vc_codes
 291
 292     global vessel_size_data
 293     manyset $vessel_size_data sizeinfos subclassinfos
 294
 295     set vc_codes {}
 296     foreach {game code abbrev full} $sizeinfos {
 297         if {![regexp {^[a-z][a-z]$} $code code]} { error "bad code" }
 298         if {![regexp {^[a-z][a-z]$} $abbrev abbrev]} { error "bad abbrev" }
 299         lappend vc_codes $code
 300         set vc_game2code($game) $code
 301         set vc_code2abbrev($code) $abbrev
 302         set vc_code2full($code) $full
 303         load-icon $abbrev
 304     }
 305
 306     global vsc_code2report
 307     global vsc_game2code
 308     set vsc_game2code(null) {}
 309     set vsc_code2report() Ordinary
 310     set vsc_code2report(!) "(Special/L.E.)"
 311     foreach {game code full} $subclassinfos {
 312         if {![regexp {^[A-Z]$} $code code]} { error "bad code" }
 313         set vsc_game2code($game) $code
 314         set vsc_code2report($code) $full
 315     }
 316
 317     load-icon atsea
 318     set owners {ours dot query}
 319     foreach b $owners { load-icon $b }
 320     foreach a {battle borrow dot} {
 321         load-icon $a
 322         foreach b $owners { load-icon-combine $a $b }
 323     }
 324 }
 325
 326 proc load-icon {icon} {
 327     global info_cache
 328     image create bitmap icon/$icon -file $info_cache/$icon.xbm
 329 }
 330
 331 proc load-icon-combine {args} {
 332     global info_cache
 333     set cmd {}
 334     set delim "pnmcat -lr "
 335     foreach icon $args {
 336         append cmd $delim " <(xbmtopbm $info_cache/$icon.xbm)"
 337         set delim " <(pbmmake -white 1 1)"
 338     }
 339     append cmd " | pbmtoxbm"
 340     debug "load-icon-combine $cmd"
 341     image create bitmap icon/[join $args +] -data [exec bash -c $cmd]
 342 }
 343
 344 #---------- vessel properties ----------
 345
 346 proc code-lockown2icon {lockown} {
 347     manyset [split $lockown ""] lock notown
 348     set l "
 349          [lindex {battle borrow dot} $lock]
 350          [lindex {ours dot query {} {} dot} $notown]
 351     "
 352     if {[llength $l]} { return icon/[join $l +] } { return {} }
 353 }
 354
 355 proc canvas-horiz-stack {xvar xoff y bind type args} {
 356     upvar 1 $xvar x
 357     upvar 1 canvas canvas
 358     set id [eval $canvas create $type [expr {$x+$xoff}] $y $args]
 359     set bbox [$canvas bbox $id]
 360 #   debug "CANVAS-HORIZ-STACK $type $x $xoff $id $bbox [list $args]"
 361     set x [lindex $bbox 2]
 362     $canvas bind $id <ButtonPress> $bind
 363     return $id
 364 }
 365
 366 proc code2canvas1 {code canvas} {
 367     set y 2
 368     code2canvas $code $canvas 5 y {} 0 {}
 369     manyset [$canvas bbox all] minx dummy maxx dummy
 370     $canvas configure -width [expr {$maxx-$minx+4}]
 371 }
 372
 373 proc code2canvas {code canvas x yvar qty qtylen bind} {
 374     global vc_code2abbrev
 375     upvar 1 $yvar y
 376
 377     manyset [split $code _] inport size subclass lockown xabbrev
 378
 379     set stackx $x
 380     incr stackx 2
 381     set imy [expr {$y+2}]
 382
 383     if {!$inport} { incr qtylen -1 }
 384     if {$qtylen<=0} { set qtylen {} }
 385     set qty [format "%${qtylen}s" $qty]
 386
 387     set qtyid [canvas-horiz-stack stackx 0 $y $bind \
 388                    text -anchor nw -font fixed -text $qty]
 389
 390     if {!$inport} {
 391         canvas-horiz-stack stackx 0 $imy $bind \
 392             image -anchor nw -image icon/atsea
 393         incr stackx
 394     }
 395
 396     upvar #0 vc_code2abbrev($size) vcabb
 397     if {![info exists vcabb]} {
 398         set vcabb vc-$size
 399         image create bitmap icon/$vcabb -data \
 400             [exec pbmtext -builtin fixed $size | pnminvert | pnmcrop >t.pnm]
 401     }
 402     canvas-horiz-stack stackx -1 $imy $bind \
 403             image -anchor nw -image icon/$vcabb
 404
 405     if {[string length $subclass]} {
 406         canvas-horiz-stack stackx 0 $y $bind \
 407             text -anchor nw -font fixed -text \
 408             $subclass
 409     }
 410
 411     incr stackx
 412     set lockownicon [code-lockown2icon $lockown]
 413     if {[string length $lockownicon]} {
 414         canvas-horiz-stack stackx 0 $imy $bind \
 415             image -anchor nw -image $lockownicon
 416         incr stackx
 417     }
 418
 419     if {[string length $xabbrev]} {
 420         canvas-horiz-stack stackx 0 $y $bind \
 421             text -anchor nw -font fixed -text \
 422             $xabbrev
 423     }
 424
 425     set bbox [$canvas bbox $qtyid]
 426     set ny [lindex $bbox 3]
 427     set bid [$canvas create rectangle \
 428                  $x $y $stackx $ny \
 429                  -fill white]
 430
 431     set y $ny
 432     $canvas lower $bid $qtyid
 433
 434     $canvas bind $bid <ButtonPress> $bind
 435 }
 436
 437 proc show-report-decode {code} {
 438     global vc_code2full
 439
 440     smash-prepare
 441
 442     manyset [split $code _] inport sizecode subclass lockown xabbrev
 443     manyset [split $lockown ""] lock notown
 444
 445     report-set inport [lindex {{At Sea} {In port}} $inport]
 446
 447     upvar #0 vc_code2full($sizecode) sizefull
 448     upvar #0 smash_sizeinexact($sizecode) sizeinexact
 449     set size_report $sizefull
 450     if {[info exists sizeinexact]} { set size_report "($sizefull+)" }
 451     report-set size $size_report
 452
 453     global smash_subclass
 454     if {$smash_subclass >= 2} {
 455         report-set subclass "(Any class)"
 456     } elseif {[
 457                upvar #0 vsc_code2report($subclass) subclass_report
 458                info exists subclass_report
 459               ]} {
 460         report-set subclass $subclass_report
 461     } else {
 462         report-set subclass "Class \"$subclass\""
 463     }
 464
 465     report-set lock [lindex {
 466         {Battle ready} {Unlocked} {Locked}
 467         {(All lock states)} {(Not battle ready)}
 468     } $lock]
 469
 470     if {[have-notes]} {
 471         switch -exact $notown {
 472             0 { report-set own "Yours" }
 473             1 { report-set own "Other pirate's" }
 474             2 { report-set own "Owner unknown" }
 475             3 { report-set own "(All ownerships)" }
 476             4 - 5 { report-set own "(Yours/unknown)" }
 477             default { report-set own "?? $notown" }
 478         }
 479     }
 480
 481     global smash_xabbrev_map
 482     if {![have-notes]} {
 483     } elseif {[llength $smash_xabbrev_map]} {
 484         if {[string length $xabbrev]} {
 485             report-set xabbrev "(Flags: $xabbrev)"
 486         } else {
 487             report-set xabbrev "(No flags)"
 488         }
 489     } else {
 490         if {[string length $xabbrev]} {
 491             report-set xabbrev "Notes flags: $xabbrev"
 492         } else {
 493             report-set xabbrev "No flags in notes"
 494         }
 495     }
 496 }
 497
 498 #---------- common to smashing and filtering ----------
 499
 500 proc make-control {parent ctrl label ekind} {
 501     debug "MAKE-CONTROL [list $parent $ctrl $label $ekind]"
 502     label $parent.lab_$ctrl -text $label -justify left
 503     $ekind $parent.$ctrl
 504     manyset [grid size $parent] dummy row
 505     incr row
 506     grid configure $parent.lab_$ctrl -row $row -column 0 -sticky nw -pady 4
 507     grid configure $parent.$ctrl -row $row -column 1 -sticky w -pady 3
 508     return $parent.$ctrl
 509 }
 510
 511 proc begin-control-grid {cw count rows inrow} {
 512     if {!$inrow} { set inrow [expr {($count + $rows) / $rows}] }
 513     upvar #0 control_grid_properties($cw) props
 514     set props [list $rows $inrow]
 515     return $cw
 516 }
 517
 518 proc make-control-grid-elem {cw kind ix ekind args} {
 519     upvar #0 control_grid_properties($cw) props
 520     manyset $props rows inrow
 521
 522     set ew $cw.$ix
 523
 524     debug "MAKE-CONTROL-GRID-ELEM $cw $kind $ix $ekind $rows $inrow $ew"
 525
 526     eval [list $ekind $ew] $args
 527
 528     switch -exact $kind {
 529         ix {
 530             grid configure $ew -sticky sw \
 531                 -row [expr {$ix / $inrow}] \
 532                 -column [expr {$ix % $inrow}]
 533         }
 534         final {
 535             grid configure $ew -sticky se \
 536                 -row [expr {$rows-1}] \
 537                 -column [expr {$inrow-1}]
 538         }
 539         default {
 540             error "$kind ?"
 541         }
 542     }
 543     return $ew
 544 }
 545
 546 proc control-tickbox-flip {varsvn values onflip} {
 547     upvar #0 $varsvn vars
 548     foreach val $values {
 549         set vars($val) [expr {!$vars($val)}]
 550     }
 551     $onflip c.-tickbox-flip $varsvn $values
 552 }
 553
 554 proc populate-control-grid-tickboxes {cw rows inrow varsvn values flipvalues
 555                             label_kind valvn default_get label_get onflip} {
 556     debug "POPULATE-CONTROL-GRID-TICKBOXES $cw $rows $inrow $varsvn\
 557              [list $values] $label_kind $valvn"
 558
 559     upvar #0 $varsvn vars
 560     upvar 1 $valvn val
 561     set count [llength $values]
 562
 563     begin-control-grid $cw $count $rows $inrow
 564
 565     for {set ix 0} {$ix < $count} {incr ix} {
 566         set val [lindex $values $ix]
 567         set vars($val) [uplevel 1 $default_get]
 568         set ew [make-control-grid-elem $cw ix $ix checkbutton \
 569                     -variable ${varsvn}($val) \
 570                     -font fixed \
 571                     -command [list $onflip c.-g.-tickbox $cw $val]]
 572         $ew configure -$label_kind [uplevel 1 $label_get]
 573         switch -exact $label_kind {
 574             image { $ew configure -height 16 }
 575         }
 576     }
 577     [make-control-grid-elem $cw final invert button] \
 578         configure \
 579         -text flip -padx 0 -pady 0 \
 580         -command [list control-tickbox-flip $varsvn $flipvalues $onflip]
 581 }
 582
 583 #---------- smashing ----------
 584
 585 proc smash-code {code} {
 586     manyset [split $code _] inport size subclass lockown xabbrev
 587
 588     upvar #0 smash_sizemap($size) smsize
 589
 590     global smash_subclass
 591     if {$smash_subclass > 1} {
 592         set subclass {}
 593     } elseif {$smash_subclass && [string length $subclass]} {
 594         set subclass !
 595     }
 596
 597     global smash_owner
 598     switch $smash_owner {
 599         0 { }
 600         1 { regsub {[12]$} $lockown 5 lockown }
 601         2 {
 602             if {[regexp {^0.} $lockown]} {
 603                 # battle ready / all lock states
 604                 set lockown 03
 605             } elseif {[regexp {^.0} $lockown]} {
 606                 # not battle ready / yours
 607                 set lockown 40
 608             } else {
 609                 # state (not battle ready) / not known to be yours
 610                 regsub {.$} $lockown 4 lockown
 611             }
 612         }
 613         3 { regsub {.$} $lockown {3} lockown }
 614         4 { set lockown 33 }
 615     }
 616
 617     global smash_xabbrev_map
 618     set xabbrev [string map $smash_xabbrev_map $xabbrev]
 619
 620     return [join [list $inport $smsize $subclass $lockown $xabbrev] _]
 621 }
 622
 623 proc smash-prepare {} {
 624     global vc_codes smash_sizemap smash_size smash_sizeinexact
 625     set mapto {}
 626     catch { unset smash_sizeplus }
 627     foreach size $vc_codes {
 628         if {!$smash_size($size)} {
 629             set mapto $size
 630         } else {
 631             set smash_sizeinexact($mapto) 1
 632         }
 633         set smash_sizemap($size) $mapto
 634     }
 635
 636     global smash_xabbrev_a smash_xabbrev_b smash_xabbrev_map
 637     set smash_xabbrev_map {}
 638     foreach a [split $smash_xabbrev_a ""] b [split $smash_xabbrev_b ""] {
 639         if {![string length $a]} continue
 640         lappend smash_xabbrev_map $a $b
 641     }
 642     debug "SMASH-PREPAE xabbrev_map=[list $smash_xabbrev_map]"
 643 }
 644
 645 proc make-smasher {sma label ekind} {
 646     return [make-control .smash $sma $label $ekind]
 647 }
 648
 649 proc make-radio-smasher {sma label variable descs rows inrow} {
 650     set w [make-smasher $sma $label frame]
 651     begin-control-grid $w [llength $descs] $rows $inrow
 652     for {set i 0} {$i < [llength $descs]} {incr i} {
 653         make-control-grid-elem $w ix $i \
 654             radiobutton \
 655             -variable $variable -value $i \
 656             -command [list redraw-needed radio-smasher $sma] \
 657             -text [lindex $descs $i]
 658     }
 659     return $w
 660 }
 661
 662 proc make-smashers {} {
 663     global vc_codes vc_code2abbrev
 664     set cw [make-smasher size "Size\n round\n down" frame]
 665     populate-control-grid-tickboxes $cw 2 0 smash_size \
 666         $vc_codes [lrange $vc_codes 1 end] \
 667         image val { expr 0 } { expr {"icon/$vc_code2abbrev($val)"} } \
 668         redraw-needed
 669     $cw.0 configure -state disabled
 670
 671     glset smash_subclass 0
 672     make-radio-smasher subclass Class smash_subclass \
 673         {Show Normal/LE Hide} 1 0
 674
 675     glset smash_owner [expr {[have-ownership] ? 0 : 3}]
 676     set cw [make-radio-smasher owner "Lock/\nowner" smash_owner \
 677                 {Show Yours? {For you} Lock Hide} 2 3]
 678     if {![have-ownership]} {
 679         foreach ix {1 2} { $cw.$ix configure -state disabled }
 680     }
 681
 682     set cw [make-smasher xabbrev "Flags" frame]
 683     foreach ix {1 3} ab {a b} width {14 12} {
 684         set vn smash_xabbrev_$ab
 685         global $vn
 686         set $vn {}
 687         entry $cw.$ix -textvariable $vn -width $width
 688         trace add variable $vn write [list redraw-needed $vn]
 689     }
 690     set ix 0
 691     foreach str {y/ / /d} { label $cw.$ix -text $str; incr ix 2 }
 692     eval pack [lsort [winfo children $cw]] -side left
 693 }
 694
 695 #---------- filtering ----------
 696
 697 set filters {}
 698
 699 proc filter-values/size {} { global vc_codes; return $vc_codes }
 700 proc filter-icon/size {code} {
 701     upvar #0 vc_code2abbrev($code) abb
 702     return icon/$abb
 703 }
 704 proc filter-default/size {code} { return 1 }
 705 proc filter-says-yes/size {codel} {
 706     set sizecode [lindex $codel 1]
 707     upvar #0 filter_size($sizecode) yes
 708     return $yes
 709 }
 710
 711 proc filter-values/lock {} { return {0 1 2} }
 712 proc filter-icon/lock {lock} { return [code-lockown2icon ${lock}3] }
 713 proc filter-default/lock {lock} { return 1 }
 714 proc filter-says-yes/lock {codel} {
 715     regexp {^.} [lindex $codel 3] lock
 716     upvar #0 filter_lock($lock) yes
 717     debug "FILTER-SAYS-YES/LOCK $codel $lock $yes"
 718     return $yes
 719 }
 720
 721 proc filter-values/own {} { return {0 1 2} }
 722 proc filter-icon/own {own} { return [code-lockown2icon 3${own}] }
 723 proc filter-default/own {own} { return 1 }
 724 proc filter-says-yes/own {codel} {
 725     regexp {.$} [lindex $codel 3] own
 726     upvar #0 filter_own($own) yes
 727     debug "FILTER-SAYS-YES/OWN $codel $own $yes"
 728     return $yes
 729 }
 730
 731 proc filter-values/lockown {} {
 732     foreach lv {0 1 2} {
 733         foreach ov {0 1 2} {
 734             lappend vals "$lv$ov"
 735         }
 736     }
 737     return $vals
 738 }
 739 proc filter-icon/lockown {lockown} { return [code-lockown2icon $lockown] }
 740 proc filter-default/lockown {lockown} {
 741     return [regexp {^[01]|^2[^1]} $lockown]
 742 }
 743 proc filter-says-yes/lockown {codel} {
 744     set lockown [lindex $codel 3]
 745     upvar #0 filter_lockown($lockown) yes
 746     debug "FILTER-SAYS-YES/LOCKOWN $codel $lockown $yes"
 747     return $yes
 748 }
 749
 750 proc filter-validate/xabbre {re} {
 751     if {[catch {
 752         regexp -- $re {}
 753     } emsg]} {
 754         regsub {^.*:\s*} $emsg {} emsg
 755         regsub {^.*(.{30})$} $emsg {\1} emsg
 756         return $emsg
 757     }
 758     return {}
 759 }
 760 proc filter-says-yes/xabbre {codel} {
 761     global filter_xabbre
 762     set xabbrev [lindex $codel 4]
 763     return [regexp -- $filter_xabbre $xabbrev]
 764 }
 765
 766 proc make-tickbox-filter {fil label rows inrow} {
 767     set values [filter-values/$fil]
 768
 769     if {![catch { info args filter-icon/$fil }]} {
 770         set label_get { filter-icon/$fil $val }
 771         set label_kind image
 772     } else {
 773         set label_get { filter-map/$fil $val }
 774         set label_kind text
 775     }
 776
 777     set fw [make-filter $fil $label frame]
 778
 779     populate-control-grid-tickboxes $fw $rows $inrow filter_$fil \
 780         $values $values \
 781         $label_kind val { filter-default/$fil $val } $label_get \
 782         specific-filter-adjusted
 783 }
 784
 785 proc entry-filter-changed {fw fil n1 n2 op} {
 786     global errorInfo
 787     upvar #0 filter_$fil realvar
 788     upvar #0 filterentered_$fil entryvar
 789     global def_background
 790     debug "entry-filter-changed $fw $fil $entryvar"
 791     if {[catch {
 792         set error [filter-validate/$fil $entryvar]
 793         if {[string length $error]} {
 794             $fw.error configure -text $error -foreground white -background red
 795         } else {
 796             $fw.error configure -text { } -background $def_background
 797             set realvar $entryvar
 798             specific-filter-adjusted entry-filter-changed $fw
 799         }
 800     } emsg]} {
 801         puts stderr "FILTER CHECK ERROR $emsg $errorInfo"
 802     }
 803 }
 804
 805 proc make-entry-filter {fil label def} {
 806     global filterentered_$fil
 807     upvar #0 filter_$fil realvar
 808     set realvar $def
 809     set fw [make-filter $fil $label frame]
 810     entry $fw.entry -textvariable filterentered_$fil
 811     label $fw.error
 812     glset def_background [$fw.error cget -background]
 813     trace add variable filterentered_$fil write \
 814         [list entry-filter-changed $fw $fil]
 815     pack $fw.entry $fw.error -side top -anchor w
 816 }
 817
 818 proc make-filter {fil label ekind} {
 819     global filters
 820     lappend filters $fil
 821     return [make-control .filter $fil $label $ekind]
 822 }
 823
 824 proc make-filters {} {
 825     global filter_lockown_separate
 826     make-tickbox-filter size Size 2 0
 827     if {!$filter_lockown_separate} {
 828         make-tickbox-filter lockown "Lock/\nowner" 2 6
 829     } else {
 830         make-tickbox-filter lock "Lock" 1 0
 831         if {[have-notes]} {
 832             make-tickbox-filter own "Owner" 1 0
 833         }
 834     }
 835     make-entry-filter xabbre "Flags\n regexp" {}
 836 }
 837
 838 proc specific-filter-adjusted {args} {
 839     glset filterstyle 3
 840     eval redraw-needed $args
 841 }
 842
 843 proc filterstyle-changed {n1 n2 op} {
 844     global filterstyle
 845     debug "FILTERSTYLE-CHANGED $filterstyle"
 846     redraw-needed filterstyle-changed
 847 }
 848
 849 proc filters-say-yes {code} {
 850     global filters filterstyle
 851     set codel [split $code _]
 852     set lockown [lindex $codel 3]
 853     switch -exact $filterstyle {
 854         0 { return 1 }
 855         1 { return [filter-default/lockown $lockown] }
 856         2 { return [regexp {^.0} $lockown] }
 857         3 { }
 858         default { error $filterstyle }
 859     }
 860
 861     foreach fil $filters {
 862         if {![filter-says-yes/$fil $codel]} {
 863             debug "FILTERS-SAY-YES $code NO $fil"
 864             return 0
 865         }
 866     }
 867     debug "FILTERS-SAY-YES $code YES $filters"
 868     return 1
 869 }
 870
 871 #---------- loading and parsing the clipboard (vessel locations) ----------
 872
 873 proc vessel {vin} {
 874     global pirate notes_used note_missings newnotes
 875     upvar 1 $vin vi
 876
 877     set codel {}
 878     lappend codel [errexpect-arrayget-boolean vi inPort]
 879
 880     set gamesize [errexpect-arrayget vi vesselClass]
 881     upvar #0 vc_game2code($gamesize) size
 882     if {![info exists size]} {
 883         set size "($gamesize)"
 884         upvar #0 vc_code2abbrev($size) vcabb
 885         set vcabb vc-$size
 886         set data [exec pbmtext -builtin fixed " $gamesize " \
 887                  | pnminvert | pnmcrop | pbmtoxbm]
 888         debug "INVENTED ICON $vcabb $data"
 889         image create bitmap icon/$vcabb -data $data
 890
 891         global vc_code2full
 892         set vc_code2full($size) "Type \"$gamesize\""
 893     }
 894     lappend codel $size
 895
 896     set gamesubclass [errexpect-arrayget vi vesselSubclass]
 897     upvar #0 vsc_game2code($gamesubclass) subclass
 898     if {[info exists subclass]} {
 899         lappend codel $subclass
 900     } else {
 901         lappend codel ($gamesubclass)
 902     }
 903
 904     switch -exact [errexpect-arrayget vi isLocked]/[ \
 905                    errexpect-arrayget vi isBattleReady] {
 906         true/false      { set lock 2 }
 907         false/false     { set lock 1 }
 908         false/true      { set lock 0 }
 909         default         { errexpect-error "unexpected isLocked/isBattleReady" }
 910     }
 911
 912     set vid [errexpect-arrayget vi vesselId]
 913     upvar #0 notes($vid) note
 914     set realname [errexpect-arrayget vi vesselName]
 915     set island [errexpect-arrayget vi islandName]
 916
 917     set owner {}
 918     set xabbrev {}
 919     if {[info exists note]} {
 920         manyset $note lno notename owner xabbrev
 921         if {[string compare -nocase $realname $notename]} {
 922             note-info $lno $vid $realname $island \
 923                 "notes say name is $notename"
 924         }
 925         if {[string length $owner]} {
 926             if {![string compare $owner $pirate]} {
 927                 set notown 0
 928             } else {
 929                 set notown 1
 930             }
 931         } else {
 932             set notown 2
 933         }
 934         append abbrev $xabbrev
 935         set notes_used($vid) 1
 936
 937     } else {
 938         set notown 2
 939         lappend note_missings [list $island $realname $vid]
 940     }
 941
 942     lappend codel "$lock$notown" $xabbrev
 943     lappend newnotes [list $vid $realname $owner $xabbrev]
 944     set kk "$island [join $codel _]"
 945     upvar #0 found($kk) k
 946     lappend k [list $vid $realname $owner]
 947
 948     debug "CODED $kk $vid $realname"
 949 }
 950
 951 set clipboard {}
 952 proc parse-clipboard {} {
 953     global clipboard found notes notes_used newnotes
 954
 955     catch { unset found }
 956     catch { unset notes_used }
 957     glset note_infos {}
 958     glset note_missings {}
 959
 960     set newnotes {}
 961
 962     set itemre { (\w+) = ([^=]*) }
 963     set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
 964     debug $manyitemre
 965
 966     set lno 0
 967     foreach l [split $clipboard "\n"] {
 968         incr lno
 969         errexpect-setline $lno $l
 970         if {![string length $l]} continue
 971         catch { unset vi }
 972         while 1 {
 973                 if {![regexp -expanded $manyitemre $l dummy \
 974                         thiskey thisval rhs]} {
 975                     errexpect-error "badly formatted"
 976                 }
 977                 set vi($thiskey) $thisval
 978                 if {![string length $rhs]} break
 979                 regsub {^, } $rhs {} rhs
 980                 set l "\[$rhs\]"
 981         }
 982         vessel vi
 983     }
 984
 985     if {[llength $newnotes]} {
 986         foreach vid [lsort [array names notes]] {
 987             if {![info exists notes_used($vid)]} {
 988                 manyset $notes($vid) lno notename
 989                 note-info $lno $vid $notename {} \
 990                     "vessel in notes no longer found"
 991             }
 992         }
 993     }
 994 }
 995
 996 proc load-clipboard-file {fn} {
 997     set f [open $fn]
 998     glset clipboard [read $f]
 999     close $f
1000 }
1001
1002
1003 #---------- loading and parsing the chart ----------
1004
1005 proc load-chart {} {
1006     global chart scraper
1007     debug "FETCHING CHART"
1008     set chart [eval exec $scraper [list | perl -we {
1009         use strict;
1010         use CommodsScrape;
1011         use IO::File;
1012         use IO::Handle;
1013         yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
1014                 sub { sprintf "%d %d", @_; },
1015                 sub { printf "archlabel %d %d %s\n", @_; },
1016                 sub { printf "island %s {%s} %s\n", @_; },
1017                 sub { printf "league %s %s %s.\n", @_; },
1018                 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
1019                         );
1020         STDOUT->error and die $!;
1021     }]]
1022 }
1023
1024 proc init-scales {} {
1025     global scales scaleix scale
1026     set defscale 16
1027     set scales {1 2 3 4 5 6 8}
1028     set e12 {10 12 15 18 22 27 33 39 47 56 68 82}
1029     foreach t $e12 {
1030         if {$t < $defscale} { set scaleix [llength $scales] }
1031         lappend scales $t
1032     }
1033     foreach t [lrange $e12 0 6] { lappend scales [expr {$t * 10}] }
1034     set scale [lindex $scales $scaleix]
1035 }
1036
1037 proc coord {c} {
1038         global scale
1039         return [expr {$c * $scale}]
1040 }
1041
1042 proc chart-got/archlabel {args} { }
1043 proc chart-got/island {x y isle sizecol} {
1044         debug "ISLE $x $y $isle $sizecol"
1045         global canvas isleloc
1046         set isleloc($isle) [list $x $y]
1047         set sz 5
1048 #       $canvas create oval \
1049 #               [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
1050 #               [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
1051 #               -fill blue
1052         set colour "#888"
1053         if {[string match *_col $sizecol]} { set colour black }
1054         $canvas create text [coord $x] [coord $y] \
1055                 -text $isle -anchor s -fill $colour
1056 }
1057 proc chart-got/league {x1 y1 x2 y2 kind} {
1058 #       debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
1059         global canvas
1060         set l [$canvas create line \
1061                 [coord $x1] [coord $y1] \
1062                 [coord $x2] [coord $y2]]
1063         if {![string compare $kind .]} {
1064                 $canvas itemconfigure $l -dash .
1065         }
1066 }
1067
1068 proc debug-filter-array {array} {
1069     upvar #0 $array a
1070     set m " FILTER $array"
1071     foreach k [lsort [array names a]] {
1072         append m " $k=$a($k)"
1073     }
1074     debug $m
1075 }
1076
1077 proc redraw-needed {args} {
1078     global redraw_after
1079     debug "REDRAW NEEDED $args"
1080     if {[info exists redraw_after]} return
1081
1082     global filterstyle
1083     debug " FILTER style $filterstyle"
1084     debug-filter-array filter_size
1085     debug-filter-array filter_lockown
1086     global filter_xabbre
1087     debug " FILTER xabbre $filter_xabbre"
1088
1089     set redraw_after [after 250 draw]
1090 }
1091
1092 proc draw {} {
1093     global chart found isleloc canvas redraw_after islandnames smfound
1094
1095     catch { after cancel $redraw_after }
1096     catch { unset redraw_after }
1097
1098     $canvas delete all
1099
1100     foreach l [split $chart "\n"] {
1101 #       debug "CHART-GOT $l"
1102         set proc [lindex $l 0]
1103         eval chart-got/$proc [lrange $l 1 end]
1104     }
1105
1106     smash-prepare
1107
1108     catch { unset smfound }
1109     foreach key [lsort [array names found]] {
1110         regexp {^(.*) (\S+)$} $key dummy islandname code
1111
1112         if {![filters-say-yes $code]} continue
1113
1114         set smcode [smash-code $code]
1115         debug "smashed $code => $smcode"
1116         set smkey "$islandname $smcode"
1117         foreach vessel $found($key) {
1118             lappend smfound($smkey) [list $vessel $code]
1119         }
1120     }
1121
1122     set islandnames {}
1123     set lastislandname {}
1124     foreach smkey [lsort [array names smfound]] {
1125         set c [llength $smfound($smkey)]
1126         regexp {^(.*) (\S+)$} $smkey dummy islandname code
1127         debug "SHOWING [list $smkey $c $islandname $code l=$lastislandname]"
1128
1129         if {[string compare $lastislandname $islandname]} {
1130                 manyset $isleloc($islandname) x y
1131                 set x [coord $x]
1132                 set y [coord $y]
1133                 set lastislandname $islandname
1134                 lappend islandnames $islandname
1135 #               debug "START Y $y"
1136         }
1137
1138         if {$c > 1} { set qty [format %d $c] } else { set qty {} }
1139         code2canvas $code $canvas $x y $qty 2 \
1140             [list show-report $islandname $code]
1141 #       debug "NEW Y $y"
1142     }
1143
1144     panner::updatecanvas-bbox .cp.ctrl.pan
1145
1146     islandnames-update
1147 }
1148
1149
1150 #---------- parser error reporting ----------
1151
1152 proc parser-control-create {w base invokebuttontext etl_title} {
1153     frame $w
1154     button $w.do -text $invokebuttontext -command invoke_$base -pady 3
1155
1156     frame $w.resframe -width 120 -height 32
1157     button $w.resframe.res -text {} -anchor nw \
1158         -padx 1 -pady 1 -borderwidth 0 -justify left
1159     glset deffont_$base [$w.resframe.res cget -font]
1160     place $w.resframe.res -relx 0.5 -y 0 -anchor n
1161
1162     pack $w.do -side top
1163     pack $w.resframe -side top -expand y -fill both
1164
1165     set eb .err_$base
1166     toplevel $eb
1167     wm withdraw $eb
1168     wm title $eb "where-vessels - $etl_title"
1169     wm protocol $eb WM_DELETE_WINDOW [list wm withdraw $eb]
1170
1171     label $eb.title -text $etl_title
1172     pack $eb.title -side top
1173
1174     button $eb.close -text Close -command [list wm withdraw $eb]
1175     pack $eb.close -side bottom
1176
1177     frame $eb.emsg -bd 2 -relief groove
1178     label $eb.emsg.lab -anchor nw -text "Error:"
1179     text $eb.emsg.text -height 1
1180     pack $eb.emsg.text -side bottom -fill x
1181     pack $eb.emsg.lab -side left
1182
1183     pack $eb.emsg -side top -pady 2 -fill x
1184
1185     frame $eb.text -bd 2 -relief groove
1186     pack $eb.text -side bottom -pady 2 -fill both -expand y
1187
1188     label $eb.text.lab -anchor nw
1189
1190     text $eb.text.text -width 85 \
1191         -xscrollcommand [list $eb.text.xscroll set] \
1192         -yscrollcommand [list $eb.text.yscroll set]
1193     $eb.text.text tag configure error \
1194         -background red -foreground white
1195
1196     scrollbar $eb.text.xscroll -orient horizontal \
1197         -command [list $eb.text.text xview]
1198     scrollbar $eb.text.yscroll -orient vertical \
1199         -command [list $eb.text.text yview]
1200
1201     grid configure $eb.text.lab -row 0 -column 0 -sticky w -columnspan 2
1202     grid configure $eb.text.text -row 1 -column 0 -sticky news
1203     grid configure $eb.text.yscroll -sticky ns -row 1 -column 1
1204     grid configure $eb.text.xscroll -sticky ew -row 2 -column 0
1205     grid rowconfigure $eb.text 0 -weight 0
1206     grid rowconfigure $eb.text 1 -weight 1
1207     grid rowconfigure $eb.text 2 -weight 0
1208     grid columnconfigure $eb.text 0 -weight 1
1209     grid columnconfigure $eb.text 1 -weight 0
1210 }
1211
1212 proc parser-control-ok-core {w base background show} {
1213     debug "parser-control-ok-core $w $base $background $show"
1214     upvar #0 deffont_$base deffont
1215     $w.resframe.res configure \
1216         -background $background -disabledforeground black -font $deffont \
1217         -state disabled -command {} \
1218         -text $show
1219 }
1220 proc parser-control-ok {w base show} {
1221     parser-control-ok-core $w $base green $show
1222 }
1223 proc parser-control-none {w base show} {
1224     parser-control-ok-core $w $base blue $show
1225 }
1226 proc parser-control-failed-core {w base foreground background smallfont
1227                                  tiny summary fulldesc fulldata} {
1228     debug "parser-control-failed-core $w $base $summary $fulldesc"
1229     upvar #0 deffont_$base deffont
1230     set eb .err_$base
1231
1232     $eb.emsg.text delete 0.0 end
1233     $eb.emsg.text insert end $summary
1234
1235     $eb.text.lab configure -text $fulldesc
1236     $eb.text.text delete 0.0 end
1237     $eb.text.text insert end $fulldata
1238
1239     regsub -all {.{18}} $tiny "&\n" ewrap
1240
1241     if {$smallfont} {
1242         set font fixed
1243     } else {
1244         set font $deffont
1245     }
1246
1247     $w.resframe.res configure \
1248         -background $background -foreground $foreground -font $font \
1249         -state normal -command [list wm deiconify $eb] \
1250         -text $ewrap
1251 }
1252
1253 proc parser-control-failed-expected {w base emsg lno ei fulldesc newdata} {
1254     set eb .err_$base
1255
1256     set line [lindex [split $ei "\n"] 0]
1257     debug "parser-control-failed-expected: $w $base: $lno: $emsg\n $line"
1258
1259     parser-control-failed-core $w $base \
1260         white red 1 \
1261         "err: [string trim $emsg]: \"$line\"" \
1262         "at line $lno: $emsg" \
1263         $fulldesc $newdata
1264
1265     $eb.text.text tag add error $lno.0 $lno.end
1266     $eb.text.text see $lno.0
1267 }
1268 proc parser-control-failed-unexpected {w base emsg ei} {
1269     global errorInfo
1270     parser-control-failed-core $w $base \
1271         black yellow 1 \
1272         $emsg $emsg "Details and stack trace:" $ei
1273 }
1274
1275 proc reparse {base varname old fulldesc okshow noneshow parse ok} {
1276     upvar #0 $varname var
1277     manyset [errexpect-catch {
1278         uplevel 1 $parse
1279         if {[string length [string trim $var]]} {
1280             parser-control-ok .cp.ctrl.$base $base $okshow
1281         } else {
1282             parser-control-none .cp.ctrl.$base $base $noneshow
1283         }
1284     }] failed emsg lno ei
1285     if {$failed} {
1286         parser-control-failed-expected .cp.ctrl.$base $base \
1287             $emsg $lno $ei $fulldesc $var
1288         set var $old
1289         uplevel 1 $parse
1290     } else {
1291         uplevel 1 $ok
1292     }
1293 }
1294
1295 #---------- island names selection etc. ----------
1296
1297 proc islandnames-update {} {
1298     global islandnames
1299     .islands.count configure -text [format "ships at %d island(s)" \
1300                                         [llength $islandnames]]
1301 }
1302
1303 proc islandnames-select {} {
1304     .islands.clip configure -relief sunken -state disabled
1305     selection own -command islandnames-deselect .islands.clip
1306 }
1307 proc islandnames-deselect {} {
1308     .islands.clip configure -relief raised -state normal
1309 }
1310
1311 proc islandnames-handler {offset maxchars} {
1312     global islandnames
1313     return [string range [join $islandnames ", "] \
1314                 $offset [expr {$offset+$maxchars-1}]]
1315 }
1316
1317 #---------- main user interface ----------
1318
1319 proc widgets-setup {} {
1320     global canvas debug pirate ocean filterstyle
1321
1322     wm geometry . 1200x800
1323     if {[string length $pirate]} {
1324         wm title . "where-vessels - $pirate on the $ocean ocean"
1325     } else {
1326         wm title . "where-vessels - $ocean ocean"
1327     }
1328
1329     #----- map -----
1330
1331     frame .f -border 1 -relief groove
1332     set canvas .f.c
1333     canvas $canvas
1334     pack $canvas -expand 1 -fill both
1335     pack .f -expand 1 -fill both -side left
1336
1337     #----- control panels and filter -----
1338
1339     frame .cp
1340     frame .smash -relief groove -bd 2 -padx 1
1341     frame .filter -relief groove -bd 2 -padx 1
1342     frame .islands -pady 2
1343     pack .cp .filter .islands .smash -side top
1344
1345     label .smash.title -text {Display/combine details}
1346     grid .smash.title -row 0 -column 0 -columnspan 2
1347
1348     set filterstyle [expr {[have-ownership] ? 1 : 3}]
1349     trace add variable filterstyle write filterstyle-changed
1350
1351     frame .filter.title
1352     label .filter.title.title -text Show
1353     pack .filter.title.title -side left
1354     foreach fing {0 1 2 3} {
1355         radiobutton .filter.title.f$fing \
1356             -variable filterstyle -value $fing \
1357             -text [lindex {All Useable Mine These:} $fing]
1358         pack .filter.title.f$fing -side left
1359     }
1360     if {![have-ownership]} {
1361         foreach fing {1 2} { .filter.title.f$fing configure -state disabled }
1362     }
1363
1364     grid configure .filter.title -row 0 -column 0 -columnspan 2
1365
1366     #----- control panel -----
1367
1368     frame .cp.ctrl
1369     pack .cp.ctrl -side left -anchor n
1370
1371     debug "BBOX [$canvas bbox all]"
1372
1373     panner::canvas-scroll-bbox .f.c
1374     panner::create .cp.ctrl.pan .f.c 120 120 $debug
1375
1376     pack .cp.ctrl.pan -side top -pady 0 -padx 5
1377     frame .cp.ctrl.zoom
1378     pack .cp.ctrl.zoom -side top
1379
1380     foreach inout {out in} minplus {- +} {
1381         button .cp.ctrl.zoom.$inout -text $minplus -font {Courier 16} \
1382             -command "zoom ${minplus}1" -pady 0
1383         pack .cp.ctrl.zoom.$inout -side left
1384     }
1385
1386     parser-control-create .cp.ctrl.acquire \
1387         acquire Acquire \
1388         "Clipboard parsing error" \
1389
1390     pack .cp.ctrl.acquire -side top -pady 2
1391
1392     parser-control-create .cp.ctrl.notes \
1393         notes "Reload notes" \
1394         "Vessel notes loading report" \
1395
1396     pack .cp.ctrl.notes -side top -pady 2
1397
1398     if {![have-notes]} {
1399         .cp.ctrl.notes.do configure -state disabled
1400     }
1401
1402     #----- island name count and copy -----
1403
1404     label .islands.count
1405     button .islands.clip -text "copy island names" -pady 2 -padx 2 \
1406          -command islandnames-select
1407     selection handle .islands.clip islandnames-handler
1408     pack .islands.count .islands.clip -side left
1409
1410     #----- decoding etc. report -----
1411
1412     frame .cp.report
1413     pack .cp.report -side left -anchor n
1414
1415     label .cp.report.island -text { }
1416
1417     canvas .cp.report.abbrev -width 1 -height 15
1418
1419     frame .cp.report.code
1420     label .cp.report.code.lab -text Code:
1421     glset report_code { }
1422     entry .cp.report.code.code -state readonly \
1423         -textvariable report_code -width 15
1424     pack .cp.report.code.lab .cp.report.code.code -side left
1425     frame .cp.report.details -bd 2 -relief groove -padx 2 -pady 2
1426
1427     listbox .cp.report.list -height 5
1428
1429     canvas .cp.report.abbrev1 -width 1 -height 15
1430
1431     pack .cp.report.island .cp.report.abbrev .cp.report.details \
1432         .cp.report.list .cp.report.abbrev1 -side top
1433     bind .cp.report.list <<ListboxSelect>> show-report-abbrev1
1434
1435     #pack .cp.report.code -side top
1436     pack configure .cp.report.details -fill x
1437
1438     foreach sw {inport size subclass lock own xabbrev} {
1439         label .cp.report.details.$sw -text { }
1440         pack .cp.report.details.$sw -side top -anchor w
1441     }
1442 }
1443
1444 proc report-set {sw val} { .cp.report.details.$sw configure -text $val }
1445
1446 proc show-report {islandname code} {
1447     .cp.report.island configure -text $islandname
1448
1449     .cp.report.abbrev delete all
1450     code2canvas1 $code .cp.report.abbrev
1451
1452     glset report_code $code
1453     show-report-decode $code
1454
1455     set kk "$islandname $code"
1456     upvar #0 smfound($kk) vessels
1457
1458     global report_list_codes
1459     set report_list_codes {}
1460     .cp.report.list delete 0 end
1461
1462     foreach foundelem $vessels {
1463         manyset $foundelem elem code
1464         manyset $elem vid name owner
1465         lappend owned($owner) [list $name $code]
1466     }
1467
1468     foreach owner [lsort [array names owned]] {
1469         if {[string length $owner]} {
1470             set owndesc "$owner's"
1471         } else {
1472             set owndesc "Owner unknown"
1473         }
1474         if {[have-notes]} {
1475             .cp.report.list insert end "$owndesc:"
1476             lappend report_list_codes {}
1477         }
1478         foreach ownelem $owned($owner) {
1479             manyset $ownelem name code
1480             .cp.report.list insert end " $name"
1481             lappend report_list_codes $code
1482         }
1483     }
1484     show-report-abbrev1
1485 }
1486
1487 proc show-report-abbrev1 {} {
1488     global report_list_codes
1489     .cp.report.abbrev1 delete all
1490     set ix [.cp.report.list curselection]
1491     debug "SHOW-REPORT-ABBREV1 $ix $report_list_codes"
1492     if {[llength $ix] != 1} return
1493     set code [lindex $report_list_codes $ix]
1494     if {![string length $code]} return
1495     if {![have-notes]} {
1496         manyset [split $code _] inport size subclass lockown xabbrev
1497         regsub {.$} $lockown 3 lockown
1498         set code [join [list $inport $size $subclass $lockown $xabbrev] _]
1499     }
1500     code2canvas1 $code .cp.report.abbrev1
1501 }
1502
1503 proc zoom {amt} {
1504     global scaleix scales scale canvas
1505     incr scaleix $amt
1506     if {$scaleix < 0} { set scaleix 0 }
1507     set nscales [llength $scales]
1508     if {$scaleix >= $nscales} { set scaleix [expr {$nscales-1}] }
1509     set scale [lindex $scales $scaleix]
1510     debug "ZOOM $amt $scaleix $scale"
1511     draw
1512 }
1513
1514 proc invoke_acquire {} {
1515     global clipboard errorInfo
1516     set old $clipboard
1517
1518     if {[catch {
1519         set clipboard [clipboard get]
1520     } emsg]} {
1521         parser-control-failed-unexpected .cp.ctrl.acquire acquire \
1522             $emsg "fetching clipboard:\n\n$errorInfo"
1523         return
1524     }
1525
1526     reparse acquire \
1527         clipboard $old "Clipboard contents:" { acquired ok } { no vessels } {
1528             parse-clipboard
1529         } {
1530             display-note-infos
1531         }
1532     draw
1533 }
1534
1535 proc invoke_notes {} {
1536     global notes_data errorInfo notes_loc
1537     set old $notes_data
1538
1539     if {[catch {
1540         load-notes
1541     } emsg]} {
1542         parser-control-failed-unexpected .cp.ctrl.notes notes \
1543             $emsg "loading $notes_loc:\n\n$errorInfo"
1544         return
1545     }
1546
1547     reparse notes \
1548         notes_data $old "Vessel notes:" "loaded ok" { no notes } {
1549             parse-notes
1550             parse-clipboard
1551         } {
1552             display-note-infos
1553         }
1554     draw
1555 }
1556
1557 #---------- main program ----------
1558
1559 init-scales
1560 parseargs
1561 argdefaults
1562 httpclientsetup where-vessels
1563 info-cache-update
1564 vesselinfo-init
1565 load-chart
1566 widgets-setup
1567 make-filters
1568 make-smashers
1569
1570 set notes_data {}
1571 if {[catch { parse-clipboard } emsg]} {
1572     puts stderr "$emsg\n$errorInfo"
1573     exit 1
1574 }
1575 if {[have-notes]} {
1576     after idle invoke_notes
1577 }
1578
1579 draw
1580
1581 if {$debug} {
1582     package require Tclx
1583     commandloop -async \
1584         -prompt1 { return "where-vessels% " } \
1585         -prompt2 { return "> " }
1586 }
1587
1588 # some runes I use:
1589 #
1590 # offline development
1591 #   ./where-vessels --notes ~/vessel-notes --vessel-info-source '' --pirate Aristarchus --ocean Midnight --debug --local-html-dir . --clipboard-file ~/clipboard-aristarchus
1592 #
1593 # updating published vessel info
1594 #   rsync -r --exclude=\*~ yarrg/icons/. ijackson@chiark.greenend.org.uk:/home/ftp/users/ijackson/yarrg/vessel-info/.