3 # $Id: elite-editor,v 1.6 2003/03/02 12:28:14 mdw Exp $
5 package require "elite" "1.0.0"
7 # --- Utility procedures ----------------------------------------------------
11 tk_messageBox -message $msg -default ok -title $argv0 -type ok -icon error
14 proc debug-array {name} {
17 if {[winfo exists .$tl]} { return }
18 set s [array startsearch a]
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
26 grid configure $tl.k-$n -row $r -column 0 -sticky e
27 grid configure $tl.v-$n -row $r -column 1 -sticky we
34 proc get-line-done {tl cmd} {
35 if {![uplevel \#0 [concat $cmd [$tl.entry get]]]} {
40 proc get-line {tl title prompt def cmd} {
41 if {[winfo exists $tl]} {
47 label $tl.label -text "$prompt: "
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
56 proc entry-on-change {widget what} {
57 bind $widget <Return> $what
58 bind $widget <FocusOut> $what
61 #----- Map editing machinery ------------------------------------------------
63 tab col red orange yellow green blue magenta violet white
67 array set default {scale 15 colourby off connect 0}
69 proc set-scale {seq sc} {
70 if {![regexp {^\d+$} $sc]} {
71 moan "bad scale factor `$sc'"
79 set g [parse-galaxy-spec $gs]
81 moan "bad galaxy spec `$gs'"
89 proc set-hyperspace-range {seq f} {
90 if {![regexp {^\d+(\.\d+)?$} $f]} {
91 moan "bad hyperspace range `$f'"
94 map-set-fuel $seq [expr {$f * 10}]
98 # --- Colour-coding planets ---
100 proc colour-by {seq} {
101 upvar \#0 map-$seq map
104 switch -exact -- $map(colourby) {
106 foreach-world $map(galaxy) p {
107 $tl.map itemconfigure $p(seed) -fill white -outline white
111 foreach-world $map(galaxy) p {
112 set c [expr {7 - $p(economy)}]
113 $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
117 foreach-world $map(galaxy) p {
119 $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
123 foreach-world $map(galaxy) p {
124 set c [expr {$p(techlevel) / 2}]
125 $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
131 proc set-colour-by {seq} {
133 upvar \#0 map-$seq map
134 set default(colourby) $map(colourby)
138 # --- Connectivity maps ---
140 proc show-connectivity {seq} {
141 upvar \#0 map-$seq map
142 upvar \#0 adj-$map(galaxy)-$map(fuel) adj
143 upvar \#0 ww-$map(galaxy) ww
146 if {!$map(connect)} {
149 if {![info exists adj]} { adjacency $ww adj $map(fuel) }
150 foreach {s x y} $ww {
152 foreach {ss xx yy} $adj($s) {
153 if {[info exists done($ss)]} { continue }
154 $tl.map create line \
155 [to-map $seq $x] [to-map $seq $y] \
156 [to-map $seq $xx] [to-map $seq $yy] \
157 -fill darkblue -tags conn
160 $tl.map lower conn sep
164 proc set-connectivity {seq} {
166 upvar \#0 map-$seq map
167 set default(connect) $map(connect)
168 show-connectivity $seq
171 # --- Planet names ---
173 proc show-names {seq} {
174 upvar \#0 map-$seq map
180 foreach-world $map(galaxy) p {
182 set px [to-map $seq $p(x)]
183 set py [to-map $seq $p(y)]
184 set offx [expr {$px + [to-map $seq 2]}]
185 set offy [expr {$py + [to-map $seq 2]}]
187 foreach {a ox oy dx x y xx yy} {
191 sw 2 -2 -10 0 -10 30 0
192 se -2 -2 0 -30 -10 0 0
193 se -2 -2 10 -30 -10 0 0
195 ne -2 2 10 -30 0 0 10
197 set ox [expr {$px + [to-map $seq $ox] + $dx}]
198 set oy [expr {$py + [to-map $seq $oy]}]
199 if {![llength [$tl.map find overlapping \
200 [expr {$ox + $x}] [expr {$ox + $y}] \
201 [expr {$ox + $xx}] [expr {$ox + $yy}]]]} {
209 $tl.map create text $offx $offy -text $p(name) \
210 -fill white -anchor $a -tags names
214 proc set-names {seq} {
216 upvar \#0 map-$seq map
217 set default(names) $map(names)
221 # --- Shortest path handling ---
223 proc show-path {seq} {
224 upvar \#0 map-$seq map
227 if {![info exists map(path)]} { return }
228 foreach n $map(path) {
230 if {[info exists x]} {
231 $tl.map create line \
232 [to-map $seq $x] [to-map $seq $y] \
233 [to-map $seq $p(x)] [to-map $seq $p(y)] \
234 -fill darkorange -tags path
239 $tl.map lower path sep
242 proc hide-path {seq} {
243 upvar \#0 map-$seq map
247 $tl.menu.path entryconfigure 7 -state disabled
250 proc show-shortest-path {seq weight} {
251 upvar \#0 map-$seq map
252 upvar \#0 adj-$map(galaxy)-$map(fuel) adj
253 upvar \#0 ww-$map(galaxy) ww
256 if {[info exists map(path)]} { unset map(path) }
257 if {![info exists map(select)] || ![info exists map(dest)]} {
258 moan "no source or destination set"
261 if {![info exists adj]} { adjacency $ww adj $map(fuel) }
262 destructure {path weight} \
263 [shortest-path adj $map(select) $map(dest) $weight]
264 if {![llength $path]} {
265 moan "no path exists"
269 $tl.menu.path entryconfigure 7 -state normal
273 # --- Planet information box ---
275 proc do-getinfo {tag seq x y} {
276 global economy government
277 upvar \#0 info-$tag info
278 set tl .world-info-$tag
279 elite-worldinfo info [find-click $seq $x $y]
280 if {[winfo exists $tl]} {
285 foreach {item label} {
290 gov-name "Government"
291 techlevel "Tech. level"
293 prod-str "Productivity"
296 label $tl.l-$item -text "$label: " -justify right
297 entry $tl.$item -textvariable info-${tag}($item) -state disabled
298 grid configure $tl.l-$item -row $r -column 0 -sticky e
299 grid configure $tl.$item -row $r -column 1 -columnspan 2 -sticky we
302 scrollbar $tl.descscr -orient vertical -command [list $tl.desc yview]
303 text $tl.desc -wrap word -yscrollcommand [list $tl.descscr set] \
305 grid configure $tl.desc -row $r -column 0 -columnspan 2 -sticky nsew
306 grid configure $tl.descscr -row $r -column 2 -sticky ns
307 grid columnconfigure $tl 1 -weight 1
308 grid rowconfigure $tl $r -weight 1
310 wm title $tl "Info: $info(name)"
311 set info(position) "$info(x), $info(y)"
312 set info(eco-name) $economy($info(economy))
313 set info(gov-name) $government($info(government))
315 [format "%s billion (%s)" \
316 [expr {$info(population)/10}] \
318 set info(prod-str) [format "%d M Cr" $info(productivity)]
319 set info(radius-km) [format "%d km" $info(radius)]
320 $tl.desc configure -state normal
321 $tl.desc delete 1.0 end
322 $tl.desc insert end $info(description)
323 $tl.desc configure -state disabled
326 # --- Messing with selections ---
329 upvar \#0 map-$seq map
330 return [expr {$x * $map(scale) / 10.0}]
333 proc to-map {seq x} {
334 upvar \#0 map-$seq map
335 return [expr {$x * 10 / $map(scale)}]
338 proc find-click {seq x y} {
339 upvar \#0 map-$seq map
340 upvar \#0 ww-$map(galaxy) ww
343 set x [to-ly $seq [$tl.map canvasx $x]]
344 set y [to-ly $seq [$tl.map canvasy $y]]
346 foreach {seed px py} $ww {
347 set dx [expr {$x - $px}]
348 set dy [expr {$y - $py}]
349 set d [expr {$dx * $dx + $dy * $dy}]
358 $tl.map create line \
359 [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] - 5}] \
360 [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] + 5}] \
361 -tags here -fill green
362 $tl.map create line \
363 [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] + 5}] \
364 [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] - 5}] \
365 -tags here -fill green
370 proc destination-world {seq} {
371 upvar \#0 map-$seq map
373 if {![info exists map(dest)]} { return }
375 elite-worldinfo p $map(dest)
376 set px [to-map $seq $p(x)]
377 set py [to-map $seq $p(y)]
378 $tl.map create line [expr {$px - 10}] $py [expr {$px + 10}] $py \
379 -tags {dest cross} -fill darkorange
380 $tl.map create line $px [expr {$py - 10}] $px [expr {$py + 10}] \
381 -tags {dest cross} -fill darkorange
382 $tl.map raise dest sel
385 proc select-world {seq} {
386 upvar \#0 map-$seq map
388 if {![info exists map(select)]} { return }
389 $tl.map delete sel dest
390 elite-worldinfo p $map(select)
391 set r [to-map $seq $map(fuel)]
392 set px [to-map $seq $p(x)]
393 set py [to-map $seq $p(y)]
394 $tl.map create line [expr {$px - 20}] $py [expr {$px + 20}] $py \
395 -tags {sel cross} -fill darkred
396 $tl.map create line $px [expr {$py - 20}] $px [expr {$py + 20}] \
397 -tags {sel cross} -fill darkred
398 $tl.map create oval \
399 [expr {$px - $r}] [expr {$py - $r}] \
400 [expr {$px + $r}] [expr {$py + $r}] \
401 -tags {sel radius} -outline darkgreen
402 $tl.map raise sel sep
405 proc select-byname {seq name seed proc} {
406 upvar \#0 map-$seq map
407 set p [parse-planet-spec $map(galaxy) $map($name)]
408 if {![string equal $p ""] && [in-galaxy-p $map(galaxy) $p]} {
410 } elseif {[info exists map($seed)]} {
412 set map($name) [worldname $map($seed)]
419 proc set-selection {seq p} {
420 upvar \#0 map-$seq map
422 elite-worldinfo pp $p
424 set map(sel-name) $pp(name)
425 if {![info exists map(dest)]} {
426 set-destination $seq $p
428 set-destination $seq $map(dest)
430 if {[info exists map(cmdr)]} {
431 cmdr-set-world $map(cmdr) $p
435 proc do-select {seq x y} {
436 set-selection $seq [find-click $seq $x $y]
439 proc set-destination {seq p} {
440 upvar \#0 map-$seq map
441 if {![info exists map(select)]} {
442 set-selection $seq $p
444 elite-worldinfo ps $map(select)
445 elite-worldinfo pd $p
447 destination-world $seq
448 set map(dest-name) $pd(name)
451 [expr {[world-distance $ps(x) $ps(y) $pd(x) $pd(y)] / 10.0}]]
455 proc do-destination {seq x y} {
456 set-destination $seq [find-click $seq $x $y]
459 # --- Redrawing a map ---
461 proc map-populate {seq} {
462 global colourby-$seq connect-$seq
463 upvar \#0 map-$seq map
464 upvar \#0 ww-$map(galaxy) ww
467 set scale $map(scale)
469 $tl.map create line -10000 -20000 -10000 -20000 -fill black -tags sep
470 if {![info exists ww]} { set ww [worldinfo $map(galaxy)] }
471 foreach {seed x y} $ww {
472 elite-worldinfo p $seed
473 set x [expr {$x * 10 / $map(scale)}]
474 set y [expr {$y * 10 / $map(scale)}]
475 set r [expr {$p(radius) / (500 * $map(scale))}]
476 $tl.map create oval \
477 [expr {$x - $r}] [expr {$y - $r}] \
478 [expr {$x + $r}] [expr {$y + $r}] \
479 -fill white -outline white \
480 -tags [list $seed world]
484 show-connectivity $seq
487 destination-world $seq
490 # --- Miscellaneous stuff ---
492 proc map-setscale {seq sc} {
494 upvar \#0 map-$seq map
496 set wd [expr {10240/$sc + 40}]
497 set ht [expr {5120/$sc} + 10]
498 $tl.map configure -scrollregion [list -40 -10 $wd $ht]
500 set default(scale) $sc
504 proc map-destroy {seq} {
506 upvar \#0 map-$seq map
507 if {[info exists map(cmdr)]} {
508 upvar \#0 cmdr-$map(cmdr) cmdr
512 destroy .map-$seq .set-scale-$seq
517 proc map-attach-cmdr {seq cmdr} {
518 upvar \#0 map-$seq map
521 .map-$seq.menu.view entryconfigure 3 -state disabled
524 proc map-set-title {seq} {
525 upvar \#0 map-$seq map
527 set t "Galaxy $map(galaxy-num)"
528 if {[info exists map(cmdr)]} {
529 append t " (commander [cmdr-name $map(cmdr)])"
534 proc map-set-galaxy {seq ng g} {
535 upvar \#0 map-$seq map
536 if {[string equal $g $map(galaxy)]} { return }
537 set map(galaxy-num) $ng
541 foreach i {select select-name dest dest-name} {
542 catch { unset map($i) }
546 proc map-set-fuel {seq qty} {
547 upvar \#0 map-$seq map
548 set map(fuel) [expr {int($qty)}]
550 show-connectivity $seq
553 # --- Making a new map window ---
555 proc map-new {ng g} {
556 global seq nwin default
559 upvar \#0 map-$seq map
561 array set map [array get default]
564 set map(galaxy-num) $ng
565 set tl [toplevel .map-$seq]
566 set wd [expr {10240/$sc + 80}]
567 set ht [expr {5120/$sc + 20}]
568 set vwd $wd; if {$vwd > 1120} { set vwd 768 }
569 set vht $ht; if {$vht > 1024} { set vht 768 }
573 -xscrollcommand [list $tl.hscr set] \
574 -yscrollcommand [list $tl.vscr set] \
575 -width $vwd -height $vht
577 label $tl.info.lhome -text "Home: "
578 entry $tl.info.home -textvariable map-${seq}(sel-name)
579 label $tl.info.ldest -text "Destination: "
580 entry $tl.info.dest -textvariable map-${seq}(dest-name)
581 label $tl.info.ldist -text "Distance: "
582 entry $tl.info.dist -textvariable map-${seq}(distance) \
583 -state disabled -width 6
585 $tl.info.lhome $tl.info.home \
586 $tl.info.ldest $tl.info.dest \
587 $tl.info.ldist $tl.info.dist \
590 scrollbar $tl.hscr -orient horizontal \
591 -command [list $tl.map xview]
592 scrollbar $tl.vscr -orient vertical \
593 -command [list $tl.map yview]
596 $tl.menu.file add command -label "New commander" -command cmdr-new
597 $tl.menu.file add command -label "Load commander..." \
598 -command { cmdr-loadfile }
599 $tl.menu.file add separator
600 $tl.menu.file add command -label "Close" -command [list map-destroy $seq]
601 $tl.menu.file add command -label "Quit" -command { exit }
602 $tl.menu add cascade -label "File" -menu $tl.menu.file
604 $tl.menu.view add command -label "New map..." \
605 -command [list get-line .new-view "New map" "Galaxy" $ng new-view]
606 $tl.menu.view add command -label "Set scale..." \
607 -command [concat get-line .set-scale-$seq {"Set scale"} "Scale" \
608 \[set map-${seq}(scale)\] [list [list set-scale $seq]]]
609 $tl.menu.view add command -label "Set hyperspace range..." \
610 -command [concat get-line .set-fuel-$seq {"Set hyperspace range"} \
611 {"Hyperspace range"} \[expr \[set map-${seq}(fuel)\]/10.0\] \
612 [list [list set-hyperspace-range $seq]]]
613 $tl.menu.view add separator
614 $tl.menu.view add radiobutton -label "Off" \
615 -variable map-${seq}(colourby) -value off \
616 -command [list set-colour-by $seq]
617 $tl.menu.view add radiobutton -label "Economy" \
618 -variable map-${seq}(colourby) -value economy \
619 -command [list set-colour-by $seq]
620 $tl.menu.view add radiobutton -label "Government" \
621 -variable map-${seq}(colourby) -value government \
622 -command [list set-colour-by $seq]
623 $tl.menu.view add radiobutton -label "Tech level" \
624 -variable map-${seq}(colourby) -value techlevel \
625 -command [list set-colour-by $seq]
626 $tl.menu.view add separator
627 $tl.menu.view add checkbutton -label "Connectivity" \
628 -variable map-${seq}(connect) \
629 -command [list set-connectivity $seq]
630 $tl.menu.view add checkbutton -label "Planet names" \
631 -variable map-${seq}(names) \
632 -command [list set-names $seq]
633 $tl.menu add cascade -label "View" -menu $tl.menu.view
635 $tl.menu.path add command -label "Minimize hops" \
636 -command [list show-shortest-path $seq weight-hops]
637 $tl.menu.path add command -label "Minimize fuel" \
638 -command [list show-shortest-path $seq weight-fuel]
639 $tl.menu.path add command -label "Maximize safety" \
640 -command [list show-shortest-path $seq weight-safety]
641 $tl.menu.path add command -label "Minimize safety" \
642 -command [list show-shortest-path $seq weight-encounters]
643 $tl.menu.path add command -label "Maximize trading" \
644 -command [list show-shortest-path $seq weight-trading]
645 $tl.menu.path add separator
646 $tl.menu.path add command -label "Hide path" -state disabled \
647 -command [list hide-path $seq]
648 $tl.menu add cascade -label "Compute path" -menu $tl.menu.path
649 $tl configure -menu $tl.menu
651 wm protocol $tl WM_DELETE_WINDOW [list map-destroy $seq]
653 grid $tl.map -column 0 -row 0 -sticky nsew
654 grid $tl.hscr -column 0 -row 1 -sticky ew
655 grid $tl.vscr -column 1 -row 0 -sticky ns
656 grid rowconfigure $tl 0 -weight 1
657 grid columnconfigure $tl 0 -weight 1
658 grid $tl.info -column 0 -columnspan 2 -row 2 -sticky ew
660 bind $tl.map <3> [list do-select $seq %x %y]
661 bind $tl.map <1> [list do-destination $seq %x %y]
662 bind $tl.map <Double-1> [list do-getinfo dest $seq %x %y]
663 bind $tl.map <Double-3> [list do-getinfo home $seq %x %y]
666 entry-on-change $tl.info.home \
667 [list select-byname $seq sel-name select set-selection]
668 entry-on-change $tl.info.dest \
669 [list select-byname $seq dest-name dest set-destination]
670 map-setscale $seq $sc
674 #----- Commander editing machinery ------------------------------------------
676 # --- Validation and factor-of-10 fixing ---
678 proc fix-tenth {tag arrvar full op} {
679 upvar \#0 $arrvar arr
680 catch { set arr($tag) [format "%d" [expr {int($arr($full) * 10)}]] }
683 proc numericp {min max n} {
684 if {[catch { expr {$n + 0} }]} { return 0 }
685 if {$n < $min || $n > $max} { return 0 }
689 proc integerp {min max n} {
690 if {[catch { incr n 0}]} { return 0 }
691 if {$n < $min || $n > $max} { return 0 }
696 if {![regexp {^[0-9a-fA-F]{12}$} $s]} { return 0 }
700 proc cmdr-do-validate {seq widget check value} {
701 upvar \#0 cmdr-$seq cmdr
702 if {$cmdr(ok/$widget)} { incr cmdr(bogus) }
703 if {![eval $check [list $value]]} {
704 set cmdr(ok/$widget) 0
705 $widget configure -foreground red
707 set cmdr(ok/$widget) 1
708 $widget configure -foreground black
714 proc cmdr-validate-widget {seq widget check} {
715 upvar \#0 cmdr-$seq cmdr
716 set cmdr(ok/$widget) 1
717 $widget configure -validate key \
718 -vcmd [list cmdr-do-validate $seq $widget $check %P]
721 # --- Cargo window handling ---
723 proc cmdr-set-fluc {seq} {
724 upvar \#0 cmdr-$seq cmdr
726 set tl .cmdr-$seq.cargo-qty
727 if {!$cmdr(ok/$tl.fluc)} { bell; return }
728 elite-market m $cmdr(world-seed) $cmdr(market-fluc)
729 foreach {i .} $products {
730 set cmdr(price-$i) [format "%.1f" [expr {[lindex $m($i) 0]/10.0}]]
734 proc cmdr-cargo {seq} {
735 upvar \#0 cmdr-$seq cmdr
736 set tl .cmdr-$seq.cargo-qty
737 if {[winfo exists $tl]} {
742 wm title $tl "Cargo for commander $cmdr(name)"
745 label $tl.l-fluc -text "Fluctuation: " -justify right
746 entry $tl.fluc -textvariable cmdr-${seq}(market-fluc) -justify right
747 cmdr-validate-widget $seq $tl.fluc [list integerp 0 255]
748 entry-on-change $tl.fluc [list cmdr-set-fluc $seq]
749 grid configure $tl.l-fluc -row $r -column 0 -sticky e
750 grid configure $tl.fluc -row $r -column 1 -columnspan 3 -sticky we
752 label $tl.l-item -text "Item" -justify center
753 label $tl.l-price -text "Price" -justify center
754 label $tl.l-station -text "Station" -justify center
755 label $tl.l-hold -text "Hold" -justify center
756 grid configure $tl.l-item -row $r -column 0 -sticky e
757 grid configure $tl.l-price -row $r -column 1 -sticky we
758 grid configure $tl.l-station -row $r -column 2 -sticky we
759 grid configure $tl.l-hold -row $r -column 3 -sticky we
761 foreach {tag label} $products {
762 label $tl.l-$tag -text "$label: " -justify right
763 entry $tl.price-$tag -textvariable cmdr-${seq}(price-${tag}) \
764 -justify right -state disabled -width 4
765 foreach {pre col} {station 2 hold 3} {
766 entry $tl.${pre}-${tag} -textvariable cmdr-${seq}(${pre}-${tag}) \
767 -justify right -width 4
768 cmdr-validate-widget $seq $tl.${pre}-${tag} [list integerp 0 255]
769 grid configure $tl.${pre}-${tag} -row $r -column $col -stick we
771 grid configure $tl.l-$tag -row $r -column 0 -sticky e
772 grid configure $tl.price-$tag -row $r -column 1 -sticky we
775 grid columnconfigure $tl 1 -weight 1
776 grid columnconfigure $tl 2 -weight 1
777 grid columnconfigure $tl 3 -weight 1
780 # --- Miscellaneous stuff ---
782 proc cmdr-destroy {seq} {
783 upvar \#0 cmdr-$seq cmdr
786 if {[info exists cmdr(map)]} { map-destroy $cmdr(map) }
793 proc cmdrdb-set {seq tag value} {
794 upvar \#0 cmdr-$seq cmdr
796 set cmdr($tag) $value
797 $tl.$tag configure -state disabled
800 proc cmdrdb-custom {seq tag} {
802 $tl.$tag configure -state normal
805 proc cmdr-set-world {seq p} {
806 upvar \#0 cmdr-$seq cmdr
808 set cmdr(world-seed) $p
809 set cmdr(world-name) $i(name)
810 set cmdr(world-x) [expr {$i(x)/4}]
811 set cmdr(world-y) [expr {$i(y)/2}]
815 proc cmdr-update-world {seq} {
816 upvar \#0 cmdr-$seq cmdr
817 upvar \#0 ww-$cmdr(gal-seed) ww
818 if {![info exists ww]} { set ww [worldinfo $cmdr(gal-seed)] }
820 set w [nearest-planet $ww \
821 [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
822 if {[info exists cmdr(map)]} {
823 if {$cmdr(std-gal)} {
824 set ng $cmdr(gal-number)
826 set ng $cmdr(gal-seed)
828 map-set-galaxy $cmdr(map) $ng $cmdr(gal-seed)
829 set-selection $cmdr(map) $w
831 cmdr-set-world $seq $w
834 proc cmdr-set-gal-num {seq} {
835 upvar \#0 cmdr-$seq cmdr
837 if {!$cmdr(ok/$tl.gal-number)} { bell; return }
838 if {$cmdr(std-gal)} {
839 set cmdr(gal-seed) [galaxy $cmdr(gal-number)]
840 cmdr-update-world $seq
844 proc cmdr-std-gal {seq} {
845 upvar \#0 cmdr-$seq cmdr
847 if {$cmdr(std-gal)} {
848 if {!$cmdr(ok/$tl.gal-number)} { bell; return }
849 set cmdr(gal-seed) [galaxy $cmdr(gal-number)]
850 cmdr-update-world $seq
851 $tl.gal-seed configure -state disabled
853 $tl.gal-seed configure -state normal
857 proc cmdr-set-fuel {seq} {
858 upvar \#0 cmdr-$seq cmdr
859 if {[info exists cmdr(map)]} {
860 map-set-fuel $cmdr(map) $cmdr(fuel)
864 proc cmdr-name {seq} {
865 upvar \#0 cmdr-$seq cmdr
869 proc cmdr-show-map {seq} {
870 upvar \#0 cmdr-$seq cmdr
871 if {[info exists cmdr(map)]} {
874 if {$cmdr(std-gal)} {
875 set ng $cmdr(gal-number)
877 set ng $cmdr(gal-seed)
879 set cmdr(map) [map-new $ng $cmdr(gal-seed)]
880 map-attach-cmdr $cmdr(map) $seq
881 map-set-fuel $cmdr(map) $cmdr(fuel)
882 set-selection $cmdr(map) $cmdr(world-seed)
885 proc cmdr-set-name {seq} {
886 upvar \#0 cmdr-$seq cmdr
887 if {[info exists cmdr(file)]} {
888 set cmdr(name) [string toupper [file rootname [file tail $cmdr(file)]]]
890 set cmdr(name) JAMESON
893 wm title $tl "Commander $cmdr(name)"
894 if {[info exists cmdr(map)]} { map-set-title $cmdr(map) }
895 if {[winfo exists $tl.cargo-qty]} {
896 wm title $tl.cargo-qty "Cargo for commander $cmdr(name)"
900 proc cmdr-check {seq} {
901 upvar \#0 cmdr-$seq cmdr
903 moan("invalid values in commander data -- fix items highlighted in red")
909 # --- Initial population ---
911 proc cmdr-open {seq} {
912 upvar \#0 cmdr-$seq cmdr
927 foreach {tag label kind} [list \
928 mission "Mission" { entry 2 255 } \
929 score "Rating" { dropbox 65535\
931 "Mostly harmless" 8 \
939 legal-status "Legal status" { dropbox 255 \
943 world "Location" where \
944 credits "Credits" { tenth 10 429496729.5 } \
945 fuel "Fuel" { tenth 4 25.5 } \
946 missiles "Missiles" { entry 4 255 } \
947 energy-unit "Energy unit" { dropbox 255 \
951 front-laser "Front laser" $laser \
952 rear-laser "Front laser" $laser \
953 left-laser "Left laser" $laser \
954 right-laser "Right laser" $laser \
956 fuel-scoop "Fuel scoops" toggle \
957 energy-bomb "Energy bomb" toggle \
958 escape-pod "Escape pod" toggle \
959 docking-computer "Docking computers" toggle \
960 gal-hyperdrive "Galactic hyperdrive" toggle \
961 cargo "Cargo capacity" { entry 4 255 } \
962 stuff "Cargo" cargo \
964 switch -exact -- [lindex $kind 0] {
966 destructure {. wd max} $kind
967 label $tl.l-$tag -text "$label: " -justify right
968 entry $tl.$tag -textvariable cmdr-${seq}($tag) \
969 -width $wd -justify right
970 cmdr-validate-widget $seq $tl.$tag [list integerp 0 $max]
971 grid configure $tl.l-$tag -row $r -column 0 -sticky e
972 grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we
975 destructure {. wd max} $kind
976 label $tl.l-$tag -text "$label: " -justify right
977 entry $tl.$tag -textvariable cmdr-${seq}(div-$tag) \
978 -width $wd -justify right
979 set cmdr(div-$tag) [format "%.1f" [expr {$cmdr($tag) / 10.0}]]
980 trace variable cmdr-${seq}(div-$tag) w [list fix-tenth $tag]
981 cmdr-validate-widget $seq $tl.$tag [list numericp 0 $max]
982 grid configure $tl.l-$tag -row $r -column 0 -sticky e
983 grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we
986 checkbutton $tl.$tag -text $label -variable cmdr-${seq}($tag)
987 grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky w
990 label $tl.l-$tag -text "$label: " -justify right
991 set menu $tl.m-$tag.menu
992 menubutton $tl.m-$tag -textvariable cmdr-${seq}(r-${tag}) \
993 -indicatoron 1 -relief raised -menu $menu -width 8 \
995 entry $tl.$tag -textvariable cmdr-${seq}($tag) \
996 -justify right -width 4
997 cmdr-validate-widget $seq $tl.$tag [list integerp 0 [lindex $kind 1]]
998 menu $menu -tearoff 0
999 set cmdr(r-$tag) "Custom"
1000 foreach {name value} [lrange $kind 2 end] {
1001 $menu add radiobutton -label "$name ($value)" \
1002 -value $name -variable cmdr-${seq}(r-$tag) \
1003 -command [list cmdrdb-set $seq $tag $value]
1004 if {$cmdr($tag) == $value} {
1005 set cmdr(r-$tag) $name
1006 set cmdr($tag) $value
1007 $tl.$tag configure -state disabled
1010 $menu add radiobutton -label "Custom" \
1011 -value "Custom" -variable cmdr-${seq}(r-$tag) \
1012 -command [list cmdrdb-custom $seq $tag]
1013 grid configure $tl.l-$tag -row $r -column 0 -sticky e
1014 grid configure $tl.m-$tag -row $r -column 1 -sticky we
1015 grid configure $tl.$tag -row $r -column 2 -sticky we
1018 button $tl.$tag -text $label -command [list cmdr-cargo $seq]
1019 grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we
1022 label $tl.l-gal-number -text "Galaxy number: " -justify right
1023 entry $tl.gal-number -textvariable cmdr-${seq}(gal-number) \
1024 -justify right -width 2
1025 cmdr-validate-widget $seq $tl.gal-number [list integerp 1 8]
1026 checkbutton $tl.std-gal -text "Standard galaxy" \
1027 -variable cmdr-${seq}(std-gal) -justify left \
1028 -command [list cmdr-std-gal $seq]
1029 entry-on-change $tl.gal-number [list cmdr-set-gal-num $seq]
1030 grid configure $tl.l-gal-number -row $r -column 0 -sticky e
1031 grid configure $tl.std-gal -row $r -column 1 -sticky w
1032 grid configure $tl.gal-number -row $r -column 2 -sticky we
1034 label $tl.l-gal-seed -text "Galaxy seed: " -justify right
1035 entry $tl.gal-seed -textvariable cmdr-${seq}(gal-seed) -width 12
1036 cmdr-validate-widget $seq $tl.gal-seed galaxyp
1037 entry-on-change $tl.gal-seed [list cmdr-update-world $seq]
1038 grid configure $tl.l-gal-seed -row $r -column 0 -sticky e
1039 grid configure $tl.gal-seed -row $r \
1040 -column 1 -columnspan 2 -sticky we
1042 if {[string equal $cmdr(gal-seed) [galaxy $cmdr(gal-number)]]} {
1044 $tl.gal-seed configure -state disabled
1048 label $tl.l-world-name -text "Planet: " -justify right
1049 entry $tl.world-name -textvariable cmdr-${seq}(world-name) \
1050 -state disabled -width 10 -justify left
1051 grid configure $tl.l-world-name -row $r -column 0 -sticky e
1052 grid configure $tl.world-name -row $r \
1053 -column 1 -columnspan 2 -sticky we
1055 button $tl.$tag -text "Show galaxy map" \
1056 -command [list cmdr-show-map $seq]
1057 grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we
1060 label $tl.l-$tag -text "($label)" -justify left
1061 grid configure $tl.l-$tag -row $r -column 0 -sticky w
1066 entry-on-change $tl.fuel [list cmdr-set-fuel $seq]
1069 $tl.menu.file add command -label "New commander" -command cmdr-new
1070 $tl.menu.file add command -label "Load commander..." \
1071 -command { cmdr-loadfile }
1072 $tl.menu.file add command -label "Save commander" \
1073 -command [list cmdr-save $seq]
1074 $tl.menu.file add command -label "Save as..." \
1075 -command [list cmdr-saveas $seq]
1076 $tl.menu.file add separator
1077 $tl.menu.file add command -label "Close" -command [list cmdr-destroy $seq]
1078 $tl.menu.file add command -label "Quit" -command { exit }
1079 $tl.menu add cascade -label "File" -menu $tl.menu.file
1080 $tl configure -menu $tl.menu
1081 grid columnconfigure $tl 2 -weight 1
1082 wm protocol $tl WM_DELETE_WINDOW [list cmdr-destroy $seq]
1083 set cmdr(ok/$tl.cargo-qty.fluc) 1
1084 cmdr-update-world $seq
1090 # --- File handling ---
1092 proc cmdr-load {file} {
1095 set c [read-file $file]
1096 upvar \#0 cmdr-$seq cmdr
1097 elite-unpackcmdr cmdr $c
1098 set cmdr(file) $file
1102 set cmdr-filetypes {
1103 { "Commander file" ".nkc" }
1106 proc cmdr-loadfile {} {
1107 global cmdr-filetypes
1108 set f [tk_getOpenFile \
1109 -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \
1110 -title "Load commander"]
1111 if {![string equal $f ""]} {
1116 proc cmdr-save-file {seq file} {
1117 upvar \#0 cmdr-$seq cmdr
1119 if {[catch { write-file $file [elite-packcmdr cmdr] } err]} {
1122 set cmdr(file) $file
1127 proc cmdr-saveas {seq} {
1128 upvar \#0 cmdr-$seq cmdr
1129 global cmdr-filetypes
1130 if {![cmdr-check $seq]} { return }
1132 -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \
1133 -title "Save commander"]
1134 if {[info exists cmdr(file)]} {
1135 lappend opts -initialdir [file dirname $cmdr(file)]
1136 lappend opts -initialfile [file tail $cmdr(file)]
1138 lappend opts -initialfile "JAMESON.nkc"
1140 set f [eval tk_getSaveFile $opts]
1141 if {[string equal $f ""]} { return }
1142 cmdr-save-file $seq $f
1145 proc cmdr-save {seq} {
1146 upvar \#0 cmdr-$seq cmdr
1147 if {![info exists cmdr(file)]} {
1151 if {![cmdr-check $seq]} { return }
1152 cmdr-save-file $seq $cmdr(file)
1158 upvar \#0 cmdr-$seq cmdr
1163 #----- Main program ---------------------------------------------------------
1167 if {[llength $argv]} {
1169 switch -glob -- $a {
1174 puts stderr "$argv0: unknown option: $a"
1178 set g [parse-galaxy-spec $a]
1180 destructure {ng g} $g
1191 if {!$nwin} { exit }
1193 #----- That's all, folks ----------------------------------------------------