X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.main.git;a=blobdiff_plain;f=yarrg%2Fwhere-vessels;h=97e5e6c0801a2119395f30a954610afa95e895cf;hp=0639d4abba33ecfcc80aa02efded735072da17c6;hb=651e153fc3598c12ae18ccf8c45d6dc80de9dbe1;hpb=fffd6551a3a72719c5147ec37698cec0e636b212 diff --git a/yarrg/where-vessels b/yarrg/where-vessels index 0639d4a..97e5e6c 100755 --- a/yarrg/where-vessels +++ b/yarrg/where-vessels @@ -103,6 +103,8 @@ proc nextarg {} { set notes_loc vessel-notes set scraper {./yppedia-ocean-scraper --chart} +set info_cache _vessel-info-cache +set info_source rsync.yarrg.chiark.net::yarrg/vessel-info proc parseargs {} { global ai argv @@ -118,6 +120,7 @@ proc parseargs {} { --clipboard-file { load-clipboard-file [nextarg] } --local-html-dir { lappend scraper --local-html-dir=[nextarg] } --notes { glset notes_loc [nextarg] } + --vessel-info-source { glset info_source [nextarg] } --debug { incr debug } default { badusage "unknown option $arg" } } @@ -133,6 +136,9 @@ proc argdefaults {} { if {[info exists ocean]} { lappend cmd --ocean $ocean } if {[info exists pirate]} { lappend cmd --pirate $pirate } manyset [split [eval exec $cmd] " "] ocean pirate + if {![llength $ocean] || ![llength $pirate]} { + error "$ocean $pirate ?" + } } lappend scraper $ocean } @@ -193,15 +199,6 @@ proc note-info {lno vid name island description} { lappend note_infos [list $lno $vid $name $island $description] } -proc canvas-horiz-stack {xvar y type args} { - upvar 1 $xvar x - global canvas - set id [eval $canvas create $type $x $y $args] - set bbox [$canvas bbox $id] - set x [lindex $bbox 2] - return $id -} - proc display-note-infos {} { global note_infos note_missings notes @@ -252,51 +249,162 @@ proc display-note-infos {} { #---------- vessel properties ---------- +proc info-cache-update {} { + global info_source info_cache + file mkdir $info_cache + exec sh -c "cp -u icons/* $info_cache/." + + if {[string length $info_source]} { + set cmdl [list \ + rsync -udLKtOzm \ + --exclude=*~ --exclude=*.bak --exclude=.* --exclude=*.tmp \ + $info_source/ $info_cache 2>@ stderr] + debug "INFO-CACHE $cmdl" + eval exec $cmdl + } + + set f [open $info_cache/vessel-info] + glset vessel_class_data [read $f] + close $f +} + proc vesselclasses-init {} { global vc_game2code vc_code2abbrev vc_code2full vc_codes - set vcl { - smsloop am sl Sloop - lgsloop bm ct Cutter - dhow cm dh Dhow - longship dm ls Longship - baghlah em bg Baghlah - merchbrig fm mb {Merchant Brig} - warbrig gm wb {War Brig} - xebec hm xe Xebec - warfrig im wf {War Frigate} - merchgal jm mg {Merchant Galleon} - grandfrig km gf {Grand Frigate} - } + + global vessel_class_data + manyset $vessel_class_data classinfos subclassinfos + set vc_codes {} - foreach {game code abbrev full} $vcl { + foreach {game code abbrev full} $classinfos { + if {![regexp {^[a-z][a-z]$} $code code]} { error "bad code" } + if {![regexp {^[a-z][a-z]$} $abbrev abbrev]} { error "bad abbrev" } lappend vc_codes $code set vc_game2code($game) $code set vc_code2abbrev($code) $abbrev set vc_code2full($code) $full - image create bitmap ship-icon/$abbrev -file iconsdir/$abbrev.xbm + load-icon $abbrev + } + + global vsc_code2report + global vsc_game2code + set vsc_game2code(null) {} + set vsc_code2report() Ordinary + set vsc_code2report(!) "(Special/L.E.)" + foreach {game code full} $subclassinfos { + if {![regexp {^[A-Z]$} $code code]} { error "bad code" } + set vsc_game2code($game) $code + set vsc_code2report($code) $full + } + + load-icon atsea + set owners {ours dot query} + foreach b $owners { load-icon $b } + foreach a {battle borrow dot} { + load-icon $a + foreach b $owners { load-icon-combine $a $b } } } -proc code2abbrev-lock {lockown} { +proc load-icon {icon} { + global info_cache + image create bitmap icon/$icon -file $info_cache/$icon.xbm +} + +proc load-icon-combine {args} { + global info_cache + set cmd {} + set delim "pnmcat -lr " + foreach icon $args { + append cmd $delim " <(xbmtopbm $info_cache/$icon.xbm)" + set delim " <(pbmmake -white 1 1)" + } + append cmd " | pbmtoxbm" + debug "load-icon-combine $cmd" + image create bitmap icon/[join $args +] -data [exec bash -c $cmd] +} + +proc code-lockown2icon {lockown} { manyset [split $lockown ""] lock notown - append abbrev [lindex {* + -} $lock] - append abbrev [lindex {= - ?} [regsub {\D} $notown 2]] -} + set l " + [lindex {battle borrow dot} $lock] + [lindex {ours dot query {} {} dot} $notown] + " + if {[llength $l]} { return icon/[join $l +] } { return {} } +} + +proc canvas-horiz-stack {xvar xoff y bind type args} { + upvar 1 $xvar x + upvar 1 canvas canvas + set id [eval $canvas create $type [expr {$x+$xoff}] $y $args] + set bbox [$canvas bbox $id] +# debug "CANVAS-HORIZ-STACK $type $x $xoff $id $bbox [list $args]" + set x [lindex $bbox 2] + $canvas bind $id $bind + return $id +} -proc code2abbrev {code} { +proc code2canvas {code canvas x yvar qty qtylen bind} { global vc_code2abbrev + upvar 1 $yvar y manyset [split $code _] inport class subclass lockown xabbrev - set abbrev {} - append abbrev [lindex {? {}} $inport] - append abbrev $vc_code2abbrev($class) - append abbrev $subclass - append abbrev [code2abbrev-lock $lockown] - append abbrev $xabbrev + set stackx $x + incr stackx 2 + set imy [expr {$y+2}] + + if {!$inport} { incr qtylen -1 } + if {$qtylen<=0} { set qtylen {} } + set qty [format "%${qtylen}s" $qty] + + set qtyid [canvas-horiz-stack stackx 0 $y $bind \ + text -anchor nw -font fixed -text $qty] + + if {!$inport} { + canvas-horiz-stack stackx 0 $imy $bind \ + image -anchor nw -image icon/atsea + incr stackx + } + + upvar #0 vc_code2abbrev($class) vcabb + if {![info exists vcabb]} { + set vcabb vc-$class + image create bitmap icon/$vcabb -data \ + [exec pbmtext -builtin fixed $class | pnminvert | pnmcrop >t.pnm] + } + canvas-horiz-stack stackx -1 $imy $bind \ + image -anchor nw -image icon/$vcabb + + if {[string length $subclass]} { + canvas-horiz-stack stackx 0 $y $bind \ + text -anchor nw -font fixed -text \ + $subclass + } + + incr stackx + set lockownicon [code-lockown2icon $lockown] + if {[string length $lockownicon]} { + canvas-horiz-stack stackx 0 $imy $bind \ + image -anchor nw -image $lockownicon + incr stackx + } + + if {[string length $xabbrev]} { + canvas-horiz-stack stackx 0 $y $bind \ + text -anchor nw -font fixed -text \ + $xabbrev + } + + set bbox [$canvas bbox $qtyid] + set ny [lindex $bbox 3] + set bid [$canvas create rectangle \ + $x $y $stackx $ny \ + -fill white] + + set y $ny + $canvas lower $bid $qtyid - debug "CODE2ABBREV $code $abbrev" - return $abbrev + $canvas bind $bid $bind } proc show-report-decode {code} { @@ -308,21 +416,29 @@ proc show-report-decode {code} { report-set inport [lindex {{At Sea} {In port}} $inport] report-set class $vc_code2full($classcode) - switch -exact $subclass { - {} { report-set subclass {Ordinary} } - F { report-set subclass {"Frost class"} } - default { report-set subclass "Subclass \"$subclass\"" } + global smash_subclass + if {$smash_subclass >= 2} { + report-set subclass "(Any subclass)" + } elseif {[ + upvar #0 vsc_code2report($subclass) subclass_report + info exists subclass_report + ]} { + report-set subclass $subclass_report + } else { + report-set subclass "Subclass \"$subclass\"" } report-set lock [lindex { {Battle ready} {Unlocked} {Locked} + {(All lock states)} {(Not battle ready)} } $lock] switch -exact $notown { 0 { report-set own "Yours" } 1 { report-set own "Other pirate's" } - U { report-set own "Owner not known" } - M { report-set own "Missing from notes" } + 2 { report-set own "Owner unknown" } + 3 { report-set own "(All ownerships)" } + 4 - 5 { report-set own "(Yours/unknown)" } default { report-set own "?? $notown" } } @@ -333,12 +449,127 @@ proc show-report-decode {code} { } } +#---------- common to smashing and filtering ---------- + +proc make-control {parent ctrl label ekind} { + debug "MAKE-CONTROL [list $parent $ctrl $label $ekind]" + label $parent.lab_$ctrl -text $label -justify left + $ekind $parent.$ctrl + manyset [grid size $parent] dummy row + incr row + grid configure $parent.lab_$ctrl -row $row -column 0 -sticky nw -pady 4 + grid configure $parent.$ctrl -row $row -column 1 -sticky w -pady 3 + return $parent.$ctrl +} + +proc begin-control-grid {cw count rows inrow} { + if {!$inrow} { set inrow [expr {($count + $rows) / $rows}] } + upvar #0 control_grid_properties($cw) props + set props [list $rows $inrow] + return $cw +} + +proc make-control-grid-entry {cw kind ix ekind args} { + upvar #0 control_grid_properties($cw) props + manyset $props rows inrow + + set ew $cw.$ix + eval [list $ekind $ew] $args + + switch -exact $kind { + ix { + grid configure $ew -sticky sw \ + -row [expr {$ix / $inrow}] \ + -column [expr {$ix % $inrow}] + } + final { + grid configure $ew -sticky se \ + -row [expr {$rows-1}] \ + -column [expr {$inrow-1}] + } + default { + error "$kind ?" + } + } + return $ew +} + +#---------- smashing ---------- + +set smash_subclass 0 +set smash_owner 0 + +proc smash-code {code} { + manyset [split $code _] inport class subclass lockown xabbrev + + global smash_subclass + if {$smash_subclass > 1} { + set subclass {} + } elseif {$smash_subclass && [string length $subclass]} { + set subclass ! + } + + global smash_owner + switch $smash_owner { + 0 { } + 1 { regsub {[12]$} $lockown 5 lockown } + 2 { + if {[regexp {^0.} $lockown]} { + # battle ready / all lock states + set lockown 03 + } elseif {[regexp {^.0} $lockown]} { + # not battle ready / yours + set lockown 40 + } else { + # state (not battle ready) / not known to be yours + regsub {.$} $lockown 4 lockown + } + } + 3 { regsub {.$} $lockown {3} lockown } + 4 { set lockown 33 } + } + + return [join [list $inport $class $subclass $lockown $xabbrev] _] +} + +proc make-smasher {sma label ekind} { + return [make-control .smash $sma $label $ekind] +} + +proc make-radio-smasher {sma label variable descs rows inrow} { + set w [make-smasher $sma $label frame] + begin-control-grid $w [llength $descs] $rows $inrow + for {set i 0} {$i < [llength $descs]} {incr i} { + make-control-grid-entry $w ix $i \ + radiobutton \ + -variable $variable -value $i -command redraw-needed \ + -text [lindex $descs $i] + } +} + +proc make-smashers {} { + make-radio-smasher subclass Subclass smash_subclass \ + {Show Normal/LE Hide} 1 0 + + make-radio-smasher owner Owner smash_owner \ + {Show Yours? {For you} Lock Hide} 2 3 + + global vc_codes vc_code2abbrev + + set cw [make-smasher size "Size\nround down" frame] + populate-control-grid-tickboxes $cw 2 0 smash_size $vc_codes \ + image val { return 0 } { return $vc_code2abbrev($val) } +} + #---------- filtering ---------- set filters {} proc filter-values/size {} { global vc_codes; return $vc_codes } -proc filter-map/size {code} { upvar #0 vc_code2abbrev($code) abb; return $abb } +proc filter-icon/size {code} { + upvar #0 vc_code2abbrev($code) abb + return icon/$abb +} proc filter-default/size {code} { return 1 } proc filter-says-yes/size {codel} { set sizecode [lindex $codel 1] @@ -348,20 +579,20 @@ proc filter-says-yes/size {codel} { proc filter-values/lockown {} { foreach lv {0 1 2} { - foreach ov {0 1 X} { + foreach ov {0 1 2} { lappend vals "$lv$ov" } } return $vals } -proc filter-map/lockown {lockown} { return [code2abbrev-lock $lockown] } +proc filter-icon/lockown {lockown} { return [code-lockown2icon $lockown] } proc filter-default/lockown {lockown} { return [regexp {^[01]|^2[^1]} $lockown] } proc filter-says-yes/lockown {codel} { set lockown [lindex $codel 3] - regsub -all {\D} $lockown X lockown upvar #0 filter_lockown($lockown) yes + debug "FILTER-SAYS-YES/LOCKOWN $codel $lockown $yes" return $yes } @@ -392,28 +623,30 @@ proc filter-tickbox-flip {fil} { proc make-tickbox-filter {fil label rows inrow} { upvar #0 filter_$fil vars - set fw [make-filter tickbox $fil $label frame] set values [filter-values/$fil] - set nvalues [llength $values] - if {!$inrow} { - set inrow [expr {($nvalues + $rows) / $rows}] - } + set count [llength $values] + set noicons [catch { info args filter-icon/$fil }] + + set fw [make-filter $fil $label frame] + begin-control-grid $fw $count $rows $inrow - for {set ix 0} {$ix < $nvalues} {incr ix} { + for {set ix 0} {$ix < $count} {incr ix} { set val [lindex $values $ix] set vars($val) [filter-default/$fil $val] - checkbutton $fw.$ix -variable filter_${fil}($val) \ - -text [filter-map/$fil $val] -font fixed \ - -command redraw-needed - grid configure $fw.$ix -sticky sw \ - -row [expr {$ix / $inrow}] \ - -column [expr {$ix % $inrow}] + set ew [make-control-grid-entry $fw ix $ix checkbutton \ + -variable filter_${fil}($val) \ + -font fixed \ + -command [list redraw-needed tickbox-filter $fil $val]] + if {!$noicons} { + $fw.$ix configure -image [filter-icon/$fil $val] -height 16 + } else { + $fw.$ix configure -text [filter-map/$fil $val] + } } - button $fw.invert -text flip -command [list filter-tickbox-flip $fil] \ + [make-control-grid-entry $fw final invert button] \ + configure \ + -text flip -command [list filter-tickbox-flip $fil] \ -padx 0 -pady 0 - grid configure $fw.invert -sticky se \ - -row [expr {$rows-1}] \ - -column [expr {$inrow-1}] } proc entry-filter-changed {fw fil n1 n2 op} { @@ -440,7 +673,7 @@ proc make-entry-filter {fil label def} { global filterentered_$fil upvar #0 filter_$fil realvar set realvar $def - set fw [make-filter entry $fil $label frame] + set fw [make-filter $fil $label frame] entry $fw.entry -textvariable filterentered_$fil label $fw.error glset def_background [$fw.error cget -background] @@ -449,15 +682,10 @@ proc make-entry-filter {fil label def} { pack $fw.entry $fw.error -side top -anchor w } -proc make-filter {kind fil label ekind} { +proc make-filter {fil label ekind} { global filters - label .filter.lab_$fil -text $label -justify left - $ekind .filter.$fil lappend filters $fil - set nfilters [llength $filters] - grid configure .filter.lab_$fil -row $nfilters -column 0 -sticky nw -pady 4 - grid configure .filter.$fil -row $nfilters -column 1 -sticky w -pady 3 - return .filter.$fil + return [make-control .filter $fil $label $ekind] } proc make-filters {} { @@ -466,12 +694,31 @@ proc make-filters {} { make-entry-filter xabbre "Flags\n regexp" {} } +proc filterstyle-changed {n1 n2 op} { + global filterstyle + debug "filterstyle-changed $filterstyle" + redraw-needed +} + proc filters-say-yes {code} { - global filters - debug "filters-say-yes $code" + global filters filterstyle + set codel [split $code _] + set lockown [lindex $codel 3] + switch -exact $filterstyle { + 0 { return 1 } + 1 { return [filter-default/lockown $lockown] } + 2 { return [regexp {^.0} $lockown] } + 3 { } + default { error $filterstyle } + } + foreach fil $filters { - if {![filter-says-yes/$fil [split $code _]]} { return 0 } + if {![filter-says-yes/$fil $codel]} { + debug "FILTERS-SAY-YES $code NO $fil" + return 0 + } } + debug "FILTERS-SAY-YES $code YES $filters" return 1 } @@ -486,14 +733,26 @@ proc vessel {vin} { set gameclass [errexpect-arrayget vi vesselClass] upvar #0 vc_game2code($gameclass) class - if {![info exists class]} { errexpect-error "unexpected vesselClass"} + if {![info exists class]} { + set class "($gameclass)" + upvar #0 vc_code2abbrev($class) vcabb + set vcabb vc-$class + set data [exec pbmtext -builtin fixed " $gameclass " \ + | pnminvert | pnmcrop | pbmtoxbm] + debug "INVENTED ICON $vcabb $data" + image create bitmap icon/$vcabb -data $data + + global vc_code2full + set vc_code2full($class) "Type \"$gameclass\"" + } lappend codel $class - set subclass [errexpect-arrayget vi vesselSubclass] - switch -exact $subclass { - null { lappend codel {} } - icy { lappend codel F } - default { lappend codel ($subclass) } + set gamesubclass [errexpect-arrayget vi vesselSubclass] + upvar #0 vsc_game2code($gamesubclass) subclass + if {[info exists subclass]} { + lappend codel $subclass + } else { + lappend codel ($gamesubclass) } switch -exact [errexpect-arrayget vi isLocked]/[ \ @@ -524,13 +783,13 @@ proc vessel {vin} { set notown 1 } } else { - set notown U + set notown 2 } append abbrev $xabbrev set notes_used($vid) 1 } else { - set notown M + set notown 2 lappend note_missings [list $island $realname $vid] } @@ -538,7 +797,7 @@ proc vessel {vin} { lappend newnotes [list $vid $realname $owner $xabbrev] set kk "$island [join $codel _]" upvar #0 found($kk) k - lappend k [list $vid $realname] + lappend k [list $vid $realname $owner] debug "CODED $kk $vid $realname" } @@ -608,7 +867,7 @@ proc load-chart {} { yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"), sub { sprintf "%d %d", @_; }, sub { printf "archlabel %d %d %s\n", @_; }, - sub { printf "island %s %s\n", @_; }, + sub { printf "island %s {%s} %s\n", @_; }, sub { printf "league %s %s %s.\n", @_; }, sub { printf STDERR "warning: %s: incomprehensible: %s", @_; } ); @@ -625,17 +884,19 @@ proc coord {c} { } proc chart-got/archlabel {args} { } -proc chart-got/island {x y args} { -# debug "ISLE $x $y $args" +proc chart-got/island {x y isle sizecol} { + debug "ISLE $x $y $isle $sizecol" global canvas isleloc - set isleloc($args) [list $x $y] + set isleloc($isle) [list $x $y] set sz 5 # $canvas create oval \ # [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \ # [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \ # -fill blue + set colour "#888" + if {[string match *_col $sizecol]} { set colour black } $canvas create text [coord $x] [coord $y] \ - -text $args -anchor s + -text $isle -anchor s -fill $colour } proc chart-got/league {x1 y1 x2 y2 kind} { # debug "LEAGUE $x1 $y1 $x2 $y2 $kind" @@ -648,16 +909,32 @@ proc chart-got/league {x1 y1 x2 y2 kind} { } } -proc redraw-needed {} { +proc debug-filter-array {array} { + upvar #0 $array a + set m " FILTER $array" + foreach k [lsort [array names a]] { + append m " $k=$a($k)" + } + debug $m +} + +proc redraw-needed {args} { global redraw_after - debug "REDRAW NEEDED" + debug "REDRAW NEEDED $args" if {[info exists redraw_after]} return + + global filterstyle + debug " FILTER style $filterstyle" + debug-filter-array filter_size + debug-filter-array filter_lockown + global filter_xabbre + debug " FILTER xabbre $filter_xabbre" + set redraw_after [after 250 draw] } proc draw {} { - global chart found isleloc canvas redraw_after - global vc_code2abbrev + global chart found isleloc canvas redraw_after islandnames smfound catch { after cancel $redraw_after } catch { unset redraw_after } @@ -670,59 +947,43 @@ proc draw {} { eval chart-got/$proc [lrange $l 1 end] } - set lastislandname {} + catch { unset smfound } foreach key [lsort [array names found]] { - set c [llength $found($key)] -# debug "SHOWING $key $c" regexp {^(.*) (\S+)$} $key dummy islandname code if {![filters-say-yes $code]} continue - set abbrev [code2abbrev $code] - + set smcode [smash-code $code] + debug "smashed $code => $smcode" + set smkey "$islandname $smcode" + foreach vessel $found($key) { lappend smfound($smkey) $vessel } + } + + set islandnames {} + set lastislandname {} + foreach smkey [lsort [array names smfound]] { + set c [llength $smfound($smkey)] + regexp {^(.*) (\S+)$} $smkey dummy islandname code + debug "SHOWING [list $smkey $c $islandname $code l=$lastislandname]" + if {[string compare $lastislandname $islandname]} { manyset $isleloc($islandname) x y set x [coord $x] set y [coord $y] set lastislandname $islandname + lappend islandnames $islandname # debug "START Y $y" } - set text $abbrev - regsub -all {[0-9]} $text {} text - if {$c > 1} { - set qty [format "%2d" $c] - } else { - set qty [format "99" $c] - } - set stackx $x - incr stackx 2 - set tid [canvas-horiz-stack stackx $y \ - text -anchor nw -font fixed -text $qty] - incr stackx -1 - canvas-horiz-stack stackx [expr {$y+1}] \ - image -anchor nw -image ship-icon/$vc_code2abbrev([lindex [split $code _] 1]) - incr stackx - canvas-horiz-stack stackx $y \ - text -anchor nw -font fixed -text $text - - set bbox [$canvas bbox $tid] - set ny [lindex $bbox 3] - puts "$tid $bbox" - set bid [$canvas create rectangle \ - $x $y $stackx $ny \ - -fill white] - - set y $ny - $canvas lower $bid $tid - - $canvas bind $tid [list show-report $islandname $code] - $canvas bind $bid [list show-report $islandname $code] - manyset $bbox dummy dummy dummy y + if {$c > 1} { set qty [format %d $c] } else { set qty {} } + code2canvas $code $canvas $x y $qty 2 \ + [list show-report $islandname $code] # debug "NEW Y $y" } panner::updatecanvas-bbox .cp.ctrl.pan + + islandnames-update } @@ -730,7 +991,7 @@ proc draw {} { proc parser-control-create {w base invokebuttontext etl_title} { frame $w - button $w.do -text $invokebuttontext -command invoke_$base + button $w.do -text $invokebuttontext -command invoke_$base -pady 3 frame $w.resframe -width 120 -height 32 button $w.resframe.res -text {} -anchor nw \ @@ -745,6 +1006,7 @@ proc parser-control-create {w base invokebuttontext etl_title} { toplevel $eb wm withdraw $eb wm title $eb "where-vessels - $etl_title" + wm protocol $eb WM_DELETE_WINDOW [list wm withdraw $eb] label $eb.title -text $etl_title pack $eb.title -side top @@ -753,17 +1015,17 @@ proc parser-control-create {w base invokebuttontext etl_title} { pack $eb.close -side bottom frame $eb.emsg -bd 2 -relief groove - label $eb.emsg.lab -text "Error:" + label $eb.emsg.lab -anchor nw -text "Error:" text $eb.emsg.text -height 1 - pack $eb.emsg.text -side bottom + pack $eb.emsg.text -side bottom -fill x pack $eb.emsg.lab -side left - pack $eb.emsg -side top -pady 2 + pack $eb.emsg -side top -pady 2 -fill x frame $eb.text -bd 2 -relief groove - pack $eb.text -side bottom -pady 2 + pack $eb.text -side bottom -pady 2 -fill both -expand y - label $eb.text.lab + label $eb.text.lab -anchor nw text $eb.text.text -width 85 \ -xscrollcommand [list $eb.text.xscroll set] \ @@ -776,10 +1038,15 @@ proc parser-control-create {w base invokebuttontext etl_title} { scrollbar $eb.text.yscroll -orient vertical \ -command [list $eb.text.text yview] - grid configure $eb.text.lab -row 0 -column 0 -sticky w - grid configure $eb.text.text -row 1 -column 0 + grid configure $eb.text.lab -row 0 -column 0 -sticky w -columnspan 2 + grid configure $eb.text.text -row 1 -column 0 -sticky news grid configure $eb.text.yscroll -sticky ns -row 1 -column 1 grid configure $eb.text.xscroll -sticky ew -row 2 -column 0 + grid rowconfigure $eb.text 0 -weight 0 + grid rowconfigure $eb.text 1 -weight 1 + grid rowconfigure $eb.text 2 -weight 0 + grid columnconfigure $eb.text 0 -weight 1 + grid columnconfigure $eb.text 1 -weight 0 } proc parser-control-ok-core {w base background show} { @@ -865,12 +1132,34 @@ proc reparse {base varname old fulldesc okshow noneshow parse ok} { } } +#---------- island names selection etc. ---------- + +proc islandnames-update {} { + global islandnames + .islands.count configure -text [format "ships at %d island(s)" \ + [llength $islandnames]] +} + +proc islandnames-select {} { + .islands.clip configure -relief sunken -state disabled + selection own -command islandnames-deselect .islands.clip +} +proc islandnames-deselect {} { + .islands.clip configure -relief raised -state normal +} + +proc islandnames-handler {offset maxchars} { + global islandnames + return [string range [join $islandnames ", "] \ + $offset [expr {$offset+$maxchars-1}]] +} + #---------- main user interface ---------- proc widgets-setup {} { - global canvas debug pirate ocean + global canvas debug pirate ocean filterstyle - wm geometry . 1024x480 + wm geometry . 1200x800 wm title . "where-vessels - $pirate on the $ocean ocean" #----- map ----- @@ -884,10 +1173,27 @@ proc widgets-setup {} { #----- control panels and filter ----- frame .cp - frame .filter -relief groove -bd 2 - pack .cp .filter -side top + frame .smash -relief groove -bd 2 -padx 1 + frame .filter -relief groove -bd 2 -padx 1 + frame .islands -pady 2 + pack .cp .filter .islands .smash -side top + + label .smash.title -text {Display/combine details} + grid .smash.title -row 0 -column 0 -columnspan 2 + + set filterstyle 1 + trace add variable filterstyle write filterstyle-changed + + frame .filter.title + label .filter.title.title -text Show + pack .filter.title.title -side left + for {set fing 0} {$fing < 4} {incr fing} { + radiobutton .filter.title.f$fing \ + -variable filterstyle -value $fing \ + -text [lindex {All Useable Mine These:} $fing] + pack .filter.title.f$fing -side left + } - label .filter.title -text Filter grid configure .filter.title -row 0 -column 0 -columnspan 2 #----- control panel ----- @@ -900,12 +1206,12 @@ proc widgets-setup {} { panner::canvas-scroll-bbox .f.c panner::create .cp.ctrl.pan .f.c 120 120 $debug - pack .cp.ctrl.pan -side top -pady 10 -padx 5 + pack .cp.ctrl.pan -side top -pady 0 -padx 5 frame .cp.ctrl.zoom pack .cp.ctrl.zoom -side top - button .cp.ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2} - button .cp.ctrl.zoom.in -text + -font {Courier 16} -command {zoom *2} + button .cp.ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2} -pady 0 + button .cp.ctrl.zoom.in -text + -font {Courier 16} -command {zoom *2} -pady 0 pack .cp.ctrl.zoom.out .cp.ctrl.zoom.in -side left parser-control-create .cp.ctrl.acquire \ @@ -920,6 +1226,14 @@ proc widgets-setup {} { pack .cp.ctrl.notes -side top -pady 2 + #----- island name count and copy ----- + + label .islands.count + button .islands.clip -text "copy island names" -pady 2 -padx 2 \ + -command islandnames-select + selection handle .islands.clip islandnames-handler + pack .islands.count .islands.clip -side left + #----- decoding etc. report ----- frame .cp.report @@ -927,14 +1241,7 @@ proc widgets-setup {} { label .cp.report.island -text { } - frame .cp.report.abbrev -background black - glset report_abbrev { } - entry .cp.report.abbrev.abbrev -state readonly \ - -textvariable report_abbrev \ - -borderwidth 0 -relief flat -width 0 \ - -highlightbackground white \ - -readonlybackground white -foreground black - pack .cp.report.abbrev.abbrev -side left -padx 1 -pady 1 + canvas .cp.report.abbrev -width 1 -height 15 frame .cp.report.code label .cp.report.code.lab -text Code: @@ -947,7 +1254,8 @@ proc widgets-setup {} { listbox .cp.report.list -height 5 pack .cp.report.island .cp.report.abbrev .cp.report.details \ - .cp.report.list .cp.report.code -side top + .cp.report.list -side top + #pack .cp.report.code -side top pack configure .cp.report.details -fill x foreach sw {inport class subclass lock own xabbrev} { @@ -960,19 +1268,36 @@ proc report-set {sw val} { .cp.report.details.$sw configure -text $val } proc show-report {islandname code} { .cp.report.island configure -text $islandname - glset report_code $code - glset report_abbrev [code2abbrev $code] + .cp.report.abbrev delete all + set y 2 + code2canvas $code .cp.report.abbrev 5 y {} 0 {} + manyset [.cp.report.abbrev bbox all] minx dummy maxx dummy + .cp.report.abbrev configure -width [expr {$maxx-$minx+4}] + + glset report_code $code show-report-decode $code set kk "$islandname $code" - upvar #0 found($kk) k + upvar #0 smfound($kk) k .cp.report.list delete 0 end foreach entry $k { - manyset $entry vid name - .cp.report.list insert end $name + manyset $entry vid name owner + lappend owned($owner) $name + } + + foreach owner [lsort [array names owned]] { + if {[string length $owner]} { + set owndesc "$owner's" + } else { + set owndesc "Owner unknown" + } + .cp.report.list insert end "$owndesc:" + foreach name $owned($owner) { + .cp.report.list insert end " $name" + } } } @@ -1030,14 +1355,15 @@ proc invoke_notes {} { #---------- main program ---------- -vesselclasses-init - parseargs argdefaults httpclientsetup where-vessels +info-cache-update +vesselclasses-init load-chart widgets-setup make-filters +make-smashers set notes_data {} if {[catch { parse-clipboard } emsg]} { @@ -1047,3 +1373,12 @@ if {[catch { parse-clipboard } emsg]} { after idle invoke_notes draw + +if {$debug} { + package require Tclx + commandloop -async \ + -prompt1 { return "where-vessels% " } \ + -prompt2 { return "> " } +} + +# rsync -r --exclude=\*~ yarrg/icons/. ijackson@chiark.greenend.org.uk:/home/ftp/users/ijackson/yarrg/vessel-info/.