+#! /usr/bin/tclsh
+
+package require "elite" "1.0.0"
+
+if {[llength $argv] < 1} {
+ puts stderr "usage: $argv0 \[-OPTION | ATTR | ATTR=VALUE\] ..."
+ exit 1
+}
+jameson cmdr
+
+proc get/string {a} { global cmdr; return $cmdr($a) }
+proc dump/string {a} { global cmdr; return $cmdr($a) }
+proc set/string {a v} { global cmdr; set cmdr($a) $v }
+
+proc get/int {min max a} {
+ global cmdr
+ return [format "%d" [expr {$cmdr($a) + 0}]]
+}
+proc dump/int {min max a} {
+ global cmdr
+ return [format "%d" [expr {$cmdr($a) + 0}]]
+}
+proc set/int {min max a v} {
+ global cmdr
+ if {$v < $min || $v > $max} { error "value out of range" }
+ set cmdr($a) $v
+}
+
+proc get/tenth {min max a} {
+ global cmdr
+ return [format "%.1f" [expr {$cmdr($a)/10.0}]]
+}
+proc dump/tenth {min max a} {
+ global cmdr
+ return [format "%.1f" [expr {$cmdr($a)/10.0}]]
+}
+proc set/tenth {min max a v} {
+ global cmdr
+ if {$v < $min || $v > $max} { error "value out of range" }
+ set cmdr($a) [expr {int($v * 10)}]
+}
+
+proc get/choice {min max l a} {
+ global cmdr
+ set x "custom"
+ foreach {t v} $l { if {$cmdr($a) >= $v} { set x $t } }
+ return [format "%d (%s)" [expr {$cmdr($a) + 0}] $x]
+}
+proc dump/choice {min max l a} {
+ global cmdr
+ return [format "%d" [expr {$cmdr($a) + 0}]]
+}
+proc set/choice {min max l a v} {
+ global cmdr
+ if {[regexp {^\d+$} $v]} {
+ if {$v < $min || $v > $max} { error "value out of range" }
+ } else {
+ set x $v
+ set v -1
+ foreach {t vv} $l {
+ if {[string equal -nocase $x $t]} { set v $vv; break }
+ }
+ if {$v == -1} { error "unknown tag `$x'" }
+ }
+ set cmdr($a) $v
+}
+
+proc get/seed {a} { global cmdr; return $cmdr($a) }
+proc dump/seed {a} { global cmdr; return $cmdr($a) }
+proc set/seed {a v} {
+ global cmdr
+ set s [parse-galaxy-spec $v]
+ if {[string equal $s ""]} { error "bad galaxy spec `$v'" }
+ destructure [list . cmdr($a)] $s
+}
+
+proc get/world {a} {
+ global cmdr gov eco
+ set ww [worldinfo $cmdr(gal-seed)]
+ set s [nearest-planet $ww \
+ [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
+ elite-worldinfo p $s
+ return [list $p(name) $p(x) $p(y) $eco($p(economy)) $gov($p(government)) \
+ $p(techlevel)]
+}
+proc dump/world {a} {
+ global cmdr
+ return [format "%d, %d" \
+ [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
+}
+proc set/world {a v} {
+ global cmdr
+ set s [parse-planet-spec $cmdr(gal-seed) $v]
+ if {[string equal $s ""]} { error "bad planet spec `$v'" }
+ if {![in-galaxy-p $cmdr(gal-seed) $s]} {
+ error "planet `[worldname $s]' not in galaxy $cmdr(gal-seed)"
+ }
+ elite-worldinfo p $s
+ set cmdr(world-x) [expr {$p(x)/4}]
+ set cmdr(world-y) [expr {$p(y)/2}]
+}
+
+proc get/bool {dfl a} {
+ global cmdr
+ if {$cmdr($a)} { return "yes" } else { return "no" }
+}
+proc dump/bool {dfl a} {
+ global cmdr
+ if {$cmdr($a)} { return "yes" } else { return "no" }
+}
+proc set/bool {dfl a v} {
+ global cmdr
+ switch -- [string tolower $v] {
+ "y" - "yes" - "true" - "on" { set v 1 }
+ "n" - "no" - "false" - "off" { set v 0 }
+ }
+ if {$v} { set cmdr($a) $dfl } else { set cmdr($a) 0 }
+}
+
+proc set/comment {a v} { }
+
+set attrs {}
+set attr(\#) { comment }
+foreach {a type} {
+ mission { int 0 255 }
+ score { choice 0 65535 {
+ "harmless" 0 "mostly-harmless" 8 "poor" 16 "average" 32
+ "above-average" 64 "competent" 128 "dangerous" 512 "deadly" 2560
+ "elite" 6400
+ } }
+ credits { tenth 0 429496729.5 }
+ cargo { int 4 255 }
+ gal-number { int 1 8 }
+ gal-seed { seed }
+ world { world }
+ market-fluc { int 0 255 }
+ missiles { int 0 255 }
+ fuel { tenth 0 25.5 }
+ energy-unit { choice 0 255 { "none" 0 "standard" 1 "naval" 2 } }
+} {
+ set attr($a) $type
+ lappend attrs $a
+}
+foreach l {front rear left right} {
+ set attr($l-laser) {
+ choice 0 255
+ { "none" 0 "pulse" 0x0f "mining" 0x32 "beam" 0x8f "military" 0x97 }
+ }
+ lappend attrs $l-laser
+}
+foreach i {
+ ecm fuel-scoop energy-bomb escape-pod docking-computer gal-hyperdrive
+} {
+ set attr($i) { bool 255 }
+ lappend attrs $i
+}
+foreach l {station hold} {
+ foreach {t p} $products {
+ set attr($l-$t) { int 0 255 }
+ lappend attrs $l-$t
+ }
+}
+
+set acted 0
+for {set i 0} {$i < [llength $argv]} {incr i} {
+ set a [lindex $argv $i]
+ switch -regexp -- $a {
+ "^-reset$" { jameson cmdr }
+ "^-show$" {
+ foreach a $attrs {
+ puts [format "%-20s %s" $a [eval \
+ get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
+ }
+ set acted 1
+ }
+ "^-load$" {
+ incr i
+ set a [lindex $argv $i]
+ if {[catch { elite-unpackcmdr cmdr [read-file $a] } err]} {
+ puts stderr "$argv0: couldn't read `$a': $err"
+ exit 1
+ }
+ }
+ "^-save$" {
+ incr i
+ set a [lindex $argv $i]
+ if {[catch { write-file $a [elite-packcmdr cmdr] } err]} {
+ puts stderr "$argv0: couldn't write `$a': $err"
+ exit 1
+ }
+ set acted 1
+ }
+ "^-dump$" {
+ puts "# {Elite commander dump}"
+ puts ""
+ foreach a $attrs {
+ puts [list $a [eval \
+ dump/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
+ }
+ set acted 1
+ }
+ "^-read$" {
+ incr i
+ set a [lindex $argv $i]
+ if {[catch {
+ foreach {a v} [read-file $a auto] {
+ if {![info exists attr($a)]} {
+ error "no such attribute `$a'"
+ }
+ eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
+ }
+ } err]} {
+ puts stderr "$argv0: error in script: $err"
+ exit 1
+ }
+ }
+ "^-" {
+ puts stderr "$argv0: unknown option `$a'"
+ exit 1
+ }
+ "^[a-z][a-z-]*=" {
+ regexp {^([a-z][a-z-]*)=(.*)$} $a . a v
+ if {![info exists attr($a)]} {
+ puts stderr "$argv0: no such attribute `$a'"
+ exit 1
+ }
+ if {[catch {
+ eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
+ } err]} {
+ puts stderr "$argv0: error setting `$a': $err"
+ exit 1
+ }
+ }
+ "^[a-z][a-z-]*$" {
+ if {![info exists attr($a)]} {
+ puts stderr "$argv0: no such attribute `$a'"
+ exit 1
+ }
+ puts [format "%-20s %s" $a [eval \
+ get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
+ }
+ default {
+ if {[catch { elite-unpackcmdr cmdr [read-file $a] } err]} {
+ puts stderr "$argv0: couldn't read `$a': $err"
+ exit 1
+ }
+ }
+ }
+}
+if {!$acted} {
+ foreach a $attrs {
+ puts [format "%-20s %s" $a [eval \
+ get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
+ }
+}