1ded87ba |
1 | #! /usr/bin/tclsh |
2 | |
3 | package require "elite" "1.0.0" |
4 | |
5 | if {[llength $argv] < 1} { |
6 | puts stderr "usage: $argv0 \[-OPTION | ATTR | ATTR=VALUE\] ..." |
7 | exit 1 |
8 | } |
9 | jameson cmdr |
10 | |
11 | proc get/string {a} { global cmdr; return $cmdr($a) } |
12 | proc dump/string {a} { global cmdr; return $cmdr($a) } |
13 | proc set/string {a v} { global cmdr; set cmdr($a) $v } |
14 | |
15 | proc get/int {min max a} { |
16 | global cmdr |
17 | return [format "%d" [expr {$cmdr($a) + 0}]] |
18 | } |
19 | proc dump/int {min max a} { |
20 | global cmdr |
21 | return [format "%d" [expr {$cmdr($a) + 0}]] |
22 | } |
23 | proc set/int {min max a v} { |
24 | global cmdr |
25 | if {$v < $min || $v > $max} { error "value out of range" } |
26 | set cmdr($a) $v |
27 | } |
28 | |
29 | proc get/tenth {min max a} { |
30 | global cmdr |
31 | return [format "%.1f" [expr {$cmdr($a)/10.0}]] |
32 | } |
33 | proc dump/tenth {min max a} { |
34 | global cmdr |
35 | return [format "%.1f" [expr {$cmdr($a)/10.0}]] |
36 | } |
37 | proc set/tenth {min max a v} { |
38 | global cmdr |
39 | if {$v < $min || $v > $max} { error "value out of range" } |
40 | set cmdr($a) [expr {int($v * 10)}] |
41 | } |
42 | |
43 | proc get/choice {min max l a} { |
44 | global cmdr |
45 | set x "custom" |
46 | foreach {t v} $l { if {$cmdr($a) >= $v} { set x $t } } |
47 | return [format "%d (%s)" [expr {$cmdr($a) + 0}] $x] |
48 | } |
49 | proc dump/choice {min max l a} { |
50 | global cmdr |
51 | return [format "%d" [expr {$cmdr($a) + 0}]] |
52 | } |
53 | proc set/choice {min max l a v} { |
54 | global cmdr |
55 | if {[regexp {^\d+$} $v]} { |
56 | if {$v < $min || $v > $max} { error "value out of range" } |
57 | } else { |
58 | set x $v |
59 | set v -1 |
60 | foreach {t vv} $l { |
61 | if {[string equal -nocase $x $t]} { set v $vv; break } |
62 | } |
63 | if {$v == -1} { error "unknown tag `$x'" } |
64 | } |
65 | set cmdr($a) $v |
66 | } |
67 | |
68 | proc get/seed {a} { global cmdr; return $cmdr($a) } |
69 | proc dump/seed {a} { global cmdr; return $cmdr($a) } |
70 | proc set/seed {a v} { |
71 | global cmdr |
72 | set s [parse-galaxy-spec $v] |
73 | if {[string equal $s ""]} { error "bad galaxy spec `$v'" } |
74 | destructure [list . cmdr($a)] $s |
75 | } |
76 | |
77 | proc get/world {a} { |
78 | global cmdr gov eco |
79 | set ww [worldinfo $cmdr(gal-seed)] |
80 | set s [nearest-planet $ww \ |
81 | [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]] |
82 | elite-worldinfo p $s |
83 | return [list $p(name) $p(x) $p(y) $eco($p(economy)) $gov($p(government)) \ |
84 | $p(techlevel)] |
85 | } |
86 | proc dump/world {a} { |
87 | global cmdr |
88 | return [format "%d, %d" \ |
89 | [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]] |
90 | } |
91 | proc set/world {a v} { |
92 | global cmdr |
8bdcaa8b |
93 | set ww [worldinfo $cmdr(gal-seed)] |
1ded87ba |
94 | set s [parse-planet-spec $cmdr(gal-seed) $v] |
95 | if {[string equal $s ""]} { error "bad planet spec `$v'" } |
96 | if {![in-galaxy-p $cmdr(gal-seed) $s]} { |
97 | error "planet `[worldname $s]' not in galaxy $cmdr(gal-seed)" |
98 | } |
99 | elite-worldinfo p $s |
8bdcaa8b |
100 | set ss [nearest-planet $ww $p(x) $p(y)] |
101 | if {![string equal $s $ss]} { |
102 | set n $p(name) |
103 | elite-worldinfo p $ss |
104 | puts stderr "can't dock at $n: $p(name) is coincident" |
105 | } |
1ded87ba |
106 | set cmdr(world-x) [expr {$p(x)/4}] |
107 | set cmdr(world-y) [expr {$p(y)/2}] |
108 | } |
109 | |
110 | proc get/bool {dfl a} { |
111 | global cmdr |
112 | if {$cmdr($a)} { return "yes" } else { return "no" } |
113 | } |
114 | proc dump/bool {dfl a} { |
115 | global cmdr |
116 | if {$cmdr($a)} { return "yes" } else { return "no" } |
117 | } |
118 | proc set/bool {dfl a v} { |
119 | global cmdr |
120 | switch -- [string tolower $v] { |
121 | "y" - "yes" - "true" - "on" { set v 1 } |
122 | "n" - "no" - "false" - "off" { set v 0 } |
123 | } |
124 | if {$v} { set cmdr($a) $dfl } else { set cmdr($a) 0 } |
125 | } |
126 | |
127 | proc set/comment {a v} { } |
128 | |
129 | set attrs {} |
130 | set attr(\#) { comment } |
131 | foreach {a type} { |
132 | mission { int 0 255 } |
133 | score { choice 0 65535 { |
134 | "harmless" 0 "mostly-harmless" 8 "poor" 16 "average" 32 |
135 | "above-average" 64 "competent" 128 "dangerous" 512 "deadly" 2560 |
136 | "elite" 6400 |
137 | } } |
138 | credits { tenth 0 429496729.5 } |
139 | cargo { int 4 255 } |
140 | gal-number { int 1 8 } |
141 | gal-seed { seed } |
142 | world { world } |
143 | market-fluc { int 0 255 } |
144 | missiles { int 0 255 } |
145 | fuel { tenth 0 25.5 } |
146 | energy-unit { choice 0 255 { "none" 0 "standard" 1 "naval" 2 } } |
147 | } { |
148 | set attr($a) $type |
149 | lappend attrs $a |
150 | } |
151 | foreach l {front rear left right} { |
152 | set attr($l-laser) { |
153 | choice 0 255 |
154 | { "none" 0 "pulse" 0x0f "mining" 0x32 "beam" 0x8f "military" 0x97 } |
155 | } |
156 | lappend attrs $l-laser |
157 | } |
158 | foreach i { |
159 | ecm fuel-scoop energy-bomb escape-pod docking-computer gal-hyperdrive |
160 | } { |
161 | set attr($i) { bool 255 } |
162 | lappend attrs $i |
163 | } |
164 | foreach l {station hold} { |
165 | foreach {t p} $products { |
166 | set attr($l-$t) { int 0 255 } |
167 | lappend attrs $l-$t |
168 | } |
169 | } |
170 | |
171 | set acted 0 |
172 | for {set i 0} {$i < [llength $argv]} {incr i} { |
173 | set a [lindex $argv $i] |
174 | switch -regexp -- $a { |
175 | "^-reset$" { jameson cmdr } |
176 | "^-show$" { |
177 | foreach a $attrs { |
178 | puts [format "%-20s %s" $a [eval \ |
179 | get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]] |
180 | } |
181 | set acted 1 |
182 | } |
183 | "^-load$" { |
184 | incr i |
185 | set a [lindex $argv $i] |
186 | if {[catch { elite-unpackcmdr cmdr [read-file $a] } err]} { |
187 | puts stderr "$argv0: couldn't read `$a': $err" |
188 | exit 1 |
189 | } |
190 | } |
191 | "^-save$" { |
192 | incr i |
193 | set a [lindex $argv $i] |
194 | if {[catch { write-file $a [elite-packcmdr cmdr] } err]} { |
195 | puts stderr "$argv0: couldn't write `$a': $err" |
196 | exit 1 |
197 | } |
198 | set acted 1 |
199 | } |
200 | "^-dump$" { |
201 | puts "# {Elite commander dump}" |
202 | puts "" |
203 | foreach a $attrs { |
204 | puts [list $a [eval \ |
205 | dump/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]] |
206 | } |
207 | set acted 1 |
208 | } |
209 | "^-read$" { |
210 | incr i |
211 | set a [lindex $argv $i] |
212 | if {[catch { |
213 | foreach {a v} [read-file $a auto] { |
214 | if {![info exists attr($a)]} { |
215 | error "no such attribute `$a'" |
216 | } |
217 | eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v] |
218 | } |
219 | } err]} { |
220 | puts stderr "$argv0: error in script: $err" |
221 | exit 1 |
222 | } |
223 | } |
224 | "^-" { |
225 | puts stderr "$argv0: unknown option `$a'" |
226 | exit 1 |
227 | } |
228 | "^[a-z][a-z-]*=" { |
229 | regexp {^([a-z][a-z-]*)=(.*)$} $a . a v |
230 | if {![info exists attr($a)]} { |
231 | puts stderr "$argv0: no such attribute `$a'" |
232 | exit 1 |
233 | } |
234 | if {[catch { |
235 | eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v] |
236 | } err]} { |
237 | puts stderr "$argv0: error setting `$a': $err" |
238 | exit 1 |
239 | } |
240 | } |
241 | "^[a-z][a-z-]*$" { |
242 | if {![info exists attr($a)]} { |
243 | puts stderr "$argv0: no such attribute `$a'" |
244 | exit 1 |
245 | } |
246 | puts [format "%-20s %s" $a [eval \ |
247 | get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]] |
7f50b5a8 |
248 | set acted 1 |
1ded87ba |
249 | } |
250 | default { |
251 | if {[catch { elite-unpackcmdr cmdr [read-file $a] } err]} { |
252 | puts stderr "$argv0: couldn't read `$a': $err" |
253 | exit 1 |
254 | } |
255 | } |
256 | } |
257 | } |
258 | if {!$acted} { |
259 | foreach a $attrs { |
260 | puts [format "%-20s %s" $a [eval \ |
261 | get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]] |
262 | } |
263 | } |