Distribute elite.tcl. Duh.

[rocl] / elite.tcl

#! /usr/bin/tclsh

package require "elite-bits" "1.0.0"

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

# --- tab ARR NAME NAME ... ---
#
# Construct an array mapping integers 0, 1, ... to the given NAMEs, in order.

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

# --- Various standard tables ---

tab government \
    "anarchy" "feudal" "multi-government" "dictatorship" \
    "communist" "confederacy" "democracy" "corporate state"

tab economy \
    "rich industrial" "average industrial" "poor industrial" \
    "mainly industrial" "mainly agricultural" "rich agricultural" \
    "average agricultural" "poor agricultural"

tab gov \
    anarchy feudal multi-gov dictator \
    communist confed democracy corp-state

tab eco \
    rich-ind ave-ind poor-ind mainly-ind \
    mainly-agri rich-agri ave-agri poor-agri

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

# --- galaxy N [GAL] ---
#
# Compute the seed of the Nth galaxy, if GAL is the seed of galaxy 1.  By
# default, GAL is the standard galaxy 1 seed.

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

# --- foreach-world GAL ARR SCRIPT ---
#
# For each world in galaxy GAL (a seed), set ARR to the world information
# and evaluate SCRIPT.  The usual loop control commands can be used in
# SCRIPT.

proc foreach-world {g p 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    
  }
}

# --- find-world GAL PAT ---
#
# Return a list of seeds for the worlds in galaxy GAL (a seed) whose names
# match the glob pattern PAT.

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

# --- destructure PAT LIST ---
#
# Destrcture LIST according to PAT.  If PAT is a single name, set the
# variable PAT to LIST; otherwise, if PAT is a list, each of its elements
# must correspond to an element of LIST, so recursively destructure the
# corresponding elements of each.  It is not an error if the PAT list is
# shorter than LIST.  The special variable name `.' indicates that no
# assignment is to be made.

proc destructure {pp xx} {
  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]
    }
  }
}

# --- worldinfo GAL ---
#
# Return a list describing the worlds in galaxy GAL (a seed).  The list
# contains a group of three elements for each world: the seed, x and y
# coordinates (in decilightyears).

proc worldinfo {g} {
  foreach-world $g p {
    lappend i $p(seed) $p(x) $p(y)
  }
  return $i
}

# --- world-distance X Y XX YY ---
#
# Computes the correct game distance in decilightyears between two worlds,
# one at X, Y and the other at XX, YY.

proc world-distance {x y xx yy} {
  set dx [expr {abs($x - $xx)/4}]
  set dy [expr {abs($y - $yy)/4}]
  return [expr {4 * floor(sqrt($dx * $dx + $dy * $dy))}]
}

# --- 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).

proc nearest-planet {ww x y} {
  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
}

# --- adjacency WW ADJ [D] ---
#
# Fill in the array ADJ with the adjacency table for the worlds listed in the
# worldinfo list WW.  That is, for each world seed S, ADJ(S) is set to a
# worldinfo list containing the worlds within D (default 70) decilightyears
# of S.

proc adjacency {p adj {d 70}} {
  upvar 1 $adj a
  array set a {}
  foreach {s x y} $p {
    set done($s) 1
    lappend a($s)
    foreach {ss xx yy} $p {
      if {[info exists done($ss)]} { continue }
      if {abs($x - $xx) > $d + 10 || abs($y - $yy) > $d + 10 ||
          [world-distance $x $y $xx $yy] > $d} { continue }
      lappend a($s) $ss $xx $yy
      lappend a($ss) $s $x $y
    }
  }
}

# --- worldname W ---
#
# Returns the name of the world with seed W.

proc worldname {w} {
  elite-worldinfo p $w
  return $p(name)
}

# --- shortest-path ADJ FROM TO WEIGHT ---
#
# Computes the shortest path and shortest distance between the worlds wose
# seeds are FROM and TO respectively.  ADJ must be 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.

proc shortest-path {adjvar from to weight} {
  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)
  }
}

# --- weight-hops A B ---
#
# shortest-path weight function giving each hop the same weight.

proc weight-hops {from to} {
  return 1
}

# --- weight-fuel A B ---
#
# shortest-path weight function measuring the distance between FROM and TO.

proc weight-fuel {from to} {
  elite-worldinfo f $from
  elite-worldinfo t $to
  return [world-distance $f(x) $f(y) $t(x) $t(y)]
}

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

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

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

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

# --- weight-trading A B ---
#
# 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.

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

# --- 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.

proc parse-galaxy-spec {g} {
  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 {}
}

# --- 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.

proc parse-planet-spec {g p} {
  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 [worldinfo $g] $x $y]
  }
  set l [find-world $g $p]
  if {[llength $l]} { return [lindex $l 0] }
  return {}
}

# --- 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.

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

# --- world-summary PLANET ---
#
# Return a one-line summary string for PLANET.

proc world-summary {s} {
  global eco gov
  elite-worldinfo p $s
  return [format "%-12s %4d %4d %-11s %-10s %2d %s" \
      $p(name) $p(x) $p(y) \
      $eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)]
}

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

package provide "elite" "1.0.0"