Commit | Line | Data |
---|---|---|
1304202a | 1 | #! /usr/bin/wish |
b130b8f5 | 2 | # |
74bdd262 | 3 | # $Id$ |
1304202a | 4 | |
b48b0bfb | 5 | package require "elite" "1.0.1" |
1304202a | 6 | |
044c8fbc | 7 | #----- Utility procedures --------------------------------------------------- |
1304202a | 8 | |
9 | proc moan {msg} { | |
10 | global argv0 | |
11 | tk_messageBox -message $msg -default ok -title $argv0 -type ok -icon error | |
12 | } | |
13 | ||
14 | proc debug-array {name} { | |
15 | upvar \#0 $name a | |
16 | set tl .debug-$name | |
17 | if {[winfo exists .$tl]} { return } | |
18 | set s [array startsearch a] | |
19 | toplevel $tl | |
20 | set r 0 | |
21 | set n 0 | |
22 | while {[array anymore a $s]} { | |
23 | set k [array nextelement a $s] | |
24 | label $tl.k-$n -text $k -justify right | |
25 | entry $tl.v-$n -textvariable ${name}($k) -state disabled | |
044c8fbc | 26 | grid configure $tl.k-$n -row $r -column 0 -sticky e -padx 1 -pady 1 |
27 | grid configure $tl.v-$n -row $r -column 1 -sticky we -padx 1 -pady 1 | |
1304202a | 28 | incr r |
29 | incr n | |
30 | } | |
31 | array donesearch a $s | |
32 | } | |
33 | ||
1304202a | 34 | proc get-line-done {tl cmd} { |
35 | if {![uplevel \#0 [concat $cmd [$tl.entry get]]]} { | |
36 | destroy $tl | |
37 | } | |
38 | } | |
39 | ||
40 | proc get-line {tl title prompt def cmd} { | |
41 | if {[winfo exists $tl]} { | |
42 | # raise $tl | |
43 | return | |
44 | } | |
45 | toplevel $tl | |
46 | wm title $tl $title | |
044c8fbc | 47 | label $tl.label -text "$prompt:" |
1304202a | 48 | entry $tl.entry; $tl.entry insert 0 $def |
49 | button $tl.ok -text OK -default active \ | |
50 | -command [list get-line-done $tl $cmd] | |
51 | bind $tl <Return> [list get-line-done $tl $cmd] | |
52 | bind $tl <Escape> [list destroy $tl] | |
53 | pack $tl.label $tl.entry $tl.ok -side left -padx 2 -pady 2 | |
54 | } | |
55 | ||
56 | proc entry-on-change {widget what} { | |
57 | bind $widget <Return> $what | |
58 | bind $widget <FocusOut> $what | |
59 | } | |
60 | ||
044c8fbc | 61 | if {$tk_version >= 8.4} { |
62 | set entry_readonly readonly | |
63 | } else { | |
64 | set entry_readonly disabled | |
65 | } | |
66 | ||
67 | #----- About box ------------------------------------------------------------ | |
68 | ||
69 | proc about-box {} { | |
70 | if {[winfo exists .about]} { | |
71 | # raise .about | |
72 | return | |
73 | } | |
74 | toplevel .about | |
75 | wm title .about "About elite-editor" | |
76 | label .about.rocl -font {helvetica 16 bold} -justify left \ | |
77 | -text "Right On Command-Line" | |
78 | label .about.ee -font {helvetica 10 italic} -justify left \ | |
79 | -text "elite-editor" | |
80 | label .about.gpl -font {helvetica 8 normal} -justify left -text { | |
81 | Copyright (c) 2003 Mark Wooding | |
82 | Partly based on code by Ian Bell and Christian Pinder | |
83 | ||
84 | This program is free software; you can redistribute it and/or modify | |
85 | it under the terms of the GNU General Public License as published by | |
86 | the Free Software Foundation; either version 2 of the License, or | |
87 | (at your option) any later version. | |
88 | ||
89 | This program is distributed in the hope that it will be useful, | |
90 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
91 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
92 | GNU General Public License for more details. | |
93 | ||
94 | You should have received a copy of the GNU General Public License | |
95 | along with this program; if not, write to the Free Software Foundation, | |
96 | Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
97 | } | |
98 | button .about.dismiss -text "Dismiss" -command { destroy .about } | |
99 | pack .about.rocl -padx 4 -side top -anchor w | |
100 | pack .about.ee -padx 4 -side top -anchor e | |
101 | pack .about.gpl -padx 24 -side top -anchor center -expand 1 | |
102 | pack .about.dismiss -side top -padx 4 -pady 4 -anchor e | |
103 | } | |
104 | ||
105 | proc help-menu {m} { | |
106 | menu $m.help | |
107 | $m.help add command -label "About..." -command about-box | |
108 | $m add cascade -label "Help" -menu $m.help | |
109 | } | |
110 | ||
1304202a | 111 | #----- Map editing machinery ------------------------------------------------ |
112 | ||
113 | tab col red orange yellow green blue magenta violet white | |
114 | ||
115 | set seq 0 | |
116 | set nwin 0 | |
117 | array set default {scale 15 colourby off connect 0} | |
118 | ||
119 | proc set-scale {seq sc} { | |
1775d50f | 120 | if {![regexp {^\d+$} $sc]} { |
1304202a | 121 | moan "bad scale factor `$sc'" |
122 | return 1 | |
123 | } | |
124 | map-setscale $seq $sc | |
125 | return 0 | |
126 | } | |
127 | ||
128 | proc new-view {gs} { | |
129 | set g [parse-galaxy-spec $gs] | |
130 | if {![llength $g]} { | |
131 | moan "bad galaxy spec `$gs'" | |
132 | return 1 | |
133 | } | |
134 | destructure {ng g} $g | |
135 | map-new $ng $g | |
136 | return 0 | |
137 | } | |
138 | ||
1775d50f | 139 | proc set-hyperspace-range {seq f} { |
140 | if {![regexp {^\d+(\.\d+)?$} $f]} { | |
141 | moan "bad hyperspace range `$f'" | |
142 | return 1 | |
143 | } | |
144 | map-set-fuel $seq [expr {$f * 10}] | |
145 | return 0 | |
146 | } | |
147 | ||
1304202a | 148 | # --- Colour-coding planets --- |
149 | ||
150 | proc colour-by {seq} { | |
151 | upvar \#0 map-$seq map | |
152 | set tl .map-$seq | |
153 | global col | |
154 | switch -exact -- $map(colourby) { | |
378b623c | 155 | off { |
1304202a | 156 | foreach-world $map(galaxy) p { |
157 | $tl.map itemconfigure $p(seed) -fill white -outline white | |
158 | } | |
159 | } | |
160 | economy { | |
161 | foreach-world $map(galaxy) p { | |
162 | set c [expr {7 - $p(economy)}] | |
163 | $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c) | |
164 | } | |
165 | } | |
166 | government { | |
167 | foreach-world $map(galaxy) p { | |
168 | set c $p(government) | |
169 | $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c) | |
170 | } | |
171 | } | |
172 | techlevel { | |
173 | foreach-world $map(galaxy) p { | |
174 | set c [expr {$p(techlevel) / 2}] | |
175 | $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c) | |
176 | } | |
177 | } | |
178 | } | |
179 | } | |
180 | ||
181 | proc set-colour-by {seq} { | |
182 | global default | |
183 | upvar \#0 map-$seq map | |
184 | set default(colourby) $map(colourby) | |
185 | colour-by $seq | |
186 | } | |
187 | ||
188 | # --- Connectivity maps --- | |
189 | ||
190 | proc show-connectivity {seq} { | |
191 | upvar \#0 map-$seq map | |
1775d50f | 192 | upvar \#0 adj-$map(galaxy)-$map(fuel) adj |
1304202a | 193 | upvar \#0 ww-$map(galaxy) ww |
194 | set tl .map-$seq | |
195 | $tl.map delete conn | |
196 | if {!$map(connect)} { | |
b48b0bfb | 197 | show-path $seq |
1304202a | 198 | return |
199 | } | |
b48b0bfb | 200 | if {![info exists adj]} { elite-adjacency adj $ww $map(fuel) } |
1304202a | 201 | foreach {s x y} $ww { |
202 | set done($s) 1 | |
203 | foreach {ss xx yy} $adj($s) { | |
204 | if {[info exists done($ss)]} { continue } | |
205 | $tl.map create line \ | |
206 | [to-map $seq $x] [to-map $seq $y] \ | |
207 | [to-map $seq $xx] [to-map $seq $yy] \ | |
208 | -fill darkblue -tags conn | |
209 | } | |
210 | } | |
211 | $tl.map lower conn sep | |
1775d50f | 212 | show-path $seq |
1304202a | 213 | } |
214 | ||
215 | proc set-connectivity {seq} { | |
216 | global default | |
217 | upvar \#0 map-$seq map | |
218 | set default(connect) $map(connect) | |
219 | show-connectivity $seq | |
220 | } | |
221 | ||
222 | # --- Planet names --- | |
223 | ||
224 | proc show-names {seq} { | |
225 | upvar \#0 map-$seq map | |
226 | set tl .map-$seq | |
227 | $tl.map delete names | |
228 | if {!$map(names)} { | |
229 | return | |
230 | } | |
231 | foreach-world $map(galaxy) p { | |
232 | set anc nw | |
233 | set px [to-map $seq $p(x)] | |
234 | set py [to-map $seq $p(y)] | |
235 | set offx [expr {$px + [to-map $seq 2]}] | |
236 | set offy [expr {$py + [to-map $seq 2]}] | |
237 | set what {} | |
238 | foreach {a ox oy dx x y xx yy} { | |
239 | nw 2 2 0 0 0 30 10 | |
240 | nw 2 2 -10 0 0 30 10 | |
241 | sw 2 -2 0 0 -10 30 0 | |
242 | sw 2 -2 -10 0 -10 30 0 | |
243 | se -2 -2 0 -30 -10 0 0 | |
244 | se -2 -2 10 -30 -10 0 0 | |
245 | ne -2 2 0 -30 0 0 10 | |
246 | ne -2 2 10 -30 0 0 10 | |
247 | } { | |
248 | set ox [expr {$px + [to-map $seq $ox] + $dx}] | |
249 | set oy [expr {$py + [to-map $seq $oy]}] | |
250 | if {![llength [$tl.map find overlapping \ | |
251 | [expr {$ox + $x}] [expr {$ox + $y}] \ | |
252 | [expr {$ox + $xx}] [expr {$ox + $yy}]]]} { | |
253 | set offx $ox | |
254 | set offy $oy | |
255 | set anc $a | |
256 | break | |
257 | } | |
258 | lappend what $a | |
259 | } | |
260 | $tl.map create text $offx $offy -text $p(name) \ | |
261 | -fill white -anchor $a -tags names | |
262 | } | |
263 | } | |
264 | ||
265 | proc set-names {seq} { | |
266 | global default | |
267 | upvar \#0 map-$seq map | |
268 | set default(names) $map(names) | |
269 | show-names $seq | |
270 | } | |
271 | ||
272 | # --- Shortest path handling --- | |
273 | ||
274 | proc show-path {seq} { | |
275 | upvar \#0 map-$seq map | |
276 | set tl .map-$seq | |
277 | $tl.map delete path | |
278 | if {![info exists map(path)]} { return } | |
279 | foreach n $map(path) { | |
280 | elite-worldinfo p $n | |
281 | if {[info exists x]} { | |
282 | $tl.map create line \ | |
283 | [to-map $seq $x] [to-map $seq $y] \ | |
284 | [to-map $seq $p(x)] [to-map $seq $p(y)] \ | |
285 | -fill darkorange -tags path | |
286 | } | |
287 | set x $p(x) | |
288 | set y $p(y) | |
289 | } | |
290 | $tl.map lower path sep | |
291 | } | |
292 | ||
1775d50f | 293 | proc hide-path {seq} { |
294 | upvar \#0 map-$seq map | |
295 | set tl .map-$seq | |
296 | $tl.map delete path | |
297 | unset map(path) | |
b48b0bfb | 298 | foreach i {2 3 11} { |
299 | $tl.menu.path entryconfigure $i -state disabled | |
300 | } | |
301 | } | |
302 | ||
378b623c | 303 | proc path-to-text {seq} { |
b48b0bfb | 304 | upvar \#0 map-$seq map |
305 | set t {} | |
306 | foreach n $map(path) { | |
307 | append t [world-summary $n] "\n" | |
308 | } | |
309 | return $t | |
1775d50f | 310 | } |
311 | ||
b48b0bfb | 312 | proc save-path {seq} { |
313 | set file [tk_getSaveFile -initialfile "path" -title "Save path"] | |
314 | if {[string equal $file ""]} { return } | |
315 | if {[catch { write-file $file [path-to-text $seq] auto } err]} { | |
316 | moan $err | |
317 | } | |
318 | } | |
319 | ||
320 | proc list-path {seq} { | |
321 | upvar \#0 map-$seq map | |
322 | set tl .map-$seq.path | |
323 | if {[winfo exists $tl]} { | |
324 | # raise $tl | |
325 | } else { | |
326 | toplevel $tl | |
327 | wm title $tl "Path listing" | |
328 | scrollbar $tl.hscr -orient horizontal -command [list $tl.text xview] | |
329 | scrollbar $tl.vscr -orient vertical -command [list $tl.text yview] | |
330 | text $tl.text -wrap none -width 80 -height 20 \ | |
331 | -xscrollcommand [list $tl.hscr set] \ | |
332 | -yscrollcommand [list $tl.vscr set] | |
333 | grid configure $tl.text -row 0 -column 0 -sticky nsew | |
334 | grid configure $tl.hscr -row 1 -column 0 -sticky ew | |
335 | grid configure $tl.vscr -row 0 -column 1 -sticky ns | |
336 | grid rowconfigure $tl 0 -weight 1 | |
337 | grid columnconfigure $tl 0 -weight 1 | |
338 | } | |
339 | $tl.text configure -state normal | |
340 | $tl.text delete 1.0 end | |
341 | $tl.text insert end [path-to-text $seq] | |
342 | $tl.text configure -state disabled | |
378b623c | 343 | } |
b48b0bfb | 344 | |
345 | proc load-path {seq} { | |
346 | upvar \#0 map-$seq map | |
347 | set tl .map-$seq | |
348 | set file [tk_getOpenFile -title "Load path"] | |
044c8fbc | 349 | if {[string equal $file ""]} { return } |
b48b0bfb | 350 | if {[catch { |
351 | set f [open $file] | |
352 | set path {} | |
353 | while {[gets $f line] >= 0} { | |
354 | if {[regexp {^\s*(\#|$)} $line]} { continue } | |
355 | if {[regexp {\m[0-9a-f]{12}\M} $line p]} { | |
356 | } else { | |
357 | set p [parse-planet-spec $map(galaxy) [lindex $line 0]] | |
358 | if {[string equal $p ""]} { | |
359 | error "unrecognized path line `$line'" | |
360 | } | |
361 | } | |
362 | lappend path $p | |
363 | } | |
364 | if {![in-galaxy-p $map(galaxy) $path]} { | |
365 | error "not all worlds in this galaxy" | |
366 | } | |
367 | close $f | |
368 | } err]} { | |
369 | catch { close $f } | |
370 | moan $err | |
371 | return | |
372 | } | |
373 | set map(path) $path | |
374 | foreach i {2 3 11} { | |
375 | $tl.menu.path entryconfigure $i -state normal | |
376 | } | |
377 | show-path $seq | |
378b623c | 378 | } |
b48b0bfb | 379 | |
1304202a | 380 | proc show-shortest-path {seq weight} { |
381 | upvar \#0 map-$seq map | |
1775d50f | 382 | upvar \#0 adj-$map(galaxy)-$map(fuel) adj |
1304202a | 383 | upvar \#0 ww-$map(galaxy) ww |
384 | set tl .map-$seq | |
385 | $tl.map delete path | |
386 | if {[info exists map(path)]} { unset map(path) } | |
387 | if {![info exists map(select)] || ![info exists map(dest)]} { | |
388 | moan "no source or destination set" | |
389 | return | |
390 | } | |
b48b0bfb | 391 | if {![info exists adj]} { elite-adjacency adj $ww $map(fuel) } |
1304202a | 392 | destructure {path weight} \ |
393 | [shortest-path adj $map(select) $map(dest) $weight] | |
394 | if {![llength $path]} { | |
395 | moan "no path exists" | |
396 | return | |
397 | } | |
398 | set map(path) $path | |
b48b0bfb | 399 | foreach i {2 3 11} { |
400 | $tl.menu.path entryconfigure $i -state normal | |
401 | } | |
1304202a | 402 | show-path $seq |
403 | } | |
404 | ||
405 | # --- Planet information box --- | |
406 | ||
1c647046 | 407 | proc show-worldinfo {tag p} { |
044c8fbc | 408 | global economy government entry_readonly |
1304202a | 409 | upvar \#0 info-$tag info |
410 | set tl .world-info-$tag | |
1c647046 | 411 | elite-worldinfo info $p |
1304202a | 412 | if {[winfo exists $tl]} { |
413 | # raise $tl | |
414 | } else { | |
415 | toplevel $tl | |
416 | set r 0 | |
417 | foreach {item label} { | |
418 | name "Name" | |
419 | seed "Seed" | |
420 | position "Position" | |
421 | eco-name "Economy" | |
422 | gov-name "Government" | |
423 | techlevel "Tech. level" | |
424 | pop-str "Population" | |
425 | prod-str "Productivity" | |
426 | radius-km "Radius" | |
427 | } { | |
044c8fbc | 428 | label $tl.l-$item -text "$label:" -justify right |
429 | entry $tl.$item -textvariable info-${tag}($item) -state $entry_readonly | |
430 | grid configure $tl.l-$item -row $r -column 0 -sticky e -padx 1 -pady 1 | |
431 | grid configure $tl.$item -row $r -column 1 -columnspan 2 -sticky we -padx 1 -pady 1 | |
1304202a | 432 | incr r |
433 | } | |
434 | scrollbar $tl.descscr -orient vertical -command [list $tl.desc yview] | |
435 | text $tl.desc -wrap word -yscrollcommand [list $tl.descscr set] \ | |
436 | -width 40 -height 4 | |
437 | grid configure $tl.desc -row $r -column 0 -columnspan 2 -sticky nsew | |
438 | grid configure $tl.descscr -row $r -column 2 -sticky ns | |
439 | grid columnconfigure $tl 1 -weight 1 | |
440 | grid rowconfigure $tl $r -weight 1 | |
441 | } | |
442 | wm title $tl "Info: $info(name)" | |
443 | set info(position) "$info(x), $info(y)" | |
444 | set info(eco-name) $economy($info(economy)) | |
445 | set info(gov-name) $government($info(government)) | |
446 | set info(pop-str) \ | |
447 | [format "%s billion (%s)" \ | |
448 | [expr {$info(population)/10}] \ | |
449 | $info(inhabitants)] | |
450 | set info(prod-str) [format "%d M Cr" $info(productivity)] | |
451 | set info(radius-km) [format "%d km" $info(radius)] | |
452 | $tl.desc configure -state normal | |
453 | $tl.desc delete 1.0 end | |
454 | $tl.desc insert end $info(description) | |
455 | $tl.desc configure -state disabled | |
456 | } | |
457 | ||
1c647046 | 458 | proc do-getinfo {tag seq x y} { |
459 | show-worldinfo $tag [find-click $seq $x $y] | |
460 | } | |
461 | ||
1304202a | 462 | # --- Messing with selections --- |
463 | ||
464 | proc to-ly {seq x} { | |
465 | upvar \#0 map-$seq map | |
466 | return [expr {$x * $map(scale) / 10.0}] | |
467 | } | |
468 | ||
469 | proc to-map {seq x} { | |
470 | upvar \#0 map-$seq map | |
471 | return [expr {$x * 10 / $map(scale)}] | |
472 | } | |
473 | ||
474 | proc find-click {seq x y} { | |
475 | upvar \#0 map-$seq map | |
476 | upvar \#0 ww-$map(galaxy) ww | |
477 | set tl .map-$seq | |
478 | ||
479 | set x [to-ly $seq [$tl.map canvasx $x]] | |
480 | set y [to-ly $seq [$tl.map canvasy $y]] | |
481 | set best 100000 | |
482 | foreach {seed px py} $ww { | |
483 | set dx [expr {$x - $px}] | |
484 | set dy [expr {$y - $py}] | |
485 | set d [expr {$dx * $dx + $dy * $dy}] | |
486 | if {$d < $best} { | |
487 | set best $d | |
488 | set p $seed | |
489 | } | |
490 | } | |
491 | $tl.map delete here | |
492 | ||
493 | if 0 { | |
494 | $tl.map create line \ | |
495 | [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] - 5}] \ | |
496 | [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] + 5}] \ | |
497 | -tags here -fill green | |
498 | $tl.map create line \ | |
499 | [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] + 5}] \ | |
500 | [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] - 5}] \ | |
501 | -tags here -fill green | |
502 | } | |
503 | return $p | |
504 | } | |
505 | ||
506 | proc destination-world {seq} { | |
507 | upvar \#0 map-$seq map | |
508 | set tl .map-$seq | |
509 | if {![info exists map(dest)]} { return } | |
510 | $tl.map delete dest | |
511 | elite-worldinfo p $map(dest) | |
512 | set px [to-map $seq $p(x)] | |
513 | set py [to-map $seq $p(y)] | |
514 | $tl.map create line [expr {$px - 10}] $py [expr {$px + 10}] $py \ | |
515 | -tags {dest cross} -fill darkorange | |
516 | $tl.map create line $px [expr {$py - 10}] $px [expr {$py + 10}] \ | |
517 | -tags {dest cross} -fill darkorange | |
518 | $tl.map raise dest sel | |
519 | } | |
520 | ||
521 | proc select-world {seq} { | |
522 | upvar \#0 map-$seq map | |
523 | set tl .map-$seq | |
524 | if {![info exists map(select)]} { return } | |
525 | $tl.map delete sel dest | |
526 | elite-worldinfo p $map(select) | |
527 | set r [to-map $seq $map(fuel)] | |
528 | set px [to-map $seq $p(x)] | |
529 | set py [to-map $seq $p(y)] | |
530 | $tl.map create line [expr {$px - 20}] $py [expr {$px + 20}] $py \ | |
531 | -tags {sel cross} -fill darkred | |
532 | $tl.map create line $px [expr {$py - 20}] $px [expr {$py + 20}] \ | |
533 | -tags {sel cross} -fill darkred | |
534 | $tl.map create oval \ | |
535 | [expr {$px - $r}] [expr {$py - $r}] \ | |
536 | [expr {$px + $r}] [expr {$py + $r}] \ | |
537 | -tags {sel radius} -outline darkgreen | |
538 | $tl.map raise sel sep | |
539 | } | |
540 | ||
541 | proc select-byname {seq name seed proc} { | |
542 | upvar \#0 map-$seq map | |
543 | set p [parse-planet-spec $map(galaxy) $map($name)] | |
544 | if {![string equal $p ""] && [in-galaxy-p $map(galaxy) $p]} { | |
545 | $proc $seq $p | |
1c647046 | 546 | return 1 |
1304202a | 547 | } elseif {[info exists map($seed)]} { |
548 | bell | |
549 | set map($name) [worldname $map($seed)] | |
1c647046 | 550 | return 0 |
1304202a | 551 | } else { |
552 | bell | |
553 | set map($name) "" | |
1c647046 | 554 | return 0 |
555 | } | |
556 | } | |
557 | ||
558 | proc info-byname {seq name seed proc} { | |
559 | upvar \#0 map-$seq map | |
560 | if {[select-byname $seq $name $seed $proc]} { | |
561 | show-worldinfo $seed $map($seed) | |
1304202a | 562 | } |
563 | } | |
564 | ||
565 | proc set-selection {seq p} { | |
566 | upvar \#0 map-$seq map | |
044c8fbc | 567 | set tl .map-$seq |
1c647046 | 568 | if {[info exists map(cmdr)]} { |
569 | set p [cmdr-set-world $map(cmdr) $p] | |
570 | } | |
1304202a | 571 | set map(select) $p |
572 | elite-worldinfo pp $p | |
573 | select-world $seq | |
574 | set map(sel-name) $pp(name) | |
575 | if {![info exists map(dest)]} { | |
576 | set-destination $seq $p | |
577 | } else { | |
578 | set-destination $seq $map(dest) | |
579 | } | |
044c8fbc | 580 | foreach i {5 6 7 8 9} { |
581 | $tl.menu.path entryconfigure $i -state normal | |
582 | } | |
378b623c | 583 | } |
1304202a | 584 | |
585 | proc do-select {seq x y} { | |
586 | set-selection $seq [find-click $seq $x $y] | |
587 | } | |
588 | ||
589 | proc set-destination {seq p} { | |
590 | upvar \#0 map-$seq map | |
591 | if {![info exists map(select)]} { | |
592 | set-selection $seq $p | |
593 | } else { | |
594 | elite-worldinfo ps $map(select) | |
595 | elite-worldinfo pd $p | |
596 | set map(dest) $p | |
597 | destination-world $seq | |
598 | set map(dest-name) $pd(name) | |
599 | set map(distance) \ | |
600 | [format "%.1f" \ | |
b48b0bfb | 601 | [expr {[elite-distance $ps(x) $ps(y) $pd(x) $pd(y)] / 10.0}]] |
1304202a | 602 | } |
603 | } | |
604 | ||
605 | proc do-destination {seq x y} { | |
606 | set-destination $seq [find-click $seq $x $y] | |
607 | } | |
608 | ||
609 | # --- Redrawing a map --- | |
610 | ||
611 | proc map-populate {seq} { | |
612 | global colourby-$seq connect-$seq | |
613 | upvar \#0 map-$seq map | |
614 | upvar \#0 ww-$map(galaxy) ww | |
615 | set tl .map-$seq | |
616 | ||
617 | set scale $map(scale) | |
618 | $tl.map delete all | |
619 | $tl.map create line -10000 -20000 -10000 -20000 -fill black -tags sep | |
b48b0bfb | 620 | if {![info exists ww]} { set ww [elite-galaxylist $map(galaxy)] } |
1304202a | 621 | foreach {seed x y} $ww { |
622 | elite-worldinfo p $seed | |
623 | set x [expr {$x * 10 / $map(scale)}] | |
624 | set y [expr {$y * 10 / $map(scale)}] | |
625 | set r [expr {$p(radius) / (500 * $map(scale))}] | |
626 | $tl.map create oval \ | |
627 | [expr {$x - $r}] [expr {$y - $r}] \ | |
628 | [expr {$x + $r}] [expr {$y + $r}] \ | |
629 | -fill white -outline white \ | |
630 | -tags [list $seed world] | |
631 | } | |
632 | ||
633 | colour-by $seq | |
634 | show-connectivity $seq | |
1304202a | 635 | show-names $seq |
636 | select-world $seq | |
637 | destination-world $seq | |
638 | } | |
639 | ||
640 | # --- Miscellaneous stuff --- | |
641 | ||
642 | proc map-setscale {seq sc} { | |
643 | global default | |
644 | upvar \#0 map-$seq map | |
645 | set tl .map-$seq | |
646 | set wd [expr {10240/$sc + 40}] | |
647 | set ht [expr {5120/$sc} + 10] | |
648 | $tl.map configure -scrollregion [list -40 -10 $wd $ht] | |
649 | set map(scale) $sc | |
650 | set default(scale) $sc | |
651 | map-populate $seq | |
652 | } | |
653 | ||
654 | proc map-destroy {seq} { | |
655 | global nwin | |
656 | upvar \#0 map-$seq map | |
657 | if {[info exists map(cmdr)]} { | |
658 | upvar \#0 cmdr-$map(cmdr) cmdr | |
659 | unset cmdr(map) | |
660 | } | |
661 | unset map | |
662 | destroy .map-$seq .set-scale-$seq | |
663 | incr nwin -1 | |
664 | if {!$nwin} { exit } | |
665 | } | |
666 | ||
667 | proc map-attach-cmdr {seq cmdr} { | |
668 | upvar \#0 map-$seq map | |
669 | set map(cmdr) $cmdr | |
670 | map-set-title $seq | |
1775d50f | 671 | .map-$seq.menu.view entryconfigure 3 -state disabled |
1304202a | 672 | } |
673 | ||
674 | proc map-set-title {seq} { | |
675 | upvar \#0 map-$seq map | |
676 | set tl .map-$seq | |
677 | set t "Galaxy $map(galaxy-num)" | |
678 | if {[info exists map(cmdr)]} { | |
679 | append t " (commander [cmdr-name $map(cmdr)])" | |
680 | } | |
681 | wm title $tl $t | |
682 | } | |
683 | ||
684 | proc map-set-galaxy {seq ng g} { | |
378b623c | 685 | upvar \#0 map-$seq map |
1304202a | 686 | if {[string equal $g $map(galaxy)]} { return } |
687 | set map(galaxy-num) $ng | |
688 | map-set-title $seq | |
689 | set map(galaxy) $g | |
690 | map-populate $seq | |
691 | foreach i {select select-name dest dest-name} { | |
692 | catch { unset map($i) } | |
693 | } | |
694 | } | |
695 | ||
696 | proc map-set-fuel {seq qty} { | |
697 | upvar \#0 map-$seq map | |
f78dd4dc | 698 | set map(fuel) [expr {int($qty)}] |
1304202a | 699 | select-world $seq |
1775d50f | 700 | show-connectivity $seq |
1304202a | 701 | } |
702 | ||
703 | # --- Making a new map window --- | |
704 | ||
705 | proc map-new {ng g} { | |
044c8fbc | 706 | global seq nwin default entry_readonly |
1304202a | 707 | incr seq |
708 | incr nwin | |
709 | upvar \#0 map-$seq map | |
710 | ||
711 | array set map [array get default] | |
712 | set sc $map(scale) | |
713 | set map(galaxy) $g | |
714 | set map(galaxy-num) $ng | |
715 | set tl [toplevel .map-$seq] | |
716 | set wd [expr {10240/$sc + 80}] | |
717 | set ht [expr {5120/$sc + 20}] | |
718 | set vwd $wd; if {$vwd > 1120} { set vwd 768 } | |
719 | set vht $ht; if {$vht > 1024} { set vht 768 } | |
720 | set map(fuel) 70 | |
721 | canvas $tl.map \ | |
722 | -background black \ | |
723 | -xscrollcommand [list $tl.hscr set] \ | |
724 | -yscrollcommand [list $tl.vscr set] \ | |
725 | -width $vwd -height $vht | |
726 | frame $tl.info | |
044c8fbc | 727 | label $tl.info.lhome -text "Home:" |
1304202a | 728 | entry $tl.info.home -textvariable map-${seq}(sel-name) |
044c8fbc | 729 | label $tl.info.ldest -text " Destination:" |
1304202a | 730 | entry $tl.info.dest -textvariable map-${seq}(dest-name) |
044c8fbc | 731 | label $tl.info.ldist -text " Distance:" |
1304202a | 732 | entry $tl.info.dist -textvariable map-${seq}(distance) \ |
044c8fbc | 733 | -state $entry_readonly -width 6 |
1304202a | 734 | pack \ |
735 | $tl.info.lhome $tl.info.home \ | |
736 | $tl.info.ldest $tl.info.dest \ | |
737 | $tl.info.ldist $tl.info.dist \ | |
044c8fbc | 738 | -side left -pady 2 |
378b623c | 739 | |
1304202a | 740 | scrollbar $tl.hscr -orient horizontal \ |
741 | -command [list $tl.map xview] | |
742 | scrollbar $tl.vscr -orient vertical \ | |
743 | -command [list $tl.map yview] | |
744 | menu $tl.menu | |
745 | menu $tl.menu.file | |
746 | $tl.menu.file add command -label "New commander" -command cmdr-new | |
747 | $tl.menu.file add command -label "Load commander..." \ | |
748 | -command { cmdr-loadfile } | |
749 | $tl.menu.file add separator | |
750 | $tl.menu.file add command -label "Close" -command [list map-destroy $seq] | |
751 | $tl.menu.file add command -label "Quit" -command { exit } | |
752 | $tl.menu add cascade -label "File" -menu $tl.menu.file | |
753 | menu $tl.menu.view | |
754 | $tl.menu.view add command -label "New map..." \ | |
1775d50f | 755 | -command [list get-line .new-view "New map" "Galaxy" $ng new-view] |
1304202a | 756 | $tl.menu.view add command -label "Set scale..." \ |
757 | -command [concat get-line .set-scale-$seq {"Set scale"} "Scale" \ | |
758 | \[set map-${seq}(scale)\] [list [list set-scale $seq]]] | |
1775d50f | 759 | $tl.menu.view add command -label "Set hyperspace range..." \ |
760 | -command [concat get-line .set-fuel-$seq {"Set hyperspace range"} \ | |
761 | {"Hyperspace range"} \[expr \[set map-${seq}(fuel)\]/10.0\] \ | |
762 | [list [list set-hyperspace-range $seq]]] | |
1304202a | 763 | $tl.menu.view add separator |
764 | $tl.menu.view add radiobutton -label "Off" \ | |
765 | -variable map-${seq}(colourby) -value off \ | |
766 | -command [list set-colour-by $seq] | |
767 | $tl.menu.view add radiobutton -label "Economy" \ | |
768 | -variable map-${seq}(colourby) -value economy \ | |
769 | -command [list set-colour-by $seq] | |
770 | $tl.menu.view add radiobutton -label "Government" \ | |
771 | -variable map-${seq}(colourby) -value government \ | |
772 | -command [list set-colour-by $seq] | |
773 | $tl.menu.view add radiobutton -label "Tech level" \ | |
774 | -variable map-${seq}(colourby) -value techlevel \ | |
775 | -command [list set-colour-by $seq] | |
776 | $tl.menu.view add separator | |
777 | $tl.menu.view add checkbutton -label "Connectivity" \ | |
778 | -variable map-${seq}(connect) \ | |
779 | -command [list set-connectivity $seq] | |
780 | $tl.menu.view add checkbutton -label "Planet names" \ | |
781 | -variable map-${seq}(names) \ | |
782 | -command [list set-names $seq] | |
783 | $tl.menu add cascade -label "View" -menu $tl.menu.view | |
784 | menu $tl.menu.path | |
b48b0bfb | 785 | $tl.menu.path add command -label "Load path..." \ |
786 | -command [list load-path $seq] | |
787 | $tl.menu.path add command -label "Save path..." -state disabled \ | |
378b623c | 788 | -command [list save-path $seq] |
b48b0bfb | 789 | $tl.menu.path add command -label "List path..." -state disabled \ |
790 | -command [list list-path $seq] | |
791 | $tl.menu.path add separator | |
044c8fbc | 792 | $tl.menu.path add command -label "Minimize hops" -state disabled \ |
1304202a | 793 | -command [list show-shortest-path $seq weight-hops] |
044c8fbc | 794 | $tl.menu.path add command -label "Minimize fuel" -state disabled \ |
1304202a | 795 | -command [list show-shortest-path $seq weight-fuel] |
044c8fbc | 796 | $tl.menu.path add command -label "Maximize safety" -state disabled \ |
1304202a | 797 | -command [list show-shortest-path $seq weight-safety] |
044c8fbc | 798 | $tl.menu.path add command -label "Minimize safety" -state disabled \ |
1304202a | 799 | -command [list show-shortest-path $seq weight-encounters] |
044c8fbc | 800 | $tl.menu.path add command -label "Maximize trading" -state disabled \ |
1304202a | 801 | -command [list show-shortest-path $seq weight-trading] |
1775d50f | 802 | $tl.menu.path add separator |
803 | $tl.menu.path add command -label "Hide path" -state disabled \ | |
804 | -command [list hide-path $seq] | |
b48b0bfb | 805 | $tl.menu add cascade -label "Path" -menu $tl.menu.path |
044c8fbc | 806 | help-menu $tl.menu |
1304202a | 807 | $tl configure -menu $tl.menu |
808 | ||
809 | wm protocol $tl WM_DELETE_WINDOW [list map-destroy $seq] | |
810 | ||
811 | grid $tl.map -column 0 -row 0 -sticky nsew | |
812 | grid $tl.hscr -column 0 -row 1 -sticky ew | |
813 | grid $tl.vscr -column 1 -row 0 -sticky ns | |
814 | grid rowconfigure $tl 0 -weight 1 | |
815 | grid columnconfigure $tl 0 -weight 1 | |
816 | grid $tl.info -column 0 -columnspan 2 -row 2 -sticky ew | |
817 | ||
818 | bind $tl.map <3> [list do-select $seq %x %y] | |
819 | bind $tl.map <1> [list do-destination $seq %x %y] | |
820 | bind $tl.map <Double-1> [list do-getinfo dest $seq %x %y] | |
1c647046 | 821 | bind $tl.map <Double-3> [list do-getinfo select $seq %x %y] |
1304202a | 822 | |
823 | map-set-title $seq | |
824 | entry-on-change $tl.info.home \ | |
825 | [list select-byname $seq sel-name select set-selection] | |
826 | entry-on-change $tl.info.dest \ | |
827 | [list select-byname $seq dest-name dest set-destination] | |
1c647046 | 828 | bind $tl.info.home <Control-Return> \ |
829 | [list info-byname $seq sel-name select set-selection] | |
830 | bind $tl.info.dest <Control-Return> \ | |
831 | [list info-byname $seq dest-name dest set-destination] | |
1304202a | 832 | map-setscale $seq $sc |
833 | return $seq | |
834 | } | |
835 | ||
836 | #----- Commander editing machinery ------------------------------------------ | |
837 | ||
838 | # --- Validation and factor-of-10 fixing --- | |
839 | ||
840 | proc fix-tenth {tag arrvar full op} { | |
841 | upvar \#0 $arrvar arr | |
842 | catch { set arr($tag) [format "%d" [expr {int($arr($full) * 10)}]] } | |
843 | } | |
844 | ||
845 | proc numericp {min max n} { | |
846 | if {[catch { expr {$n + 0} }]} { return 0 } | |
847 | if {$n < $min || $n > $max} { return 0 } | |
848 | return 1 | |
849 | } | |
850 | ||
851 | proc integerp {min max n} { | |
852 | if {[catch { incr n 0}]} { return 0 } | |
853 | if {$n < $min || $n > $max} { return 0 } | |
854 | return 1 | |
855 | } | |
856 | ||
857 | proc galaxyp {s} { | |
858 | if {![regexp {^[0-9a-fA-F]{12}$} $s]} { return 0 } | |
859 | return 1 | |
378b623c | 860 | } |
1304202a | 861 | |
862 | proc cmdr-do-validate {seq widget check value} { | |
863 | upvar \#0 cmdr-$seq cmdr | |
864 | if {$cmdr(ok/$widget)} { incr cmdr(bogus) } | |
865 | if {![eval $check [list $value]]} { | |
866 | set cmdr(ok/$widget) 0 | |
867 | $widget configure -foreground red | |
868 | } else { | |
869 | set cmdr(ok/$widget) 1 | |
870 | $widget configure -foreground black | |
871 | incr cmdr(bogus) -1 | |
872 | } | |
873 | return 1 | |
874 | } | |
875 | ||
876 | proc cmdr-validate-widget {seq widget check} { | |
877 | upvar \#0 cmdr-$seq cmdr | |
878 | set cmdr(ok/$widget) 1 | |
879 | $widget configure -validate key \ | |
880 | -vcmd [list cmdr-do-validate $seq $widget $check %P] | |
881 | } | |
882 | ||
883 | # --- Cargo window handling --- | |
884 | ||
885 | proc cmdr-set-fluc {seq} { | |
886 | upvar \#0 cmdr-$seq cmdr | |
887 | global products | |
888 | set tl .cmdr-$seq.cargo-qty | |
889 | if {!$cmdr(ok/$tl.fluc)} { bell; return } | |
890 | elite-market m $cmdr(world-seed) $cmdr(market-fluc) | |
891 | foreach {i .} $products { | |
892 | set cmdr(price-$i) [format "%.1f" [expr {[lindex $m($i) 0]/10.0}]] | |
893 | } | |
894 | } | |
895 | ||
896 | proc cmdr-cargo {seq} { | |
044c8fbc | 897 | global entry_readonly |
1304202a | 898 | upvar \#0 cmdr-$seq cmdr |
899 | set tl .cmdr-$seq.cargo-qty | |
900 | if {[winfo exists $tl]} { | |
901 | # raise $tl | |
902 | return | |
903 | } | |
904 | toplevel $tl | |
905 | wm title $tl "Cargo for commander $cmdr(name)" | |
906 | global products | |
907 | set r 0 | |
044c8fbc | 908 | label $tl.l-fluc -text "Fluctuation:" -justify right |
1304202a | 909 | entry $tl.fluc -textvariable cmdr-${seq}(market-fluc) -justify right |
910 | cmdr-validate-widget $seq $tl.fluc [list integerp 0 255] | |
911 | entry-on-change $tl.fluc [list cmdr-set-fluc $seq] | |
044c8fbc | 912 | grid configure $tl.l-fluc -row $r -column 0 -sticky e -padx 1 -pady 1 |
913 | grid configure $tl.fluc -row $r -column 1 -columnspan 3 -sticky we -padx 1 -pady 1 | |
1304202a | 914 | incr r |
915 | label $tl.l-item -text "Item" -justify center | |
916 | label $tl.l-price -text "Price" -justify center | |
917 | label $tl.l-station -text "Station" -justify center | |
918 | label $tl.l-hold -text "Hold" -justify center | |
044c8fbc | 919 | grid configure $tl.l-item -row $r -column 0 -sticky e -padx 1 -pady 1 |
920 | grid configure $tl.l-price -row $r -column 1 -sticky we -padx 1 -pady 1 | |
921 | grid configure $tl.l-station -row $r -column 2 -sticky we -padx 1 -pady 1 | |
922 | grid configure $tl.l-hold -row $r -column 3 -sticky we -padx 1 -pady 1 | |
1304202a | 923 | incr r |
924 | foreach {tag label} $products { | |
044c8fbc | 925 | label $tl.l-$tag -text "$label:" -justify right |
1304202a | 926 | entry $tl.price-$tag -textvariable cmdr-${seq}(price-${tag}) \ |
044c8fbc | 927 | -justify right -state $entry_readonly -width 4 |
1304202a | 928 | foreach {pre col} {station 2 hold 3} { |
929 | entry $tl.${pre}-${tag} -textvariable cmdr-${seq}(${pre}-${tag}) \ | |
930 | -justify right -width 4 | |
931 | cmdr-validate-widget $seq $tl.${pre}-${tag} [list integerp 0 255] | |
932 | grid configure $tl.${pre}-${tag} -row $r -column $col -stick we | |
933 | } | |
044c8fbc | 934 | grid configure $tl.l-$tag -row $r -column 0 -sticky e -padx 1 -pady 1 |
935 | grid configure $tl.price-$tag -row $r -column 1 -sticky we -padx 1 -pady 1 | |
1304202a | 936 | incr r |
937 | } | |
938 | grid columnconfigure $tl 1 -weight 1 | |
939 | grid columnconfigure $tl 2 -weight 1 | |
940 | grid columnconfigure $tl 3 -weight 1 | |
941 | } | |
942 | ||
943 | # --- Miscellaneous stuff --- | |
944 | ||
945 | proc cmdr-destroy {seq} { | |
946 | upvar \#0 cmdr-$seq cmdr | |
947 | global nwin | |
948 | set tl .cmdr-$seq | |
949 | if {[info exists cmdr(map)]} { map-destroy $cmdr(map) } | |
950 | unset cmdr | |
951 | destroy $tl | |
952 | incr nwin -1 | |
953 | if {!$nwin} { exit } | |
954 | } | |
955 | ||
044c8fbc | 956 | proc cmdr-new-map {seq} { |
957 | upvar \#0 cmdr-$seq cmdr | |
958 | set tl .cmdr-$seq | |
959 | if {$cmdr(std-gal)} { | |
960 | set g $cmdr(gal-number) | |
961 | } else { | |
962 | set g $cmdr(gal-seed) | |
963 | } | |
964 | get-line .new-view "New map..." "Galaxy" $g new-view | |
965 | } | |
966 | ||
1304202a | 967 | proc cmdrdb-set {seq tag value} { |
968 | upvar \#0 cmdr-$seq cmdr | |
969 | set tl .cmdr-$seq | |
970 | set cmdr($tag) $value | |
971 | $tl.$tag configure -state disabled | |
972 | } | |
973 | ||
974 | proc cmdrdb-custom {seq tag} { | |
975 | set tl .cmdr-$seq | |
976 | $tl.$tag configure -state normal | |
977 | } | |
978 | ||
979 | proc cmdr-set-world {seq p} { | |
980 | upvar \#0 cmdr-$seq cmdr | |
1c647046 | 981 | upvar \#0 ww-$cmdr(gal-seed) ww |
1304202a | 982 | elite-worldinfo i $p |
1c647046 | 983 | set pp [nearest-planet $ww $i(x) $i(y)] |
984 | if {![string equal $p $pp]} { | |
985 | set n $i(name) | |
986 | elite-worldinfo i $pp | |
987 | moan "world $n is coincident with $i(name); substituting" | |
988 | } | |
989 | set cmdr(world-seed) $i(seed) | |
1304202a | 990 | set cmdr(world-name) $i(name) |
991 | set cmdr(world-x) [expr {$i(x)/4}] | |
992 | set cmdr(world-y) [expr {$i(y)/2}] | |
993 | cmdr-set-fluc $seq | |
1c647046 | 994 | return $i(seed) |
1304202a | 995 | } |
996 | ||
997 | proc cmdr-update-world {seq} { | |
998 | upvar \#0 cmdr-$seq cmdr | |
999 | upvar \#0 ww-$cmdr(gal-seed) ww | |
b48b0bfb | 1000 | if {![info exists ww]} { set ww [elite-galaxylist $cmdr(gal-seed)] } |
1304202a | 1001 | set tl .cmdr-$seq |
1002 | set w [nearest-planet $ww \ | |
1003 | [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]] | |
1004 | if {[info exists cmdr(map)]} { | |
1005 | if {$cmdr(std-gal)} { | |
1006 | set ng $cmdr(gal-number) | |
1007 | } else { | |
1008 | set ng $cmdr(gal-seed) | |
1009 | } | |
1010 | map-set-galaxy $cmdr(map) $ng $cmdr(gal-seed) | |
1011 | set-selection $cmdr(map) $w | |
1012 | } | |
1013 | cmdr-set-world $seq $w | |
1014 | } | |
1015 | ||
1016 | proc cmdr-set-gal-num {seq} { | |
1017 | upvar \#0 cmdr-$seq cmdr | |
1018 | set tl .cmdr-$seq | |
1019 | if {!$cmdr(ok/$tl.gal-number)} { bell; return } | |
1020 | if {$cmdr(std-gal)} { | |
1021 | set cmdr(gal-seed) [galaxy $cmdr(gal-number)] | |
1022 | cmdr-update-world $seq | |
1023 | } | |
1024 | } | |
1025 | ||
1026 | proc cmdr-std-gal {seq} { | |
1027 | upvar \#0 cmdr-$seq cmdr | |
1028 | set tl .cmdr-$seq | |
1029 | if {$cmdr(std-gal)} { | |
1030 | if {!$cmdr(ok/$tl.gal-number)} { bell; return } | |
1031 | set cmdr(gal-seed) [galaxy $cmdr(gal-number)] | |
1032 | cmdr-update-world $seq | |
1033 | $tl.gal-seed configure -state disabled | |
1034 | } else { | |
1035 | $tl.gal-seed configure -state normal | |
1036 | } | |
1037 | } | |
1038 | ||
1039 | proc cmdr-set-fuel {seq} { | |
1040 | upvar \#0 cmdr-$seq cmdr | |
1041 | if {[info exists cmdr(map)]} { | |
1042 | map-set-fuel $cmdr(map) $cmdr(fuel) | |
1043 | } | |
1044 | } | |
1045 | ||
1046 | proc cmdr-name {seq} { | |
1047 | upvar \#0 cmdr-$seq cmdr | |
1048 | return $cmdr(name) | |
1049 | } | |
1050 | ||
1051 | proc cmdr-show-map {seq} { | |
1052 | upvar \#0 cmdr-$seq cmdr | |
1053 | if {[info exists cmdr(map)]} { | |
1054 | return | |
1055 | } | |
1056 | if {$cmdr(std-gal)} { | |
1057 | set ng $cmdr(gal-number) | |
1058 | } else { | |
1059 | set ng $cmdr(gal-seed) | |
1060 | } | |
1061 | set cmdr(map) [map-new $ng $cmdr(gal-seed)] | |
1062 | map-attach-cmdr $cmdr(map) $seq | |
1063 | map-set-fuel $cmdr(map) $cmdr(fuel) | |
1064 | set-selection $cmdr(map) $cmdr(world-seed) | |
1065 | } | |
1066 | ||
1067 | proc cmdr-set-name {seq} { | |
1068 | upvar \#0 cmdr-$seq cmdr | |
1069 | if {[info exists cmdr(file)]} { | |
1070 | set cmdr(name) [string toupper [file rootname [file tail $cmdr(file)]]] | |
1071 | } else { | |
1072 | set cmdr(name) JAMESON | |
1073 | } | |
1074 | set tl .cmdr-$seq | |
1075 | wm title $tl "Commander $cmdr(name)" | |
1076 | if {[info exists cmdr(map)]} { map-set-title $cmdr(map) } | |
1077 | if {[winfo exists $tl.cargo-qty]} { | |
1078 | wm title $tl.cargo-qty "Cargo for commander $cmdr(name)" | |
1079 | } | |
1080 | } | |
1081 | ||
1082 | proc cmdr-check {seq} { | |
1083 | upvar \#0 cmdr-$seq cmdr | |
1084 | if {$cmdr(bogus)} { | |
1085 | moan("invalid values in commander data -- fix items highlighted in red") | |
1086 | return 0 | |
1087 | } | |
1088 | return 1 | |
1089 | } | |
1090 | ||
1091 | # --- Initial population --- | |
1092 | ||
1093 | proc cmdr-open {seq} { | |
1094 | upvar \#0 cmdr-$seq cmdr | |
044c8fbc | 1095 | global cmdr-$seq entry_readonly |
1304202a | 1096 | set tl .cmdr-$seq |
1097 | global nwin | |
1098 | toplevel $tl | |
1099 | set laser { | |
1100 | dropbox 255 | |
1101 | "None" 0 | |
1102 | "Pulse" 0x0f | |
1103 | "Beam" 0x8f | |
1104 | "Military" 0x97 | |
1105 | "Mining" 0x32 | |
1106 | } | |
1107 | set r 0 | |
1108 | set cmdr(bogus) 0 | |
1109 | foreach {tag label kind} [list \ | |
1110 | mission "Mission" { entry 2 255 } \ | |
74bdd262 | 1111 | score "Rating" { dropbox 65535 \ |
378b623c MW |
1112 | "Harmless" 0 \ |
1113 | "Mostly harmless" 8 \ | |
1ded87ba | 1114 | "Poor" 16 \ |
378b623c | 1115 | "Average" 32 \ |
1304202a | 1116 | "Above average" 64 \ |
378b623c MW |
1117 | "Competent" 128 \ |
1118 | "Dangerous" 512 \ | |
1119 | "Deadly" 2560 \ | |
1120 | "Elite" 6400 } \ | |
1304202a | 1121 | legal-status "Legal status" { dropbox 255 \ |
1122 | "Clean" 0 \ | |
1123 | "Offender" 1 \ | |
1124 | "Fugitive" 50 } \ | |
1125 | world "Location" where \ | |
1126 | credits "Credits" { tenth 10 429496729.5 } \ | |
1127 | fuel "Fuel" { tenth 4 25.5 } \ | |
1128 | missiles "Missiles" { entry 4 255 } \ | |
1129 | energy-unit "Energy unit" { dropbox 255 \ | |
378b623c | 1130 | "None" 0 \ |
1304202a | 1131 | "Standard" 1 \ |
1132 | "Naval" 2 } \ | |
1133 | front-laser "Front laser" $laser \ | |
044c8fbc | 1134 | rear-laser "Rear laser" $laser \ |
1304202a | 1135 | left-laser "Left laser" $laser \ |
1136 | right-laser "Right laser" $laser \ | |
1137 | ecm "ECM" toggle \ | |
1138 | fuel-scoop "Fuel scoops" toggle \ | |
1139 | energy-bomb "Energy bomb" toggle \ | |
1140 | escape-pod "Escape pod" toggle \ | |
1141 | docking-computer "Docking computers" toggle \ | |
1142 | gal-hyperdrive "Galactic hyperdrive" toggle \ | |
1143 | cargo "Cargo capacity" { entry 4 255 } \ | |
1144 | stuff "Cargo" cargo \ | |
1145 | ] { | |
1146 | switch -exact -- [lindex $kind 0] { | |
1147 | entry { | |
1148 | destructure {. wd max} $kind | |
044c8fbc | 1149 | label $tl.l-$tag -text "$label:" -justify right |
1304202a | 1150 | entry $tl.$tag -textvariable cmdr-${seq}($tag) \ |
1151 | -width $wd -justify right | |
1152 | cmdr-validate-widget $seq $tl.$tag [list integerp 0 $max] | |
044c8fbc | 1153 | grid configure $tl.l-$tag -row $r -column 0 -sticky e -padx 1 -pady 1 |
1154 | grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we -padx 1 -pady 1 | |
1304202a | 1155 | } |
1156 | tenth { | |
1157 | destructure {. wd max} $kind | |
044c8fbc | 1158 | label $tl.l-$tag -text "$label:" -justify right |
1304202a | 1159 | entry $tl.$tag -textvariable cmdr-${seq}(div-$tag) \ |
1160 | -width $wd -justify right | |
1161 | set cmdr(div-$tag) [format "%.1f" [expr {$cmdr($tag) / 10.0}]] | |
1162 | trace variable cmdr-${seq}(div-$tag) w [list fix-tenth $tag] | |
1163 | cmdr-validate-widget $seq $tl.$tag [list numericp 0 $max] | |
044c8fbc | 1164 | grid configure $tl.l-$tag -row $r -column 0 -sticky e -padx 1 -pady 1 |
1165 | grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we -padx 1 -pady 1 | |
1304202a | 1166 | } |
1167 | toggle { | |
1168 | checkbutton $tl.$tag -text $label -variable cmdr-${seq}($tag) | |
044c8fbc | 1169 | grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky w -padx 1 -pady 1 |
1304202a | 1170 | } |
1171 | dropbox { | |
044c8fbc | 1172 | label $tl.l-$tag -text "$label:" -justify right |
1304202a | 1173 | set menu $tl.m-$tag.menu |
1174 | menubutton $tl.m-$tag -textvariable cmdr-${seq}(r-${tag}) \ | |
1175 | -indicatoron 1 -relief raised -menu $menu -width 8 \ | |
1176 | -direction flush | |
1177 | entry $tl.$tag -textvariable cmdr-${seq}($tag) \ | |
1178 | -justify right -width 4 | |
1179 | cmdr-validate-widget $seq $tl.$tag [list integerp 0 [lindex $kind 1]] | |
1180 | menu $menu -tearoff 0 | |
1181 | set cmdr(r-$tag) "Custom" | |
1182 | foreach {name value} [lrange $kind 2 end] { | |
1183 | $menu add radiobutton -label "$name ($value)" \ | |
1184 | -value $name -variable cmdr-${seq}(r-$tag) \ | |
1185 | -command [list cmdrdb-set $seq $tag $value] | |
1186 | if {$cmdr($tag) == $value} { | |
1187 | set cmdr(r-$tag) $name | |
1188 | set cmdr($tag) $value | |
1189 | $tl.$tag configure -state disabled | |
1190 | } | |
1191 | } | |
1192 | $menu add radiobutton -label "Custom" \ | |
1193 | -value "Custom" -variable cmdr-${seq}(r-$tag) \ | |
1194 | -command [list cmdrdb-custom $seq $tag] | |
044c8fbc | 1195 | grid configure $tl.l-$tag -row $r -column 0 -sticky e -padx 1 -pady 1 |
1196 | grid configure $tl.m-$tag -row $r -column 1 -sticky we -padx 1 -pady 1 | |
1197 | grid configure $tl.$tag -row $r -column 2 -sticky we -padx 1 -pady 1 | |
1304202a | 1198 | } |
1199 | cargo { | |
1200 | button $tl.$tag -text $label -command [list cmdr-cargo $seq] | |
044c8fbc | 1201 | grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we -padx 1 -pady 1 |
1304202a | 1202 | } |
1203 | where { | |
044c8fbc | 1204 | label $tl.l-gal-number -text "Galaxy number:" -justify right |
1304202a | 1205 | entry $tl.gal-number -textvariable cmdr-${seq}(gal-number) \ |
1206 | -justify right -width 2 | |
1207 | cmdr-validate-widget $seq $tl.gal-number [list integerp 1 8] | |
1208 | checkbutton $tl.std-gal -text "Standard galaxy" \ | |
1209 | -variable cmdr-${seq}(std-gal) -justify left \ | |
378b623c | 1210 | -command [list cmdr-std-gal $seq] |
1304202a | 1211 | entry-on-change $tl.gal-number [list cmdr-set-gal-num $seq] |
044c8fbc | 1212 | grid configure $tl.l-gal-number -row $r -column 0 -sticky e -padx 1 -pady 1 |
1213 | grid configure $tl.std-gal -row $r -column 1 -sticky w -padx 1 -pady 1 | |
1214 | grid configure $tl.gal-number -row $r -column 2 -sticky we -padx 1 -pady 1 | |
1304202a | 1215 | incr r |
044c8fbc | 1216 | label $tl.l-gal-seed -text "Galaxy seed:" -justify right |
1304202a | 1217 | entry $tl.gal-seed -textvariable cmdr-${seq}(gal-seed) -width 12 |
1218 | cmdr-validate-widget $seq $tl.gal-seed galaxyp | |
1219 | entry-on-change $tl.gal-seed [list cmdr-update-world $seq] | |
044c8fbc | 1220 | grid configure $tl.l-gal-seed -row $r -column 0 -sticky e -padx 1 -pady 1 |
1304202a | 1221 | grid configure $tl.gal-seed -row $r \ |
044c8fbc | 1222 | -column 1 -columnspan 2 -sticky we -padx 1 -pady 1 |
1304202a | 1223 | incr r |
1224 | if {[string equal $cmdr(gal-seed) [galaxy $cmdr(gal-number)]]} { | |
1225 | set cmdr(std-gal) 1 | |
1226 | $tl.gal-seed configure -state disabled | |
1227 | } else { | |
1228 | set cmdr(std-gal) 0 | |
1229 | } | |
044c8fbc | 1230 | label $tl.l-world-name -text "Planet:" -justify right |
1304202a | 1231 | entry $tl.world-name -textvariable cmdr-${seq}(world-name) \ |
044c8fbc | 1232 | -state $entry_readonly -width 10 -justify left |
1233 | grid configure $tl.l-world-name -row $r -column 0 -sticky e -padx 1 -pady 1 | |
1304202a | 1234 | grid configure $tl.world-name -row $r \ |
044c8fbc | 1235 | -column 1 -columnspan 2 -sticky we -padx 1 -pady 1 |
1304202a | 1236 | incr r |
1237 | button $tl.$tag -text "Show galaxy map" \ | |
1238 | -command [list cmdr-show-map $seq] | |
044c8fbc | 1239 | grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we -padx 1 -pady 1 |
1304202a | 1240 | } |
1241 | default { | |
1242 | label $tl.l-$tag -text "($label)" -justify left | |
044c8fbc | 1243 | grid configure $tl.l-$tag -row $r -column 0 -sticky w -padx 1 -pady 1 |
1304202a | 1244 | } |
1245 | } | |
1246 | incr r | |
1247 | } | |
1248 | entry-on-change $tl.fuel [list cmdr-set-fuel $seq] | |
1249 | menu $tl.menu | |
1250 | menu $tl.menu.file | |
1251 | $tl.menu.file add command -label "New commander" -command cmdr-new | |
1252 | $tl.menu.file add command -label "Load commander..." \ | |
1253 | -command { cmdr-loadfile } | |
1254 | $tl.menu.file add command -label "Save commander" \ | |
1255 | -command [list cmdr-save $seq] | |
1256 | $tl.menu.file add command -label "Save as..." \ | |
1257 | -command [list cmdr-saveas $seq] | |
1258 | $tl.menu.file add separator | |
044c8fbc | 1259 | $tl.menu.file add command -label "New map..." \ |
1260 | -command [list cmdr-new-map $seq] | |
1261 | $tl.menu.file add separator | |
1304202a | 1262 | $tl.menu.file add command -label "Close" -command [list cmdr-destroy $seq] |
1263 | $tl.menu.file add command -label "Quit" -command { exit } | |
1264 | $tl.menu add cascade -label "File" -menu $tl.menu.file | |
044c8fbc | 1265 | help-menu $tl.menu |
1304202a | 1266 | $tl configure -menu $tl.menu |
1267 | grid columnconfigure $tl 2 -weight 1 | |
1268 | wm protocol $tl WM_DELETE_WINDOW [list cmdr-destroy $seq] | |
1269 | set cmdr(ok/$tl.cargo-qty.fluc) 1 | |
1270 | cmdr-update-world $seq | |
1271 | cmdr-set-name $seq | |
1272 | incr nwin | |
1273 | return $seq | |
1274 | } | |
1275 | ||
1276 | # --- File handling --- | |
1277 | ||
1278 | proc cmdr-load {file} { | |
1279 | global seq | |
1280 | incr seq | |
1281 | set c [read-file $file] | |
1282 | upvar \#0 cmdr-$seq cmdr | |
1283 | elite-unpackcmdr cmdr $c | |
1284 | set cmdr(file) $file | |
1285 | cmdr-open $seq | |
1286 | } | |
1287 | ||
1288 | set cmdr-filetypes { | |
1289 | { "Commander file" ".nkc" } | |
1290 | } | |
1291 | ||
1292 | proc cmdr-loadfile {} { | |
1293 | global cmdr-filetypes | |
1294 | set f [tk_getOpenFile \ | |
1295 | -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \ | |
1296 | -title "Load commander"] | |
1297 | if {![string equal $f ""]} { | |
1298 | cmdr-load $f | |
1299 | } | |
1300 | } | |
1301 | ||
1302 | proc cmdr-save-file {seq file} { | |
1303 | upvar \#0 cmdr-$seq cmdr | |
1304 | set tl .cmdr-$seq | |
1305 | if {[catch { write-file $file [elite-packcmdr cmdr] } err]} { | |
1306 | moan $err | |
1307 | } else { | |
1308 | set cmdr(file) $file | |
1309 | cmdr-set-name $seq | |
1310 | } | |
1311 | } | |
1312 | ||
1313 | proc cmdr-saveas {seq} { | |
1314 | upvar \#0 cmdr-$seq cmdr | |
1315 | global cmdr-filetypes | |
1316 | if {![cmdr-check $seq]} { return } | |
1317 | set opts [list \ | |
1318 | -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \ | |
1319 | -title "Save commander"] | |
1320 | if {[info exists cmdr(file)]} { | |
1321 | lappend opts -initialdir [file dirname $cmdr(file)] | |
1322 | lappend opts -initialfile [file tail $cmdr(file)] | |
1323 | } else { | |
1324 | lappend opts -initialfile "JAMESON.nkc" | |
1325 | } | |
1326 | set f [eval tk_getSaveFile $opts] | |
1327 | if {[string equal $f ""]} { return } | |
1328 | cmdr-save-file $seq $f | |
1329 | } | |
1330 | ||
1331 | proc cmdr-save {seq} { | |
1332 | upvar \#0 cmdr-$seq cmdr | |
1333 | if {![info exists cmdr(file)]} { | |
1334 | cmdr-saveas $seq | |
1335 | return | |
1336 | } | |
1337 | if {![cmdr-check $seq]} { return } | |
1338 | cmdr-save-file $seq $cmdr(file) | |
1339 | } | |
1340 | ||
1341 | proc cmdr-new {} { | |
1ded87ba | 1342 | global seq |
1304202a | 1343 | incr seq |
1344 | upvar \#0 cmdr-$seq cmdr | |
1ded87ba | 1345 | jameson cmdr |
1304202a | 1346 | cmdr-open $seq |
1347 | } | |
1348 | ||
1349 | #----- Main program --------------------------------------------------------- | |
1350 | ||
1351 | wm withdraw . | |
1352 | ||
1c647046 | 1353 | bind Entry <Control-u> { %W delete 0 end } |
1354 | ||
1304202a | 1355 | if {[llength $argv]} { |
1356 | foreach a $argv { | |
ceff67f2 | 1357 | switch -glob -- $a { |
1358 | "-jameson" { | |
1359 | cmdr-new | |
1360 | } | |
1361 | "-*" { | |
1362 | puts stderr "$argv0: unknown option: $a" | |
1363 | exit 1 | |
1364 | } | |
1365 | default { | |
1366 | set g [parse-galaxy-spec $a] | |
1367 | if {[llength $g]} { | |
1368 | destructure {ng g} $g | |
1369 | map-new $ng $g | |
1370 | } else { | |
1371 | cmdr-load $a | |
1372 | } | |
1373 | } | |
1304202a | 1374 | } |
1375 | } | |
1376 | } else { | |
1377 | map-new 1 $galaxy1 | |
1378 | } | |
1379 | if {!$nwin} { exit } | |
1380 | ||
1381 | #----- That's all, folks ---------------------------------------------------- |