uyydyBtytotz (*$L'MILIEU - MULTI USER ROLE PLAY GAME.',L'DECLARATIONS AND VARIABLES'*)
(*$A+,E+,P-,T-,R- *)
(*[E=3,I=1,B+,S=2,L=2,W1-85] FOR SPRUCE. *)
(* N O T E - LIST THIS SOURCE WHILE IN CSET(NORMAL). DO NOT
REPEAT *DO NOT* LIST THIS SOURCE USING CSET(ASCII). CERTAIN
CHARACTERS SUCH AS POINTERS (^) WILL DISAPPEAR FROM THE LISTING
IF YOU LIST UNDER CSET(ASCII). *)
(*$B5 SET OUTPUT BUFFER LARGE *)
PROGRAM MILIEU(OUTPUT +);
(*$B1 RESET BUFFER LENGTH TO 129D WORDS *)
(* MILIEU - INTERACTIVE ADVENTURE SIMULATION PROGRAM.
A. E. KLIETZ 79/07/13., 82/03/10., 83/03/03.
COPYRIGHT (C) 1979, 1981, 1982, 1983 A.E.KLIETZ. ALL RIGHTS RESERVED.
MILIEU IS AN INTERACTIVE ROLE-PLAY GAME. IT LETS YOU, THE
USER, INVOLVE YOURSELF WITH OTHER USERS IN A SIMULATED WORLD
OF TOWNS, DUNGEONS, CASTLES AND WILDERNESS. INTERACTION WITH OTHER
PLAYERS IS TOTAL -- ALLOWING YOU TO TALK, TRADE WITH, AND EVEN
FIGHT IN HAND-HAND COMBAT WITH OTHER PLAYERS. THE "WORLD" IS STOCKED
WITH A WIDE ARRAY OF "NON-PLAYER CHARACTERS": COMPUTER CONTROLLED
CREATURES, BARTENDERS, SOLDIERS, ETC. IN ORDER TO ADD A BIT
OF SPICE TO YOUR PLAY, DIFFICULT TRIALS AND CHALLENGES ARE BUILT
INTO THE WORLD... WIZARDS TO OVERTHROW, SOLDIERS TO AVOID. THE
ACTUAL ENCOUNTERS CAN BE CHANGED AROUND EASILY BY THE USE OF A
SPECIAL "EDITOR". THE EDITOR CAN MODIFY ANY PART OF THE DATABASE,
EVEN WHILE THE GAME IS IN PROGRESS!
THE PROGRAM ITSELF IS WRITTEN IN PASCAL-6000, WITH SOME
COMPASS SUBROUTINES ADDED FOR INTERFACING WITH NOS. THE PROGRAM
TAKES ADVANTAGE OF THE MULTI OPERATING SYSTEM BY DIRECTLY TALKING
TO THE SUBCONTROL-POINT VIA TEXT CONTROL WORDS. A SPECIAL PASCAL
COMPILER IS NOT NEEDED SINCE THE PROGRAM ITSELF DOES ALL THE
EXTRA WORK NEEDED FOR MULTI.
MILIEU IS A SEGMENTED PROGRAM. THAT IS, ONLY CERTAIN PARTS
OF THE PROGRAM ARE ACTUALLY IN MEMORY AT ANY GIVEN TIME. THE
LIST OF SEGMENTS IS STORED IN A LIBRARY *ABS*. THEY ARE AUTOMATICALLY
FETCHED AS NEEDED, AND ERASED WHEN NO LONGER IN USE.
DISPITE THE MULTI USER ENVIRONMENT, MILIEU CONTAINS ALL THE
FEATURES USED IN STANDARD PASCAL, INCLUDING RECURSION AND DYNAMIC
MEMORY ALLOCATION.
EVERY USER ASSOCIATED WITH THE TASK HAS A DATA RECORD. THIS
RECORD CONTAINS THE USER'S TERMINAL NUMBER AND THE ADDRESS
OF THE NEXT ENTRY POINT IN THE PROGRAM THAT THE USER WILL RUN
WHEN HE IS ROLLED IN. THE RECORD LIST IS STORED DYNAMICALLY, WITH
RECORDS BEING CREATED AND DISPOSED OF AS USERS LOG IN AND OUT.
*)
LABEL
(*$E'RESTART' *)
1;
(* THE RESTART LABEL IS THE RE-ENTRY POINT FOR THE PROGRAM. THE
PROGRAM JUMPS HERE AFTER THE SNAPSHOT DUMP. *)
CONST
BOOTLEN = 7700B (* LENGTH OF BOOT SEGMENT *);
(* THE FOLLOWING IS A LIST OF DEFINITIONS FOR MULTI CONTROL WORDS.
THESE TWO CHARACTER STRINGS PREFACE ALL OUTPUT FROM THIS PROGRAM.
NOTE THAT THE *MTXT* CONTROL WORD EQUALS 4000B OCTAL, OR "5:"
IN THE CHARACTER SET. *)
MTXT = '5
MTLI = 1B;
MTLO = 'PB';
MTHU = 3B;
MTNT = 4B;
MTIN = 'PE';
MTAK = 'PF';
MTRN = 'PG';
MTAN = 10B;
MTRC = 11B;
BLANKS = ' ';
QUITWAIT = 20 (*MIN # OF SECS TO WAIT BEFORE QUITTING AFTER ATK*);
HEALWAIT = 30 (* # OF SECS TO INCREASE MP/HP OF USER*);
UPDATEPERIOD = 3600 (* # OF SECS BETWEEN FILE UPDATES. 60MIN*);
EMPTY = 'ZZZEMPTY ' (* EMPTY PERSON SECTOR *);
ABSOLUTEPLMAX = 210 (* MAX # OF USERS IN FILE *);
MAXOBJS = 6 (* MAX # OF OBJECTS STORED/PERSON *);
MAXLOGLEN = 128 (* MAX NUMBER OF U/L CHARACTERS *);
MAXBUFLEN = 257 (* MAXLOGLEN * 2 + 1 PHYSICAL BUFFER *);
VERSION = '2.4.1PUBLIC B^O^L^D^H^O^L^M V^I^L^L^A^G^E ';
MAXUSERS = 25 (*MAX NUMBER OF USERS*);
MAXPLUSONE = 26 (* MAXUSERS + 1 *);
RMLIMIT = 259 (* MAXUSERS * 10 + 9 *);
MAXQUEUE = 15 (* MAX USERS IN WAITING QUEUE *);
ORIGINUN = 'GWAKIM6';
AUTHOR = 'MORDOR ';
MAXNAMES = 40 (*MAX # OF ITEMS IN A ROOM FOR PARSING*);
CMDLISTLEN = 112 (*NUMBER OF COMMANDS*);
SPELLEN = 17;
LENCOUNTER = 18;
OBJLISTLEN = 16;
RANMONLEN = 100;
RANOBJLEN = 78;
MAXSEGS = 199 (* 10 ROOMS PER SEGMENT = 2000 ROOMS *);
RESPONDLIMIT = 60 (* SECS TO RESPOND TO PROMPT *);
LENEVENT = 21 (*NUMBER OF EVENTS IN THE CIRCULAR QUEUE *);
DAYRECLEN = 6 (* 6 RECORDS STORED IN DAYFILE *);
(* ZEROPARM = SIX BYTES OF ZEROS *)
VAR
TASKNAM: ALFA7;
USER: USERPOINT;
BOOTSEG: INTFILE (* BINARY OVL + SEGFILE *);
ILOOP: INTEGER (*LOOP VAR FOR STORING BOOTSEG DATA*);
EPERSON: BINFILETYPE (*PERSON FILE*);
DAYFILE: SEGCHARFIL (* GAME DAYFILE *);
(* GLOBAL VARIABLES *)
(*THE FOLLOWING VARIABLES ARE PART OF THE MULTI CONTROL WORD.
FOR SIMPLICITY'S SAKE, THEY ARE MADE INTO GLOBAL PARAMETERS
RATHER THAN FORMAL PASSED PARAMETERS. *)
TERM: ALFA (* TERMINAL NUMBER FOR I/O. USED EVERYWHERE *);
INPUT: INPUTTYPE (* SPECIAL INPUT FILE WITH BIG BUFFER *);
CURRENTREC: INTEGER (* CURRENT RECORD OF EDESC FILE *);
CURRENTLINE: INTEGER (* CURRENT LINE OF EDESC FILE *);
LASTUPDATE: INTEGER (* LAST POSTING OF DATA FILES *);
RA: INTEGER (* COUNT OF RA+1 REQUESTS SINCE LAST READ *);
(* THE FOLLOWING ARE PSUEDO CONSTANTS. THESE ARE FUNDAMENTAL
VALUES WHICH ARE INITIALIZED AT THE BEGINNING OF THE PROGRAM. *)
ZEROPARM: PARMBLOCK (* = NULL BLOCK. 000000000000B *);
FIST, DEADBODY: OBJECTTYPE (* DEAD PLAYER "OBJECT *);
CNAME: ARRAY [CHTYPE] OF ALFA (* CHARACTER TYPES *);
TODAY: INTEGER (* DAY OF MONTH FOR FILE EXPIRATION *);
DAY, SYSDATE: INTEGER (* DAY OF WEEK, SYSTEM PDATE *);
NTH: ARRAY [0..20] OF ALFA (* WORD VALUE OF #'S 0-20 *);
NUMSTRING: ARRAY [0..20] OF ALFA (*NUMBERS SPELLED IN WORDS*);
DIRLIST: PACKED ARRAY [1..7] OF ALFA;
CMDLIST: CMDTYPELIST (* TABLE OF ALL COMMANDS *);
CMDNUM: CMDNUMTYPE (* HASH CODE FOR COMMANDS *);
SPELLIST: ARRAY [0.. SPELLEN] OF ALFA;
SPELLCLASS: PACKED ARRAY [0.. SPELLEN] OF SPELLTYPE;
ENCOUNTERINDEX: PACKED ARRAY [1.. LENCOUNTER, 1..6] OF 0..200;
OBJINDEX: PACKED ARRAY [1.. OBJLISTLEN, 1..6] OF 0..200;
EDITLIST: EDITTYPELIST (* DO NOT CHANGE THE ORDER OF THIS LIST! *);
PROTOUSER: USERTYPE (*DEFAULT STATS*);
PROTOMONSTER: MONSTERTYPE (*DEFAULT STATS*);
PROTOOBJECT: OBJECTTYPE;
PROTOROOM: ROOMTYPE;
(* POINTER TAILS. THESE ARE THE BEGINNINGS OF LINKED LISTS.
THE TAILS POINT TO THE FIRST VALUE IN THE LIST. IN A SENSE, THE
TAILS ARE ENTRY POINTS TO THE LISTS, AND ARE USED AS SUCH. *)
USERTAIL: USERPOINT;
(* SYSTEM-WIDE VARIABLES. THESE ARE GLOBAL VARIABLES*)
NUSERS: INTEGER (* # OF ACTIVE USERS*);
REALTIME: INTEGER (*CURRENT TIME IN SECS*);
CLOCKTIME: ALFA (*CURRENT TIME IN CLOCK FORMAT*);
NEXTCHECK: ALFA (*TIME OF NEXT TIMED-EVENT*);
EVENT: ARRAY [1.. LENEVENT] OF ALFA (*EVENT QUEUE*);
FIRSTLOGIN: BOOLEAN (* FLAG SET WHILE INITIALIZING *);
TASKCLOSED: CHAR (* FLAG SET TO 'C' IF CLOSED *);
ERRFLAG: INTEGER (* ERROR TRAP FLAG. =0 IF INHIBIT ERROR TRAP *);
MSPEED: INTEGER;
NUMRUN: INTEGER (* NUMBER OF TIMES TASK TAKEN UP *);
NOTICE: PACKED ARRAY [1..80] OF CHAR (*CURRENT PROGRAM NOTICE*);
MONPARMLIST: PACKED ARRAY [1..26] OF PARAMETERS;
OBJPARMLIST: PACKED ARRAY [1..33] OF PARAMETERS;
RMPARMLIST: PACKED ARRAY [1..13] OF PARAMETERS;
USRPARMLIST: PACKED ARRAY [1..42] OF PARAMETERS;
ERRLOC: ALFA;
UNACTIVE: ARRAY [1.. MAXPLUSONE] OF PACKED RECORD
OFFTERM: ALFA;
OFFTIME: TIMETYPE;
END;
UNACLOC: INTEGER;
QUEUE: PACKED ARRAY [1.. MAXQUEUE] OF PACKED RECORD
QTERM: ALFA;
QUN: ALFA7;
QTIME: TIMETYPE
END;
NUMQUEUED: INTEGER;
HELLFREEZESOVER: BOOLEAN;
NORESTART: ALFA;
PRO: ARRAY[MALE..FEMALE] OF PACKED ARRAY [1..3] OF CHAR;
BADUN: ALFA7 (* UN BLOCKED OFF DUE TO PW GUESSING *);
BADCOUNT: INTEGER (* NUMBER OF PW GUESSES *);
BEGIN MESSAGE('COPYRIGHT (C) 1983 A. KLIETZ.'); END (*HEADER*);
PROCEDURE ABORT(STRING: DYNAMIC ALFA);
(* FORCE AN ERROR IN THE PROGRAM *)
BEGIN
MESSAGE(STRING);
IF USER <> NIL
THEN
IF USER ^.NAME <> EMPTY
THEN
BEGIN
MESSAGE('PLAYER WHO CAUSED PTA IS:'); MESSAGE(USER ^.NAME);
WRITELN(DAYFILE, CLOCKTIME, ' PLAYER WHO CAUSED PTA IS: ', USER ^.NAME)
END (*IF*);
WRITELN(DAYFILE, CLOCKTIME, ' ', STRING); HALT
END (*ABORT*);
PROCEDURE MULTIO;
(* THIS IS THE MAIN LOOP OF MILIEU. ALL ROUTINES CONTAINED
HEREIN ARE EXCLUSIVELY FOR MILIEU. THE ABOVE ROUTINES ARE
GENERAL UTILITIES ONLY; THE FOLLOW ROUTINES ARE MORE SPECIFIC
TO THE PROGRAM *)
TYPE
PLINDEXTYPE = 1.. ABSOLUTEPLMAX (* LENGTH OF HASH INDEX FOR PERSON FILE *);
NAMETYPELIST = ARRAY [1.. MAXNAMES] OF ALFA;
VAR
ROOM: ROOMLIST (*DUNGEON MAP*);
TERMLIST: TERMTYPELIST (*LIST OF TERMINAL #'S TO SENT MSGS TO*);
EMAP, EROOM, EROOM2: BINFILETYPE (*DUNGEON FILES*);
EDESC: SEGCHARFIL (*DESCRIPTION FILE*);
BUFFER: BUFTYPE (* INPUT BUFFER *);
LOGLEN: LOGLENTYPE;
LENBUF: LENBUFTYPE;
CONTROL: BYTE (* CONTROL WORD *);
PARM: PARMBLOCK;
WHICHCONTROL: INTEGER;
PLAYERINDEX: ARRAY [PLINDEXTYPE] OF ALFA (*LIST OF STORED PLAYERS*);
CURRENTPLINDEX: 0.. ABSOLUTEPLMAX;
LOC: INTEGER (* LOCATION OF GETWORD POINTER *);
NUM: INTEGER (* KLUDGE PATCH: MONSTER INDEX # *);
CMDCODE: INTEGER (* COMMAND NUMBER *);
RANMONLIST: PACKED ARRAY [1.. RANMONLEN] OF MONSTERTYPE;
RANOBJLIST: PACKED ARRAY [1.. RANOBJLEN] OF OBJECTTYPE;
TNAME, YNAME, TCLASS, YCLASS: ARRAY [1..3] OF ALFA;
TLVL, YLVL: ARRAY [1..3] OF INTEGER;
TBUF, YBUF: PACKED ARRAY [1..3, 1..80] OF CHAR;
NEWSBUF: PACKED ARRAY [1..5, 1..80] OF CHAR;
TRADETIME, FCASH, TCASH: INTEGER;
NFPLYR, NTPLYR, NFOBJ, NTOBJ: ALFA;
SFOBJ, STOBJ: ALFA20;
RMSEGLOC: PACKED ARRAY [0.. MAXSEGS] OF 0..1000;
NUMSEGS: INTEGER (* # OF SEGS *);
CURRENTSEG: INTEGER (* CURRENT LOC OF EMAP *);
EOFSEG: INTEGER (* EOF, LAST SEG + 1 *);
SLOTTBL: ARRAY [0.. MAXPLUSONE] OF INTEGER;
ACTIVE: ARRAY [0.. MAXPLUSONE] OF INTEGER;
NUMROOMS: RMCODETYPE;
ACTIVEFLAG: INTEGER (* FLAG INACTIVE PORT ERR *);
NOPROMPT: BOOLEAN;
CURRENTDUM: 0..2 (*SELECT EROOMS FILE NONE, 1, 2*);
LIMBOINDEX: INTEGER;
PROCEDURE SETPFM(VAR F: BINFILETYPE; PFM, UN, PW: ALFA7);
EXTERN;
BEGIN
IF SELECTDUN = 1
THEN
BEGIN
OPENDFIL(EROOM, 'DUNJON1 ', WFLAG);
SETPFM(EROOM, 'DUNJON1', ORIGINUN, FILEPW);
OPENDFIL(EROOM2, 'DUNJON2 ', FALSE);
SETPFM(EROOM2, 'DUNJON2', ORIGINUN, FILEPW)
END (*IF*)
ELSE
IF SELECTDUN = 2
THEN
BEGIN
OPENDFIL(EROOM, 'DUNJON2 ', WFLAG);
SETPFM(EROOM, 'DUNJON2', ORIGINUN, FILEPW);
OPENDFIL(EROOM2, 'DUNJON1 ', FALSE);
SETPFM(EROOM2, 'DUNJON1', ORIGINUN, FILEPW)
END (*IF*);
SAVDFILE(EROOM, 2, 2); SAVDFILE(EROOM2, 2, 3);
IF WFLAG THEN REWRITE(EROOM) ELSE RESET(EROOM);
END (*SWITCH*);
FUNCTION SUBSET(PART, FULL: ALFA): BOOLEAN;
(* SUBSET RETURNS THE VALUE TRUE IF THE STRING "PART" IS
IDENTICAL TO THE BEGINNING OF "FULL". EXAMPLE: "VASE" IS
A SUBSET OF "VASELINE".*)
VAR
I: - 10..11;
BEGIN
SUBSET := TRUE (* DEFAULT *); I := 1;
WHILE (I >= 1) AND (I <= 10) DO
IF PART[I] = FULL[I] THEN I := I + 1 ELSE I := - I (* FLAG MISMATCH *);
IF I < 0 THEN SUBSET := (PART[- I] = ' ')
END (*SUBSET*);
PROCEDURE ODESTROY(VAR CONT: OBJECTPOINT);
VAR
OBJ: OBJECTPOINT;
BEGIN
IF CONT ^.OBCLASS = CHEST
THEN
WHILE CONT ^.OBJECTTAIL <> NIL DO
BEGIN
OBJ := CONT ^.OBJECTTAIL; CONT ^.OBJECTTAIL := CONT ^.OBJECTTAIL ^.NEXT;
ODESTROY(OBJ)
END (*WHILE*);
DISPOSE(CONT); CONT := NIL
END (*ODESTROY*);
FUNCTION PM(MON: MONSTERPOINT): CHAR;
(* PRINTMONSTER WILL WRITE OUT THE NAME OF A MONSTER. IF THERE
IS MORE THAN ONE MONSTER IN THE ROOM, THEN A MONSTER'S NUMBER IS
RETURNED IN THE FORM "RAT #3", "JACKAL #5", ETC. *)
VAR
SINGLE: BOOLEAN;
BEGIN
SINGLE := MON ^.TOP AND (MON ^.NUM = 1); IF SINGLE THEN WRITE('THE ');
WRITE(PS(MON ^.NAME)) (* WRITE MONSTER'S NAME. *);
IF NOT SINGLE THEN WRITE(' #', MON ^.NUM: 0) (* WRITE OUT MONSTER # *);
PM := ' ' (* RETURN DUMMY SPACE *)
END (*PM*);
FUNCTION SEARCHPLINDEX(NAME: ALFA): INTEGER;
(* SEARCHPLINDEX LOOKS THROUGH *PLAYERINDEX* TO SEE IF A USER IS
ALREADY LOGGED IN. IF SO, THE INDEX # IS RETURNED. IF NOT, ZERO
IS RETURNED. USES CURRENTPLINDEX *)
VAR
INDEX: 0.. ABSOLUTEPLMAX;
FOUND: BOOLEAN;
BEGIN
FOUND := FALSE; INDEX := 0;
WHILE NOT FOUND AND (INDEX < CURRENTPLINDEX) DO
BEGIN INDEX := INDEX + 1; FOUND := (PLAYERINDEX[INDEX] = NAME); END (*WHILE*);
IF FOUND THEN SEARCHPLINDEX := INDEX ELSE SEARCHPLINDEX := 0
END (*SEARCHPLINDEX*);
FUNCTION FINDOPENLOC: INTEGER;
(* LOOKS FOR OPENINGS FOR NEW USER ENTRIES. - 1 = FULL FILE,
0 = APPEND ENTRY TO EOF, > 0 = OPEN LOCATION *)
VAR
LOC: INTEGER;
BEGIN
LOC := SEARCHPLINDEX(EMPTY); FINDOPENLOC := LOC;
IF LOC = 0 THEN IF CURRENTPLINDEX >= ABSOLUTEPLMAX THEN FINDOPENLOC := - 1;
END (*FINDOPENLOC*);
BEGIN
INDEX := SEARCHPLINDEX(NAME);
IF INDEX > 0
THEN
BEGIN
POINTFILE(EPERSON, (INDEX + 1) DIV 2); GETSEG(EPERSON);
IF ODD(INDEX) THEN READUSR(PLAYER, TRUE)
ELSE BEGIN READUSR(PLAYER, FALSE); READUSR(PLAYER, TRUE) END;
WITH PLAYER ^ DO
BEGIN
AC := 10; NEXT := NIL; USWEAP := NIL; USARM := NIL; DEFPLAYER := NIL;
USSHIELD := NIL; DEFMON := NIL; LASTINPUT := REALTIME; ENTRY := XNAME;
STATUS := SLOGIN
END (*WITH*)
END (*IF*);
END (*READPLAYER*);
PROCEDURE WRITEPLAYER(VAR PLAYER: USERPOINT; NAME: ALFA);
(* WRITEPLAYER WILL WRITE THE PLAYER'S RECORD INTO THE POSITION
*NAME*. IF THE NAME IS NOT FOUND, THEN A NEW ENTRY IS CREATED.
THERE ARE TWO PLAYERS PER PRU. UP TO SIX OBJECTS CAN BE STORED
FOR EACH PLAYER. MESSAGES ARE SENT TELLING THE USER IF THE
SAVE WAS SUCCESSFUL OR NOT. *)
VAR
INDEX: INTEGER;
TEMP: USERPOINT;
FULL: BOOLEAN;
BEGIN
FULL := FALSE; INDEX := SEARCHPLINDEX(NAME);
IF INDEX <= 0
THEN (* NOT FOUND *)
BEGIN
INDEX := FINDOPENLOC;
IF INDEX < 0 THEN FULL := TRUE (* FILE FULL *)
ELSE (* FIND OPEN LOC *)
BEGIN
IF INDEX = 0
THEN
BEGIN (* OPEN LOC AT EOI *)
NEW(TEMP); TEMP ^ := PROTOUSER; REWRITE(EPERSON, 10000);
WRITEUSR(TEMP, TRUE); NEW(TEMP); TEMP ^ := PROTOUSER;
WRITEUSR(TEMP, TRUE); CURRENTPLINDEX := CURRENTPLINDEX + 2;
(* MAKE 2 NEW ENTRIES IN A NEW PRU *)
PUTSEG(EPERSON); INDEX := CURRENTPLINDEX - 1;
END (*IF*);
IF WHICHCONTROL <> MTHU THEN WRITELN(TERM, 'ENTRY CREATED.')
END (*ELSE*)
END (* MAKE INDEX *);
IF NOT FULL
THEN
BEGIN
PLAYERINDEX[INDEX] := PLAYER ^.NAME; POINTFILE(EPERSON, (INDEX + 1) DIV 2);
GETSEG(EPERSON) (* READ IN OLD PRU *); NEW(TEMP);
IF ODD(INDEX) THEN BEGIN READUSR(TEMP, FALSE); READUSR(TEMP, TRUE) END
ELSE READUSR(TEMP, TRUE);
OPENDFIL(EPERSON, 'EPERSON ', TRUE);
RANDOMACCESS(EPERSON) (*RESET RANDOM BIT*);
IF ODD(INDEX) THEN BEGIN WRITEUSR(PLAYER, TRUE); WRITEUSR(TEMP, TRUE) END
ELSE BEGIN WRITEUSR(TEMP, TRUE); WRITEUSR(PLAYER, TRUE) END;
POINTFILE(EPERSON, (INDEX + 1) DIV 2); PUTSEG(EPERSON) (* WRITE PRU *);
IF WHICHCONTROL <> MTHU THEN WRITELN(TERM, 'PLAYER FILE UPDATED.')
END (*IF*)
ELSE
BEGIN
IF WHICHCONTROL <> MTHU
THEN WRITELN(TERM, 'SORRY, FILE FULL. PLAYER CANNOT BE SAVED.');
WRITEUSR(PLAYER, FALSE);
(* DISPOSE OF USER AND OBJECTS *)
END (*ELSE*)
END (*WRITEPLAYER*);
PROCEDURE PRINTDESC(REC, LINE, PHRASENUM: INTEGER; BRIEF: BOOLEAN);
(* PRINTDESC WILL DISPLAY LINE *LINE* IN RECORD *REC*OF THE
EDESC FILE. THE CURRENT RECORD IS STORED IN *CURRENTREC*, A
GLOBAL VARIABLE. IF IT IS ZERO, THEN THE CURRENTREC IS UNKNOWN,
AND THE FILE IS REWOUND. *)
VAR
CH: CHAR;
LINENUM, NUMPHRASES, ILOOP: INTEGER;
BRMARK: BOOLEAN;
BEGIN
BRMARK := FALSE;
IF CURRENTREC <= 0 THEN
BEGIN (* REWIND FILE *) RESET(EDESC); CURRENTREC := 1; CURRENTLINE := 1 END;
IF (REC <= 0) OR (REC > 1000) OR (LINE <= 0) OR (LINE > 500)
THEN ABORT(' MIL72 - BAD DESCRIPTION INDEX!');
IF (REC <> CURRENTREC) OR (CURRENTLINE > LINE) THEN
BEGIN CURRENTLINE := 1; GETSEG(EDESC, REC - CURRENTREC); CURRENTREC := REC;
END (*IF*);
IF EOS(EDESC) OR EOF(EDESC) THEN WRITE('MEL314 - BAD DESCRIPTION RECORD!')
ELSE
BEGIN
WHILE CURRENTLINE < LINE DO (* SKIP DOWN TO LINE # *)
BEGIN
READLN(EDESC); CURRENTLINE := CURRENTLINE + 1;
IF EOS(EDESC)
THEN BEGIN WRITE('MEL315 - BAD DESCRIPTION INDEX!'); CURRENTLINE := LINE END
END (*WHILE*);
IF NOT EOS(EDESC)
THEN
BEGIN
READ(EDESC, LINENUM, NUMPHRASES);
IF LINENUM <> CURRENTLINE
THEN ABORT(' MIL73 - LINE NUMBER MISMATCH IN DESC FILE!');
IF PHRASENUM > NUMPHRASES THEN ABORT(' MIL74 - PHRASENUM NUMBER TOO LARGE!');
IF PHRASENUM = 0 THEN (*RANDOM PHRASE*) PHRASENUM := RND(NUMPHRASES);
FOR ILOOP := 1 TO PHRASENUM DO REPEAT READ(EDESC, CH) UNTIL CH = '/';
CH := ' ';
WHILE NOT EOLN(EDESC) AND (CH <> '/') DO
BEGIN
READ(EDESC, CH);
IF CH <> '/'
THEN
IF CH = '#' THEN BRMARK := NOT BRMARK
ELSE
IF NOT (BRMARK AND BRIEF)
THEN
IF CH = '+'
THEN
BEGIN
WRITELN; WRITE(TERM); PRINTDESC(REC, LINE + 1, PHRASENUM, BRIEF);
CH := '/' (*FLAG EOLN*)
END (*IF*)
ELSE WRITE(CH)
END (*WHILE*);
IF NOT EOS(EDESC) THEN READLN(EDESC); CURRENTLINE := CURRENTLINE + 1;
END (*IF*)
ELSE CURRENTREC := 0
END (*ELSE*)
END (*PRINTDESC*);
BEGIN (*WRITERM*)
WCPYRM(ROOM, BUF, 3); FOR ILOOP := 1 TO 3 DO WRITE(EMAP, BUF[ILOOP])
END (*WRITERM*);
PROCEDURE SAVECHEST(VAR CONT: OBJECTPOINT);
VAR
OBJ, OBJ2: OBJECTPOINT;
BEGIN
IF CONT ^.OBCLASS = CHEST
THEN
BEGIN
OBJ := CONT ^.OBJECTTAIL;
WHILE OBJ <> NIL DO
BEGIN
WRITEUOBJ(EMAP, OBJ ^); SAVECHEST(OBJ); OBJ2 := OBJ ^.NEXT;
IF ERASE THEN DISPOSE(OBJ); OBJ := OBJ2
END (*WHILE*)
END (*IF*)
END (*SAVECHEST*);
BEGIN (*WRITESEG*)
IF (SEGNUM < 0) OR (SEGNUM >= NUMSEGS)
THEN ABORT(' MIL211 - SEGNUM OUT OF BOUNDS!');
REWRITE(EMAP, 10000); RMSEGLOC[SEGNUM] := EOFSEG; EOFSEG := EOFSEG + 1;
FOR RLOOP := 0 TO 9 DO
BEGIN
RM := RLOOP + 10 * SLOTNUM; WRITERM(ROOM[RM]);
OBJECT := ROOM[RM].RMOBJECTTAIL;
WHILE OBJECT <> NIL DO
BEGIN
WRITEUOBJ(EMAP, OBJECT ^); SAVECHEST(OBJECT); OBJ2 := OBJECT ^.NEXT;
IF ERASE THEN DISPOSE(OBJECT); OBJECT := OBJ2
END (*WHILE*);
MONSTER := ROOM[RM].RMMONSTERTAIL;
WHILE MONSTER <> NIL DO
BEGIN
MONSTER ^.DEFPLAYER := NIL; WRITEMON(EMAP, MONSTER ^);
OBJECT := MONSTER ^.OBJECTTAIL;
WHILE OBJECT <> NIL DO
BEGIN
WRITEUOBJ(EMAP, OBJECT ^); OBJ2 := OBJECT ^.NEXT;
IF ERASE THEN DISPOSE(OBJECT); OBJECT := OBJ2
END (*WHILE*);
MON2 := MONSTER ^.NEXT; IF ERASE THEN DISPOSE(MONSTER); MONSTER := MON2
END (*WHILE*)
END (*FOR*);
PUTSEG(EMAP); CURRENTSEG := EOFSEG;
END (*WRITESEG*);
PROCEDURE READSEG(SLOTNUM, SEGNUM: INTEGER);
(* READ IN A ROOM SEGMENT *)
BEGIN (*READRM*)
FOR ILOOP := 1 TO 3 DO READ(EMAP, BUF[ILOOP]); RCPYRM(BUF, ROOM, 3)
END (*READRM*);
PROCEDURE GETCHEST(CONT: OBJECTPOINT);
VAR
OBJ, OBJ2: OBJECTPOINT;
BEGIN
IF CONT ^.OBCLASS = CHEST
THEN
IF CONT ^.OBJECTTAIL <> NIL
THEN
BEGIN
NEW(OBJ); CONT ^.OBJECTTAIL := OBJ; READUOBJ(EMAP, OBJ ^); GETCHEST(OBJ);
WHILE (OBJ ^.NEXT <> NIL) DO
BEGIN
NEW(OBJ2); OBJ ^.NEXT := OBJ2; READUOBJ(EMAP, OBJ2 ^); OBJ := OBJ2;
GETCHEST(OBJ)
END (*WHILE*)
END (*IF*)
END (*GETCHEST*);
BEGIN
IF MONSTER ^.OBJECTTAIL <> NIL
THEN
BEGIN
NEW(OBJ); MONSTER ^.OBJECTTAIL := OBJ; READUOBJ(EMAP, OBJ ^);
WHILE OBJ ^.NEXT <> NIL DO
BEGIN NEW(OBJ2); OBJ ^.NEXT := OBJ2; READUOBJ(EMAP, OBJ2 ^); OBJ := OBJ2
END (*WHILE*)
END (*IF*)
END (*GETMONOBJECTS*);
BEGIN (*READSEG*)
IF (SEGNUM < 0) OR (SEGNUM >= NUMSEGS)
THEN ABORT(' MIL210 - SEGNUM OUT OF BOUNDS!');
SLOTTBL[SLOTNUM] := SEGNUM;
IF CURRENTSEG = 0 THEN BEGIN RESET(EMAP); CURRENTSEG := 1; END;
GETSEG(EMAP, RMSEGLOC[SEGNUM] - CURRENTSEG); CURRENTSEG := RMSEGLOC[SEGNUM];
FOR RLOOP := 0 TO 9 DO
BEGIN
RM := RLOOP + 10 * SLOTNUM; READRM(ROOM[RM]); ROOM[RM].RMPLAYERTAIL := NIL;
IF ROOM[RM].RMOBJECTTAIL <> NIL
THEN
BEGIN
NEW(OBJECT); ROOM[RM].RMOBJECTTAIL := OBJECT; READUOBJ(EMAP, OBJECT ^);
GETCHEST(OBJECT);
WHILE OBJECT ^.NEXT <> NIL DO
BEGIN
NEW(OBJECT2); OBJECT ^.NEXT := OBJECT2; READUOBJ(EMAP, OBJECT2 ^);
OBJECT := OBJECT2; GETCHEST(OBJECT)
END (*WHILE*);
END (*IF*);
IF ROOM[RM].RMMONSTERTAIL <> NIL
THEN
BEGIN
NEW(MONSTER); ROOM[RM].RMMONSTERTAIL := MONSTER; READMON(EMAP, MONSTER ^);
MONSTER ^.DEFPLAYER := NIL; GETMONOBJECTS(MONSTER);
WHILE MONSTER ^.NEXT <> NIL DO
BEGIN
NEW(MONSTER2); MONSTER ^.NEXT := MONSTER2; READMON(EMAP, MONSTER2 ^);
MONSTER2 ^.DEFPLAYER := NIL; GETMONOBJECTS(MONSTER2); MONSTER := MONSTER2
END (*WHILE*);
END (*IF*)
END (*FOR*);
IF NOT EOS(EMAP) THEN ABORT(' MIL287 - FAILED TO READ ENTIRE RM SEG!');
END (*READSEG*);
FUNCTION S(RM: INTEGER): INTEGER;
(* RETURN PHYSICAL LOC OF ROOM IN ROOM LIST *)
VAR
ILOOP, SEGNUM: INTEGER;
BEGIN
IF (RM < 1) OR (RM >= NUMSEGS * 10)
THEN ABORT(' MIL205 - ROOM # OUT OF BOUNDS!');
SEGNUM := RM DIV 10; ILOOP := 0;
WHILE (ILOOP <= MAXUSERS) AND (SLOTTBL[ILOOP] <> SEGNUM) DO ILOOP := ILOOP + 1;
IF ILOOP <= MAXUSERS THEN (*FOUND*) S := ILOOP * 10 + RM - SEGNUM * 10
ELSE
BEGIN
ILOOP := 0;
WHILE (ILOOP <= MAXUSERS) AND (SLOTTBL[ILOOP] > - 1) DO ILOOP := ILOOP + 1;
IF ILOOP > MAXUSERS THEN
BEGIN
ILOOP := 0;
WHILE (ILOOP <= MAXUSERS) AND (ACTIVE[ILOOP] > 0) DO ILOOP := ILOOP + 1;
END (*IF*);
IF ILOOP > MAXUSERS THEN ABORT(' MIL206 - ROOM BUFFER FULL!'); ERRFLAG := 0;
IF SLOTTBL[ILOOP] > - 1 THEN WRITESEG(ILOOP, SLOTTBL[ILOOP], TRUE);
READSEG(ILOOP, SEGNUM); S := ILOOP * 10 + RM - SEGNUM * 10;
END (*ELSE*);
ERRFLAG := 1;
END (*S*);
PROCEDURE ADDSEG;
VAR
ILOOP, JLOOP: INTEGER;
BEGIN
ERRFLAG := 0;
IF NUMSEGS > MAXSEGS THEN WRITELN(TERM, ' SORRY, MAX ROOM LIMIT REACHED.')
ELSE
BEGIN
ILOOP := 0;
WHILE (ILOOP <= MAXUSERS) AND (ACTIVE[ILOOP] > 0) DO ILOOP := ILOOP + 1;
IF ILOOP > MAXUSERS THEN ABORT(' MIL209 - RM BUF FULL.');
IF SLOTTBL[ILOOP] > - 1 THEN WRITESEG(ILOOP, SLOTTBL[ILOOP], TRUE);
FOR JLOOP := ILOOP * 10 TO ILOOP * 10 + 9 DO ROOM[JLOOP] := PROTOROOM;
SLOTTBL[ILOOP] := NUMSEGS;
WRITELN(TERM, 'NEW ROOMS ', NUMSEGS * 10: 1, ' TO ', NUMSEGS * 10 + 9: 1,
' CREATED.');
NUMSEGS := NUMSEGS + 1; WRITESEG(ILOOP, NUMSEGS - 1, FALSE);
END (*ELSE*);
NUMROOMS := NUMSEGS * 10 - 1 (* NEW HIGHEST #ED ROOM *); ERRFLAG := 1
END (*ADDSEG*);
FUNCTION SA(RM: INTEGER): INTEGER;
(* LOAD AND SET-ACTIVE ROOM SEG *)
VAR
SEG, SEGRM: INTEGER;
BEGIN
SEGRM := S(RM); SEG := SEGRM DIV 10; ACTIVE[SEG] := ACTIVE[SEG] + 1;
SA := SEGRM
END (*SA*);
PROCEDURE INACTIVE(RM: INTEGER);
(* SET ROOM INACTIVE *)
VAR
SEG: INTEGER;
BEGIN
SEG := RM DIV 10;
IF ACTIVE[SEG] = 0 THEN ABORT(' SEC222 - NON ACTIVE SEG ASSUMED ACTIVE!');
ACTIVE[SEG] := ACTIVE[SEG] - 1
END (*INACTIVE*);
FUNCTION W(RM: INTEGER): INTEGER;
(* RETURN LOGICAL NUM OF PHYSICAL ROOM NUM *)
VAR
WHERE: INTEGER;
BEGIN
IF (RM < 0) OR (RM > RMLIMIT) THEN WHERE := 0
ELSE WHERE := SLOTTBL[RM DIV 10] * 10 + RM - (RM DIV 10) * 10;
IF (WHERE < 0) OR (WHERE > NUMROOMS) THEN WHERE := 0; W := WHERE;
END (*W*);
FUNCTION MATCHMONSTER(MONSTERTAIL: MONSTERPOINT; FUNCTION TEST(MON: MONSTERPOINT):
BOOLEAN): MONSTERPOINT;
(* MATCHMONSTER WILL GO THOUGH A LIST OF MONSTERS (MONSTERTAIL)
UNTIL IT FINDS A MONSTER THAT MEETS THE CRITERIA OF *TEST* *)
VAR
FOUND: BOOLEAN;
POINTER: MONSTERPOINT;
BEGIN
FOUND := FALSE; POINTER := MONSTERTAIL;
WHILE NOT FOUND AND (POINTER <> NIL) DO
IF TEST(POINTER) (* IT'S EFFICIENT TO PASS ONLY THE POINTER *)
THEN FOUND := TRUE
ELSE POINTER := POINTER ^.NEXT;
IF FOUND THEN MATCHMONSTER := POINTER ELSE MATCHMONSTER := NIL
END (*MATCHMONSTER*);
FUNCTION MATCHOBJECT(OBJECTTAIL: OBJECTPOINT; FUNCTION TEST(OBJECT: OBJECTPOINT):
BOOLEAN): OBJECTPOINT;
(* MATCHOBJECT WILL GO THROUGH A LIST OF OBJECTS UNTIL IT FINDS
AN OBJECT THAT MEETS THE CRITERIA OF *TEST* *)
VAR
FOUND: BOOLEAN;
POINTER: OBJECTPOINT;
BEGIN
FOUND := FALSE; POINTER := OBJECTTAIL;
WHILE NOT FOUND AND (POINTER <> NIL) DO
IF TEST(POINTER) THEN FOUND := TRUE ELSE POINTER := POINTER ^.NEXT;
IF FOUND THEN MATCHOBJECT := POINTER ELSE MATCHOBJECT := NIL
END (*MATCHOBJECT*);
FUNCTION MATCHPLAYER(PLAYERTAIL: USERPOINT; FUNCTION TEST(PLAYER: USERPOINT):
BOOLEAN): USERPOINT;
(* MATCHPLAYER WILL GO THROUGH A LIST OF PLAYERS (PLAYERTAIL)
UNTIL IT FINDS A PLAYER THAT MEETS THE CRITERIA OF *TEST* *)
VAR
FOUND: BOOLEAN;
POINTER: USERPOINT;
BEGIN
FOUND := FALSE; POINTER := PLAYERTAIL;
WHILE NOT FOUND AND (POINTER <> NIL) DO
IF TEST(POINTER) THEN FOUND := TRUE ELSE POINTER := POINTER ^.NEXT;
IF FOUND THEN MATCHPLAYER := POINTER ELSE MATCHPLAYER := NIL
END (*MATCHPLAYER*);
FUNCTION MATCHUSER(USERTAIL: USERPOINT; FUNCTION TEST(USER: USERPOINT): BOOLEAN):
USERPOINT;
(* MATCHUSER WILL GO THROUGH THE MAIN USER LIST (USERTAIL)
UNTIL IT FINDS A USER THAT MEETS THE CRITERIA OF *TEST*.
*)
VAR
FOUND: BOOLEAN;
POINTER: USERPOINT;
BEGIN
FOUND := FALSE; POINTER := USERTAIL;
WHILE NOT FOUND AND (POINTER <> NIL) DO
IF TEST(POINTER) THEN FOUND := TRUE ELSE POINTER := POINTER ^.NEXTUSER;
IF FOUND THEN MATCHUSER := POINTER ELSE MATCHUSER := NIL
END (*MATCHUSER*);
PROCEDURE FIXMONCOUNT(MONSTERTAIL: MONSTERPOINT; NAME: ALFA);
(* FIXMONCOUNT RESTORES THE INDEX NUMBERS OF MONSTERS AFTER ONE
LEAVES OR ARRIVES. IT UPDATES .TOP AND .NUM *)
VAR
PT: MONSTERPOINT;
I, NUMMON: INTEGER;
FUNCTION NAMEMON(MON: MONSTERPOINT): BOOLEAN;
(* IF MONSTER'S NAME = NAMECLASS TO PATCH *)
BEGIN NAMEMON := (NAME = MON ^.NAME) END;
BEGIN (*FIXMONCOUNT*)
PT := MATCHMONSTER(MONSTERTAIL, NAMEMON);
IF PT <> NIL
THEN
BEGIN
NUMMON := 0;
WHILE PT <> NIL DO
BEGIN PT := MATCHMONSTER(PT ^.NEXT, NAMEMON); NUMMON := NUMMON + 1
END (*WHILE*);
PT := MATCHMONSTER(MONSTERTAIL, NAMEMON);
FOR I := NUMMON DOWNTO 1 DO
BEGIN
PT ^.NUM := MIN(I, 9); PT ^.TOP := (I = NUMMON);
PT := MATCHMONSTER(PT ^.NEXT, NAMEMON)
END (*FOR*)
END (*IF*)
END (*FIXMONCOUNT*);
PROCEDURE STOPOTHERATK (* AGAINST PLAYER *) (PLAYER: USERPOINT;
(* GLOBAL
RMPLAYERTAIL AND RMMONSTERTAIL *) RM: RMCODETYPE);
(* STOPOTHERATK WILL RESET THE DEFPLAYER POINTERS ON HOSTILE
PLAYERS AND MONSTERS. IT ALSO STOPS THE USER'S ATTACKS. *)
VAR
OTHERPLAYER: USERPOINT;
OTHERMONSTER: MONSTERPOINT;
FUNCTION PATK(PLYR: USERPOINT): BOOLEAN;
(* IS ANOTHER PLAYER ATTACKING? *)
BEGIN PATK := (PLYR ^.DEFPLAYER = PLAYER) END;
FUNCTION MATTACK(MON: MONSTERPOINT): BOOLEAN;
(* IS ANOTHER MONSTER ATTACKING? *)
BEGIN MATTACK := (MON ^.DEFPLAYER = PLAYER) END;
BEGIN (*STOPOTHERATK*)
PLAYER ^.DEFMON := NIL (* STOP PLAYER'S ATTACKS TOO.*);
PLAYER ^.DEFPLAYER := NIL (* STOP PLAYER'S ATTACKS TOO.*);
WITH ROOM[RM] DO
BEGIN
OTHERPLAYER := MATCHPLAYER(RMPLAYERTAIL, PATK);
WHILE OTHERPLAYER <> NIL DO
BEGIN
OTHERPLAYER ^.DEFPLAYER := NIL;
OTHERPLAYER := MATCHPLAYER(OTHERPLAYER ^.NEXT, PATK)
END (*WHILE*);
(* MAKE MONSTERS STOP ATTACKING TOO *)
OTHERMONSTER := MATCHMONSTER(RMMONSTERTAIL, MATTACK);
WHILE OTHERMONSTER <> NIL DO
BEGIN
OTHERMONSTER ^.DEFPLAYER := NIL;
IF OTHERMONSTER^.MREACT >= 5 THEN
OTHERMONSTER^.MREACT := 0;
OTHERMONSTER := MATCHMONSTER(OTHERMONSTER ^.NEXT, MATTACK)
END (*WHILE*)
END (*WITH*)
END (*STOPOTHERATK*);
PROCEDURE STOPPLYRATK(MONSTER: MONSTERPOINT; RM: RMCODETYPE);
(* STOPPLRYATK WILL STOP THE ATTACKS OF PLAYERS AGAINST THE MONSTER
THAT IS DELETED. *)
VAR
OTHERPLAYER: USERPOINT;
FUNCTION PATTACKING(OTHRPLYR: USERPOINT): BOOLEAN;
(* PATTACKING RETURNS TRUE IF ANOTHER PLAYER IS ATTACKING MONSTAR *)
BEGIN PATTACKING := (OTHRPLYR ^.DEFMON = MONSTER) END;
BEGIN (*STOPPLYRATK*)
WITH ROOM[RM] DO
BEGIN
OTHERPLAYER := MATCHPLAYER(RMPLAYERTAIL, PATTACKING);
WHILE OTHERPLAYER <> NIL DO
BEGIN
OTHERPLAYER ^.DEFMON := NIL;
OTHERPLAYER := MATCHPLAYER(OTHERPLAYER ^.NEXT, PATTACKING)
END (*WHILE*)
END (*WITH*)
END (*STOPPLYRATK*);
PROCEDURE DESTROY(VAR MON: MONSTERPOINT);
(* DESTROY MONSTER RECORD *)
VAR
OBJ: OBJECTPOINT;
BEGIN
WHILE MON ^.OBJECTTAIL <> NIL DO
BEGIN
OBJ := MON ^.OBJECTTAIL; MON ^.OBJECTTAIL := MON ^.OBJECTTAIL ^.NEXT;
ODESTROY(OBJ);
END (*WHILE*);
DISPOSE(MON); MON := NIL
END (*DESTROY*);
PROCEDURE INSERTMONSTER(VAR MONSTER: MONSTERPOINT; RM: RMCODETYPE);
(* INSERTMONSTER WILL ADD A MONSTER TO THE TAIL. IT ALSO CALLS
*FIXMONCOUNT* WHICH RESTORES .TOP AND .NUM *)
BEGIN
WITH ROOM[RM] DO
BEGIN
MONSTER ^.NEXT := RMMONSTERTAIL; RMMONSTERTAIL := MONSTER;
FIXMONCOUNT(RMMONSTERTAIL, MONSTER ^.NAME);
(* RESTORE .NUM AND .TOP OF THE MONSTERCLASS *)
END (*WITH*)
END (*INSERTMONSTER*);
PROCEDURE PLACEPLAYER(VAR PLYR: USERPOINT; RM: RMCODETYPE);
(* INSERT PLAYER INTO LOGICAL *RM* *)
VAR
NEWRM: RMCODETYPE;
BEGIN
NEWRM := SA(RM); PLYR ^.NEXT := ROOM[NEWRM].RMPLAYERTAIL;
ROOM[NEWRM].RMPLAYERTAIL := PLYR; PLYR ^.RMCODE := NEWRM
END (*PLACEPLAYER*);
PROCEDURE DELETEMONSTER(PT: MONSTERPOINT; RM: RMCODETYPE);
(* DELETE MONSTER REMOVES A MONSTER FROM A LIST OF MONSTERS
(MONSTERTAIL). IF THE MONSTER (PT) IS NOT FOUND, THE PROGRAM
ABORTS! SO MAKE SURE THE MONSTER EXISTS BEFORE DELETING IT *)
VAR
PT2: MONSTERPOINT;
FOUND: BOOLEAN;
BEGIN
IF PT = NIL THEN ABORT(' MIL86 - CANNOT DELETE NIL MONSTER!');
WITH ROOM[RM] DO
BEGIN
IF PT = RMMONSTERTAIL THEN RMMONSTERTAIL := RMMONSTERTAIL ^.NEXT
ELSE
BEGIN
FOUND := FALSE; PT2 := RMMONSTERTAIL;
WHILE NOT FOUND AND (PT2 <> NIL) DO
IF PT2 ^.NEXT = PT THEN FOUND := TRUE ELSE PT2 := PT2 ^.NEXT;
IF FOUND THEN PT2 ^.NEXT := PT ^.NEXT (*DELETE*)
ELSE BEGIN MESSAGE(PT ^.NAME); ABORT(' MIL02 - DELETED MON NOT FOUND') END
END (*ELSE*);
FIXMONCOUNT(RMMONSTERTAIL, PT ^.NAME);
(* RESTORE .NUM AND .TOP OF THE REMAINING MONSTERS *)
IF RMPLAYERTAIL <> NIL THEN STOPPLYRATK(PT, RM)
END (*WITH*)
END (*DELETEMONSTER*);
FUNCTION DELETEOBJECT(PT, OBJECTTAIL: OBJECTPOINT): BOOLEAN;
(* DELETEOBJECT REMOVES AN OBJECT FROM A LINKED LIST *)
VAR
PT2: OBJECTPOINT;
FOUND: BOOLEAN;
BEGIN
IF PT = NIL THEN ABORT(' MIL84 - CANNOT DELETE NIL OBJ!');
IF PT = OBJECTTAIL THEN DELETEOBJECT := TRUE
ELSE
BEGIN
DELETEOBJECT := FALSE; FOUND := FALSE; PT2 := OBJECTTAIL;
WHILE NOT FOUND AND (PT2 <> NIL) DO
IF PT2 ^.NEXT = PT THEN FOUND := TRUE ELSE PT2 := PT2 ^.NEXT;
IF FOUND THEN PT2 ^.NEXT := PT ^.NEXT (* DELETE *)
ELSE BEGIN MESSAGE(PT ^.NAME); ABORT(' MIL05 - DELETED OBJ NOT FOUND') END
END (*ELSE*)
END (*DELETEOBJECT*);
PROCEDURE CLEANRM(RM: RMCODETYPE);
(* CLEANRM REMOVES OLD MONSTERS AND OBJECTS THAT DON'T HAVE
THE *PERMANENT* BIT SET. *)
VAR
NEXTMON, OLDMON: MONSTERPOINT;
NEXTOBJ, OLDOBJ: OBJECTPOINT;
FUNCTION TEMPOBJ(OBJ: OBJECTPOINT): BOOLEAN;
(* IS OBJECT TEMPORARY*)
BEGIN TEMPOBJ := (NOT OBJ ^.PERMANENT) END;
BEGIN (*CLEANRM*)
WITH ROOM[RM] DO
BEGIN
OLDOBJ := MATCHOBJECT(RMOBJECTTAIL, TEMPOBJ);
WHILE OLDOBJ <> NIL DO
BEGIN
NEXTOBJ := OLDOBJ ^.NEXT;
IF DELETEOBJECT(OLDOBJ, RMOBJECTTAIL)
THEN RMOBJECTTAIL := RMOBJECTTAIL ^.NEXT;
ODESTROY(OLDOBJ); OLDOBJ := MATCHOBJECT(NEXTOBJ, TEMPOBJ)
END (*WHILE*);
OLDMON := RMMONSTERTAIL;
WHILE OLDMON <> NIL DO
BEGIN
NEXTMON := OLDMON ^.NEXT;
IF OLDMON ^.PERMANENT THEN OLDMON ^.HITS := OLDMON ^.MAXHITS
ELSE BEGIN DELETEMONSTER(OLDMON, RM); DISPOSE(OLDMON); END;
OLDMON := NEXTMON
END (*WHILE*)
END (*WITH*)
END (*CLEANRM*);
PROCEDURE DELETEPLAYER(PT: USERPOINT; RM: RMCODETYPE);
(* DELETEPLAYER WILL REMOVE A PLAYER FROM A LINKED LIST *)
VAR
PT2: USERPOINT;
FOUND: BOOLEAN;
BEGIN
IF PT = NIL THEN ABORT(' MIL87 - CANNOT DELETE NIL PLAYER!');
WITH ROOM[RM] DO
BEGIN
IF PT = RMPLAYERTAIL
THEN
BEGIN
RMPLAYERTAIL := RMPLAYERTAIL ^.NEXT;
IF RMPLAYERTAIL = NIL THEN CLEANRM(PT ^.RMCODE)
ELSE IF RMPLAYERTAIL ^.HITS = 0 THEN CLEANRM(PT ^.RMCODE)
END (*IF*)
ELSE
BEGIN
FOUND := FALSE; PT2 := RMPLAYERTAIL;
WHILE NOT FOUND AND (PT2 <> NIL) DO
IF PT2 ^.NEXT = PT THEN FOUND := TRUE ELSE PT2 := PT2 ^.NEXT;
IF FOUND THEN PT2 ^.NEXT := PT ^.NEXT (*DELETE*)
ELSE BEGIN MESSAGE(PT ^.NAME); ABORT(' MIL06 - DELETED PLYR NOT FOUND!') END
END (*ELSE*);
STOPOTHERATK(PT, RM (* RMPLAYERTAIL, RMMONSTERTAIL*)) (* STO
P ATTACKS ON THIS USER BY MONSTERS/PLAYERS *);
PT ^.FOLLOW := NIL; INACTIVE(RM);
END (*WITH*)
END (*DELETEPLAYER*);
PROCEDURE DELETEUSER(PT: USERPOINT; VAR USERTAIL: USERPOINT);
(* DELETEUSER WILL REMOVE A USER FROM THE MAIN LIST. IF THE
USER IS NOT CURRENTLY LOGGING IN (STATUS=SLOGIN), THEN HE IS ALSO
DELETED FROM THE ROOM HE IS IN. *)
VAR
PT2: USERPOINT;
FOLLOWPLYR: USERPOINT;
FOUND: BOOLEAN;
FUNCTION PLFOLLOW(USR: USERPOINT): BOOLEAN;
BEGIN PLFOLLOW := (USR ^.FOLLOW = PT) END;
BEGIN (*DELETEUSER*)
IF (PT = NIL) OR (USERTAIL = NIL) THEN ABORT(' MIL88 - CANNOT DELETE NIL USER!');
IF PT = USERTAIL THEN USERTAIL := USERTAIL ^.NEXTUSER
ELSE
BEGIN
FOUND := FALSE; PT2 := USERTAIL;
WHILE NOT FOUND AND (PT2 <> NIL) DO
IF PT2 ^.NEXTUSER = PT THEN FOUND := TRUE ELSE PT2 := PT2 ^.NEXTUSER;
IF FOUND THEN PT2 ^.NEXTUSER := PT ^.NEXTUSER (*DELETE*)
ELSE BEGIN MESSAGE(PT ^.NAME); ABORT(' MIL08 - DELETED RECORD NOT FOUND!') END
END (*ELSE*);
IF PT ^.STATUS <> SLOGIN THEN DELETEPLAYER(PT, PT ^.RMCODE);
PT ^.RMCODE := W(PT ^.RMCODE); FOLLOWPLYR := MATCHUSER(USERTAIL, PLFOLLOW);
WHILE FOLLOWPLYR <> NIL DO
BEGIN
FOLLOWPLYR ^.FOLLOW := NIL;
FOLLOWPLYR := MATCHUSER(FOLLOWPLYR ^.NEXT, PLFOLLOW)
END (*WHILE*)
END (*DELETEUSER*);
FUNCTION NOTIMEOUT(USR: USERPOINT): BOOLEAN;
BEGIN
IF USR = NIL THEN ABORT(' MIL220 - NIL USR POINTER!');
IF (REALTIME - USR ^.LASTINPUT <= RESPONDLIMIT) THEN NOTIMEOUT := TRUE
ELSE NOTIMEOUT := USR ^.AUTO;
END (*NOTIMEOUT*);
FUNCTION MSGTERM(VAR TERMLIST: TERMTYPELIST; TALKHOW: TALKHOWTYPE): INTEGER;
(* USERTAIL IS USED GLOBALLY *)
(* MSGTERM SETS UP A LIST OF TERMINAL NUMBERS FOR TO SEND TEXT TO.
IT IS USED TO SEND MESSAGES TO PLAYERS IN THE SAME ROOM, IN ADJACENT
ROOMS, AND THROUGHOUT THE WHOLE PROGRAM. *)
VAR
FACTOR, COUNT, ILOOP: INTEGER;
OTHERPLAYER: USERPOINT;
FUNCTION OKSEND(USR: USERPOINT): BOOLEAN;
BEGIN OKSEND := ((USR <> USER) AND NOTIMEOUT(USR) AND (USR ^.STATUS <> SLOGIN));
END (*OKSEND*);
BEGIN (*MSGTERM*)
COUNT := 0;
IF NOT USER ^.INVISIBLE OR (CMDCODE IN [12, 13, 14, 16, 36, 37, 38]) OR (TALKHOW =
SYSMSG)
THEN
IF (TALKHOW = LOCAL) OR (TALKHOW = YELL)
THEN
WITH ROOM[USER ^.RMCODE] DO
BEGIN
OTHERPLAYER := MATCHPLAYER(RMPLAYERTAIL, OKSEND);
WHILE (OTHERPLAYER <> NIL) AND (COUNT < MAXNAMES) DO
BEGIN
COUNT := COUNT + 1; TERMLIST[COUNT] := OTHERPLAYER ^.TRM;
OTHERPLAYER := MATCHPLAYER(OTHERPLAYER ^.NEXT, OKSEND);
END (*WHILE*);
IF TALKHOW = YELL
THEN
FOR ILOOP := 1 TO 6 DO
IF ADJOIN[ILOOP] > 0
THEN
BEGIN
IF ILOOP IN THOUSANDS THEN FACTOR := 1000 ELSE FACTOR := 0;
OTHERPLAYER := MATCHPLAYER(ROOM[S(ADJOIN[ILOOP] + FACTOR)].RMPLAYERTAIL,
OKSEND);
WHILE (OTHERPLAYER <> NIL) AND (COUNT < MAXNAMES) DO
BEGIN
COUNT := COUNT + 1; TERMLIST[COUNT] := OTHERPLAYER ^.TRM;
OTHERPLAYER := MATCHPLAYER(OTHERPLAYER ^.NEXT, OKSEND)
END (*WHILE*)
END (*IF*)
END (* WITH *)
ELSE
IF TALKHOW IN [ALL, OTHERS, NOBLOCK, BRALL, BROTHERS, SYSMSG]
THEN
BEGIN
OTHERPLAYER := MATCHUSER(USERTAIL, OKSEND);
WHILE (OTHERPLAYER <> NIL) AND (COUNT < MAXNAMES) DO
BEGIN
IF NOT ((TALKHOW IN [BROTHERS, BRALL]) AND OTHERPLAYER ^.BRIEF)
THEN
IF NOT ((TALKHOW = NOBLOCK) AND (OTHERPLAYER ^.MESBLOCK))
THEN BEGIN COUNT := COUNT + 1; TERMLIST[COUNT] := OTHERPLAYER ^.TRM; END;
OTHERPLAYER := MATCHUSER(OTHERPLAYER ^.NEXTUSER, OKSEND)
END (*WHILE*);
IF (TALKHOW IN [SYSMSG, ALL, BRALL]) OR USER ^.ECHO
THEN BEGIN COUNT := COUNT + 1; TERMLIST[COUNT] := TERM END;
FOR ILOOP := 1 TO MAXQUEUE DO
IF QUEUE[ILOOP].QTERM <> BLANKS
THEN BEGIN COUNT := COUNT + 1; TERMLIST[COUNT] := QUEUE[ILOOP].QTERM END;
END (*IF*)
ELSE ABORT(' MIL10 - BAD TALK/TERM FUNCTION!');
IF COUNT > MAXNAMES THEN WRITELN(TERM, 'MIL11 - TERM MSG TABLE OVERFLOW!')
ELSE MSGTERM := COUNT
END (*MSGTERM*);
PROCEDURE STOPUSING(USR: USERPOINT; OBJECT: OBJECTPOINT);
(* STOPUSING WILL SET TO NIL EITHER USSHIELD, USARM, OR
USWEAP IF THESE OBJECTS ARE DROPPED OR BROKEN. ARMOR CLASS IS ALSO
REDUCED ACCORDINGLY *)
BEGIN
IF OBJECT <> NIL
THEN
WITH USR ^ DO
IF OBJECT = USWEAP THEN USWEAP := NIL
ELSE
IF OBJECT = USSHIELD
THEN
BEGIN USSHIELD := NIL; AC := MAX(- 50, MIN(AC + OBJECT ^.SHPLUS, 50)) END
ELSE
IF OBJECT = USARM
THEN BEGIN USARM := NIL; AC := MAX(- 50, MIN(AC + OBJECT ^.ARMPLUS, 50)) END
END (*STOPUSING*);
FUNCTION FINDTERM(TERM: ALFA; USERTAIL: USERPOINT): USERPOINT;
VAR
FOUND: BOOLEAN;
USERSCANNER: USERPOINT;
BEGIN
FOUND := FALSE; USERSCANNER := USERTAIL (*POINT TO TOP OF USER LIST*);
WHILE NOT FOUND AND (USERSCANNER <> NIL) DO
IF USERSCANNER ^.TRM = TERM THEN FOUND := TRUE
ELSE USERSCANNER := USERSCANNER ^.NEXTUSER;
IF FOUND THEN FINDTERM := USERSCANNER
ELSE ABORT(' MIL101 - UNDEFINED TERMINAL!')
END (*FINDTERM*);
PROCEDURE GETWORD(VAR WORD: ALFA; VAR NUM: INTEGER; VAR BUFFER: BUFTYPE; VAR LENBUF:
LENBUFTYPE; VAR LOC: INTEGER);
(* GETWORD IS THE MAIN PARSER. IT EXTRACTS THE NEXT WORD OR
NUMBER FROM THE BUFFER. THE WORDS "TO", "THE", AND "AT" ARE
IGNORED. *)
VAR
ILOOP, DIGIT: INTEGER;
LBSIGN: BOOLEAN;
BEGIN
WORD := BLANKS; NUM := 0; LBSIGN := FALSE;
IF BUFFER[LOC] = ',' THEN LOC := LOC + 1;
WHILE (BUFFER[LOC] = ' ') AND (LOC <= LENBUF) DO LOC := LOC + 1 (* SKIP BLANKS *);
IF LOC <= LENBUF
THEN
BEGIN
ILOOP := 1;
REPEAT
IF BUFFER[LOC] = '#' THEN LBSIGN := TRUE;
IF (ILOOP <= 10) AND NOT LBSIGN THEN WORD[ILOOP] := BUFFER[LOC];
LOC := LOC + 1; ILOOP := ILOOP + 1;
UNTIL (BUFFER[LOC] IN [' ', ',']) OR (LOC > LENBUF);
IF WORD[1] IN ['0' .. '9', '-']
THEN WORD := BLANKS (* IT'S A NUMBER, NOT A STRING*);
ILOOP := LOC - 1; DIGIT := 1;
WHILE ILOOP > 0 DO
IF BUFFER[ILOOP] IN ['0' .. '9', '-']
THEN
BEGIN
IF BUFFER[ILOOP] = '-' THEN NUM := - NUM
ELSE
BEGIN
NUM := NUM + (ORD(BUFFER[ILOOP]) - ORD('0')) * DIGIT; DIGIT := DIGIT * 10
END (*ELSE*);
ILOOP := ILOOP - 1
END (*IF*)
ELSE ILOOP := 0 (*END WHILE*);
IF (WORD = 'TO ') OR (WORD = 'THE ') OR (WORD = 'AT ') OR (
WORD = 'OF ') OR (WORD = 'ON ') OR (WORD = 'IN ') OR (
WORD = 'FOR ') OR (WORD = 'FROM ') OR (WORD = 'SPELL ') OR (
WORD = 'WITH ')
THEN GETWORD(WORD, NUM, BUFFER, LENBUF, LOC);
(* RECURSIVELY GET THE NEXT WORD.. TO,THE,AT ARE DISCARDED *)
END (*IF*)
END (*GETWORD*);
FUNCTION GETEDITPARM(VAR PARMLIST: DYNAMIC PARMTYPELIST; VAR WORD: ALFA; VAR NUMBER:
INTEGER; VAR FLAG: BOOLEAN; VAR BUFFER: BUFTYPE; VAR LENBUF: LENBUFTYPE; VAR LOC:
INTEGER): INTEGER;
(* GETEDITPARM PARSES THE VARIOUS PARAMETERS USED WHILE USING
THE EDITOR.. EXAMPLES ARE: "LV=2,NA=HAROLD,HT=4,SS=FALSE".
IT RETURNS 0 IF END-OF-LIST OR ERROR. OTHERWISE IT RETURNS THE
INDEX # OF THE PARAMETER PARSED, ALONG WITH ITS VALUE *)
VAR
PARM: BYTE;
WHICHPARM: INTEGER;
FOUND: BOOLEAN;
BEGIN
PARM[1] := ' '; PARM[2] := ' '; WORD := BLANKS; NUM := 0; FLAG := FALSE;
IF BUFFER[LOC] = ',' THEN LOC := LOC + 1;
WHILE (BUFFER[LOC] = ' ') AND (LOC <= LENBUF) DO
LOC := LOC + 1 (* SKIP BLANKS & COMMAS *);
IF LOC > LENBUF THEN GETEDITPARM := 0 (* END OF LIST *)
ELSE
BEGIN
PARM[1] := BUFFER[LOC]; LOC := LOC + 1;
IF (BUFFER[LOC] <> '=') AND (LOC <= LENBUF)
THEN BEGIN PARM[2] := BUFFER[LOC]; LOC := LOC + 1 END;
WHILE BUFFER[LOC] IN ['A' .. 'Z'] DO LOC := LOC + 1;
IF (BUFFER[LOC] <> '=') OR (LOC >= LENBUF)
THEN
BEGIN (* BAD PARAMETER *)
GETEDITPARM := 0; WRITELN(TERM, 'BAD PARAMETER: ', PARM: 2);
END (*IF*)
ELSE
BEGIN
LOC := LOC + 1; FOUND := FALSE; WHICHPARM := 0 (*SEARCH FOR PARM*);
WHILE NOT FOUND AND (WHICHPARM < HIGH(PARMLIST)) DO
BEGIN
WHICHPARM := WHICHPARM + 1; FOUND := (PARM = PARMLIST[WHICHPARM].PNAME)
END (*WHILE*);
IF NOT FOUND THEN WHICHPARM := 0;
IF WHICHPARM = 0 THEN WRITELN(TERM, 'UNKNOWN PARAMETER: ', PARM: 2)
ELSE
CASE PARMLIST[WHICHPARM].PTYPE OF
DFLAG:
BEGIN (* BOOLEAN *)
IF BUFFER[LOC] = 'T' THEN FLAG := TRUE
ELSE
IF BUFFER[LOC] = 'F' THEN FLAG := FALSE
ELSE
BEGIN WHICHPARM := 0; WRITELN(TERM, PARM: 2, ' MUST BE T OR F.')
END (*ELSE*);
WHILE NOT (BUFFER[LOC] IN [' ', ',']) AND (LOC <= LENBUF) DO
LOC := LOC + 1
END (*DFLAG*);
DNUM:
BEGIN
GETWORD(WORD, NUMBER, BUFFER, LENBUF, LOC);
IF WORD <> BLANKS THEN
BEGIN WHICHPARM := 0; WRITELN(TERM, PARM: 2, ' MUST BE A NUMBER.')
END (*IF*)
END (*DNUM*);
DWORD:
BEGIN
GETWORD(WORD, NUMBER, BUFFER, LENBUF, LOC);
IF (WORD = BLANKS) AND (NUM <> 0) THEN
BEGIN WHICHPARM := 0; WRITELN(TERM, PARM: 2, ' - ONLY STRING ALLOWED.')
END (*IF*)
END (*DWORD*);
DOTHER: (*LET CALLING PROGRAM PROCESS PARAMETER*);
END (*CASE*);
GETEDITPARM := WHICHPARM
END (*ELSE*)
END (*ELSE*)
END (*GETEDITPARM*);
PROCEDURE DAYMSG(REASON: ALFA3; WHO: USERPOINT; CAUSE: ALFA; CLEV: INTEGER);
(* ISSUE A MESSAGE TO THE GAME DAYFILE *)
BEGIN
WRITE(DAYFILE, CLOCKTIME, ' ', REASON: 3, ' ');
WITH WHO ^ DO WRITE(DAYFILE, NAME, ' ', LVL: 2, ' ', UN: 7);
IF CAUSE <> BLANKS THEN WRITE(DAYFILE, ' BY ', CAUSE);
IF CLEV <> 0 THEN WRITELN(DAYFILE, ' ', CLEV: 2) ELSE WRITELN(DAYFILE)
END (*DAYMSG*);
PROCEDURE ROOMDISPLAY(RM: INTEGER; BRIEF: BOOLEAN);
(* DISPLAY THE ROOM AFTER ANNOUNCING LOGIN *)
FORWARD;
PROCEDURE ANNOUNCELOGIN(USER: USERPOINT);
VAR
I, ILOOP: INTEGER;
BEGIN
USER ^.STATUS := SNORMAL; WRITELN(TERM) (* SKIP PAST PW ENTRY *);
WITH USER ^ DO
IF LASTACCESS <> TODAY
THEN
BEGIN
LASTACCESS := TODAY; SPELLDAY := 0; SENDDAY := 0;
IF TGUILD OR AGUILD
THEN
BEGIN
MONEY := MAX(0, MONEY - LVL * 20);
IF MONEY = 0
THEN
BEGIN
WRITELN(TERM, 'YOU HAVE NOT THE FUNDS TO PAY YOUR DUES!');
WRITELN(TERM, 'YOU HAVE BEEN EXPELLED FROM THE GUILD.'); AGUILD := FALSE;
TGUILD := FALSE;
END (*IF*)
ELSE
WRITELN(TERM, 'DAILY ', LVL * 20: 0, ' GUILD FEE PAID IN FULL. THANK YOU!')
END (*IF*);
END (*IF*);
IF NOTICE[1] <> COL THEN
BEGIN WRITELN(TERM, 'NOTICE:'); WRITELN(TERM, PO(NOTICE)); WRITELN(TERM); END;
CMDCODE := 0; IF USER ^.SSJ THEN DAYMSG('LOG', USER, BLANKS, 0);
USER ^.PLYRTEMP := FALSE;
IF USER^.UNHASH IN [0,1] THEN BEGIN USER^.UNHASH := HASH(USER^.UN,5);
WRITELN(TERM,'USERNUMBER RESTRICTION TURNED ON.') END;
USER^.CONVERTED := 0;
FOR ILOOP := 1 TO MSGTERM(TERMLIST, BRALL) DO
BEGIN
WRITE(TERMLIST[ILOOP], '### PLEASE WELCOME ', PS(USER ^.NAME));
WRITELN(', THE ', PS(CNAME[USER ^.CLASS]), ', FROM ', PS(USER ^.UN), '.');
END (*FOR*);
IF NOT USER ^.SSJ AND (USER ^.NONEXISTANT OR USER ^.INVISIBLE)
THEN
BEGIN
USER ^.NONEXISTANT := FALSE; DAYMSG('INV', USER, 'ILLEGAL IV', 0);
USER ^.INVISIBLE := FALSE
END (*IF*);
IF USER ^.INVISIBLE THEN
IF USER ^.NONEXISTANT THEN WRITELN(TERM, 'YOU ARE NONEXISTANT.')
ELSE WRITELN(TERM, 'YOU ARE CURRENTLY INVISIBLE.');
ROOMDISPLAY(USER ^.RMCODE, USER ^.BRIEF);
END (*ANNOUNCELOGIN*);
PROCEDURE DOINPUT(VAR BUFFER: BUFTYPE; VAR LENBUF: LENBUFTYPE; VAR USER: USERPOINT);
FORWARD;
PROCEDURE PROMPTUSER(USER: USERPOINT);
VAR
ASCII: BOOLEAN;
BEGIN
IF NOPROMPT AND (LOC <= LENBUF) THEN DOINPUT(BUFFER, LENBUF, USER)
ELSE
BEGIN
ASCII := FALSE; USER ^.ENCOUNTSTOP := FALSE; WRITE(USER ^.TRM);
CASE USER ^.ENTRY OF
XNAME: WRITELN(COL, 'I', 'E^N^T^E^R ^Y^O^U^R ^N^A^M^E ', COL, 'A');
XNEWCLASS: WRITELN('CLASS ', COL, 'A');
XSTATS: WRITELN('STATS ', COL, 'A');
XSKILL: WRITELN('SKILL ', COL, 'A');
XSEX: WRITELN('FINALLY, IS YOUR CHARACTER A (M)ALE OR (F)EMALE?');
XCMD:
IF USER ^.BRIEF THEN WRITELN(COL, 'I', 'D^O ', COL, 'A')
ELSE WRITELN(COL, 'I', 'A^C^T^I^O^N ', COL, 'A');
XPASSWORD:
BEGIN WRITELN('ENTER YOUR PASSWORD'); WRITEPWMASK(USER ^.TRM);
END (*XPASSWORD*);
XNEWPW: WRITELN('ENTER ACCESS PASSWORD ', COL, 'A');
XCHANGEPW: WRITELN('ENTER NEW PASSWORD', COL, 'A');
XEDIT:
IF USER ^.BRIEF THEN WRITELN('ED', COL, 'A')
ELSE WRITELN('EDIT COMMAND', COL, 'A');
XNOTICE: WRITELN('ENTER NOTICE', COL, 'A');
XDEAD:
BEGIN
WRITELN('CONGRATULATIONS! YOUR DEATH HAS MADE THE NEWSPAPERS!');
WRITELN(TERM, 'IN ONE LINE, TRY TO EXPLAIN WHAT KILLED YOU AND HOW. USE');
WRITELN(TERM, 'WORDS LIKE "HE" AND "SHE" INSTEAD OF "I".');
WRITELN(TERM,
'EXAMPLE: "HIS WEAPON BROKE, AND BEFORE HE KNEW IT THE VAMPIRE');
WRITELN(TERM, 'DRAINED HIS LIFE AWAY.."');
END (*XDEAD*);
XSPELL: WRITELN('SAY CHANT ', COL, 'A');
XNEWS: WRITELN('ENTER NEWS', COL, 'A');
XSELL, XREPAIR: WRITELN('YES/NO', COL, 'A');
XWISH: WRITELN('ENTER WISH', COL, 'A');
XSURE: WRITELN('ARE YOU SURE', COL, 'A');
XPARLEY: WRITELN('WOULD YOU LIKE TO HAVE IT, EFFENDI', COL, 'A');
END (*CASE*);
REQUESTINPUT(USER ^.TRM, ASCII);
END (*ELSE*)
END (*PROMPTUSER*);
PROCEDURE FINDLIMBO(VAR TERM: ALFA; VAR INDX: INTEGER; PRIORITY: BOOLEAN);
(* SCAN FOR A USER IN THE WAITING QUEUE *)
VAR
ILOOP: INTEGER;
PLACED: BOOLEAN;
BEGIN
IF PRIORITY
THEN
BEGIN
INDX := 1;
FOR ILOOP := 1 TO MAXQUEUE DO
IF (QUEUE[ILOOP].QTIME < QUEUE[INDX].QTIME) AND (QUEUE[ILOOP].QTIME <> 0) OR (
QUEUE[INDX].QTIME = 0)
THEN INDX := ILOOP;
TERM := QUEUE[INDX].QTERM;
IF TERM = BLANKS THEN ABORT(' MIL532 - QUEUED TERM NOT FOUND!');
END (*IF*)
ELSE
BEGIN
PLACED := FALSE; INDX := 0;
WHILE NOT PLACED AND (INDX < MAXQUEUE) DO
BEGIN INDX := INDX + 1; PLACED := (TERM = QUEUE[INDX].QTERM) END;
IF NOT PLACED THEN INDX := 0;
END (*ELSE*)
END (*FINDLIMBO*);
FUNCTION FINDUSER(WORD: ALFA; USERTAIL: USERPOINT): USERPOINT;
FORWARD;
PROCEDURE GETSTATUS(WORD: ALFA; USER: USERPOINT);
(* OBTAIN A LISTING OF ALL ACTIVE USERS *)
VAR
PLAYER: USERPOINT;
PROCEDURE DISPSTATUS(PLR: USERPOINT);
VAR
TERMNUM: INTEGER;
BEGIN
WITH PLR ^ DO
BEGIN
TERMNUM := ORD(TRM[9]) * 64 + ORD(TRM[10]);
WRITE(TERM,NAME,' ');
IF MESBLOCK THEN WRITE('*') ELSE WRITE(' ');
WRITE(' ', TERMNUM: 3 OCT, ' ', LASTCMD, ' ');
IF LVL >= 10
THEN
CASE CLASS OF
FIGHTER: IF SEX=MALE THEN WRITE('LORD ') ELSE WRITE('LADY ');
THIEF: WRITE('MASTER THIEF ');
MAGICUSER: WRITE('WIZARD ');
CLERIC: IF LVL>=15 THEN WRITE('SAINT ') ELSE WRITE('HIGH PRIEST ');
BARBARIAN: WRITE('BARBARIAN CHIEFTAIN ');
RANGER: IF SEX=MALE THEN WRITE('RANGER LORD ') ELSE WRITE('AMAZON ');
PALADIN: IF SEX=MALE THEN WRITE('LORD OF THE QUEST ') ELSE
WRITE('LADY OF THE QUEST ');
OTHERWISE
WRITE(PS(CNAME[CLASS]), ' ')
END (*CASE*)
ELSE WRITE(PS(CNAME[CLASS]), ' ');
IF USER ^.SSJ THEN WRITE(LVL: 0, ' ');
IF NONEXISTANT THEN WRITE(' (NONEXIST)')
ELSE IF INVISIBLE THEN WRITE(' (INV)');
IF USER ^.MASTER AND (SEX = FEMALE) THEN WRITE('(F) ');
IF USER ^.SSJ THEN IF STATUS = SNORMAL THEN WRITE('(', W(RMCODE): 0, ')');
WRITELN;
END (*WITH*);
END (*DISPSTATUS*);
BEGIN (*GETSTATUS*)
WRITELN(TERM);
IF NOT USER ^.BRIEF
THEN WRITELN(TERM, 'NAME UN S TRM LASTCMD CLASS');
IF WORD <> BLANKS
THEN
BEGIN
PLAYER := FINDUSER(WORD, USERTAIL);
IF PLAYER = NIL THEN WRITELN(TERM, 'PLAYER NOT ACTIVE.')
ELSE
IF NOT PLAYER ^.NONEXISTANT THEN DISPSTATUS(PLAYER)
ELSE WRITELN(TERM, 'PLAYER NOT ACTIVE.')
END (*IF*)
ELSE
BEGIN
PLAYER := USERTAIL;
REPEAT
IF (NOT PLAYER ^.INVISIBLE AND (PLAYER ^.STATUS = SNORMAL)) OR USER ^.SSJ
THEN DISPSTATUS(PLAYER);
PLAYER := PLAYER ^.NEXTUSER
UNTIL PLAYER = NIL
END (*ELSE*)
END (*GETSTATUS*);
FUNCTION LOGIN(VAR PARM: PARMBLOCK; VAR TERM: ALFA; VAR BUFFER: BUFTYPE; VAR NUSERS:
INTEGER; VAR PLAYERTAIL: USERPOINT): USERPOINT;
PROCEDURE ADDLIMBO(TERM: ALFA; ONTIME: INTEGER; UN: ALFA7);
(* ADD A USER TO THE WAITING QUEUE *)
VAR
N, COUNT, ILOOP: INTEGER;
PLACED: BOOLEAN;
BEGIN
PLACED := FALSE; ILOOP := 0; COUNT := 0;
WHILE (ILOOP < MAXQUEUE) AND NOT PLACED DO
BEGIN ILOOP := ILOOP + 1; PLACED := (QUEUE[ILOOP].QTERM = BLANKS) END;
IF NOT PLACED
THEN
BEGIN
WRITELN(TERM, 'SORRY, THE WAITING ROOM IS FULL.');
WRITECONTROL(MTLO, ZEROPARM, TERM); WRITELN;
END (*IF*)
ELSE
BEGIN
N := ILOOP;
FOR ILOOP := 1 TO MAXQUEUE DO
IF QUEUE[ILOOP].QTERM <> BLANKS THEN
WRITELN(QUEUE[ILOOP].QTERM, 'PERSON FROM ', PS(UN),
' ENTERS THE WAITING ROOM.');
QUEUE[N].QTERM := TERM; QUEUE[N].QUN := UN; QUEUE[N].QTIME := ONTIME;
COUNT := 0;
FOR ILOOP := 1 TO MAXQUEUE DO
IF QUEUE[ILOOP].QTERM <> BLANKS THEN COUNT := COUNT + 1;
WRITELN(TERM, 'YOU ENTER THE WAITING ROOM, SIT DOWN, AND READ A MAGAZINE.');
WRITELN(TERM, 'YOU ARE THE ', PNTH(COUNT), 'PERSON ON THE WAITING LIST.');
WRITELN(TERM, 'HIT THE <BREAK> KEY IF YOU DO NOT WISH TO WAIT.');
WRITELN(TERM); WRITELN(TERM, 'WAITING...'); WRITELN(TERM);
NUMQUEUED := NUMQUEUED + 1;
END (*ELSE*);
END (*ADDLIMBO*);
BEGIN (*LOGIN*)
NUSERS := NUSERS + 1; NOPROMPT := FALSE;
IF NOT FIRSTLOGIN
THEN
BEGIN
NEW(NEWUSER) (*SET UP NEW USERBLOCK*);
NEWUSER ^ := PROTOUSER (* SET DEFAULTS *);
PACK(BUFFER, 1, NEWUSER ^.UN) (*PACK USERNUM INTO USER^*); ILOOP := 7;
WHILE NEWUSER ^.UN[ILOOP] = COL DO
BEGIN NEWUSER ^.UN[ILOOP] := ' '; ILOOP := ILOOP - 1 END;
READCONTROL(CONTROL, DUMPARM, TERM, BUFFER, LENBUF, LOGLEN);
END (*IF*)
ELSE NEWUSER := USER (*FIRST LOGIN ONLY*);
ILOOP := 1; FOUND := FALSE;
WHILE (ILOOP <= LENBUF) AND NOT FOUND DO
BEGIN FOUND := (BUFFER[ILOOP] IN [')', '.']); ILOOP := ILOOP + 1 END;
IF FOUND THEN BEGIN LOC := ILOOP; NOPROMPT := (LENBUF >= LOC) END;
VALIDLOGIN := GOOD; GETSEG(EDESC, 10000); GETSEG(EDESC, - 2);
WHILE NOT EOS(EDESC) DO
BEGIN
I := 0; PREVCH := ' ';
WHILE NOT EOLN(EDESC) AND (I < 7) DO
BEGIN
I := I + 1; READ(EDESC, CH);
IF CH <> NEWUSER ^.UN[I] THEN
IF CH <> '$' THEN I := 1000
ELSE IF (PREVCH <> '$') AND (NEWUSER ^.UN[I] = '*') THEN I := 500;
PREVCH := CH
END (*WHILE*);
IF (I >= 0) AND (I <= 7)
THEN
IF (EDESC ^ <> 'P') OR (CLOCKTIME > ' 07.00.00.') AND (CLOCKTIME < ' 15.00.00.'
) AND (DAY IN [0..4])
THEN
BEGIN
READ(EDESC, CH); WRITE(TERM, 'THIS USERNUMBER HAS BEEN LOCKED OFF MILIEU ');
IF CH = 'P' THEN WRITE('DURING PEAK TIME. '); WRITELN; WRITE(TERM);
WHILE NOT EOLN(EDESC) DO BEGIN READ(EDESC, CH); WRITE(CH) END; WRITELN;
VALIDLOGIN := BAD
END (*IF*);
READLN(EDESC)
END (*WHILE*);
IF NEWUSER ^.UN[7] = '*' THEN
WRITELN(TERM, 'MASTER USER: WRITE TO CODENAME "MILIEU" TO BLOCK SUBORDINATES.');
IF (NEWUSER^.UN = BADUN) THEN
IF BADCOUNT >= 3 THEN
BEGIN VALIDLOGIN := BAD;
WRITELN(TERM,'USERNUMBER AUTO-LOCKED OFF DUE TO PW GUESSING.')
END;
CURRENTREC := 0; I := LOC (*TEMP STORAGE*); WORD := BLANKS; NUM := 0;
IF NOPROMPT THEN GETWORD(WORD, NUM, BUFFER, LENBUF, LOC);
LOC := I (*RESTORE LOC INDEX*);
IF WORD = '+ '
THEN
BEGIN
VALIDLOGIN := BAD;
IF PLAYERTAIL = NIL THEN WRITELN(TERM, 'NO ACTIVE USERS.')
ELSE GETSTATUS(BLANKS, NEWUSER);
END (*IF*)
ELSE
IF SUBSET(WORD, '/FLASH ') AND (WORD <> BLANKS)
THEN
BEGIN
VALIDLOGIN := BAD; I := LOC; GETWORD(WORD, NUM, BUFFER, LENBUF, LOC);
GETWORD(WORD, NUM, BUFFER, LENBUF, LOC);
USFLASH := FINDUSER(WORD, PLAYERTAIL);
IF USFLASH = NIL THEN WRITELN(TERM, 'PLAYER NOT FOUND.')
ELSE
IF REALTIME - ACTIVETRM(TERM) < 20
THEN WRITELN(TERM, 'PLEASE WAIT 20 MORE SECONDS BEFORE TRYING AGAIN.')
ELSE
IF USFLASH ^.MESBLOCK OR USFLASH ^.SSJ THEN WRITELN(TERM, 'MESSAGE BLOCKED.')
ELSE
BEGIN
WRITELN(USFLASH ^.TRM, 'YOU HEAR A VOICE COME FROM OUT OF NOWHERE:');
TNUM := ORD(TERM[9]) * 64 + ORD(TERM[10]);
WRITE(USFLASH ^.TRM, 'T', TNUM: 3 OCT, ' ');
FOR ILOOP := LOC + 1 TO MIN(LOC + 1 + 80, LENBUF) DO WRITE(BUFFER[ILOOP]);
WRITELN; WRITELN(TERM, 'MESSAGE SENT.');
END (*ELSE*);
LOC := I;
END (*IF*)
ELSE
BEGIN
IF NUSERS > MAXUSERS
THEN
BEGIN
IF (WORD <> AUTHOR) AND (WORD <> 'RINGTHANE ') OR (NUSERS > MAXPLUSONE)
THEN
BEGIN
IF VALIDLOGIN <> BAD THEN VALIDLOGIN := QUEUED;
WRITELN(TERM, 'TOO MANY ACTIVE USERS ARE ON THE TASK.')
END (*IF*);
END (*IF*);
I := ACTIVETRM(TERM);
IF I > 0
THEN
IF REALTIME - UNACTIVE[I].OFFTIME < 45
THEN
BEGIN
IF (WORD <> AUTHOR) AND (WORD <> 'RINGTHANE ')
THEN
BEGIN
VALIDLOGIN := BAD;
WRITELN(TERM, 'PLEASE WAIT ', 45 - (REALTIME - UNACTIVE[I].OFFTIME): 0,
' MORE SECONDS BEFORE TRYING AGAIN.');
END (*IF*);
END (*IF*)
ELSE UNACTIVE[I].OFFTIME := REALTIME
END (*ELSE*);
IF VALIDLOGIN IN [BAD, QUEUED]
THEN
BEGIN
IF VALIDLOGIN = QUEUED
THEN
BEGIN
IF I > 0 THEN UNACTIVE[I].OFFTERM := BLANKS;
IF (WORD='HALINDROME') OR (WORD='THOST ') OR (WORD='YENDAR ')
OR (WORD='SNOOPY ') THEN
ADDLIMBO(TERM,1,NEWUSER^.UN) ELSE
ADDLIMBO(TERM, REALTIME, NEWUSER ^.UN)
END (*IF*)
ELSE BEGIN WRITECONTROL(MTLO, ZEROPARM, TERM); WRITELN (* LOG OUT USER *) END;
DISPOSE(NEWUSER); LOGIN := NIL; NUSERS := NUSERS - 1
END (*IF*)
ELSE
BEGIN
IF I > 0 THEN UNACTIVE[I].OFFTERM := BLANKS; WRITE(TERM);
PRINTDESC(1, 1, 0, FALSE) (* "MILIEU" *);
WRITELN(' V^E^R ', VERSION, ' (R^U^N ', NUMRUN: 0, ')');
WITH NEWUSER ^ DO
BEGIN ENTRY := XNAME; STATUS := SLOGIN; TRM := TERM; NEXTUSER := PLAYERTAIL
END (*WITH*);
PLAYERTAIL := NEWUSER; LOGIN := NEWUSER (* PASS NEW USER TO MAIN ROUTINE *);
END (*ELSE*);
END (*LOGIN*);
PROCEDURE ENTERNOTICE;
VAR
ILOOP: INTEGER;
BEGIN
DAYMSG('NOT', USER, BLANKS, 0);
FOR ILOOP := 1 TO MIN(LENBUF, 78) DO NOTICE[ILOOP] := BUFFER[ILOOP];
FOR ILOOP := LENBUF + 1 TO 80 DO NOTICE[ILOOP] := COL; USER ^.ENTRY := XCMD;
PROMPTUSER(USER);
END (*ENTERNOTICE*);
PROCEDURE ENTERNEWS;
VAR
ILOOP, JLOOP: INTEGER;
FOUND: BOOLEAN;
BEGIN
ILOOP := 1; FOUND := FALSE;
WHILE NOT FOUND AND (ILOOP <= 5) DO
BEGIN FOUND := (NEWSBUF[ILOOP, 1] = COL); ILOOP := ILOOP + 1 END;
IF NOT FOUND THEN WRITELN(TERM, '*DELETE A LINE FIRST.')
ELSE
BEGIN
ILOOP := ILOOP - 1;
FOR JLOOP := 1 TO MIN(LENBUF, 78) DO NEWSBUF[ILOOP, JLOOP] := BUFFER[JLOOP];
FOR JLOOP := LENBUF + 1 TO 80 DO NEWSBUF[ILOOP, JLOOP] := COL;
WRITELN(TERM, 'ENTERED AS LINE ', ILOOP: 0);
END (*ELSE*);
USER ^.ENTRY := XCMD; PROMPTUSER(USER);
END (*ENTERNEWS*);
PROCEDURE ENTERSEX(USER: USERPOINT);
VAR
CH: CHAR;
WORD: ALFA;
NUM: INTEGER;
BEGIN
WITH USER ^ DO
BEGIN
GETWORD(WORD, NUM, BUFFER, LENBUF, LOC); CH := WORD[1]; ENTRY := XCMD;
IF CH = 'M' THEN SEX := MALE
ELSE
IF CH = 'F' THEN SEX := FEMALE
ELSE BEGIN ENTRY := XSEX; NOPROMPT := FALSE; WRITELN(TERM, 'TRY AGAIN.') END;
IF ENTRY = XCMD THEN
BEGIN PLACEPLAYER(USER, 1); NOPROMPT := FALSE; ANNOUNCELOGIN(USER)
END (*IF*);
PROMPTUSER(USER);
END (*WITH*);
END (*ENTERSEX*);
PROCEDURE NEWPW(USER: USERPOINT);
VAR
PASSWORD: ALFA;
DUMMY: INTEGER;
BEGIN
GETWORD(PASSWORD, DUMMY, BUFFER, LENBUF, LOC);
IF PASSWORD <> BLANKS
THEN BEGIN USER ^.PW := HASH(PASSWORD,10); USER ^.ENTRY := XSEX; END;
PROMPTUSER(USER);
END (*NEWPW*);
PROCEDURE ENTERSTATS(USER: USERPOINT);
VAR
DUMMY: ALFA;
ILOOP, SUM, NUM: INTEGER;
BADNUM: BOOLEAN;
STAT: ARRAY [1..5] OF INTEGER;
BEGIN
SUM := 0; ILOOP := 1; BADNUM := FALSE;
REPEAT
GETWORD(DUMMY, NUM, BUFFER, LENBUF, LOC); STAT[ILOOP] := NUM; SUM := SUM + NUM;
ILOOP := ILOOP + 1; BADNUM := ((NUM < 5) OR (NUM > 18));
UNTIL BADNUM OR (ILOOP > 5);
IF BADNUM
THEN
BEGIN
WRITELN(TERM, 'ERROR. A NUMBER IS MORE THAN 18 OR LESS THAN 5.');
USER ^.ENTRY := XSTATS; NOPROMPT := FALSE
END (*IF*)
ELSE
IF SUM / 5 > 10.1
THEN
BEGIN
WRITELN(TERM, 'ERROR. YOUR AVERAGE IS ', SUM / 5: 2: 1);
USER ^.ENTRY := XSTATS; NOPROMPT := FALSE
END (*IF*)
ELSE
WITH USER ^ DO
BEGIN
STR := STAT[1]; INT := STAT[2]; DEX := STAT[3]; PTY := STAT[4];
CON := STAT[5]; ENTRY := XSKILL;
END (*WITH*);
IF (USER ^.ENTRY = XSKILL) AND NOT NOPROMPT
THEN
BEGIN
WRITELN(TERM, 'WHICH WEAPON IS YOUR MOST SKILLFUL?');
WRITELN(TERM, 'CHOOSE FROM: SHARP WEAPON, THRUSTING WEAPON, BLUNT WEAPON,');
WRITELN(TERM, 'OR POLE WEAPON.');
END (*IF*);
PROMPTUSER(USER);
END (*ENTERSTATS*);
PROCEDURE ENTERSKILL(USER: USERPOINT);
VAR
WORD: ALFA;
NUM: INTEGER;
CH: CHAR;
BEGIN
USER ^.ENTRY := XNEWPW; GETWORD(WORD, NUM, BUFFER, LENBUF, LOC); CH := WORD[1];
WITH USER ^ DO
CASE CH OF
'S': SSHARP := 1;
'T': STHRUST := 1;
'B': SBLUNT := 1;
'P': SLONG := 1; OTHERWISE NOPROMPT := FALSE;
ENTRY := XSKILL; WRITELN(TERM, 'NO SUCH SKILL. TRY AGAIN.'); END; PROMPTUSER(
USER) END;
PROCEDURE CHOOSECLASS(USER: USERPOINT);
VAR WORD: ALFA; NUM: INTEGER;
CH: CHAR;
BEGIN WITH USER ^ DO BEGIN CLASS := CL; MAXHITS := VIT; HITS := VIT; MAXFATIGUE
:= FAT; FATIGUE := FAT; MAXMAGIC := MAG; MAGIC := MAG; MONEY := MONY
END (*WITH*)
END;
BEGIN USER^.ENTRY := XSTATS; GETWORD(WORD,NUM,BUFFER,LENBUF,LOC);
CH := WORD[1]; WITH USER ^ DO
CASE CH OF
'F':
SETSTATS(FIGHTER, 8, 14, 2, 200);
'T': SETSTATS(THIEF, 7, 10, 3, 130);
'M': SETSTATS(MAGICUSER, 6, 9, 6, 150);
'C': SETSTATS(CLERIC, 7, 11, 4, 80);
'R': SETSTATS(RANGER, 7, 11, 3, 150);
'P': SETSTATS(PALADIN, 11, 8, 3, 140);
OTHERWISE
NOPROMPT := FALSE; ENTRY := XNEWCLASS;
WRITELN(TERM, 'NO SUCH CLASS. TRY AGAIN.')
END (*CASE*);
IF (USER ^.ENTRY = XSTATS) AND NOT NOPROMPT
THEN
BEGIN
WRITELN(TERM, 'CHOOSE YOUR CHARACTER''S ATTRIBUTES FOR STRENGTH, INTELLIGENCE,')
;
WRITELN(TERM, ' DEXTERITY, PIETY, AND CONSTITUTION.');
WRITELN(TERM, '(EXAMPLE: 13,7,10,11,5) EACH MUST BE FROM 5 TO 18 AND');
WRITELN(TERM, 'THE TOTAL AVERAGE MUST BE 10 OR LESS.');
END (*IF*);
PROMPTUSER(USER);
END (*CHOOSECLASS*);
PROCEDURE NEXTLIMBO;
(* FETCH NEXT USER FROM WAITING ROOM *)
VAR
TM: ALFA;
INDX, ILOOP: INTEGER;
QUSER: USERPOINT;
BEGIN
FINDLIMBO(TM, INDX, TRUE);
IF (TM <> BLANKS) AND (NUSERS < MAXUSERS)
THEN
BEGIN
NEW(QUSER); QUSER ^ := PROTOUSER; ILOOP := ACTIVETRM(TM);
IF ILOOP > 0 THEN UNACTIVE[ILOOP].OFFTERM := BLANKS;
WRITELN(TM, COL, 'I', CHR(76B), CHR(47B)) (* SEND BELL *); WRITE(TM);
PRINTDESC(1, 1, 0, FALSE);
WRITELN(' V^E^R ', VERSION, ' (R^U^N ', NUMRUN: 0, ')');
WITH QUSER ^ DO
BEGIN
UN := QUEUE[INDX].QUN; ENTRY := XNAME; STATUS := SLOGIN; TRM := TM;
NEXTUSER := USERTAIL; USERTAIL := QUSER;
END (*WITH*);
NOPROMPT := FALSE; NUSERS := NUSERS + 1;
FOR ILOOP := 1 TO MAXQUEUE DO
IF QUEUE[ILOOP].QTERM <> BLANKS
THEN BEGIN WRITELN(QUEUE[ILOOP].QTERM, 'PAGING PERSON FROM ', PS(QUSER ^.UN), '!');
IF QUEUE[INDX].QTIME = 1 THEN
WRITELN(QUEUE[ILOOP].QTERM,'(DM QUEUE OVERRIDE)')
END;
DELETELIMBO(TM); PROMPTUSER(QUSER);
END (*IF*)
END (*NEXTLIMBO*);
PROCEDURE LOGOFF(USR: USERPOINT; LOGQUEUE: BOOLEAN);
(* LOGOFF LOGS OFF THE USER, AND SAVES HIS FILE (IF ROOM LEFT).
*NOTE* USR IS NOT A VAR PARAMETER. IT IS DISPOSED
IN WRITEPLAYER BUT MAY BE NEEDED AGAIN FOR ABORT! *)
VAR
ILOOP: INTEGER;
BEGIN
IF NOT (USR ^.STATUS IN [SLOGIN, SINIT]) OR (USR ^.ENTRY = XDEAD)
THEN
BEGIN
DELETEUSER(USR, USERTAIL);
IF WHICHCONTROL = MTHU
THEN
BEGIN
IF USR ^.LVL >= 5 THEN DAYMSG('HUP', USR, BLANKS, 0);
USR ^.CON := MAX(3, USR ^.CON - 1) (*TAKE AWAY CON AS PUNISHMENT*);
FOR ILOOP := 1 TO MSGTERM(TERMLIST, OTHERS) DO
BEGIN
WRITE(TERMLIST[ILOOP], '### ', PS(USR ^.NAME): 0,
', THE COWARD, JUST HUNG UP ');
IF USR ^.SEX = MALE THEN WRITELN('HIS PHONE.')
ELSE WRITELN('HER PHONE.')
END (*FOR*)
END (*IF*);
IF USR ^.LVL >= 2 THEN WRITEPLAYER(USR, USR ^.NAME)
ELSE
BEGIN
IF WHICHCONTROL <> MTHU THEN
WRITELN(TERM, 'SORRY, YOU MUST BE AT LEAST 2ND LEVEL TO SAVE YOUR CHARACTER.'
);
WRITEUSR(USR, FALSE) (*DISPOSE USR + OBJECTS*)
END (*ELSE*);
END (*IF*)
ELSE
BEGIN USR ^.RMCODE := 0; DELETEUSER(USR, USERTAIL); WRITEUSR(USR, FALSE); END;
USR := NIL; NUSERS := NUSERS - 1;
IF LOGQUEUE AND (NUMQUEUED > 0) THEN NEXTLIMBO;
END (*LOGOFF*);
PROCEDURE ROLLOUT(TERMNUM: ALFA);
FORWARD;
PROCEDURE ROLLCHECK(TRM: ALFA);
(* CHECK IF 40 RA+1 CALLS HAVE BEEN ISSUED. IF SO, DO A ROLLOUT *)
BEGIN IF RA >= 40 THEN ROLLOUT(TRM) END;
PROCEDURE OFF;
(* OFF - KICK OFF ALL USERS AND SAVE THEIR FILES IN PREPARATION FOR
A PTA. 4 RA+1S ARE DONE FOR EACH LOGOFF. SO ROLLOUTS MUST BE DONE *)
BEGIN
ERRLOC := 'OFF '; ROLLOUT(TERM); USER := USERTAIL;
WHILE USER <> NIL DO
BEGIN
TERM := USER ^.TRM; ROLLCHECK(TERM);
USER := USERTAIL (* IN CASE THE PREVIOUS USER HUNG UP *); TERM := USER ^.TRM;
LOGOFF(USER, FALSE); WRITECONTROL(MTLO, ZEROPARM, TERM); WRITELN;
USER := USERTAIL
END (*WHILE*)
END (*OFF*);
PROCEDURE SETDAYFILE;
VAR
CH: CHAR;
TEMP: SEGCHARFIL;
BEGIN
RESET(DAYFILE); REWRITE(TEMP); GETSEG(DAYFILE, 10000); ROLLCHECK(TERM);
GETSEG(DAYFILE, - DAYRECLEN); ROLLCHECK(TERM);
WHILE NOT EOF(DAYFILE) DO
BEGIN
WHILE NOT EOS(DAYFILE) DO
BEGIN
WHILE NOT EOLN(DAYFILE) DO BEGIN READ(DAYFILE, CH); WRITE(TEMP, CH); END;
READLN(DAYFILE); WRITELN(TEMP);
END (*WHILE*);
PUTSEG(TEMP); GETSEG(DAYFILE); ROLLCHECK(TERM);
END (*WHILE*);
REWRITE(DAYFILE); RESET(TEMP); ROLLCHECK(TERM);
WHILE NOT EOF(TEMP) DO
BEGIN
WHILE NOT EOS(TEMP) DO
BEGIN
WHILE NOT EOLN(TEMP) DO BEGIN READ(TEMP, CH); WRITE(DAYFILE, CH); END;
READLN(TEMP); WRITELN(DAYFILE);
END (*WHILE*);
GETSEG(TEMP); IF NOT EOF(TEMP) THEN PUTSEG(DAYFILE); ROLLCHECK(TERM);
END (*WHILE*);
END (*SETDAYFILE*);
PROCEDURE MATCHPW(USER: USERPOINT);
(* MATCHPW COMPARES THE PASSWORD ENTERED TO THE ONE IN USER^.
*)
VAR
PASSWORD: ALFA;
DUMMY: INTEGER;
BEGIN
GETWORD(PASSWORD, DUMMY, BUFFER, LENBUF, LOC);
IF NOT NOPROMPT THEN WRITELN(TERM,'ZZZZZZZZZZ');
DUMMY := HASH(USER^.UN,5);
IF (USER^.UNHASH DIV DUMMY * DUMMY <> USER^.UNHASH) AND NOT (USER^.UNHASH IN [0,1])
THEN
BEGIN
NOPROMPT := FALSE;
WRITELN(TERM,'IMPROPER USERNUMBER, SORRY.');
LOGOFF(USER,TRUE); WRITECONTROL(MTLO,ZEROPARM,TERM);
WRITELN
END
ELSE
IF HASH(PASSWORD,10) <> USER ^.PW
THEN
BEGIN
NOPROMPT := FALSE;
IF USER ^.SSJ
THEN (* 4-BYTE THE SUCKER *)
BEGIN WRITELN(TERM, COL, 'D'); DAYMSG('ILL', USER, 'ILLEGAL PW', 0);
IF USER^.UN = BADUN THEN BEGIN
BADCOUNT := BADCOUNT + 1;
IF BADCOUNT >= 3 THEN
DAYMSG('BLO',USER,'UN BLOCKED',0);
END
ELSE
BADCOUNT := 1;
BADUN := USER^.UN;
END
ELSE WRITELN(TERM, 'WRONG PASSWORD, SORRY.');
LOGOFF(USER, TRUE); WRITECONTROL(MTLO, ZEROPARM, TERM); WRITELN;
END (*IF*)
ELSE
BEGIN
NOPROMPT := FALSE;
PLACEPLAYER(USER, USER ^.RMCODE); ANNOUNCELOGIN(USER); USER ^.ENTRY := XCMD;
PROMPTUSER(USER)
END (*ELSE*)
END (*MATCHPW*);
PROCEDURE GETNAM(USER: USERPOINT);
(* GETNAM LOOKS IN THE PERSON FILE TO SEE IF THE NAM IN
THE BUFFER IS AN OLD CHARACTER. IF NOT, IT BEGINS THE PROMPTING
TO DESIGN A NEW ONE. THE SEARCH FOR OLD CHARACTERS IS DONE USING
A "TARGET BOARD" OF CODENAMS AND INDEXES IN ORDER TO SPEED UP
THE SEARCH. *)
BEGIN (*GETNAM*)
GETWORD(NAM, DUMMY, BUFFER, LENBUF, LOC); I1 := 1;
WHILE I1 <= 10 DO
IF NOT (NAM[I1] IN ['A' .. 'Z', ' '])
THEN BEGIN FOR I2 := I1 + 1 TO 10 DO NAM[I2 - 1] := NAM[I2]; NAM[10] := ' ' END
ELSE I1 := I1 + 1;
IF (DUMMY <> 0) OR (NAM = BLANKS)
THEN
BEGIN
NOPROMPT := FALSE; WRITELN(TERM, 'BAD CHARACTERS IN NAME.'); PROMPTUSER(USER)
END (*IF*)
ELSE
BEGIN
OTHER := MATCHUSER(USERTAIL, SAMENAME);
IF OTHER <> NIL
THEN
BEGIN
NOPROMPT := FALSE; WRITELN(TERM, 'NAME ALREADY IN USE!');
LOGOFF(USER, TRUE); WRITECONTROL(MTLO, ZEROPARM, TERM); WRITELN
END (*IF*)
ELSE
IF NAM = 'STOP '
THEN
BEGIN
NOPROMPT := FALSE; LOGOFF(USER, TRUE); WRITECONTROL(MTLO, ZEROPARM, TERM);
WRITELN
END (*IF*)
ELSE
WITH USER ^ DO
BEGIN
TEMPNEXT := NEXTUSER; READPLAYER(USER, NAM); STATUS := SLOGIN;
TRM := TERM; NEXTUSER := TEMPNEXT;
LASTINPUT := REALTIME;
IF NOT SSJ AND ((TASKCLOSED = 'C') OR (TASKCLOSED = 'T') AND NOT PLAYTESTER)
THEN
BEGIN
WRITELN(TERM, 'AS YOU APPROACH THE GATES, A LITTLE GNOME JUMPS OUT FROM');
WRITELN(TERM,
'BEHIND A ROCK. HE WHINES "GO BACK! THE MASTERS ARE NOT READY');
WRITELN(TERM, 'FOR YOU YET!" THE GNOME THEN DISAPPEARS INTO THE BRUSH.');
NOPROMPT := FALSE; LOGOFF(USER, TRUE);
WRITECONTROL(MTLO, ZEROPARM, TERM); WRITELN (*LOG OFF*);
END (*IF*)
ELSE
IF NOT SSJ AND (CLOCKTIME >= ' 00.58.00.') AND (CLOCKTIME <= ' 07.05.00.')
AND (DAY IN [0..4])
THEN
BEGIN
WRITELN(TERM,
'YOU APPROACH THE GATES IN THE DARK OF NIGHT. SUDDENLY A TIRED GNOME')
;
WRITELN(TERM,
'JUMPS OUT FROM BEHIND A ROCK! HE YELLS, "EVERYTHING IS CLOSED');
WRITELN(TERM,
'FOR THE NIGHT... COME BACK AT SUNRISE!". THE GNOME THEN STOMPS OFF');
WRITELN(TERM, 'TO RESUME HIS NAP.'); NOPROMPT := FALSE;
LOGOFF(USER, TRUE); WRITECONTROL(MTLO, ZEROPARM, TERM); WRITELN
END (*IF*)
ELSE
IF USER ^.NAME = EMPTY
THEN
BEGIN
NAME := NAM; ENTRY := XNEWCLASS (* ASK FOR NEW CLASS *);
IF NOT NOPROMPT
THEN
BEGIN
WRITELN(TERM, 'PLEASE SELECT YOUR CHARACTER''S CLASS:');
WRITELN(TERM,
'FIGHTER, THIEF, CLERIC, PALADIN, RANGER, OR MAGIC-USER.');
END (*IF*);
PROMPTUSER(USER)
END (*IF*)
ELSE
BEGIN
ENTRY := XPASSWORD (* ASK FOR PW *);
IF LOC < LENBUF THEN MATCHPW(USER) ELSE PROMPTUSER(USER)
END (*ELSE*);
END (*WITH*)
END (*ELSE*)
END (*GETNAM*);
FUNCTION BINARYMATCH(WORD: ALFA; COUNT: INTEGER; VAR NAMELIST: DYNAMIC NAMETYPELIST)
: INTEGER;
(* DO A BINARY SEARCH OF A ALPHABETIZED LIST *)
VAR
LOWER, UPPER, POS: INTEGER;
BEGIN
IF WORD = BLANKS THEN BINARYMATCH := 0
ELSE
BEGIN
LOWER := 1; UPPER := COUNT;
REPEAT
POS := (LOWER + UPPER) DIV 2; IF NAMELIST[POS] <= WORD THEN LOWER := POS + 1;
IF NAMELIST[POS] >= WORD THEN UPPER := POS - 1
UNTIL (LOWER > UPPER);
IF NAMELIST[POS] = WORD THEN BINARYMATCH := POS
ELSE
IF POS = 1 THEN BINARYMATCH := 0
ELSE
BEGIN
IF NOT SUBSET(WORD, NAMELIST[POS]) THEN POS := POS - 1; BINARYMATCH := POS;
IF NOT SUBSET(WORD, NAMELIST[POS]) THEN BINARYMATCH := 0
ELSE
IF POS > 1 THEN
IF SUBSET(WORD, NAMELIST[POS - 1]) THEN
BEGIN WRITELN(TERM, PS(WORD), ' IS NOT UNIQUE.'); BINARYMATCH := - 1 END
END (*ELSE*)
END (*ELSE*);
END (*BINARYMATCH*);
FUNCTION WORDMATCH(WORD: ALFA; COUNT: INTEGER; VAR NAMELIST: DYNAMIC NAMETYPELIST):
INTEGER;
(* THIS ROUTINE IS SEARCHES A TABLE (NAMELIST) TO SEE IF THE
USER TYPED IN SOMETHING RECOGNIZABLE. IT RECOGNIZES A MATCH
WHEN IT READS THE MINIMUM NUMBER OF LETTERS TO MAKE THE ENTRY
UNIQUE. THE INDEX NUMBER IS RETURNED. INDEX = -1 IF NOT UNIQUE,
AND IT ISSUES AN APPROPRIATE MESSAGE. INDEX = 0 IF NOT FOUND,
AND THE CALLING PROGRAM MUST ISSUE ITS OWN MESSAGE. *)
VAR
ILOOP, JLOOP: INTEGER;
FOUND: BOOLEAN;
BEGIN
IF (COUNT < 0) OR (COUNT > HIGH(NAMELIST))
THEN ABORT(' MIL03 - BAD PARSE COUNT!');
IF (COUNT = 0) OR (WORD = BLANKS)
THEN WORDMATCH := 0 (* ITEM NOT FOUND BY DEFAULT *)
ELSE
BEGIN (* SCAN LIST *)
ILOOP := 0;
REPEAT ILOOP := ILOOP + 1 UNTIL (NAMELIST[ILOOP] = WORD) OR (ILOOP = COUNT);
IF NAMELIST[ILOOP] = WORD THEN WORDMATCH := ILOOP (* FOUND DIRECT MATCH *)
ELSE
BEGIN
ILOOP := 0 (*CHECK FOR PARTIAL MATCH*);
REPEAT ILOOP := ILOOP + 1; FOUND := SUBSET(WORD, NAMELIST[ILOOP]);
UNTIL FOUND OR (ILOOP = COUNT);
IF NOT FOUND (* NO MATCH AT ALL*) THEN WORDMATCH := 0
ELSE (*CHECK FOR UNIQUENESS*)
IF ILOOP = COUNT THEN WORDMATCH := COUNT (* LAST WORD IS UNIQUE*)
ELSE
BEGIN
JLOOP := ILOOP;
REPEAT
JLOOP := JLOOP + 1; FOUND := SUBSET(WORD, NAMELIST[JLOOP]);
IF FOUND THEN FOUND := (NAMELIST[ILOOP] <> NAMELIST[JLOOP]);
(* DON'T FLAG UNQUE-ERROR IF TWO WORDS ARE IDENTICAL IN LIST *)
UNTIL FOUND OR (JLOOP = COUNT);
IF FOUND
THEN
BEGIN WRITELN(TERM, PS(WORD), ' IS NOT UNIQUE.'); WORDMATCH := - 1
END (*IF*)
ELSE WORDMATCH := ILOOP (* MATCHED+UNIQUE*)
END (*ELSE*)
END (*PARTIAL SCAN OF LIST*)
END (* SCANNING LIST *)
END (*WORDMATCH*);
FUNCTION FINDMONSTER(WORD: ALFA; NUM: INTEGER; MONSTERTAIL: MONSTERPOINT):
MONSTERPOINT;
(* FINDMONSTER RETURNS THE MATCHING MONSTER TO *WORD* IN THE LIST .
IT ALSO CHECKS THE MONSTER.NUM IF USER SPECIFIES "RAT/5". IF
NOT SPECIFIED, IT RETURNS THE FIRST MONSTER ON THE LIST. (WHICH
IS THE HIGHEST .NUM'BERED MONSTER) *)
VAR
MONSTER: MONSTERPOINT;
COUNT, INDEX: INTEGER;
NAMELIST: NAMETYPELIST;
MONNAME: ALFA;
FUNCTION MONNUMMATCH(MON: MONSTERPOINT): BOOLEAN;
(* MONNUMMATCH RETURNS TRUE IF THE BOTH THE NAME AND NUMBER MATCH *)
BEGIN MONNUMMATCH := ((MONNAME = MON ^.NAME) AND (NUM = MON ^.NUM))
END (*MONNUMMATCH*);
BEGIN (*FINDMONSTER*)
COUNT := 0; MONSTER := MONSTERTAIL;
WHILE (MONSTER <> NIL) AND (COUNT < MAXNAMES) DO
BEGIN
COUNT := COUNT + 1; NAMELIST[COUNT] := MONSTER ^.NAME;
MONSTER := MONSTER ^.NEXT
END (*WHILE*);
IF COUNT >= MAXNAMES THEN WRITELN(TERM, 'MIL04 - MONSTER TABLE OVERFLOW.');
INDEX := WORDMATCH(WORD, COUNT, NAMELIST);
IF INDEX <= 0 THEN MONSTER := NIL
ELSE
BEGIN
MONSTER := MONSTERTAIL;
FOR COUNT := 1 TO INDEX - 1 DO MONSTER := MONSTER ^.NEXT;
IF NUM > 0 THEN
BEGIN
MONNAME := MONSTER ^.NAME; MONSTER := MATCHMONSTER(MONSTER, MONNUMMATCH)
END (*IF*)
END (*ELSE*);
FINDMONSTER := MONSTER
END (*FINDMONSTER*);
FUNCTION FINDOBJECT(WORD: ALFA; NUM: INTEGER; OBJECTTAIL: OBJECTPOINT): OBJECTPOINT;
(* FINDOBJECT RETURNS THE MATCHING OBJECT TO *WORD* IN THE LIST*)
VAR
OBJECT: OBJECTPOINT;
I, NUMMATCH, COUNT, INDEX: INTEGER;
NAMELIST: NAMETYPELIST;
NAME: ALFA;
PROCEDURE FILLEND(VAR NAM: ALFA);
(* FILL END OF NAME WITH SPACES *)
VAR
ILOOP: 0..10;
FOUND: BOOLEAN;
BEGIN
ILOOP := 0;
REPEAT ILOOP := ILOOP + 1; FOUND := (NAM[ILOOP] IN [COL, ' ']);
UNTIL FOUND OR (ILOOP >= 10);
IF FOUND THEN FOR ILOOP := ILOOP TO 10 DO NAM[ILOOP] := ' '
END (*FILLEND*);
BEGIN (*FINDOBJECT*)
COUNT := 0; OBJECT := OBJECTTAIL;
WHILE (OBJECT <> NIL) AND (COUNT < MAXNAMES) DO
BEGIN
COUNT := COUNT + 1; LD(OBJECT ^.NAME, NAMELIST[COUNT]);
FILLEND(NAMELIST[COUNT]) (* SPACE FILL RIGHT *); OBJECT := OBJECT ^.NEXT
END (*WHILE*);
IF COUNT >= MAXNAMES THEN WRITELN(TERM, 'MIL30 - OBJECT TABLE OVERFLOW!');
INDEX := WORDMATCH(WORD, COUNT, NAMELIST);
IF INDEX <= 0 THEN OBJECT := NIL
ELSE
BEGIN
OBJECT := OBJECTTAIL; FOR I := 1 TO INDEX - 1 DO OBJECT := OBJECT ^.NEXT;
IF NUM > 1
THEN
BEGIN
NAME := NAMELIST[INDEX]; I := INDEX + 1; NUMMATCH := 1;
WHILE (NUMMATCH < NUM) AND (I <= COUNT) DO
BEGIN
OBJECT := OBJECT ^.NEXT;
IF NAMELIST[I] = NAME THEN NUMMATCH := NUMMATCH + 1; I := I + 1
END (*WHILE*);
IF (I > COUNT) AND (NUMMATCH < NUM) THEN OBJECT := NIL
END (*IF*)
END (*ELSE*);
FINDOBJECT := OBJECT
END (*FINDOBJECT*);
FUNCTION FINDPLAYER(WORD: ALFA; PLAYERTAIL: USERPOINT): USERPOINT;
(*FINDPLAYER TURNS THE PLAYER MATCHING *WORD* IN THE LIST *)
VAR
PLAYER: USERPOINT;
COUNT, INDEX: INTEGER;
NAMELIST: NAMETYPELIST;
BEGIN
COUNT := 0; PLAYER := PLAYERTAIL;
WHILE (PLAYER <> NIL) AND (COUNT < MAXNAMES) DO
BEGIN
COUNT := COUNT + 1; NAMELIST[COUNT] := PLAYER ^.NAME; PLAYER := PLAYER ^.NEXT
END (*WHILE*);
IF COUNT >= MAXNAMES THEN WRITELN(TERM, 'MIL31 - PLAYER TABLE OVERFLOW!');
INDEX := WORDMATCH(WORD, COUNT, NAMELIST);
IF INDEX <= 0 THEN PLAYER := NIL
ELSE
BEGIN
PLAYER := PLAYERTAIL; FOR COUNT := 1 TO INDEX - 1 DO PLAYER := PLAYER ^.NEXT
END (*ELSE*);
FINDPLAYER := PLAYER
END (*FINDPLAYER*);
FUNCTION FINDUSER;
(* FINDUSER RETURNS THE USER THAT MATCHES *WORD* IN THE LIST*)
VAR
USR: USERPOINT;
COUNT, INDEX: INTEGER;
NAMELIST: NAMETYPELIST;
BEGIN
COUNT := 0; USR := USERTAIL;
WHILE (USR <> NIL) AND (COUNT < MAXNAMES) DO
BEGIN COUNT := COUNT + 1; NAMELIST[COUNT] := USR ^.NAME; USR := USR ^.NEXTUSER
END (*WHILE*);
IF COUNT >= MAXNAMES THEN WRITELN(TERM, 'MIL32 - USER TABLE OVERFLOW!');
INDEX := WORDMATCH(WORD, COUNT, NAMELIST);
IF INDEX <= 0 THEN USR := NIL
ELSE
BEGIN USR := USERTAIL; FOR COUNT := 1 TO INDEX - 1 DO USR := USR ^.NEXTUSER
END (*ELSE*);
FINDUSER := USR
END (*FINDUSER*);
FUNCTION EXPR(LEV: INTEGER): INTEGER;
VAR
NUM: INTEGER;
BEGIN
IF LEV <= 1 THEN EXPR := 0
ELSE
BEGIN
NUM := LEV + 7;
IF NUM <= 17 THEN EXPR := TRUNC(1.0, NUM)
ELSE EXPR := TRUNC(1.0, 17) * (NUM - 16)
END (*ELSE*)
END (*EXPR*);
FUNCTION SPELLIMIT: BOOLEAN;
BEGIN
IF USER ^.SPELLDAY >= 7
THEN BEGIN SPELLIMIT := TRUE; WRITELN(TERM, 'DAILY LIMIT EXCEEDED, SORRY.'); END
ELSE BEGIN SPELLIMIT := FALSE; USER ^.SPELLDAY := USER ^.SPELLDAY + 1 END
END (*SPELLIMIT*);
PROCEDURE PRINTOBJ(VAR OBJECT: OBJECTTYPE; SINGULAR: BOOLEAN);
(* PRINTOBJ WILL DISPLAY THE NAME OF AN OBJECT. IF *SINGULAR*
IS TRUE, THEN "THE" IS PREFIXED (UNLESS ARTICLE = NONE). ELSE
THE ARTICLE IS PREFIXED. TREASURES HAVE THEIR VALUE DISPLAYED, AND
WEAPONS, SHIELDS AND ARMOR HAVE THEIR COMBAT VALUES DISPLAYED TOO.
(IF SINGULAR IS FALSE.) *)
VAR
ILOOP, JLOOP, KLOOP: 0..21;
FLAG: BOOLEAN;
BEGIN
WITH OBJECT DO
BEGIN
IF SINGULAR AND (ARTICLE <> NONE) THEN WRITE('THE ');
IF NOT SINGULAR
THEN
IF OBCLASS <> DOOR
THEN
CASE ARTICLE OF
A: WRITE('A ');
AN: WRITE('AN ');
THE: WRITE('THE ');
SOME: WRITE('SOME ');
NONE:;
END (*CASE*)
ELSE
BEGIN
CASE ARTICLE OF
A, AN: IF DCLOSED THEN WRITE('A ') ELSE WRITE('AN ');
THE: WRITE('THE ');
SOME: WRITE('SOME ');
NONE:;
END (*CASE*);
IF DCLOSED
THEN IF DLOCKED > 0 THEN WRITE('LOCKED ') ELSE WRITE('CLOSED ')
ELSE WRITE('OPEN ')
END (*ELSE*);
IF OBCLASS = COINS THEN WRITE(PRICE DIV MULTIPLIER: 0, ' ');
IF MAGIC THEN WRITE('MAGIC '); ILOOP := 0;
REPEAT ILOOP := ILOOP + 1; FLAG := (NAME[ILOOP] = ' ')
UNTIL FLAG OR (ILOOP >= 20);
IF NOT FLAG THEN WRITE(PO(NAME)) (* ONE WORD *)
ELSE
BEGIN
JLOOP := ILOOP + 1;
WHILE (JLOOP <= 20) DO
IF NAME[JLOOP] <> COL
THEN
BEGIN
IF NAME[JLOOP] = '*'
THEN FOR KLOOP := 1 TO ILOOP - 1 DO WRITE(NAME[KLOOP])
ELSE WRITE(NAME[JLOOP]);
JLOOP := JLOOP + 1
END (*IF*)
ELSE JLOOP := 21 (*END WHILE LOOP*);
END (*ELSE*);
IF NOT SINGULAR
THEN (* WRITE STATS *)
BEGIN
IF INVISIBLE THEN WRITE(' (INV)');
IF (OBCLASS = WEAP) AND MAGIC THEN WRITE(' (+', ABS(WEAPLUS): 0, ')');
IF OBCLASS = SHIELD THEN WRITE(' (', ABS(SHPLUS): 0, ')');
IF OBCLASS = ARMOR THEN WRITE(' (', ABS(ARMPLUS): 0, ')');
IF OBCLASS = TREASURE THEN WRITE(' (VALUE: ', PRICE: 0, ')');
END (*IF*)
END (*WITH*)
END (*PRINTOBJ*);
PROCEDURE OBJDISPLAY(OBJECT: OBJECTPOINT);
VAR
TOBJ: OBJECTPOINT;
BEGIN
ERRLOC := 'OBJDISPLAY'; WRITE(TERM);
PRINTOBJ(OBJECT ^, FALSE) (* WRITE OBJ NAME *); WRITE(', ');
WITH OBJECT ^ DO
BEGIN
IF CARRY THEN WRITE('CARRYABLE, '); WRITE(WEIGHT: 0, ' LBS, ');
WRITELN(PRICE: 0, ' SHILLINGS');
IF (DESCREC > 0) AND (USER ^.SSJ OR (OBCLASS <> SCROLL))
THEN
BEGIN
WRITELN(TERM, 'DR=', DESCREC: 0, ', DI=', DESCCODE: 0, '.');
WRITE(TERM, 'DESCRP: '); PRINTDESC(DESCREC, DESCCODE, 0, FALSE); WRITELN
END (*IF*);
WRITELN(TERM, 'MAGIC=', MAGIC: 5, ', PERMANENT=', PERMANENT: 5, ', INVISIBLE=',
INVISIBLE: 5, '.');
WRITE(TERM) (* WRITE CLASS DESCS *);
CASE OBCLASS OF
PORTAL: WRITELN('PORTAL TO ROOM ', TOWHERE: 0, '.');
WEAP:
BEGIN
WRITE('OFFENSIVE WEAPON, ', MINHP: 0, '-', MAXHP: 0, ' HP, ');
WRITELN(STRIKESLEFT: 0, ' STRIKES LEFT.'); WRITE(TERM);
CASE WEAPTYPE OF
SHARP: WRITE('SHARP');
THRUST: WRITE('THRUST');
BLUNT: WRITE('BLUNT');
LONG: WRITE('POLE');
END (*CASE*);
WRITELN(' CLASS WEAPON.'); WRITELN(TERM, '+ ', WEAPLUS: 0, ' TO HIT.');
END (*WEAP*);
SHIELD:
WRITELN('SHIELD, + ', SHPLUS: 0, ' PROTECTION, ', SHHITSLEFT: 0,
' HITS LEFT.');
ARMOR:
WRITELN('ARMOR, + ', ARMPLUS: 0, ' PROTECTION, ', ARMHITSLEFT: 0,
' HITS LEFT.');
COINS: WRITELN('MONEY, VALUE MULTIPLIER: X', MULTIPLIER: 0);
SCROLL: WRITELN('SCROLL, SPELL = ', SPELLIST[SPELL]);
CHEST:
BEGIN
WRITELN('CONTAINER, OBJECTS =', NUMINSIDE: 0, ' TRAP=', TRAP: 0);
WRITELN(TERM, 'LOCK TYPE = ', LOCKED: 0);
IF OBJECTTAIL <> NIL
THEN
BEGIN
TOBJ := OBJECTTAIL; WRITELN(TERM, 'ITEMS INSIDE:');
WHILE TOBJ <> NIL DO
BEGIN
WRITE(TERM, ' '); PRINTOBJ(TOBJ ^, FALSE); WRITELN;
TOBJ := TOBJ ^.NEXT
END (*WHILE*)
END (*IF*)
END (*CHEST*);
DOOR:
BEGIN
WRITELN('DOOR, PORTAL TO ROOM ', DTOWHERE: 0, '. DOOR TRAP=', DTRAP: 0);
WRITELN(TERM, 'DLOCK TYPE=', DLOCKED: 0);
END (*DOOR*);
MAGDEVICE:
BEGIN
WRITELN('MAGICAL DEVICE, SPELL = ', SPELLIST[SPELL]);
WRITELN(TERM, 'NUMBER OF CHARGES = ', NUMCHARGES: 0)
END (*MAGDEVICE*);
TELEPORT:
WRITELN('TELEPORT DEVICE, FROM ROOM ', TACTIVERM: 0, ' TO ROOM ', TOWHERE: 0,
'.');
KEYS: WRITELN('KEYS, UNLOCK TYPE=', UNLOCK: 0);
CARD: WRITELN('CARDS, TELEPORT TO PLAYER');
OTHERWISE
WRITELN;
END (*CASE*);
END (*WITH*);
END (*OBJDISPLAY*);
PROCEDURE PLAYERDISPLAY(PLYER: USERPOINT);
VAR
COUNT: INTEGER;
OBJ: OBJECTPOINT;
BEGIN
ERRLOC := 'PLAYERDISP';
WITH PLYER ^ DO
BEGIN
WRITE(TERM, PS(NAME), ', THE ', PNTH(LVL), 'LEVEL ', PS(CNAME[CLASS]), ' ');
IF PLAYTESTER THEN WRITE('(PLAYTESTER) ');
IF SSJ AND NOT ASSOC AND NOT MASTER THEN WRITE('(DM)');
IF SSJ AND ASSOC THEN WRITE('(ASSOC DM)');
IF SSJ AND MASTER THEN WRITE('(MASTER DM)');
IF USER ^.SSJ THEN WRITE(' IN ROOM ', RMCODE: 0, '/', W(RMCODE): 0); WRITELN;
IF INVISIBLE THEN
IF NONEXISTANT THEN WRITELN(TERM, 'YOU ARE NONEXISTANT.')
ELSE WRITELN(TERM, 'YOU ARE CURRENTLY INVISIBLE.');
IF TGUILD THEN WRITELN(TERM, 'YOU ARE A MEMBER OF THE THIEVES GUILD.');
IF AGUILD THEN WRITELN(TERM, 'YOU ARE A MEMBER OF THE ASSASSINS GUILD.');
IF EVIL THEN WRITELN(TERM, 'YOU HAVE FALLEN INTO THE FORCES OF EVIL.');
WRITE(TERM, 'WITH ', HITS: 0, '/', MAXHITS: 0, ' VITALITY PTS, ');
WRITE(FATIGUE: 0, '/', MAXFATIGUE: 0, ' FATIGUE PTS, AND ');
WRITELN(MAGIC: 0, '/', MAXMAGIC: 0, ' MAGIC PTS.');
IF POISONED THEN WRITELN(TERM, 'YOU ARE DYING FROM POISON!');
WRITELN(TERM, ' YOU HAVE A DEFENSIVE ARMOUR CLASS OF ', PN(AC));
WRITE(TERM, 'STR=', STR: 0, ', INT=', INT: 0, ', DEX=', DEX: 0);
WRITELN(', PTY=', PTY: 0, ', CON=', CON: 0);
WRITE(TERM, COL, 'IWEAPON SKILL: SHARP-', SSHARP * 10: 1, '@D, THRUST-');
WRITE(STHRUST * 10: 1, '@D, BLUNT-', SBLUNT * 10: 1, '@D, POLE-');
WRITE(SLONG * 10: 1, '@D'); WRITELN; WRITE(TERM, 'YOU NEED ');
WRITE(MAX(0, EXPR(LVL + 1) - EXPR(LVL) - EXPERIENCE): 0);
WRITELN(' MORE EXP POINTS TO TRAIN FOR THE NEXT LEVEL.');
WRITELN(TERM, 'YOU HAVE ', MONEY: 0, ' SHILLINGS IN CASH.'); WRITELN(TERM);
WRITELN(TERM, 'YOU ARE CARRYING ', WEIGHT: 0, ' LBS OF ITEMS:');
OBJ := OBJECTTAIL; COUNT := 0;
WHILE OBJ <> NIL DO
BEGIN
COUNT := COUNT + 1; WRITE(TERM, ' ', COUNT: 0, ') ');
PRINTOBJ(OBJ ^, FALSE); WRITELN; OBJ := OBJ ^.NEXT
END (*WHILE*);
IF COUNT > MAXOBJS THEN
WRITELN(TERM, 'ONLY THE FIRST ', PN(MAXOBJS),
'ITEMS WILL BE SAVED WHEN YOU LOG OUT.');
IF UNHASH=0 THEN WRITELN(TERM,'YOU HAVE NO USERNUMBER RESTRICTIONS.');
IF USER ^.SSJ THEN
WRITELN(TERM, 'LAST LOGGED IN ON THE ', PNTH(LASTACCESS), ' OF THE MONTH.');
END (* WITH *)
END (*PLAYERDISPLAY*);
PROCEDURE MONDISPLAY(MONSTER: MONSTERPOINT);
VAR
OBJECT: OBJECTPOINT;
BEGIN
ERRLOC := 'MONDISPLAY';
WITH MONSTER ^ DO
BEGIN
WRITELN(TERM, PM(MONSTER), 'IS A ', PNTH(LVL), 'LEVEL MONSTER WITH ', HITS: 0,
'/', MAXHITS: 0, ' H.P.');
WRITELN(TERM, 'DEFEND=', DEFEND: 5, ', BLOCK=', BLOCK: 5, ', FOLLOW=', FOLLOW: 5
, ',');
WRITELN(TERM, 'GUARD=', GUARD: 5, ', ATKLASTAGGR=', ATKLASTAGGR: 5);
WRITELN(TERM, EXPERIENCE, ' E.P., PERMANENT=', PERMANENT: 5);
IF MORALREACT THEN WRITELN(TERM, 'MONSTER WILL HIT PLAYERS WITH PIETY < 8.');
IF INVISIBLE THEN WRITELN(TERM, 'MONSTER IS INVISIBLE.');
IF FLEE THEN WRITELN(TERM, 'MONSTER MAY FLEE.');
IF ASSISTANCE THEN WRITELN(TERM, 'MONSTER WILL CALL FOR HELP IF ATTACKED.');
IF MAGIC THEN WRITELN(TERM, 'AFFECTED ONLY BY MAGICAL WEAPONS.');
IF POISON THEN WRITELN(TERM, 'MONSTER IS POISONOUS.');
IF ANTIMAGIC THEN WRITELN(TERM, 'MONSTER IS IMMUNE TO SPELLS.');
IF UNDEAD THEN WRITELN(TERM, 'MONSTER IS UNDEAD.');
IF SLOWREACT THEN WRITELN(TERM, 'MONSTER WILL REACT SLOWLY.');
IF FASTREACT THEN WRITELN(TERM, 'MONSTER WILL REACT QUICKLY.');
IF REGENERATE THEN WRITELN(TERM, 'MONSTER CAN REGENERATE H.P.');
IF DRAIN THEN WRITELN(TERM, 'MONSTER HAS ENERGY-DRAIN.');
IF MONSPELLS THEN WRITELN(TERM, 'MONSTER CAN CAST SPELLS.');
IF MPARLEY > 0
THEN WRITELN(TERM, 'MONSTER WILL DO TYPE ', PN(MPARLEY), ' PARLEY.');
WRITELN(TERM, 'TREASURE TYPE: ', WHICHOBJ: 0, '.'); OBJECT := OBJECTTAIL;
IF OBJECT <> NIL
THEN
BEGIN
WRITELN(TERM); WRITELN(TERM, 'OBJECTS CARRIED:');
REPEAT
WRITE(TERM); PRINTOBJ(OBJECT ^, FALSE); WRITELN; OBJECT := OBJECT ^.NEXT;
UNTIL OBJECT = NIL;
END (* PRINT MON OBJECTS *);
END (*WITH*)
END (*MONDISPLAY*);
PROCEDURE PUNCTUATE(NUM, TOTAL: INTEGER);
BEGIN
IF NUM <> TOTAL THEN IF TOTAL - NUM >= 2 THEN WRITE(', ') ELSE WRITE(' AND ');
IF (NUM MOD 3 = 0) AND (NUM < TOTAL) THEN BEGIN WRITELN; WRITE(TERM) END
END (*PUNCTUATE*);
PROCEDURE INVENTORY;
(* INVENTORY WILL PRINT A LIST OF CARRIED OBJECTS *)
VAR
ILOOP, COUNT: INTEGER;
OBJECT: OBJECTPOINT;
BEGIN
WRITELN(TERM, 'YOU ARE CARRYING THE FOLLOWING OBJECTS:'); COUNT := 0;
OBJECT := USER ^.OBJECTTAIL;
WHILE OBJECT <> NIL DO BEGIN COUNT := COUNT + 1; OBJECT := OBJECT ^.NEXT END;
IF COUNT > 0
THEN
BEGIN
WRITE(TERM); OBJECT := USER ^.OBJECTTAIL; ILOOP := 0;
WHILE (ILOOP < COUNT) AND (OBJECT <> NIL) DO
BEGIN
ILOOP := ILOOP + 1; PRINTOBJ(OBJECT ^, FALSE); PUNCTUATE(ILOOP, COUNT);
OBJECT := OBJECT ^.NEXT;
END (*WHILE*);
WRITELN('.'); WRITELN(TERM);
END (*IF*)
ELSE WRITELN(TERM, 'NOTHING AT ALL.')
END (*INVENTORY*);
PROCEDURE ROOMDISPLAY;
(* FORWARDED FROM ANNOUNCELOGIN. DISPLAY THE ROOM. *)
VAR
ILOOP, COUNT: INTEGER;
FOUND: BOOLEAN;
OBJECT: OBJECTPOINT;
MONSTER: MONSTERPOINT;
PLAYER: USERPOINT;
TEMP: ALFA;
TENSE: ARRAY [FALSE .. TRUE] OF PACKED ARRAY [1..3] OF CHAR;
BEGIN
ERRLOC := 'ROOMDISPLA'; WRITE(TERM, 'YOU''RE ');
WITH ROOM[RM] DO
BEGIN
PRINTDESC(DESCREC, DESCCODE, 0, BRIEF);
IF USER ^.SSJ THEN WRITE(' (', W(RM): 0, ')'); WRITELN; COUNT := 0;
FOR ILOOP := 1 TO 6 DO IF ADJOIN[ILOOP] <> 0 THEN COUNT := COUNT + 1;
IF OUT > 0 THEN COUNT := COUNT + 1;
IF COUNT > 0
THEN
BEGIN
WRITE(TERM, 'OBVIOUS EXITS ARE ');
FOR ILOOP := 1 TO 7 DO
BEGIN
IF ILOOP = 7 THEN FOUND := (OUT <> 0) ELSE FOUND := (ADJOIN[ILOOP] <> 0);
IF FOUND
THEN
BEGIN
WRITE(PS(DIRLIST[ILOOP]));
IF COUNT = 1 THEN WRITELN('.')
ELSE IF COUNT > 2 THEN WRITE(', ') ELSE WRITE(' AND ');
COUNT := COUNT - 1
END (*IF*)
END (*FOR*);
END (*IF*);
COUNT := 0; OBJECT := RMOBJECTTAIL;
WHILE OBJECT <> NIL DO
BEGIN
IF NOT OBJECT ^.INVISIBLE OR USER ^.SSJ THEN COUNT := COUNT + 1;
OBJECT := OBJECT ^.NEXT
END (*WHILE*);
MONSTER := RMMONSTERTAIL;
WHILE MONSTER <> NIL DO
BEGIN
IF MONSTER ^.TOP AND (NOT MONSTER ^.INVISIBLE OR USER ^.SSJ)
THEN COUNT := COUNT + 1;
MONSTER := MONSTER ^.NEXT
END (*WHILE*);
(* TOTAL # OF THINGS COUNTED. NOW PRINT THEM. *)
IF COUNT > 0
THEN
BEGIN
WRITE(TERM, 'YOU SEE '); OBJECT := RMOBJECTTAIL; MONSTER := RMMONSTERTAIL;
ILOOP := 0;
WHILE (ILOOP < COUNT) AND (MONSTER <> NIL) DO
BEGIN
IF MONSTER ^.TOP AND (NOT MONSTER ^.INVISIBLE OR USER ^.SSJ)
THEN
IF MONSTER ^.NUM = 1
THEN
BEGIN
ILOOP := ILOOP + 1; WRITE('A ', PS(MONSTER ^.NAME));
IF MONSTER ^.INVISIBLE AND USER ^.SSJ THEN WRITE(' (INV)');
PUNCTUATE(ILOOP, COUNT);
END (*IF*)
ELSE
BEGIN
ILOOP := ILOOP + 1; WRITE(PN(MONSTER ^.NUM), PS(MONSTER ^.NAME), 'S');
IF MONSTER ^.INVISIBLE AND USER ^.SSJ THEN WRITE(' (INV)');
PUNCTUATE(ILOOP, COUNT);
END (*ELSE*);
MONSTER := MONSTER ^.NEXT
END (*WHILE*);
WHILE (ILOOP < COUNT) AND (OBJECT <> NIL) DO
BEGIN
IF NOT OBJECT ^.INVISIBLE OR USER ^.SSJ THEN
BEGIN
ILOOP := ILOOP + 1; PRINTOBJ(OBJECT ^, FALSE); PUNCTUATE(ILOOP, COUNT);
END (*IF*);
OBJECT := OBJECT ^.NEXT;
END (*WHILE*);
WRITELN('.'); WRITELN(TERM);
END (*IF*);
PLAYER := RMPLAYERTAIL (* PRINT PLAYERS IN ROOM *); COUNT := 0;
WHILE PLAYER <> NIL DO
BEGIN
IF (PLAYER <> USER) AND NOT PLAYER ^.INVISIBLE AND (NOT PLAYER ^.HIDDEN OR
USER ^.SSJ)
THEN COUNT := COUNT + 1;
PLAYER := PLAYER ^.NEXT
END (*WHILE*);
IF COUNT > 0
THEN
BEGIN
WRITE(TERM); PLAYER := RMPLAYERTAIL; ILOOP := 0;
WHILE PLAYER <> NIL DO
BEGIN
IF (PLAYER <> USER) AND NOT PLAYER ^.INVISIBLE AND (NOT PLAYER ^.HIDDEN OR
USER ^.SSJ)
THEN
BEGIN
WRITE(PS(PLAYER ^.NAME)); IF PLAYER ^.HIDDEN THEN WRITE(' (HID)');
ILOOP := ILOOP + 1; PUNCTUATE(ILOOP, COUNT);
END (*IF*);
PLAYER := PLAYER ^.NEXT;
END (*WHILE*);
IF COUNT = 1 THEN WRITELN(' IS ALSO HERE.') ELSE WRITELN(' ARE ALSO HERE.');
END (*IF*);
TEMP := USER ^.NAME; USER ^.NAME := 'YOU '; TENSE[FALSE] := ' IS';
TENSE[TRUE] := '''RE';
(* SAY "YOU ARE", NOT "<NAME> IS" *)
MONSTER := RMMONSTERTAIL;
WHILE MONSTER <> NIL DO
BEGIN
IF MONSTER ^.DEFPLAYER <> NIL THEN
WRITELN(TERM, PM(MONSTER), 'IS ATTACKING ', PS(MONSTER ^.DEFPLAYER ^.NAME),
'!');
MONSTER := MONSTER ^.NEXT
END (*WHILE*);
PLAYER := RMPLAYERTAIL;
WHILE PLAYER <> NIL DO
BEGIN
IF PLAYER ^.DEFMON <> NIL
THEN
IF PLAYER ^.DEFMON ^.DEFPLAYER <> PLAYER
THEN (* DON'T BE REDUNDANT. MONSTER-PLAYER PLAYER-MONSTER *)
WRITELN(TERM, PS(PLAYER ^.NAME), TENSE[PLAYER = USER], ' ATTACKING ', PM(
PLAYER ^.DEFMON), '!')
ELSE
IF PLAYER ^.DEFPLAYER <> NIL THEN
WRITELN(TERM, PS(PLAYER ^.NAME), TENSE[PLAYER = USER], ' ATTACKING ', PS(
PLAYER ^.DEFPLAYER ^.NAME), '!');
PLAYER := PLAYER ^.NEXT;
END (*WHILE*);
USER ^.NAME := TEMP (*RESTORE NAME*);
END (*WITH*);
END (*ROOMDISPLAY*);
PROCEDURE ASSOCERR;
BEGIN WRITELN(TERM, 'SORRY, ASSOCIATE DM''S MAY NOT DO THAT.') END;
PROCEDURE MODPLAYER(VAR PLAYER: USERPOINT; ONLINE: BOOLEAN);
(* MODPLAY WILL MODIFY A PLAYER'S DATA RECORD. IT IS
CALLED BY EDITPLAYER AND EDITFILE. ONLINE IS TRUE IF THE EDITED
PLAYER IS ACTUALLY LOGGED IN. *)
BEGIN
WHICHPARM := GETEDITPARM(USRPARMLIST, WORD, NUMBER, FLAG, BUFFER, LENBUF, LOC);
WHILE WHICHPARM > 0 DO
WITH PLAYER ^ DO
BEGIN
IF USER ^.ASSOC AND (WHICHPARM IN [3, 11, 20, 21, 25, 29,34,37])
THEN
BEGIN
WRITELN(TERM, USRPARMLIST[WHICHPARM].PNAME, ' - ILLEGAL ACCESS.'); ASSOCERR;
LOC := LENBUF + 1
END (*IF*)
ELSE
CASE WHICHPARM OF
1:
BEGIN
INDEX := SEARCHPLINDEX(NAME);
IF INDEX > 0 THEN PLAYERINDEX[INDEX] := WORD; NAME := WORD
END (*1*);
2:
IF NOT USER ^.MASTER
THEN WRITELN(TERM, 'ONLY MASTER DM''S MAY ACTIVATE DM PRIVILEDGES.')
ELSE
BEGIN
CH := WORD[1];
CASE CH OF
'D': BEGIN SSJ := TRUE; ASSOC := FALSE; MASTER := FALSE END;
'A': BEGIN SSJ := TRUE; ASSOC := TRUE; MASTER := FALSE END;
'M': BEGIN SSJ := TRUE; ASSOC := FALSE; MASTER := TRUE END;
'N': BEGIN SSJ := FALSE; ASSOC := FALSE; MASTER := FALSE END;
OTHERWISE
WRITELN(TERM, 'ERROR. ZZ MUST = NONE, ASSISTANT, DM, OR MASTER.');
END (*CASE*)
END (*ELSE*);
3: WEIGHT := MAX(0, MIN(5000, NUMBER));
4: LVL := MAX(0, MIN(25, NUMBER));
5:
BEGIN
CH := WORD[1];
CASE CH OF
'B': CLASS := BARBARIAN;
'F': CLASS := FIGHTER;
'T': CLASS := THIEF;
'C': CLASS := CLERIC;
'M': IF WORD[3] = 'Y' THEN CLASS := MAYOR ELSE CLASS := MAGICUSER;
'R': CLASS := RANGER;
'P': CLASS := PALADIN;
'D': CLASS := DM;
OTHERWISE
WRITELN(TERM, 'ILLEGAL CLASS TYPE.');
END (*CASE*);
END (*5*);
6: HITS := MAX(0, MIN(2500, NUMBER));
7: MAXHITS := MAX(0, MIN(2500, NUMBER));
8: MAGIC := MAX(0, MIN(2500, NUMBER));
9: MAXMAGIC := MAX(0, MIN(2500, NUMBER));
10: EXPERIENCE := MAX(0, MIN(262000, NUMBER));
11: AC := MAX(- 50, MIN(50, NUMBER));
12:
IF ONLINE
THEN
BEGIN DELETEPLAYER(PLAYER, RMCODE); PLACEPLAYER(PLAYER, NUMBER);
END (*IF*)
ELSE RMCODE := NUMBER;
13: BRIEF := FLAG;
14: STR := MAX(- 10, MIN(25, NUMBER));
15: INT := MAX(- 10, MIN(25, NUMBER));
16: DEX := MAX(- 10, MIN(25, NUMBER));
17: PTY := MAX(- 10, MIN(25, NUMBER));
18: ECHO := FLAG;
19: CON := MAX(- 10, MIN(25, NUMBER));
20:
IF WORD[1] = 'M' THEN SEX := MALE ELSE
IF WORD[1] = 'F' THEN SEX := FEMALE ELSE
WRITELN(TERM,'SEX MUST BE MALE OR FEMALE.');
21: FOR ILOOP := 1 TO 7 DO UN[ILOOP] := WORD[ILOOP];
22:
IF USER ^.MASTER THEN PW := HASH(WORD,10)
ELSE WRITELN(TERM, 'ONLY MASTER DM''S MAY ALTER PASSWORDS.');
23: MONEY := MAX(0, MIN(500000, NUMBER));
24: LASTACCESS := MAX(0, MIN(31, NUMBER));
25: INVISIBLE := FLAG;
26: FATIGUE := MAX(0, MIN(2500, NUMBER));
27: MAXFATIGUE := MAX(0, MIN(2500, NUMBER));
28: POISONED := FLAG;
29: PLAYTESTER := FLAG;
30: HIDDEN := FLAG;
31: TGUILD := FLAG;
32: MESBLOCK := FLAG;
33: AGUILD := FLAG;
34: EVIL := FLAG;
35: SPELLDAY := MAX(0, MIN(5, NUMBER));
36: SENDDAY := MAX(0, MIN(31, NUMBER));
37: NONEXISTANT := FLAG;
38: SSHARP := MIN(7, MAX(0, NUMBER DIV 10));
39: STHRUST := MIN(7, MAX(0, NUMBER DIV 10));
40: SBLUNT := MIN(7, MAX(0, NUMBER DIV 10));
41: SLONG := MIN(7, MAX(0, NUMBER DIV 10));
42: BEGIN
IF UNHASH = 0 THEN UNHASH := 1 (* TURN OFF NO-RESTRICTIONS *);
GETWORD(WORD,NUM,BUFFER,LENBUF,LOC);
IF (WORD=BLANKS) AND (NUMBER=0) THEN
UNHASH := 1
ELSE IF WORD = 'CLEAR ' THEN UNHASH := 0 ELSE
IF UNHASH > TRUNC(1.0,39) THEN
WRITELN(TERM,'TOO MANY UNS IN ACCESS BLOCK.')
ELSE
UNHASH := UNHASH * HASH(WORD,5)
END;
END (*CASE*);
WHICHPARM := GETEDITPARM(USRPARMLIST, WORD, NUMBER, FLAG, BUFFER, LENBUF, LOC);
END (*WHILE*);
END (*MODPLAYER*);
PROCEDURE DISPEDPLAYER(PLAYER: USERPOINT);
BEGIN PLAYERDISPLAY(PLAYER) END;
(*$L'HIGH LEVEL PROCEDURES' *)
BEGIN
EXISTS := TRUE; NEW(PLAYER) (* CREATE TEMP PLAYER *); PLAYER ^ := PROTOUSER;
READPLAYER(PLAYER, WHICH);
IF PLAYER ^.NAME = EMPTY THEN
BEGIN
WRITELN(TERM, 'ENTRY NOT FOUND.'); EXISTS := FALSE; PLAYER ^.NAME := WHICH
END (*IF*);
CASE EDITCMD OF
1: (* MODIFY *)
IF EXISTS
THEN
BEGIN
DAYMSG('FIL', PLAYER, USER ^.NAME, 0); MODPLAYER(PLAYER, FALSE);
WRITEPLAYER(PLAYER, PLAYER ^.NAME)
END (*IF*)
ELSE WRITEUSR(PLAYER, FALSE);
2: (* DISPOSE *)
IF EXISTS
THEN
BEGIN
DAYMSG('ERA', PLAYER, USER ^.NAME, 0); PLAYER ^.NAME := EMPTY;
WRITEPLAYER(PLAYER, WHICH); WRITELN(TERM, 'PLAYER ERASED.')
END (*IF*)
ELSE WRITEUSR(PLAYER, FALSE);
3: (* EXAMINE *)
BEGIN IF EXISTS THEN DISPEDPLAYER(PLAYER); WRITEUSR(PLAYER, FALSE) END (*3*);
4:
IF NOT EXISTS
THEN
BEGIN
PLAYER ^.LASTACCESS := TODAY; MODPLAYER(PLAYER, FALSE);
DAYMSG('CRE', PLAYER, USER ^.NAME, 0); WRITEPLAYER(PLAYER, PLAYER ^.NAME)
END (*IF*)
ELSE
BEGIN
WRITELN(TERM, 'PLAYER ALREADY EXISTS IN FILE.'); WRITEUSR(PLAYER, FALSE)
END (*ELSE*)
END (*CASE*);
END (*EDITFILE*);
BEGIN
PLAYER := NIL;
IF EDITCMD = 4 THEN WRITELN(TERM, 'YOU CANNOT CREATE PLAYERS.')
ELSE
BEGIN
PLAYER := FINDUSER(WHICH, USERTAIL);
IF PLAYER = NIL THEN WRITELN(TERM, 'PLAYER NOT FOUND.')
ELSE
CASE EDITCMD OF
1: (*MODIFY*)
BEGIN
IF PLAYER ^.NAME <> USER ^.NAME THEN DAYMSG('MOD', PLAYER, USER ^.NAME, 0);
MODPLAYER(PLAYER, TRUE);
END (*1*);
2: (*DISPOSE*)
IF USER ^.ASSOC THEN ASSOCERR
ELSE
BEGIN
FOR ILOOP := 1 TO MSGTERM(TERMLIST, SYSMSG) DO
WRITELN(TERMLIST[ILOOP], '### A LIGHTNING BOLT HITS ', PS(PLAYER ^.NAME),
' AND TURNS ', PRO[PLAYER^.SEX], ' INTO ASHES!');
PLAYER^.DEAD := TRUE;
PLAYER ^.HITS := 0; DAYMSG('ZAP', PLAYER, USER ^.NAME, 0);
END (*2*);
3: (*DISPLAY*) DISPEDPLAYER(PLAYER);
END (*CASE*);
END (*ELSE*)
END (*EDITPLAYER*);
VAR
N, ILOOP, WHICHPARM, NUMBER: INTEGER;
WORD: ALFA;
FLAG: BOOLEAN;
BEGIN
IF (RM <= 0) OR (RM > NUMROOMS) THEN WRITELN(TERM, 'ROOM # OUT OF BOUNDS.')
ELSE
CASE EDITCMD OF
1: (*MODIFY*)
BEGIN
RM := S(RM);
WHICHPARM := GETEDITPARM(RMPARMLIST, WORD, NUMBER, FLAG, BUFFER, LENBUF, LOC);
WHILE WHICHPARM > 0 DO
WITH ROOM[RM] DO
BEGIN
CASE WHICHPARM OF
1: DESCCODE := MAX(0, MIN(50, NUMBER));
2: DESCREC := MAX(0, MIN(300, NUMBER));
3, 4, 5, 6, 7, 8:
IF NUMBER = 1000 THEN WRITELN(TERM, 'SORRY, ROOM 1000 IS RESERVED.')
ELSE
BEGIN
NUMBER := MAX(0, MIN(NUMROOMS, NUMBER));
IF NUMBER < 1000 THEN THOUSANDS := THOUSANDS - [WHICHPARM - 2]
ELSE
BEGIN
THOUSANDS := THOUSANDS + [WHICHPARM - 2]; NUMBER := NUMBER - 1000
END (*ELSE*);
ADJOIN[WHICHPARM - 2] := NUMBER;
END (*ELSE*);
9: OUT := MAX(0, MIN(NUMROOMS, NUMBER));
10: WHICHENCOUNTER := MAX(0, MIN(LENCOUNTER, NUMBER));
11: ENCOUNTERTIME := MAX(0, MIN(1000, NUMBER));
12: NOTIFYDM := FLAG;
13: SAFE := FLAG;
END (*CASE*);
WHICHPARM := GETEDITPARM(RMPARMLIST, WORD, NUMBER, FLAG, BUFFER, LENBUF,
LOC)
END (*WITH*);
WRITELN(TERM, 'ROOM MODIFIED.')
END (*1*);
2: (*DISPOSE*) WRITELN(TERM, 'IT IS NOT POSSIBLE TO DISPOSE OF A ROOM.');
3: (*EXAMINE*)
BEGIN
RM := S(RM); ROOMDISPLAY(RM, USER ^.BRIEF);
WITH ROOM[RM] DO
BEGIN
WRITE(TERM);
FOR ILOOP := 1 TO 6 DO
BEGIN
N := ADJOIN[ILOOP];
IF N > 0 THEN
BEGIN
IF ILOOP IN THOUSANDS THEN N := N + 1000;
WRITE(DIRLIST[ILOOP, 1], '=', N: 0, ', ');
END (*IF*);
END (*FOR*);
N := OUT; IF N > 0 THEN WRITE('OUT=', N: 0, ', ');
WRITELN('DR=', DESCREC: 0, ', DI=', DESCCODE: 0, ', EN=', WHICHENCOUNTER: 0,
', ET=', ENCOUNTERTIME: 0, '.');
IF NOTIFYDM THEN WRITELN(TERM, 'DM NOTIFIED ON ENTRY.');
IF SAFE THEN WRITELN(TERM, 'ROOM IS HAVEN AGAINST ATTACK.');
END (*WITH*);
END (*3*);
4:
IF NOT USER ^.MASTER
THEN WRITELN(TERM, 'SORRY, ONLY MASTER DM''S MAY CREATE ADDITIONAL ROOMSEGS.')
ELSE BEGIN ADDSEG; DAYMSG('ADD', USER, 'ADD ROOMS ', NUMROOMS); END;
END (*CASE*);
END (*EDITROOM*);
BEGIN
IF WHATCODE = 10 THEN GETWORD(DUMMY, RM, BUFFER, LENBUF, LOC)
ELSE BEGIN RM := MNUM; DUMMY := WHICH END;
IF (RM <= 0) OR (RM > NUMROOMS) OR (DUMMY <> BLANKS)
THEN WRITELN(TERM, 'ILLEGAL LOC NUMBER.')
ELSE
BEGIN
IF WHATCODE = 10
THEN
BEGIN
RM := S(RM); MONSTER := FINDMONSTER(WHICH, MNUM, ROOM[RM].RMMONSTERTAIL);
IF EDITCMD = 4
THEN
BEGIN
NEW(MONSTER); MONSTER ^ := PROTOMONSTER; MONSTER ^.NAME := WHICH;
INSERTMONSTER(MONSTER, RM); WRITELN(TERM, 'MONSTER CREATED.')
END (*IF*)
END (*IF*)
ELSE
IF (RM >= 1) AND (RM <= RANMONLEN)
THEN BEGIN NEW(MONSTER); MONSTER ^ := RANMONLIST[RM];
END
ELSE
BEGIN WRITELN(TERM, 'BAD MLIST NUMBER.'); WHATCODE := 0; MONSTER := NIL END;
IF MONSTER <> NIL
THEN
CASE EDITCMD OF
1, 4: (*MODIFY, CREATE*)
WITH MONSTER ^ DO
BEGIN
IF WHATCODE = 13 THEN DAYMSG('MLI',USER,BLANKS,RM);
WHICHPARM := GETEDITPARM(MONPARMLIST, WORD, NUMBER, FLAG, BUFFER, LENBUF,
LOC);
WHILE WHICHPARM > 0 DO
BEGIN
IF (WHATCODE = 13) AND USER ^.ASSOC
THEN BEGIN ASSOCERR; LOC := LENBUF + 1 END
ELSE
CASE WHICHPARM OF
1: DEFEND := FLAG;
2: BLOCK := FLAG;
3: FOLLOW := FLAG;
4: GUARD := FLAG;
5: ATKLASTAGGR := FLAG;
6: SLOWREACT := FLAG;
7: MORALREACT := FLAG;
8: FLEE := FLAG;
9: ASSISTANCE := FLAG;
10:
BEGIN
LVL := MAX(0, MIN(25, NUMBER));
IF LVL >= 15
THEN DAYMSG('LVL', USER, MONSTER ^.NAME, MONSTER ^.LVL)
END (*10*);
11: HITS := MAX(0, MIN(1000, NUMBER));
12: MAXHITS := MAX(0, MIN(1000, NUMBER));
13: EXPERIENCE := MAX(0, MIN(100000, NUMBER));
14: PERMANENT := FLAG;
15: MAGIC := FLAG;
16: WHICHOBJ := MAX(0, MIN(NUMBER, OBJLISTLEN));
17:
IF WHATCODE <> 10 THEN NAME := WORD
ELSE WRITELN(TERM, 'NAME CANNOT BE MODIFIED.');
18: FASTREACT := FLAG;
19: INVISIBLE := FLAG;
20: REGENERATE := FLAG;
21: DRAIN := FLAG;
22: POISON := FLAG;
23: ANTIMAGIC := FLAG;
24: UNDEAD := FLAG;
25: MONSPELLS := FLAG;
26: MPARLEY := MAX(0, MIN(NUMBER, 30));
END (*CASE*);
WHICHPARM := GETEDITPARM(MONPARMLIST, WORD, NUMBER, FLAG, BUFFER, LENBUF,
LOC)
END (*WHILE*);
IF MAXHITS < HITS THEN MAXHITS := HITS;
WRITELN(TERM, 'MONSTER MODIFIED.');
END (*1*);
2: (*DISPOSE*)
IF WHATCODE = 10
THEN
BEGIN
DELETEMONSTER(MONSTER, RM); DESTROY(MONSTER);
WRITELN(TERM, 'MONSTER DISPOSED.')
END (*IF*)
ELSE WRITELN(TERM, 'MLIST CANNOT BE DISPOSED.');
3: (* EXAMINE *) MONDISPLAY(MONSTER);
END (*CASE*)
ELSE WRITELN(TERM, 'MONSTER NOT FOUND.');
IF WHATCODE = 13 THEN BEGIN RANMONLIST[RM] := MONSTER ^; DISPOSE(MONSTER) END
END (*ELSE*)
END (*EDITMONSTER*);
PROCEDURE EDIT(VAR BUFFER: BUFTYPE; LENBUF: LENBUFTYPE; VAR EDITLIST: EDITTYPELIST);
(* *EDIT* IS THE MAIN ROUTINE FOR EDITING THE DATABASE OF MILIEU.
IT ALLOWS THE DM TO MODIFY THE DUNGEON *WHILE THE GAME IS RUNNING*.
WITH THE EDITOR, THE DM CAN MODIFY PLAYER SITUATION IN ANY WAY,
ACCORDING TO HIS/HER OWN DISCRETION.
*** WARNING *** IT IS POSSIBLE TO PERMANENTLY DAMAGE THE
DATABASE BY ISSUING BAD EDIT COMMANDS. READ THE EDIT INSTRUCTIONS
BEFORE USING THIS!!! *)
VAR
EDITCMD, WHAT, WHICH: ALFA;
EDITNUM, DUMMY, WHATCODE, RMORMONNUM: INTEGER;
BEGIN
LOC := 1 (* RESET GETWORD POINTER *);
GETWORD(EDITCMD, DUMMY, BUFFER, LENBUF, LOC);
(* FETCH THE COMMAND WORD FROM THE BUFFER *)
EDITNUM := WORDMATCH(EDITCMD, 7, EDITLIST);
(* FIND WHICH COMMAND # IT IS. *)
GETWORD(WHAT, DUMMY, BUFFER, LENBUF, LOC);
(* GET THE OPERAND: ROOM, OBJECT, MONSTER, PLAYER OR FILE. *)
WHATCODE := WORDMATCH(WHAT, 14, EDITLIST);
(* FIND WHICH # IT IS. *)
IF EDITNUM = 0
THEN BEGIN IF EDITCMD <> BLANKS THEN WRITELN(TERM, 'ILLEGAL EDIT CMD.') END
ELSE
IF (WHATCODE <= 7) AND NOT (EDITNUM IN [5, 6, 7])
THEN (* -1, 0, OR CMD AS 2ND WORD *) WRITELN(TERM, 'BAD OPERAND - ', WHAT)
ELSE
BEGIN
GETWORD(WHICH, RMORMONNUM, BUFFER, LENBUF, LOC);
CASE EDITNUM OF
- 1, 0: (* NOT UNIQUE, MESSAGE ALREADY SENT *);
1, 2, 3, 4:
CASE WHATCODE OF
8:
IF (EDITNUM <> 3) AND USER ^.ASSOC THEN ASSOCERR
ELSE EDITROOM(EDITNUM, RMORMONNUM);
14, 9: EDITOBJECT(EDITNUM, WHICH, RMORMONNUM, WHATCODE);
13, 10: EDITMONSTER(EDITNUM, WHICH, RMORMONNUM, WHATCODE);
11: EDITPLAYER(EDITNUM, WHICH);
12:
IF (EDITNUM <> 3) AND USER ^.ASSOC THEN ASSOCERR
ELSE EDITFILE(EDITNUM, WHICH);
END (*CASE*);
5, 6, 7:
BEGIN
USER ^.ENTRY := XCMD;
IF NOT USER ^.BRIEF THEN WRITELN(TERM, 'EXITING THE EDITOR.')
END (*5*)
END (*CASE*);
END (*ELSE*);
PROMPTUSER(USER)
END (*EDIT*);
PROCEDURE TRAIN;
VAR
TROOM: INTEGER;
BEGIN
CASE USER ^.CLASS OF
FIGHTER: TROOM := 20;
PALADIN: TROOM := 21;
CLERIC: TROOM := 22;
THIEF: TROOM := 23;
MAGICUSER: TROOM := 24;
RANGER: TROOM := 25;
OTHERWISE
TROOM := 20
END (*CASE*);
WITH USER ^ DO
IF W(RMCODE) <> TROOM
THEN WRITELN(TERM, 'THIS IS NOT THE PROPER PLACE FOR TRAINING!')
ELSE
IF MONEY * 2 < EXPR(LVL + 1) - EXPR(LVL)
THEN WRITELN(TERM, 'YOU HAVE NOT ENOUGH FUNDS TO SPEND ON TRAINING!')
ELSE
IF EXPERIENCE + EXPR(LVL) < EXPR(LVL + 1)
THEN WRITELN(TERM, 'YOU ARE NOT EXPERIENCED ENOUGH FOR FURTHER TRAINING!')
ELSE
IF LVL >= 20
THEN WRITELN(TERM, 'YOU HAVE REACHED THE PEAK OF EXCELLANCE AND KNOWLEDGE.')
ELSE
BEGIN
MONEY := MONEY - (EXPR(LVL + 1) - EXPR(LVL)) DIV 2;
WRITE(TERM, 'AFTER MANY WEEKS OF TRAINING');
IF NOT (CLASS IN [BARBARIAN, THIEF, FIGHTER])
THEN WRITE(' AND MEDITATION');
WRITELN(' YOU FIND......'); EXPERIENCE := 0;
MAXHITS := MIN(2500, MAXHITS + MAXHITS DIV LVL);
MAXFATIGUE := MIN(2500, MAXFATIGUE + MAXFATIGUE DIV LVL);
MAXMAGIC := MIN(2500, MAXMAGIC + MAXMAGIC DIV LVL);
LVL := MIN(25, LVL + 1);
CASE RND(5) OF
1: STR := MIN(25, STR + 1);
2: DEX := MIN(25, DEX + 1);
3: INT := MIN(25, INT + 1);
4: PTY := MIN(25, PTY + 1);
5: CON := MIN(25, CON + 1);
END (*CASE*);
SKILLNEW := FALSE; IF LVL <= 10 THEN CON := MIN(25, CON + 1);
IF (CLASS=CLERIC) AND (LVL >= 15) THEN
BEGIN
WRITELN(TERM,'YOU HAVE DISCOVERED THE SOURCE OF ULTIMATE KNOWLEDGE AND TRUTH.');
WRITELN(TERM,' ');
WRITELN(TERM,'YOU STAND UP, AND ANNOUNCE YOURSELF TO THE WORLD AS YOU MARCH OFF INTO');
WRITELN(TERM,'THE SUNSET AS ',PS(NAME):0,', THE SAINT OF TRUTH AND LIGHT!');
LVL := 6; CON := 0; HITS := 0; DEAD := TRUE
END
ELSE
PLAYERDISPLAY(USER)
END (*ELSE*)
END (*TRAIN*);
BEGIN
WITH PLAYER ^ DO
IF BRF
THEN
BEGIN
IF FATIGUE = 0 THEN WRITELN(DAMAGE: 0, ' VIT!')
ELSE
IF DAMAGE > FATIGUE
THEN WRITELN(FATIGUE: 0, ' FAT, AND ', DAMAGE - FATIGUE: 0, ' VIT!')
ELSE WRITELN(DAMAGE: 0, ' FAT!')
END (*IF*)
ELSE
BEGIN
IF FATIGUE = 0 THEN WRITELN(DAMAGE: 0, ' VITALITY POINTS!')
ELSE
IF DAMAGE > FATIGUE
THEN
WRITELN(FATIGUE: 0, ' FATIGUE PTS, AND ', DAMAGE - FATIGUE: 0,
' VITALITY PTS!')
ELSE WRITELN(DAMAGE: 0, ' FATIGUE POINTS!')
END (*ELSE*)
END (*PRINTDMG*);
PROCEDURE HITSHARMOR(VAR PLYR: USERPOINT; VAR DAMAGE: INTEGER);
VAR
TEMP: OBJECTPOINT;
BEGIN
ERRLOC := ' SEVEN ';
WITH PLYR ^ DO
BEGIN
IF USARM <> NIL
THEN
BEGIN
DAMAGE := MAX(0, DAMAGE - USARM ^.ARMPLUS);
USARM ^.ARMHITSLEFT := MAX(0, USARM ^.ARMHITSLEFT - 1);
IF USARM ^.ARMHITSLEFT = 0
THEN
BEGIN
WRITELN(TRM, 'YOUR ARMOR FALLS APART!');
IF DELETEOBJECT(USARM, OBJECTTAIL) THEN OBJECTTAIL := OBJECTTAIL ^.NEXT;
WEIGHT := WEIGHT - USARM ^.WEIGHT; TEMP := USARM; STOPUSING(PLYR, USARM);
DISPOSE(TEMP);
END (*IF*)
END (*IF*);
IF USSHIELD <> NIL
THEN
BEGIN
USSHIELD ^.SHHITSLEFT := MAX(0, USSHIELD ^.SHHITSLEFT - 1);
IF USSHIELD ^.SHHITSLEFT = 0
THEN
BEGIN
WRITELN(TRM, 'YOUR SHIELD BREAKS IN HALF!');
IF DELETEOBJECT(USSHIELD, OBJECTTAIL) THEN OBJECTTAIL := OBJECTTAIL ^.NEXT;
WEIGHT := WEIGHT - USSHIELD ^.WEIGHT; TEMP := USSHIELD;
STOPUSING(PLYR, USSHIELD); DISPOSE(TEMP);
END (*IF*)
END (*IF*)
END (*WITH*)
END (*HITSHARMOR*);
PROCEDURE YESNO;
VAR
YES: BOOLEAN;
OBJ: OBJECTPOINT;
BEGIN
YES := (BUFFER[1] = 'Y');
WITH USER ^ DO
CASE ENTRY OF
XPARLEY:
IF YES
THEN
IF DATA > MONEY THEN WRITELN(TERM, 'YOU HAVE NOT ENOUGH MONEY, EFFENDI!')
ELSE
BEGIN
MONEY := MONEY - DATA; NEW(OBJ); OBJ ^ := RANOBJLIST[LASTATK];
OBJ ^.NEXT := ROOM[RMCODE].RMOBJECTTAIL; ROOM[RMCODE].RMOBJECTTAIL := OBJ;
WRITELN(TERM, 'HERE YOU ARE, MY FRIEND. YOU ARE A SHREWD BUYER, EFFENDI!')
END (*ELSE*)
ELSE
WRITELN(TERM, 'OH PLEASE RECONSIDER, EFFENDI! IT IS OF SUCH HIGH QUALITY!');
XREPAIR:
BEGIN
OBJ := USWEAP; USWEAP := NIL;
IF YES AND (OBJ <> NIL)
THEN
IF DATA >= MONEY THEN WRITELN(TERM, '"YOU DON''T HAVE ENOUGH MONEY!"')
ELSE
WITH OBJ ^ DO
BEGIN
IF RND(2) = 1 THEN MAGIC := FALSE;
CASE OBCLASS OF
WEAP:
IF (MAXHP+MINHP>30) AND (RND(2)=1) THEN BEGIN
WRITELN(TERM,'<<CRACK>>! "OOPS! SORRY!", SAYS THE REPAIRMAN MEEKLY.');
MINHP := 1; MAXHP := MAXHP DIV 2 + 1
END
ELSE
BEGIN
IF NOT MAGIC THEN WEAPLUS := MIN(0, WEAPLUS);
STRIKESLEFT := MIN(100, STRIKESLEFT * 2 + 50)
END (*WEAP*);
SHIELD: SHHITSLEFT := MIN(50, SHHITSLEFT * 2 + 25);
ARMOR: ARMHITSLEFT := MIN(50, ARMHITSLEFT * 2 + 25);
END (*CASE*);
WRITELN(TERM, '"HERE IT IS SIR, REPAIRED AS WELL IT CAN BE."');
MONEY := MONEY - DATA
END (*WITH*);
END (*XREPAIR*);
XSELL:
BEGIN
OBJ := USWEAP; USWEAP := NIL;
IF YES AND (OBJ <> NIL)
THEN
BEGIN
MONEY := MIN(500000, MONEY + DATA);
WEIGHT := MAX(0, WEIGHT - OBJ ^.WEIGHT);
IF DELETEOBJECT(OBJ, OBJECTTAIL) THEN OBJECTTAIL := OBJECTTAIL ^.NEXT;
ODESTROY(OBJ); WRITELN(TERM, '"THANK YOU! COME AGAIN!"')
END (*IF*);
END (*XSELL*);
END (*CASE*);
USER ^.ENTRY := XCMD; PROMPTUSER(USER);
END (*YESNO*);
PROCEDURE WISH;
(* PRINTOUT A WISH TO THE DM *)
VAR
DM: USERPOINT;
ILOOP: INTEGER;
FUNCTION LOCTDM(USR: USERPOINT): BOOLEAN;
BEGIN LOCTDM := (USR ^.SSJ) AND (USR ^.STATUS = SNORMAL) END;
BEGIN (*WISH*)
USER ^.ENTRY := XCMD; DM := MATCHUSER(USERTAIL, LOCTDM);
IF DM = NIL THEN WRITELN(TERM, 'YOUR WISH IS NOT HEARD.')
ELSE WRITELN(TERM, 'WISH SENT.');
WHILE DM <> NIL DO
BEGIN
WRITE(DM ^.TRM, '*** ', PS(USER ^.NAME), ' (', W(USER ^.RMCODE): 0,
') CASTS A WISH ');
IF USER ^.WDATA <> BLANKS THEN WRITELN('ON ', USER ^.WDATA) ELSE WRITELN('.');
WRITE(DM ^.TRM, '*** "'); FOR ILOOP := 1 TO LENBUF DO WRITE(BUFFER[ILOOP]);
WRITELN('"'); DM := MATCHUSER(DM ^.NEXTUSER, LOCTDM);
END (*WHILE*);
USER ^.CON := MAX(0, USER ^.CON - 1); DAYMSG('WIS', USER, 'WISH CAST ', 0);
FOR ILOOP := 1 TO MSGTERM(TERMLIST, ALL) DO
WRITELN(TERMLIST[ILOOP], 'THE SKY AROUND ', PS(USER ^.NAME),
' SUDDENLY DARKENS AND THEN CLEARS!');
PROMPTUSER(USER)
END (*WISH*);
FUNCTION READYCHECK(LASTATK: INTEGER): BOOLEAN;
BEGIN
READYCHECK := FALSE;
IF REALTIME + 1 < LASTATK
THEN WRITELN(TERM, 'NOT READY! WAIT ', LASTATK - REALTIME: 1, ' MORE SECONDS.')
ELSE
IF USER ^.DRUNK - REALTIME >= 60
THEN WRITELN(TERM, 'YOU''RE TOO SMASHED TO DO ANYTHING!')
ELSE READYCHECK := TRUE
END (*READYCHECK*);
BEGIN
DAMAGE := 0;
WITH USER ^ DO
CASE SPELLCODE OF
1 (*VIGOR, ONUSPLAYER*):
BEGIN
PLAYER ^.FATIGUE := MIN(PLAYER ^.MAXFATIGUE, PLAYER ^.FATIGUE + LEVEL * 6);
WRITELN(PLAYER ^.TRM, 'YOU NOW HAVE ', PLAYER ^.FATIGUE: 0, ' FATIGUE POINTS.'
);
END (*1*);
