--- /dev/null
+elite.so
+pkgIndex.tcl
+rocl-1.0.0.tar.gz
+elite.o
--- /dev/null
+# Makefile for RIGHT ON COMMAND-LINE
+
+#----- Configuration stuff --------------------------------------------------
+
+# --- Compiling and linking ---
+
+CC = gcc
+INCLUDES =
+CFLAGS = -O2 -g -pedantic -Wall $(INCLUDES)
+LD = gcc
+LDFLAGS = -shared
+
+# --- Installation ---
+
+INST =
+prefix = /usr/local
+tcllibdir = $(prefix)/lib
+pkglibdir = $(tcllibdir)/elite
+bindir = $(prefix)/bin
+
+INSTALL = install
+RM = rm
+
+#----- Main machinery -------------------------------------------------------
+#
+# Shouldn't need to fiddle with thiis stuff.
+
+PACKAGE = rocl
+VERSION = 1.0.0
+
+TCLSCRIPTS = \
+ elite-editor elite-pairs elite-path elite-find elite-map \
+ elite-prices elite-describe elite-reach
+
+all: elite.so pkgIndex.tcl
+
+elite.so: elite.o
+ $(LD) $(LDFLAGS) elite.o -o elite.so
+
+.SUFFIXES: .c .o
+.c.o:; $(CC) -c $(CFLAGS) -o $@ $<
+
+pkgIndex.tcl: elite.so elite.tcl
+ echo "pkg_mkIndex -verbose -direct . elite.so elite.tcl" | tclsh
+
+install: all
+ $(INSTALL) -d $(INST)$(bindir) $(INST)$(pkglibdir)
+ $(INSTALL) -m 644 elite.so elite.tcl pkgIndex.tcl $(INST)$(pkglibdir)
+ $(INSTALL) -m 755 $(TCLSCRIPTS) $(INST)$(bindir)
+
+clean:
+ $(RM) -f elite.o elite.so pkgIndex.tcl
+
+DISTDIR = $(PACKAGE)-$(VERSION)
+DISTFILES = README Makefile elite.c elite.def $(TCLSCRIPTS)
+distdir: $(DISTFILES)
+ $(RM) -rf $(DISTDIR)
+ mkdir $(DISTDIR)
+ for i in $(DISTFILES); do ln -s ../$$i $(DISTDIR); done
+dist: distdir
+ tar chofz $(DISTDIR).tar.gz $(DISTDIR)
+ $(RM) -rf $(DISTDIR)
+
+.PHONY: all install clean dist distdir
+
+#----- That's all, folks ----------------------------------------------------
--- /dev/null
+RIGHT ON COMMAND-LINE
+ Elite tools for the discerning player
+
+1. Installation
+
+ You need a C compiler and a working Tcl/Tk installation. (The
+ elite-editor program needs Tk; the rest of the tools don't.)
+ The Makefile works on my Debian GNU/Linux box, but I'm not
+ making any promises about anyone else's. I've successfully
+ built earlier versions of everything under Cygwin, against
+ ActiveState's Tcl 8.4, but I've forgotten the Holy Runes. I do
+ have the `.def' file I used to build the DLL, though, for
+ whatever that's worth. (If you want to hack the Makefile to
+ work under Windows, I'll take a patch.)
+
+ The theory is that you should edit the Makefile for your system
+ and say `make'; then, as some suitably privileged person, say
+ `make install' and stand well back. Everything should then be
+ installed.
+
+ In practice:
+
+ * If you can't build `pkgIndex.tcl', run `tclsh' and say
+
+ % pkg_mkIndex -verbose -direct . elite.so elite.tcl
+
+ to it. (Use `elite.dll' if you're on Windows.) Say
+
+ % set tcl_pkgPath
+
+ to see a list of suitable places for putting the kit. Pick
+ one. The directory `/usr/local/lib' appears in my
+ installation, so that's what I use.
+
+ * Make a subdirectory in the place you chose, and copy
+ `elite.so', `elite.tcl' and `pkgIndex.tcl' into it. All
+ should now be hunky-dory.
+
+ * Run (say) `elite-describe lave' to check that things are set
+ up properly.
+
+
+2. The command-line tools
+
+ A `galaxy-spec' is
+
+ * a number, between 1 and 8, for one of the standard eight
+ galaxies;
+
+ * a `galaxy seed' of 12 hex digits (a 48-bit value), for any
+ arbitrary galaxy; or
+
+ * a string `SEED:N' where SEED is a galaxy seed and N is a
+ number between 1 and 8, for the Nth galaxy in some custom
+ universe.
+
+ A `planet-spec' is interpreted relative to some parent galaxy.
+ It may be
+
+ * a number N, for the Nth planet in the galaxy (planets are
+ numbered pseudorandomly -- this is not often a helpful
+ option);
+
+ * a `planet seed' of 12 hex digits (a 48-bit value), for any
+ arbitrary planet;
+
+ * a pair of numbers `X,Y', for the planet nearest the point X
+ decilightyears rightwards and T decilightyears down from the
+ top left of the galaxy;
+
+ * a glob pattern (a string containing `*' and `?' wildcards,
+ matching any substring or any single character,
+ respectively), for the first planet whose name matches the
+ pattern; or
+
+ * a string `GAL:P', where GAL is a galaxy-spec and P is a
+ planet-spec, for the planet P in galaxy GAL.
+
+
+ elite-describe [-g GAL] PLANET ...
+
+ For each PLANET, print the planet data for that PLANET. The
+ PLANETs are interpreted relative to GAL, or standard galaxy 1 if
+ GAL is not specified.
+
+
+ elite-map [-qv] [-g GALAXY] [-d DIST] [-w WD,HT] [-a ASP] [PLANET]
+
+ Prints a map of (part of) a galaxy to the terminal.
+
+ If PLANET is specified (which it usually is), a map of the area
+ around PLANET in GALAXY (default standard galaxy 1) is printed,
+ showing other planets within DIST lightyears (default 7) of
+ PLANET.
+
+ If PLANET is not specified, the entire galaxy is printed. This
+ is usually unhelpful.
+
+ Planets are shown as numbers or letters. The home PLANET is
+ shown as a `*'. Below the map is printed a key describing the
+ planets in a strict left-to-right top-to-bottom order.
+
+ The size of the map may be controlled by the -w option -- set WD
+ to the maximum allowable width, and HT to the maximum allowable
+ height (in columns and rows, respectively). The map will be
+ scaled so as to fit. The -a option sets the aspect ratio of
+ your characters, height to width (the default is about 2, and
+ seems right for viewing in an xterm with the standard fixed
+ font).
+
+
+ elite-path [-g GALAXY] [-w WEIGHT] PLANET PLANET ...
+
+ Computes a route through a GALAXY (default is standard galaxy
+ 1), starting at the first PLANET listed, via the second, via the
+ third, etc., and ending at the last. For each planet you're
+ meant to stop at on the way, a summary line is printed giving
+ the planet's name, position, government type, economy type and
+ tech level.
+
+ You can affect how elite-path selects its routes using the `-w'
+ option. The default is to minimize the number of hops. Other
+ possibilities are:
+
+ hops Minimize number of hops. This is the default.
+
+ safety Maximize stability of the planets in the route,
+ to attempt to improve safety. Useful during the
+ early stages of the game.
+
+ encounters The opposite of `safety' -- minimizes stability
+ of planets in the route. Useful if you want to
+ maximize kills.
+
+ trading Maximize the difference in economy type between
+ successive planets in the route. This should
+ give you an opportunity to make a good profit as
+ you go.
+
+ fuel Minimize absolute distance. For those on a
+ tight budget.
+
+
+ elite-reach [-d DIST] [GALAXY ...]
+
+ For each GALAXY (default is the 8 standard ones), print summary
+ information for each planet, with blank lines separating
+ disconnected groups of planets, i.e., groups where a ship
+ capable of travelling DIST lightyears (default 7) can't get from
+ one to the other.
+
+
+ elite-find [-g GALAXY] [EXPR]
+
+ Without EXPR, simply prints summary information for each planet
+ in GALAXY (default standard 1).
+
+ If EXPR is specified, it must be a Tcl expression (as for the
+ `expr' command). Information is printed for each planet for
+ which EXPR returns nonzero. The EXPR may use the following
+ variables:
+
+ name The planet name, with initial capital letter.
+
+ x, y X and Y coordinates, from top left, in
+ decilightyears.
+
+ economy From 0 (rich industrial) to 7 (poor
+ agricultural).
+
+ government From 0 (anarchy) to 7 (corporate state).
+
+ techlevel From 1 to 15.
+
+ radius In kilometres.
+
+ productivity In millions of credits.
+
+ population In hundreds of millions.
+
+ inhabitants A Tcl list of words describing the inhabitants.
+
+ description As a Tcl list of words.
+
+
+ elite-pairs [-g GALAXY] [-d DIST] AEXPR BEXPR
+
+ Prints the names of pairs of planets A and B in GALAXY (default
+ standard 1), no further than DIST (default 7) lightyears apart,
+ such that AEXPR returns nonzero for planet A and BEXPR returns
+ nonzero for planet B.
+
+ The expressions AEXPR and BEXPR may use the same variables as
+ for elite-find. In addition, BEXPR may use
+
+ d The distance between planets A and B.
+
+ a An array containing the information about planet
+ A. The indices have the same names and meanings
+ as the variables described above.
+
+
+3. The graphical editor
+
+ elite-editor [GALAXY | FILE]
+
+ Starts the RIGHT ON COMMAND-LINE Commander Editor and Map. This
+ is a Tk program -- you'll need that installed to run it.
+
+ I'll not go into excruciating detail about how to work the
+ program. It's fairly simple, really.
+
+ The map view lets you colour-code planets according to
+ techlevel, government or economy. The colours ought to be as
+ follows:
+
+ Colour Government Economy Techlevel
+
+ Red Anarchy Poor agri 1
+ Orange Feudal Average agri 2 or 3
+ Yellow Multi-gov Rich agri 4 or 5
+ Green Dictatorship Mainly agri 6 or 7
+ Blue Communist Mainly indust 8 or 9
+ Magenta Confederacy Poor indust 10 or 11
+ Violet Democracy Average indust 12 or 13
+ White Corporate Rich indust 14 or 15
+
+ The connectivity map shows how you can get around the galaxy
+ using hops of up to 7 light years.
+
+ Planet names are unhelpful except at small scales. The
+ placement algorithm could do with a lot of work.
+
+ Clicking on the map with button 1 (usually the left one) sets
+ the destination world, marked with an orange cross. Clicking
+ with button 3 (usually the right one) sets the home world,
+ marked with a red cross, and with a green hyperspace-range
+ circle around it. (The circle doesn't actually correspond
+ exactly with hyperspace reachability, because there are rounding
+ errors in the distance computation. ROCL correctly emulates the
+ rounding errors from the original game.)
+
+ Double-clicking opens a window showing information about a
+ planet. Two info windows can be open at any time, one for the
+ home world and one for the destination.
+
+ The bar along the bottom of the map window shows the names of
+ the home and destination worlds, and the distance between them.
+ You can type new names (or any old planet spec) into either to
+ select different planets. The change will take place when you
+ press return or when the input focus moves.
+
+ The `Compute path' lets you do the same kinds of computations as
+ the elite-path tool. It plots a route from the home to the
+ destination. The path is shown in orange on the map.
+
+ The commander editor should be self-explanatory, but maybe a few
+ pointers might be helpful.
+
+ The entry fields for items with pop-up menus are disabled when
+ the menus show values other than `Custom', so you must first
+ choose `Custom' from the menu if you want a fancy value.
+
+ The `Show galaxy map' button opens a map which will be tied to
+ the commander window. When you select a home world (button 3),
+ this will set the world where the commander will start. Note
+ that the market prices (in the `Cargo' window) update
+ automatically as you move about the universe. It is quite
+ possible to travel about entirely new universes by turning off
+ the `Standard galaxy' button and typing some hex number into the
+ `Galaxy seed' box. All of the ROCL tools work in these custom
+ universes. Note that your docked planet is recorded as an x, y
+ coordinate pair, so Elite can't tell which of two coincident
+ planets you're docked at (yes, there are such pairs). ROCL
+ won't cope with this at the moment.
+
+ Lasers are a bit odd. Bit 7 is a `rapid-fire' bit. It doesn't
+ affect the strength of the laser, but means that there's no
+ delay between shots. The low 7 bits control the strength, but
+ without the rapid-fire bit, powerful lasers will tend to fire
+ more slowly than weak ones. Some comparisons in the program are
+ for exact laser power: you can't damage the Constrictor or
+ Cougar ships unless you have military (or 0x17 slow-firing)
+ lasers; and you can't fragment asteroids unless you have mining
+ or 0xb2 rapid-fire lasers. (The 0xb2's pack a serious punch. I
+ recommend them as an upgrade for commanders who don't wish to
+ cheat completely.)
+
+
+\f
+Local variables:
+mode: text
+End:
--- /dev/null
+#! /usr/bin/tclsh
+
+package require "elite" "1.0.0"
+
+proc describe n {
+ global economy government
+ elite-worldinfo p $n
+ puts "Name: $p(name)"
+ puts "Position: $p(x), $p(y) LY"
+ puts "Economy: $economy($p(economy))"
+ puts "Government: $government($p(government))"
+ puts "Tech. level: $p(techlevel)"
+ puts [format "Population: %s billion (%s)" \
+ [expr {$p(population)/10.0}] $p(inhabitants)]
+ puts "Gross productivity: $p(productivity) M Cr"
+ puts "Radius: $p(radius) km"
+ puts ""
+ set ll {}
+ set l 0
+ foreach w $p(description) {
+ incr l
+ incr l [string length $w]
+ if {$l > 72} { puts $ll; set ll {}; set l 0 }
+ lappend ll $w
+ }
+ puts $ll
+}
+
+if {[llength $argv] < 1} {
+ puts stderr "usage: $argv0 \[-g GALAXY\] PLANET ..."
+ exit 1
+}
+set g $galaxy1
+for {set i 0} {$i < [llength $argv]} {incr i} {
+ set a [lindex $argv $i]
+ switch -- $a {
+ "-g" {
+ incr i
+ set a [lindex $argv $i]
+ set g [parse-galaxy-spec $a]
+ if {[string equal $g ""]} {
+ puts stderr "$argv0: bad galaxy string `$a'"
+ exit 1
+ }
+ destructure {. g} $g
+ }
+ default {
+ set n [parse-planet-spec $g $a]
+ if {[string equal $n ""]} {
+ puts stderr "$argv0: unknown planet `$a'"
+ continue
+ }
+ describe $n
+ puts ""
+ }
+ }
+}
--- /dev/null
+#! /usr/bin/wish
+
+package require "elite" "1.0.0"
+
+# --- Utility procedures ----------------------------------------------------
+
+proc moan {msg} {
+ global argv0
+ tk_messageBox -message $msg -default ok -title $argv0 -type ok -icon error
+}
+
+proc debug-array {name} {
+ upvar \#0 $name a
+ set tl .debug-$name
+ if {[winfo exists .$tl]} { return }
+ set s [array startsearch a]
+ toplevel $tl
+ set r 0
+ set n 0
+ while {[array anymore a $s]} {
+ set k [array nextelement a $s]
+ label $tl.k-$n -text $k -justify right
+ entry $tl.v-$n -textvariable ${name}($k) -state disabled
+ grid configure $tl.k-$n -row $r -column 0 -sticky e
+ grid configure $tl.v-$n -row $r -column 1 -sticky we
+ incr r
+ incr n
+ }
+ array donesearch a $s
+}
+
+proc write-file {name contents {trans binary}} {
+ 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}} {
+ set f [open $name]
+ fconfigure $f -translation $trans
+ set c [read $f]
+ close $f
+ return $c
+}
+
+proc get-line-done {tl cmd} {
+ if {![uplevel \#0 [concat $cmd [$tl.entry get]]]} {
+ destroy $tl
+ }
+}
+
+proc get-line {tl title prompt def cmd} {
+ if {[winfo exists $tl]} {
+# raise $tl
+ return
+ }
+ toplevel $tl
+ wm title $tl $title
+ label $tl.label -text "$prompt: "
+ entry $tl.entry; $tl.entry insert 0 $def
+ button $tl.ok -text OK -default active \
+ -command [list get-line-done $tl $cmd]
+ bind $tl <Return> [list get-line-done $tl $cmd]
+ bind $tl <Escape> [list destroy $tl]
+ pack $tl.label $tl.entry $tl.ok -side left -padx 2 -pady 2
+}
+
+proc entry-on-change {widget what} {
+ bind $widget <Return> $what
+ bind $widget <FocusOut> $what
+}
+
+#----- Map editing machinery ------------------------------------------------
+
+tab col red orange yellow green blue magenta violet white
+
+set seq 0
+set nwin 0
+array set default {scale 15 colourby off connect 0}
+
+proc set-scale {seq sc} {
+ if {![regexp {^[0-9]+$} $sc]} {
+ moan "bad scale factor `$sc'"
+ return 1
+ }
+ map-setscale $seq $sc
+ return 0
+}
+
+proc new-view {gs} {
+ set g [parse-galaxy-spec $gs]
+ if {![llength $g]} {
+ moan "bad galaxy spec `$gs'"
+ return 1
+ }
+ destructure {ng g} $g
+ map-new $ng $g
+ return 0
+}
+
+# --- Colour-coding planets ---
+
+proc colour-by {seq} {
+ upvar \#0 map-$seq map
+ set tl .map-$seq
+ global col
+ switch -exact -- $map(colourby) {
+ off {
+ foreach-world $map(galaxy) p {
+ $tl.map itemconfigure $p(seed) -fill white -outline white
+ }
+ }
+ economy {
+ foreach-world $map(galaxy) p {
+ set c [expr {7 - $p(economy)}]
+ $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
+ }
+ }
+ government {
+ foreach-world $map(galaxy) p {
+ set c $p(government)
+ $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
+ }
+ }
+ techlevel {
+ foreach-world $map(galaxy) p {
+ set c [expr {$p(techlevel) / 2}]
+ $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
+ }
+ }
+ }
+}
+
+proc set-colour-by {seq} {
+ global default
+ upvar \#0 map-$seq map
+ set default(colourby) $map(colourby)
+ colour-by $seq
+}
+
+# --- Connectivity maps ---
+
+proc show-connectivity {seq} {
+ upvar \#0 map-$seq map
+ upvar \#0 adj-$map(galaxy) adj
+ upvar \#0 ww-$map(galaxy) ww
+ set tl .map-$seq
+ $tl.map delete conn
+ if {!$map(connect)} {
+ return
+ }
+ if {![info exists adj]} { adjacency $ww adj }
+ foreach {s x y} $ww {
+ set done($s) 1
+ foreach {ss xx yy} $adj($s) {
+ if {[info exists done($ss)]} { continue }
+ $tl.map create line \
+ [to-map $seq $x] [to-map $seq $y] \
+ [to-map $seq $xx] [to-map $seq $yy] \
+ -fill darkblue -tags conn
+ }
+ }
+ $tl.map lower conn sep
+}
+
+proc set-connectivity {seq} {
+ global default
+ upvar \#0 map-$seq map
+ set default(connect) $map(connect)
+ show-connectivity $seq
+}
+
+# --- Planet names ---
+
+proc show-names {seq} {
+ upvar \#0 map-$seq map
+ set tl .map-$seq
+ $tl.map delete names
+ if {!$map(names)} {
+ return
+ }
+ foreach-world $map(galaxy) p {
+ set anc nw
+ set px [to-map $seq $p(x)]
+ set py [to-map $seq $p(y)]
+ set offx [expr {$px + [to-map $seq 2]}]
+ set offy [expr {$py + [to-map $seq 2]}]
+ set what {}
+ foreach {a ox oy dx x y xx yy} {
+ nw 2 2 0 0 0 30 10
+ nw 2 2 -10 0 0 30 10
+ sw 2 -2 0 0 -10 30 0
+ sw 2 -2 -10 0 -10 30 0
+ se -2 -2 0 -30 -10 0 0
+ se -2 -2 10 -30 -10 0 0
+ ne -2 2 0 -30 0 0 10
+ ne -2 2 10 -30 0 0 10
+ } {
+ set ox [expr {$px + [to-map $seq $ox] + $dx}]
+ set oy [expr {$py + [to-map $seq $oy]}]
+ if {![llength [$tl.map find overlapping \
+ [expr {$ox + $x}] [expr {$ox + $y}] \
+ [expr {$ox + $xx}] [expr {$ox + $yy}]]]} {
+ set offx $ox
+ set offy $oy
+ set anc $a
+ break
+ }
+ lappend what $a
+ }
+ $tl.map create text $offx $offy -text $p(name) \
+ -fill white -anchor $a -tags names
+ }
+}
+
+proc set-names {seq} {
+ global default
+ upvar \#0 map-$seq map
+ set default(names) $map(names)
+ show-names $seq
+}
+
+# --- Shortest path handling ---
+
+proc show-path {seq} {
+ upvar \#0 map-$seq map
+ set tl .map-$seq
+ $tl.map delete path
+ if {![info exists map(path)]} { return }
+ foreach n $map(path) {
+ elite-worldinfo p $n
+ if {[info exists x]} {
+ $tl.map create line \
+ [to-map $seq $x] [to-map $seq $y] \
+ [to-map $seq $p(x)] [to-map $seq $p(y)] \
+ -fill darkorange -tags path
+ }
+ set x $p(x)
+ set y $p(y)
+ }
+ $tl.map lower path sep
+}
+
+proc show-shortest-path {seq weight} {
+ upvar \#0 map-$seq map
+ upvar \#0 adj-$map(galaxy) adj
+ upvar \#0 ww-$map(galaxy) ww
+ set tl .map-$seq
+ $tl.map delete path
+ if {[info exists map(path)]} { unset map(path) }
+ if {![info exists map(select)] || ![info exists map(dest)]} {
+ moan "no source or destination set"
+ return
+ }
+ if {![info exists adj]} { adjacency $ww adj }
+ destructure {path weight} \
+ [shortest-path adj $map(select) $map(dest) $weight]
+ if {![llength $path]} {
+ moan "no path exists"
+ return
+ }
+ set map(path) $path
+ show-path $seq
+}
+
+# --- Planet information box ---
+
+proc do-getinfo {tag seq x y} {
+ global economy government
+ upvar \#0 info-$tag info
+ set tl .world-info-$tag
+ elite-worldinfo info [find-click $seq $x $y]
+ if {[winfo exists $tl]} {
+# raise $tl
+ } else {
+ toplevel $tl
+ set r 0
+ foreach {item label} {
+ name "Name"
+ seed "Seed"
+ position "Position"
+ eco-name "Economy"
+ gov-name "Government"
+ techlevel "Tech. level"
+ pop-str "Population"
+ prod-str "Productivity"
+ radius-km "Radius"
+ } {
+ label $tl.l-$item -text "$label: " -justify right
+ entry $tl.$item -textvariable info-${tag}($item) -state disabled
+ grid configure $tl.l-$item -row $r -column 0 -sticky e
+ grid configure $tl.$item -row $r -column 1 -columnspan 2 -sticky we
+ incr r
+ }
+ scrollbar $tl.descscr -orient vertical -command [list $tl.desc yview]
+ text $tl.desc -wrap word -yscrollcommand [list $tl.descscr set] \
+ -width 40 -height 4
+ grid configure $tl.desc -row $r -column 0 -columnspan 2 -sticky nsew
+ grid configure $tl.descscr -row $r -column 2 -sticky ns
+ grid columnconfigure $tl 1 -weight 1
+ grid rowconfigure $tl $r -weight 1
+ }
+ wm title $tl "Info: $info(name)"
+ set info(position) "$info(x), $info(y)"
+ set info(eco-name) $economy($info(economy))
+ set info(gov-name) $government($info(government))
+ set info(pop-str) \
+ [format "%s billion (%s)" \
+ [expr {$info(population)/10}] \
+ $info(inhabitants)]
+ set info(prod-str) [format "%d M Cr" $info(productivity)]
+ set info(radius-km) [format "%d km" $info(radius)]
+ $tl.desc configure -state normal
+ $tl.desc delete 1.0 end
+ $tl.desc insert end $info(description)
+ $tl.desc configure -state disabled
+}
+
+# --- Messing with selections ---
+
+proc to-ly {seq x} {
+ upvar \#0 map-$seq map
+ return [expr {$x * $map(scale) / 10.0}]
+}
+
+proc to-map {seq x} {
+ upvar \#0 map-$seq map
+ return [expr {$x * 10 / $map(scale)}]
+}
+
+proc find-click {seq x y} {
+ upvar \#0 map-$seq map
+ upvar \#0 ww-$map(galaxy) ww
+ set tl .map-$seq
+
+ set x [to-ly $seq [$tl.map canvasx $x]]
+ set y [to-ly $seq [$tl.map canvasy $y]]
+ set best 100000
+ foreach {seed px py} $ww {
+ set dx [expr {$x - $px}]
+ set dy [expr {$y - $py}]
+ set d [expr {$dx * $dx + $dy * $dy}]
+ if {$d < $best} {
+ set best $d
+ set p $seed
+ }
+ }
+ $tl.map delete here
+
+ if 0 {
+ $tl.map create line \
+ [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] - 5}] \
+ [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] + 5}] \
+ -tags here -fill green
+ $tl.map create line \
+ [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] + 5}] \
+ [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] - 5}] \
+ -tags here -fill green
+ }
+ return $p
+}
+
+proc destination-world {seq} {
+ upvar \#0 map-$seq map
+ set tl .map-$seq
+ if {![info exists map(dest)]} { return }
+ $tl.map delete dest
+ elite-worldinfo p $map(dest)
+ set px [to-map $seq $p(x)]
+ set py [to-map $seq $p(y)]
+ $tl.map create line [expr {$px - 10}] $py [expr {$px + 10}] $py \
+ -tags {dest cross} -fill darkorange
+ $tl.map create line $px [expr {$py - 10}] $px [expr {$py + 10}] \
+ -tags {dest cross} -fill darkorange
+ $tl.map raise dest sel
+}
+
+proc select-world {seq} {
+ upvar \#0 map-$seq map
+ set tl .map-$seq
+ if {![info exists map(select)]} { return }
+ $tl.map delete sel dest
+ elite-worldinfo p $map(select)
+ set r [to-map $seq $map(fuel)]
+ set px [to-map $seq $p(x)]
+ set py [to-map $seq $p(y)]
+ $tl.map create line [expr {$px - 20}] $py [expr {$px + 20}] $py \
+ -tags {sel cross} -fill darkred
+ $tl.map create line $px [expr {$py - 20}] $px [expr {$py + 20}] \
+ -tags {sel cross} -fill darkred
+ $tl.map create oval \
+ [expr {$px - $r}] [expr {$py - $r}] \
+ [expr {$px + $r}] [expr {$py + $r}] \
+ -tags {sel radius} -outline darkgreen
+ $tl.map raise sel sep
+}
+
+proc select-byname {seq name seed proc} {
+ upvar \#0 map-$seq map
+ set p [parse-planet-spec $map(galaxy) $map($name)]
+ if {![string equal $p ""] && [in-galaxy-p $map(galaxy) $p]} {
+ $proc $seq $p
+ } elseif {[info exists map($seed)]} {
+ bell
+ set map($name) [worldname $map($seed)]
+ } else {
+ bell
+ set map($name) ""
+ }
+}
+
+proc set-selection {seq p} {
+ upvar \#0 map-$seq map
+ set map(select) $p
+ elite-worldinfo pp $p
+ select-world $seq
+ set map(sel-name) $pp(name)
+ if {![info exists map(dest)]} {
+ set-destination $seq $p
+ } else {
+ set-destination $seq $map(dest)
+ }
+ if {[info exists map(cmdr)]} {
+ cmdr-set-world $map(cmdr) $p
+ }
+}
+
+proc do-select {seq x y} {
+ set-selection $seq [find-click $seq $x $y]
+}
+
+proc set-destination {seq p} {
+ upvar \#0 map-$seq map
+ if {![info exists map(select)]} {
+ set-selection $seq $p
+ } else {
+ elite-worldinfo ps $map(select)
+ elite-worldinfo pd $p
+ set map(dest) $p
+ destination-world $seq
+ set map(dest-name) $pd(name)
+ set map(distance) \
+ [format "%.1f" \
+ [expr {[world-distance $ps(x) $ps(y) $pd(x) $pd(y)] / 10.0}]]
+ }
+}
+
+proc do-destination {seq x y} {
+ set-destination $seq [find-click $seq $x $y]
+}
+
+# --- Redrawing a map ---
+
+proc map-populate {seq} {
+ global colourby-$seq connect-$seq
+ upvar \#0 map-$seq map
+ upvar \#0 ww-$map(galaxy) ww
+ set tl .map-$seq
+
+ set scale $map(scale)
+ $tl.map delete all
+ $tl.map create line -10000 -20000 -10000 -20000 -fill black -tags sep
+ if {![info exists ww]} { set ww [worldinfo $map(galaxy)] }
+ foreach {seed x y} $ww {
+ elite-worldinfo p $seed
+ set x [expr {$x * 10 / $map(scale)}]
+ set y [expr {$y * 10 / $map(scale)}]
+ set r [expr {$p(radius) / (500 * $map(scale))}]
+ $tl.map create oval \
+ [expr {$x - $r}] [expr {$y - $r}] \
+ [expr {$x + $r}] [expr {$y + $r}] \
+ -fill white -outline white \
+ -tags [list $seed world]
+ }
+
+ colour-by $seq
+ show-connectivity $seq
+ show-path $seq
+ show-names $seq
+ select-world $seq
+ destination-world $seq
+}
+
+# --- Miscellaneous stuff ---
+
+proc map-setscale {seq sc} {
+ global default
+ upvar \#0 map-$seq map
+ set tl .map-$seq
+ set wd [expr {10240/$sc + 40}]
+ set ht [expr {5120/$sc} + 10]
+ $tl.map configure -scrollregion [list -40 -10 $wd $ht]
+ set map(scale) $sc
+ set default(scale) $sc
+ map-populate $seq
+}
+
+proc map-destroy {seq} {
+ global nwin
+ upvar \#0 map-$seq map
+ if {[info exists map(cmdr)]} {
+ upvar \#0 cmdr-$map(cmdr) cmdr
+ unset cmdr(map)
+ }
+ unset map
+ destroy .map-$seq .set-scale-$seq
+ incr nwin -1
+ if {!$nwin} { exit }
+}
+
+proc map-attach-cmdr {seq cmdr} {
+ upvar \#0 map-$seq map
+ set map(cmdr) $cmdr
+ map-set-title $seq
+}
+
+proc map-set-title {seq} {
+ upvar \#0 map-$seq map
+ set tl .map-$seq
+ set t "Galaxy $map(galaxy-num)"
+ if {[info exists map(cmdr)]} {
+ append t " (commander [cmdr-name $map(cmdr)])"
+ }
+ wm title $tl $t
+}
+
+proc map-set-galaxy {seq ng g} {
+ upvar \#0 map-$seq map
+ if {[string equal $g $map(galaxy)]} { return }
+ set map(galaxy-num) $ng
+ map-set-title $seq
+ set map(galaxy) $g
+ map-populate $seq
+ foreach i {select select-name dest dest-name} {
+ catch { unset map($i) }
+ }
+}
+
+proc map-set-fuel {seq qty} {
+ upvar \#0 map-$seq map
+ set map(fuel) $qty
+ select-world $seq
+}
+
+# --- Making a new map window ---
+
+proc map-new {ng g} {
+ global seq nwin default
+ incr seq
+ incr nwin
+ upvar \#0 map-$seq map
+
+ array set map [array get default]
+ set sc $map(scale)
+ set map(galaxy) $g
+ set map(galaxy-num) $ng
+ set tl [toplevel .map-$seq]
+ set wd [expr {10240/$sc + 80}]
+ set ht [expr {5120/$sc + 20}]
+ set vwd $wd; if {$vwd > 1120} { set vwd 768 }
+ set vht $ht; if {$vht > 1024} { set vht 768 }
+ set map(fuel) 70
+ canvas $tl.map \
+ -background black \
+ -xscrollcommand [list $tl.hscr set] \
+ -yscrollcommand [list $tl.vscr set] \
+ -width $vwd -height $vht
+ frame $tl.info
+ label $tl.info.lhome -text "Home: "
+ entry $tl.info.home -textvariable map-${seq}(sel-name)
+ label $tl.info.ldest -text "Destination: "
+ entry $tl.info.dest -textvariable map-${seq}(dest-name)
+ label $tl.info.ldist -text "Distance: "
+ entry $tl.info.dist -textvariable map-${seq}(distance) \
+ -state disabled -width 6
+ pack \
+ $tl.info.lhome $tl.info.home \
+ $tl.info.ldest $tl.info.dest \
+ $tl.info.ldist $tl.info.dist \
+ -side left
+
+ scrollbar $tl.hscr -orient horizontal \
+ -command [list $tl.map xview]
+ scrollbar $tl.vscr -orient vertical \
+ -command [list $tl.map yview]
+ menu $tl.menu
+ menu $tl.menu.file
+ $tl.menu.file add command -label "New commander" -command cmdr-new
+ $tl.menu.file add command -label "Load commander..." \
+ -command { cmdr-loadfile }
+ $tl.menu.file add separator
+ $tl.menu.file add command -label "Close" -command [list map-destroy $seq]
+ $tl.menu.file add command -label "Quit" -command { exit }
+ $tl.menu add cascade -label "File" -menu $tl.menu.file
+ menu $tl.menu.view
+ $tl.menu.view add command -label "New map..." \
+ -command [list get-line .new-view "New view" "Galaxy" $ng new-view]
+ $tl.menu.view add command -label "Set scale..." \
+ -command [concat get-line .set-scale-$seq {"Set scale"} "Scale" \
+ \[set map-${seq}(scale)\] [list [list set-scale $seq]]]
+ $tl.menu.view add separator
+ $tl.menu.view add radiobutton -label "Off" \
+ -variable map-${seq}(colourby) -value off \
+ -command [list set-colour-by $seq]
+ $tl.menu.view add radiobutton -label "Economy" \
+ -variable map-${seq}(colourby) -value economy \
+ -command [list set-colour-by $seq]
+ $tl.menu.view add radiobutton -label "Government" \
+ -variable map-${seq}(colourby) -value government \
+ -command [list set-colour-by $seq]
+ $tl.menu.view add radiobutton -label "Tech level" \
+ -variable map-${seq}(colourby) -value techlevel \
+ -command [list set-colour-by $seq]
+ $tl.menu.view add separator
+ $tl.menu.view add checkbutton -label "Connectivity" \
+ -variable map-${seq}(connect) \
+ -command [list set-connectivity $seq]
+ $tl.menu.view add checkbutton -label "Planet names" \
+ -variable map-${seq}(names) \
+ -command [list set-names $seq]
+ $tl.menu add cascade -label "View" -menu $tl.menu.view
+ menu $tl.menu.path
+ $tl.menu.path add command -label "Minimize hops" \
+ -command [list show-shortest-path $seq weight-hops]
+ $tl.menu.path add command -label "Minimize fuel" \
+ -command [list show-shortest-path $seq weight-fuel]
+ $tl.menu.path add command -label "Maximize safety" \
+ -command [list show-shortest-path $seq weight-safety]
+ $tl.menu.path add command -label "Minimize safety" \
+ -command [list show-shortest-path $seq weight-encounters]
+ $tl.menu.path add command -label "Maximize trading" \
+ -command [list show-shortest-path $seq weight-trading]
+ $tl.menu add cascade -label "Compute path" -menu $tl.menu.path
+ $tl configure -menu $tl.menu
+
+ wm protocol $tl WM_DELETE_WINDOW [list map-destroy $seq]
+
+ grid $tl.map -column 0 -row 0 -sticky nsew
+ grid $tl.hscr -column 0 -row 1 -sticky ew
+ grid $tl.vscr -column 1 -row 0 -sticky ns
+ grid rowconfigure $tl 0 -weight 1
+ grid columnconfigure $tl 0 -weight 1
+ grid $tl.info -column 0 -columnspan 2 -row 2 -sticky ew
+
+ bind $tl.map <3> [list do-select $seq %x %y]
+ bind $tl.map <1> [list do-destination $seq %x %y]
+ bind $tl.map <Double-1> [list do-getinfo dest $seq %x %y]
+ bind $tl.map <Double-3> [list do-getinfo home $seq %x %y]
+
+ map-set-title $seq
+ entry-on-change $tl.info.home \
+ [list select-byname $seq sel-name select set-selection]
+ entry-on-change $tl.info.dest \
+ [list select-byname $seq dest-name dest set-destination]
+ map-setscale $seq $sc
+ return $seq
+}
+
+#----- Commander editing machinery ------------------------------------------
+
+# --- Validation and factor-of-10 fixing ---
+
+proc fix-tenth {tag arrvar full op} {
+ upvar \#0 $arrvar arr
+ catch { set arr($tag) [format "%d" [expr {int($arr($full) * 10)}]] }
+}
+
+proc numericp {min max n} {
+ if {[catch { expr {$n + 0} }]} { return 0 }
+ if {$n < $min || $n > $max} { return 0 }
+ return 1
+}
+
+proc integerp {min max n} {
+ if {[catch { incr n 0}]} { return 0 }
+ if {$n < $min || $n > $max} { return 0 }
+ return 1
+}
+
+proc galaxyp {s} {
+ if {![regexp {^[0-9a-fA-F]{12}$} $s]} { return 0 }
+ return 1
+}
+
+proc cmdr-do-validate {seq widget check value} {
+ upvar \#0 cmdr-$seq cmdr
+ if {$cmdr(ok/$widget)} { incr cmdr(bogus) }
+ if {![eval $check [list $value]]} {
+ set cmdr(ok/$widget) 0
+ $widget configure -foreground red
+ } else {
+ set cmdr(ok/$widget) 1
+ $widget configure -foreground black
+ incr cmdr(bogus) -1
+ }
+ return 1
+}
+
+proc cmdr-validate-widget {seq widget check} {
+ upvar \#0 cmdr-$seq cmdr
+ set cmdr(ok/$widget) 1
+ $widget configure -validate key \
+ -vcmd [list cmdr-do-validate $seq $widget $check %P]
+}
+
+# --- Cargo window handling ---
+
+proc cmdr-set-fluc {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ global products
+ set tl .cmdr-$seq.cargo-qty
+ if {!$cmdr(ok/$tl.fluc)} { bell; return }
+ elite-market m $cmdr(world-seed) $cmdr(market-fluc)
+ foreach {i .} $products {
+ set cmdr(price-$i) [format "%.1f" [expr {[lindex $m($i) 0]/10.0}]]
+ }
+}
+
+proc cmdr-cargo {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ set tl .cmdr-$seq.cargo-qty
+ if {[winfo exists $tl]} {
+# raise $tl
+ return
+ }
+ toplevel $tl
+ wm title $tl "Cargo for commander $cmdr(name)"
+ global products
+ set r 0
+ label $tl.l-fluc -text "Fluctuation: " -justify right
+ entry $tl.fluc -textvariable cmdr-${seq}(market-fluc) -justify right
+ cmdr-validate-widget $seq $tl.fluc [list integerp 0 255]
+ entry-on-change $tl.fluc [list cmdr-set-fluc $seq]
+ grid configure $tl.l-fluc -row $r -column 0 -sticky e
+ grid configure $tl.fluc -row $r -column 1 -columnspan 3 -sticky we
+ incr r
+ label $tl.l-item -text "Item" -justify center
+ label $tl.l-price -text "Price" -justify center
+ label $tl.l-station -text "Station" -justify center
+ label $tl.l-hold -text "Hold" -justify center
+ grid configure $tl.l-item -row $r -column 0 -sticky e
+ grid configure $tl.l-price -row $r -column 1 -sticky we
+ grid configure $tl.l-station -row $r -column 2 -sticky we
+ grid configure $tl.l-hold -row $r -column 3 -sticky we
+ incr r
+ foreach {tag label} $products {
+ label $tl.l-$tag -text "$label: " -justify right
+ entry $tl.price-$tag -textvariable cmdr-${seq}(price-${tag}) \
+ -justify right -state disabled -width 4
+ foreach {pre col} {station 2 hold 3} {
+ entry $tl.${pre}-${tag} -textvariable cmdr-${seq}(${pre}-${tag}) \
+ -justify right -width 4
+ cmdr-validate-widget $seq $tl.${pre}-${tag} [list integerp 0 255]
+ grid configure $tl.${pre}-${tag} -row $r -column $col -stick we
+ }
+ grid configure $tl.l-$tag -row $r -column 0 -sticky e
+ grid configure $tl.price-$tag -row $r -column 1 -sticky we
+ incr r
+ }
+ grid columnconfigure $tl 1 -weight 1
+ grid columnconfigure $tl 2 -weight 1
+ grid columnconfigure $tl 3 -weight 1
+}
+
+# --- Miscellaneous stuff ---
+
+proc cmdr-destroy {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ global nwin
+ set tl .cmdr-$seq
+ if {[info exists cmdr(map)]} { map-destroy $cmdr(map) }
+ unset cmdr
+ destroy $tl
+ incr nwin -1
+ if {!$nwin} { exit }
+}
+
+proc cmdrdb-set {seq tag value} {
+ upvar \#0 cmdr-$seq cmdr
+ set tl .cmdr-$seq
+ set cmdr($tag) $value
+ $tl.$tag configure -state disabled
+}
+
+proc cmdrdb-custom {seq tag} {
+ set tl .cmdr-$seq
+ $tl.$tag configure -state normal
+}
+
+proc cmdr-set-world {seq p} {
+ upvar \#0 cmdr-$seq cmdr
+ elite-worldinfo i $p
+ set cmdr(world-seed) $p
+ set cmdr(world-name) $i(name)
+ set cmdr(world-x) [expr {$i(x)/4}]
+ set cmdr(world-y) [expr {$i(y)/2}]
+ cmdr-set-fluc $seq
+}
+
+proc cmdr-update-world {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ upvar \#0 ww-$cmdr(gal-seed) ww
+ if {![info exists ww]} { set ww [worldinfo $cmdr(gal-seed)] }
+ set tl .cmdr-$seq
+ set w [nearest-planet $ww \
+ [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
+ if {[info exists cmdr(map)]} {
+ if {$cmdr(std-gal)} {
+ set ng $cmdr(gal-number)
+ } else {
+ set ng $cmdr(gal-seed)
+ }
+ map-set-galaxy $cmdr(map) $ng $cmdr(gal-seed)
+ set-selection $cmdr(map) $w
+ }
+ cmdr-set-world $seq $w
+}
+
+proc cmdr-set-gal-num {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ set tl .cmdr-$seq
+ if {!$cmdr(ok/$tl.gal-number)} { bell; return }
+ if {$cmdr(std-gal)} {
+ set cmdr(gal-seed) [galaxy $cmdr(gal-number)]
+ cmdr-update-world $seq
+ }
+}
+
+proc cmdr-std-gal {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ set tl .cmdr-$seq
+ if {$cmdr(std-gal)} {
+ if {!$cmdr(ok/$tl.gal-number)} { bell; return }
+ set cmdr(gal-seed) [galaxy $cmdr(gal-number)]
+ cmdr-update-world $seq
+ $tl.gal-seed configure -state disabled
+ } else {
+ $tl.gal-seed configure -state normal
+ }
+}
+
+proc cmdr-set-fuel {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ if {[info exists cmdr(map)]} {
+ map-set-fuel $cmdr(map) $cmdr(fuel)
+ }
+}
+
+proc cmdr-name {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ return $cmdr(name)
+}
+
+proc cmdr-show-map {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ if {[info exists cmdr(map)]} {
+ return
+ }
+ if {$cmdr(std-gal)} {
+ set ng $cmdr(gal-number)
+ } else {
+ set ng $cmdr(gal-seed)
+ }
+ set cmdr(map) [map-new $ng $cmdr(gal-seed)]
+ map-attach-cmdr $cmdr(map) $seq
+ map-set-fuel $cmdr(map) $cmdr(fuel)
+ set-selection $cmdr(map) $cmdr(world-seed)
+}
+
+proc cmdr-set-name {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ if {[info exists cmdr(file)]} {
+ set cmdr(name) [string toupper [file rootname [file tail $cmdr(file)]]]
+ } else {
+ set cmdr(name) JAMESON
+ }
+ set tl .cmdr-$seq
+ wm title $tl "Commander $cmdr(name)"
+ if {[info exists cmdr(map)]} { map-set-title $cmdr(map) }
+ if {[winfo exists $tl.cargo-qty]} {
+ wm title $tl.cargo-qty "Cargo for commander $cmdr(name)"
+ }
+}
+
+proc cmdr-check {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ if {$cmdr(bogus)} {
+ moan("invalid values in commander data -- fix items highlighted in red")
+ return 0
+ }
+ return 1
+}
+
+# --- Initial population ---
+
+proc cmdr-open {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ global cmdr-$seq
+ set tl .cmdr-$seq
+ global nwin
+ toplevel $tl
+ set laser {
+ dropbox 255
+ "None" 0
+ "Pulse" 0x0f
+ "Beam" 0x8f
+ "Military" 0x97
+ "Mining" 0x32
+ }
+ set r 0
+ set cmdr(bogus) 0
+ foreach {tag label kind} [list \
+ mission "Mission" { entry 2 255 } \
+ score "Rating" { dropbox 65535\
+ "Harmless" 0 \
+ "Mostly harmless" 8 \
+ "Poor" 6 \
+ "Average" 32 \
+ "Above average" 64 \
+ "Competent" 128 \
+ "Dangerous" 512 \
+ "Deadly" 2560 \
+ "Elite" 6400 } \
+ legal-status "Legal status" { dropbox 255 \
+ "Clean" 0 \
+ "Offender" 1 \
+ "Fugitive" 50 } \
+ world "Location" where \
+ credits "Credits" { tenth 10 429496729.5 } \
+ fuel "Fuel" { tenth 4 25.5 } \
+ missiles "Missiles" { entry 4 255 } \
+ energy-unit "Energy unit" { dropbox 255 \
+ "None" 0 \
+ "Standard" 1 \
+ "Naval" 2 } \
+ front-laser "Front laser" $laser \
+ rear-laser "Front laser" $laser \
+ left-laser "Left laser" $laser \
+ right-laser "Right laser" $laser \
+ ecm "ECM" toggle \
+ fuel-scoop "Fuel scoops" toggle \
+ energy-bomb "Energy bomb" toggle \
+ escape-pod "Escape pod" toggle \
+ docking-computer "Docking computers" toggle \
+ gal-hyperdrive "Galactic hyperdrive" toggle \
+ cargo "Cargo capacity" { entry 4 255 } \
+ stuff "Cargo" cargo \
+ ] {
+ switch -exact -- [lindex $kind 0] {
+ entry {
+ destructure {. wd max} $kind
+ label $tl.l-$tag -text "$label: " -justify right
+ entry $tl.$tag -textvariable cmdr-${seq}($tag) \
+ -width $wd -justify right
+ cmdr-validate-widget $seq $tl.$tag [list integerp 0 $max]
+ grid configure $tl.l-$tag -row $r -column 0 -sticky e
+ grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we
+ }
+ tenth {
+ destructure {. wd max} $kind
+ label $tl.l-$tag -text "$label: " -justify right
+ entry $tl.$tag -textvariable cmdr-${seq}(div-$tag) \
+ -width $wd -justify right
+ set cmdr(div-$tag) [format "%.1f" [expr {$cmdr($tag) / 10.0}]]
+ trace variable cmdr-${seq}(div-$tag) w [list fix-tenth $tag]
+ cmdr-validate-widget $seq $tl.$tag [list numericp 0 $max]
+ grid configure $tl.l-$tag -row $r -column 0 -sticky e
+ grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we
+ }
+ toggle {
+ checkbutton $tl.$tag -text $label -variable cmdr-${seq}($tag)
+ grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky w
+ }
+ dropbox {
+ label $tl.l-$tag -text "$label: " -justify right
+ set menu $tl.m-$tag.menu
+ menubutton $tl.m-$tag -textvariable cmdr-${seq}(r-${tag}) \
+ -indicatoron 1 -relief raised -menu $menu -width 8 \
+ -direction flush
+ entry $tl.$tag -textvariable cmdr-${seq}($tag) \
+ -justify right -width 4
+ cmdr-validate-widget $seq $tl.$tag [list integerp 0 [lindex $kind 1]]
+ menu $menu -tearoff 0
+ set cmdr(r-$tag) "Custom"
+ foreach {name value} [lrange $kind 2 end] {
+ $menu add radiobutton -label "$name ($value)" \
+ -value $name -variable cmdr-${seq}(r-$tag) \
+ -command [list cmdrdb-set $seq $tag $value]
+ if {$cmdr($tag) == $value} {
+ set cmdr(r-$tag) $name
+ set cmdr($tag) $value
+ $tl.$tag configure -state disabled
+ }
+ }
+ $menu add radiobutton -label "Custom" \
+ -value "Custom" -variable cmdr-${seq}(r-$tag) \
+ -command [list cmdrdb-custom $seq $tag]
+ grid configure $tl.l-$tag -row $r -column 0 -sticky e
+ grid configure $tl.m-$tag -row $r -column 1 -sticky we
+ grid configure $tl.$tag -row $r -column 2 -sticky we
+ }
+ cargo {
+ button $tl.$tag -text $label -command [list cmdr-cargo $seq]
+ grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we
+ }
+ where {
+ label $tl.l-gal-number -text "Galaxy number: " -justify right
+ entry $tl.gal-number -textvariable cmdr-${seq}(gal-number) \
+ -justify right -width 2
+ cmdr-validate-widget $seq $tl.gal-number [list integerp 1 8]
+ checkbutton $tl.std-gal -text "Standard galaxy" \
+ -variable cmdr-${seq}(std-gal) -justify left \
+ -command [list cmdr-std-gal $seq]
+ entry-on-change $tl.gal-number [list cmdr-set-gal-num $seq]
+ grid configure $tl.l-gal-number -row $r -column 0 -sticky e
+ grid configure $tl.std-gal -row $r -column 1 -sticky w
+ grid configure $tl.gal-number -row $r -column 2 -sticky we
+ incr r
+ label $tl.l-gal-seed -text "Galaxy seed: " -justify right
+ entry $tl.gal-seed -textvariable cmdr-${seq}(gal-seed) -width 12
+ cmdr-validate-widget $seq $tl.gal-seed galaxyp
+ entry-on-change $tl.gal-seed [list cmdr-update-world $seq]
+ grid configure $tl.l-gal-seed -row $r -column 0 -sticky e
+ grid configure $tl.gal-seed -row $r \
+ -column 1 -columnspan 2 -sticky we
+ incr r
+ if {[string equal $cmdr(gal-seed) [galaxy $cmdr(gal-number)]]} {
+ set cmdr(std-gal) 1
+ $tl.gal-seed configure -state disabled
+ } else {
+ set cmdr(std-gal) 0
+ }
+ label $tl.l-world-name -text "Planet: " -justify right
+ entry $tl.world-name -textvariable cmdr-${seq}(world-name) \
+ -state disabled -width 10 -justify left
+ grid configure $tl.l-world-name -row $r -column 0 -sticky e
+ grid configure $tl.world-name -row $r \
+ -column 1 -columnspan 2 -sticky we
+ incr r
+ button $tl.$tag -text "Show galaxy map" \
+ -command [list cmdr-show-map $seq]
+ grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we
+ }
+ default {
+ label $tl.l-$tag -text "($label)" -justify left
+ grid configure $tl.l-$tag -row $r -column 0 -sticky w
+ }
+ }
+ incr r
+ }
+ entry-on-change $tl.fuel [list cmdr-set-fuel $seq]
+ menu $tl.menu
+ menu $tl.menu.file
+ $tl.menu.file add command -label "New commander" -command cmdr-new
+ $tl.menu.file add command -label "Load commander..." \
+ -command { cmdr-loadfile }
+ $tl.menu.file add command -label "Save commander" \
+ -command [list cmdr-save $seq]
+ $tl.menu.file add command -label "Save as..." \
+ -command [list cmdr-saveas $seq]
+ $tl.menu.file add separator
+ $tl.menu.file add command -label "Close" -command [list cmdr-destroy $seq]
+ $tl.menu.file add command -label "Quit" -command { exit }
+ $tl.menu add cascade -label "File" -menu $tl.menu.file
+ $tl configure -menu $tl.menu
+ grid columnconfigure $tl 2 -weight 1
+ wm protocol $tl WM_DELETE_WINDOW [list cmdr-destroy $seq]
+ set cmdr(ok/$tl.cargo-qty.fluc) 1
+ cmdr-update-world $seq
+ cmdr-set-name $seq
+ incr nwin
+ return $seq
+}
+
+# --- File handling ---
+
+proc cmdr-load {file} {
+ global seq
+ incr seq
+ set c [read-file $file]
+ upvar \#0 cmdr-$seq cmdr
+ elite-unpackcmdr cmdr $c
+ set cmdr(file) $file
+ cmdr-open $seq
+}
+
+set cmdr-filetypes {
+ { "Commander file" ".nkc" }
+}
+
+proc cmdr-loadfile {} {
+ global cmdr-filetypes
+ set f [tk_getOpenFile \
+ -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \
+ -title "Load commander"]
+ if {![string equal $f ""]} {
+ cmdr-load $f
+ }
+}
+
+proc cmdr-save-file {seq file} {
+ upvar \#0 cmdr-$seq cmdr
+ set tl .cmdr-$seq
+ if {[catch { write-file $file [elite-packcmdr cmdr] } err]} {
+ moan $err
+ } else {
+ set cmdr(file) $file
+ cmdr-set-name $seq
+ }
+}
+
+proc cmdr-saveas {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ global cmdr-filetypes
+ if {![cmdr-check $seq]} { return }
+ set opts [list \
+ -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \
+ -title "Save commander"]
+ if {[info exists cmdr(file)]} {
+ lappend opts -initialdir [file dirname $cmdr(file)]
+ lappend opts -initialfile [file tail $cmdr(file)]
+ } else {
+ lappend opts -initialfile "JAMESON.nkc"
+ }
+ set f [eval tk_getSaveFile $opts]
+ if {[string equal $f ""]} { return }
+ cmdr-save-file $seq $f
+}
+
+proc cmdr-save {seq} {
+ upvar \#0 cmdr-$seq cmdr
+ if {![info exists cmdr(file)]} {
+ cmdr-saveas $seq
+ return
+ }
+ if {![cmdr-check $seq]} { return }
+ cmdr-save-file $seq $cmdr(file)
+}
+
+proc cmdr-new {} {
+ global seq galaxy1 products
+ incr seq
+ upvar \#0 cmdr-$seq 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
+ cmdr-open $seq
+}
+
+#----- Main program ---------------------------------------------------------
+
+wm withdraw .
+
+if {[llength $argv]} {
+ foreach a $argv {
+ set g [parse-galaxy-spec $a]
+ if {[llength $g]} {
+ destructure {ng g} $g
+ map-new $ng $g
+ } else {
+ cmdr-load $a
+ }
+ }
+} else {
+ map-new 1 $galaxy1
+}
+if {!$nwin} { exit }
+
+#----- That's all, folks ----------------------------------------------------
--- /dev/null
+#! /usr/bin/tclsh
+
+package require "elite" "1.0.0"
+
+proc ok {s vv expr} {
+ global argv0
+ set ip [interp create]
+ foreach v $vv {
+ upvar 1 $v var
+ if {[array exists var]} {
+ foreach {k d} [array get var] {
+ $ip eval [list set ${v}($k) $d]
+ }
+ } else {
+ $ip eval [list set $v $var]
+ }
+ }
+ elite-worldinfo p $s
+ foreach {k v} [array get p] {
+ $ip eval [list set $k $v]
+ }
+ if {[catch { $ip eval [list expr $expr] } rc]} {
+ puts stderr "$argv0: error in expression: $rc"
+ exit 1
+ }
+ interp delete $ip
+ return $rc
+}
+
+set g $galaxy1
+set d 70
+for {set i 0} {$i < [llength $argv]} {incr i} {
+ set a [lindex $argv $i]
+ switch -glob -- $a {
+ "-g" {
+ incr i
+ set a [lindex $argv $i]
+ set g [parse-galaxy-spec $a]
+ if {[string equal $g ""]} {
+ puts stderr "$argv0: bad galaxy string `$a'"
+ exit 1
+ }
+ destructure {. g} $g
+ }
+ "--" {
+ incr i
+ break
+ }
+ "-*" {
+ puts stderr "usage: $argv0 \[-g GALAXY\] \[EXPR\]"
+ exit 1
+ }
+ default {
+ break
+ }
+ }
+}
+
+set expr {}
+if {$i == [llength $argv] - 1} {
+ set expr [lindex $argv $i]
+} elseif {$i != [llength $argv]} {
+ puts stderr "usage: $argv0 \[-g GALAXY\] \[EXPR\]"
+ exit 1
+}
+set ww [worldinfo $g]
+foreach {s x y} $ww {
+ if {[string equal $expr ""] || [ok $s {} $expr]} {
+ puts [world-summary $s]
+ }
+}
--- /dev/null
+#! /usr/bin/tclsh
+
+package require "elite" "1.0.0"
+
+set syms "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+proc symbol {i} {
+ global syms
+ if {$i < [string length $syms]} {
+ return [string index $syms $i]
+ }
+ set hi [expr {$i / [string length $syms]}]
+ set lo [expr {$i % [string length $syms]}]
+ return [string index $syms $hi][string index $syms $lo]
+}
+
+proc show-map {asp wx wy ww {n ""}} {
+ set minx 10000
+ set miny 10000
+ set maxx 0
+ set maxy 0
+
+ foreach {s x y} $ww {
+ if {$x < $minx} { set minx $x}
+ if {$y < $miny} { set miny $y}
+ if {$x > $maxx} { set maxx $x}
+ if {$y > $maxy} { set maxy $y}
+ }
+ set dx [expr {$maxx - $minx}]
+ set dy [expr {$maxy - $miny}]
+ if {$dx == 0} { set dx 1 }
+ if {$dy == 0} { set dy 1 }
+
+ set sc [expr {$wx/double($dx)}]
+ if {$dy * $sc/$asp > $wy} {
+ set sc [expr {$wy * $asp/double($dy)}]
+ }
+ set gw {}
+ foreach {s x y} $ww {
+ set gx [expr {int(($x - $minx) * $sc + 0.5)}]
+ set gy [expr {int(($y - $miny) * $sc/$asp + 0.5)}]
+ lappend gw [list $s $gx $gy]
+ }
+
+ set pw [lsort -index 1 -integer -increasing $gw]
+ set pw [lsort -index 2 -integer -increasing $pw]
+ set x 0
+ set y 0
+ set i 0
+ set l {}
+ foreach w $pw {
+ destructure {s px py} $w
+ if {$y < $py} {
+ puts -nonewline [string repeat "\n" [expr {$py - $y}]]
+ set x 0
+ set y $py
+ }
+ if {$x < $px} {
+ puts -nonewline [string repeat " " [expr {$px - $x}]]
+ set x $px
+ }
+ if {[string equal $s $n]} {
+ set sy "*"
+ } else {
+ set sy [symbol $i]
+ incr i
+ }
+ puts -nonewline $sy
+ incr x [string length $sy]
+ lappend l $sy $s
+ }
+ puts -nonewline "\n"
+ return $l
+}
+
+proc show-key {l n} {
+ global gov eco
+ if {![string equal $n ""]} {
+ elite-worldinfo p $n
+ }
+ foreach {sy s} $l {
+ elite-worldinfo pp $s
+ set out [format "%2s %s" $sy [world-summary $s]]
+ if {![string equal $n ""]} {
+ append out [format " (%.1f LY)" \
+ [expr {[world-distance $p(x) $p(y) $pp(x) $pp(y)]/10.0}]]
+ }
+ puts $out
+ }
+}
+
+proc local-area {g d n} {
+ set ww [worldinfo $g]
+ elite-worldinfo p $n
+
+ set w {}
+ foreach {s x y} $ww {
+ if {abs($p(x) - $x) > $d + 10 || abs($p(y) - $y) > $d + 10 ||
+ [world-distance $p(x) $p(y) $x $y] > $d} { continue }
+ lappend w $s $x $y
+ }
+ return $w
+}
+
+set g $galaxy1
+set wx 72
+set wy 10
+set asp 2.17
+set d 70
+set v 1
+set usage "usage: $argv0 \[-qv\] \[-g GAL\] \[-d DIST\] \[-w WD,HT\] \[-a ASP\] \[PLANET\]"
+for {set i 0} {$i < [llength $argv]} {incr i} {
+ set a [lindex $argv $i]
+ switch -glob -- $a {
+ "-g" {
+ incr i
+ set a [lindex $argv $i]
+ set g [parse-galaxy-spec $a]
+ if {[string equal $g ""]} {
+ puts stderr "$argv0: bad galaxy string `$a'"
+ exit 1
+ }
+ destructure {. g} $g
+ }
+ "-d" {
+ incr i
+ set d [expr {[lindex $argv $i] * 10}]
+ }
+ "-w" {
+ incr i
+ if {![regexp {^(\d+),(\d+)$} [lindex $argv $i] . wx wy]} {
+ puts stderr "$argv0: bad window size string"
+ exit 1
+ }
+ }
+ "-a" {
+ incr i
+ set asp [lindex $argv $i]
+ }
+ "-v" {
+ incr v
+ }
+ "-q" {
+ incr v -1
+ }
+ "--" {
+ incr i
+ break
+ }
+ "-*" {
+ puts stderr $usage
+ exit 1
+ }
+ default {
+ break
+ }
+ }
+}
+
+set p [lrange $argv $i end]
+switch -exact [llength $p] {
+ 0 {
+ set n ""
+ set w [worldinfo $g]
+ incr v -1
+ }
+ 1 {
+ set n [parse-planet-spec $g $a]
+ if {[string equal $n ""]} {
+ puts stderr "$argv0: unknown planet `$a'"
+ exit 1
+ }
+ set w [local-area $g $d $n]
+ }
+ default {
+ puts stderr $usage
+ exit 1
+ }
+}
+set l [show-map $asp $wx $wy $w $n]
+if {$v > 0} {
+ puts ""
+ show-key $l $n
+}
--- /dev/null
+#! /usr/bin/tclsh
+
+package require "elite" "1.0.0"
+
+proc ok {s vv expr} {
+ global argv0
+ set ip [interp create]
+ foreach v $vv {
+ upvar 1 $v var
+ if {[array exists var]} {
+ foreach {k d} [array get var] {
+ $ip eval [list set ${v}($k) $d]
+ }
+ } else {
+ $ip eval [list set $v $var]
+ }
+ }
+ elite-worldinfo p $s
+ foreach {k v} [array get p] {
+ $ip eval [list set $k $v]
+ }
+ if {[catch { $ip eval [list expr $expr] } rc]} {
+ puts stderr "$argv0: error in expression: $rc"
+ exit 1
+ }
+ interp delete $ip
+ return $rc
+}
+
+set g $galaxy1
+set d 70
+for {set i 0} {$i < [llength $argv]} {incr i} {
+ set a [lindex $argv $i]
+ switch -glob -- $a {
+ "-g" {
+ incr i
+ set a [lindex $argv $i]
+ set g [parse-galaxy-spec $a]
+ if {[string equal $g ""]} {
+ puts stderr "$argv0: bad galaxy string `$a'"
+ exit 1
+ }
+ destructure {. g} $g
+ }
+ "-d" {
+ incr i
+ set d [expr {[lindex $argv $i] * 10}]
+ }
+ "--" {
+ incr i
+ break
+ }
+ "-*" {
+ puts stderr "usage: $argv0 \[-g GALAXY\] \[-d DIST\] AEXPR BEXPR"
+ exit 1
+ }
+ default {
+ break
+ }
+ }
+}
+if {$i != [llength $argv] - 2} {
+ puts stderr "usage: $argv0 \[-g GALAXY\] \[-d DIST\] AEXPR BEXPR"
+ exit 1
+}
+destructure {aexpr bexpr} [lrange $argv $i end]
+puts -nonewline stderr "\[computing adjacency table..."
+flush stderr
+set ww [worldinfo $g]
+adjacency $ww adj $d
+puts stderr " done\]"
+unset a
+foreach {s x y} $ww {
+ if {![ok $s {} $aexpr]} { continue }
+ elite-worldinfo a $s
+ set l {}
+ foreach {ss xx yy} $adj($s) {
+ set d [world-distance $x $y $xx $yy]
+ if {[ok $ss {a d} $bexpr]} {
+ puts [format "%-11s %-11s (%.1f LY)" $a(name) [worldname $ss] \
+ [expr {[world-distance $x $y $xx $yy]/10.0}]]
+ }
+ }
+}
--- /dev/null
+#! /usr/bin/tclsh
+
+package require "elite" "1.0.0"
+
+set g $galaxy1
+set ng 1
+set weight weight-hops
+for {set i 0} {$i < [llength $argv]} {incr i} {
+ set a [lindex $argv $i]
+ switch -glob -- $a {
+ "-g" {
+ incr i
+ set a [lindex $argv $i]
+ set g [parse-galaxy-spec $a]
+ if {[string equal $g ""]} {
+ puts stderr "$argv0: bad galaxy string `$a'"
+ exit 1
+ }
+ destructure {ng g} $g
+ }
+ "-w" {
+ incr i
+ set a [lindex $argv $i]
+ set weight "weight-$a"
+ if {[lsearch -exact [info commands "weight-*"] $weight] == -1} {
+ puts stderr "$argv0: unknown weight function `$a'"
+ puts stderr "$argv0: I know [info commands weight-*]"
+ exit 1
+ }
+ }
+ "--" {
+ incr i
+ break
+ }
+ "-*" {
+ puts stderr "unknown switch `$a'"
+ exit 1
+ }
+ default {
+ break
+ }
+ }
+}
+
+set r {}
+set ww [worldinfo $g]
+foreach-world $g ii {
+ set px($ii(seed)) 1
+}
+foreach a [lrange $argv $i end] {
+ set s [parse-planet-spec $g $a]
+ if {[string equal $s ""]} {
+ puts stderr "$argv0: unknown planet `$a'"
+ exit 1
+ }
+ if {![info exists px($s)]} {
+ puts stderr "$argv0: planet `$a' doesn't exist in galaxy $ng"
+ exit 1
+ }
+ lappend r $s
+}
+if {[llength $r] < 2} {
+ puts stderr "usage: $argv0 \[-g GALAXY\] \[-w WEIGHT\] PLANET PLANET ..."
+ exit 1
+}
+puts -nonewline stderr "\[computing adjacency table..."
+adjacency $ww adj
+puts stderr " done\]"
+set home [lindex $r 0]
+set rt {}
+foreach w [lrange $r 1 end] {
+ destructure {p .} [shortest-path adj $home $w $weight]
+ if {![llength $p]} {
+ puts -stderr "$argv0: no route from [worldinfo $home] to [worldinfo $w]"
+ exit 1
+ }
+ eval lappend rt $p
+ set home $w
+}
+set last x
+foreach s $rt {
+ if {![string equal $s $last]} {
+ puts [world-summary $s]
+ set last $s
+ }
+}
--- /dev/null
+#! /usr/bin/tclsh
+
+package require "elite" "1.0.0"
+
+# --- An optimal trading pair ---
+
+set lezaer "1598f98a6581"
+set esmaonbe "7997d18a0d89"
+
+set np [expr {[llength $products]/2}]
+puts -nonewline stderr "\[[string repeat { } $np]\] "
+puts -nonewline stderr "\[[string repeat { } 32]\]"
+puts -nonewline stderr "\r\[[string repeat { } $np]\] \["
+flush stderr
+foreach {a s} [list l $lezaer e $esmaonbe] {
+ for {set f 0} {$f < 256} {incr f} {
+ elite-market m $s $f
+ foreach {t p} $products { destructure [list ${a}($f:$t) .] $m($t) }
+ if {($f & 15) == 15} { puts -nonewline stderr "."; flush stderr }
+ }
+}
+foreach {t p} $products {
+ set tot($t) 0
+ set min($t) 100000
+ set max($t) -100000
+}
+set i 0
+foreach {t p} $products {
+ incr i
+ puts -nonewline stderr "\r\[[string repeat . $i]"
+ puts -nonewline stderr "[string repeat { } [expr {$np - $i}]]\] "
+ puts -nonewline stderr "\[[string repeat { } 32]\]"
+ puts -nonewline stderr "\r\[[string repeat . $i]"
+ puts -nonewline stderr "[string repeat { } [expr {$np - $i}]]\] \["
+ set ll {}
+ set ee {}
+ for {set f 0} {$f < 256} {incr f} {
+ lappend ll $l($f:$t)
+ lappend ee $e($f:$t)
+ }
+ set j 0
+ foreach pl $ll {
+ foreach pe $ee {
+ set pr [expr {$pl - $pe}]
+ if {$pr < $min($t)} { set min($t) $pr }
+ if {$pr > $max($t)} { set max($t) $pr }
+ incr tot($t) $pr
+ }
+ incr j
+ if {($j & 7) == 0} { puts -nonewline stderr "."; flush stderr }
+ }
+}
+puts stderr ""
+
+foreach {t p} $products {
+ puts [format "%-15s %5d %4d %4d" $t \
+ $min($t) [expr {$tot($t)/65536}] $max($t)]
+}
--- /dev/null
+#! /usr/bin/tclsh
+
+package require "elite" "1.0.0"
+
+proc reach {dist seed} {
+ set ww [worldinfo $seed]
+ puts -nonewline stderr "\[computing adjacency table..."
+ adjacency $ww a $dist
+ puts stderr " done\]"
+ puts -nonewline stderr "\[painting..."
+ flush stdout
+ foreach {s x w} $ww { set p($s) 1 }
+ set pp {}
+ while 1 {
+ set ps [array startsearch p]
+ if {![array anymore p $ps]} { array donesearch p $ps; break }
+ set cc [array nextelement p $ps]
+ array donesearch p $ps
+ unset p($cc)
+ set go 1
+ while {$go} {
+ set go 0
+ foreach c $cc {
+ foreach w $a($c) {
+ if {[info exists p($w)]} {
+ unset p($w)
+ lappend cc $w
+ set go 1
+ }
+ }
+ }
+ }
+ lappend pp $cc
+ }
+ puts stderr " done\]\n"
+ foreach cc $pp {
+ set de 1
+ set l {}
+ foreach c $cc {
+ elite-worldinfo i $c
+ if {$i(techlevel) >= 10} {
+ set de 0
+ }
+ lappend l [world-summary $i(seed)]
+ }
+ foreach n $l {
+ if {$de} { append n " *" }
+ puts $n
+ }
+ puts ""
+ }
+}
+
+if {[llength $argv] == 0} {
+ set argv {1 2 3 4 5 6 7 8}
+}
+set gg {}
+set d 70
+for {set i 0} {$i < [llength $argv]} {incr i} {
+ set a [lindex $argv $i]
+ switch -glob -- $a {
+ "-d" {
+ incr i
+ set d [expr {[lindex $argv $i] * 10}]
+ }
+ "-*" {
+ puts stderr "usage: $argv0 \[-d DIST\] \[GALAXY ...\]"
+ exit 1
+ }
+ default {
+ set g [parse-galaxy-spec $a]
+ if {[string equal $g ""]} {
+ puts stderr "$argv0: bad galaxy spec `$a'"
+ exit 1
+ }
+ destructure {ng g} $g
+ lappend gg $d $ng $g
+ }
+ }
+}
+foreach {d ng g} $gg {
+ puts "*** GALAXY $ng ***"
+ reach $d $g
+}
--- /dev/null
+/* -*-c-*-
+ *
+ * $Id: elite.c,v 1.1 2003/02/24 01:13:12 mdw Exp $
+ *
+ * Elite planet data
+ *
+ * (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.
+ */
+
+/*----- Revision history --------------------------------------------------*
+ *
+ * $Log: elite.c,v $
+ * Revision 1.1 2003/02/24 01:13:12 mdw
+ * Initial import.
+ *
+ */
+
+/*----- Header files ------------------------------------------------------*/
+
+#include <ctype.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <tcl.h>
+
+/*----- Data structures ---------------------------------------------------*/
+
+typedef struct world {
+ unsigned char x[6];
+} world;
+
+typedef struct worldinfo {
+ unsigned x, y, gov, eco, tech, pop, prod, rad;
+} worldinfo;
+
+/*----- The world type ----------------------------------------------------*/
+
+static void world_fir(Tcl_Obj *o)
+{
+ Tcl_Free(o->internalRep.otherValuePtr);
+}
+
+static int xtoi(unsigned x)
+{
+ if (x >= '0' && x <= '9')
+ return (x - '0');
+ else if (x >= 'a' && x <= 'f')
+ return (x - 'a' + 10);
+ else if (x >= 'A' && x <= 'F')
+ return (x - 'A' + 10);
+ else
+ abort();
+}
+
+static Tcl_ObjType world_type;
+
+static int world_sfa(Tcl_Interp *ti, Tcl_Obj *o)
+{
+ int l;
+ world ww, *w;
+ int i;
+ char *p = Tcl_GetStringFromObj(o, &l);
+ if (l != 12)
+ goto bad;
+ for (i = 0; i < 12; i += 2) {
+ if (!isxdigit((unsigned char)p[i]) ||
+ !isxdigit((unsigned char)p[i + 1]))
+ goto bad;
+ ww.x[i >> 1] = (xtoi(p[i]) << 4) | (xtoi(p[i + 1]));
+ }
+ w = (world *)Tcl_Alloc(sizeof(*w));
+ *w = ww;
+ o->internalRep.otherValuePtr = w;
+ o->typePtr = &world_type;
+ return (TCL_OK);
+
+bad:
+ if (ti)
+ Tcl_SetResult(ti, "bad world seed string", TCL_STATIC);
+ return (TCL_ERROR);
+}
+
+static void world_us(Tcl_Obj *o)
+{
+ char *p;
+ world *w = o->internalRep.otherValuePtr;
+ int i;
+
+ p = Tcl_Alloc(13);
+ p[12] = 0;
+ o->bytes = p;
+ o->length = 12;
+ for (i = 0; i < 6; i++, p += 2)
+ sprintf(p, "%02x", w->x[i]);
+}
+
+static void world_dir(Tcl_Obj *o, Tcl_Obj *oo)
+{
+ world *w = (world *)Tcl_Alloc(sizeof(*w));
+ memcpy(w, o->internalRep.otherValuePtr, sizeof(world));
+ oo->internalRep.otherValuePtr = w;
+ oo->typePtr = &world_type;
+ Tcl_InvalidateStringRep(oo);
+}
+
+static /*const*/ Tcl_ObjType world_type = {
+ "elite-world", world_fir, world_dir, world_us, world_sfa
+};
+
+static world *world_get(Tcl_Interp *ti, Tcl_Obj *o)
+{
+ if (Tcl_ConvertToType(ti, o, &world_type) != TCL_OK)
+ return (0);
+ return (o->internalRep.otherValuePtr);
+}
+
+static Tcl_Obj *world_new(const world *w)
+{
+ world *ww;
+ Tcl_Obj *o = Tcl_NewObj();
+ ww = (world *)Tcl_Alloc(sizeof(*ww));
+ *ww = *w;
+ o->internalRep.otherValuePtr = ww;
+ o->typePtr = &world_type;
+ Tcl_InvalidateStringRep(o);
+ return (o);
+}
+
+/*----- Elite-specific hacking --------------------------------------------*
+ *
+ * Taken from `Elite: The New Kind' by Christian Pinder.
+ */
+
+static void waggle(world *w, world *ww)
+{
+ unsigned int h, l;
+
+ /* --- What goes on --- *
+ *
+ * 16-bit add of all three words, shift up, and insert the new value at the
+ * end.
+ */
+
+ l = w->x[0];
+ h = w->x[1];
+ l += w->x[2];
+ h += w->x[3] + (l >= 0x100);
+ l &= 0xff; h &= 0xff;
+ l += w->x[4];
+ h += w->x[5] + (l >= 0x100);
+ l &= 0xff; h &= 0xff;
+ ww->x[0] = w->x[2]; ww->x[1] = w->x[3];
+ ww->x[2] = w->x[4]; ww->x[3] = w->x[5];
+ ww->x[4] = l; ww->x[5] = h;
+}
+
+/*----- Tcl commands ------------------------------------------------------*/
+
+static int err(Tcl_Interp *ti, /*const*/ char *p)
+{
+ Tcl_SetResult(ti, p, TCL_STATIC);
+ return (TCL_ERROR);
+}
+
+/* --- elite-nextworld SEED --- */
+
+static int cmd_nextworld(ClientData cd, Tcl_Interp *ti,
+ int objc, Tcl_Obj *const *objv)
+{
+ world *w, ww;
+ if (objc != 2)
+ return (err(ti, "usage: elite-nextworld SEED"));
+ if ((w = world_get(ti, objv[1])) == 0)
+ return (TCL_ERROR);
+ waggle(w, &ww);
+ waggle(&ww, &ww);
+ waggle(&ww, &ww);
+ waggle(&ww, &ww);
+ Tcl_SetObjResult(ti, world_new(&ww));
+ return (TCL_OK);
+}
+
+/* --- elite-nextgalaxy SEED --- */
+
+static int cmd_nextgalaxy(ClientData cd, Tcl_Interp *ti,
+ int objc, Tcl_Obj *const *objv)
+{
+ world *w, ww;
+ int i;
+
+ if (objc != 2)
+ return (err(ti, "usage: elite-nextgalaxy SEED"));
+ if ((w = world_get(ti, objv[1])) == 0)
+ return (TCL_ERROR);
+ for (i = 0; i < 6; i++)
+ ww.x[i] = ((w->x[i] << 1) | (w->x[i] >> 7)) & 0xff;
+ Tcl_SetObjResult(ti, world_new(&ww));
+ return (TCL_OK);
+}
+
+/* --- elite-worldinfo ARR SEED --- */
+
+static void getworldinfo(worldinfo *wi, world *w)
+{
+ wi->x = w->x[3];
+ wi->y = w->x[1];
+ wi->gov = (w->x[2] >> 3) & 0x07;
+ wi->eco = w->x[1] & 0x07;
+ if (wi->gov < 2)
+ wi->eco |= 0x02;
+ wi->tech = ((wi->eco ^ 7) + (w->x[3] & 0x03) +
+ (wi->gov >> 1) + (wi->gov & 0x01) + 1);
+ wi->pop = wi->tech * 4 + wi->gov + wi->eco - 3;
+ wi->prod = ((wi->eco ^ 7) + 3) * (wi->gov + 4) * wi->pop * 8;
+ wi->rad = (((w->x[5] & 0x0f) + 11) << 8) + w->x[3];
+}
+
+static const char digrams[] =
+ "abouseitiletstonlonuthnoallexegezacebisouses"
+ "armaindirea?eratenberalavetiedorquanteisrion";
+
+static const char *const desc[][5] = {
+/* 0 */ { "fabled", "notable", "well known", "famous", "noted" },
+/* 1 */ { "very ", "mildly ", "most ", "reasonably ", "" },
+/* 2 */ { "ancient", "<20>", "great", "vast", "pink" },
+/* 3 */ { "<29> <28> plantations", "mountains", "<27>",
+ "<19> forests", "oceans" },
+/* 4 */ { "shyness", "silliness", "mating traditions",
+ "loathing of <5>", "love for <5>" },
+/* 5 */ { "food blenders", "tourists", "poetry", "discos", "<13>" },
+/* 6 */ { "talking tree", "crab", "bat", "lobst", "%R" },
+/* 7 */ { "beset", "plagued", "ravaged", "cursed", "scourged" },
+/* 8 */ { "<21> civil war", "<26> <23> <24>s",
+ "a <26> disease", "<21> earthquakes", "<21> solar activity" },
+/* 9 */ { "its <2> <3>", "the %I <23> <24>",
+ "its inhabitants' <25> <4>", "<32>", "its <12> <13>" },
+/* 10 */ { "juice", "brandy", "water", "brew", "gargle blasters" },
+/* 11 */ { "%R", "%I <24>", "%I %R", "%I <26>", "<26> %R" },
+/* 12 */ { "fabulous", "exotic", "hoopy", "unusual", "exciting" },
+/* 13 */ { "cuisine", "night life", "casinos", "sit coms", " <32>" },
+/* 14 */ { "%H", "The planet %H", "The world %H",
+ "This planet", "This world" },
+/* 15 */ { "n unremarkable", " boring", " dull", " tedious", " revolting" },
+/* 16 */ { "planet", "world", "place", "little planet", "dump" },
+/* 17 */ { "wasp", "moth", "grub", "ant", "%R" },
+/* 18 */ { "poet", "arts graduate", "yak", "snail", "slug" },
+/* 19 */ { "tropical", "dense", "rain", "impenetrable", "exuberant" },
+/* 20 */ { "funny", "weird", "unusual", "strange", "peculiar" },
+/* 21 */ { "frequent", "occasional", "unpredictable", "dreadful", "deadly" },
+/* 22 */ { "<1><0> for <9>", "<1><0> for <9> and <9>",
+ "<7> by <8>", "<1><0> for <9> but <7> by <8>","a<15> <16>" },
+/* 23 */ { "<26>", "mountain", "edible", "tree", "spotted" },
+/* 24 */ { "<30>", "<31>", "<6>oid", "<18>", "<17>" },
+/* 25 */ { "ancient", "exceptional", "eccentric", "ingrained", "<20>" },
+/* 26 */ { "killer", "deadly", "evil", "lethal", "vicious" },
+/* 27 */ { "parking meters", "dust clouds", "ice bergs",
+ "rock formations", "volcanoes" },
+/* 28 */ { "plant", "tulip", "banana", "corn", "%Rweed" },
+/* 29 */ { "%R", "%I %R", "%I <26>", "inhabitant", "%I %R" },
+/* 30 */ { "shrew", "beast", "bison", "snake", "wolf" },
+/* 31 */ { "leopard", "cat", "monkey", "goat", "fish" },
+/* 32 */ { "<11> <10>", "%I <30> <33>", "its <12> <31> <33>",
+ "<34> <35>", "<11> <10>" },
+/* 33 */ { "meat", "cutlet", "steak", "burgers", "soup" },
+/* 34 */ { "ice", "mud", "Zero-G", "vacuum", "%I ultra" },
+/* 35 */ { "hockey", "cricket", "karate", "polo", "tennis" }
+};
+
+static int mangle(world *w)
+{
+ unsigned a, x;
+
+ x = (w->x[2] << 1) & 0xff;
+ a = x + w->x[4];
+ if (w->x[2] & 0x80)
+ a++;
+ w->x[2] = a & 0xff;
+ w->x[4] = x;
+ a >>= 8;
+ x = w->x[3];
+ a = (a + x + w->x[5]) & 0xff;
+ w->x[3] = a;
+ w->x[5] = x;
+ return (a);
+}
+
+static void goatsoup(Tcl_Obj *d, const char *pn, world *w, const char *p)
+{
+ for (;;) {
+ size_t sz = strcspn(p, "<%");
+ unsigned n;
+ char buf[12];
+ char *q;
+
+ Tcl_AppendToObj(d, (char *)p, sz);
+ p += sz;
+ switch (*p) {
+ unsigned i, j;
+ case 0:
+ return;
+ case '<':
+ i = strtoul(p + 1, (char **)&p, 10);
+ p++;
+ j = mangle(w);
+ goatsoup(d, pn, w, desc[i][(j >= 0x33) + (j >= 0x66) +
+ (j >= 0x99) + (j >= 0xcc)]);
+ break;
+ case '%':
+ p++;
+ switch (*p++) {
+ case 'H':
+ Tcl_AppendToObj(d, (char *)pn, -1);
+ break;
+ case 'I':
+ sz = strlen(pn) - 1;
+ Tcl_AppendToObj(d, (char *)pn,
+ (pn[sz] == 'i' || pn[sz] == 'e') ? sz : sz + 1);
+ Tcl_AppendToObj(d, "ian", 3);
+ break;
+ case 'R':
+ n = (mangle(w) & 0x03) + 1;
+ q = buf;
+ while (n--) {
+ unsigned i = mangle(w) & 0x3e;
+ *q++ = digrams[i++];
+ if (digrams[i] != '?')
+ *q++ = digrams[i++];
+ }
+ *buf = toupper(*buf);
+ Tcl_AppendToObj(d, buf, q - buf);
+ break;
+ default:
+ abort();
+ }
+ break;
+ default:
+ abort();
+ }
+ }
+}
+
+static int cmd_worldinfo(ClientData cd, Tcl_Interp *ti,
+ int objc, Tcl_Obj *const *objv)
+{
+ world *w;
+ worldinfo wi;
+ char *arr;
+ char buf[9];
+ char *p;
+ unsigned j, n;
+ Tcl_Obj *o;
+ world ww;
+
+ /* --- Check arguments --- */
+
+ if (objc != 3)
+ return (err(ti, "usage: elite-worldinfo ARR SEED"));
+ if ((w = world_get(ti, objv[2])) == 0)
+ return (TCL_ERROR);
+ arr = Tcl_GetString(objv[1]);
+
+ /* --- Get the basic information --- */
+
+ getworldinfo(&wi, w);
+ if (!Tcl_SetVar2Ex(ti, arr, "x", Tcl_NewIntObj(wi.x * 4),
+ TCL_LEAVE_ERR_MSG) ||
+ !Tcl_SetVar2Ex(ti, arr, "y", Tcl_NewIntObj(wi.y * 2),
+ TCL_LEAVE_ERR_MSG) ||
+ !Tcl_SetVar2Ex(ti, arr, "government", Tcl_NewIntObj(wi.gov),
+ TCL_LEAVE_ERR_MSG) ||
+ !Tcl_SetVar2Ex(ti, arr, "economy", Tcl_NewIntObj(wi.eco),
+ TCL_LEAVE_ERR_MSG) ||
+ !Tcl_SetVar2Ex(ti, arr, "techlevel", Tcl_NewIntObj(wi.tech),
+ TCL_LEAVE_ERR_MSG) ||
+ !Tcl_SetVar2Ex(ti, arr, "population", Tcl_NewIntObj(wi.pop),
+ TCL_LEAVE_ERR_MSG) ||
+ !Tcl_SetVar2Ex(ti, arr, "productivity", Tcl_NewIntObj(wi.prod),
+ TCL_LEAVE_ERR_MSG) ||
+ !Tcl_SetVar2Ex(ti, arr, "radius", Tcl_NewIntObj(wi.rad),
+ TCL_LEAVE_ERR_MSG) ||
+ !Tcl_SetVar2Ex(ti, arr, "seed", objv[2],
+ TCL_LEAVE_ERR_MSG))
+ return (TCL_ERROR);
+
+ /* --- Work out the inhabitants --- */
+
+ if (!(w->x[4] & 0x80)) {
+ if (!Tcl_SetVar2(ti, arr, "inhabitants", "humans", TCL_LEAVE_ERR_MSG))
+ return (TCL_ERROR);
+ } else {
+ static const char *const id_a[] = { "large", "fierce", "small" };
+ static const char *const id_b[] = { "green", "red", "yellow", "blue",
+ "black", "harmless" };
+ static const char *const id_c[] = { "slimy", "bug-eyed", "horned",
+ "bony", "fat", "furry" };
+ static const char *const id_d[] = { "rodents", "frogs", "lizards",
+ "lobsters", "birds", "humanoids",
+ "felines", "insects" };
+
+ o = Tcl_NewListObj(0, 0);
+ j = (w->x[5] >> 2) & 0x07;
+ if (j < 3)
+ Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_a[j], -1));
+ j = (w->x[5] >> 5) & 0x07;
+ if (j < 6)
+ Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_b[j], -1));
+ j = (w->x[1] ^ w->x[3]) & 0x07;
+ if (j < 6)
+ Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_c[j], -1));
+ j += w->x[5] & 0x03;
+ Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_d[j & 0x07], -1));
+ if (!Tcl_SetVar2Ex(ti, arr, "inhabitants", o, TCL_LEAVE_ERR_MSG))
+ return (TCL_ERROR);
+ }
+
+ /* --- Work out the planet name --- */
+
+ n = (w->x[0] & 0x40) ? 4 : 3;
+ p = buf;
+ ww = *w;
+ while (n--) {
+ j = ww.x[5] & 0x1f;
+ if (j) {
+ j = (j + 12) << 1;
+ *p++ = digrams[j++];
+ if (digrams[j] != '?')
+ *p++ = digrams[j];
+ }
+ waggle(&ww, &ww);
+ }
+ *p++ = 0;
+ *buf = toupper(*buf);
+ if (!Tcl_SetVar2Ex(ti, arr, "name", Tcl_NewStringObj(buf, -1),
+ TCL_LEAVE_ERR_MSG))
+ return (TCL_ERROR);
+
+ /* --- Finally work out the goat-soup description --- */
+
+ ww = *w;
+ o = Tcl_NewStringObj(0, 0);
+ goatsoup(o, buf, &ww, "<14> is <22>.");
+ if (!Tcl_SetVar2Ex(ti, arr, "description", o, TCL_LEAVE_ERR_MSG))
+ return (TCL_ERROR);
+ return (TCL_OK);
+}
+
+/* --- elite-market ARR SEED [FLUC] --- */
+
+static const struct item {
+ /*const*/ char *name;
+ unsigned base;
+ int var;
+ unsigned qty;
+ unsigned mask;
+} items[] = {
+ { "food", 19, -2, 6, 0x01 },
+ { "textiles", 20, -1, 10, 0x03 },
+ { "radioactives", 65, -3, 2, 0x07 },
+ { "slaves", 40, -5, 226, 0x1f },
+ { "liquor-wines", 83, -5, 251, 0x0f },
+ { "luxuries", 196, 8, 54, 0x03 },
+ { "narcotics", 235, 29, 8, 0x78 },
+ { "computers", 154, 14, 56, 0x03 },
+ { "machinery", 117, 6, 40, 0x07 },
+ { "alloys", 78, 1, 17, 0x1f },
+ { "firearms", 124, 13, 29, 0x07 },
+ { "furs", 176, -9, 220, 0x3f },
+ { "minerals", 32, -1, 53, 0x03 },
+ { "gold", 97, -1, 66, 0x07 },
+ { "platinum", 171, -2, 55, 0x1f },
+ { "gem-stones", 45, -1, 250, 0x0f },
+ { "alien-items", 53, 15, 192, 0x07 },
+ { 0, 0, 0, 0, 0x00 }
+};
+
+static int cmd_market(ClientData cd, Tcl_Interp *ti,
+ int objc, Tcl_Obj *const *objv)
+{
+ int fluc = 0;
+ world *w;
+ worldinfo wi;
+ const struct item *i;
+ char *arr;
+
+ if (objc < 3 || objc > 5)
+ return (err(ti, "usage: elite-market ARR SEED [FLUC]"));
+ if ((w = world_get(ti, objv[2])) == 0)
+ return (TCL_ERROR);
+ arr = Tcl_GetString(objv[1]);
+ if (objc >= 4 && Tcl_GetIntFromObj(ti, objv[3], &fluc) != TCL_OK)
+ return (TCL_ERROR);
+ getworldinfo(&wi, w);
+
+ for (i = items; i->name; i++) {
+ unsigned pr, qt;
+ Tcl_Obj *oo[2];
+ pr = (i->base + (fluc & i->mask) + (wi.eco * i->var)) & 0xff;
+ qt = (i->qty + (fluc & i->mask) - (wi.eco * i->var)) & 0xff;
+ if (qt & 0x80)
+ qt = 0;
+ oo[0] = Tcl_NewIntObj(pr << 2);
+ oo[1] = Tcl_NewIntObj(qt & 0x3f);
+ if (!Tcl_SetVar2Ex(ti, arr, i->name, Tcl_NewListObj(2, oo),
+ TCL_LEAVE_ERR_MSG))
+ return (TCL_ERROR);
+ }
+ return (TCL_OK);
+}
+
+/*----- Commander file decomposition --------------------------------------*/
+
+static unsigned cksum(const unsigned char *p, size_t sz)
+{
+ unsigned a = 0x49, c = 0;
+
+ p += sz - 1;
+ while (--sz) {
+ a += *--p + c;
+ c = a >> 8;
+ a &= 0xff;
+ a ^= p[1];
+ }
+ fflush(stdout);
+ return (a);
+}
+
+/* --- The big translation table --- */
+
+struct cmddata {
+ /*const*/ char *name;
+ unsigned off;
+ int (*get)(Tcl_Interp *, /*const*/ char *,
+ const unsigned char *, const struct cmddata *);
+ int (*put)(Tcl_Interp *, /*const*/ char *,
+ unsigned char *, const struct cmddata *);
+ int x;
+};
+
+static int get_byte(Tcl_Interp *ti, /*const*/ char *arr,
+ const unsigned char *p, const struct cmddata *cd)
+{
+ return (!Tcl_SetVar2Ex(ti, arr, cd->name,
+ Tcl_NewIntObj(*p - cd->x), TCL_LEAVE_ERR_MSG));
+}
+
+static int get_seed(Tcl_Interp *ti, /*const*/ char *arr,
+ const unsigned char *p, const struct cmddata *cd)
+{
+ world w;
+
+ memcpy(w.x, p, 6);
+ return (!Tcl_SetVar2Ex(ti, arr, cd->name,
+ world_new(&w), TCL_LEAVE_ERR_MSG));
+}
+
+static int get_word(Tcl_Interp *ti, /*const*/ char *arr,
+ const unsigned char *p, const struct cmddata *cd)
+{
+ return (!Tcl_SetVar2Ex(ti, arr, cd->name,
+ Tcl_NewLongObj((p[0] & 0xff) << 24 |
+ (p[1] & 0xff) << 16 |
+ (p[2] & 0xff) << 8 |
+ (p[3] & 0xff) << 0),
+ TCL_LEAVE_ERR_MSG));
+}
+
+static int get_hword(Tcl_Interp *ti, /*const*/ char *arr,
+ const unsigned char *p, const struct cmddata *cd)
+{
+ return (!Tcl_SetVar2Ex(ti, arr, cd->name,
+ Tcl_NewLongObj((p[0] & 0xff) << 0 |
+ (p[1] & 0xff) << 8),
+ TCL_LEAVE_ERR_MSG));
+}
+
+static int get_bool(Tcl_Interp *ti, /*const*/ char *arr,
+ const unsigned char *p, const struct cmddata *cd)
+{
+ return (!Tcl_SetVar2Ex(ti, arr, cd->name,
+ Tcl_NewBooleanObj(*p), TCL_LEAVE_ERR_MSG));
+}
+
+static int get_items(Tcl_Interp *ti, /*const*/ char *arr,
+ const unsigned char *p, const struct cmddata *cd)
+{
+ char buf[32];
+ const struct item *i;
+
+ for (i = items; i->name; i++) {
+ sprintf(buf, "%s-%s", cd->name, i->name);
+ if (!Tcl_SetVar2Ex(ti, arr, buf,
+ Tcl_NewIntObj(*p++), TCL_LEAVE_ERR_MSG))
+ return (-1);
+ }
+ return (0);
+}
+
+static int put_byte(Tcl_Interp *ti, /*const*/ char *arr,
+ unsigned char *p, const struct cmddata *cd)
+{
+ Tcl_Obj *o;
+ int i;
+
+ if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
+ Tcl_GetIntFromObj(ti, o, &i) != TCL_OK)
+ return (-1);
+ *p = i + cd->x;
+ return (0);
+}
+
+static int put_word(Tcl_Interp *ti, /*const*/ char *arr,
+ unsigned char *p, const struct cmddata *cd)
+{
+ Tcl_Obj *o;
+ long l;
+
+ if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
+ Tcl_GetLongFromObj(ti, o, &l) != TCL_OK)
+ return (-1);
+ p[0] = (l >> 24) & 0xff;
+ p[1] = (l >> 16) & 0xff;
+ p[2] = (l >> 8) & 0xff;
+ p[3] = (l >> 0) & 0xff;
+ return (0);
+}
+
+static int put_hword(Tcl_Interp *ti, /*const*/ char *arr,
+ unsigned char *p, const struct cmddata *cd)
+{
+ Tcl_Obj *o;
+ long l;
+
+ if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
+ Tcl_GetLongFromObj(ti, o, &l) != TCL_OK)
+ return (-1);
+ p[0] = (l >> 0) & 0xff;
+ p[1] = (l >> 8) & 0xff;
+ return (0);
+}
+
+static int put_const(Tcl_Interp *ti, /*const*/ char *arr,
+ unsigned char *p, const struct cmddata *cd)
+{
+ *p = cd->x;
+ return (0);
+}
+
+static int put_seed(Tcl_Interp *ti, /*const*/ char *arr,
+ unsigned char *p, const struct cmddata *cd)
+{
+ Tcl_Obj *o;
+ world *w;
+
+ if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
+ (w = world_get(ti, o)) == 0)
+ return (-1);
+ memcpy(p, w->x, 6);
+ return (0);
+}
+
+static int put_bool(Tcl_Interp *ti, /*const*/ char *arr,
+ unsigned char *p, const struct cmddata *cd)
+{
+ Tcl_Obj *o;
+ int b;
+
+ if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
+ Tcl_GetBooleanFromObj(ti, o, &b) != TCL_OK)
+ return (-1);
+ *p = b ? cd->x : 0;
+ return (0);
+}
+
+static int put_items(Tcl_Interp *ti, /*const*/ char *arr,
+ unsigned char *p, const struct cmddata *cd)
+{
+ char buf[32];
+ int ii;
+ Tcl_Obj *o;
+ const struct item *i;
+
+ for (i = items; i->name; i++) {
+ sprintf(buf, "%s-%s", cd->name, i->name);
+ if ((o = Tcl_GetVar2Ex(ti, arr, buf, TCL_LEAVE_ERR_MSG)) == 0 ||
+ Tcl_GetIntFromObj(ti, o, &ii) != TCL_OK)
+ return (-1);
+ *p++ = ii;
+ }
+ return (0);
+}
+
+static struct cmddata cmdtab[] = {
+ { "mission", 0, get_byte, put_byte, 0 },
+ { "world-x", 1, get_byte, put_byte, 0 },
+ { "world-y", 2, get_byte, put_byte, 0 },
+ { "gal-seed", 3, get_seed, put_seed, 0 },
+ { "credits", 9, get_word, put_word, 0 },
+ { "fuel", 13, get_byte, put_byte, 0 },
+ { "", 14, 0, put_const, 4 },
+ { "gal-number", 15, get_byte, put_byte, -1 },
+ { "front-laser", 16, get_byte, put_byte, 0 },
+ { "rear-laser", 17, get_byte, put_byte, 0 },
+ { "left-laser", 18, get_byte, put_byte, 0 },
+ { "right-laser", 19, get_byte, put_byte, 0 },
+ { "cargo", 22, get_byte, put_byte, 2 },
+ { "hold", 23, get_items, put_items, 0 },
+ { "ecm", 40, get_bool, put_bool, 255 },
+ { "fuel-scoop", 41, get_bool, put_bool, 255 },
+ { "energy-bomb", 42, get_bool, put_bool, 127 },
+ { "energy-unit", 43, get_byte, put_byte, 0 },
+ { "docking-computer", 44, get_bool, put_bool, 255 },
+ { "gal-hyperdrive", 45, get_bool, put_bool, 255 },
+ { "escape-pod", 46, get_bool, put_bool, 255 },
+ { "missiles", 51, get_byte, put_byte, 0 },
+ { "legal-status", 52, get_byte, put_byte, 0 },
+ { "station", 53, get_items, put_items, 0 },
+ { "market-fluc", 70, get_byte, put_byte, 0 },
+ { "score", 71, get_hword, put_hword, 0 },
+ { "", 74, 0, put_const, 32 },
+ { 0, 0, 0, 0, 0 }
+};
+
+/* --- elite-unpackcmdr [-force] ARR DATA --- */
+
+static int cmd_unpackcmdr(ClientData cd, Tcl_Interp *ti,
+ int objc, Tcl_Obj *const *objv)
+{
+ char *arr;
+ unsigned char *p, *q;
+ int sz;
+ unsigned f = 0;
+ unsigned ck;
+ const struct cmddata *c;
+
+#define f_force 1u
+
+ /* --- Read the arguments --- */
+
+ objc--; objv++;
+ while (objc) {
+ char *opt = Tcl_GetString(*objv);
+ if (strcmp(opt, "-force") == 0)
+ f |= f_force;
+ else if (strcmp(opt, "--") == 0) {
+ objc--;
+ objv++;
+ break;
+ } else
+ break;
+ objc--;
+ objv++;
+ }
+ if (objc != 2)
+ return (err(ti, "usage: elite-unpackcmdr [-force] ARR DATA"));
+ arr = Tcl_GetString(objv[0]);
+ p = Tcl_GetByteArrayFromObj(objv[1], &sz);
+
+ /* --- Check the data for correctness --- */
+
+ if (sz < 74)
+ return (err(ti, "bad commander data (bad length)"));
+ ck = cksum(p, 74);
+ if (!(f & f_force)) {
+ if (sz < 76 || p[74] != (ck ^ 0xa9) || p[75] != ck)
+ return (err(ti, "bad commander data (bad checksum)"));
+ for (q = p + 77; q < p + sz; q++)
+ if (*q)
+ return (err(ti, "bad commander data (bad data at end)"));
+ }
+
+ /* --- Deconstruct the data --- */
+
+ for (c = cmdtab; c->name; c++) {
+ if (c->get && c->get(ti, arr, p + c->off, c))
+ return (TCL_ERROR);
+ }
+ return (0);
+}
+
+/* --- elite-packcmdr ARR --- */
+
+static int cmd_packcmdr(ClientData cd, Tcl_Interp *ti,
+ int objc, Tcl_Obj *const *objv)
+{
+ char *arr;
+ unsigned char p[256];
+ unsigned ck;
+ const struct cmddata *c;
+
+ if (objc != 2)
+ return (err(ti, "usage: elite-packcmdr ARR"));
+ arr = Tcl_GetString(objv[1]);
+
+ memset(p, 0, sizeof(p));
+ for (c = cmdtab; c->name; c++) {
+ if (c->put && c->put(ti, arr, p + c->off, c))
+ return (TCL_ERROR);
+ }
+
+ ck = cksum(p, 74);
+ p[74] = ck ^ 0xa9;
+ p[75] = ck;
+ Tcl_SetObjResult(ti, Tcl_NewByteArrayObj(p, sizeof(p)));
+ return (0);
+}
+
+/*----- Initialization ----------------------------------------------------*/
+
+int Elite_SafeInit(Tcl_Interp *ti)
+{
+ static const struct cmd {
+ /*const*/ char *name;
+ Tcl_ObjCmdProc *proc;
+ } cmds[] = {
+ { "elite-nextworld", cmd_nextworld },
+ { "elite-nextgalaxy", cmd_nextgalaxy },
+ { "elite-worldinfo", cmd_worldinfo },
+ { "elite-market", cmd_market },
+ { "elite-unpackcmdr", cmd_unpackcmdr },
+ { "elite-packcmdr", cmd_packcmdr },
+ { 0, 0 }
+ };
+
+ const struct cmd *c;
+ for (c = cmds; c->name; c++)
+ Tcl_CreateObjCommand(ti, c->name, c->proc, 0, 0);
+ Tcl_RegisterObjType(&world_type);
+ if (Tcl_PkgProvide(ti, "elite-bits", "1.0.0"))
+ return (TCL_ERROR);
+ return (TCL_OK);
+}
+
+int Elite_Init(Tcl_Interp *ti)
+{
+ return (Elite_SafeInit(ti));
+}
+
+/*----- That's all, folks -------------------------------------------------*/
--- /dev/null
+EXPORTS\r
+ Elite_Init @1\r
+ Elite_SafeInit @2\r
--- /dev/null
+#! /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"
~mdw / rocl / commitdiff