3 ### Commander file inspector
5 ### (c) 2003 Mark Wooding
8 ###----- Licensing notice ---------------------------------------------------
10 ### This program is free software; you can redistribute it and/or modify
11 ### it under the terms of the GNU General Public License as published by
12 ### the Free Software Foundation; either version 2 of the License, or
13 ### (at your option) any later version.
15 ### This program is distributed in the hope that it will be useful,
16 ### but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ### GNU General Public License for more details.
20 ### You should have received a copy of the GNU General Public License
21 ### along with this program; if not, write to the Free Software Foundation,
22 ### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 package require "elite" "1.0.1"
26 ###--------------------------------------------------------------------------
27 ### Various type handlers.
29 ### We associate a named type and some optional (type-specific) parameters
30 ### with each attribute in the commander file format. For each TYPE, there
31 ### are Tcl procedures:
33 ### get/TYPE [PARAM ...] A -- return presentation form of the attribute A
34 ### dump/TYPE [PARAM ...] A -- return an external form of the attribute A
35 ### set/TYPE [PARAM ...] A V -- convert V from presentation form and store
36 ### as the attribute A
38 proc dump-like-get {type} {
39 ## Define dump/TYPE as a synonym for get/TYPE.
41 proc dump/$type {args} [list uplevel 1 get/$type \$args]
44 ## string -- just a plain unconverted string.
45 proc get/string {a} { global cmdr; return $cmdr($a) }
47 proc set/string {a v} { global cmdr; set cmdr($a) $v }
49 ## int MIN MAX -- an integer constrained to lie between the stated
50 ## (inclusive) bounds.
51 proc get/int {min max a} {
53 return [format "%d" [expr {$cmdr($a) + 0}]]
56 proc set/int {min max a v} {
58 if {$v < $min || $v > $max} { error "value out of range" }
62 ## tenth MIN MAX -- a numerical value constrained to lie between the stated
63 ## inclusive bounds; the internal format is an integer containing ten times
64 ## the presentation value.
65 proc get/tenth {min max a} {
67 return [format "%.1f" [expr {$cmdr($a)/10.0}]]
70 proc set/tenth {min max a v} {
72 if {$v < $min || $v > $max} { error "value out of range" }
73 set cmdr($a) [expr {int($v * 10)}]
76 ## choice MIN MAX L -- the presentation form is either an integer between the
77 ## given inclusive bounds, or a token matching one of the items in the
78 ## list L; the internal form is the integer, or the index of the token
80 proc get/choice {min max l a} {
83 foreach {t v} $l { if {$cmdr($a) >= $v} { set x $t } }
84 return [format "%d (%s)" [expr {$cmdr($a) + 0}] $x]
86 proc dump/choice {min max l a} {
88 return [format "%d" [expr {$cmdr($a) + 0}]]
90 proc set/choice {min max l a v} {
92 if {[regexp {^\d+$} $v]} {
93 if {$v < $min || $v > $max} { error "value out of range" }
98 if {[string equal -nocase $x $t]} { set v $vv; break }
100 if {$v == -1} { error "unknown tag `$x'" }
105 ## seed -- a galaxy seed; any valid galaxy spec is permitted as the
106 ## presentation form.
107 proc get/seed {a} { global cmdr; return $cmdr($a) }
109 proc set/seed {a v} {
111 set s [parse-galaxy-spec $v]
112 if {[string equal $s ""]} { error "bad galaxy spec `$v'" }
113 destructure [list . cmdr($a)] $s
116 ## world -- a planet identifier; on input, any planet spec is permitted
117 ## (relative to the commander's established galaxy), and on output a
118 ## summary description is produced.
121 set ww [elite-galaxylist $cmdr(gal-seed)]
122 set s [nearest-planet $ww \
123 [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
125 return [list $p(name) $p(x) $p(y) $eco($p(economy)) $gov($p(government)) \
128 proc dump/world {a} {
130 return [format "%d, %d" \
131 [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
133 proc set/world {a v} {
135 set ww [elite-galaxylist $cmdr(gal-seed)]
136 set s [parse-planet-spec $cmdr(gal-seed) $v]
137 if {[string equal $s ""]} { error "bad planet spec `$v'" }
138 if {![in-galaxy-p $cmdr(gal-seed) $s]} {
139 error "planet `[worldname $s]' not in galaxy $cmdr(gal-seed)"
142 set ss [nearest-planet $ww $p(x) $p(y)]
143 if {![string equal $s $ss]} {
145 elite-worldinfo p $ss
146 puts stderr "can't dock at $n: $p(name) is coincident"
148 set cmdr(world-x) [expr {$p(x)/4}]
149 set cmdr(world-y) [expr {$p(y)/2}]
152 ## bool DFL -- internal form is either zero or DFL; external form is one of a
153 ## number of standard boolean tokens.
154 proc get/bool {dfl a} {
156 if {$cmdr($a)} { return "yes" } else { return "no" }
159 proc set/bool {dfl a v} {
161 switch -- [string tolower $v] {
162 "y" - "yes" - "true" - "on" - "t" { set v 1 }
163 "n" - "no" - "false" - "off" - "nil" { set v 0 }
165 if {$v} { set cmdr($a) $dfl } else { set cmdr($a) 0 }
168 ## comment -- a pseudo-type for discarding commnts in input files.
169 proc set/comment {a v} { }
171 ###--------------------------------------------------------------------------
174 ### The `attr' array maps commander attribute names to TYPE [PARAM ...]
175 ### lists; the `attrs' list contains the names in a canonical order.
179 set attr(\#) { comment }
183 mission { int 0 255 }
184 score { choice 0 65535 {
185 "harmless" 0 "mostly-harmless" 8 "poor" 16 "average" 32
186 "above-average" 64 "competent" 128 "dangerous" 512 "deadly" 2560
189 credits { tenth 0 429496729.5 }
190 legal-status { choice 0 255
191 { "clean" 0 "offender" 1 "fugitive" 50 } }
193 gal-number { int 1 8 }
196 market-fluc { int 0 255 }
197 missiles { int 0 255 }
198 fuel { tenth 0 25.5 }
199 energy-unit { choice 0 255 { "none" 0 "standard" 1 "naval" 2 } }
206 foreach l {front rear left right} {
209 { "none" 0 "pulse" 0x0f "mining" 0x32 "beam" 0x8f "military" 0x97 }
211 lappend attrs $l-laser
214 ## Standard boolean properties.
216 ecm fuel-scoop energy-bomb escape-pod docking-computer gal-hyperdrive
218 set attr($i) { bool 255 }
222 ## Station and hold produce.
223 foreach l {station hold} {
224 foreach {t p} $products {
225 set attr($l-$t) { int 0 255 }
230 ###--------------------------------------------------------------------------
235 ## Parse the command-line.
236 if {[llength $argv] < 1} {
237 puts stderr "usage: $argv0 \[-OPTION | ATTR | ATTR=VALUE\] ..."
241 proc show-attrs {pat} {
242 ## Show the attributes whose names match the glob pattern PAT. Return the
243 ## number of matches.
248 if {[string match $pat $a]} {
249 puts [format "%-20s %s" $a [eval \
250 get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
257 proc load-file {file} {
258 ## Load FILE as a commander.
261 if {[catch { elite-unpackcmdr cmdr [read-file $file] } err]} {
262 puts stderr "$argv0: couldn't read `$file': $err"
268 for {set i 0} {$i < [llength $argv]} {incr i} {
269 set a [lindex $argv $i]
270 switch -regexp -- $a {
273 ## Reset the commander back to Jameson.
279 ## Produce a human-readable description of the commander.
286 ## Load a commander file.
289 set a [lindex $argv $i]
294 ## Write the commander to a file.
297 set a [lindex $argv $i]
298 if {[catch { write-file $a [elite-packcmdr cmdr] } err]} {
299 puts stderr "$argv0: couldn't write `$a': $err"
306 ## Dump a machine-readable textual description of the commander.
308 puts "# {Elite commander dump}"
311 puts [list $a [eval \
312 dump/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
318 ## Read back a description produced by `-dump'.
321 set a [lindex $argv $i]
323 foreach {a v} [read-file $a auto] {
324 if {![info exists attr($a)]} {
325 error "no such attribute `$a'"
327 eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
330 puts stderr "$argv0: error in script: $err"
336 ## An unknown option.
338 puts stderr "$argv0: unknown option `$a'"
343 ## An assignment ATTR=VALUE.
345 regexp {^([a-z][a-z-]*)=(.*)$} $a . a v
346 if {![info exists attr($a)]} {
347 puts stderr "$argv0: no such attribute `$a'"
351 eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
353 puts stderr "$argv0: error setting `$a': $err"
359 ## If the argument matches any attribute names, then print the matching
360 ## attributes; otherwise load the named file.
362 if {[show-attrs $a]} {
371 ## If we didn't do anything, write out a description of the file.
376 ###----- That's all, folks --------------------------------------------------