Use `auto-version' for discovering the package version.

[rocl] / elite.tcl

### -*-tcl-*-
###
### Common Elite hacking functions
###
### (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-bits" "1.0.1"

###--------------------------------------------------------------------------
### Internal utilities.

proc _tab {arr args} {
  ## _tab ARR NAME NAME ... ---
  ##
  ## Construct an array mapping integers 0, 1, ... to the given NAMEs, in
  ## order.

  upvar 1 $arr a
  set i 0
  foreach v $args {
    set a($i) $v
    incr i
  }
}

###--------------------------------------------------------------------------
### Magic constants and tables.

set galaxy1 "4a5a480253b7"		;# Seed for standard galaxy 1

## Government types.
_tab government \
    "anarchy" "feudal" "multi-government" "dictatorship" \
    "communist" "confederacy" "democracy" "corporate state"

## Economy types.
_tab economy \
    "rich industrial" "average industrial" "poor industrial" \
    "mainly industrial" "mainly agricultural" "rich agricultural" \
    "average agricultural" "poor agricultural"

## Abbreviated government types.
_tab gov \
    anarchy feudal multi-gov dictator \
    communist confed democracy corp-state

## Abbreviated economy types.
_tab eco \
    rich-ind avg-ind poor-ind mainly-ind \
    mainly-agri rich-agri avg-agri poor-agri

## Two-letter government and economy types.
_tab gv Ay Fl MG Dp Ct Cy Dy CS
_tab ec RI AI PI MI MA RA AA PA

## Products for trading.
set products {
  food		"Food"
  textiles	"Textiles"
  radioactives	"Radioactives"
  slaves	"Slaves"
  liquor-wines	"Liquor & wines"
  luxuries	"Luxuries"
  narcotics	"Narcotics"
  computers	"Computers"
  machinery	"Machinery"
  alloys	"Alloys"
  firearms	"Firearms"
  furs		"Furs"
  minerals	"Minerals"
  gold		"Gold"
  platinum	"Platinum"
  gem-stones	"Gem-stones"
  alien-items	"Alien items"
}

foreach p $products { set unit($p) t }
foreach p {gold platinum} { set unit($p) kg }
set unit(gem-stones) g
unset p

###--------------------------------------------------------------------------
### External functions.

proc galaxy [list n [list g $galaxy1]] {
  ## Compute the seed of the Nth galaxy, if G is the seed of galaxy 1.  By
  ## default, G is the standard galaxy 1 seed.

  for {set i 1} {$i < $n} {incr i} {
    set g [elite-nextgalaxy $g]
  }
  return $g
}

proc foreach-world {g p act} {
  ## For each world in galaxy G (a seed), set P to the world information and
  ## evaluate ACT.  The usual loop control commands can be used in ACT.
  upvar 1 $p pp
  for {set i 0} {$i < 256} {incr i; set g [elite-nextworld $g]} {
    elite-worldinfo pp $g
    uplevel 1 $act
  }
}

proc find-world {g pat} {
  ## Return a list of seeds for the worlds in galaxy G (a seed) whose names
  ## match the glob pattern PAT.

  set l {}
  foreach-world $g p {
    if {[string match -nocase $pat $p(name)]} {
      lappend l $p(seed)
    }
  }
  return $l
}

proc destructure {pp xx} {
  ## Destrcture an object XX according to the pattern PP.  If PP is a single
  ## name, set the variable PP to XX; otherwise, if PP is a list, each of its
  ## elements must correspond to an element of the list XX, so recursively
  ## destructure the corresponding elements of each.  It is not an error if
  ## the PP list is shorter than XX.  The special variable name `.' indicates
  ## that no assignment is to be made.

  if {![string compare $pp "."]} {
    return
  } elseif {[llength $pp] == 0} {
    return
  } elseif {[llength $pp] == 1} {
    upvar 1 $pp p
    set p $xx
  } else {
    foreach p $pp x $xx {
      uplevel 1 [list destructure $p $x]
    }
  }
}

proc write-file {name contents {trans binary}} {
  ## Write file NAME, storing CONTENTS translated according to TRANS (default
  ## `binary'.  The write is safe against errors -- we don't destroy the old
  ## data until the file is written.

  if {[file exists $name]} {
    if {[set rc [catch { file copy -force $name "$name.old" } err]]} {
      return -code $rc $err
    }
  }
  if {[set rc [catch {
    set f [open $name w]
    fconfigure $f -translation $trans
    puts -nonewline $f $contents
    close $f
  } err]]} {
    catch { close $f }
    catch { file rename -force "$name.old" $name }
    return -code $rc $err
  }
  return ""
}

proc read-file {name {trans binary}} {
  ## Read the contents of the file NAME, translating it according to TRANS
  ## (default `binary').

  set f [open $name]
  fconfigure $f -translation $trans
  set c [read $f]
  close $f
  return $c
}

proc nearest-planet {ww x y} {
  ## Returns the seed of the `nearest' planet given in the worldinfo list WW
  ## to the point X Y (in decilightyears).

  set min 10000
  foreach {ss xx yy} $ww {
    set dx [expr {abs($x - $xx)/4}]
    set dy [expr {abs($y - $yy)/2}]
    if {$dx > $dy} {
      set d [expr {($dx * 2 + $dy)/2}]
    } else {
      set d [expr {($dx + $dy * 2)/2}]
    }
    if {$d < $min} {
      set p $ss
      set min $d
    }
  }
  return $p
}

proc worldname {w} {
  ## Returns the name of the world with seed W.

  elite-worldinfo p $w
  return $p(name)
}

proc shortest-path {adjvar from to weight} {
  ## Computes the shortest path and shortest distance between the worlds wose
  ## seeds are FROM and TO respectively.  ADJVAR must be the name of a
  ## variable holding an adjacency table for the galaxy containing FROM and
  ## TO.  WEIGHT is a command such that WEIGHT A B returns the `distance' for
  ## the simple path between A and B.  The return value is a list P D, where
  ## D is the weight of the path found, and P is a simple list of seeds for
  ## the worlds on the path.  P starts with FROM and ends with TO.

  upvar 1 $adjvar adj
  if {[string equal $from $to]} { return [list $to 0] }
  set l($from) 0
  set p($from) $from
  set c $from
  while 1 {
    foreach {n x y} $adj($c) {
      if {[info exists l($n)]} {
	continue
      }
      set w [expr {$l($c) + [uplevel 1 $weight [list $c $n]]}]
      if {![info exists ll($n)] || $w < $ll($n)} {
	set ll($n) $w
	set p($n) [concat $p($c) [list $n]]
      }
    }
    set s [array startsearch ll]
    if {![array anymore ll $s]} {
      return {{} 0}
    }
    set c [array nextelement ll $s]
    set w $ll($c)
    while {[array anymore ll $s]} {
      set n [array nextelement ll $s]
      if {$ll($n) < $w} {
	set c $n
	set w $ll($n)
      }
    }
    if {[string equal $c $to]} { return [list $p($to) $ll($to)] }
    set l($c) $ll($c)
    unset ll($c)
  }
}

proc weight-hops {from to} {
  ## shortest-path weight function giving each hop the same weight.
  return 1
}

proc weight-fuel {from to} {
  ## shortest-path weight function measuring the distance between FROM and
  ## TO.

  elite-worldinfo f $from
  elite-worldinfo t $to
  return [elite-distance $f(x) $f(y) $t(x) $t(y)]
}

proc weight-safety {from to} {
  ## shortest-path weight function attempting to maximize safety of the
  ## journey by giving high weight (square-law) to worlds with unstable
  ## governments.

  elite-worldinfo t $to
  set w [expr {8 - $t(government)}]
  return [expr {$w * $w}]
}

proc weight-encounters {from to} {
  ## shortest-path weight function attempting to maximize encounters on the
  ## journey by giving high weight (square law) to worlds with stable
  ## governments.

  elite-worldinfo f $from
  elite-worldinfo t $to
  set w [expr {1 + $t(government)}]
  return [expr {$w * $w}]
}

proc weight-trading {from to} {
  ## shortest-path weight function attempting to maximize trading
  ## opportunities along the journey by giving high weight (square law) to
  ## pairs of worlds with small differences between their economic statuses.

  elite-worldinfo f $from
  elite-worldinfo t $to
  set w [expr {8 - abs($f(economy) - $t(economy))}]
  return [expr {$w * $w}]
}

proc parse-galaxy-spec {g} {
  ## Parses a galaxy spec and returns a list containing a description of the
  ## galaxy and the corresponding galaxy seed.  A galaxy spec is one of:
  ##
  ##   * a number between 1 and 8, corresponding to one of the standard
  ##     galaxies;
  ##
  ##   * a 12-digit hex string, which is a galaxy seed (and is returned
  ##     unchanged); or
  ##
  ##   * a string of the form S:N where S is a 12-hex-digit seed and N is a
  ##     galaxy number, corresponding to the Nth galaxy starting with S as
  ##     galaxy 1.
  ##
  ## If the string is unrecognized, an empty list is returned.

  switch -regexp -- $g {
    {^[1-8]$} { return [list $g [galaxy $g]] }
    {^[0-9a-fA-F]{12}$} { return [list $g $g] }
    default {
      if {[regexp {^([0-9a-fA-F]{12}):([1-8])$} $g . b n]} {
	return [list $g [galaxy $n $b]]
      }
    }
  }
  return {}
}

proc parse-planet-spec {g p} {
  ## Parses a planet spec and returns the planet seed.  The planet spec P is
  ## interpreted relative to galaxy G.  A planet spec is one of:
  ##
  ##   * a simple integer, corresponding to a planet number;
  ##
  ##   * a 12-hex-digit seed, which is returned unchanged;
  ##
  ##   * a pair of integers separated by commas, corresponding to the nearest
  ##	 planet to those coordinates;
  ##
  ##   * a glob pattern, corresponding to the lowest-numbered planet in the
  ##     galaxy whose name matches the pattern case-insensitively; or
  ##
  ##   * a string of the form G.P where G is a galaxy spec and P is a planet
  ##	 spec, corresponding to the planet specified by P relative to galaxy
  ##	 G.
  ##
  ## If the string is unrecognized, an empty string is returned.

  if {[regexp {^[0-9a-fA-F]{12}$} $p]} { return $p }
  if {[regexp {^(.+)\.(.+)$} $p . g p]} {
    set g [parse-galaxy-spec $g]
    if {[string equal $g ""]} { return {} }
    destructure {. g} $g
    return [parse-planet-spec $g $p]
  }
  if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+)$} $p]} {
    for {set s $g; set i 0} {$i < $p} {incr i; set s [elite-nextworld $s]} {}
    return $s
  }
  if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+),\s*(0x[0-9a-fA-F]+|[0-9]+)$} \
      $p . x y]} {
    return [nearest-planet [elite-galaxylist $g] $x $y]
  }
  if {[regexp {^([^/]*)(?:/([1-9]\d*))?$} $p . p i]} {
    if {[string equal $i ""]} { set i 1 }
    set l [find-world $g $p]
    if {$i <= [llength $l]} { return [lindex $l [expr {$i - 1}]] }
  }
  return {}
}

proc in-galaxy-p {g pp} {
  ## Returns nonzero if the planets (seeds) listed in PP are in galaxy G.
  ## Doesn't mind if the planet seeds are invalid.

  foreach-world $g i { set x($i(seed)) 1 }
  foreach p $pp { if {![info exists x($p)]} { return 0 } }
  return 1
}

proc world-summary {s {ind 0} {spc 0}} {
  ## Return a one-line summary string for planet S.  IND and SPC are numbers
  ## of additional spaces to insert at the start of the line and after the
  ## planet name, respectively.

  global eco gov
  elite-worldinfo p $s
  set is [string repeat " " $ind]
  set ss [string repeat " " $spc]
  return [format "%s%-8s%s %4d %4d %-11s %-10s %2d %s" \
      $is $p(name) $ss $p(x) $p(y) \
      $eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)]
}

proc world-brief {s} {
  ## Return a very brief summary string for planet S.

  global gv ec
  elite-worldinfo p $s
  return [format "%-8s (%s, %s, %2d)" \
	      $p(name) $ec($p(economy)) $gv($p(government)) $p(techlevel)]
}

proc jameson {arr} {
  ## Fill ARR with the information about commander JAMESON.

  global galaxy1 products
  upvar 1 $arr cmdr
  array set cmdr {
    mission	      0
    credits	   1000
    fuel	     70
    gal-number	      1
    front-laser	   0x0f
    rear-laser	      0
    left-laser	      0
    right-laser	      0
    cargo	     20
    missiles	      3
    legal-status      0
    score	      0
    market-fluc	      0
  }
  set cmdr(gal-seed) $galaxy1
  foreach i {
    ecm fuel-scoop energy-bomb energy-unit docking-computer
    gal-hyperdrive escape-pod
  } { set cmdr($i) 0 }
  elite-worldinfo lave [find-world $galaxy1 "Lave"]
  set cmdr(world-x) [expr {$lave(x)/4}]
  set cmdr(world-y) [expr {$lave(y)/2}]
  elite-market mkt $lave(seed) 0
  foreach {t n} $products {
    destructure [list . cmdr(station-$t)] $mkt($t)
    set cmdr(hold-$t) 0
  }
  set cmdr(station-alien-items) 0
}

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

package provide "elite" "1.0.1"