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

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