games-request@tekred.TEK.COM (10/24/87)
Submitted by: Marc Russell Pawliger <mp1w+@andrew.cmu.edu>
Comp.sources.games: Volume 2, Issue 56
Archive-name: advsys/Part02
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 2 (of 3)."
# Contents: advdbs.c advexp.c advfcn.c objects.adi osample.adv
# Wrapped by billr@tekred on Fri Oct 9 16:25:13 1987
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f advdbs.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"advdbs.c\"
else
echo shar: Extracting \"advdbs.c\" \(10575 characters\)
sed "s/^X//" >advdbs.c <<'END_OF_advdbs.c'
X/* advdbs.c - adventure database access routines */
X/*
X Copyright (c) 1986, by David Michael Betz
X All rights reserved
X*/
X
X#include "advint.h"
X#include "advdbs.h"
X#ifdef MAC
X#include <fnctl.h>
X#define RMODE (O_RDONLY|O_BINARY)
X#else
X#include <setjmp.h>
X#define RMODE 0
X#endif
X
X/* global variables */
Xint h_init; /* initialization code */
Xint h_update; /* update code */
Xint h_before; /* before handler code */
Xint h_after; /* after handler code */
Xint h_error; /* error handling code */
Xint datafd; /* data file descriptor */
X
X/* external variables */
Xextern jmp_buf restart;
X
X/* external routines */
Xextern char *malloc();
X
X/* table base addresses */
Xchar *wtable; /* word table */
Xchar *wtypes; /* word type table */
Xint wcount; /* number of words */
Xchar *otable; /* object table */
Xint ocount; /* number of objects */
Xchar *atable; /* action table */
Xint acount; /* number of actions */
Xchar *vtable; /* variable table */
Xint vcount; /* number of variables */
Xchar *data; /* base of data tables */
Xchar *base; /* current base address */
Xchar *dbase; /* base of the data space */
Xchar *cbase; /* base of the code space */
Xint length; /* length of resident data structures */
X
X/* data file header */
Xstatic char hdr[HDR_SIZE];
X
X/* save parameters */
Xstatic long saveoff; /* save data file offset */
Xstatic char *save; /* save area base address */
Xstatic int slen; /* save area length */
X
X/* db_init - read and decode the data file header */
Xdb_init(name)
X char *name;
X{
X int woff,ooff,aoff,voff,n;
X char fname[50];
X
X /* get the data file name */
X strcpy(fname,name);
X#ifndef MAC
X strcat(fname,".dat");
X#endif
X
X /* open the data file */
X if ((datafd = open(fname,RMODE)) == -1)
X error("can't open data file");
X
X /* read the header */
X if (read(datafd,hdr,HDR_SIZE) != HDR_SIZE)
X error("bad data file");
X complement(hdr,HDR_SIZE);
X base = hdr;
X
X /* check the magic information */
X if (strncmp(&hdr[HDR_MAGIC],"ADVSYS",6) != 0)
X error("not an adventure data file");
X
X /* check the version number */
X if ((n = getword(HDR_VERSION)) < 101 || n > VERSION)
X error("wrong version number");
X
X /* decode the resident data length header field */
X length = getword(HDR_LENGTH);
X
X /* allocate space for the resident data structure */
X if ((data = malloc(length)) == 0)
X error("insufficient memory");
X
X /* compute the offset to the data */
X saveoff = (long)getword(HDR_DATBLK) * 512L;
X
X /* read the resident data structure */
X lseek(datafd,saveoff,0);
X if (read(datafd,data,length) != length)
X error("bad data file");
X complement(data,length);
X
X /* get the table base addresses */
X wtable = data + (woff = getword(HDR_WTABLE));
X wtypes = data + getword(HDR_WTYPES) - 1;
X otable = data + (ooff = getword(HDR_OTABLE));
X atable = data + (aoff = getword(HDR_ATABLE));
X vtable = data + (voff = getword(HDR_VTABLE));
X
X /* get the save data area */
X saveoff += (long)getword(HDR_SAVE);
X save = data + getword(HDR_SAVE);
X slen = getword(HDR_SLEN);
X
X /* get the base of the data and code spaces */
X dbase = data + getword(HDR_DBASE);
X cbase = data + getword(HDR_CBASE);
X
X /* initialize the message routines */
X msg_init(datafd,getword(HDR_MSGBLK));
X
X /* get the code pointers */
X h_init = getword(HDR_INIT);
X h_update = getword(HDR_UPDATE);
X h_before = getword(HDR_BEFORE);
X h_after = getword(HDR_AFTER);
X h_error = getword(HDR_ERROR);
X
X /* get the table lengths */
X base = data;
X wcount = getword(woff);
X ocount = getword(ooff);
X acount = getword(aoff);
X vcount = getword(voff);
X
X /* setup the base of the resident data */
X base = dbase;
X
X /* set the object count */
X setvalue(V_OCOUNT,ocount);
X}
X
X/* db_save - save the current database */
Xdb_save(name)
X char *name;
X{
X return (advsave(&hdr[HDR_ANAME],20,save,slen) ? T : NIL);
X}
X
X/* db_restore - restore a saved database */
Xint db_restore(name)
X char *name;
X{
X return (advrestore(&hdr[HDR_ANAME],20,save,slen) ? T : NIL);
X}
X
X/* db_restart - restart the current game */
Xdb_restart()
X{
X lseek(datafd,saveoff,0);
X if (read(datafd,save,slen) != slen)
X return (NIL);
X complement(save,slen);
X setvalue(V_OCOUNT,ocount);
X longjmp(restart,1);
X}
X
X/* complement - complement a block of memory */
Xcomplement(adr,len)
X char *adr; int len;
X{
X for (; len--; adr++)
X *adr = ~(*adr + 30);
X}
X
X/* findword - find a word in the dictionary */
Xint findword(word)
X char *word;
X{
X char sword[WRDSIZE+1];
X int wrd,i;
X
X /* shorten the word */
X strncpy(sword,word,WRDSIZE); sword[WRDSIZE] = 0;
X
X /* look up the word */
X for (i = 1; i <= wcount; i++) {
X wrd = getwloc(i);
X if (strcmp(base+wrd+2,sword) == 0)
X return (getword(wrd));
X }
X return (NIL);
X}
X
X/* wtype - return the type of a word */
Xint wtype(wrd)
X int wrd;
X{
X return (wtypes[wrd]);
X}
X
X/* match - match an object against a name and list of adjectives */
Xint match(obj,noun,adjs)
X int obj,noun,*adjs;
X{
X int *aptr;
X
X if (!hasnoun(obj,noun))
X return (FALSE);
X for (aptr = adjs; *aptr != NIL; aptr++)
X if (!hasadjective(obj,*aptr))
X return (FALSE);
X return (TRUE);
X}
X
X/* checkverb - check to see if this is a valid verb */
Xint checkverb(verbs)
X int *verbs;
X{
X int act;
X
X /* look up the action */
X for (act = 1; act <= acount; act++)
X if (hasverb(act,verbs))
X return (act);
X return (NIL);
X}
X
X/* findaction - find an action matching a description */
Xfindaction(verbs,preposition,flag)
X int *verbs,preposition,flag;
X{
X int act,mask;
X
X /* look up the action */
X for (act = 1; act <= acount; act++) {
X if (preposition && !haspreposition(act,preposition))
X continue;
X if (!hasverb(act,verbs))
X continue;
X mask = ~getabyte(act,A_MASK);
X if ((flag & mask) == (getabyte(act,A_FLAG) & mask))
X return (act);
X }
X return (NIL);
X}
X
X/* getp - get the value of an object property */
Xint getp(obj,prop)
X int obj,prop;
X{
X int p;
X
X for (; obj; obj = getofield(obj,O_CLASS))
X if (p = findprop(obj,prop))
X return (getofield(obj,p));
X return (NIL);
X}
X
X/* setp - set the value of an object property */
Xint setp(obj,prop,val)
X int obj,prop,val;
X{
X int p;
X
X for (; obj; obj = getofield(obj,O_CLASS))
X if (p = findprop(obj,prop))
X return (putofield(obj,p,val));
X return (NIL);
X}
X
X/* findprop - find a property */
Xint findprop(obj,prop)
X int obj,prop;
X{
X int n,i,p;
X
X n = getofield(obj,O_NPROPERTIES);
X for (i = p = 0; i < n; i++, p += 4)
X if ((getofield(obj,O_PROPERTIES+p) & ~P_CLASS) == prop)
X return (O_PROPERTIES+p+2);
X return (NIL);
X}
X
X/* hasnoun - check to see if an object has a specified noun */
Xint hasnoun(obj,noun)
X int obj,noun;
X{
X while (obj) {
X if (inlist(getofield(obj,O_NOUNS),noun))
X return (TRUE);
X obj = getofield(obj,O_CLASS);
X }
X return (FALSE);
X}
X
X/* hasadjective - check to see if an object has a specified adjective */
Xint hasadjective(obj,adjective)
X int obj,adjective;
X{
X while (obj) {
X if (inlist(getofield(obj,O_ADJECTIVES),adjective))
X return (TRUE);
X obj = getofield(obj,O_CLASS);
X }
X return (FALSE);
X}
X
X/* hasverb - check to see if this action has this verb */
Xint hasverb(act,verbs)
X int act,*verbs;
X{
X int link,word,*verb;
X
X /* get the list of verbs */
X link = getafield(act,A_VERBS);
X
X /* look for this verb */
X while (link != NIL) {
X verb = verbs;
X word = getword(link+L_DATA);
X while (*verb != NIL && word != NIL) {
X if (*verb != getword(word+L_DATA))
X break;
X verb++;
X word = getword(word+L_NEXT);
X }
X if (*verb == NIL && word == NIL)
X return (TRUE);
X link = getword(link+L_NEXT);
X }
X return (FALSE);
X}
X
X/* haspreposition - check to see if an action has a specified preposition */
Xint haspreposition(act,preposition)
X int act,preposition;
X{
X return (inlist(getafield(act,A_PREPOSITIONS),preposition));
X}
X
X/* inlist - check to see if a word is an element of a list */
Xint inlist(link,word)
X int link,word;
X{
X while (link != NIL) {
X if (word == getword(link+L_DATA))
X return (TRUE);
X link = getword(link+L_NEXT);
X }
X return (FALSE);
X}
X
X/* getofield - get a field from an object */
Xint getofield(obj,off)
X int obj,off;
X{
X return (getword(getoloc(obj)+off));
X}
X
X/* putofield - put a field into an object */
Xint putofield(obj,off,val)
X int obj,off,val;
X{
X return (putword(getoloc(obj)+off,val));
X}
X
X/* getafield - get a field from an action */
Xint getafield(act,off)
X int act,off;
X{
X return (getword(getaloc(act)+off));
X}
X
X/* getabyte - get a byte field from an action */
Xint getabyte(act,off)
X int act,off;
X{
X return (getbyte(getaloc(act)+off));
X}
X
X/* getoloc - get an object from the object table */
Xint getoloc(n)
X int n;
X{
X if (n < 1 || n > ocount)
X nerror("object number out of range: %d",n);
X return (getdword(otable+n+n));
X}
X
X/* getaloc - get an action from the action table */
Xint getaloc(n)
X int n;
X{
X if (n < 1 || n > acount)
X nerror("action number out of range: %d",n);
X return (getdword(atable+n+n));
X}
X
X/* getvalue - get the value of a variable from the variable table */
Xint getvalue(n)
X int n;
X{
X if (n < 1 || n > vcount)
X nerror("variable number out of range: %d",n);
X return (getdword(vtable+n+n));
X}
X
X/* setvalue - set the value of a variable in the variable table */
Xint setvalue(n,v)
X int n,v;
X{
X if (n < 1 || n > vcount)
X nerror("variable number out of range: %d",n);
X return (putdword(vtable+n+n,v));
X}
X
X/* getwloc - get a word from the word table */
Xint getwloc(n)
X int n;
X{
X if (n < 1 || n > wcount)
X nerror("word number out of range: %d",n);
X return (getdword(wtable+n+n));
X}
X
X/* getword - get a word from the data array */
Xint getword(n)
X int n;
X{
X return (getdword(base+n));
X}
X
X/* putword - put a word into the data array */
Xint putword(n,w)
X int n,w;
X{
X return (putdword(base+n,w));
X}
X
X/* getbyte - get a byte from the data array */
Xint getbyte(n)
X int n;
X{
X return (*(base+n) & 0xFF);
X}
X
X/* getcbyte - get a code byte */
Xint getcbyte(n)
X int n;
X{
X return (*(cbase+n) & 0xFF);
X}
X
X/* getcword - get a code word */
Xint getcword(n)
X int n;
X{
X return (getdword(cbase+n));
X}
X
X/* getdword - get a word from the data array */
Xint getdword(p)
X char *p;
X{
X return (((*p & 0xFF) | (*(p+1) << 8))&0xFFFF);
X}
X
X/* putdword - put a word into the data array */
Xint putdword(p,w)
X char *p; int w;
X{
X *p = w; *(p+1) = w >> 8;
X return (w);
X}
X
X/* nerror - handle errors with numeric arguments */
Xnerror(fmt,n)
X char *fmt; int n;
X{
X char buf[100];
X sprintf(buf,fmt,n);
X error(buf);
X}
X
END_OF_advdbs.c
if test 10575 -ne `wc -c <advdbs.c`; then
echo shar: \"advdbs.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f advexp.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"advexp.c\"
else
echo shar: Extracting \"advexp.c\" \(10163 characters\)
sed "s/^X//" >advexp.c <<'END_OF_advexp.c'
X
X/* advexp.c - expression compiler for adventure games */
X/*
X Copyright (c) 1986, by David Michael Betz
X All rights reserved
X*/
X
X#include "advcom.h"
X#include "advdbs.h"
X
X/* external routines */
Xextern SYMBOL *sfind();
X
X/* external variables */
Xextern char t_token[];
Xextern int t_value;
Xextern int curobj;
Xextern char *code;
Xextern int cptr;
X
X/* forward declarations */
Xint do_cond(),do_and(),do_or(),do_if(),do_while(),do_progn();
Xint do_setq(),do_return(),do_send(),do_sndsuper();
X
X/* opcode tables */
Xstatic struct { char *nt_name; int nt_code,nt_args; } *nptr,ntab[] = {
X "not", OP_NOT, 1,
X "+", OP_ADD, 2,
X "-", OP_SUB, 2,
X "*", OP_MUL, 2,
X "/", OP_DIV, 2,
X "%", OP_REM, 2,
X "&", OP_BAND, 2,
X "|", OP_BOR, 2,
X "~", OP_BNOT, 1,
X "<", OP_LT, 2,
X "=", OP_EQ, 2,
X ">", OP_GT, 2,
X "getp", OP_GETP, 2,
X "setp", OP_SETP, 3,
X "class", OP_CLASS, 1,
X "match", OP_MATCH, 2,
X "print", OP_PRINT, 1,
X "print-number", OP_PNUMBER, 1,
X "print-noun", OP_PNOUN, 1,
X "terpri", OP_TERPRI, 0,
X "finish", OP_FINISH, 0,
X "chain", OP_CHAIN, 0,
X "abort", OP_ABORT, 0,
X "exit", OP_EXIT, 0,
X "save", OP_SAVE, 0,
X "restore", OP_RESTORE, 0,
X "restart", OP_RESTART, 0,
X "yes-or-no", OP_YORN, 0,
X "rand", OP_RAND, 1,
X "randomize", OP_RNDMIZE, 0,
X 0
X};
Xstatic struct { char *ft_name; int (*ft_fcn)(); } *fptr,ftab[] = {
X "cond", do_cond,
X "and", do_and,
X "or", do_or,
X "if", do_if,
X "while", do_while,
X "progn", do_progn,
X "setq", do_setq,
X "return", do_return,
X "send", do_send,
X "send-super", do_sndsuper,
X 0
X};
X
X/* do_expr - compile a subexpression */
Xdo_expr()
X{
X int tkn;
X
X switch (token()) {
X case T_OPEN:
X switch (tkn = token()) {
X case T_IDENTIFIER:
X if (in_ntab() || in_ftab())
X break;
X default:
X stoken(tkn);
X do_call();
X }
X break;
X case T_NUMBER:
X do_literal();
X break;
X case T_STRING:
X do_literal();
X break;
X case T_IDENTIFIER:
X do_identifier();
X break;
X default:
X error("Expecting expression");
X }
X}
X
X/* in_ntab - check for a function in ntab */
Xint in_ntab()
X{
X for (nptr = ntab; nptr->nt_name; ++nptr)
X if (strcmp(t_token,nptr->nt_name) == 0) {
X do_nary(nptr->nt_code,nptr->nt_args);
X return (TRUE);
X }
X return (FALSE);
X}
X
X/* in_ftab - check for a function in ftab */
Xint in_ftab()
X{
X for (fptr = ftab; fptr->ft_name; ++fptr)
X if (strcmp(t_token,fptr->ft_name) == 0) {
X (*fptr->ft_fcn)();
X return (TRUE);
X }
X return (FALSE);
X}
X
X/* do_cond - compile the (COND ... ) expression */
Xdo_cond()
X{
X int tkn,nxt,end;
X
X /* initialize the fixup chain */
X end = NIL;
X
X /* compile each COND clause */
X while ((tkn = token()) != T_CLOSE) {
X require(tkn,T_OPEN);
X do_expr();
X putcbyte(OP_BRF);
X nxt = putcword(NIL);
X while ((tkn = token()) != T_CLOSE) {
X stoken(tkn);
X do_expr();
X }
X putcbyte(OP_BR);
X end = putcword(end);
X fixup(nxt,cptr);
X }
X
X /* fixup references to the end of statement */
X if (end)
X fixup(end,cptr);
X else
X putcbyte(OP_NIL);
X}
X
X/* do_and - compile the (AND ... ) expression */
Xdo_and()
X{
X int tkn,end;
X
X /* initialize the fixup chain */
X end = NIL;
X
X /* compile each expression */
X while ((tkn = token()) != T_CLOSE) {
X stoken(tkn);
X do_expr();
X putcbyte(OP_BRF);
X end = putcword(end);
X }
X
X /* fixup references to the end of statement */
X if (end)
X fixup(end,cptr);
X else
X putcbyte(OP_NIL);
X}
X
X/* do_or - compile the (OR ... ) expression */
Xdo_or()
X{
X int tkn,end;
X
X /* initialize the fixup chain */
X end = NIL;
X
X /* compile each expression */
X while ((tkn = token()) != T_CLOSE) {
X stoken(tkn);
X do_expr();
X putcbyte(OP_BRT);
X end = putcword(end);
X }
X
X /* fixup references to the end of statement */
X if (end)
X fixup(end,cptr);
X else
X putcbyte(OP_T);
X}
X
X/* do_if - compile the (IF ... ) expression */
Xdo_if()
X{
X int tkn,nxt,end;
X
X /* compile the test expression */
X do_expr();
X
X /* skip around the 'then' clause if the expression is false */
X putcbyte(OP_BRF);
X nxt = putcword(NIL);
X
X /* compile the 'then' clause */
X do_expr();
X
X /* compile the 'else' clause */
X if ((tkn = token()) != T_CLOSE) {
X putcbyte(OP_BR);
X end = putcword(NIL);
X fixup(nxt,cptr);
X stoken(tkn);
X do_expr();
X frequire(T_CLOSE);
X nxt = end;
X }
X
X /* handle the end of the statement */
X fixup(nxt,cptr);
X}
X
X/* do_while - compile the (WHILE ... ) expression */
Xdo_while()
X{
X int tkn,nxt,end;
X
X /* compile the test expression */
X nxt = cptr;
X do_expr();
X
X /* skip around the 'then' clause if the expression is false */
X putcbyte(OP_BRF);
X end = putcword(NIL);
X
X /* compile the loop body */
X while ((tkn = token()) != T_CLOSE) {
X stoken(tkn);
X do_expr();
X }
X
X /* branch back to the start of the loop */
X putcbyte(OP_BR);
X putcword(nxt);
X
X /* handle the end of the statement */
X fixup(end,cptr);
X}
X
X/* do_progn - compile the (PROGN ... ) expression */
Xdo_progn()
X{
X int tkn,n;
X
X /* compile each expression */
X for (n = 0; (tkn = token()) != T_CLOSE; ++n) {
X stoken(tkn);
X do_expr();
X }
X
X /* check for an empty statement list */
X if (n == 0)
X putcbyte(OP_NIL);
X}
X
X/* do_setq - compile the (SETQ v x) expression */
Xdo_setq()
X{
X char name[TKNSIZE+1];
X int n;
X
X /* get the symbol name */
X frequire(T_IDENTIFIER);
X strcpy(name,t_token);
X
X /* compile the value expression */
X do_expr();
X
X /* check for this being a local symbol */
X if ((n = findarg(name)) >= 0)
X code_setargument(n);
X else if ((n = findtmp(name)) >= 0)
X code_settemporary(n);
X else {
X n = venter(name);
X code_setvariable(n);
X }
X frequire(T_CLOSE);
X}
X
X/* do_return - handle the (RETURN [expr]) expression */
Xdo_return()
X{
X int tkn;
X
X /* look for a result expression */
X if ((tkn = token()) != T_CLOSE) {
X stoken(tkn);
X do_expr();
X frequire(T_CLOSE);
X }
X
X /* otherwise, default the result to nil */
X else
X putcbyte(OP_NIL);
X
X /* insert the return opcode */
X putcbyte(OP_RETURN);
X}
X
X/* do_send - handle the (SEND obj msg [expr]...) expression */
Xdo_send()
X{
X /* start searching for the method at the object itself */
X putcbyte(OP_NIL);
X
X /* compile the object expression */
X putcbyte(OP_PUSH);
X do_expr();
X
X /* call the general message sender */
X sender();
X}
X
X/* do_sndsuper - handle the (SEND-SUPER msg [expr]...) expression */
Xdo_sndsuper()
X{
X /* start searching for the method at the current class object */
X code_literal(curobj);
X
X /* pass the message to "self" */
X putcbyte(OP_PUSH);
X code_argument(findarg("self"));
X
X /* call the general message sender */
X sender();
X}
X
X/* sender - compile an expression to send a message to an object */
Xsender()
X{
X int tkn,n;
X
X /* compile the selector expression */
X putcbyte(OP_PUSH);
X do_expr();
X
X /* compile each argument expression */
X for (n = 2; (tkn = token()) != T_CLOSE; ++n) {
X stoken(tkn);
X putcbyte(OP_PUSH);
X do_expr();
X }
X putcbyte(OP_SEND);
X putcbyte(n);
X}
X
X/* do_call - compile a function call */
Xdo_call()
X{
X int tkn,n;
X
X /* compile the function itself */
X do_expr();
X
X /* compile each argument expression */
X for (n = 0; (tkn = token()) != T_CLOSE; ++n) {
X stoken(tkn);
X putcbyte(OP_PUSH);
X do_expr();
X }
X putcbyte(OP_CALL);
X putcbyte(n);
X}
X
X/* do_nary - compile nary operator expressions */
Xdo_nary(op,n)
X int op,n;
X{
X while (n--) {
X do_expr();
X if (n) putcbyte(OP_PUSH);
X }
X putcbyte(op);
X frequire(T_CLOSE);
X}
X
X/* do_literal - compile a literal */
Xdo_literal()
X{
X code_literal(t_value);
X}
X
X/* do_identifier - compile an identifier */
Xdo_identifier()
X{
X SYMBOL *sym;
X int n;
X
X if (match("t"))
X putcbyte(OP_T);
X else if (match("nil"))
X putcbyte(OP_NIL);
X else if ((n = findarg(t_token)) >= 0)
X code_argument(n);
X else if ((n = findtmp(t_token)) >= 0)
X code_temporary(n);
X else if (sym = sfind(t_token)) {
X if (sym->s_type == ST_VARIABLE)
X code_variable(sym->s_value);
X else
X code_literal(sym->s_value);
X }
X else
X code_literal(oenter(t_token));
X}
X
X/* code_argument - compile an argument reference */
Xcode_argument(n)
X int n;
X{
X putcbyte(OP_ARG);
X putcbyte(n);
X}
X
X/* code_setargument - compile a set argument reference */
Xcode_setargument(n)
X int n;
X{
X putcbyte(OP_ASET);
X putcbyte(n);
X}
X
X/* code_temporary - compile an temporary reference */
Xcode_temporary(n)
X int n;
X{
X putcbyte(OP_TMP);
X putcbyte(n);
X}
X
X/* code_settemporary - compile a set temporary reference */
Xcode_settemporary(n)
X int n;
X{
X putcbyte(OP_TSET);
X putcbyte(n);
X}
X
X/* code_variable - compile a variable reference */
Xcode_variable(n)
X int n;
X{
X if (n < 32)
X putcbyte(OP_XVAR+n);
X else if (n < 256)
X { putcbyte(OP_SVAR); putcbyte(n); }
X else
X { putcbyte(OP_VAR); putcword(n); }
X}
X
X/* code_setvariable - compile a set variable reference */
Xcode_setvariable(n)
X int n;
X{
X if (n < 32)
X putcbyte(OP_XSET+n);
X else if (n < 256)
X { putcbyte(OP_SSET); putcbyte(n); }
X else
X { putcbyte(OP_SET); putcword(n); }
X}
X
X/* code_literal - compile a literal reference */
Xcode_literal(n)
X int n;
X{
X if (n >= 0 && n < 64)
X putcbyte(OP_XPLIT+n);
X else if (n < 0 && n > -64)
X putcbyte(OP_XNLIT-n);
X else if (n >= 64 && n < 256)
X { putcbyte(OP_SPLIT); putcbyte(n); }
X else if (n <= -64 && n > -256)
X { putcbyte(OP_SNLIT); putcbyte(-n); }
X else
X { putcbyte(OP_LIT); putcword(n); }
X}
X
X/* do_op - insert an opcode and look for closing paren */
Xdo_op(op)
X int op;
X{
X putcbyte(op);
X frequire(T_CLOSE);
X}
X
X/* putcbyte - put a code byte into data space */
Xint putcbyte(b)
X int b;
X{
X if (cptr < CMAX)
X code[cptr++] = b;
X else
X error("insufficient code space");
X return (cptr-1);
X}
X
X/* putcword - put a code word into data space */
Xint putcword(w)
X int w;
X{
X putcbyte(w);
X putcbyte(w >> 8);
X return (cptr-2);
X}
X
X/* fixup - fixup a reference chain */
Xfixup(chn,val)
X int chn,val;
X{
X int hval,nxt;
X
X /* store the value into each location in the chain */
X for (hval = val >> 8; chn != NIL; chn = nxt) {
X if (chn < 0 || chn > CMAX-2)
X return;
X nxt = (code[chn] & 0xFF) | (code[chn+1] << 8);
X code[chn] = val;
X code[chn+1] = hval;
X }
X}
X
END_OF_advexp.c
if test 10163 -ne `wc -c <advexp.c`; then
echo shar: \"advexp.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f advfcn.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"advfcn.c\"
else
echo shar: Extracting \"advfcn.c\" \(13701 characters\)
sed "s/^X//" >advfcn.c <<'END_OF_advfcn.c'
X
X/* advfcn.c - functions for the adventure compiler */
X/*
X Copyright (c) 1986, by David Michael Betz
X All rights reserved
X*/
X
X#include "advcom.h"
X#include "advdbs.h"
X
X/* external variables */
Xextern char aname[]; /* adventure name */
Xextern int aversion; /* adventure version number */
Xextern int cptr; /* code space pointer */
Xextern int objbuf[]; /* object staging buffer */
Xextern int nprops; /* number of properties in current object */
Xextern int t_value; /* token value */
Xextern char t_token[]; /* token string */
Xextern char *t_names[]; /* token names */
Xextern int otable[]; /* object table */
Xextern int curobj; /* current object number */
Xextern int curact; /* current action offset */
Xextern int atable[],acnt; /* action table and count */
Xextern ARGUMENT *arguments; /* function argument list */
Xextern ARGUMENT *temporaries; /* function temporary variable list */
Xextern int def_flag; /* default action flag value */
Xextern int def_mask; /* default action mask value */
X
X/* external routines */
Xextern char *malloc();
Xextern char *save();
X
X/* do_adventure - handle the <ADVENTURE name version-number> statement */
Xdo_adventure()
X{
X /* get the adventure name */
X frequire(T_IDENTIFIER);
X strncpy(aname,t_token,18);
X aname[18] = 0;
X
X /* get the adventure version number */
X frequire(T_NUMBER);
X aversion = t_value;
X
X /* check for the closing paren */
X frequire(T_CLOSE);
X}
X
X/* do_word - enter words of a particular type */
Xdo_word(type)
X{
X int tkn;
X
X while ((tkn = token()) == T_IDENTIFIER)
X add_word(t_token,type);
X require(tkn,T_CLOSE);
X}
X
X/* do_synonym - handle the <SYNONYMS ... > statement */
Xdo_synonym()
X{
X int tkn,wrd;
X
X frequire(T_IDENTIFIER);
X wrd = add_word(t_token,WT_UNKNOWN);
X while ((tkn = token()) == T_IDENTIFIER)
X add_synonym(t_token,wrd);
X require(tkn,T_CLOSE);
X}
X
X/* do_define - handle the <DEFINE ... > statement */
Xdo_define()
X{
X char name[TKNSIZE+1];
X int tkn;
X
X if ((tkn = token()) == T_OPEN)
X return (do_function());
X stoken(tkn);
X
X while ((tkn = token()) == T_IDENTIFIER) {
X strcpy(name,t_token);
X center(name,getvalue());
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_variable - handle the <VARIABLE ... > statement */
Xdo_variable()
X{
X int tkn;
X
X while ((tkn = token()) == T_IDENTIFIER)
X venter(t_token);
X require(tkn,T_CLOSE);
X}
X
X/* do_defproperty - handle the <PROPERTY ... > statement */
Xdo_defproperty()
X{
X int tkn;
X
X while ((tkn = token()) == T_IDENTIFIER)
X penter(t_token);
X require(tkn,T_CLOSE);
X}
X
X/* do_default - handle the <DEFAULT ... > statement */
Xdo_default()
X{
X int tkn;
X
X /* process statements until end of file */
X while ((tkn = token()) == T_OPEN) {
X frequire(T_IDENTIFIER);
X if (match("actor"))
X do_dflag(A_ACTOR);
X else if (match("direct-object"))
X do_dflag(A_DOBJECT);
X else if (match("indirect-object"))
X do_dflag(A_IOBJECT);
X else
X error("Unknown default definition statement type");
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_dflag - handle ACTOR, DIRECT-OBJECT, and INDIRECT-OBJECT statements */
Xdo_dflag(flag)
X int flag;
X{
X int tkn;
X
X if ((tkn = token()) == T_IDENTIFIER) {
X if (match("required")) {
X def_flag |= flag;
X def_mask &= ~flag;
X }
X else if (match("forbidden")) {
X def_flag &= ~flag;
X def_mask &= ~flag;
X }
X else if (match("optional"))
X def_mask |= flag;
X else
X error("Expecting: REQUIRED, FORBIDDEN or OPTIONAL");
X tkn = token();
X }
X else {
X def_flag |= flag;
X def_mask &= ~flag;
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_object - handle object (LOCATION,OBJECT,ACTOR) definitions */
Xint do_object(cname,class)
X char *cname; int class;
X{
X int tkn,obj,obase,osize,i,p;
X
Xprintf("[ %s: ",cname);
X frequire(T_IDENTIFIER);
Xprintf("%s ]\n",t_token);
X obj = curobj = oenter(t_token);
X
X /* initialize the object */
X objbuf[O_CLASS/2] = class;
X objbuf[O_NOUNS/2] = NIL;
X objbuf[O_ADJECTIVES/2] = NIL;
X objbuf[O_NPROPERTIES/2] = nprops = 0;
X
X /* copy the property list of the class object */
X if (class) {
X obase = otable[class];
X osize = getword(obase+O_NPROPERTIES);
X for (i = p = 0; i < osize; i++, p += 4)
X if ((getword(obase+O_PROPERTIES+p) & P_CLASS) == 0)
X addprop(getword(obase+O_PROPERTIES+p),0,
X getword(obase+O_PROPERTIES+p+2));
X }
X
X /* process statements until end of file */
X while ((tkn = token()) == T_OPEN) {
X frequire(T_IDENTIFIER);
X if (match("noun"))
X do_noun();
X else if (match("adjective"))
X do_adjective();
X else if (match("property"))
X do_property(0);
X else if (match("class-property"))
X do_property(P_CLASS);
X else if (match("method"))
X do_method();
X else
X error("Unknown object definition statement type");
X }
X require(tkn,T_CLOSE);
X
X /* copy the object to data memory */
X osize = O_SIZE/2 + nprops*2;
X obase = dalloc(osize*2);
X for (i = p = 0; i < osize; i++, p += 2)
X putword(obase+p,objbuf[i]);
X otable[obj] = obase;
X curobj = NIL;
X
X /* return the object number */
X return (obj);
X}
X
X/* do_noun - handle the <NOUN ... > statement */
Xdo_noun()
X{
X int tkn,new;
X
X while ((tkn = token()) == T_IDENTIFIER) {
X new = dalloc(L_SIZE);
X putword(new+L_DATA,add_word(t_token,WT_NOUN));
X putword(new+L_NEXT,objbuf[O_NOUNS/2]);
X objbuf[O_NOUNS/2] = new;
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_adjective - handle the <ADJECTIVE ... > statement */
Xdo_adjective()
X{
X int tkn,new;
X
X while ((tkn = token()) == T_IDENTIFIER) {
X new = dalloc(L_SIZE);
X putword(new+L_DATA,add_word(t_token,WT_ADJECTIVE));
X putword(new+L_NEXT,objbuf[O_ADJECTIVES/2]);
X objbuf[O_ADJECTIVES/2] = new;
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_property - handle the <PROPERTY ... > statement */
Xdo_property(flags)
X int flags;
X{
X int tkn,name,value;
X
X while ((tkn = token()) == T_IDENTIFIER || tkn == T_NUMBER) {
X name = (tkn == T_IDENTIFIER ? penter(t_token) : t_value);
X value = getvalue();
X setprop(name,flags,value);
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_method - handle <METHOD (FUN ...) ... > statement */
Xdo_method()
X{
X int tkn,name,tcnt;
X
X /* get the property name */
X frequire(T_OPEN);
X frequire(T_IDENTIFIER);
Xprintf("[ method: %s ]\n",t_token);
X
X /* create a new property */
X name = penter(t_token);
X
X /* allocate a new (anonymous) action */
X if (acnt < AMAX)
X ++acnt;
X else
X error("too many actions");
X
X /* store the action as the value of the property */
X setprop(name,P_CLASS,acnt);
X
X /* initialize the action */
X curact = atable[acnt] = dalloc(A_SIZE);
X putword(curact+A_VERBS,NIL);
X putword(curact+A_PREPOSITIONS,NIL);
X arguments = temporaries = NULL;
X tcnt = 0;
X
X /* enter the "self" argument */
X addargument(&arguments,"self");
X addargument(&arguments,"(dummy)");
X
X /* get the argument list */
X while ((tkn = token()) != T_CLOSE) {
X require(tkn,T_IDENTIFIER);
X if (match("&aux"))
X break;
X addargument(&arguments,t_token);
X }
X
X /* check for temporary variable definitions */
X if (tkn == T_IDENTIFIER)
X while ((tkn = token()) != T_CLOSE) {
X require(tkn,T_IDENTIFIER);
X addargument(&temporaries,t_token);
X tcnt++;
X }
X
X /* store the code address */
X putword(curact+A_CODE,cptr);
X
X /* allocate space for temporaries */
X if (temporaries) {
X putcbyte(OP_TSPACE);
X putcbyte(tcnt);
X }
X
X /* compile the code */
X do_code(NULL);
X
X /* free the argument and temporary variable symbol tables */
X freelist(arguments);
X freelist(temporaries);
X arguments = temporaries = NULL;
X}
X
X/* setprop - set the value of a property */
Xsetprop(prop,flags,value)
X int prop,flags,value;
X{
X int i;
X
X /* look for the property */
X for (i = 0; i < nprops; i++)
X if ((objbuf[O_PROPERTIES/2 + i*2] & ~P_CLASS) == prop) {
X objbuf[O_PROPERTIES/2 + i*2 + 1] = value;
X return;
X }
X addprop(prop,flags,value);
X}
X
X/* addprop - add a property to the current object's property list */
Xaddprop(prop,flags,value)
X int prop,flags,value;
X{
X if (nprops >= OPMAX) {
X printf("too many properties for this object\n");
X return;
X }
X objbuf[O_PROPERTIES/2 + nprops*2] = prop|flags;
X objbuf[O_PROPERTIES/2 + nprops*2 + 1] = value;
X objbuf[O_NPROPERTIES/2] = ++nprops;
X}
X
X/* do_code - compile code for an expression */
Xint do_code(type)
X char *type;
X{
X int adr,tkn;
X
X if (type) printf("[ compiling %s code ]\n",type);
X adr = putcbyte(OP_PUSH);
X while ((tkn = token()) != T_CLOSE) {
X stoken(tkn);
X do_expr();
X }
X putcbyte(OP_RETURN);
X return (adr);
X}
X
X/* do_action - handle <ACTION ... > statement */
Xdo_action()
X{
X int tkn,act;
X
X /* get the action name */
X frequire(T_IDENTIFIER);
Xprintf("[ action: %s ]\n",t_token);
X
X /* create a new action */
X act = aenter(t_token);
X curact = atable[act] = dalloc(A_SIZE);
X putword(curact+A_VERBS,NIL);
X putword(curact+A_PREPOSITIONS,NIL);
X putbyte(curact+A_FLAG,def_flag);
X putbyte(curact+A_MASK,def_mask);
X putword(curact+A_CODE,NIL);
X
X /* process statements until end of file */
X while ((tkn = token()) == T_OPEN) {
X frequire(T_IDENTIFIER);
X if (match("actor"))
X do_flag(A_ACTOR);
X else if (match("verb"))
X do_verb();
X else if (match("direct-object"))
X do_flag(A_DOBJECT);
X else if (match("preposition"))
X do_preposition();
X else if (match("indirect-object"))
X do_flag(A_IOBJECT);
X else if (match("code"))
X putword(curact+A_CODE,do_code(NULL));
X else
X error("Unknown action definition statement type");
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_flag - handle ACTOR, DIRECT-OBJECT, and INDIRECT-OBJECT statements */
Xdo_flag(flag)
X int flag;
X{
X int tkn;
X
X if ((tkn = token()) == T_IDENTIFIER) {
X if (match("required")) {
X putbyte(curact+A_FLAG,getbyte(curact+A_FLAG) | flag);
X putbyte(curact+A_MASK,getbyte(curact+A_MASK) & ~flag);
X }
X else if (match("forbidden")) {
X putbyte(curact+A_FLAG,getbyte(curact+A_FLAG) & ~flag);
X putbyte(curact+A_MASK,getbyte(curact+A_MASK) & ~flag);
X }
X else if (match("optional"))
X putbyte(curact+A_MASK,getbyte(curact+A_MASK) | flag);
X else
X error("Expecting: REQUIRED, FORBIDDEN or OPTIONAL");
X tkn = token();
X }
X else {
X putbyte(curact+A_FLAG,getbyte(curact+A_FLAG) | flag);
X putbyte(curact+A_MASK,getbyte(curact+A_MASK) & ~flag);
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_verb - handle the <VERB ... > statement */
Xdo_verb()
X{
X int tkn,new,lst;
X
X while ((tkn = token()) == T_IDENTIFIER || tkn == T_OPEN) {
X new = dalloc(L_SIZE);
X putword(new+L_NEXT,getword(curact+A_VERBS));
X putword(curact+A_VERBS,new);
X lst = dalloc(L_SIZE);
X putword(lst+L_NEXT,NIL);
X putword(new+L_DATA,lst);
X if (tkn == T_IDENTIFIER)
X putword(lst+L_DATA,add_word(t_token,WT_VERB));
X else {
X if ((tkn = token()) == T_IDENTIFIER)
X putword(lst+L_DATA,add_word(t_token,WT_VERB));
X else
X error("Expecting verb");
X while ((tkn = token()) == T_IDENTIFIER) {
X new = dalloc(L_SIZE);
X putword(new+L_DATA,add_word(t_token,WT_UNKNOWN));
X putword(new+L_NEXT,NIL);
X putword(lst+L_NEXT,new);
X lst = new;
X }
X require(tkn,T_CLOSE);
X }
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_preposition - handle the <PREPOSITION ... > statement */
Xdo_preposition()
X{
X int tkn,new;
X
X while ((tkn = token()) == T_IDENTIFIER) {
X new = dalloc(L_SIZE);
X putword(new+L_DATA,add_word(t_token,WT_PREPOSITION));
X putword(new+L_NEXT,getword(curact+A_PREPOSITIONS));
X putword(curact+A_PREPOSITIONS,new);
X }
X require(tkn,T_CLOSE);
X}
X
X/* do_function - handle <DEFINE (FUN ...) ... > statement */
Xdo_function()
X{
X int tkn,act,tcnt;
X
X /* get the function name */
X frequire(T_IDENTIFIER);
Xprintf("[ function: %s ]\n",t_token);
X
X /* create a new action */
X act = aenter(t_token);
X
X /* initialize the action */
X curact = atable[act] = dalloc(A_SIZE);
X putword(curact+A_VERBS,NIL);
X putword(curact+A_PREPOSITIONS,NIL);
X arguments = temporaries = NULL;
X tcnt = 0;
X
X /* get the argument list */
X while ((tkn = token()) != T_CLOSE) {
X require(tkn,T_IDENTIFIER);
X if (match("&aux"))
X break;
X addargument(&arguments,t_token);
X }
X
X /* check for temporary variable definitions */
X if (tkn == T_IDENTIFIER)
X while ((tkn = token()) != T_CLOSE) {
X require(tkn,T_IDENTIFIER);
X addargument(&temporaries,t_token);
X tcnt++;
X }
X
X /* store the code address */
X putword(curact+A_CODE,cptr);
X
X /* allocate space for temporaries */
X if (temporaries) {
X putcbyte(OP_TSPACE);
X putcbyte(tcnt);
X }
X
X /* compile the code */
X do_code(NULL);
X
X /* free the argument and temporary variable symbol tables */
X freelist(arguments);
X freelist(temporaries);
X arguments = temporaries = NULL;
X}
X
X/* addargument - add a formal argument */
Xaddargument(list,name)
X ARGUMENT **list; char *name;
X{
X ARGUMENT *arg;
X
X if ((arg = (ARGUMENT *)malloc(sizeof(ARGUMENT))) == NULL)
X fail("out of memory");
X arg->arg_name = save(name);
X arg->arg_next = *list;
X *list = arg;
X}
X
X/* freelist - free a list of arguments or temporaries */
Xfreelist(arg)
X ARGUMENT *arg;
X{
X ARGUMENT *nxt;
X
X while (arg) {
X nxt = arg->arg_next;
X free(arg->arg_name);
X free(arg);
X arg = nxt;
X }
X}
X
X/* findarg - find an argument offset */
Xint findarg(name)
X char *name;
X{
X ARGUMENT *arg;
X int n;
X
X for (n = 0, arg = arguments; arg; n++, arg = arg->arg_next)
X if (strcmp(name,arg->arg_name) == 0)
X return (n);
X return (-1);
X}
X
X/* findtmp - find a temporary variable offset */
Xint findtmp(name)
X char *name;
X{
X ARGUMENT *tmp;
X int n;
X
X for (n = 0, tmp = temporaries; tmp; n++, tmp = tmp->arg_next)
X if (strcmp(name,tmp->arg_name) == 0)
X return (n);
X return (-1);
X}
X
X
END_OF_advfcn.c
if test 13701 -ne `wc -c <advfcn.c`; then
echo shar: \"advfcn.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f objects.adi -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"objects.adi\"
else
echo shar: Extracting \"objects.adi\" \(12513 characters\)
sed "s/^X//" >objects.adi <<'END_OF_objects.adi'
X
X; This is the object-oriented runtime package
X; by David Betz
X; July 19, 1986
X
X; ********************
X; PROPERTY DEFINITIONS
X; ********************
X
X; These properties will be used for connections between locations
X(property
X north ; the location to the north
X south ; the location to the south
X east ; the location to the east
X west ; the location to the west
X up ; the location above
X down) ; the location below
X
X; Basic object properties
X(property
X initial-location ; the initial location of a "thing"
X description ; the "long" description of a location
X short-description) ; the "short" description of a location
X
X; Connection properties
X(property
X parent ; the parent of an object
X sibling ; the next sibling of an object
X child) ; the first child of an object
X
X; Location properties
X(property
X visited) ; true if location has been visited by player
X
X; Portal properties
X(property
X closed ; true if the portal is closed
X locked ; true if the portal is locked
X key ; key to unlock the portal
X other-side) ; the other portal in a pair
X
X; **********************
X; VOCABULARY DEFINITIONS
X; **********************
X
X; Some abbreviations for common commands
X(synonym north n)
X(synonym south s)
X(synonym east e)
X(synonym west w)
X(synonym inventory i)
X
X; Define the basic vocabulary
X(conjunction and)
X(article the that)
X
X; ********************
X; VARIABLE DEFINITIONS
X; ********************
X
X(variable
X curloc ; the location of the player character
X %actor ; the actor object
X %dobject ; the direct object
X %iobject) ; the indirect object
X
X; *********************
X; CONNECTION PRIMITIVES
X; *********************
X
X; Connect an object to a parent
X(define (connect p c)
X (setp c parent p)
X (setp c sibling (getp p child))
X (setp p child c))
X
X; Connect all objects to their initial parents
X(define (connect-all &aux obj maxp1 par)
X (setq obj 1)
X (setq maxp1 (+ $ocount 1))
X (while (< obj maxp1)
X (if (setq par (getp obj initial-location))
X (connect par obj))
X (setq obj (+ obj 1))))
X
X; Disconnect an object from its current parent
X(define (disconnect obj &aux this prev)
X (setq this (getp (getp obj parent) child))
X (setq prev nil)
X (while this
X (if (= this obj)
X (progn
X (if prev
X (setp prev sibling (getp this sibling))
X (setp (getp this parent) child (getp this sibling)))
X (setp this parent nil)
X (return)))
X (setq prev this)
X (setq this (getp this sibling))))
X
X; Print the contents of an object (used by "look")
X(define (print-contents obj prop &aux desc)
X (setq obj (getp obj child))
X (while obj
X (if (setq desc (getp obj prop))
X (progn
X (print " ")
X (print desc)))
X (setq obj (getp obj sibling))))
X
X; List the contents of an object (used for "inventory")
X(define (list-contents obj prop &aux desc)
X (setq obj (getp obj child))
X (while obj
X (if (setq desc (getp obj prop))
X (progn
X (print "\t")
X (print desc)
X (terpri)))
X (setq obj (getp obj sibling))))
X
X; ************************
X; OBJECT CLASS DEFINITIONS
X; ************************
X
X; ***********************
X; The "basic-thing" class
X; ***********************
X
X(object basic-thing
X (property
X parent nil ; the parent of this object
X sibling nil)) ; the next sibling of this object
X
X; ***************************
X; The "location" object class
X; ***************************
X
X(object location
X (property
X child nil ; the first object in this location
X visited nil) ; has the player been here yet?
X (method (knock? obj)
X T)
X (method (enter obj)
X (connect self obj)
X T)
X (method (leave obj dir &aux loc)
X (if (setq loc (getp self dir))
X (if (send loc knock? obj)
X (progn
X (disconnect obj)
X (send loc enter obj)))
X (progn
X (print "There is no exit in that direction.\n")
X nil)))
X (method (describe)
X (if (getp self visited)
X (print (getp self short-description))
X (progn
X (print (getp self description))
X (print-contents self description)
X (setp self visited t)))
X (terpri)))
X
X
X; ******************
X; The "portal" class
X; ******************
X
X(basic-thing portal
X (method (knock? obj)
X (if (getp self closed)
X (progn
X (print "The ")
X (print (getp self short-description))
X (print " is closed!\n")
X nil)
X T))
X (method (enter obj)
X (connect (getp (getp self other-side) parent) obj))
X (method (open)
X (if (not (getp self closed))
X (progn
X (print "The ")
X (print (getp self short-description))
X (print " is already open!\n")
X nil)
X (if (getp self locked)
X (progn
X (print "The ")
X (print (getp self short-description))
X (print " is locked!\n")
X nil)
X (progn
X (setp self closed nil)
X T))))
X (method (close)
X (if (getp self closed)
X (progn
X (print "The ")
X (print (getp self short-description))
X (print " is already closed!\n")
X nil)
X (progn
X (setp self closed T)
X T)))
X (method (lock thekey)
X (if (not (getp self closed))
X (progn
X (print "The ")
X (print (getp self short-description))
X (print " is not closed!\n")
X nil)
X (if (getp self locked)
X (progn
X (print "The ")
X (print (getp self short-description))
X (print " is already locked!\n")
X nil)
X (if (not (= thekey (getp self key)))
X (progn
X (print "It doesn't fit the lock!\n")
X nil)
X (progn
X (setp self locked t)
X T)))))
X (method (unlock thekey)
X (if (not (getp self closed))
X (progn
X (print "The ")
X (print (getp self short-description))
X (print " is already open!\n")
X nil)
X (if (not (getp self locked))
X (progn
X (print "The ")
X (print (getp self short-description))
X (print " is not locked!\n")
X nil)
X (if (not (= thekey (getp self key)))
X (progn
X (print "It doesn't fit the lock!\n")
X nil)
X (progn
X (setp self locked nil)
X T))))))
X
X; *****************
X; The "actor" class
X; *****************
X
X(basic-thing actor
X (property
X child nil) ; the first "thing" carried by this actor
X (method (move dir)
X (send (getp self parent) leave self dir))
X (method (take obj)
X (disconnect obj)
X (connect self obj))
X (method (drop obj)
X (disconnect obj)
X (connect (getp self parent) obj))
X (method (carrying? obj)
X (= (getp obj parent) self))
X (method (inventory)
X (cond ((getp %actor child)
X (print "You are carrying:\n")
X (list-contents %actor short-description))
X (T (print "You are empty-handed.\n")))))
X
X; *****************
X; The "thing" class (things that can be taken)
X; *****************
X
X(basic-thing thing
X (class-property
X takeable t))
X
X; ****************************
X; The "stationary-thing" class (things that can't be moved)
X; ****************************
X
X(basic-thing stationary-thing)
X
X; ***********************
X; MISCELLANEOUS FUNCTIONS
X; ***********************
X
X; Complain about a noun phrase
X(define (complain head n tail)
X (print head)
X (print-noun n)
X (print tail)
X (abort))
X
X; Find an object in a location
X(define (findobject loc n &aux this found)
X (setq this (getp loc child))
X (setq found nil)
X (while this
X (if (match this n)
X (if found
X (complain "I don't know which " n " you mean!\n")
X (setq found this)))
X (setq this (getp this sibling)))
X found)
X
X; Find an object in the player's current location
X; (or in the player's inventory)
X(define (in-location n &aux obj)
X (if (or (setq obj (findobject curloc n))
X (setq obj (findobject %actor n)))
X obj
X (complain "I don't see a " n " here!\n")))
X
X; Find an object in the player's inventory
X; (or in the player's current location)
X(define (in-pocket n &aux obj)
X (if (or (setq obj (findobject %actor n))
X (setq obj (findobject curloc n)))
X obj
X (complain "You don't have a " n "!\n")))
X
X; ***************
X; ACTION DEFAULTS
X; ***************
X
X(default
X (actor optional))
X
X; ******************
X; ACTION DEFINITIONS
X; ******************
X
X(action look
X (verb look)
X (code
X (setp curloc visited nil)
X (send curloc describe)))
X
X(action a-take
X (verb take get (pick up))
X (direct-object)
X (code
X (setq %dobject (in-location $dobject))
X (if (getp %dobject takeable)
X (progn
X (if (send %actor carrying? %dobject)
X (complain "You are already carrying the " $dobject "!\n"))
X (send %actor take %dobject)
X (print-noun $dobject)
X (print " taken.\n"))
X (complain "You can't take the " $dobject "!\n"))))
X
X(action take-err
X (verb take get (pick up))
X (code
X (print "Take what?\n")))
X
X(action a-drop
X (verb drop (put down))
X (direct-object)
X (code
X (setq %dobject (in-pocket $dobject))
X (if (send %actor carrying? %dobject)
X (progn
X (send %actor drop %dobject)
X (print-noun $dobject)
X (print " dropped.\n"))
X (complain "You aren't carrying the " $dobject "!\n"))))
X
X(action drop-err
X (verb drop (put down))
X (code
X (print "Drop what?\n")))
X
X(action give
X (verb give)
X (direct-object)
X (preposition to)
X (indirect-object)
X (code
X (setq %dobject (in-pocket $dobject))
X (setq %iobject (in-location $iobject))
X (if (send %actor carrying? %dobject)
X (progn
X (send %actor drop %dobject)
X (send %iobject take %dobject)
X (print-noun $dobject)
X (print " given.\n"))
X (complain "You aren't carrying the " $dobject "!\n"))))
X
X(action give-err
X (verb give)
X (direct-object optional)
X (code
X (if $dobject
X (complain "Give the " $dobject " to who?\n"))
X (print "Give what?\n")))
X
X(action a-inventory
X (verb inventory)
X (code
X (send %actor inventory)))
X
X; ***************
X; PORTAL COMMANDS
X; ***************
X
X(action a-open
X (verb open)
X (direct-object)
X (code
X (setq %dobject (in-location $dobject))
X (send %dobject open)))
X
X(action open-err
X (verb open)
X (code
X (print "Open what?\n")))
X
X(action a-close
X (verb close)
X (direct-object)
X (code
X (setq %dobject (in-location $dobject))
X (send %dobject close)))
X
X(action close-err
X (verb close)
X (code
X (print "Close what?\n")))
X
X(action a-lock
X (verb lock)
X (direct-object)
X (preposition with)
X (indirect-object)
X (code
X (setq %dobject (in-location $dobject))
X (setq %iobject (in-pocket $iobject))
X (send %dobject lock %iobject)))
X
X(action lock-err
X (verb lock)
X (direct-object optional)
X (code
X (if $dobject
X (complain "Lock the " $dobject " with what?\n"))
X (print "Lock what?\n")))
X
X(action a-unlock
X (verb unlock)
X (direct-object)
X (preposition with)
X (indirect-object)
X (code
X (setq %dobject (in-location $dobject))
X (setq %iobject (in-pocket $iobject))
X (send %dobject unlock %iobject)))
X
X(action unlock-err
X (verb unlock)
X (direct-object optional)
X (code
X (if $dobject
X (complain "Unlock the " $dobject " with what?\n"))
X (print "Unlock what?\n")))
X
X; *********************
X; GAME CONTROL COMMANDS
X; *********************
X
X(action save
X (verb save)
X (code
X (save)))
X
X(action restore
X (verb restore)
X (code
X (restore)))
X
X(action restart
X (verb restart)
X (code
X (restart)))
X
X(action quit
X (verb quit)
X (code
X (print "Are you sure you want to quit? ")
X (if (yes-or-no)
X (exit))))
X
X; **************
X; TRAVEL ACTIONS
X; **************
X
X(action go-north
X (verb north (go north))
X (code
X (send %actor move north)))
X
X(action go-south
X (verb south (go south))
X (code
X (send %actor move south)))
X
X(action go-east
X (verb east (go east))
X (code
X (send %actor move east)))
X
X(action go-west
X (verb west (go west))
X (code
X (send %actor move west)))
X
X(action go-up
X (verb up (go up))
X (code
X (send %actor move up)))
X
X(action go-down
X (verb down (go down))
X (code
X (send %actor move down)))
X
X; *******************
X; HANDLER DEFINITIONS
X; *******************
X
X(init
X (connect-all)
X (print welcome)
X (setq curloc nil))
X
X(update
X (if (not (= (getp adventurer parent) curloc))
X (progn
X (setq curloc (getp adventurer parent))
X (send curloc describe))))
X
X(before
X (setq %actor adventurer)
X (if $actor
X (progn
X (setq %actor (in-location $actor))
X (if (not (= (class %actor) actor))
X (complain "You can't talk to a " $actor "!\n")))))
X
X
X
X
END_OF_objects.adi
if test 12513 -ne `wc -c <objects.adi`; then
echo shar: \"objects.adi\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f osample.adv -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"osample.adv\"
else
echo shar: Extracting \"osample.adv\" \(4207 characters\)
sed "s/^X//" >osample.adv <<'END_OF_osample.adv'
X
X; SAMPLE.ADV
X;
X; This is a VERY simple sample adventure that uses the "BASIC.ADI" simple
X; runtime support code. It isn't interesting to play, but does illustrate
X; most of the features of the adventure authoring system. Try compiling
X; it using the command:
X;
X; A>ADVCOM SAMPLE
X;
X; When the compile has finished, run the adventure using the command:
X;
X; A>ADVINT SAMPLE
X;
X; You should then see the initial welcome message and a description of
X; your initial location. You can use the direction names to move from
X; one location to the next (or the abreviations N,S,E,W). You should try
X; manipulating objects using TAKE and DROP. You can manipulate more than
X; one at a time by using the conjunction AND. You can also GIVE an object
X; to another creature like the DOG or CAT. You can instruct another
X; creature to perform an action like:
X;
X; CAT, GIVE THE DOG THE KEY
X;
X; You can also experiment with using adjectives to distinguish between
X; objects (there is more than one KEY in this adventure).
X
X(adventure sample 1)
X
X(define welcome "Welcome to the sample adventure.\n")
X
X@objects.adi
X
X(actor adventurer
X (noun me)
X (property
X initial-location livingroom))
X
X(actor dog
X (noun dog)
X (adjective small)
X (property
X description "There is a small dog here."
X short-description "a small dog"
X initial-location kitchen))
X
X(actor cat
X (noun cat)
X (property
X description "There is a cat here."
X short-description "a cat"
X initial-location kitchen))
X
X(location storage-room
X (property
X description "You are in a small storage room with many empty shelves.
X The only exit is a door to the west."
X short-description "You are in the storage room."
X west hallway)
X (method (leave obj dir)
X (if (send obj carrying? rusty-key)
X (send-super leave obj dir)
X (print "You seem to be missing something!\n"))))
X
X(location hallway
X (property
X description "You are in a long narrow hallway. There is a door to the
X east into a small dark room. There are also exits on both
X the north and south ends of the hall."
X short-description "You are in the hallway."
X east storage-room
X north kitchen
X south livingroom))
X
X(location kitchen
X (property
X description "This is a rather dusty kitchen. There is a hallway to the
X south and a pantry to the west."
X short-description "You are in the kitchen."
X south hallway
X west pantry))
X
X(location pantry
X (property
X description "This is the kitchen pantry. The kitchen is through a
X doorway to the east."
X short-description "You are in the pantry."
X east kitchen))
X
X(location livingroom
X (property
X description "This appears to be the livingroom. There is a hallway to
X the north and a closet to the west."
X short-description "You are in the livingroom."
X north hallway
X west closet
X south front-door-1))
X
X(location outside
X (property
X description "You are outside a small house. The front door is to the
X north."
X short-description "You are outside."
X north front-door-2))
X
X(portal front-door
X (noun door)
X (adjective front)
X (class-property
X short-description "front door"
X closed t
X locked t
X key rusty-key))
X
X(front-door front-door-1
X (property
X initial-location livingroom
X other-side front-door-2))
X
X(front-door front-door-2
X (property
X initial-location outside
X other-side front-door-1))
X
X(location closet
X (property
X description "This is the livingroom closet. The livingroom is through
X a doorway to the east."
X short-description "You are in the closet."
X east livingroom))
X
X(thing rusty-key
X (noun key)
X (adjective rusty)
X (property
X description "There is a rusty key here."
X short-description "a rusty key"
X initial-location storage-room))
X
X(thing silver-key
X (noun key)
X (adjective small silver)
X (property
X description "There is a small silver key here."
X short-description "a small silver key"
X initial-location closet))
X
X
X
END_OF_osample.adv
if test 4207 -ne `wc -c <osample.adv`; then
echo shar: \"osample.adv\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 2 \(of 3\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 3 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 3 archives.
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.stoken
X