X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=blobdiff_plain;f=yarrg%2Fwhere-vessels;h=47cd6ed1119fb63aedea28561d8a8a00abdae5c3;hp=ae8fb5520325066b134011566c178f5ed7650264;hb=59393edc418d7062f6fb074a90d3b8e810c43772;hpb=2bafdfd9436b439aa7ccd22289e99e84e895134a diff --git a/yarrg/where-vessels b/yarrg/where-vessels index ae8fb55..47cd6ed 100755 --- a/yarrg/where-vessels +++ b/yarrg/where-vessels @@ -254,8 +254,8 @@ proc vesselclasses-init {} { merchbrig fm mb {Merchant Brig} warbrig gm wb {War Brig} xebec hm xe Xebec - warfrig im wf {War Frigate} merchgal jm mg {Merchant Galleon} + warfrig im wf {War Frigate} grandfrig km gf {Grand Frigate} } set vc_codes {} @@ -264,29 +264,105 @@ proc vesselclasses-init {} { set vc_game2code($game) $code set vc_code2abbrev($code) $abbrev set vc_code2full($code) $full + load-icon $abbrev } + + load-icon atsea + foreach a {battle borrow dot} { + foreach b {ours dot query} { + load-icon-combine $a $b + } + } +} + +proc load-icon {icon} { + image create bitmap icon/$icon -file icons/$icon.xbm } -proc code2abbrev-lock {lockown} { +proc load-icon-combine {args} { + set cmd {} + set delim "pnmcat -lr " + foreach icon $args { + append cmd $delim " <(xbmtopbm icons/$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]] -} + return icon/[ + lindex {battle borrow dot} $lock + ]+[ + lindex {ours dot query} $notown + ] +} + +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] + 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 + } + + canvas-horiz-stack stackx -1 $imy $bind \ + image -anchor nw -image icon/$vc_code2abbrev($class) + + if {[string length $subclass]} { + canvas-horiz-stack stackx 0 $y $bind \ + text -anchor nw -font fixed -text \ + $subclass + } + + incr stackx + canvas-horiz-stack stackx 0 $imy $bind \ + image -anchor nw -image [code-lockown2icon $lockown] + 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} { @@ -311,8 +387,7 @@ proc show-report-decode {code} { 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" } default { report-set own "?? $notown" } } @@ -328,7 +403,10 @@ proc show-report-decode {code} { 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] @@ -338,19 +416,18 @@ 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 return $yes } @@ -388,13 +465,17 @@ proc make-tickbox-filter {fil label rows inrow} { if {!$inrow} { set inrow [expr {($nvalues + $rows) / $rows}] } - + set noicons [catch { info args filter-icon/$fil }] for {set ix 0} {$ix < $nvalues} {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 + -font fixed -command redraw-needed + if {!$noicons} { + $fw.$ix configure -image [filter-icon/$fil $val] -height 16 + } else { + $fw.$ix configure -text [filter-map/$fil $val] + } grid configure $fw.$ix -sticky sw \ -row [expr {$ix / $inrow}] \ -column [expr {$ix % $inrow}] @@ -514,13 +595,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] } @@ -646,7 +727,7 @@ proc redraw-needed {} { } proc draw {} { - global chart found isleloc canvas redraw_after + global chart found isleloc canvas redraw_after islandnames catch { after cancel $redraw_after } catch { unset redraw_after } @@ -659,6 +740,7 @@ proc draw {} { eval chart-got/$proc [lrange $l 1 end] } + set islandnames {} set lastislandname {} foreach key [lsort [array names found]] { set c [llength $found($key)] @@ -667,35 +749,24 @@ proc draw {} { if {![filters-say-yes $code]} continue - set abbrev [code2abbrev $code] - 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 text [format "%2d%s" $c $text] - } else { - set text [format " %s" $text] - } - set id [$canvas create text $x $y \ - -anchor nw -font fixed \ - -text $text] - set bbox [$canvas bbox $id] - set bid [eval $canvas create rectangle $bbox -fill white] - $canvas lower $bid $id - $canvas bind $id [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 } @@ -703,7 +774,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 \ @@ -838,6 +909,28 @@ 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 {} { @@ -857,8 +950,9 @@ proc widgets-setup {} { #----- control panels and filter ----- frame .cp - frame .filter -relief groove -bd 2 - pack .cp .filter -side top + frame .filter -relief groove -bd 2 -padx 1 + frame .islands -pady 2 + pack .cp .filter .islands -side top label .filter.title -text Filter grid configure .filter.title -row 0 -column 0 -columnspan 2 @@ -873,12 +967,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 \ @@ -893,6 +987,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 @@ -900,14 +1002,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: @@ -920,7 +1015,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} { @@ -933,9 +1029,14 @@ 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" @@ -1003,9 +1104,8 @@ proc invoke_notes {} { #---------- main program ---------- -vesselclasses-init - parseargs +vesselclasses-init argdefaults httpclientsetup where-vessels load-chart