You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

1473 lines
31 KiB

##
## This is Daimler's 350-point "Adventure" (circa June 1990, according
## to Russel Dalenberg). Its version information lists
##
## -Conversion to BDS C by J. R. Jaeger
## -Unix standardization by Jerry D. Pohl.
## -OS/2 Conversion by Martin Heller
## -Conversion to TurboC 2.0 by Daimler
##
## It contains Jerry Pohl's original ADVENT.DOC (dated 12 JUNE 1984),
## plus comments from Martin Heller (dated 30-Aug-1988). Strangely for
## an expansion, Daimler's version actually introduces a number of typos
## into the data files, and disables a handful of inessential verbs
## (READ, EAT, FILL) with the comment that there is "no room" for them
## (presumably in the PC's limited memory).
## -------------------------------------------------------------------
## Adapted for HiTech C Z80 under CP/M by Ladislau Szilagyi, Oct. 2023
## Uncommented Daimler's disabled verbs - game is complete again !
## Added a new pseudo-random number generator (Xorshift)
## Adapted to Cowgol language by Ladislau Szilagyi, Feb. 2025
include "misc.coh";
include "string.coh";
include "ranfile.coh";
@decl sub move(obj: uint16, where: int16) @extern("move");
@decl sub score() @extern("score");
@decl sub death() @extern("death");
@decl sub initplay() @extern("initplay");
@decl sub turn() @extern("turn");
@decl sub ivtake() @extern("ivtake");
@decl sub ivopen() @extern("ivopen");
@decl sub trverb(verb: int16, object: int16, closed: int16) @extern("trverb");
@decl sub actspk(verb: uint16) @extern("actspk");
@decl sub ivkill() @extern("ivkill");
@decl sub iveat() @extern("iveat");
@decl sub ivdrink() @extern("ivdrink");
@decl sub ivquit() @extern("ivquit");
@decl sub ivfill() @extern("ivfill");
@decl sub ivfoo() @extern("ivfoo");
@decl sub ivread() @extern("ivread");
@decl sub vdrop() @extern("vdrop");
@decl sub vtake() @extern("vtake");
@decl sub vopen() @extern("vopen");
@decl sub von() @extern("von");
@decl sub voff() @extern("voff");
@decl sub vwave() @extern("vwave");
@decl sub vkill() @extern("vkill");
@decl sub vpour() @extern("vpour");
@decl sub veat() @extern("veat");
@decl sub vdrink() @extern("vdrink");
@decl sub vthrow() @extern("vthrow");
@decl sub vfeed() @extern("vfeed");
@decl sub vfind() @extern("vfind");
@decl sub vfill() @extern("vfill");
@decl sub vblast() @extern("vblast");
@decl sub vbreak() @extern("vbreak");
@decl sub vwake() @extern("vwake");
@decl sub set_limit(v: int16) @extern("set_limit");
@decl sub set_verb(v: int16) @extern("set_verb");
@decl sub set_object(v: int16) @extern("set_object");
@decl sub set_motion(v: int16) @extern("set_motion");
@decl sub rspeak(msg: uint8) @extern("rspeak");
@decl sub dark(): (ret: uint8) @extern("dark");
@decl sub toting(item: uint16): (ret: uint8) @extern("toting");
@decl sub yes(msg1: uint8, msg2: uint8, msg3: uint8): (ret: uint8) @extern("yes");
@decl sub pspeak(item: uint8, state: int8) @extern("pspeak");
@decl sub save() @extern("save");
@decl sub restore() @extern("restore");
@decl sub get_dbugflg(): (ret: int16) @extern("get_dbugflg");
@decl sub set_saveflg(v: int16) @extern("set_saveflg");
@decl sub get_saveflg(): (ret: int16) @extern("get_saveflg");
@decl sub set_dbugflg(v: int16) @extern("set_dbugflg");
# Action verb definitions
const TAKE := 1;
const DROP := 2;
const SAY := 3;
const OPEN := 4;
const NOTHING := 5;
const LOCK := 6;
const ON := 7;
const OFF := 8;
const WAVE := 9;
const CALM := 10;
const WALK := 11;
const KILL := 12;
const POUR := 13;
const EAT := 14;
const DRINK := 15;
const RUB := 16;
const THROW := 17;
const QUIT := 18;
const FIND := 19;
const INVENTORY := 20;
const FEED := 21;
const FILL := 22;
const BLAST := 23;
const SCORE := 24;
const FOO := 25;
const BRIEF := 26;
const READ := 27;
const BREAK := 28;
const WAKE := 29;
const SUSPEND := 30;
const HOURS := 31;
const LOG := 32;
# Object definitions
const KEYS := 1;
const LAMP := 2;
const GRATE := 3;
const CAGE := 4;
const ROD := 5;
const ROD2 := 6;
const STEPS := 7;
const BIRD := 8;
const DOOR := 9;
const PILLOW := 10;
const SNAKE := 11;
const FISSURE := 12;
const TABLET := 13;
const CLAM := 14;
const OYSTER := 15;
const MAGAZINE := 16;
const DWARF := 17;
const KNIFE := 18;
const FOOD := 19;
const BOTTLE := 20;
const WATER := 21;
const OIL := 22;
const MIRROR := 23;
const PLANT := 24;
const PLANT2 := 25;
const AXE := 28;
const DRAGON := 31;
const CHASM := 32;
const TROLL := 33;
const TROLL2 := 34;
const BEAR := 35;
const MESSAGE := 36;
const VEND := 38;
const BATTERIES := 39;
const NUGGET := 50;
const COINS := 54;
const CHEST := 55;
const EGGS := 56;
const TRIDENT := 57;
const VASE := 58;
const EMERALD := 59;
const PYRAMID := 60;
const PEARL := 61;
const RUG := 62;
const SPICES := 63;
const CHAIN := 64;
const MAXOBJ := 100;
# English variables
const WORDSIZE := 20; # max # of chars in commands
var word1: uint8[WORDSIZE];
var word2: uint8[WORDSIZE];
# some utilities --------------------------------------------------------------
# Fatal error routine
sub bug(n: uint8) @extern("bug") is
print("Fatal error number ");
print(itoa(n as int16));
print_nl();
exit();
end sub;
# normal end of game
sub normend() @extern("normend") is
score();
exit();
end sub;
# Routine to handle player's demise via
# waking up the dwarves...
sub dwarfend() @extern("dwarfend") is
death();
normend();
end sub;
record wac is
aword: [uint8];
acode: uint16;
end record;
# Adventure vocabulary & encryption
const MAXWC := 301;
var wc: wac[] :=
{
{"spelunker today",1016},
{"?", 3051},
{"above", 29},
{"abra", 3050},
{"abracadabra", 3050},
{"across", 42},
{"ascend", 29},
{"attack", 2012},
{"awkward", 26},
{"axe", 1028},
{"back", 8},
{"barren", 40},
{"bars", 1052},
{"batteries", 1039},
{"battery", 1039},
{"beans", 1024},
{"bear", 1035},
{"bed", 16},
{"bedquilt", 70},
{"bird", 1008},
{"blast", 2023},
{"blowup", 2023},
{"bottle", 1020},
{"box", 1055},
{"break", 2028},
{"brief", 2026},
{"broken", 54},
{"building", 12},
{"cage", 1004},
{"calm", 2010},
{"canyon", 25},
{"capture", 2001},
{"carpet", 1040},
{"carry", 2001},
{"catch", 2001},
{"cave", 67},
{"cavern", 73},
{"chain", 1064},
{"chant", 2003},
{"chasm", 1032},
{"chest", 1055},
{"clam", 1014},
{"climb", 56},
{"close", 2006},
{"cobblestone", 18},
{"coins", 1054},
{"continue", 2011},
{"crack", 33},
{"crap", 3079},
{"crawl", 17},
{"cross", 69},
{"d", 30},
{"damn", 3079},
{"damnit", 3079},
{"dark", 22},
{"debris", 51},
{"depression", 63},
{"descend", 30},
{"describe", 57},
{"detonate", 2023},
{"devour", 2014},
{"diamonds", 1051},
{"dig", 3066},
{"discard", 2002},
{"disturb", 2029},
{"dome", 35},
{"door", 1009},
{"down", 30},
{"downstream", 4},
{"downward", 30},
{"dragon", 1031},
{"drawing", 1029},
{"drink", 2015},
{"drop", 2002},
{"dump", 2002},
{"dwarf", 1017},
{"dwarves", 1017},
{"e", 43},
{"east", 43},
{"eat", 2014},
{"egg", 1056},
{"eggs", 1056},
{"emerald", 1059},
{"enter", 3},
{"entrance", 64},
{"examine", 57},
{"excavate", 3066},
{"exit", 11},
{"explore", 2011},
{"extinguish", 2008},
{"fee", 2025},
{"fee", 3001},
{"feed", 2021},
{"fie", 2025},
{"fie", 3002},
{"fight", 2012},
{"figure", 1027},
{"fill", 2022},
{"find", 2019},
{"fissure", 1012},
{"floor", 58},
{"foe", 2025},
{"foe", 3003},
{"follow", 2011},
{"foo", 2025},
{"foo", 3004},
{"food", 1019},
{"forest", 6},
{"fork", 77},
{"forward", 7},
{"free", 2002},
{"fuck", 3079},
{"fum", 2025},
{"fum", 3005},
{"get", 2001},
{"geyser", 1037},
{"giant", 27},
{"go", 2011},
{"gold", 1050},
{"goto", 2011},
{"grate", 1003},
{"gully", 13},
{"h2o", 1021},
{"hall", 38},
{"headlamp", 1002},
{"help", 3051},
{"hill", 2},
{"hit", 2012},
{"hocus", 3050},
{"hole", 52},
{"hours", 2031},
{"house", 12},
{"ignite", 2023},
{"in", 19},
{"info", 3142},
{"information", 3142},
{"inside", 19},
{"inventory", 2020},
{"inward", 19},
{"issue", 1016},
{"jar", 1020},
{"jewel", 1053},
{"jewelry", 1053},
{"jewels", 1053},
{"jump", 39},
{"keep", 2001},
{"key", 1001},
{"keys", 1001},
{"kill", 2012},
{"knife", 1018},
{"knives", 1018},
{"lamp", 1002},
{"lantern", 1002},
{"leave", 11},
{"left", 36},
{"light", 2007},
{"lock", 2006},
{"log", 2032},
{"look", 57},
{"lost", 3068},
{"low", 24},
{"machine", 1038},
{"magazine", 1016},
{"main", 76},
{"message", 1036},
{"ming", 1058},
{"mirror", 1023},
{"mist", 3069},
{"moss", 1040},
{"mumble", 2003},
{"n", 45},
{"ne", 47},
{"nest", 1056},
{"north", 45},
{"nothing", 2005},
{"nowhere", 21},
{"nugget", 1050},
{"null", 21},
{"nw", 50},
{"off", 2008},
{"office", 76},
{"oil", 1022},
{"on", 2007},
{"onward", 7},
{"open", 2004},
{"opensesame", 3050},
{"oriental", 72},
{"out", 11},
{"outdoors", 32},
{"outside", 11},
{"over", 41},
{"oyster", 1015},
{"passage", 23},
{"pause", 2030},
{"pearl", 1061},
{"persian", 1062},
{"peruse", 2027},
{"pillow", 1010},
{"pirate", 1030},
{"pit", 31},
{"placate", 2010},
{"plant", 1024},
{"plant", 1025},
{"platinum", 1060},
{"plover", 71},
{"plugh", 65},
{"pocus", 3050},
{"pottery", 1058},
{"pour", 2013},
{"proceed", 2011},
{"pyramid", 1060},
{"quit", 2018},
{"rations", 1019},
{"read", 2027},
{"release", 2002},
{"reservoir", 75},
{"retreat", 8},
{"return", 8},
{"right", 37},
{"road", 2},
{"rock", 15},
{"rod", 1005},
{"rod", 1006},
{"room", 59},
{"rub", 2016},
{"rug", 1062},
{"run", 2011},
{"s", 46},
{"save", 2030},
{"say", 2003},
{"score", 2024},
{"se", 48},
{"secret", 66},
{"sesame", 3050},
{"shadow", 1027},
{"shake", 2009},
{"shard", 1058},
{"shatter", 2028},
{"shazam", 3050},
{"shell", 74},
{"shit", 3079},
{"silver", 1052},
{"sing", 2003},
{"slab", 61},
{"slit", 60},
{"smash", 2028},
{"snake", 1011},
{"south", 46},
{"spelunker", 1016},
{"spice", 1063},
{"spices", 1063},
{"stairs", 10},
{"stalactite", 1026},
{"steal", 2001},
{"steps", 1007},
{"steps", 34},
{"stop", 3139},
{"stream", 14},
{"strike", 2012},
{"surface", 20},
{"suspend", 2030},
{"sw", 49},
{"swim", 3147},
{"swing", 2009},
{"tablet", 1013},
{"take", 2001},
{"tame", 2010},
{"throw", 2017},
{"toss", 2017},
{"tote", 2001},
{"touch", 57},
{"travel", 2011},
{"treasure", 1055},
{"tree", 3064},
{"trees", 3064},
{"trident", 1057},
{"troll", 1033},
{"troll", 1034},
{"tunnel", 23},
{"turn", 2011},
{"u", 29},
{"unlock", 2004},
{"up", 29},
{"upstream", 4},
{"upward", 29},
{"utter", 2003},
{"valley", 9},
{"vase", 1058},
{"velvet", 1010},
{"vending", 1038},
{"view", 28},
{"volcano", 1037},
{"w", 44},
{"wake", 2029},
{"walk", 2011},
{"wall", 53},
{"water", 1021},
{"wave", 2009},
{"west", 44},
{"xyzzy", 62},
{"y2", 55}
};
# binary search
sub binary(w: [uint8], wctable: [wac], maxwc: uint16): (ret: int16) is
var lo: uint16;
var mid: uint16;
var hi: uint16;
var check: int8;
var pwc: [wac];
lo := 0;
hi := maxwc - 1;
while lo <= hi loop
mid := (lo + hi) / 2;
pwc := wctable + 4 * mid;
check := strcmp(w, [pwc].aword);
if check == -1 then
hi := mid - 1;
elseif check == 1 then
lo := mid + 1;
else
ret := mid as int16;
return;
end if;
end loop;
ret := -1;
end sub;
# look-up vocabulary word in lex-ordered table. words may have
# two entries with different codes. if minimum acceptable value
# = 0, then return minimum of different codes. last word CANNOT
# have two entries(due to binary sort).
# word is the word to look up.
# val is the minimum acceptable value,
# if != 0 return %1000
sub vocab(word: [uint8], val: uint16): (ret: int16) @extern("vocab") is
var v1: int16;
var v2: int16;
v1 := binary(word, &wc[0], MAXWC);
if v1 >= 0 then
v2 := binary(word, &wc[0], MAXWC-1);
if v2 < 0 then
v2 := v1;
end if;
if val == 0 then
if wc[v1 as uint16].acode < wc[v2 as uint16].acode then
ret := wc[v1 as uint16].acode as int16;
else
ret := wc[v2 as uint16].acode as int16;
end if;
else
if val <= wc[v1 as uint16].acode then
ret := (wc[v1 as uint16].acode % 1000) as int16;
elseif val <= wc[v2 as uint16].acode then
ret := (wc[v2 as uint16].acode % 1000) as int16;
else
ret := -1;
end if;
end if;
else
ret := -1;
end if;
end sub;
sub vocab_ivfoo(): (ret: uint8) @extern("vocab_ivfoo") is
ret := vocab(&word1[0], 3000) as uint8;
end sub;
# Routine to analyze a word.
sub analyze(word: [uint8]): (valid: uint8, type: int16, value: int16) @extern("analyze") is
var wordval: int16;
var msg: uint8;
# make sure I understand
wordval := vocab(word, 0);
if wordval == -1 then
case (xrnd() % 3) is
when 0:
msg := 60;
when 1:
msg := 61;
when else:
msg := 13;
end case;
rspeak(msg);
valid := 0;
type := -1;
value := -1;
else
valid := 1;
type := wordval/1000;
value := wordval%1000;
end if;
end sub;
# called by doobj & vread
sub I_see_no() extern("I_see_no") is
var wtype: int16;
var wval: int16;
var valid: uint8;
(valid, wtype, wval) := analyze(&word1[0]);
if valid == 1 then
print("I see no ");
if wtype == 1 then
print(&word1[0]);
else
print(&word2[0]);
end if;
print(" here.\n");
end if;
end sub;
# Routine to indicate no reasonable
# object for verb found. Used mostly by
# intransitive verbs.
sub needobj() @extern("needobj") is
var wtype: int16;
var wval: int16;
var valid: uint8;
(valid, wtype, wval) := analyze(&word1[0]);
if valid == 1 then
if wtype == 2 then
print(&word1[0]);
else
print(&word2[0]);
end if;
print(" what?\n");
end if;
end sub;
# SAY etc.
sub vsay() is
var wtype: int16;
var wval: int16;
var valid: uint8;
(valid, wtype, wval) := analyze(&word1[0]);
if valid == 1 then
print("Okay.\n");
if wval == SAY then
print(&word2[0]);
else
print(&word1[0]);
end if;
end if;
end sub;
# READ etc.
sub vread(object: int16, closed: int16, verb: int16) @extern("vread") is
var msg: uint8;
var valid: uint8;
msg := 0;
if dark() == 1 then
I_see_no();
return;
end if;
case object is
when MAGAZINE:
msg := 190;
when TABLET:
msg := 196;
when MESSAGE:
msg := 191;
when OYSTER:
if toting(OYSTER) != 0 and closed != 0 then
valid := yes(192,193,54);
return;
end if;
when else:
end case;
if msg > 0 then
rspeak(msg);
else
actspk(verb as uint16);
end if;
end sub;
# INVENTORY
sub inventory() is
var msg: uint8;
var i: uint16;
msg := 98;
i := 1;
while i <= MAXOBJ loop
if i == BEAR or toting(i) == 0 then
i := i + 1;
continue;
end if;
if msg > 0 then
rspeak(99);
end if;
msg := 0;
pspeak(i as uint8 ,-1);
i := i + 1;
end loop;
if toting(BEAR) == 1 then
msg := 141;
end if;
if msg > 0 then
rspeak(msg);
end if;
end sub;
# Routines to process intransitive verbs
sub itverb(verb: int16, object: int16, closed: int16) @extern("itverb") is
var v := verb;
if v == DROP or v == SAY or v == WAVE or v == CALM or v == RUB or v == THROW or v == FIND or v == FEED or v == BREAK then v := WAKE;
elseif v == OPEN then v := LOCK;
elseif v == ON or v == OFF then v := POUR;
end if;
case v is
#when DROP:
#when SAY:
#when WAVE:
#when CALM:
#when RUB:
#when THROW:
#when FIND:
#when FEED:
#when BREAK:
when WAKE:
needobj();
when TAKE:
ivtake();
#when OPEN:
when LOCK:
ivopen();
when NOTHING:
rspeak(54);
#when ON:
#when OFF:
when POUR:
trverb(verb, object, closed);
when WALK:
actspk(verb as uint16);
when KILL:
ivkill();
when EAT:
iveat();
when DRINK:
ivdrink();
when QUIT:
ivquit();
when FILL:
ivfill();
when BLAST:
vblast();
when SCORE:
score();
when FOO:
ivfoo();
when SUSPEND:
set_saveflg(1);
when INVENTORY:
inventory();
when READ:
ivread();
when else:
print("This intransitive not implemented yet\n");
end case;
end sub;
# Routine to process a transitive verb
@impl sub trverb is
var v := verb;
if v == CALM or v == WALK or v == QUIT or v == SCORE or v == FOO or v == BRIEF or v == SUSPEND or v == HOURS then v := LOG;
elseif v == OPEN then v := LOCK;
elseif v == FIND then v := INVENTORY;
end if;
case v is
#when CALM:
#when WALK:
#when QUIT:
#when SCORE:
#when FOO:
#when BRIEF:
#when SUSPEND:
#when HOURS:
when LOG:
actspk(verb as uint16);
when TAKE:
vtake();
when DROP:
vdrop();
#when OPEN:
when LOCK:
vopen();
when SAY:
vsay();
when NOTHING:
rspeak(54);
when ON:
von();
when OFF:
voff();
when WAVE:
vwave();
when KILL:
vkill();
when POUR:
vpour();
when EAT:
veat();
when DRINK:
vdrink();
when RUB:
if object != LAMP then
rspeak(76);
else
actspk(RUB);
end if;
when THROW:
vthrow();
when FEED:
vfeed();
#when FIND:
when INVENTORY:
vfind();
when FILL:
vfill();
when READ:
vread(object, closed, verb);
when BLAST:
vblast();
when BREAK:
vbreak();
when WAKE:
vwake();
when else:
print("This verb is not implemented yet.\n");
end case;
end sub;
# file I/O support ---------------------------------------------------------
record CpmFCB is
dr: uint8;
f: uint8[11];
ex: uint8;
s1: uint8;
s2: uint8;
rc: uint8;
d: uint8[16];
cr: uint8;
r: uint16;
r2: uint8;
end record;
record FCB is
bufferptr: uint8; # byte just read
dirty: uint8;
cpm: CpmFCB;
buffer: uint8[128];
end record;
var fd1: FCB;
var fd2: FCB;
var fd3: FCB;
var fd4: FCB;
sub closefiles() is
var sts: uint8;
sts := FCBClose(&fd1);
sts := FCBClose(&fd2);
sts := FCBClose(&fd3);
sts := FCBClose(&fd4);
end sub;
# Open advent?.txt files
sub opentxt() is
var sts: uint8;
sts := FCBOpenIn(&fd1, "advent1.txt");
if sts != 0 then
print("Sorry, I can't open advent1.txt...\n");
exit();
end if;
sts := FCBOpenIn(&fd2, "advent2.txt");
if sts != 0 then
print("Sorry, I can't open advent2.txt...\n");
exit();
end if;
sts := FCBOpenIn(&fd3, "advent3.txt");
if sts != 0 then
print("Sorry, I can't open advent3.txt...\n");
exit();
end if;
sts := FCBOpenIn(&fd4, "advent4.txt");
if sts != 0 then
print("Sorry, I can't open advent4.txt...\n");
exit();
end if;
end sub;
# ---------------------------------------------------------
const MAXLOC := 140;
var idx1: uint32[MAXLOC] := {
3,160,304,367,448,
507,564,689,855,980,
1086,1333,1385,1567,1694,
2033,2083,2224,2332,2415,
2472,2496,2525,2647,2770,
2894,2963,3029,3125,3164,
3274,3282,3314,3490,3547,
4023,4151,4229,4335,4477,
4574,4733,4793,4853,4913,
4973,4986,4999,5012,5072,
5132,5192,5252,5312,5325,
5385,5398,5581,5594,5691,
5863,5977,6045,6058,6270,
6398,6557,6892,7187,7242,
7302,7447,7512,7532,7688,
7744,7803,7896,7953,8065,
8125,8139,8153,8213,8273,
8287,8301,8361,8516,8589,
8643,8818,9043,9096,9154,
9364,9499,9698,9944,10149,
10283,10357,10504,10769,10834,
10888,11197,11262,11328,11802,
12278,12486,12553,12884,12899,
13652,14160,14346,14427,14494,
14561,14628,14722,14818,15026,
15215,16503,16733,16843,16980,
17180,17247,17312,17379,17446,
17511,17576,17641,17708,17773
};
var idx2: uint32[MAXLOC] := {
3,35,62,89,110,
131,152,184,209,237,
265,292,344,372,404,
433,483,519,554,586,
644,668,697,736,760,
784,853,919,1015,1054,
1164,1172,1204,1224,1281,
1310,1339,1417,1523,1554,
1651,1692,1752,1812,1872,
1932,1946,1960,1974,2034,
2094,2154,2214,2274,2288,
2348,2362,2390,2404,2501,
2538,2575,2643,2657,2689,
2817,2850,2889,2914,2969,
3029,3077,3142,3162,3214,
3270,3329,3422,3479,3591,
3651,3665,3679,3739,3799,
3813,3827,3887,3918,3991,
4045,4091,4117,4170,4228,
4265,4290,4319,4347,4370,
4398,4424,4452,4479,4544,
4598,4623,4688,4715,4745,
4775,4809,4876,4902,4917,
4954,4991,5024,5057,5124,
5191,5258,5291,5316,5345,
5386,5421,5457,5491,5528,
5556,5623,5688,5755,5822,
5887,5952,6017,6084,6149
};
var idx3: uint32[MAXOBJ] := {
3,63,153,208,274,
355,436,524,636,770,
833,889,981,1110,1200,
1377,1469,1473,1477,1522,
1640,1668,1693,1709,2151,
2315,2335,2424,2518,2541,
2557,2780,3020,3196,3250,
3451,3643,3674,3821,3924,
3952,3956,3960,3964,3968,
3972,3976,3980,3984,3988,
4062,4112,4166,4223,4269,
4329,4444,4509,4733,4812,
4891,4957,5072,5120,0,
0,0,0,0,0,
0,0,0,0,0,
0,0,0,0,0,
0,0,0,0,0,
0,0,0,0,0,
0,0,0,0,0,
0,0,0,0,0
};
const MAXMSG := 201;
var idx4: uint32[MAXMSG] := {
3,485,537,655,716,
760,785,810,842,884,
959,1073,1119,1148,1194,
1301,1376,1427,1465,1580,
1631,1796,1832,1891,1924,
1950,2060,2113,2152,2180,
2276,2298,2318,2371,2398,
2427,2458,2487,2520,2545,
2571,2666,2687,2698,2735,
2790,2855,2886,2947,2979,
3033,4327,4342,4359,4366,
4397,4485,4609,4659,4781,
4809,4819,4860,5032,5394,
5717,5810,5842,5874,6040,
6067,6104,6138,6268,6306,
6401,6444,6492,6517,6531,
6546,6717,6921,7054,7171,
7312,7372,7385,7398,7411,
7424,7493,7566,7613,7665,
7708,7780,7820,7854,7900,
7990,8033,8097,8170,8214,
8248,8306,8345,8382,8408,
8434,8488,8565,8630,8733,
8804,8874,8991,9059,9129,
9197,9267,9328,9391,9592,
9688,9825,9892,10117,10254,
10373,10503,10712,10986,11202,
11294,11474,11518,11577,11649,
11685,11741,13063,13100,13156,
13229,13270,13293,13333,13418,
13474,13542,13605,13672,13793,
13807,13937,14078,14222,14291,
14332,14382,14619,14759,14830,
14889,14950,15008,15134,15178,
15210,15242,15272,15333,15368,
15395,15442,15509,15564,15737,
15780,15800,15870,16064,16101,
16236,16564,16636,16719,16820,
16873,16945,17067,17195,17238,
17274,17335,17433,17502,17612,
17637
};
const EOF := 0x1A;
# Function to scan a file up to a specified
# point and either print or return a string.
sub rdupto(fdi: [FCB], uptoc: uint8, print: uint8, str: [uint8]) is
var ch: uint8;
ch := FCBGetChar(fdi);
while ch != uptoc loop
if ch == EOF or ch == 0 then
return;
# elseif ch == '\n' then
# ch := FCBGetChar(fdi);
# continue;
elseif print == 1 then
print_char(ch);
else
[str] := ch; str := str + 1;
end if;
ch := FCBGetChar(fdi);
end loop;
if print == 0 then
[str] := 0;
end if;
end sub;
# Function to read a file skipping
# a given character a specified number
# of times, with or without repositioning
# the file.
sub rdskip(fdi: [FCB], skipc: uint8, n: uint16, rewind: uint8) is
var ch: uint8;
if rewind == 1 then
FCBSeek(fdi, 0);
end if;
while n > 0 loop
ch := FCBGetChar(fdi);
while ch != skipc loop
if ch == EOF or ch == 0 then
bug(32);
end if;
ch := FCBGetChar(fdi);
end loop;
n := n - 1;
end loop;
end sub;
# Print a location description from "advent4.txt"
@impl sub rspeak is
if msg == 54 then
print("ok.\n");
else
if get_dbugflg() == 1 then
print("Seek loc msg #");
print(itoa(msg as int16));
print(" @ ");
print(ltoa(idx4[msg - 1] as int32));
end if;
FCBSeek(&fd4, idx4[msg - 1]);
rdupto(&fd4, '#', 1, 0);
end if;
end sub;
# Print an item message for a given state from "advent3.txt"
@impl sub pspeak is
FCBSeek(&fd3, idx3[item - 1]);
rdskip(&fd3, '/', (state+2) as uint16, 0);
rdupto(&fd3, '/', 1, 0);
end sub;
# Print a long location description from "advent1.txt"
sub desclg(loc: uint8) @extern("desclg") is
FCBSeek(&fd1, idx1[loc - 1]);
rdupto(&fd1, '#', 1, 0);
end sub;
# Print a short location description from "advent2.txt"
sub descsh(loc: uint8) @extern("descsh") is
FCBSeek(&fd2, idx2[loc - 1]);
rdupto(&fd2, '#', 1, 0);
end sub;
# output adventure word list (motion/0xxx & verb/2xxx) only
# 6 words/line pausing at 20th line until keyboard active
sub outwords() @extern("outwords") is
var i: uint16;
var j: uint16;
var line: uint16;
var ch: uint8;
j := 0;
line := 0;
i := 0;
while i < 301 loop
if (wc[i].acode < 1000) or ((wc[i].acode < 3000) and (wc[i].acode > 1999)) then
print(wc[i].aword);
print_char(' ');
j := j + 1;
if (j == 6) or (i == 300) then
j := 0;
print_nl();
line := line + 1;
if line == 20 then
line := 0;
print("\nHit any key to continue...");
ch := get_char();
end if;
end if;
end if;
i := i + 1;
end loop;
end sub;
# Routine true x% of the time.
sub pct(x: uint16): (ret: uint8) @extern("pct") is
if xrnd() % 100 < x then
ret := 1;
else
ret := 0;
end if;
end sub;
# Routine to request a yes or no answer to a question.
@impl sub yes is
var answer: uint8[80];
var n: uint8;
var ch: uint8;
if msg1 > 0 then
rspeak(msg1);
end if;
print_char('>');
get_line(&answer[0]);
if answer[0] == 'n' or answer[0] == 'N' then
if msg3 == 1 then
rspeak(msg3);
end if;
ret := 0;
end if;
if msg2 == 1 then
rspeak(msg2);
end if;
ret := 1;
end sub;
# Routine to destroy an object
sub dstroy(obj: uint16) @extern("dstroy") is
move(obj, 0);
end sub;
# Juggle an object, currently a no-op
sub juggle(loc: uint16) @extern("juggle") is
end sub;
# routine to move an object and return a
# value used to set the negated prop values
# for the repository.
sub put(obj: uint16, where: int16, pval: int16): (ret: int16) @extern("put") is
move(obj, where);
ret := -pval-1;
end sub;
# Convert 0 to WATER
# 1 to nothing
# 2 to OIL
sub liq2(pbottle: uint16): (ret: uint16) @extern("liq2") is
ret := (1 - pbottle) * WATER + (pbottle >> 1) * (WATER + OIL);
end sub;
# The player tried a poor move option.
sub badmove(motion: int16, verb: int16) @extern("badmove") is
var msg: uint8;
msg := 12;
if motion >= 43 and motion <= 50 then msg := 9; end if;
if motion == 29 or motion == 30 then msg := 9; end if;
if motion == 7 or motion == 36 or motion == 37 then msg := 10; end if;
if motion == 11 or motion == 19 then msg := 11; end if;
if verb == FIND or verb == INVENTORY then msg := 59; end if;
if motion == 62 or motion == 65 then msg := 42; end if;
if motion == 17 then msg := 80; end if;
rspeak(msg);
end sub;
# Routine to process an object being referred to.
sub trobj(verb: int16, object: int16, closed: int16) @extern("trobj") is
var wtype: int16;
var wval: int16;
var valid: uint8;
if verb != 0 then
trverb(verb, object, closed);
else
(valid, wtype, wval) := analyze(&word1[0]);
if valid == 1 then
print("What do you want to do with the");
if wtype == 1 then
print(&word1[0]);
else
print(&word2[0]);
end if;
print_nl();
end if;
end if;
end sub;
# retrieve input line (max 80 chars), convert to lower case
# & rescan for first two words (max. WORDSIZE-1 chars).
sub getwords() @extern("getwords") is
var words: uint8[80];
var wptr: [uint8];
var n: uint8;
print_char('>');
word1[0] := 0;
word2[0] := 0;
get_line(&words[0]);
wptr := &words[0];
while [wptr] != 0 loop
[wptr] := tolower([wptr]);
wptr := wptr + 1;
end loop;
n := 0;
wptr := &words[0];
if [wptr] == 0 then return; end if;
while [wptr] != ' ' and [wptr] != 0 loop
word1[n] := [wptr];
wptr := wptr + 1;
n := n + 1;
if n == 19 then break; end if;
end loop;
word1[n] := 0;
if [wptr] == 0 then return; end if;
wptr := wptr + 1; #skip blank
n := 0;
while [wptr] != ' ' and [wptr] != 0 loop
word2[n] := [wptr];
wptr := wptr + 1;
n := n + 1;
if n == 19 then break; end if;
end loop;
word2[n] := 0;
if get_dbugflg() == 1 then
print("WORD1 = ");
print(&word1[0]);
print(" WORD2 = ");
print(&word2[0]);
print_nl();
end if;
end sub;
# Analyze a two word sentence
sub english(): (ret: uint8) @extern("english") is
var msg: [uint8];
var type1: int16;
var type2: int16;
var val1: int16;
var val2: int16;
var valid: uint8;
set_verb(0);
set_object(0);
set_motion(0);
type2 := -1;
val2 := -1;
type1 := -1;
val1 := -1;
msg := "bad grammar...";
getwords();
if word1[0] == 0 then
ret := 0; # ignore whitespace
return;
end if;
(valid, type1, val1) := analyze(&word1[0]);
if valid == 0 then # check word1
ret := 0; # didn't know it
return;
end if;
if type1 == 2 and val1 == SAY then
set_verb(SAY); # repeat word & act upon if..
set_object(1);
ret := 1;
return;
end if;
if word2[0] != 0 then
(valid, type2, val2) := analyze(&word2[0]);
if valid == 0 then
ret := 0; # didn't know it
return;
end if;
end if;
# check his grammar
if (type1 == 3) and (type2 == 3) and (val1 == 51) and (val2 == 51) then
outwords();
ret := 0;
return;
elseif type1 == 3 then
rspeak(val1 as uint8);
ret := 0;
return;
elseif type2 == 3 then
rspeak(val2 as uint8);
ret := 0;
return;
elseif type1 == 0 then
if type2 == 0 then
print(msg);
print_nl();
ret := 0;
return;
else
set_motion(val1);
end if;
elseif type2 == 0 then
set_motion(val2);
elseif type1 == 1 then
set_object(val1);
if type2 == 2 then
set_verb(val2);
end if;
if type2 == 1 then
print(msg);
print_nl();
ret := 0;
return;
end if;
elseif type1 == 2 then
set_verb(val1);
if type2 == 1 then
set_object(val2);
end if;
if type2 == 2 then
print(msg);
print_nl();
ret := 0;
return;
end if;
else
bug(36);
end if;
ret := 1;
end sub;
# Initialize integer arrays
sub scanint(pi: [int16], str: [uint8]) @extern("scanint") is
var p: [uint8];
p := str;
while [p] != nil loop
if [p] == ',' then
[p] := 0;
end if;
p := p + 1;
end loop;
p := str;
while [p] != nil loop
[pi] := atoi(p);
pi := @next pi;
p := p + strlen(p) + 1;
end loop;
end sub;
# main
var arg: [uint8];
var rest: uint8 := 0;
xrndseed();
set_dbugflg(0);
ArgvInit();
loop
var ch: uint8;
arg := ArgvNext();
if arg == nil then
break;
end if;
ch := tolower([arg]);
if ch == 'd' then
set_dbugflg(1);
elseif ch == 'r' then
rest := 1;
end if;
end loop;
opentxt();
initplay();
if rest == 1 then
restore();
end if;
if yes(65, 1, 0) == 1 then
set_limit(1000);
else
set_limit(330);
end if;
set_saveflg(0);
while get_saveflg() == 0 loop
turn();
end loop;
# ...suspend
closefiles();
save();
exit();