Release 1.1.6.

[rocl] / elite-cmdr

#! /usr/bin/tclsh
###
### Commander file inspector
###
### (c) 2003 Mark Wooding
###

###----- Licensing notice ---------------------------------------------------
###
### This program is free software; you can redistribute it and/or modify
### it under the terms of the GNU General Public License as published by
### the Free Software Foundation; either version 2 of the License, or
### (at your option) any later version.
###
### This program is distributed in the hope that it will be useful,
### but WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
### GNU General Public License for more details.
###
### You should have received a copy of the GNU General Public License
### along with this program; if not, write to the Free Software Foundation,
### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

package require "elite" "1.0.1"

###--------------------------------------------------------------------------
### Various type handlers.
###
### We associate a named type and some optional (type-specific) parameters
### with each attribute in the commander file format.  For each TYPE, there
### are Tcl procedures:
###
### get/TYPE [PARAM ...] A -- return presentation form of the attribute A
### dump/TYPE [PARAM ...] A -- return an external form of the attribute A
### set/TYPE [PARAM ...] A V -- convert V from presentation form and store
###	as the attribute A

proc dump-like-get {type} {
  ## Define dump/TYPE as a synonym for get/TYPE.

  proc dump/$type {args} [list uplevel 1 get/$type \$args]
}

## string -- just a plain unconverted string.
proc get/string {a} { global cmdr; return $cmdr($a) }
dump-like-get string
proc set/string {a v} { global cmdr; set cmdr($a) $v }

## int MIN MAX -- an integer constrained to lie between the stated
##	(inclusive) bounds.
proc get/int {min max a} {
  global cmdr
  return [format "%d" [expr {$cmdr($a) + 0}]]
}
dump-like-get int
proc set/int {min max a v} {
  global cmdr
  if {$v < $min || $v > $max} { error "value out of range" }
  set cmdr($a) $v
}

## tenth MIN MAX -- a numerical value constrained to lie between the stated
## inclusive bounds; the internal format is an integer containing ten times
## the presentation value.
proc get/tenth {min max a} {
  global cmdr
  return [format "%.1f" [expr {$cmdr($a)/10.0}]]
}
dump-like-get tenth
proc set/tenth {min max a v} {
  global cmdr
  if {$v < $min || $v > $max} { error "value out of range" }
  set cmdr($a) [expr {int($v * 10)}]
}

## choice MIN MAX L -- the presentation form is either an integer between the
##	given inclusive bounds, or a token matching one of the items in the
##	list L; the internal form is the integer, or the index of the token
##	in the list.
proc get/choice {min max l a} {
  global cmdr
  set x "custom"
  foreach {t v} $l { if {$cmdr($a) >= $v} { set x $t } }
  return [format "%d (%s)" [expr {$cmdr($a) + 0}] $x]
}
proc dump/choice {min max l a} {
  global cmdr
  return [format "%d" [expr {$cmdr($a) + 0}]]
}
proc set/choice {min max l a v} {
  global cmdr
  if {[regexp {^\d+$} $v]} {
    if {$v < $min || $v > $max} { error "value out of range" }
  } else {
    set x $v
    set v -1
    foreach {t vv} $l {
      if {[string equal -nocase $x $t]} { set v $vv; break }
    }
    if {$v == -1} { error "unknown tag `$x'" }
  }
  set cmdr($a) $v
}

## seed -- a galaxy seed; any valid galaxy spec is permitted as the
##	presentation form.
proc get/seed {a} { global cmdr; return $cmdr($a) }
dump-like-get seed
proc set/seed {a v} {
  global cmdr
  set s [parse-galaxy-spec $v]
  if {[string equal $s ""]} { error "bad galaxy spec `$v'" }
  destructure [list . cmdr($a)] $s
}

## world -- a planet identifier; on input, any planet spec is permitted
##	(relative to the commander's established galaxy), and on output a
##	summary description is produced.
proc get/world {a} {
  global cmdr gov eco
  set ww [elite-galaxylist $cmdr(gal-seed)]
  set s [nearest-planet $ww \
      [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
  elite-worldinfo p $s
  return [list $p(name) $p(x) $p(y) $eco($p(economy)) $gov($p(government)) \
      $p(techlevel)]
}
proc dump/world {a} {
  global cmdr
  return [format "%d, %d" \
      [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
}
proc set/world {a v} {
  global cmdr
  set ww [elite-galaxylist $cmdr(gal-seed)]
  set s [parse-planet-spec $cmdr(gal-seed) $v]
  if {[string equal $s ""]} { error "bad planet spec `$v'" }
  if {![in-galaxy-p $cmdr(gal-seed) $s]} {
    error "planet `[worldname $s]' not in galaxy $cmdr(gal-seed)"
  }
  elite-worldinfo p $s
  set ss [nearest-planet $ww $p(x) $p(y)]
  if {![string equal $s $ss]} {
    set n $p(name)
    elite-worldinfo p $ss
    puts stderr "can't dock at $n: $p(name) is coincident"
  }
  set cmdr(world-x) [expr {$p(x)/4}]
  set cmdr(world-y) [expr {$p(y)/2}]
}

## bool DFL -- internal form is either zero or DFL; external form is one of a
##	number of standard boolean tokens.
proc get/bool {dfl a} {
  global cmdr
  if {$cmdr($a)} { return "yes" } else { return "no" }
}
dump-like-get bool
proc set/bool {dfl a v} {
  global cmdr
  switch -- [string tolower $v] {
    "y" - "yes" - "true" - "on" - "t" { set v 1 }
    "n" - "no" - "false" - "off" - "nil" { set v 0 }
  }
  if {$v} { set cmdr($a) $dfl } else { set cmdr($a) 0 }
}

## comment -- a pseudo-type for discarding commnts in input files.
proc set/comment {a v} { }

###--------------------------------------------------------------------------
### Attribute table.

### The `attr' array maps commander attribute names to TYPE [PARAM ...]
### lists; the `attrs' list contains the names in a canonical order.
set attrs {}

## Comment magic.
set attr(\#) { comment }

## Basic attributes.
foreach {a type} {
  mission		{ int 0 255 }
  score			{ choice 0 65535 {
    "harmless" 0 "mostly-harmless" 8 "poor" 16 "average" 32
    "above-average" 64 "competent" 128 "dangerous" 512 "deadly" 2560
    "elite" 6400
  } }
  credits		{ tenth 0 429496729.5 }
  legal-status		{ choice 0 255
			  { "clean" 0 "offender" 1 "fugitive" 50 } }
  cargo			{ int 4 255 }
  gal-number		{ int 1 8 }
  gal-seed		{ seed }
  world			{ world }
  market-fluc		{ int 0 255 }
  missiles		{ int 0 255 }
  fuel			{ tenth 0 25.5 }
  energy-unit		{ choice 0 255 { "none" 0 "standard" 1 "naval" 2 } }
} {
  set attr($a) $type
  lappend attrs $a
}

## Lasers.
foreach l {front rear left right} {
  set attr($l-laser) {
    choice 0 255
    { "none" 0 "pulse" 0x0f "mining" 0x32 "beam" 0x8f "military" 0x97 }
  }
  lappend attrs $l-laser
}

## Standard boolean properties.
foreach i {
  ecm fuel-scoop energy-bomb escape-pod docking-computer gal-hyperdrive
} {
  set attr($i) { bool 255 }
  lappend attrs $i
}

## Station and hold produce.
foreach l {station hold} {
  foreach {t p} $products {
    set attr($l-$t) { int 0 255 }
    lappend attrs $l-$t
  }
}

###--------------------------------------------------------------------------
### Main program.

jameson cmdr

## Parse the command-line.
if {[llength $argv] < 1} {
  puts stderr "usage: $argv0 \[-OPTION | ATTR | ATTR=VALUE\] ..."
  exit 1
}

proc show-attrs {pat} {
  ## Show the attributes whose names match the glob pattern PAT.  Return the
  ## number of matches.

  global attr attrs
  set n 0
  foreach a $attrs {
    if {[string match $pat $a]} {
      puts [format "%-20s %s" $a [eval \
	  get/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
      incr n
    }
  }
  return $n
}

proc load-file {file} {
  ## Load FILE as a commander.

  global argv0 cmdr
  if {[catch { elite-unpackcmdr cmdr [read-file $file] } err]} {
    puts stderr "$argv0: couldn't read `$file': $err"
    exit 1
  }
}

set acted 0
for {set i 0} {$i < [llength $argv]} {incr i} {
  set a [lindex $argv $i]
  switch -regexp -- $a {

    "^-reset$" {
      ## Reset the commander back to Jameson.

      jameson cmdr
    }

    "^-show$" {
      ## Produce a human-readable description of the commander.

      show-attrs "*"
      set acted 1
    }

    "^-load$" {
      ## Load a commander file.

      incr i
      set a [lindex $argv $i]
      load-file $a
    }

    "^-save$" {
      ## Write the commander to a file.

      incr i
      set a [lindex $argv $i]
      if {[catch { write-file $a [elite-packcmdr cmdr] } err]} {
	puts stderr "$argv0: couldn't write `$a': $err"
	exit 1
      }
      set acted 1
    }

    "^-dump$" {
      ## Dump a machine-readable textual description of the commander.

      puts "# {Elite commander dump}"
      puts ""
      foreach a $attrs {
	puts [list $a [eval \
	    dump/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a]]]
      }
      set acted 1
    }

    "^-read$" {
      ## Read back a description produced by `-dump'.

      incr i
      set a [lindex $argv $i]
      if {[catch {
	foreach {a v} [read-file $a auto] {
	  if {![info exists attr($a)]} {
	    error "no such attribute `$a'"
	  }
	  eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
	}
      } err]} {
	puts stderr "$argv0: error in script: $err"
	exit 1
      }
    }

    "^-" {
      ## An unknown option.

      puts stderr "$argv0: unknown option `$a'"
      exit 1
    }

    "^[a-z][a-z-]*=" {
      ## An assignment ATTR=VALUE.

      regexp {^([a-z][a-z-]*)=(.*)$} $a . a v
      if {![info exists attr($a)]} {
	puts stderr "$argv0: no such attribute `$a'"
	exit 1
      }
      if {[catch {
	eval set/[lindex $attr($a) 0] [lrange $attr($a) 1 end] [list $a $v]
      } err]} {
	puts stderr "$argv0: error setting `$a': $err"
	exit 1
      }
    }

    default {
      ## If the argument matches any attribute names, then print the matching
      ## attributes; otherwise load the named file.

      if {[show-attrs $a]} {
	set acted 1
      } else {
	load-file $a
      }
    }
  }
}

## If we didn't do anything, write out a description of the file.
if {!$acted} {
  show-attrs "*"
}

###----- That's all, folks --------------------------------------------------