chiark - git - mdw - rocl/blob - 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 }