chiark / gitweb /
where-vessels: a few more disablements in the ui if cannot down "is ours?"
[ypp-sc-tools.main.git] / 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/.