chiark / gitweb /
Add elite-tantalus. Add a developer guide.
[rocl] / elite-editor
CommitLineData
1304202a 1#! /usr/bin/wish
b130b8f5 2#
74bdd262 3# $Id$
1304202a 4
b48b0bfb 5package require "elite" "1.0.1"
1304202a 6
044c8fbc 7#----- Utility procedures ---------------------------------------------------
1304202a 8
9proc moan {msg} {
10 global argv0
11 tk_messageBox -message $msg -default ok -title $argv0 -type ok -icon error
12}
13
14proc 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 34proc get-line-done {tl cmd} {
35 if {![uplevel \#0 [concat $cmd [$tl.entry get]]]} {
36 destroy $tl
37 }
38}
39
40proc 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
56proc entry-on-change {widget what} {
57 bind $widget <Return> $what
58 bind $widget <FocusOut> $what
59}
60
044c8fbc 61if {$tk_version >= 8.4} {
62 set entry_readonly readonly
63} else {
64 set entry_readonly disabled
65}
66
67#----- About box ------------------------------------------------------------
68
69proc 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 {
81Copyright (c) 2003 Mark Wooding
82Partly based on code by Ian Bell and Christian Pinder
83
84This program is free software; you can redistribute it and/or modify
85it under the terms of the GNU General Public License as published by
86the Free Software Foundation; either version 2 of the License, or
87(at your option) any later version.
88
89This program is distributed in the hope that it will be useful,
90but WITHOUT ANY WARRANTY; without even the implied warranty of
91MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
92GNU General Public License for more details.
93
94You should have received a copy of the GNU General Public License
95along with this program; if not, write to the Free Software Foundation,
96Inc., 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
105proc 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
113tab col red orange yellow green blue magenta violet white
114
115set seq 0
116set nwin 0
117array set default {scale 15 colourby off connect 0}
118
119proc 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
128proc 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 139proc 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
150proc colour-by {seq} {
151 upvar \#0 map-$seq map
152 set tl .map-$seq
153 global col
154 switch -exact -- $map(colourby) {
155 off {
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
181proc 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
190proc 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
215proc 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
224proc 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
265proc 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
274proc 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 293proc 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
303proc path-to-text {seq} {
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 312proc 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
320proc 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
343}
344
345proc 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
378}
379
1304202a 380proc 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 407proc 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 458proc do-getinfo {tag seq x y} {
459 show-worldinfo $tag [find-click $seq $x $y]
460}
461
1304202a 462# --- Messing with selections ---
463
464proc to-ly {seq x} {
465 upvar \#0 map-$seq map
466 return [expr {$x * $map(scale) / 10.0}]
467}
468
469proc to-map {seq x} {
470 upvar \#0 map-$seq map
471 return [expr {$x * 10 / $map(scale)}]
472}
473
474proc 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
506proc 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
521proc 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
541proc 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
558proc 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
565proc 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 }
1304202a 583}
584
585proc do-select {seq x y} {
586 set-selection $seq [find-click $seq $x $y]
587}
588
589proc 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
605proc do-destination {seq x y} {
606 set-destination $seq [find-click $seq $x $y]
607}
608
609# --- Redrawing a map ---
610
611proc 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
642proc 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
654proc 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
667proc 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
674proc 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
684proc map-set-galaxy {seq ng g} {
685 upvar \#0 map-$seq map
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
696proc 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
705proc 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
1304202a 739
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 \
788 -command [list save-path $seq]
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
840proc 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
845proc 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
851proc 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
857proc galaxyp {s} {
858 if {![regexp {^[0-9a-fA-F]{12}$} $s]} { return 0 }
859 return 1
860}
861
862proc 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
876proc 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
885proc 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
896proc 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
945proc 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 956proc 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 967proc 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
974proc cmdrdb-custom {seq tag} {
975 set tl .cmdr-$seq
976 $tl.$tag configure -state normal
977}
978
979proc 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
997proc 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
1016proc 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
1026proc 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
1039proc 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
1046proc cmdr-name {seq} {
1047 upvar \#0 cmdr-$seq cmdr
1048 return $cmdr(name)
1049}
1050
1051proc 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
1067proc 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
1082proc 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
1093proc 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 \
1304202a 1112 "Harmless" 0 \
1113 "Mostly harmless" 8 \
1ded87ba 1114 "Poor" 16 \
1304202a 1115 "Average" 32 \
1116 "Above average" 64 \
1117 "Competent" 128 \
1118 "Dangerous" 512 \
1119 "Deadly" 2560 \
1120 "Elite" 6400 } \
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 \
1130 "None" 0 \
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 \
1210 -command [list cmdr-std-gal $seq]
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
1278proc 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
1288set cmdr-filetypes {
1289 { "Commander file" ".nkc" }
1290}
1291
1292proc 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
1302proc 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
1313proc 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
1331proc 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
1341proc 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
1351wm withdraw .
1352
1c647046 1353bind Entry <Control-u> { %W delete 0 end }
1354
1304202a 1355if {[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}
1379if {!$nwin} { exit }
1380
1381#----- That's all, folks ----------------------------------------------------