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

   1 #! /usr/bin/tclsh
   2
   3 package require "elite" "1.0.0"
   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 [worldinfo $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 s [parse-planet-spec $cmdr(gal-seed) $v]
  94   if {[string equal $s ""]} { error "bad planet spec `$v'" }
  95   if {![in-galaxy-p $cmdr(gal-seed) $s]} {
  96     error "planet `[worldname $s]' not in galaxy $cmdr(gal-seed)"
  97   }
  98   elite-worldinfo p $s
  99   set cmdr(world-x) [expr {$p(x)/4}]
 100   set cmdr(world-y) [expr {$p(y)/2}]
 101 }
 102
 103 proc get/bool {dfl a} {
 104   global cmdr
 105   if {$cmdr($a)} { return "yes" } else { return "no" }
 106 }
 107 proc dump/bool {dfl a} {
 108   global cmdr
 109   if {$cmdr($a)} { return "yes" } else { return "no" }
 110 }
 111 proc set/bool {dfl a v} {
 112   global cmdr
 113   switch -- [string tolower $v] {
 114     "y" - "yes" - "true" - "on" { set v 1 }
 115     "n" - "no" - "false" - "off" { set v 0 }
 116   }
 117   if {$v} { set cmdr($a) $dfl } else { set cmdr($a) 0 }
 118 }
 119
 120 proc set/comment {a v} { }
 121
 122 set attrs {}
 123 set attr(\#) { comment }
 124 foreach {a type} {
 125   mission               { int 0 255 }
 126   score                 { choice 0 65535 {
 127     "harmless" 0 "mostly-harmless" 8 "poor" 16 "average" 32
 128     "above-average" 64 "competent" 128 "dangerous" 512 "deadly" 2560
 129     "elite" 6400
 130   } }
 131   credits               { tenth 0 429496729.5 }
 132   cargo                 { int 4 255 }
 133   gal-number            { int 1 8 }
 134   gal-seed              { seed }
 135   world                 { world }
 136   market-fluc           { int 0 255 }
 137   missiles              { int 0 255 }
 138   fuel                  { tenth 0 25.5 }
 139   energy-unit           { choice 0 255 { "none" 0 "standard" 1 "naval" 2 } }
 140 } {
 141   set attr($a) $type
 142   lappend attrs $a
 143 }
 144 foreach l {front rear left right} {
 145   set attr($l-laser) {
 146     choice 0 255
 147     { "none" 0 "pulse" 0x0f "mining" 0x32 "beam" 0x8f "military" 0x97 }
 148   }
 149   lappend attrs $l-laser
 150 }
 151 foreach i {
 152   ecm fuel-scoop energy-bomb escape-pod docking-computer gal-hyperdrive
 153 } {
 154   set attr($i) { bool 255 }
 155   lappend attrs $i
 156 }
 157 foreach l {station hold} {
 158   foreach {t p} $products {
 159     set attr($l-$t) { int 0 255 }
 160     lappend attrs $l-$t
 161   }
 162 }
 163
 164 set acted 0
 165 for {set i 0} {$i < [llength $argv]} {incr i} {
 166   set a [lindex $argv $i]
 167   switch -regexp -- $a {
 168     "^-reset$" { jameson cmdr }
 169     "^-show$" {
 170       foreach a $attrs {
 171         puts [format "%-20s %s" $a [eval \
 172             get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
 173       }
 174       set acted 1
 175     }
 176     "^-load$" {
 177       incr i
 178       set a [lindex $argv $i]
 179       if {[catch { elite-unpackcmdr cmdr [read-file $a] } err]} {
 180         puts stderr "$argv0: couldn't read `$a': $err"
 181         exit 1
 182       }
 183     }
 184     "^-save$" {
 185       incr i
 186       set a [lindex $argv $i]
 187       if {[catch { write-file $a [elite-packcmdr cmdr] } err]} {
 188         puts stderr "$argv0: couldn't write `$a': $err"
 189         exit 1
 190       }
 191       set acted 1
 192     }
 193     "^-dump$" {
 194       puts "# {Elite commander dump}"
 195       puts ""
 196       foreach a $attrs {
 197         puts [list $a [eval \
 198             dump/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
 199       }
 200       set acted 1
 201     }
 202     "^-read$" {
 203       incr i
 204       set a [lindex $argv $i]
 205       if {[catch {
 206         foreach {a v} [read-file $a auto] {
 207           if {![info exists attr($a)]} {
 208             error "no such attribute `$a'"
 209           }
 210           eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
 211         }
 212       } err]} {
 213         puts stderr "$argv0: error in script: $err"
 214         exit 1
 215       }
 216     }
 217     "^-" {
 218       puts stderr "$argv0: unknown option `$a'"
 219       exit 1
 220     }
 221     "^[a-z][a-z-]*=" {
 222       regexp {^([a-z][a-z-]*)=(.*)$} $a . a v
 223       if {![info exists attr($a)]} {
 224         puts stderr "$argv0: no such attribute `$a'"
 225         exit 1
 226       }
 227       if {[catch {
 228         eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
 229       } err]} {
 230         puts stderr "$argv0: error setting `$a': $err"
 231         exit 1
 232       }
 233     }
 234     "^[a-z][a-z-]*$" {
 235       if {![info exists attr($a)]} {
 236         puts stderr "$argv0: no such attribute `$a'"
 237         exit 1
 238       }
 239       puts [format "%-20s %s" $a [eval \
 240           get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
 241       set acted 1
 242     }
 243     default {
 244       if {[catch { elite-unpackcmdr cmdr [read-file $a] } err]} {
 245         puts stderr "$argv0: couldn't read `$a': $err"
 246         exit 1
 247       }
 248     }
 249   }
 250 }
 251 if {!$acted} {
 252   foreach a $attrs {
 253     puts [format "%-20s %s" $a [eval \
 254         get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
 255   }
 256 }