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   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]]]
 248       set acted 1
 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 }