chiark / gitweb /
Fix output formatting a little.
[rocl] / elite.c
1 /* -*-c-*-
2  *
3  * $Id$
4  *
5  * Elite planet data
6  *
7  * (c) 2003 Mark Wooding
8  */
9
10 /*----- Licensing notice --------------------------------------------------* 
11  *
12  * This program is free software; you can redistribute it and/or modify
13  * it under the terms of the GNU General Public License as published by
14  * the Free Software Foundation; either version 2 of the License, or
15  * (at your option) any later version.
16  * 
17  * This program is distributed in the hope that it will be useful,
18  * but WITHOUT ANY WARRANTY; without even the implied warranty of
19  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20  * GNU General Public License for more details.
21  * 
22  * You should have received a copy of the GNU General Public License
23  * along with this program; if not, write to the Free Software Foundation,
24  * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
25  */
26
27 /*----- Header files ------------------------------------------------------*/
28
29 #include <ctype.h>
30 #include <math.h>
31 #include <stdio.h>
32 #include <stdlib.h>
33 #include <string.h>
34
35 #include <tcl.h>
36
37
38 /*----- Data structures ---------------------------------------------------*/
39
40 typedef struct world {
41   unsigned char x[6];
42 } world;
43
44 typedef struct worldinfo {
45   unsigned x, y, gov, eco, tech, pop, prod, rad;
46 } worldinfo;
47
48 /*----- The world type ----------------------------------------------------*/
49
50 static void world_fir(Tcl_Obj *o)
51 {
52   Tcl_Free(o->internalRep.otherValuePtr);
53 }
54
55 static int xtoi(unsigned x)
56 {
57   if (x >= '0' && x <= '9')
58     return (x - '0');
59   else if (x >= 'a' && x <= 'f')
60     return (x - 'a' + 10);
61   else if (x >= 'A' && x <= 'F')
62     return (x - 'A' + 10);
63   else
64     abort();
65 }
66
67 static Tcl_ObjType world_type;
68
69 static int world_sfa(Tcl_Interp *ti, Tcl_Obj *o)
70 {
71   int l;
72   world ww, *w;
73   int i;
74   char *p = Tcl_GetStringFromObj(o, &l);
75   if (l != 12)
76     goto bad;
77   for (i = 0; i < 12; i += 2) {
78     if (!isxdigit((unsigned char)p[i]) ||
79         !isxdigit((unsigned char)p[i + 1]))
80       goto bad;
81     ww.x[i >> 1] = (xtoi(p[i]) << 4) | (xtoi(p[i + 1]));
82   }
83   w = (world *)Tcl_Alloc(sizeof(*w));
84   *w = ww;
85   o->internalRep.otherValuePtr = w;
86   o->typePtr = &world_type;
87   return (TCL_OK);
88
89 bad:
90   if (ti)
91     Tcl_SetResult(ti, "bad world seed string", TCL_STATIC);
92   return (TCL_ERROR);
93 }
94
95 static void world_us(Tcl_Obj *o)
96 {
97   char *p;
98   world *w = o->internalRep.otherValuePtr;
99   int i;
100
101   p = Tcl_Alloc(13);
102   p[12] = 0;
103   o->bytes = p;
104   o->length = 12;
105   for (i = 0; i < 6; i++, p += 2)
106     sprintf(p, "%02x", w->x[i]);  
107 }
108
109 static void world_dir(Tcl_Obj *o, Tcl_Obj *oo)
110 {
111   world *w = (world *)Tcl_Alloc(sizeof(*w));
112   memcpy(w, o->internalRep.otherValuePtr, sizeof(world));
113   oo->internalRep.otherValuePtr = w;
114   oo->typePtr = &world_type;
115   Tcl_InvalidateStringRep(oo);
116 }
117
118 static /*const*/ Tcl_ObjType world_type = {
119   "elite-world", world_fir, world_dir, world_us, world_sfa
120 };
121
122 static world *world_get(Tcl_Interp *ti, Tcl_Obj *o)
123 {
124   if (Tcl_ConvertToType(ti, o, &world_type) != TCL_OK)
125     return (0);
126   return (o->internalRep.otherValuePtr);
127 }
128
129 static Tcl_Obj *world_new(const world *w)
130 {
131   world *ww;
132   Tcl_Obj *o = Tcl_NewObj();
133   ww = (world *)Tcl_Alloc(sizeof(*ww));
134   *ww = *w;
135   o->internalRep.otherValuePtr = ww;
136   o->typePtr = &world_type;
137   Tcl_InvalidateStringRep(o);
138   return (o);
139 }
140
141 /*----- Elite-specific hacking --------------------------------------------*
142  *
143  * Taken from `Elite: The New Kind' by Christian Pinder.
144  */
145
146 static void waggle(world *w, world *ww)
147 {
148   unsigned int h, l;
149
150   /* --- What goes on --- *
151    *
152    * 16-bit add of all three words, shift up, and insert the new value at the
153    * end.
154    */
155
156   l = w->x[0];
157   h = w->x[1];
158   l += w->x[2];
159   h += w->x[3] + (l >= 0x100);
160   l &= 0xff; h &= 0xff;
161   l += w->x[4];
162   h += w->x[5] + (l >= 0x100);
163   l &= 0xff; h &= 0xff;
164   ww->x[0] = w->x[2]; ww->x[1] = w->x[3];
165   ww->x[2] = w->x[4]; ww->x[3] = w->x[5];
166   ww->x[4] = l; ww->x[5] = h;
167 }
168
169 /*----- Tcl commands ------------------------------------------------------*/
170
171 static int err(Tcl_Interp *ti, /*const*/ char *p)
172 {
173   Tcl_SetResult(ti, p, TCL_STATIC);
174   return (TCL_ERROR);
175 }
176
177 /* --- elite-nextworld SEED --- */
178
179 static int cmd_nextworld(ClientData cd, Tcl_Interp *ti,
180                          int objc, Tcl_Obj *const *objv)
181 {
182   world *w, ww;
183   if (objc != 2)
184     return (err(ti, "usage: elite-nextworld SEED"));
185   if ((w = world_get(ti, objv[1])) == 0)
186     return (TCL_ERROR);
187   waggle(w, &ww);
188   waggle(&ww, &ww);
189   waggle(&ww, &ww);
190   waggle(&ww, &ww);
191   Tcl_SetObjResult(ti, world_new(&ww));
192   return (TCL_OK);
193 }
194
195 /* --- elite-nextgalaxy SEED --- */
196
197 static int cmd_nextgalaxy(ClientData cd, Tcl_Interp *ti,
198                           int objc, Tcl_Obj *const *objv)
199 {
200   world *w, ww;
201   int i;
202
203   if (objc != 2)
204     return (err(ti, "usage: elite-nextgalaxy SEED"));
205   if ((w = world_get(ti, objv[1])) == 0)
206     return (TCL_ERROR);
207   for (i = 0; i < 6; i++)
208     ww.x[i] = ((w->x[i] << 1) | (w->x[i] >> 7)) & 0xff;
209   Tcl_SetObjResult(ti, world_new(&ww));
210   return (TCL_OK);
211 }
212
213 /* --- elite-worldinfo ARR SEED --- */
214
215 static void getworldinfo(worldinfo *wi, world *w)
216 {
217   wi->x = w->x[3];
218   wi->y = w->x[1];
219   wi->gov = (w->x[2] >> 3) & 0x07;
220   wi->eco = w->x[1] & 0x07;
221   if (wi->gov < 2)
222     wi->eco |= 0x02;
223   wi->tech = ((wi->eco ^ 7) + (w->x[3] & 0x03) +
224               (wi->gov >> 1) + (wi->gov & 0x01) + 1);
225   wi->pop = wi->tech * 4 + wi->gov + wi->eco - 3;
226   wi->prod = ((wi->eco ^ 7) + 3) * (wi->gov + 4) * wi->pop * 8;
227   wi->rad = (((w->x[5] & 0x0f) + 11) << 8) + w->x[3];
228 }
229
230 static const char digrams[] =
231   "abouseitiletstonlonuthnoallexegezacebisouses"
232   "armaindirea?eratenberalavetiedorquanteisrion";
233
234 static const char *const desc[][5] = {
235 /*  0 */ { "fabled", "notable", "well known", "famous", "noted" },
236 /*  1 */ { "very ", "mildly ", "most ", "reasonably ", "" },
237 /*  2 */ { "ancient", "<20>", "great", "vast", "pink" },
238 /*  3 */ { "<29> <28> plantations", "mountains", "<27>",
239            "<19> forests", "oceans" },
240 /*  4 */ { "shyness", "silliness", "mating traditions",
241            "loathing of <5>", "love for <5>" },
242 /*  5 */ { "food blenders", "tourists", "poetry", "discos", "<13>" },
243 /*  6 */ { "talking tree", "crab", "bat", "lobst", "%R" },
244 /*  7 */ { "beset", "plagued", "ravaged", "cursed", "scourged" },
245 /*  8 */ { "<21> civil war", "<26> <23> <24>s",
246            "a <26> disease", "<21> earthquakes", "<21> solar activity" },
247 /*  9 */ { "its <2> <3>", "the %I <23> <24>",
248            "its inhabitants' <25> <4>", "<32>", "its <12> <13>" },
249 /* 10 */ { "juice", "brandy", "water", "brew", "gargle blasters" },
250 /* 11 */ { "%R", "%I <24>", "%I %R", "%I <26>", "<26> %R" },
251 /* 12 */ { "fabulous", "exotic", "hoopy", "unusual", "exciting" },
252 /* 13 */ { "cuisine", "night life", "casinos", "sit coms", " <32>" },
253 /* 14 */ { "%H", "The planet %H", "The world %H",
254            "This planet", "This world" },
255 /* 15 */ { "n unremarkable", " boring", " dull", " tedious", " revolting" },
256 /* 16 */ { "planet", "world", "place", "little planet", "dump" },
257 /* 17 */ { "wasp", "moth", "grub", "ant", "%R" },
258 /* 18 */ { "poet", "arts graduate", "yak", "snail", "slug" },
259 /* 19 */ { "tropical", "dense", "rain", "impenetrable", "exuberant" },
260 /* 20 */ { "funny", "weird", "unusual", "strange", "peculiar" },
261 /* 21 */ { "frequent", "occasional", "unpredictable", "dreadful", "deadly" },
262 /* 22 */ { "<1><0> for <9>", "<1><0> for <9> and <9>",
263            "<7> by <8>", "<1><0> for <9> but <7> by <8>","a<15> <16>" },
264 /* 23 */ { "<26>", "mountain", "edible", "tree", "spotted" },
265 /* 24 */ { "<30>", "<31>", "<6>oid", "<18>", "<17>" },
266 /* 25 */ { "ancient", "exceptional", "eccentric", "ingrained", "<20>" },
267 /* 26 */ { "killer", "deadly", "evil", "lethal", "vicious" },
268 /* 27 */ { "parking meters", "dust clouds", "ice bergs",
269            "rock formations", "volcanoes" },
270 /* 28 */ { "plant", "tulip", "banana", "corn", "%Rweed" },
271 /* 29 */ { "%R", "%I %R", "%I <26>", "inhabitant", "%I %R" },
272 /* 30 */ { "shrew", "beast", "bison", "snake", "wolf" },
273 /* 31 */ { "leopard", "cat", "monkey", "goat", "fish" },
274 /* 32 */ { "<11> <10>", "%I <30> <33>", "its <12> <31> <33>",
275            "<34> <35>", "<11> <10>" },
276 /* 33 */ { "meat", "cutlet", "steak", "burgers", "soup" },
277 /* 34 */ { "ice", "mud", "Zero-G", "vacuum", "%I ultra" },
278 /* 35 */ { "hockey", "cricket", "karate", "polo", "tennis" }
279 };
280
281 static int mangle(world *w)
282 {
283   unsigned a, x;
284
285   x = (w->x[2] << 1) & 0xff;
286   a = x + w->x[4];
287   if (w->x[2] & 0x80)
288     a++;
289   w->x[2] = a & 0xff;
290   w->x[4] = x;
291   a >>= 8;
292   x = w->x[3];
293   a = (a + x + w->x[5]) & 0xff;
294   w->x[3] = a;
295   w->x[5] = x;
296   return (a);
297 }
298
299 static void goatsoup(Tcl_Obj *d, const char *pn, world *w, const char *p)
300 {
301   for (;;) {
302     size_t sz = strcspn(p, "<%");
303     unsigned n;
304     char buf[12];
305     char *q;
306
307     Tcl_AppendToObj(d, (char *)p, sz);
308     p += sz;
309     switch (*p) {
310       unsigned i, j;
311       case 0:
312         return;
313       case '<':
314         i = strtoul(p + 1, (char **)&p, 10);
315         p++;
316         j = mangle(w);
317         goatsoup(d, pn, w, desc[i][(j >= 0x33) + (j >= 0x66) +
318                                    (j >= 0x99) + (j >= 0xcc)]);
319         break;
320       case '%':
321         p++;
322         switch (*p++) {
323           case 'H':
324             Tcl_AppendToObj(d, (char *)pn, -1);
325             break;
326           case 'I':
327             sz = strlen(pn) - 1;
328             Tcl_AppendToObj(d, (char *)pn,
329                             (pn[sz] == 'i' || pn[sz] == 'e') ? sz : sz + 1);
330             Tcl_AppendToObj(d, "ian", 3);
331             break;
332           case 'R':
333             n = (mangle(w) & 0x03) + 1;
334             q = buf;
335             while (n--) {
336               unsigned i = mangle(w) & 0x3e;
337               *q++ = digrams[i++];
338               if (digrams[i] != '?')
339                 *q++ = digrams[i++];
340             }
341             *buf = toupper(*buf);
342             Tcl_AppendToObj(d, buf, q - buf);
343             break;
344           default:
345             abort();
346         }
347         break;
348       default:
349         abort();
350     }
351   }
352 }
353
354 static int cmd_worldinfo(ClientData cd, Tcl_Interp *ti,
355                          int objc, Tcl_Obj *const *objv)
356 {
357   world *w;
358   worldinfo wi;
359   char *arr;
360   char buf[9];
361   char *p;
362   unsigned j, n;
363   Tcl_Obj *o;
364   world ww;
365
366   /* --- Check arguments --- */
367   
368   if (objc != 3)
369     return (err(ti, "usage: elite-worldinfo ARR SEED"));
370   if ((w = world_get(ti, objv[2])) == 0)
371     return (TCL_ERROR);
372   arr = Tcl_GetString(objv[1]);
373
374   /* --- Get the basic information --- */
375
376   getworldinfo(&wi, w);
377   Tcl_UnsetVar(ti, arr, 0);
378   if (!Tcl_SetVar2Ex(ti, arr, "x", Tcl_NewIntObj(wi.x * 4),
379                      TCL_LEAVE_ERR_MSG) ||
380       !Tcl_SetVar2Ex(ti, arr, "y", Tcl_NewIntObj(wi.y * 2),
381                      TCL_LEAVE_ERR_MSG) ||
382       !Tcl_SetVar2Ex(ti, arr, "government", Tcl_NewIntObj(wi.gov), 
383                     TCL_LEAVE_ERR_MSG) ||
384       !Tcl_SetVar2Ex(ti, arr, "economy", Tcl_NewIntObj(wi.eco),
385                      TCL_LEAVE_ERR_MSG) ||
386       !Tcl_SetVar2Ex(ti, arr, "techlevel", Tcl_NewIntObj(wi.tech), 
387                     TCL_LEAVE_ERR_MSG) ||
388       !Tcl_SetVar2Ex(ti, arr, "population", Tcl_NewIntObj(wi.pop), 
389                     TCL_LEAVE_ERR_MSG) ||
390       !Tcl_SetVar2Ex(ti, arr, "productivity", Tcl_NewIntObj(wi.prod), 
391                     TCL_LEAVE_ERR_MSG) ||
392       !Tcl_SetVar2Ex(ti, arr, "radius", Tcl_NewIntObj(wi.rad),
393                      TCL_LEAVE_ERR_MSG) ||
394       !Tcl_SetVar2Ex(ti, arr, "seed", objv[2],
395                      TCL_LEAVE_ERR_MSG))
396     return (TCL_ERROR);
397
398   /* --- Work out the inhabitants --- */
399
400   if (!(w->x[4] & 0x80)) {
401     if (!Tcl_SetVar2(ti, arr, "inhabitants", "humans", TCL_LEAVE_ERR_MSG))
402       return (TCL_ERROR);
403   } else {
404     static const char *const id_a[] = { "large", "fierce", "small" };
405     static const char *const id_b[] = { "green", "red", "yellow", "blue",
406                                         "black", "harmless" };
407     static const char *const id_c[] = { "slimy", "bug-eyed", "horned",
408                                         "bony", "fat", "furry" };
409     static const char *const id_d[] = { "rodents", "frogs", "lizards",
410                                         "lobsters", "birds", "humanoids",
411                                         "felines", "insects" };
412
413     o = Tcl_NewListObj(0, 0);
414     j = (w->x[5] >> 2) & 0x07;
415     if (j < 3)
416       Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_a[j], -1));
417     j = (w->x[5] >> 5) & 0x07;
418     if (j < 6)
419       Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_b[j], -1));
420     j = (w->x[1] ^ w->x[3]) & 0x07;
421     if (j < 6)
422       Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_c[j], -1));
423     j += w->x[5] & 0x03;
424       Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_d[j & 0x07], -1));
425     if (!Tcl_SetVar2Ex(ti, arr, "inhabitants", o, TCL_LEAVE_ERR_MSG))
426       return (TCL_ERROR);
427   }
428
429   /* --- Work out the planet name --- */
430
431   n = (w->x[0] & 0x40) ? 4 : 3;
432   p = buf;
433   ww = *w;
434   while (n--) {
435     j = ww.x[5] & 0x1f;
436     if (j) {
437       j = (j + 12) << 1;
438       *p++ = digrams[j++];
439       if (digrams[j] != '?')
440         *p++ = digrams[j];
441     }
442     waggle(&ww, &ww);
443   }
444   *p++ = 0;
445   *buf = toupper(*buf);
446   if (!Tcl_SetVar2Ex(ti, arr, "name", Tcl_NewStringObj(buf, -1),
447                      TCL_LEAVE_ERR_MSG))
448     return (TCL_ERROR);
449
450   /* --- Finally work out the goat-soup description --- */
451
452   ww = *w;
453   o = Tcl_NewStringObj(0, 0);
454   goatsoup(o, buf, &ww, "<14> is <22>.");
455   if (!Tcl_SetVar2Ex(ti, arr, "description", o, TCL_LEAVE_ERR_MSG))
456     return (TCL_ERROR);
457   return (TCL_OK);
458 }
459
460 /* --- elite-market ARR SEED [FLUC] --- */
461
462 static const struct item {
463   /*const*/ char *name;
464   unsigned base;
465   int var;
466   unsigned qty;
467   unsigned mask;
468 } items[] = {
469   { "food",              19, -2,   6, 0x01 },
470   { "textiles",          20, -1,  10, 0x03 },
471   { "radioactives",      65, -3,   2, 0x07 },
472   { "slaves",            40, -5, 226, 0x1f },
473   { "liquor-wines",      83, -5, 251, 0x0f },
474   { "luxuries",         196,  8,  54, 0x03 },
475   { "narcotics",        235, 29,   8, 0x78 },
476   { "computers",        154, 14,  56, 0x03 },
477   { "machinery",        117,  6,  40, 0x07 },
478   { "alloys",            78,  1,  17, 0x1f },
479   { "firearms",         124, 13,  29, 0x07 },
480   { "furs",             176, -9, 220, 0x3f },
481   { "minerals",          32, -1,  53, 0x03 },
482   { "gold",              97, -1,  66, 0x07 },
483   { "platinum",         171, -2,  55, 0x1f },
484   { "gem-stones",        45, -1, 250, 0x0f },
485   { "alien-items",       53, 15, 192, 0x07 },
486   { 0,                    0,  0,   0, 0x00 }
487 };
488
489 static int cmd_market(ClientData cd, Tcl_Interp *ti,
490                       int objc, Tcl_Obj *const *objv)
491 {
492   int fluc = 0;
493   world *w;
494   worldinfo wi;
495   const struct item *i;
496   char *arr;
497
498   if (objc < 3 || objc > 5)
499     return (err(ti, "usage: elite-market ARR SEED [FLUC]"));
500   if ((w = world_get(ti, objv[2])) == 0)
501     return (TCL_ERROR);
502   arr = Tcl_GetString(objv[1]);
503   if (objc >= 4 && Tcl_GetIntFromObj(ti, objv[3], &fluc) != TCL_OK)
504     return (TCL_ERROR);
505   getworldinfo(&wi, w);
506
507   Tcl_UnsetVar(ti, arr, 0);
508   for (i = items; i->name; i++) {
509     unsigned pr, qt;
510     Tcl_Obj *oo[2];
511     pr = (i->base + (fluc & i->mask) + (wi.eco * i->var)) & 0xff;
512     qt = (i->qty + (fluc & i->mask) - (wi.eco * i->var)) & 0xff;
513     if (qt & 0x80)
514       qt = 0;
515     oo[0] = Tcl_NewIntObj(pr << 2);
516     oo[1] = Tcl_NewIntObj(qt & 0x3f);
517     if (!Tcl_SetVar2Ex(ti, arr, i->name, Tcl_NewListObj(2, oo),
518                       TCL_LEAVE_ERR_MSG))
519       return (TCL_ERROR);
520   }
521   return (TCL_OK);
522 }
523
524 /*----- Commander file decomposition --------------------------------------*/
525
526 static unsigned cksum(const unsigned char *p, size_t sz)
527 {
528   unsigned a = 0x49, c = 0;
529
530   p += sz - 1;
531   while (--sz) {
532     a += *--p + c;
533     c = a >> 8;
534     a &= 0xff;
535     a ^= p[1];
536   }
537   fflush(stdout);
538   return (a);
539 }
540
541 /* --- The big translation table --- */
542
543 struct cmddata {
544   /*const*/ char *name;
545   unsigned off;
546   int (*get)(Tcl_Interp *, /*const*/ char *,
547              const unsigned char *, const struct cmddata *);
548   int (*put)(Tcl_Interp *, /*const*/ char *,
549              unsigned char *, const struct cmddata *);
550   int x;
551 };
552
553 static int get_byte(Tcl_Interp *ti, /*const*/ char *arr,
554                     const unsigned char *p, const struct cmddata *cd)
555 {
556   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
557                          Tcl_NewIntObj(*p - cd->x), TCL_LEAVE_ERR_MSG));
558 }
559
560 static int get_seed(Tcl_Interp *ti, /*const*/ char *arr,
561                     const unsigned char *p, const struct cmddata *cd)
562 {
563   world w;
564
565   memcpy(w.x, p, 6);
566   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
567                          world_new(&w), TCL_LEAVE_ERR_MSG));
568 }
569
570 static int get_word(Tcl_Interp *ti, /*const*/ char *arr,
571                     const unsigned char *p, const struct cmddata *cd)
572 {
573   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
574                          Tcl_NewLongObj((p[0] & 0xff) << 24 |
575                                         (p[1] & 0xff) << 16 |
576                                         (p[2] & 0xff) <<  8 |
577                                         (p[3] & 0xff) <<  0),
578                          TCL_LEAVE_ERR_MSG));
579 }
580
581 static int get_hword(Tcl_Interp *ti, /*const*/ char *arr,
582                      const unsigned char *p, const struct cmddata *cd)
583 {
584   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
585                          Tcl_NewLongObj((p[0] & 0xff) << 0 |
586                                         (p[1] & 0xff) << 8),
587                          TCL_LEAVE_ERR_MSG));
588 }
589
590 static int get_bool(Tcl_Interp *ti, /*const*/ char *arr,
591                     const unsigned char *p, const struct cmddata *cd)
592 {
593   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
594                          Tcl_NewBooleanObj(*p), TCL_LEAVE_ERR_MSG));
595 }
596
597 static int get_items(Tcl_Interp *ti, /*const*/ char *arr,
598                      const unsigned char *p, const struct cmddata *cd)
599 {
600   char buf[32];
601   const struct item *i;
602
603   for (i = items; i->name; i++) {
604     sprintf(buf, "%s-%s", cd->name, i->name);
605     if (!Tcl_SetVar2Ex(ti, arr, buf,
606                        Tcl_NewIntObj(*p++), TCL_LEAVE_ERR_MSG))
607       return (-1);
608   }
609   return (0);
610 }
611
612 static int put_byte(Tcl_Interp *ti, /*const*/ char *arr,
613                     unsigned char *p, const struct cmddata *cd)
614 {
615   Tcl_Obj *o;
616   int i;
617
618   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
619       Tcl_GetIntFromObj(ti, o, &i) != TCL_OK)
620     return (-1);
621   *p = i + cd->x;
622   return (0);
623 }
624
625 static int put_word(Tcl_Interp *ti, /*const*/ char *arr,
626                     unsigned char *p, const struct cmddata *cd)
627 {
628   Tcl_Obj *o;
629   long l;
630
631   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
632       Tcl_GetLongFromObj(ti, o, &l) != TCL_OK)
633     return (-1);
634   p[0] = (l >> 24) & 0xff;
635   p[1] = (l >> 16) & 0xff;
636   p[2] = (l >>  8) & 0xff;
637   p[3] = (l >>  0) & 0xff;
638   return (0);
639 }
640
641 static int put_hword(Tcl_Interp *ti, /*const*/ char *arr,
642                      unsigned char *p, const struct cmddata *cd)
643 {
644   Tcl_Obj *o;
645   long l;
646
647   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
648       Tcl_GetLongFromObj(ti, o, &l) != TCL_OK)
649     return (-1);
650   p[0] = (l >> 0) & 0xff;
651   p[1] = (l >> 8) & 0xff;
652   return (0);
653 }
654
655 static int put_const(Tcl_Interp *ti, /*const*/ char *arr,
656                      unsigned char *p, const struct cmddata *cd)
657 {
658   *p = cd->x;
659   return (0);
660 }
661
662 static int put_seed(Tcl_Interp *ti, /*const*/ char *arr,
663                     unsigned char *p, const struct cmddata *cd)
664 {
665   Tcl_Obj *o;
666   world *w;
667
668   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
669       (w = world_get(ti, o)) == 0)
670     return (-1);
671   memcpy(p, w->x, 6);
672   return (0);
673 }
674
675 static int put_bool(Tcl_Interp *ti, /*const*/ char *arr,
676                     unsigned char *p, const struct cmddata *cd)
677 {
678   Tcl_Obj *o;
679   int b;
680
681   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
682       Tcl_GetBooleanFromObj(ti, o, &b) != TCL_OK)
683     return (-1);
684   *p = b ? cd->x : 0;
685   return (0);
686 }
687
688 static int put_items(Tcl_Interp *ti, /*const*/ char *arr,
689                      unsigned char *p, const struct cmddata *cd)
690 {
691   char buf[32];
692   int ii;
693   Tcl_Obj *o;
694   const struct item *i;
695
696   for (i = items; i->name; i++) {
697     sprintf(buf, "%s-%s", cd->name, i->name);
698     if ((o = Tcl_GetVar2Ex(ti, arr, buf, TCL_LEAVE_ERR_MSG)) == 0 ||
699         Tcl_GetIntFromObj(ti, o, &ii) != TCL_OK)
700       return (-1);
701     *p++ = ii;
702   }
703   return (0);  
704 }
705
706 static struct cmddata cmdtab[] = {
707   { "mission",           0,     get_byte,       put_byte,         0 },
708   { "world-x",           1,     get_byte,       put_byte,         0 },
709   { "world-y",           2,     get_byte,       put_byte,         0 },
710   { "gal-seed",          3,     get_seed,       put_seed,         0 },
711   { "credits",           9,     get_word,       put_word,         0 },
712   { "fuel",             13,     get_byte,       put_byte,         0 },
713   { "",                 14,     0,              put_const,        4 },
714   { "gal-number",       15,     get_byte,       put_byte,        -1 },
715   { "front-laser",      16,     get_byte,       put_byte,         0 },
716   { "rear-laser",       17,     get_byte,       put_byte,         0 },
717   { "left-laser",       18,     get_byte,       put_byte,         0 },
718   { "right-laser",      19,     get_byte,       put_byte,         0 },
719   { "cargo",            22,     get_byte,       put_byte,         2 },
720   { "hold",             23,     get_items,      put_items,        0 },
721   { "ecm",              40,     get_bool,       put_bool,       255 },
722   { "fuel-scoop",       41,     get_bool,       put_bool,       255 },
723   { "energy-bomb",      42,     get_bool,       put_bool,       127 },
724   { "energy-unit",      43,     get_byte,       put_byte,         0 },
725   { "docking-computer", 44,     get_bool,       put_bool,       255 },
726   { "gal-hyperdrive",   45,     get_bool,       put_bool,       255 },
727   { "escape-pod",       46,     get_bool,       put_bool,       255 },
728   { "missiles",         51,     get_byte,       put_byte,         0 },
729   { "legal-status",     52,     get_byte,       put_byte,         0 },
730   { "station",          53,     get_items,      put_items,        0 },
731   { "market-fluc",      70,     get_byte,       put_byte,         0 },
732   { "score",            71,     get_hword,      put_hword,        0 },
733   { "",                 74,     0,              put_const,       32 },
734   { 0,                   0,     0,              0,                0 }
735 };
736
737 /* --- elite-unpackcmdr [-force] ARR DATA --- */
738
739 static int cmd_unpackcmdr(ClientData cd, Tcl_Interp *ti,
740                           int objc, Tcl_Obj *const *objv)
741 {
742   char *arr;
743   unsigned char *p, *q;
744   int sz;
745   unsigned f = 0;
746   unsigned ck;
747   const struct cmddata *c;
748
749 #define f_force 1u
750
751   /* --- Read the arguments --- */
752
753   objc--; objv++;
754   while (objc) {
755     char *opt = Tcl_GetString(*objv);
756     if (strcmp(opt, "-force") == 0)
757       f |= f_force;
758     else if (strcmp(opt, "--") == 0) {
759       objc--;
760       objv++;
761       break;
762     } else
763       break;
764     objc--;
765     objv++;
766   }
767   if (objc != 2)
768     return (err(ti, "usage: elite-unpackcmdr [-force] ARR DATA"));
769   arr = Tcl_GetString(objv[0]);
770   p = Tcl_GetByteArrayFromObj(objv[1], &sz);
771
772   /* --- Check the data for correctness --- */
773
774   if (sz < 74)
775     return (err(ti, "bad commander data (bad length)"));
776   ck = cksum(p, 74);
777   if (!(f & f_force)) {
778     if (sz < 76 || p[74] != (ck ^ 0xa9) || p[75] != ck)
779       return (err(ti, "bad commander data (bad checksum)"));
780     for (q = p + 77; q < p + sz; q++)
781       if (*q)
782         return (err(ti, "bad commander data (bad data at end)"));
783   }
784
785   /* --- Deconstruct the data --- */
786
787   Tcl_UnsetVar(ti, arr, 0);
788   for (c = cmdtab; c->name; c++) {
789     if (c->get && c->get(ti, arr, p + c->off, c))
790       return (TCL_ERROR);
791   }
792   return (0);
793 }
794
795 /* --- elite-packcmdr ARR --- */
796
797 static int cmd_packcmdr(ClientData cd, Tcl_Interp *ti,
798                        int objc, Tcl_Obj *const *objv)
799 {
800   char *arr;
801   unsigned char p[256];
802   unsigned ck;
803   const struct cmddata *c;
804
805   if (objc != 2)
806     return (err(ti, "usage: elite-packcmdr ARR"));
807   arr = Tcl_GetString(objv[1]);
808
809   memset(p, 0, sizeof(p));
810   for (c = cmdtab; c->name; c++) {
811     if (c->put && c->put(ti, arr, p + c->off, c))
812       return (TCL_ERROR);
813   }
814
815   ck = cksum(p, 74);
816   p[74] = ck ^ 0xa9;
817   p[75] = ck;
818   Tcl_SetObjResult(ti, Tcl_NewByteArrayObj(p, sizeof(p)));
819   return (0);
820 }
821
822 /*----- Optimizations -----------------------------------------------------*/
823
824 /* --- @elite-galaxylist SEED@ --- *
825  *
826  * Returns a SEED/X/Y list for the worlds in galaxy SEED.
827  */
828
829 static int cmd_galaxylist(ClientData cd, Tcl_Interp *ti,
830                           int objc, Tcl_Obj *const *objv)
831 {
832   world *w, ww;
833   worldinfo wi;
834   int i;
835   Tcl_Obj *o;
836
837   if (objc != 2)
838     return (err(ti, "usage: elite-galaxylist SEED"));
839   if ((w = world_get(ti, objv[1])) == 0)
840     return (TCL_ERROR);
841   ww = *w;
842   o = Tcl_NewListObj(0, 0);
843   for (i = 0; i < 256; i++) {
844     getworldinfo(&wi, &ww);
845     Tcl_ListObjAppendElement(ti, o, world_new(&ww));
846     Tcl_ListObjAppendElement(ti, o, Tcl_NewIntObj(wi.x * 4));
847     Tcl_ListObjAppendElement(ti, o, Tcl_NewIntObj(wi.y * 2));
848     waggle(&ww, &ww); waggle(&ww, &ww); waggle(&ww, &ww); waggle(&ww, &ww);
849   }
850   Tcl_SetObjResult(ti, o);
851   return (TCL_OK);
852 }
853
854 /* --- @elite-distance X Y XX YY@ --- *
855  *
856  * Returns the distance between two points.
857  */
858
859 static int cmd_distance(ClientData cd, Tcl_Interp *ti,
860                         int objc, Tcl_Obj *const *objv)
861 {
862   long x, y, xx, yy;
863   long d;
864
865   if (objc != 5)
866     return (err(ti, "usage: elite-distance X Y XX YY"));
867   if (Tcl_GetLongFromObj(ti, objv[1], &x) != TCL_OK ||
868       Tcl_GetLongFromObj(ti, objv[2], &y) != TCL_OK ||
869       Tcl_GetLongFromObj(ti, objv[3], &xx) != TCL_OK ||
870       Tcl_GetLongFromObj(ti, objv[4], &yy) != TCL_OK)
871     return (TCL_ERROR);
872   xx = xx >= x ? xx - x : x - xx; xx >>= 2; xx *= xx;
873   yy = yy >= y ? yy - y : y - yy; yy >>= 2; yy *= yy;
874   d = sqrt(xx + yy); d <<= 2;
875   Tcl_SetObjResult(ti, Tcl_NewLongObj(d));
876   return (TCL_OK);
877 }
878
879 /* --- @elite-adjacency ADJ LIST [DIST]@ --- *
880  *
881  * Construct an adjacency table from a world list.
882  */
883
884 static int cmd_adjacency(ClientData cd, Tcl_Interp *ti,
885                          int objc, Tcl_Obj *const *objv)
886 {
887   int oc;
888   Tcl_Obj **ov;
889   size_t i, j;
890   long x, y, xx, yy, d;
891   Tcl_Obj *a;
892   char *s, *ss;
893   Tcl_HashTable done;
894   long dd = 70;
895   int rc = TCL_ERROR;
896   int dummy;
897   Tcl_Obj *o;
898
899   if (objc < 3 || objc > 4)
900     return (err(ti, "usage: elite-adjacency ADJ LIST [DIST]"));
901   a = objv[1];
902   if (Tcl_ListObjGetElements(ti, objv[2], &oc, &ov) != TCL_OK)
903     return (TCL_ERROR);
904   if (oc % 3 != 0)
905     return (err(ti, "world array not a multiple of three in size"));
906   if (objc >= 4 && Tcl_GetLongFromObj(ti, objv[3], &dd) != TCL_OK)
907     return (TCL_ERROR);
908
909   Tcl_InitHashTable(&done, TCL_ONE_WORD_KEYS);
910   Tcl_UnsetVar(ti, Tcl_GetString(a), 0);
911   o = Tcl_NewObj();
912   Tcl_IncrRefCount(o);
913   for (i = 0; i < oc; i += 3) {
914     s = Tcl_GetString(ov[i]);
915     if (Tcl_ObjSetVar2(ti, a, ov[i], o, TCL_LEAVE_ERR_MSG) == 0)
916       goto done;
917   }
918   for (i = 0; i < oc; i += 3) {
919     s = Tcl_GetString(ov[i]);  
920     Tcl_CreateHashEntry(&done, s, &dummy);
921     if (Tcl_GetLongFromObj(ti, ov[i + 1], &x) != TCL_OK ||
922         Tcl_GetLongFromObj(ti, ov[i + 2], &y) != TCL_OK)
923       goto done;
924     for (j = 0; j < oc; j += 3) {
925       ss = Tcl_GetString(ov[j]);
926       if (Tcl_FindHashEntry(&done, ss))
927         continue;
928       if (Tcl_GetLongFromObj(ti, ov[j + 1], &xx) != TCL_OK ||
929           Tcl_GetLongFromObj(ti, ov[j + 2], &yy) != TCL_OK)
930         goto done;
931       xx = xx >= x ? xx - x : x - xx; xx >>= 2; xx *= xx;
932       yy = yy >= y ? yy - y : y - yy; yy >>= 2; yy *= yy;
933       d = sqrt(xx + yy); d <<= 2;
934       if (d <= dd) {
935         if (Tcl_ObjSetVar2(ti, a, ov[i], ov[j],
936                            (TCL_APPEND_VALUE |
937                             TCL_LIST_ELEMENT |
938                             TCL_LEAVE_ERR_MSG)) == 0 ||
939             Tcl_ObjSetVar2(ti, a, ov[i], ov[j + 1],
940                            (TCL_APPEND_VALUE |
941                             TCL_LIST_ELEMENT |
942                             TCL_LEAVE_ERR_MSG)) == 0 ||
943             Tcl_ObjSetVar2(ti, a, ov[i], ov[j + 2],
944                            (TCL_APPEND_VALUE |
945                             TCL_LIST_ELEMENT |
946                             TCL_LEAVE_ERR_MSG)) == 0 ||
947             Tcl_ObjSetVar2(ti, a, ov[j], ov[i],
948                            (TCL_APPEND_VALUE |
949                             TCL_LIST_ELEMENT |
950                             TCL_LEAVE_ERR_MSG)) == 0 ||
951             Tcl_ObjSetVar2(ti, a, ov[j], ov[i + 1],
952                            (TCL_APPEND_VALUE |
953                             TCL_LIST_ELEMENT |
954                             TCL_LEAVE_ERR_MSG)) == 0 ||
955             Tcl_ObjSetVar2(ti, a, ov[j], ov[i + 2],
956                            (TCL_APPEND_VALUE |
957                             TCL_LIST_ELEMENT |
958                             TCL_LEAVE_ERR_MSG)) == 0)
959           goto done;
960       }
961     }
962   }
963   rc = TCL_OK;
964
965 done:
966   Tcl_DeleteHashTable(&done);
967   return (rc);
968 }
969
970 /*----- Initialization ----------------------------------------------------*/
971
972 int Elite_SafeInit(Tcl_Interp *ti)
973 {
974   static const struct cmd {
975     /*const*/ char *name;
976     Tcl_ObjCmdProc *proc;
977   } cmds[] = {
978     { "elite-nextworld",        cmd_nextworld },
979     { "elite-nextgalaxy",       cmd_nextgalaxy },
980     { "elite-worldinfo",        cmd_worldinfo },
981     { "elite-market",           cmd_market },
982     { "elite-unpackcmdr",       cmd_unpackcmdr },
983     { "elite-packcmdr",         cmd_packcmdr },
984     { "elite-distance",         cmd_distance },
985     { "elite-galaxylist",       cmd_galaxylist },
986     { "elite-adjacency",        cmd_adjacency },
987     { 0,                        0 }
988   };
989
990   const struct cmd *c;
991   for (c = cmds; c->name; c++)
992     Tcl_CreateObjCommand(ti, c->name, c->proc, 0, 0);
993   Tcl_RegisterObjType(&world_type);
994   if (Tcl_PkgProvide(ti, "elite-bits", "1.0.1"))
995     return (TCL_ERROR);
996   return (TCL_OK);
997 }
998
999 int Elite_Init(Tcl_Interp *ti)
1000 {
1001   return (Elite_SafeInit(ti));
1002 }
1003
1004 /*----- That's all, folks -------------------------------------------------*/