| 1 | #! /usr/bin/tclsh |
| 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. |
| 23 | |
| 24 | package require "elite" "1.0.1" |
| 25 | |
| 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] |
| 42 | } |
| 43 | |
| 44 | ## string -- just a plain unconverted string. |
| 45 | proc get/string {a} { global cmdr; return $cmdr($a) } |
| 46 | dump-like-get string |
| 47 | proc set/string {a v} { global cmdr; set cmdr($a) $v } |
| 48 | |
| 49 | ## int MIN MAX -- an integer constrained to lie between the stated |
| 50 | ## (inclusive) bounds. |
| 51 | proc get/int {min max a} { |
| 52 | global cmdr |
| 53 | return [format "%d" [expr {$cmdr($a) + 0}]] |
| 54 | } |
| 55 | dump-like-get int |
| 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 | |
| 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} { |
| 66 | global cmdr |
| 67 | return [format "%.1f" [expr {$cmdr($a)/10.0}]] |
| 68 | } |
| 69 | dump-like-get tenth |
| 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 | |
| 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. |
| 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 | |
| 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) } |
| 108 | dump-like-get seed |
| 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 | |
| 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. |
| 119 | proc get/world {a} { |
| 120 | global cmdr gov eco |
| 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}]] |
| 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 |
| 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)" |
| 140 | } |
| 141 | elite-worldinfo p $s |
| 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 | } |
| 148 | set cmdr(world-x) [expr {$p(x)/4}] |
| 149 | set cmdr(world-y) [expr {$p(y)/2}] |
| 150 | } |
| 151 | |
| 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} { |
| 155 | global cmdr |
| 156 | if {$cmdr($a)} { return "yes" } else { return "no" } |
| 157 | } |
| 158 | dump-like-get bool |
| 159 | proc set/bool {dfl a v} { |
| 160 | global cmdr |
| 161 | switch -- [string tolower $v] { |
| 162 | "y" - "yes" - "true" - "on" - "t" { set v 1 } |
| 163 | "n" - "no" - "false" - "off" - "nil" { set v 0 } |
| 164 | } |
| 165 | if {$v} { set cmdr($a) $dfl } else { set cmdr($a) 0 } |
| 166 | } |
| 167 | |
| 168 | ## comment -- a pseudo-type for discarding commnts in input files. |
| 169 | proc set/comment {a v} { } |
| 170 | |
| 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. |
| 176 | set attrs {} |
| 177 | |
| 178 | ## Comment magic. |
| 179 | set attr(\#) { comment } |
| 180 | |
| 181 | ## Basic attributes. |
| 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 } |
| 190 | legal-status { choice 0 255 |
| 191 | { "clean" 0 "offender" 1 "fugitive" 50 } } |
| 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 | } |
| 204 | |
| 205 | ## Lasers. |
| 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 | } |
| 213 | |
| 214 | ## Standard boolean properties. |
| 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 | } |
| 221 | |
| 222 | ## Station and hold produce. |
| 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 | |
| 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 | |
| 267 | set acted 0 |
| 268 | for {set i 0} {$i < [llength $argv]} {incr i} { |
| 269 | set a [lindex $argv $i] |
| 270 | switch -regexp -- $a { |
| 271 | |
| 272 | "^-reset$" { |
| 273 | ## Reset the commander back to Jameson. |
| 274 | |
| 275 | jameson cmdr |
| 276 | } |
| 277 | |
| 278 | "^-show$" { |
| 279 | ## Produce a human-readable description of the commander. |
| 280 | |
| 281 | show-attrs "*" |
| 282 | set acted 1 |
| 283 | } |
| 284 | |
| 285 | "^-load$" { |
| 286 | ## Load a commander file. |
| 287 | |
| 288 | incr i |
| 289 | set a [lindex $argv $i] |
| 290 | load-file $a |
| 291 | } |
| 292 | |
| 293 | "^-save$" { |
| 294 | ## Write the commander to a file. |
| 295 | |
| 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 | } |
| 304 | |
| 305 | "^-dump$" { |
| 306 | ## Dump a machine-readable textual description of the commander. |
| 307 | |
| 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 | } |
| 316 | |
| 317 | "^-read$" { |
| 318 | ## Read back a description produced by `-dump'. |
| 319 | |
| 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 | } |
| 334 | |
| 335 | "^-" { |
| 336 | ## An unknown option. |
| 337 | |
| 338 | puts stderr "$argv0: unknown option `$a'" |
| 339 | exit 1 |
| 340 | } |
| 341 | |
| 342 | "^[a-z][a-z-]*=" { |
| 343 | ## An assignment ATTR=VALUE. |
| 344 | |
| 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 | } |
| 357 | |
| 358 | default { |
| 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]} { |
| 363 | set acted 1 |
| 364 | } else { |
| 365 | load-file $a |
| 366 | } |
| 367 | } |
| 368 | } |
| 369 | } |
| 370 | |
| 371 | ## If we didn't do anything, write out a description of the file. |
| 372 | if {!$acted} { |
| 373 | show-attrs "*" |
| 374 | } |
| 375 | |
| 376 | ###----- That's all, folks -------------------------------------------------- |