chiark / gitweb /
Fix output formatting a little.
[rocl] / elite-cmdr
1 #! /usr/bin/tclsh
2
3 package require "elite" "1.0.1"
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 [elite-galaxylist $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
93   set ww [elite-galaxylist $cmdr(gal-seed)]
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
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   }
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   legal-status          { choice 0 255
140                           { "clean" 0 "offender" 1 "fugitive" 50 } }
141   cargo                 { int 4 255 }
142   gal-number            { int 1 8 }
143   gal-seed              { seed }
144   world                 { world }
145   market-fluc           { int 0 255 }
146   missiles              { int 0 255 }
147   fuel                  { tenth 0 25.5 }
148   energy-unit           { choice 0 255 { "none" 0 "standard" 1 "naval" 2 } }
149 } {
150   set attr($a) $type
151   lappend attrs $a
152 }
153 foreach l {front rear left right} {
154   set attr($l-laser) {
155     choice 0 255
156     { "none" 0 "pulse" 0x0f "mining" 0x32 "beam" 0x8f "military" 0x97 }
157   }
158   lappend attrs $l-laser
159 }
160 foreach i {
161   ecm fuel-scoop energy-bomb escape-pod docking-computer gal-hyperdrive
162 } {
163   set attr($i) { bool 255 }
164   lappend attrs $i
165 }
166 foreach l {station hold} {
167   foreach {t p} $products {
168     set attr($l-$t) { int 0 255 }
169     lappend attrs $l-$t
170   }
171 }
172
173 set acted 0
174 for {set i 0} {$i < [llength $argv]} {incr i} {
175   set a [lindex $argv $i]
176   switch -regexp -- $a {
177     "^-reset$" { jameson cmdr }
178     "^-show$" {
179       foreach a $attrs {
180         puts [format "%-20s %s" $a [eval \
181             get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
182       }
183       set acted 1
184     }
185     "^-load$" {
186       incr i
187       set a [lindex $argv $i]
188       if {[catch { elite-unpackcmdr cmdr [read-file $a] } err]} {
189         puts stderr "$argv0: couldn't read `$a': $err"
190         exit 1
191       }
192     }
193     "^-save$" {
194       incr i
195       set a [lindex $argv $i]
196       if {[catch { write-file $a [elite-packcmdr cmdr] } err]} {
197         puts stderr "$argv0: couldn't write `$a': $err"
198         exit 1
199       }
200       set acted 1
201     }
202     "^-dump$" {
203       puts "# {Elite commander dump}"
204       puts ""
205       foreach a $attrs {
206         puts [list $a [eval \
207             dump/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
208       }
209       set acted 1
210     }
211     "^-read$" {
212       incr i
213       set a [lindex $argv $i]
214       if {[catch {
215         foreach {a v} [read-file $a auto] {
216           if {![info exists attr($a)]} {
217             error "no such attribute `$a'"
218           }
219           eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
220         }
221       } err]} {
222         puts stderr "$argv0: error in script: $err"
223         exit 1
224       }
225     }
226     "^-" {
227       puts stderr "$argv0: unknown option `$a'"
228       exit 1
229     }
230     "^[a-z][a-z-]*=" {
231       regexp {^([a-z][a-z-]*)=(.*)$} $a . a v
232       if {![info exists attr($a)]} {
233         puts stderr "$argv0: no such attribute `$a'"
234         exit 1
235       }
236       if {[catch {
237         eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
238       } err]} {
239         puts stderr "$argv0: error setting `$a': $err"
240         exit 1
241       }
242     }
243     default {
244       set n 0
245       foreach aa $attrs {
246         if {[string match $a $aa]} {
247           incr n
248           puts [format "%-20s %s" $aa [eval \
249               get/[lindex $attr($aa) 0] \
250               [lrange $attr($aa) 1 end] [list $aa]]]
251         }
252       }
253       if {$n} {
254         set acted 1
255       } else {
256         if {[catch { elite-unpackcmdr cmdr [read-file $a] } err]} {
257           puts stderr "$argv0: couldn't read `$a': $err"
258           exit 1
259         }
260       }
261     }
262   }
263 }
264 if {!$acted} {
265   foreach a $attrs {
266     puts [format "%-20s %s" $a [eval \
267         get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
268   }
269 }