4 set auto_path [concat . $auto_path]
10 proc manyset {list args} {
11 foreach val $list var $args {
17 set itemre { (\w+) = ([^=]*) }
18 set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
21 set vn [open vessel-notes]
22 while {[gets $vn l] >= 0} {
23 regsub -all {\t+} $l "\t" l
24 manyset [split $l "\t"] vname vid owner note
27 set notes($nk) [list $owner $note]
34 switch -exact $vi(vesselClass) {
35 smsloop { set sz 00sl }
36 lgsloop { set sz 01ct }
38 longship { set sz 03ls }
39 baghlah { set sz 04bg }
40 merchbrig { set sz 05mb }
41 warbrig { set sz 06wb }
43 warfrig { set sz 08wf }
44 merchgal { set sz 09mg }
45 grandfrig { set sz 10gf }
46 default { error "$vi(vesselClass) ?" }
49 switch -exact $vi(vesselSubclass) {
51 icy { append abbrev F }
52 default { error "$vi(vesselSubclass) ?" }
54 switch -exact $vi(isLocked)/$vi(isBattleReady) {
55 true/false { append abbrev 2- }
56 false/false { append abbrev 1+ }
57 false/true { append abbrev 0* }
58 default { error "$vi(isLocked)/$vi(isBattleReady) ?" }
60 switch -exact $vi(inPort) {
62 false { append abbrev ? }
63 default { error "$vi(inPort) ?" }
65 set nk $vi(vesselId).$vi(vesselName)
66 upvar #0 notes($nk) note
67 if {[info exists note]} {
68 manyset $note owner xabbrev
69 if {![string compare $owner $us]} {
74 append abbrev $xabbrev
79 set kk "$vi(islandName) $abbrev"
81 if {![info exists k]} { set k 0 }
85 set cl [open clipboard]
86 while {[gets $cl l] >= 0} {
90 if {![regexp -expanded $manyitemre $l dummy \
91 thiskey thisval rhs]} { error "$l ?" }
92 # puts "KEY $thiskey VAL $thisval"
93 set vi($thiskey) $thisval
94 if {![string length $rhs]} break
95 regsub {^, } $rhs {} rhs
102 set chart [open |[list perl -we {
107 yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
108 sub { sprintf "%d %d", @_; },
109 sub { printf "archlabel %d %d %s\n", @_; },
110 sub { printf "island %s %s\n", @_; },
111 sub { printf "league %s %s %s.\n", @_; },
112 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
114 STDOUT->error and die $!;
117 frame .f -border 1 -relief groove
120 #$canvas configure -width 1000 -height 800
121 pack $canvas -expand 1 -fill both
122 pack .f -expand 1 -fill both -side left
128 return [expr {$c * $scale}]
131 proc chart-got/archlabel {args} { }
132 proc chart-got/island {x y args} {
133 # puts "ISLE $x $y $args"
134 global canvas isleloc
135 set isleloc($args) [list $x $y]
137 # $canvas create oval \
138 # [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
139 # [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
141 $canvas create text [coord $x] [coord $y] \
142 -text $args -anchor s
144 proc chart-got/league {x1 y1 x2 y2 kind} {
145 # puts "LEAGUE $x1 $y1 $x2 $y2 $kind"
147 set l [$canvas create line \
148 [coord $x1] [coord $y1] \
149 [coord $x2] [coord $y2]]
150 if {![string compare $kind .]} {
151 $canvas itemconfigure $l -dash .
155 while {[gets $chart l] >= 0} {
156 # puts "CHART-GOT $l"
157 set proc [lindex $l 0]
158 eval chart-got/$proc [lrange $l 1 end]
163 set lastislandname {}
164 foreach key [lsort [array names count]] {
166 # puts "SHOWING $key $c"
167 regexp {^(.*) (\S+)$} $key dummy islandname abbrev
168 if {[string compare $lastislandname $islandname]} {
169 manyset $isleloc($islandname) x y
172 set lastislandname $islandname
176 regsub -all {[0-9]} $text {} text
178 set text [format "%2d%s" $c $text]
180 set text [format " %s" $text]
182 set id [$canvas create text $x $y \
183 -anchor nw -font fixed \
185 set bbox [$canvas bbox $id]
186 set bid [eval $canvas create rectangle $bbox -fill white]
187 $canvas lower $bid $id
188 manyset $bbox dummy dummy dummy y
192 foreach nk [lsort [array names $note]] {
193 puts "IGNORED NOTE $nk"
197 pack .ctrl -side right
199 panner::canvas-scroll-bbox .f.c
200 panner::create .ctrl.pan .f.c 200 200
202 pack .ctrl.pan -side top -pady 20 -padx 20
204 pack .ctrl.zoom -side top
206 button .ctrl.zoom.out -text - -font {Courier 16}
207 button .ctrl.zoom.in -text + -font {Courier 16}
208 pack .ctrl.zoom.out .ctrl.zoom.in -side left
210 #. configure -width 640 -height 480
211 wm geometry . 1024x480
213 #puts "[$canvas bbox all]"