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

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