chiark - git - mdw - rocl/blob - elite-cmdr

   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 --------------------------------------------------