chiark - git - mdw - rocl/blob - elite.tcl

   1 #! /usr/bin/tclsh
   2 #
   3 # $Id: elite.tcl,v 1.6 2003/03/07 00:44:57 mdw Exp $
   4
   5 package require "elite-bits" "1.0.1"
   6
   7 set galaxy1 "4a5a480253b7"              ;# Seed for standard galaxy 1
   8
   9 # --- tab ARR NAME NAME ... ---
  10 #
  11 # Construct an array mapping integers 0, 1, ... to the given NAMEs, in order.
  12
  13 proc tab {arr args} {
  14   upvar 1 $arr a
  15   set i 0
  16   foreach v $args {
  17     set a($i) $v
  18     incr i
  19   }
  20 }
  21
  22 # --- Various standard tables ---
  23
  24 tab government \
  25     "anarchy" "feudal" "multi-government" "dictatorship" \
  26     "communist" "confederacy" "democracy" "corporate state"
  27
  28 tab economy \
  29     "rich industrial" "average industrial" "poor industrial" \
  30     "mainly industrial" "mainly agricultural" "rich agricultural" \
  31     "average agricultural" "poor agricultural"
  32
  33 tab gov \
  34     anarchy feudal multi-gov dictator \
  35     communist confed democracy corp-state
  36
  37 tab eco \
  38     rich-ind avg-ind poor-ind mainly-ind \
  39     mainly-agri rich-agri avg-agri poor-agri
  40
  41 set products {
  42   food          "Food"
  43   textiles      "Textiles"
  44   radioactives  "Radioactives"
  45   slaves        "Slaves"
  46   liquor-wines  "Liquor & wines"
  47   luxuries      "Luxuries"
  48   narcotics     "Narcotics"
  49   computers     "Computers"
  50   machinery     "Machinery"
  51   alloys        "Alloys"
  52   firearms      "Firearms"
  53   furs          "Furs"
  54   minerals      "Minerals"
  55   gold          "Gold"
  56   platinum      "Platinum"
  57   gem-stones    "Gem-stones"
  58   alien-items   "Alien items"
  59 }
  60
  61 foreach p $products { set unit($p) t }
  62 foreach p {gold platinum} { set unit($p) kg }
  63 set unit(gem-stones) g
  64 unset p
  65
  66 # --- galaxy N [GAL] ---
  67 #
  68 # Compute the seed of the Nth galaxy, if GAL is the seed of galaxy 1.  By
  69 # default, GAL is the standard galaxy 1 seed.
  70
  71 proc galaxy [list n [list g $galaxy1]] {
  72   for {set i 1} {$i < $n} {incr i} {
  73     set g [elite-nextgalaxy $g]
  74   }
  75   return $g
  76 }
  77
  78 # --- foreach-world GAL ARR SCRIPT ---
  79 #
  80 # For each world in galaxy GAL (a seed), set ARR to the world information
  81 # and evaluate SCRIPT.  The usual loop control commands can be used in
  82 # SCRIPT.
  83
  84 proc foreach-world {g p act} {
  85   upvar 1 $p pp
  86   for {set i 0} {$i < 256} {incr i; set g [elite-nextworld $g]} {
  87     elite-worldinfo pp $g
  88     uplevel 1 $act
  89   }
  90 }
  91
  92 # --- find-world GAL PAT ---
  93 #
  94 # Return a list of seeds for the worlds in galaxy GAL (a seed) whose names
  95 # match the glob pattern PAT.
  96
  97 proc find-world {g pat} {
  98   set l {}
  99   foreach-world $g p {
 100     if {[string match -nocase $pat $p(name)]} {
 101       lappend l $p(seed)
 102     }
 103   }
 104   return $l
 105 }
 106
 107 # --- destructure PAT LIST ---
 108 #
 109 # Destrcture LIST according to PAT.  If PAT is a single name, set the
 110 # variable PAT to LIST; otherwise, if PAT is a list, each of its elements
 111 # must correspond to an element of LIST, so recursively destructure the
 112 # corresponding elements of each.  It is not an error if the PAT list is
 113 # shorter than LIST.  The special variable name `.' indicates that no
 114 # assignment is to be made.
 115
 116 proc destructure {pp xx} {
 117   if {![string compare $pp "."]} {
 118     return
 119   } elseif {[llength $pp] == 0} {
 120     return
 121   } elseif {[llength $pp] == 1} {
 122     upvar 1 $pp p
 123     set p $xx
 124   } else {
 125     foreach p $pp x $xx {
 126       uplevel 1 [list destructure $p $x]
 127     }
 128   }
 129 }
 130
 131 # --- write-file NAME CONTENTS [TRANS] ---
 132 #
 133 # Write file NAME, storing CONTENTS translated according to TRANS (default
 134 # `binary'.  The write is safe against errors -- we don't destroy the old
 135 # data until the file is written.
 136
 137 proc write-file {name contents {trans binary}} {
 138   if {[file exists $name]} {
 139     if {[set rc [catch { file copy -force $name "$name.old" } err]]} {
 140       return -code $rc $err
 141     }
 142   }
 143   if {[set rc [catch {
 144     set f [open $name w]
 145     fconfigure $f -translation $trans
 146     puts -nonewline $f $contents
 147     close $f
 148   } err]]} {
 149     catch { close $f }
 150     catch { file rename -force "$name.old" $name }
 151     return -code $rc $err
 152   }
 153   return ""
 154 }
 155
 156 # --- read-file NAME [TRANS] ---
 157 #
 158 # Read the contents of the file NAME, translating it according to TRANS
 159 # (default `binary').
 160
 161 proc read-file {name {trans binary}} {
 162   set f [open $name]
 163   fconfigure $f -translation $trans
 164   set c [read $f]
 165   close $f
 166   return $c
 167 }
 168
 169 # --- nearest-planet WW X Y ---
 170 #
 171 # Returns the seed of the `nearest' planet given in the worldinfo list WW to
 172 # the point X Y (in decilightyears).
 173
 174 proc nearest-planet {ww x y} {
 175   set min 10000
 176   foreach {ss xx yy} $ww {
 177     set dx [expr {abs($x - $xx)/4}]
 178     set dy [expr {abs($y - $yy)/2}]
 179     if {$dx > $dy} {
 180       set d [expr {($dx * 2 + $dy)/2}]
 181     } else {
 182       set d [expr {($dx + $dy * 2)/2}]
 183     }
 184     if {$d < $min} {
 185       set p $ss
 186       set min $d
 187     }
 188   }
 189   return $p
 190 }
 191
 192 # --- worldname W ---
 193 #
 194 # Returns the name of the world with seed W.
 195
 196 proc worldname {w} {
 197   elite-worldinfo p $w
 198   return $p(name)
 199 }
 200
 201 # --- shortest-path ADJ FROM TO WEIGHT ---
 202 #
 203 # Computes the shortest path and shortest distance between the worlds wose
 204 # seeds are FROM and TO respectively.  ADJ must be an adjacency table for the
 205 # galaxy containing FROM and TO.  WEIGHT is a command such that WEIGHT A B
 206 # returns the `distance' for the simple path between A and B.  The return
 207 # value is a list P D, where D is the weight of the path found, and P is a
 208 # simple list of seeds for the worlds on the path.  P starts with FROM and
 209 # ends with TO.
 210
 211 proc shortest-path {adjvar from to weight} {
 212   upvar 1 $adjvar adj
 213   if {[string equal $from $to]} { return [list $to 0] }
 214   set l($from) 0
 215   set p($from) $from
 216   set c $from
 217   while 1 {
 218     foreach {n x y} $adj($c) {
 219       if {[info exists l($n)]} {
 220         continue
 221       }
 222       set w [expr {$l($c) + [uplevel 1 $weight [list $c $n]]}]
 223       if {![info exists ll($n)] || $w < $ll($n)} {
 224         set ll($n) $w
 225         set p($n) [concat $p($c) [list $n]]
 226       }
 227     }
 228     set s [array startsearch ll]
 229     if {![array anymore ll $s]} {
 230       return {{} 0}
 231     }
 232     set c [array nextelement ll $s]
 233     set w $ll($c)
 234     while {[array anymore ll $s]} {
 235       set n [array nextelement ll $s]
 236       if {$ll($n) < $w} {
 237         set c $n
 238         set w $ll($n)
 239       }
 240     }
 241     if {[string equal $c $to]} { return [list $p($to) $ll($to)] }
 242     set l($c) $ll($c)
 243     unset ll($c)
 244   }
 245 }
 246
 247 # --- weight-hops A B ---
 248 #
 249 # shortest-path weight function giving each hop the same weight.
 250
 251 proc weight-hops {from to} {
 252   return 1
 253 }
 254
 255 # --- weight-fuel A B ---
 256 #
 257 # shortest-path weight function measuring the distance between FROM and TO.
 258
 259 proc weight-fuel {from to} {
 260   elite-worldinfo f $from
 261   elite-worldinfo t $to
 262   return [elite-distance $f(x) $f(y) $t(x) $t(y)]
 263 }
 264
 265 # --- weight-safety A B ---
 266 #
 267 # shortest-path weight function attempting to maximize safety of the journey
 268 # by giving high weight (square-law) to worlds with unstable governments.
 269
 270 proc weight-safety {from to} {
 271   elite-worldinfo t $to
 272   set w [expr {8 - $t(government)}]
 273   return [expr {$w * $w}]
 274 }
 275
 276 # --- weight-encounters A B ---
 277 #
 278 # shortest-path weight function attempting to maximize encounters on the
 279 # journey by giving high weight (square law) to worlds with stable
 280 # governments.
 281
 282 proc weight-encounters {from to} {
 283   elite-worldinfo f $from
 284   elite-worldinfo t $to
 285   set w [expr {1 + $t(government)}]
 286   return [expr {$w * $w}]
 287 }
 288
 289 # --- weight-trading A B ---
 290 #
 291 # shortest-path weight function attempting to maximize trading opportunities
 292 # along the journey by giving high weight (square law) to pairs of worlds
 293 # with small differences between their economic statuses.
 294
 295 proc weight-trading {from to} {
 296   elite-worldinfo f $from
 297   elite-worldinfo t $to
 298   set w [expr {8 - abs($f(economy) - $t(economy))}]
 299   return [expr {$w * $w}]
 300 }
 301
 302 # --- parse-galaxy-spec G ---
 303 #
 304 # Parses a galaxy spec and returns a list containing a description of the
 305 # galaxy and the corresponding galaxy seed.  A galaxy spec is one of:
 306 #
 307 #   * a number between 1 and 8, corresponding to one of the standard
 308 #     galaxies;
 309 #
 310 #   * a 12-digit hex string, which is a galaxy seed (and is returned
 311 #     unchanged); or
 312 #
 313 #   * a string of the form S:N where S is a 12-hex-digit seed and N is a
 314 #     galaxy number, corresponding to the Nth galaxy starting with S as
 315 #     galaxy 1.
 316 #
 317 # If the string is unrecognized, an empty list is returned.
 318
 319 proc parse-galaxy-spec {g} {
 320   switch -regexp -- $g {
 321     {^[1-8]$} { return [list $g [galaxy $g]] }
 322     {^[0-9a-fA-F]{12}$} { return [list $g $g] }
 323     default {
 324       if {[regexp {^([0-9a-fA-F]{12}):([1-8])$} $g . b n]} {
 325         return [list $g [galaxy $n $b]]
 326       }
 327     }
 328   }
 329   return {}
 330 }
 331
 332 # --- parse-planet-spec G P ---
 333 #
 334 # Parses a planet spec and returns the planet seed.  The planet spec P is
 335 # interpreted relative to galaxy G.  A planet spec is one of:
 336 #
 337 #   * a simple integer, corresponding to a planet number;
 338 #
 339 #   * a 12-hex-digit seed, which is returned unchanged;
 340 #
 341 #   * a pair of integers separated by commas, corresponding to the nearest
 342 #     planet to those coordinates;
 343 #
 344 #   * a glob pattern, corresponding to the lowest-numbered planet in the
 345 #     galaxy whose name matches the pattern case-insensitively; or
 346 #
 347 #   * a string of the form G.P where G is a galaxy spec and P is a planet
 348 #     spec, corresponding to the planet specified by P relative to galaxy G.
 349 #
 350 # If the string is unrecognized, an empty string is returned.
 351
 352 proc parse-planet-spec {g p} {
 353   if {[regexp {^[0-9a-fA-F]{12}$} $p]} { return $p }
 354   if {[regexp {^(.+)\.(.+)$} $p . g p]} {
 355     set g [parse-galaxy-spec $g]
 356     if {[string equal $g ""]} { return {} }
 357     destructure {. g} $g
 358     return [parse-planet-spec $g $p]
 359   }
 360   if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+)$} $p]} {
 361     for {set s $g; set i 0} {$i < $p} {incr i; set s [elite-nextworld $s]} {}
 362     return $s
 363   }
 364   if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+),\s*(0x[0-9a-fA-F]+|[0-9]+)$} \
 365       $p . x y]} {
 366     return [nearest-planet [elite-galaxylist $g] $x $y]
 367   }
 368   if {[regexp {^([^/]*)(?:/([1-9]\d*))?$} $p . p i]} {
 369     if {[string equal $i ""]} { set i 1 }
 370     set l [find-world $g $p]
 371     if {$i <= [llength $l]} { return [lindex $l [expr {$i - 1}]] }
 372   }
 373   return {}
 374 }
 375
 376 # --- in-galaxy-p G PP ---
 377 #
 378 # Returns nonzero if the planets (seeds) listed in PP are in galaxy G.
 379 # Doesn't mind if the planet seeds are invalid.
 380
 381 proc in-galaxy-p {g pp} {
 382   foreach-world $g i { set x($i(seed)) 1 }
 383   foreach p $pp { if {![info exists x($p)]} { return 0 } }
 384   return 1
 385 }
 386
 387 # --- world-summary PLANET ---
 388 #
 389 # Return a one-line summary string for PLANET.
 390
 391 proc world-summary {s {ind 0} {spc 0}} {
 392   global eco gov
 393   elite-worldinfo p $s
 394   set is [string repeat " " $ind]
 395   set ss [string repeat " " $spc]
 396   return [format "%s%-8s%s %4d %4d %-11s %-10s %2d %s" \
 397       $is $p(name) $ss $p(x) $p(y) \
 398       $eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)]
 399 }
 400
 401 # --- jameson ARR ---
 402 #
 403 # Fill ARR with the information about commander JAMESON.
 404
 405 proc jameson {arr} {
 406   global galaxy1 products
 407   upvar 1 $arr cmdr
 408   array set cmdr {
 409     mission           0
 410     credits        1000
 411     fuel             70
 412     gal-number        1
 413     front-laser    0x0f
 414     rear-laser        0
 415     left-laser        0
 416     right-laser       0
 417     cargo            20
 418     missiles          3
 419     legal-status      0
 420     score             0
 421     market-fluc       0
 422   }
 423   set cmdr(gal-seed) $galaxy1
 424   foreach i {
 425     ecm fuel-scoop energy-bomb energy-unit docking-computer
 426     gal-hyperdrive escape-pod
 427   } { set cmdr($i) 0 }
 428   elite-worldinfo lave [find-world $galaxy1 "Lave"]
 429   set cmdr(world-x) [expr {$lave(x)/4}]
 430   set cmdr(world-y) [expr {$lave(y)/2}]
 431   elite-market mkt $lave(seed) 0
 432   foreach {t n} $products {
 433     destructure [list . cmdr(station-$t)] $mkt($t)
 434     set cmdr(hold-$t) 0
 435   }
 436   set cmdr(station-alien-items) 0
 437 }
 438
 439 #----- That's all, folks ----------------------------------------------------
 440
 441 package provide "elite" "1.0.1"