Commit | Line | Data |
---|---|---|
1ded87ba | 1 | #! /usr/bin/tclsh |
378b623c MW |
2 | ### |
3 | ### Commander file inspector | |
4 | ### | |
5 | ### (c) 2003 Mark Wooding | |
6 | ### | |
7 | ||
8 | ###----- Licensing notice --------------------------------------------------- | |
9 | ### | |
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. | |
14 | ### | |
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. | |
19 | ### | |
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. | |
1ded87ba | 23 | |
161e6ada | 24 | package require "elite" "1.0.1" |
1ded87ba | 25 | |
378b623c MW |
26 | ###-------------------------------------------------------------------------- |
27 | ### Various type handlers. | |
28 | ### | |
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: | |
32 | ### | |
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 | |
37 | ||
38 | proc dump-like-get {type} { | |
39 | ## Define dump/TYPE as a synonym for get/TYPE. | |
40 | ||
41 | proc dump/$type {args} [list uplevel 1 get/$type \$args] | |
1ded87ba | 42 | } |
1ded87ba | 43 | |
378b623c | 44 | ## string -- just a plain unconverted string. |
1ded87ba | 45 | proc get/string {a} { global cmdr; return $cmdr($a) } |
378b623c | 46 | dump-like-get string |
1ded87ba | 47 | proc set/string {a v} { global cmdr; set cmdr($a) $v } |
48 | ||
378b623c MW |
49 | ## int MIN MAX -- an integer constrained to lie between the stated |
50 | ## (inclusive) bounds. | |
1ded87ba | 51 | proc get/int {min max a} { |
52 | global cmdr | |
53 | return [format "%d" [expr {$cmdr($a) + 0}]] | |
54 | } | |
378b623c | 55 | dump-like-get int |
1ded87ba | 56 | proc set/int {min max a v} { |
57 | global cmdr | |
58 | if {$v < $min || $v > $max} { error "value out of range" } | |
59 | set cmdr($a) $v | |
60 | } | |
61 | ||
378b623c MW |
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. | |
1ded87ba | 65 | proc get/tenth {min max a} { |
66 | global cmdr | |
67 | return [format "%.1f" [expr {$cmdr($a)/10.0}]] | |
68 | } | |
378b623c | 69 | dump-like-get tenth |
1ded87ba | 70 | proc set/tenth {min max a v} { |
71 | global cmdr | |
72 | if {$v < $min || $v > $max} { error "value out of range" } | |
73 | set cmdr($a) [expr {int($v * 10)}] | |
74 | } | |
75 | ||
378b623c MW |
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 | |
79 | ## in the list. | |
1ded87ba | 80 | proc get/choice {min max l a} { |
81 | global cmdr | |
82 | set x "custom" | |
83 | foreach {t v} $l { if {$cmdr($a) >= $v} { set x $t } } | |
84 | return [format "%d (%s)" [expr {$cmdr($a) + 0}] $x] | |
85 | } | |
86 | proc dump/choice {min max l a} { | |
87 | global cmdr | |
88 | return [format "%d" [expr {$cmdr($a) + 0}]] | |
89 | } | |
90 | proc set/choice {min max l a v} { | |
91 | global cmdr | |
92 | if {[regexp {^\d+$} $v]} { | |
93 | if {$v < $min || $v > $max} { error "value out of range" } | |
94 | } else { | |
95 | set x $v | |
96 | set v -1 | |
97 | foreach {t vv} $l { | |
98 | if {[string equal -nocase $x $t]} { set v $vv; break } | |
99 | } | |
100 | if {$v == -1} { error "unknown tag `$x'" } | |
101 | } | |
102 | set cmdr($a) $v | |
103 | } | |
104 | ||
378b623c MW |
105 | ## seed -- a galaxy seed; any valid galaxy spec is permitted as the |
106 | ## presentation form. | |
1ded87ba | 107 | proc get/seed {a} { global cmdr; return $cmdr($a) } |
378b623c | 108 | dump-like-get seed |
1ded87ba | 109 | proc set/seed {a v} { |
110 | global cmdr | |
111 | set s [parse-galaxy-spec $v] | |
112 | if {[string equal $s ""]} { error "bad galaxy spec `$v'" } | |
113 | destructure [list . cmdr($a)] $s | |
114 | } | |
115 | ||
378b623c MW |
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. | |
1ded87ba | 119 | proc get/world {a} { |
120 | global cmdr gov eco | |
161e6ada | 121 | set ww [elite-galaxylist $cmdr(gal-seed)] |
1ded87ba | 122 | set s [nearest-planet $ww \ |
123 | [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]] | |
124 | elite-worldinfo p $s | |
125 | return [list $p(name) $p(x) $p(y) $eco($p(economy)) $gov($p(government)) \ | |
126 | $p(techlevel)] | |
127 | } | |
128 | proc dump/world {a} { | |
129 | global cmdr | |
130 | return [format "%d, %d" \ | |
131 | [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]] | |
132 | } | |
133 | proc set/world {a v} { | |
134 | global cmdr | |
161e6ada | 135 | set ww [elite-galaxylist $cmdr(gal-seed)] |
1ded87ba | 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)" | |
140 | } | |
141 | elite-worldinfo p $s | |
8bdcaa8b | 142 | set ss [nearest-planet $ww $p(x) $p(y)] |
143 | if {![string equal $s $ss]} { | |
144 | set n $p(name) | |
145 | elite-worldinfo p $ss | |
146 | puts stderr "can't dock at $n: $p(name) is coincident" | |
147 | } | |
1ded87ba | 148 | set cmdr(world-x) [expr {$p(x)/4}] |
149 | set cmdr(world-y) [expr {$p(y)/2}] | |
150 | } | |
151 | ||
378b623c MW |
152 | ## bool DFL -- internal form is either zero or DFL; external form is one of a |
153 | ## number of standard boolean tokens. | |
1ded87ba | 154 | proc get/bool {dfl a} { |
155 | global cmdr | |
156 | if {$cmdr($a)} { return "yes" } else { return "no" } | |
157 | } | |
378b623c | 158 | dump-like-get bool |
1ded87ba | 159 | proc set/bool {dfl a v} { |
160 | global cmdr | |
161 | switch -- [string tolower $v] { | |
378b623c MW |
162 | "y" - "yes" - "true" - "on" - "t" { set v 1 } |
163 | "n" - "no" - "false" - "off" - "nil" { set v 0 } | |
1ded87ba | 164 | } |
165 | if {$v} { set cmdr($a) $dfl } else { set cmdr($a) 0 } | |
166 | } | |
167 | ||
378b623c | 168 | ## comment -- a pseudo-type for discarding commnts in input files. |
1ded87ba | 169 | proc set/comment {a v} { } |
170 | ||
378b623c MW |
171 | ###-------------------------------------------------------------------------- |
172 | ### Attribute table. | |
173 | ||
174 | ### The `attr' array maps commander attribute names to TYPE [PARAM ...] | |
175 | ### lists; the `attrs' list contains the names in a canonical order. | |
1ded87ba | 176 | set attrs {} |
378b623c MW |
177 | |
178 | ## Comment magic. | |
1ded87ba | 179 | set attr(\#) { comment } |
378b623c MW |
180 | |
181 | ## Basic attributes. | |
1ded87ba | 182 | foreach {a type} { |
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 | |
187 | "elite" 6400 | |
188 | } } | |
189 | credits { tenth 0 429496729.5 } | |
22518481 | 190 | legal-status { choice 0 255 |
486cb648 | 191 | { "clean" 0 "offender" 1 "fugitive" 50 } } |
1ded87ba | 192 | cargo { int 4 255 } |
193 | gal-number { int 1 8 } | |
194 | gal-seed { seed } | |
195 | world { world } | |
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 } } | |
200 | } { | |
201 | set attr($a) $type | |
202 | lappend attrs $a | |
203 | } | |
378b623c MW |
204 | |
205 | ## Lasers. | |
1ded87ba | 206 | foreach l {front rear left right} { |
207 | set attr($l-laser) { | |
208 | choice 0 255 | |
209 | { "none" 0 "pulse" 0x0f "mining" 0x32 "beam" 0x8f "military" 0x97 } | |
210 | } | |
211 | lappend attrs $l-laser | |
212 | } | |
378b623c MW |
213 | |
214 | ## Standard boolean properties. | |
1ded87ba | 215 | foreach i { |
216 | ecm fuel-scoop energy-bomb escape-pod docking-computer gal-hyperdrive | |
217 | } { | |
218 | set attr($i) { bool 255 } | |
219 | lappend attrs $i | |
220 | } | |
378b623c MW |
221 | |
222 | ## Station and hold produce. | |
1ded87ba | 223 | foreach l {station hold} { |
224 | foreach {t p} $products { | |
225 | set attr($l-$t) { int 0 255 } | |
226 | lappend attrs $l-$t | |
227 | } | |
228 | } | |
229 | ||
378b623c MW |
230 | ###-------------------------------------------------------------------------- |
231 | ### Main program. | |
232 | ||
233 | jameson cmdr | |
234 | ||
235 | ## Parse the command-line. | |
236 | if {[llength $argv] < 1} { | |
237 | puts stderr "usage: $argv0 \[-OPTION | ATTR | ATTR=VALUE\] ..." | |
238 | exit 1 | |
239 | } | |
240 | ||
241 | proc show-attrs {pat} { | |
242 | ## Show the attributes whose names match the glob pattern PAT. Return the | |
243 | ## number of matches. | |
244 | ||
245 | global attr attrs | |
246 | set n 0 | |
247 | foreach a $attrs { | |
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]]] | |
251 | incr n | |
252 | } | |
253 | } | |
254 | return $n | |
255 | } | |
256 | ||
257 | proc load-file {file} { | |
258 | ## Load FILE as a commander. | |
259 | ||
260 | global argv0 cmdr | |
261 | if {[catch { elite-unpackcmdr cmdr [read-file $file] } err]} { | |
262 | puts stderr "$argv0: couldn't read `$file': $err" | |
263 | exit 1 | |
264 | } | |
265 | } | |
266 | ||
1ded87ba | 267 | set acted 0 |
268 | for {set i 0} {$i < [llength $argv]} {incr i} { | |
269 | set a [lindex $argv $i] | |
270 | switch -regexp -- $a { | |
378b623c MW |
271 | |
272 | "^-reset$" { | |
273 | ## Reset the commander back to Jameson. | |
274 | ||
275 | jameson cmdr | |
276 | } | |
277 | ||
1ded87ba | 278 | "^-show$" { |
378b623c MW |
279 | ## Produce a human-readable description of the commander. |
280 | ||
281 | show-attrs "*" | |
1ded87ba | 282 | set acted 1 |
283 | } | |
378b623c | 284 | |
1ded87ba | 285 | "^-load$" { |
378b623c MW |
286 | ## Load a commander file. |
287 | ||
1ded87ba | 288 | incr i |
289 | set a [lindex $argv $i] | |
378b623c | 290 | load-file $a |
1ded87ba | 291 | } |
378b623c | 292 | |
1ded87ba | 293 | "^-save$" { |
378b623c MW |
294 | ## Write the commander to a file. |
295 | ||
1ded87ba | 296 | incr i |
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" | |
300 | exit 1 | |
301 | } | |
302 | set acted 1 | |
303 | } | |
378b623c | 304 | |
1ded87ba | 305 | "^-dump$" { |
378b623c MW |
306 | ## Dump a machine-readable textual description of the commander. |
307 | ||
1ded87ba | 308 | puts "# {Elite commander dump}" |
309 | puts "" | |
310 | foreach a $attrs { | |
311 | puts [list $a [eval \ | |
312 | dump/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]] | |
313 | } | |
314 | set acted 1 | |
315 | } | |
378b623c | 316 | |
1ded87ba | 317 | "^-read$" { |
378b623c MW |
318 | ## Read back a description produced by `-dump'. |
319 | ||
1ded87ba | 320 | incr i |
321 | set a [lindex $argv $i] | |
322 | if {[catch { | |
323 | foreach {a v} [read-file $a auto] { | |
324 | if {![info exists attr($a)]} { | |
325 | error "no such attribute `$a'" | |
326 | } | |
327 | eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v] | |
328 | } | |
329 | } err]} { | |
330 | puts stderr "$argv0: error in script: $err" | |
331 | exit 1 | |
332 | } | |
333 | } | |
378b623c | 334 | |
1ded87ba | 335 | "^-" { |
378b623c MW |
336 | ## An unknown option. |
337 | ||
1ded87ba | 338 | puts stderr "$argv0: unknown option `$a'" |
339 | exit 1 | |
340 | } | |
378b623c | 341 | |
1ded87ba | 342 | "^[a-z][a-z-]*=" { |
378b623c MW |
343 | ## An assignment ATTR=VALUE. |
344 | ||
1ded87ba | 345 | regexp {^([a-z][a-z-]*)=(.*)$} $a . a v |
346 | if {![info exists attr($a)]} { | |
347 | puts stderr "$argv0: no such attribute `$a'" | |
348 | exit 1 | |
349 | } | |
350 | if {[catch { | |
351 | eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v] | |
352 | } err]} { | |
353 | puts stderr "$argv0: error setting `$a': $err" | |
354 | exit 1 | |
355 | } | |
356 | } | |
378b623c | 357 | |
1ded87ba | 358 | default { |
378b623c MW |
359 | ## If the argument matches any attribute names, then print the matching |
360 | ## attributes; otherwise load the named file. | |
361 | ||
362 | if {[show-attrs $a]} { | |
d45cab7c | 363 | set acted 1 |
364 | } else { | |
378b623c | 365 | load-file $a |
1ded87ba | 366 | } |
367 | } | |
368 | } | |
369 | } | |
378b623c MW |
370 | |
371 | ## If we didn't do anything, write out a description of the file. | |
1ded87ba | 372 | if {!$acted} { |
378b623c | 373 | show-attrs "*" |
1ded87ba | 374 | } |
378b623c MW |
375 | |
376 | ###----- That's all, folks -------------------------------------------------- |