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