{
This is Monster, a multiuser adventure game system
where the players create the universe.
Written by Rich Skrenta at Northwestern University, 1988.
skrenta@nuacc.acns.nwu.edu
skrenta@nuacc.bitnet
}
program monster(input,output);
const
%include 'privusers.pas'
veryshortlen = 12; { very short string length for userid's etc }
shortlen = 20; { ordinary short string }
maxobjs = 15; { max objects allow on floor in a room }
maxpeople = 10; { max people allowed in a room }
maxplayers = 300; { max log entries to make for players }
maxcmds = 75; { top value for cmd keyword slots }
maxshow = 50; { top value for set/show keywords }
maxexit = 6; { 6 exits from each loc: NSEWUD }
maxroom = 1000; { Total maximum ever possible }
maxdetail = 5; { max num of detail keys/descriptions per room }
maxevent = 15; { event slots per event block }
maxindex = 10000; { top value for bitmap allocation }
maxhold = 6; { max # of things a player can be holding }
maxerr = 15; { # of consecutive record collisions before the
the deadlock error message is printed }
numevnts = 10; { # of different event records to be maintained }
numpunches = 12; { # of different kinds of punches there are }
maxparm = 20; { parms for object USEs }
maxspells = 50; { total number of spells available }
descmax = 10; { lines per description block }
DEFAULT_LINE = 32000; { A virtual one liner record number that
really means "use the default one liner
description instead of reading one from
the file" }
{ Mnemonics for directions }
north = 1;
south = 2;
east = 3;
west = 4;
up = 5;
down = 6;
{ Index record mnemonics }
I_BLOCK = 1; { True if description block is not used }
I_LINE = 2; { True if line slot is not used }
I_ROOM = 3; { True if room slot is not in use }
I_PLAYER = 4; { True if slot is not occupied by a player }
I_ASLEEP = 5; { True if player is not playing }
I_OBJECT = 6; { True if object record is not being used }
I_INT = 7; { True if int record is not being used }
{ Integer record mnemonics }
N_LOCATION = 1; { Player's location }
N_NUMROOMS = 2; { How many rooms they've made }
N_ALLOW = 3; { How many rooms they're allowed to make }
N_ACCEPT = 4; { Number of open accept exits they have }
N_EXPERIENCE = 5; { How "good" they are }
N_SELF = 6; { player's self descriptions }
{ object kind mnemonics }
O_BLAND = 0; { bland object, good for keys }
O_WEAPON = 1;
O_ARMOR = 2;
O_THRUSTER = 3; { use puts player through an exit }
O_CLOAK = 4;
O_BAG = 100;
O_CRYSTAL = 101;
O_WAND = 102;
O_HAND = 103;
{ Command Mnemonics }
error = 0;
setnam = 1;
help = 2;
quest = 3;
quit = 4;
look = 5;
go = 6;
form = 7;
link = 8;
unlink = 9;
c_whisper = 10;
poof = 11;
desc = 12;
dbg = 14;
say = 15;
c_rooms = 17;
c_system = 18;
c_disown = 19;
c_claim = 20;
c_create = 21;
c_public = 22;
c_accept = 23;
c_refuse = 24;
c_zap = 25;
c_hide = 26;
c_l = 27;
c_north = 28;
c_south = 29;
c_east = 30;
c_west = 31;
c_up = 32;
c_down = 33;
c_n = 34;
c_s = 35;
c_e = 36;
c_w = 37;
c_u = 38;
c_d = 39;
c_custom = 40;
c_who = 41;
c_players = 42;
c_search = 43;
c_unhide = 44;
c_punch = 45;
c_ping = 46;
c_health = 47;
c_get = 48;
c_drop = 49;
c_inv = 50;
c_i = 51;
c_self = 52;
c_whois = 53;
c_duplicate = 54;
c_version = 56;
c_objects = 57;
c_use = 58;
c_wield = 59;
c_brief = 60;
c_wear = 61;
c_relink = 62;
c_unmake = 63;
c_destroy = 64;
c_show = 65;
c_set = 66;
e_detail = 100; { pseudo command for log_action of desc exit }
e_custroom = 101; { customizing this room }
e_program = 102; { customizing (programming) an object }
e_usecrystal = 103; { using a crystal ball }
{ Show Mnemonics }
s_exits = 1;
s_object = 2;
s_quest = 3;
s_details = 4;
{ Set Mnemonics }
y_quest = 1;
y_altmsg = 2;
y_group1 = 3;
y_group2 = 4;
{ Event Mnemonics }
E_EXIT = 1; { player left room }
E_ENTER = 2; { player entered room }
E_BEGIN = 3; { player joined game here }
E_QUIT = 4; { player here quit game }
E_SAY = 5; { someone said something }
E_SETNAM = 6; { player set his personal name }
E_POOFIN = 8; { someone poofed into this room }
E_POOFOUT = 9; { someone poofed out of this room }
E_DETACH = 10; { a link has been destroyed }
E_EDITDONE = 11; { someone is finished editing a desc }
E_NEWEXIT = 12; { someone made an exit here }
E_BOUNCEDIN = 13; { an object "bounced" into the room }
E_EXAMINE = 14; { someone is examining something }
E_CUSTDONE = 15; { someone is done customizing an exit }
E_FOUND = 16; { player found something }
E_SEARCH = 17; { player is searching room }
E_DONEDET = 18; { done adding details to a room }
E_HIDOBJ = 19; { someone hid an object here }
E_UNHIDE = 20; { voluntarily revealed themself }
E_FOUNDYOU = 21; { someone found someone else hiding }
E_PUNCH = 22; { someone has punched someone else }
E_MADEOBJ = 23; { someone made an object here }
E_GET = 24; { someone picked up an object }
E_DROP = 25; { someone dropped an object }
E_DROPALL = 26; { quit & dropped stuff on way out }
E_IHID = 27; { tell others that I have hidden (!) }
E_NOISES = 28; { strange noises from hidden people }
E_PING = 29; { send a ping to a potential zombie }
E_PONG = 30; { ping answered }
E_HIDEPUNCH = 31; { someone hidden is attacking }
E_SLIPPED = 32; { attack caused obj to drop unwillingly }
E_ROOMDONE = 33; { done customizing this room }
E_OBJDONE = 34; { done programming an object }
E_HPOOFOUT = 35; { someone hiding poofed out }
E_FAILGO = 36; { a player failed to go through an exit }
E_HPOOFIN = 37; { someone poofed into a room hidden }
E_TRYPUNCH = 38; { someone failed to punch someone else }
E_PINGONE = 39; { someone was pinged away . . . }
E_CLAIM = 40; { someone claimed this room }
E_DISOWN = 41; { owner of this room has disowned it }
E_WEAKER = 42; { person is weaker from battle }
E_OBJCLAIM = 43; { someone claimed an object }
E_OBJDISOWN = 44; { someone disowned an object }
E_SELFDONE = 45; { done editing self description }
E_WHISPER = 46; { someone whispers to someone else }
E_WIELD = 47; { player wields a weapon }
E_UNWIELD = 48; { player puts a weapon away }
E_DONECRYSTALUSE = 49; { done using the crystal ball }
E_WEAR = 50; { someone has put on something }
E_UNWEAR = 51; { someone has taken off something }
E_DESTROY = 52; { someone has destroyed an object }
E_HIDESAY = 53; { anonymous say }
E_OBJPUBLIC = 54; { someone made an object public }
E_SYSDONE = 55; { done with system maint. mode }
E_UNMAKE = 56; { remove typedef for object }
E_LOOKDETAIL = 57; { looking at a detail of this room }
E_ACCEPT = 58; { made an "accept" exit here }
E_REFUSE = 59; { got rid of an "accept" exit here }
E_DIED = 60; { someone died and evaporated }
E_LOOKYOU = 61; { someone is looking at you }
E_FAILGET = 62; { someone can't get something }
E_FAILUSE = 63; { someone can't use something }
E_CHILL = 64; { someone scrys you }
E_NOISE2 = 65; { say while in crystal ball }
E_LOOKSELF = 66; { someone looks at themself }
E_INVENT = 67; { someone takes inventory }
E_POOFYOU = 68; { MM poofs someone away . . . . }
E_WHO = 69; { someone does a who }
E_PLAYERS = 70; { someone does a players }
E_VIEWSELF = 71; { someone views a self description }
E_REALNOISE = 72; { make the real noises message print }
E_ALTNOISE = 73; { alternate mystery message }
E_MIDNIGHT = 74; { it's midnight now, tell everyone }
E_ACTION = 100; { base command action event }
{ Misc. }
GOODHEALTH = 7;
type
string = varying[80] of char;
veryshortstring = varying[veryshortlen] of char;
shortstring = varying[shortlen] of char;
{ This is a list of description block numbers;
If a number is zero, there is no text for that block }
{ exit kinds:
0: no way - blocked exit
1: open passageway
2: object required
6: exit only exists if player is holding the key
}
exit = record
toloc: integer; { location exit goes to }
kind: integer; { type of the exit }
slot: integer; { exit slot of toloc target }
exitdesc, { one liner description of exit }
closed, { desc of a closed door }
fail, { description if can't go thru }
success, { desc while going thru exit }
goin, { what others see when you go into the exit }
{ ofail, }
comeout: { what others see when you come out of the exit }
integer; { all refer to the liner file }
{ if zero defaults will be printed }
hidden: integer; { **** about to change this **** }
objreq: integer; { object required to pass this exit }
alias: veryshortstring; { alias for the exit dir, a keyword }
reqverb: boolean; { require alias as a verb to work }
reqalias: boolean; { require alias only (no direction) to
pass through the exit }
autolook: boolean; { do a look when user comes out of exit }
end;
{ index record # 1 is block index }
{ index record # 2 is line index }
{ index record # 3 is room index }
{ index record # 4 is player alloc index }
{ index record # 5 is player awake (in game) index }
indexrec = record
indexnum: integer; { validation number }
free: packed array[1..maxindex] of boolean;
top: integer; { max records available }
inuse: integer; { record #s in use }
end;
{ names are record #1 }
{ owners are record # 2 }
{ player pers_names are record # 3 }
{ userids are record # 4 }
{ object names are record # 5 }
{ object creators are record # 6 }
{ date of last play is # 7 }
{ time of last play is # 8 }
namrec = record
validate: integer;
loctop: integer;
idents: array[1..maxroom] of shortstring;
end;
objectrec = record
objnum: integer; { allocation number for the object }
onum: integer; { number index to objnam/objown }
oname: shortstring; { duplicate of name of object }
kind: integer; { what kind of object this is }
linedesc: integer; { liner desc of object Here }
home: integer; { if object at home, then print the }
homedesc: integer; { home description }
actindx: integer; { action index -- programs for the future }
examine: integer; { desc block for close inspection }
worth: integer; { how much it cost to make (in gold) }
numexist: integer; { number in existence }
sticky: boolean; { can they ever get it? }
getobjreq: integer; { object required to get this object }
getfail: integer; { fail-to-get description }
getsuccess: integer; { successful picked up description }
useobjreq: integer; { object require to use this object }
uselocreq: integer; { place have to be to use this object }
usefail: integer; { fail-to-use description }
usesuccess: integer; { successful use of object description }
usealias: veryshortstring;
reqalias: boolean;
reqverb: boolean;
particle: integer; { a,an,some, etc... "particle" is not
be right, but hey, it's in the code }
parms: array[1..maxparm] of integer;
d1: integer; { extra description # 1 }
d2: integer; { extra description # 2 }
exp3,exp4,exp5,exp6: integer;
end;
anevent = record
sender, { slot of sender }
action, { what event this is, E_something }
target, { opt target of action }
parm: integer; { expansion parm }
msg: string; { string for SAY and other cmds }
loc: integer; { room that event is targeted for }
end;
eventrec = record
validat: integer; { validation number for record locking }
evnt: array[1..maxevent] of anevent;
point: integer; { circular buffer pointer }
end;
peoplerec = record
kind: integer; { 0=none,1=player,2=npc }
parm: integer; { index to npc controller (object?) }
username: veryshortstring; { actual userid of person }
name: shortstring; { chosen name of person }
hiding: integer; { degree to which they're hiding }
act,targ: integer; { last thing that this person did }
holding: array[1..maxhold] of integer; { objects being held }
experience: integer;
wearing: integer; { object that they're wearing }
wielding: integer; { weapon they're wielding }
health: integer; { how healthy they are }
self: integer; { self description }
ex1,ex2,ex3,ex4,ex5: integer;
end;
spellrec = record
recnum: integer;
level: array[1..maxspells] of integer;
end;
descrec = record
descrinum: integer;
lines: array[1..descmax] of string;
desclen: integer; { number used in this block }
end;
linerec = record
linenum: integer;
theline: string;
end;
room = record
valid: integer; { validation number for record locking }
locnum: integer;
owner: veryshortstring; { who owns the room: userid if private
'' if public
'*' if disowned }
nicename: string; { pretty name for location }
nameprint: integer; { code for printing name:
0: don't print it
1: You're in
2: You're at
}
primary: integer; { room descriptions }
secondary: integer;
which: integer; { 0 = only print primary room desc.
1 = only print secondary room desc.
2 = print both
3 = print primary then secondary
if has magic object }
magicobj: integer; { special object for this room }
effects: integer;
parm: integer;
exits: array[1..maxexit] of exit;
pile: integer; { if more than maxobjs objects here }
objs: array[1..maxobjs] of integer; { refs to object file }
objhide: array[1..maxobjs] of integer; { how much each object
is hidden }
{ see hidden on exitrec
above }
objdrop: integer; { where objects go when they're dropped }
objdesc: integer; { what it says when they're dropped }
objdest: integer; { what it says in target room when
"bounced" object comes in }
people: array[1..maxpeople] of peoplerec;
grploc1,grploc2: integer;
grpnam1,grpnam2: shortstring;
detail: array[1..maxdetail] of veryshortstring;
detaildesc: array[1..maxdetail] of integer;
trapto: integer; { where the "trapdoor" goes }
trapchance: integer; { how often the trapdoor works }
rndmsg: integer; { message that randomly prints }
xmsg2: integer; { another random block }
exp2,exp3,exp4: integer;
exitfail: integer; { default fail description for exits }
ofail: integer; { what other's see when you fail, default }
end;
intrec = record
intnum: integer;
int: array[1..maxplayers] of integer;
end;
var
old_prompt: [external] string;
line: [external] string;
oldcmd: string; { string for '.' command to do last command }
inmem: boolean; { Is this rooms roomrec (here....) in memory?
We call gethere many times to make sure
here is current. However, we only want to
actually do a getroom if the roomrec has been
modified }
brief: boolean := FALSE; { brief/verbose descriptions }
rndcycle: integer; { integer for rnd_event }
debug: boolean;
ping_answered: boolean; { flag for ping answers }
hiding : boolean := FALSE; { is player hiding? }
midnight_notyet: boolean := TRUE; { hasn't been midnight yet }
first_puttoken: boolean := TRUE; { flag for first place into world }
logged_act : boolean := FALSE; { flag to indicate that a log_action
has been called, and the next call
to clear_command needs to clear the
action parms in the here roomrec }
roomfile : file of room;
eventfile: file of eventrec;
namfile: file of namrec;
descfile: file of descrec;
linefile: file of linerec;
indexfile: file of indexrec;
intfile: file of intrec;
objfile: file of objectrec;
spellfile: file of spellrec;
cmds: array[1..maxcmds] of shortstring := (
'name', { setnam = 1 }
'help', { help = 2 }
'?', { quest = 3 }
'quit', { quit = 4 }
'look', { look = 5 }
'go', { go = 6 }
'form', { form = 7 }
'link', { link = 8 }
'unlink', { unlink = 9 }
'whisper', { c_whisper = 10}
'poof', { poof = 11 }
'describe', { desc = 12 }
'',
'debug', { dbg = 14 }
'say', { say = 15 }
'', { }
'rooms', { c_rooms = 17 }
'system', { c_system = 18 }
'disown', { c_disown = 19 }
'claim', { c_claim = 20 }
'make', { c_create = 21 }
'public', { c_public = 22 }
'accept', { c_accept = 23 }
'refuse', { c_refuse = 24 }
'zap', { c_zap = 25 }
'hide', { c_hide = 26 }
'l', { c_l = 27 }
'north', { c_north = 28 }
'south', { c_south = 29 }
'east', { c_east = 30 }
'west', { c_west = 31 }
'up', { c_up = 32 }
'down', { c_down = 33 }
'n', { c_n = 34 }
's', { c_s = 35 }
'e', { c_e = 36 }
'w', { c_w = 37 }
'u', { c_u = 38 }
'd', { c_d = 39 }
'customize', { c_custom = 40 }
'who', { c_who = 41 }
'players', { c_players = 42}
'search', { c_search = 43 }
'reveal', { c_unhide = 44 }
'punch', { c_punch = 45 }
'ping', { c_ping = 46 }
'health', { c_health = 47 }
'get', { c_get = 48 }
'drop', { c_drop = 49 }
'inventory', { c_inv = 50 }
'i', { c_i = 51 }
'self', { c_self = 52 }
'whois', { c_whois = 53 }
'duplicate', { c_duplicate = 54 }
'',
'version', { c_version = 56}
'objects', { c_objects = 57}
'use', { c_use = 58 }
'wield', { c_wield = 59 }
'brief', { c_brief = 60 }
'wear', { c_wear = 61 }
'relink', { c_relink = 62 }
'unmake', { c_unmake = 63 }
'destroy', { c_destroy = 64}
'show', { c_show = 65 }
'set', { c_set = 66 }
'',
'',
'',
'',
'',
'',
'',
'',
''
);
numcmds: integer; { number of main level commands there are }
show: array[1..maxshow] of shortstring;
numshow: integer;
setkey: array[1..maxshow] of shortstring;
numset: integer;
direct: array[1..maxexit] of shortstring :=
('north','south','east','west','up','down');
spells: array[1..maxspells] of string; { names of spells }
numspells: integer; { number of spells there actually are }
done: boolean; { flag for QUIT }
userid: veryshortstring; { userid of this player }
location: integer; { current place number }
hold_kind: array[1..maxhold] of integer; { kinds of the objects i'm
holding }
myslot: integer := 1; { here.people[myslot]... is this player }
myname: shortstring; { personal name this player chose (setname) }
myevent: integer; { which point in event buffer we are at }
found_exit: array[1..maxexit] of boolean;
{ has exit i been found by the player? }
mylog: integer; { which log entry this player is }
mywear: integer; { what I'm wearing }
mywield: integer; { weapon I'm wielding }
myhealth: integer; { how well I'm feeling }
myexperience: integer; { how experienced I am }
myself: integer; { self description block }
healthcycle: integer; { used in rnd_event to control how quickly a
player heals }
here: room; { current room record }
event: eventrec;
privd: boolean;
objnam, { object names }
objown, { object owners }
nam, { record 1 is room names }
own, { rec 2 is room owners }
pers, { 3 is player personal names }
user, { 4 is player userid }
adate, { 5 is date of last play }
atime { 6 is time of last play }
: namrec;
anint: intrec; { info about game players }
obj: objectrec;
spell: spellrec;
block: descrec; { a text block of descmax lines }
indx: indexrec; { an record allocation record }
oneliner: linerec; { a line record }
heredsc: descrec;
[external]
procedure wait(seconds: real); { system SLEEP call }
external;
[external]
function random:real; { system random number generator }
external;
[external]
function rnd100: integer; { returns a random # between 0-100 }
external;
[external]
procedure setup_guts; { disables ctrl-Y/ctrl-C }
{ necessary to prevent ZOMBIES in the world }
extern;
[external]
procedure finish_guts; { re-enables ctrl-Y/ctrl-C }
extern;
[external] function get_userid:string;
external;
[external] function trim(s: string): string;
external;
[external]
procedure grab_line(prompt: string; var s:string; echo:boolean := true);
{ Input routine. Gets a line of text from user which checking
for async events }
external;
[external]
procedure putchars(s: string);
extern;
procedure xpoof(loc: integer);
forward;
procedure do_exit(exit_slot: integer);
forward;
function put_token(room: integer;var aslot:integer;hidelev:integer := 0):boolean;
forward;
procedure take_token(aslot, roomno: integer);
forward;
procedure maybe_drop;
forward;
procedure do_program(objnam: string);
forward;
function drop_everything(pslot: integer := 0): boolean;
forward;
procedure collision_wait;
var
wait_time: real;
begin
wait_time := random;
if wait_time < 0.001 then
wait_time := 0.001;
wait(wait_time);
end;
{ increment err; if err is too high, suspect deadlock }
{ this is called by all getX procedures to ease deadlock checking }
procedure deadcheck(var err: integer; s:string);
begin
err := err + 1;
if err > maxerr then begin
writeln('%warning- ',s,' seems to be deadlocked; notify the Monster Manager');
finish_guts;
halt;
err := 0;
end;
end;
{ first procedure of form getX
attempts to get given room record
resolves record access conflicts, checks for deadlocks
Locks record; use freeroom immediately after getroom if data is
for read-only
}
procedure getroom(n: integer:= 0);
var
err: integer;
begin
if n = 0 then
n := location;
roomfile^.valid := 0;
err := 0;
if debug then
writeln('%getroom(',n:1,')');
find(roomfile,n,error := continue);
while roomfile^.valid <> n do begin
deadcheck(err,'getroom');
collision_wait;
find(roomfile,n,error := continue);
end;
here := roomfile^;
inmem := false;
{ since this getroom could be doing anything, we will
assume that it is bozoing the correct here record for
this room. If this getroom called by gethere, then
gethere will correct inmem immediately. Otherwise
the next gethere will restore the correct here record. }
end;
procedure putroom;
begin
locate(roomfile,here.valid);
roomfile^ := here;
put(roomfile);
end;
procedure freeroom; { unlock the record if you're not going to write it }
begin
unlock(roomfile);
end;
procedure gethere(n: integer := 0);
begin
if (n = 0) or (n = location) then begin
if not(inmem) then begin
getroom; { getroom(n) okay here also }
freeroom;
inmem := true;
end else if debug then
writeln('%gethere - here already in memory');
end else begin
getroom(n);
freeroom;
end;
end;
procedure getown;
var
err: integer;
begin
namfile^.validate := 0;
err := 0;
find(namfile,2,error := continue);
while namfile^.validate <> 2 do begin
deadcheck(err,'getown');
collision_wait;
find(namfile,2,error := continue);
end;
own := namfile^;
end;
procedure getnam;
var
err: integer;
begin
namfile^.validate := 0;
err := 0;
find(namfile,1,error := continue);
while namfile^.validate <> 1 do begin
deadcheck(err,'getnam');
collision_wait;
find(namfile,1,error := continue);
end;
nam := namfile^;
end;
procedure freenam;
begin
unlock(namfile);
end;
procedure freeown;
begin
unlock(namfile);
end;
procedure putnam;
begin
locate(namfile,1);
namfile^:= nam;
put(namfile);
end;
procedure putown;
begin
locate(namfile,2);
namfile^:= own;
put(namfile);
end;
procedure getobj(n: integer);
var
err: integer;
begin
if n = 0 then
n := location;
objfile^.objnum := 0;
err := 0;
find(objfile,n,error := continue);
while objfile^.objnum <> n do begin
deadcheck(err,'getobj');
collision_wait;
find(objfile,n,error := continue);
end;
obj := objfile^;
end;
procedure putobj;
begin
locate(objfile,obj.objnum);
objfile^ := obj;
put(objfile);
end;
procedure freeobj; { unlock the record if you're not going to write it }
begin
unlock(objfile);
end;
procedure getint(n: integer);
var
err: integer;
begin
intfile^.intnum := 0;
err := 0;
find(intfile,n,error := continue);
while intfile^.intnum <> n do begin
deadcheck(err,'getint');
collision_wait;
find(intfile,n,error := continue);
end;
anint := intfile^;
end;
procedure freeint;
begin
unlock(intfile);
end;
procedure putint;
var
n: integer;
begin
n := anint.intnum;
locate(intfile,n);
intfile^:= anint;
put(intfile);
end;
procedure getspell(n: integer := 0);
var
err: integer;
begin
if n = 0 then
n := mylog;
spellfile^.recnum := 0;
err := 0;
find(spellfile,n,error := continue);
while spellfile^.recnum <> n do begin
deadcheck(err,'getspell');
collision_wait;
find(spellfile,n,error := continue);
end;
spell := spellfile^;
end;
procedure freespell;
begin
unlock(spellfile);
end;
procedure putspell;
var
n: integer;
begin
n := spell.recnum;
locate(spellfile,n);
spellfile^:= spell;
put(spellfile);
end;
procedure getuser; { get log rec with everyone's userids in it }
var
err: integer;
begin
namfile^.validate := 0;
err := 0;
find(namfile,4,error := continue);
while namfile^.validate <> 4 do begin
deadcheck(err,'getuser');
collision_wait;
find(namfile,4,error := continue);
end;
user := namfile^;
end;
procedure freeuser;
begin
unlock(namfile);
end;
procedure putuser;
begin
locate(namfile,4);
namfile^:= user;
put(namfile);
end;
procedure getdate; { get log rec with date of last play in it }
var
err: integer;
begin
namfile^.validate := 0;
err := 0;
find(namfile,7,error := continue);
while namfile^.validate <> 7 do begin
deadcheck(err,'getdate');
collision_wait;
find(namfile,7,error := continue);
end;
adate := namfile^;
end;
procedure freedate;
begin
unlock(namfile);
end;
procedure putdate;
begin
locate(namfile,7);
namfile^:= adate;
put(namfile);
end;
procedure gettime; { get log rec with time of last play in it }
var
err: integer;
begin
namfile^.validate := 0;
err := 0;
find(namfile,8,error := continue);
while namfile^.validate <> 8 do begin
deadcheck(err,'gettime');
collision_wait;
find(namfile,8,error := continue);
end;
atime := namfile^;
end;
procedure freetime;
begin
unlock(namfile);
end;
procedure puttime;
begin
locate(namfile,8);
namfile^:= atime;
put(namfile);
end;
procedure getobjnam;
var
err: integer;
begin
namfile^.validate := 0;
err := 0;
find(namfile,5,error := continue);
while namfile^.validate <> 5 do begin
deadcheck(err,'getobjnam');
collision_wait;
find(namfile,5,error := continue);
end;
objnam := namfile^;
end;
procedure freeobjnam;
begin
unlock(namfile);
end;
procedure putobjnam;
begin
locate(namfile,5);
namfile^:= objnam;
put(namfile);
end;
procedure getobjown;
var
err: integer;
begin
namfile^.validate := 0;
err := 0;
find(namfile,6,error := continue);
while namfile^.validate <> 6 do begin
deadcheck(err,'getobjown');
collision_wait;
find(namfile,6,error := continue);
end;
objown := namfile^;
end;
procedure freeobjown;
begin
unlock(namfile);
end;
procedure putobjown;
begin
locate(namfile,6);
namfile^:= objown;
put(namfile);
end;
procedure getpers; { get log rec with everyone's pers names in it }
var
err: integer;
begin
namfile^.validate := 0;
err := 0;
find(namfile,3,error := continue);
while namfile^.validate <> 3 do begin
deadcheck(err,'getpers');
collision_wait;
find(namfile,3,error := continue);
end;
pers := namfile^;
end;
procedure freepers;
begin
unlock(namfile);
end;
procedure putpers;
begin
locate(namfile,3);
namfile^:= pers;
put(namfile);
end;
procedure getevent(n: integer := 0);
var
err: integer;
begin
if n = 0 then
n := location;
n := (n mod numevnts) + 1;
eventfile^.validat := 0;
err := 0;
find(eventfile,n,error := continue);
while eventfile^.validat <> n do begin
deadcheck(err,'getevent');
collision_wait;
find(eventfile,n,error := continue);
end;
event := eventfile^;
end;
procedure freeevent;
begin
unlock(eventfile);
end;
procedure putevent;
begin
locate(eventfile,event.validat);
eventfile^:= event;
put(eventfile);
end;
procedure getblock(n: integer);
var
err: integer;
begin
if debug then
writeln('%getblock: ',n:1);
descfile^.descrinum := 0;
err := 0;
find(descfile,n,error := continue);
while descfile^.descrinum <> n do begin
deadcheck(err,'getblock');
collision_wait;
find(descfile,n,error := continue);
end;
block := descfile^;
end;
procedure putblock;
var
n: integer;
begin
n := block.descrinum;
if debug then
writeln('%putblock: ',n:1);
if n <> 0 then begin
locate(descfile,n);
descfile^ := block;
put(descfile);
end;
end;
procedure freeblock; { unlock the record if you're not going to write it }
begin
unlock(descfile);
end;
{ *** new code begins here *** }
procedure getline(n: integer);
var
err: integer;
begin
if n = -1 then begin
oneliner.theline := '';
end else begin
err := 0;
linefile^.linenum := 0;
find(linefile,n,error := continue);
while linefile^.linenum <> n do begin
deadcheck(err,'getline');
collision_wait;
find(linefile,n,error := continue);
end;
oneliner := linefile^;
end;
end;
procedure putline;
begin
if oneliner.linenum > 0 then begin
locate(linefile,oneliner.linenum);
linefile^ := oneliner;
put(linefile);
end;
end;
procedure freeline; { unlock the record if you're not going to write it }
begin
unlock(linefile);
end;
{
Index record 1 -- Description blocks that are free
Index record 2 -- One liners that are free
}
procedure getindex(n: integer);
var
err: integer;
begin
indexfile^.indexnum := 0;
err := 0;
find(indexfile,n,error := continue);
while indexfile^.indexnum <> n do begin
deadcheck(err,'getindex');
collision_wait;
find(indexfile,n,error := continue);
end;
indx := indexfile^;
end;
procedure putindex;
begin
locate(indexfile,indx.indexnum);
indexfile^ := indx;
put(indexfile);
end;
procedure freeindex; { unlock the record if you're not going to write it }
begin
unlock(indexfile);
end;
{
First procedure of form alloc_X
Allocates the oneliner resource using the indexrec bitmaps
Return the number of a one liner if one is available
and remove it from the free list
}
function alloc_line(var n: integer):boolean;
var
found: boolean;
begin
getindex(I_LINE);
if indx.inuse = indx.top then begin
freeindex;
n := 0;
alloc_line := false;
writeln('There are no available one line descriptions.');
end else begin
n := 1;
found := false;
while (not found) and (n <= indx.top) do begin
if indx.free[n] then
found := true
else
n := n + 1;
end;
if found then begin
indx.free[n] := false;
alloc_line := true;
indx.inuse := indx.inuse + 1;
putindex;
end else begin
freeindex;
writeln('%serious error in alloc_line; notify Monster Manager');
alloc_line := false;
end;
end;
end;
{
put the line specified by n back on the free list
zeroes n also, for convenience
}
procedure delete_line(var n: integer);
begin
if n = DEFAULT_LINE then
n := 0
else if n > 0 then begin
getindex(I_LINE);
indx.inuse := indx.inuse - 1;
indx.free[n] := true;
putindex;
end;
n := 0;
end;
function alloc_int(var n: integer):boolean;
var
found: boolean;
begin
getindex(I_INT);
if indx.inuse = indx.top then begin
freeindex;
n := 0;
alloc_int := false;
writeln('There are no available integer records.');
end else begin
n := 1;
found := false;
while (not found) and (n <= indx.top) do begin
if indx.free[n] then
found := true
else
n := n + 1;
end;
if found then begin
indx.free[n] := false;
alloc_int := true;
indx.inuse := indx.inuse + 1;
putindex;
end else begin
freeindex;
writeln('%serious error in alloc_int; notify Monster Manager');
alloc_int := false;
end;
end;
end;
procedure delete_int(var n: integer);
begin
if n > 0 then begin
getindex(I_INT);
indx.inuse := indx.inuse - 1;
indx.free[n] := true;
putindex;
end;
n := 0;
end;
{
Return the number of a description block if available and
remove it from the free list
}
function alloc_block(var n: integer):boolean;
var
found: boolean;
begin
if debug then
writeln('%alloc_block entry');
getindex(I_BLOCK);
if indx.inuse = indx.top then begin
freeindex;
n := 0;
alloc_block := false;
writeln('There are no available description blocks.');
end else begin
n := 1;
found := false;
while (not found) and (n <= indx.top) do begin
if indx.free[n] then
found := true
else
n := n + 1;
end;
if found then begin
indx.free[n] := false;
alloc_block := true;
indx.inuse := indx.inuse + 1;
putindex;
if debug then
writeln('%alloc_block successful');
end else begin
freeindex;
writeln('%serious error in alloc_block; notify Monster Manager');
alloc_block := false;
end;
end;
end;
{
puts a description block back on the free list
zeroes n for convenience
}
procedure delete_block(var n: integer);
begin
if n = DEFAULT_LINE then
n := 0 { no line really exists in the file }
else if n > 0 then begin
getindex(I_BLOCK);
indx.inuse := indx.inuse - 1;
indx.free[n] := true;
putindex;
n := 0;
end else if n < 0 then begin
n := (- n);
delete_line(n);
end;
end;
{
Return the number of a room if one is available
and remove it from the free list
}
function alloc_room(var n: integer):boolean;
var
found: boolean;
begin
getindex(I_ROOM);
if indx.inuse = indx.top then begin
freeindex;
n := 0;
alloc_room := false;
writeln('There are no available free rooms.');
end else begin
n := 1;
found := false;
while (not found) and (n <= indx.top) do begin
if indx.free[n] then
found := true
else
n := n + 1;
end;
if found then begin
indx.free[n] := false;
alloc_room := true;
indx.inuse := indx.inuse + 1;
putindex;
end else begin
freeindex;
writeln('%serious error in alloc_room; notify Monster Manager');
alloc_room := false;
end;
end;
end;
{
Called by DEL_ROOM()
put the room specified by n back on the free list
zeroes n also, for convenience
}
procedure delete_room(var n: integer);
begin
if n <> 0 then begin
getindex(I_ROOM);
indx.inuse := indx.inuse - 1;
indx.free[n] := true;
putindex;
n := 0;
end;
end;
function alloc_log(var n: integer):boolean;
var
found: boolean;
begin
getindex(I_PLAYER);
if indx.inuse = indx.top then begin
freeindex;
n := 0;
alloc_log := false;
writeln('There are too many monster players, you can''t find a space.');
end else begin
n := 1;
found := false;
while (not found) and (n <= indx.top) do begin
if indx.free[n] then
found := true
else
n := n + 1;
end;
if found then begin
indx.free[n] := false;
alloc_log := true;
indx.inuse := indx.inuse + 1;
putindex;
end else begin
freeindex;
writeln('%serious error in alloc_log; notify Monster Manager');
alloc_log := false;
end;
end;
end;
procedure delete_log(var n: integer);
begin
if n <> 0 then begin
getindex(I_PLAYER);
indx.inuse := indx.inuse - 1;
indx.free[n] := true;
putindex;
n := 0;
end;
end;
function lowcase(s: string):string;
var
sprime: string;
i: integer;
begin
if length(s) = 0 then
lowcase := ''
else begin
sprime := s;
for i := 1 to length(s) do
if sprime[i] in ['A'..'Z'] then
sprime[i] := chr(ord('a')+(ord(sprime[i])-ord('A')));
lowcase := sprime;
end;
end;
{ lookup a spell with disambiguation in the spell list }
function lookup_spell(var n: integer;s:string): boolean;
var
i,poss,maybe,num: integer;
begin
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to numspells do begin
if s = spells[i] then
num := i
else if index(spells[i],s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
if num <> 0 then begin
n := num;
lookup_spell := true;
end else if maybe = 1 then begin
n := poss;
lookup_spell := true;
end else if maybe > 1 then begin
lookup_spell := false;
end else begin
lookup_spell := false;
end;
end;
function lookup_user(var pnum: integer;s: string): boolean;
var
i,poss,maybe,num: integer;
begin
getuser;
freeuser;
getindex(I_PLAYER);
freeindex;
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to indx.top do begin
if not(indx.free[i]) then begin
if s = user.idents[i] then
num := i
else if index(user.idents[i],s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
end;
if num <> 0 then begin
pnum := num;
lookup_user := true;
end else if maybe = 1 then begin
pnum := poss;
lookup_user := true;
end else if maybe > 1 then begin
{ writeln('-- Ambiguous direction'); }
lookup_user := false;
end else begin
lookup_user := false;
{ writeln('-- Unknown direction'); }
end;
end;
function alloc_obj(var n: integer):boolean;
var
found: boolean;
begin
getindex(I_OBJECT);
if indx.inuse = indx.top then begin
freeindex;
n := 0;
alloc_obj := false;
writeln('All of the possible objects have been made.');
end else begin
n := 1;
found := false;
while (not found) and (n <= indx.top) do begin
if indx.free[n] then
found := true
else
n := n + 1;
end;
if found then begin
indx.free[n] := false;
alloc_obj := true;
indx.inuse := indx.inuse + 1;
putindex;
end else begin
freeindex;
writeln('%serious error in alloc_obj; notify Monster Manager');
alloc_obj := false;
end;
end;
end;
procedure delete_obj(var n: integer);
begin
if n <> 0 then begin
getindex(I_OBJECT);
indx.inuse := indx.inuse - 1;
indx.free[n] := true;
putindex;
n := 0;
end;
end;
function lookup_obj(var pnum: integer;s: string): boolean;
var
i,poss,maybe,num: integer;
tmp: string;
begin
getobjnam;
freeobjnam;
getindex(I_OBJECT);
freeindex;
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to indx.top do begin
if not(indx.free[i]) then begin
if s = objnam.idents[i] then
num := i
else if index(objnam.idents[i],s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
end;
if num <> 0 then begin
pnum := num;
lookup_obj := true;
end else if maybe = 1 then begin
pnum := poss;
lookup_obj := true;
end else if maybe > 1 then begin
{ writeln('-- Ambiguous direction'); }
lookup_obj := false;
end else begin
lookup_obj := false;
{ writeln('-- Unknown direction'); }
end;
end;
{ returns true if object N is in this room }
function obj_here(n: integer): boolean;
var
i: integer;
found: boolean;
begin
i := 1;
found := false;
while (i <= maxobjs) and (not found) do begin
if here.objs[i] = n then
found := true
else
i := i + 1;
end;
obj_here := found;
end;
{ returns true if object N is being held by the player }
function obj_hold(n: integer): boolean;
var
i: integer;
found: boolean;
begin
if n = 0 then
obj_hold := false
else begin
i := 1;
found := false;
while (i <= maxhold) and (not found) do begin
if here.people[myslot].holding[i] = n then
found := true
else
i := i + 1;
end;
obj_hold := found;
end;
end;
{ return the slot of an object that is HERE }
function find_obj(objnum: integer): integer;
var
i: integer;
begin
i := 1;
find_obj := 0;
while i <= maxobjs do begin
if here.objs[i] = objnum then
find_obj := i;
i := i + 1;
end;
end;
{ similar to lookup_obj, but only returns true if the object is in
this room or is being held by the player }
function parse_obj(var n: integer; s: string;override: boolean := false): boolean;
var
slot: integer;
begin
if lookup_obj(n,s) then begin
if obj_here(n) or obj_hold(n) then
{ took out a great block of code that wouldn't let
parse_obj work if player couldn't see object }
parse_obj := true;
end else
parse_obj := false;
end;
function lookup_pers(var pnum: integer;s: string): boolean;
var
i,poss,maybe,num: integer;
pname: string;
begin
getpers;
freepers;
getindex(I_PLAYER);
freeindex;
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to indx.top do begin
if not(indx.free[i]) then begin
pname := lowcase(pers.idents[i]);
if s = pname then
num := i
else if index(pname,s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
end;
if num <> 0 then begin
pnum := num;
lookup_pers := true;
end else if maybe = 1 then begin
pnum := poss;
lookup_pers := true;
end else if maybe > 1 then begin
{ writeln('-- Ambiguous direction'); }
lookup_pers := false;
end else begin
lookup_pers := false;
{ writeln('-- Unknown direction'); }
end;
end;
function parse_pers(var pnum: integer;s: string): boolean;
var
persnum: integer;
i,poss,maybe,num: integer;
pname: string;
begin
gethere;
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to maxpeople do begin
{ if here.people[i].username <> '' then begin }
if here.people[i].kind > 0 then begin
pname := lowcase(here.people[i].name);
if s = pname then
num := i
else if index(pname,s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
end;
if num <> 0 then begin
persnum := num;
parse_pers := true;
end else if maybe = 1 then begin
persnum := poss;
parse_pers := true;
end else if maybe > 1 then begin
persnum := 0;
parse_pers := false;
end else begin
persnum := 0;
parse_pers := false;
end;
if persnum > 0 then begin
if here.people[persnum].hiding > 0 then
parse_pers := false
else begin
parse_pers := true;
pnum := persnum;
end;
end;
end;
{
Returns TRUE if player is owner of room n
If no n is given default will be this room (location)
}
function is_owner(n: integer := 0;surpress:boolean := false): boolean;
begin
gethere(n);
if (here.owner = userid) or (privd) then
is_owner := true
else begin
is_owner := false;
if not(surpress) then
writeln('You are not the owner of this room.');
end;
end;
function room_owner(n: integer): string;
begin
if n <> 0 then begin
gethere(n);
room_owner := here.owner;
gethere; { restore old state! }
end else
room_owner := 'no room';
end;
{
Returns TRUE if player is allowed to alter the exit
TRUE if either this room or if target room is owned by player
}
function can_alter(dir: integer;room: integer := 0): boolean;
begin
gethere;
if (here.owner=userid) or (privd) then begin
can_alter := true
end else begin
if here.exits[dir].toloc > 0 then begin
if room_owner(here.exits[dir].toloc) = userid then
can_alter := true
else
can_alter := false;
end else
can_alter := false;
end;
end;
function can_make(dir: integer;room: integer := 0): boolean;
begin
gethere(room); { 5 is accept door }
if (here.exits[dir].toloc <> 0) then begin
writeln('There is already an exit there. Use UNLINK or RELINK.');
can_make := false;
end else begin
if (here.owner = userid) or { I'm the owner }
(here.exits[dir].kind = 5) or { there's an accept }
(privd) or { Monster Manager }
(here.owner = '*') { disowned room }
then
can_make := true
else begin
can_make := false;
writeln('You are not allowed to create an exit there.');
end;
end;
end;
{
print a one liner
}
procedure print_line(n: integer);
begin
if n = DEFAULT_LINE then
writeln('<default line>')
else if n > 0 then begin
getline(n);
freeline;
writeln(oneliner.theline);
end;
end;
procedure print_desc(dsc: integer;default:string := '<no default supplied>');
var
i: integer;
begin
if dsc = DEFAULT_LINE then begin
writeln(default);
end else if dsc > 0 then begin
getblock(dsc);
freeblock;
i := 1;
while i <= block.desclen do begin
writeln(block.lines[i]);
i := i + 1;
end;
end else if dsc < 0 then begin
print_line(abs(dsc));
end;
end;
procedure make_line(var n: integer;prompt : string := '';limit:integer := 79);
var
s: string;
ok: boolean;
begin
writeln('Type ** to leave line unchanged, * to make [no line]');
grab_line(prompt,s);
if s = '**' then begin
writeln('No changes.');
end else if s = '***' then begin
n := DEFAULT_LINE;
end else if s = '*' then begin
if debug then
writeln('%deleting line ',n:1);
delete_line(n);
end else if s = '' then begin
if debug then
writeln('%deleting line ',n:1);
delete_line(n);
end else if length(s) > limit then begin
writeln('Please limit your string to ',limit:1,' characters.');
end else begin
if (n = 0) or (n = DEFAULT_LINE) then begin
if debug then
writeln('%makeline: allocating line');
ok := alloc_line(n);
end else
ok := true;
if ok then begin
if debug then
writeln('%ok in makeline');
getline(n);
oneliner.theline := s;
putline;
if debug then
writeln('%completed putline in makeline');
end;
end;
end;
{ translate a direction s [north, south, etc...] into the integer code }
function lookup_dir(var dir: integer;s:string): boolean;
var
i,poss,maybe,num: integer;
begin
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to maxexit do begin
if s = direct[i] then
num := i
else if index(direct[i],s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
if num <> 0 then begin
dir := num;
lookup_dir := true;
end else if maybe = 1 then begin
dir := poss;
lookup_dir := true;
end else if maybe > 1 then begin
lookup_dir := false;
{ writeln('-- Ambiguous direction'); }
end else begin
lookup_dir := false;
{ writeln('-- Unknown direction'); }
end;
end;
function lookup_show(var n: integer;s:string): boolean;
var
i,poss,maybe,num: integer;
begin
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to numshow do begin
if s = show[i] then
num := i
else if index(show[i],s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
if num <> 0 then begin
n := num;
lookup_show := true;
end else if maybe = 1 then begin
n := poss;
lookup_show := true;
end else if maybe > 1 then begin
lookup_show := false;
{ writeln('-- Ambiguous direction'); }
end else begin
lookup_show := false;
{ writeln('-- Unknown direction'); }
end;
end;
function lookup_set(var n: integer;s:string): boolean;
var
i,poss,maybe,num: integer;
begin
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to numset do begin
if s = setkey[i] then
num := i
else if index(setkey[i],s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
if num <> 0 then begin
n := num;
lookup_set := true;
end else if maybe = 1 then begin
n := poss;
lookup_set := true;
end else if maybe > 1 then begin
lookup_set := false;
end else begin
lookup_set := false;
end;
end;
function lookup_room(var n: integer; s: string): boolean;
var
found: boolean;
top: integer;
i,
poss,
maybe,
num: integer;
begin
if s <> '' then begin
s := lowcase(s); { case insensitivity }
getnam;
freenam;
getindex(I_ROOM);
freeindex;
top := indx.top;
i := 1;
maybe := 0;
num := 0;
for i := 1 to top do begin
if s = nam.idents[i] then
num := i
else if index(nam.idents[i],s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
if num <> 0 then begin
lookup_room := true;
n := num;
end else if maybe = 1 then begin
lookup_room := true;
n := poss;
end else if maybe > 1 then begin
lookup_room := false;
end else begin
lookup_room := false;
end;
end else
lookup_room := false;
end;
function exact_room(var n: integer;s: string): boolean;
var
match: boolean;
begin
if debug then
writeln('%exact room: s = ',s);
if lookup_room(n,s) then begin
if nam.idents[n] = lowcase(s) then
exact_room := true
else
exact_room := false;
end else
exact_room := false;
end;
function exact_pers(var n: integer;s: string): boolean;
var
match: boolean;
begin
if lookup_pers(n,s) then begin
if lowcase(pers.idents[n]) = lowcase(s) then
exact_pers := true
else
exact_pers := false;
end else
exact_pers := false;
end;
function exact_user(var n: integer;s: string): boolean;
var
match: boolean;
begin
if lookup_user(n,s) then begin
if lowcase(user.idents[n]) = lowcase(s) then
exact_user := true
else
exact_user := false;
end else
exact_user := false;
end;
function exact_obj(var n: integer;s: string): boolean;
var
match: boolean;
begin
if lookup_obj(n,s) then begin
if objnam.idents[n] = lowcase(s) then
exact_obj := true
else
exact_obj := false;
end else
exact_obj := false;
end;
{
Return n as the direction number if s is a valid alias for an exit
}
function lookup_alias(var n: integer; s: string): boolean;
var
i,poss,maybe,num: integer;
begin
gethere;
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to maxexit do begin
if s = here.exits[i].alias then
num := i
else if index(here.exits[i].alias,s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
if num <> 0 then begin
n := num;
lookup_alias := true;
end else if maybe = 1 then begin
n := poss;
lookup_alias := true;
end else if maybe > 1 then begin
lookup_alias := false;
end else begin
lookup_alias := false;
end;
end;
procedure exit_default(dir, kind: integer);
begin
case kind of
1: writeln('There is a passage leading ',direct[dir],'.');
2: writeln('There is a locked door leading ',direct[dir],'.');
5: case dir of
north,south,east,west:
writeln('A note on the ',direct[dir],' wall says "Your exit here."');
up: writeln('A note on the ceiling says "Your exit here."');
down: writeln('A note on the floor says "Your exit here."');
end;
otherwise writeln('There is an exit: ',direct[dir]);
end;
end;
{
Prints out the exits here for DO_LOOK()
}
procedure show_exits;
var
i: integer;
one: boolean;
cansee: boolean;
begin
one := false;
for i := 1 to maxexit do begin
if (here.exits[i].toloc <> 0) or { there is an exit }
(here.exits[i].kind = 5) then begin { there could be an exit }
if (here.exits[i].hidden = 0) or
(found_exit[i]) then
cansee := true
else
cansee := false;
if here.exits[i].kind = 6 then begin
{ door kind only visible with object }
if obj_hold( here.exits[i].objreq ) then
cansee := true
else
cansee := false;
end;
if cansee then begin
if here.exits[i].exitdesc = DEFAULT_LINE then begin
exit_default(i,here.exits[i].kind);
{ give it direction and type }
one := true;
end else if here.exits[i].exitdesc > 0 then begin
print_line(here.exits[i].exitdesc);
one := true;
end;
end;
end;
end;
if one then
writeln;
end;
procedure setevent;
begin
getevent;
freeevent;
myevent := event.point;
end;
function isnum(s: string): boolean;
var
i: integer;
begin
isnum := true;
if length(s) < 1 then
isnum := false
else begin
i := 1;
while i <= length(s) do begin
if not (s[i] in ['0'..'9']) then
isnum := false;
i := i + 1;
end;
end;
end;
function number(s: string): integer;
var
i: integer;
begin
if (length(s) < 1) or not(s[1] in ['0'..'9']) then
number := 0
else begin
readv(s,i);
number := i;
end;
end;
procedure log_event( send: integer := 0; { slot of sender }
act:integer; { what event occurred }
targ: integer := 0; { target of event }
p: integer := 0; { expansion parameter }
s: string := ''; { string for messages }
room: integer := 0 { room to log event in }
);
begin
if room = 0 then
room := location;
getevent(room);
event.point := event.point + 1;
if debug then
writeln('%logging event ',act:1,' to point ',event.point:1);
if event.point > maxevent then
event.point := 1;
with event.evnt[event.point] do begin
sender := send;
action := act;
target := targ;
parm := p;
msg := s;
loc := room;
end;
putevent;
end;
procedure log_action(theaction,thetarget: integer);
begin
if debug then
writeln('%log_action(',theaction:1,',',thetarget:1,')');
getroom;
here.people[myslot].act := theaction;
here.people[myslot].targ := thetarget;
putroom;
logged_act := true;
log_event(myslot,E_ACTION,thetarget,theaction,myname);
end;
function desc_action(theaction,thetarget: integer): string;
var
s: string;
begin
case theaction of { use command mnemonics }
look: s:= ' looking around the room.';
form: s:= ' creating a new room.';
desc: s:= ' editing the description to this room.';
e_detail: s := ' adding details to the room.';
c_custom: s := ' customizing an exit here.';
e_custroom:s := ' customizing this room.';
e_program: s := ' customizing an object.';
c_self: s := ' editing a self-description.';
e_usecrystal: s := ' hunched over a crystal orb, immersed in its glow.';
link: s := ' creating an exit here.';
c_system: s := ' in system maintenance mode.';
otherwise s := ' here.'
end;
desc_action := s;
end;
function protected(n: integer := 0): boolean;
begin
if n = 0 then
n := myslot;
if here.people[n].act in [e_detail,c_custom,
e_custroom,e_program,
c_self,c_system] then
protected := true
else
protected := false;
end;
{
user procedure to designate an exit for acceptance of links
}
procedure do_accept(s: string);
var
dir: integer;
begin
if lookup_dir(dir,s) then begin
if can_make(dir) then begin
getroom;
here.exits[dir].kind := 5;
putroom;
log_event(myslot,E_ACCEPT,0,0);
writeln('Someone will be able to make an exit ',direct[dir],'.');
end;
end else
writeln('To allow others to make an exit, type ACCEPT <direction of exit>.');
end;
{
User procedure to refuse an exit for links
Note: may be unlink
}
procedure do_refuse(s: string);
var
dir: integer;
ok: boolean;
begin
if not(is_owner) then
{ is_owner prints error message itself }
else if lookup_dir(dir,s) then begin
getroom;
with here.exits[dir] do begin
if (toloc = 0) and (kind = 5) then begin
kind := 0;
ok := true;
end else
ok := false;
end;
putroom;
if ok then begin
log_event(myslot,E_REFUSE,0,0);
writeln('Exits ',direct[dir],' will be refused.');
end else
writeln('Exits were not being accepted there.');
end else
writeln('To undo an Accept, type REFUSE <direction>.');
end;
function systime:string;
var
hourstring: string;
hours: integer;
thetime: packed array[1..11] of char;
dayornite: string;
begin
time(thetime);
if thetime[1] = ' ' then
hours := ord(thetime[2]) - ord('0')
else
hours := (ord(thetime[1]) - ord('0'))*10 +
(ord(thetime[2]) - ord('0'));
if hours < 12 then
dayornite := 'am'
else
dayornite := 'pm';
if hours >= 13 then
hours := hours - 12;
if hours = 0 then
hours := 12;
writev(hourstring,hours:2);
systime := hourstring + ':' + thetime[4] + thetime[5] + dayornite;
end;
{ substitute a parameter string for the # sign in the source string }
function subs_parm(s,parm: string): string;
var
right,left: string;
i: integer; { i is point to break at }
begin
i := index(s,'#');
if (i > 0) and ((length(s) + length(parm)) <= 80) then begin
if i >= length(s) then begin
right := '';
left := s;
end else if i < 1 then begin
right := s;
left := '';
end else begin
right := substr(s,i+1,length(s)-i);
left := substr(s,1,i);
end;
if length(left) <= 1 then
left := ''
else
left := substr(left,1,length(left)-1);
subs_parm := left + parm + right;
end else begin
subs_parm := s;
end;
end;
procedure time_health;
begin
if healthcycle > 0 then begin { how quickly they heal }
if myhealth < 7 then begin { heal a little bit }
myhealth := myhealth + 1;
getroom;
here.people[myslot].health := myhealth;
putroom;
{show new health rating }
case myhealth of
9: writeln('You are now in exceptional health.');
8: writeln('You feel much stronger. You are in better than average condition.');
7: writeln('You are now in perfect health.');
6: writeln('You only feel a little bit dazed now.');
5: begin
writeln('You only have some minor cuts and abrasions now. Most of your serious wounds');
writeln('have healed.');
end;
4: writeln('You are only suffering from some minor wounds now.');
3: writeln('Your most serious wounds have healed, but you are still in bad shape.');
2: writeln('You have healed somewhat, but are still very badly wounded.');
1: writeln('You are in critical condition, but there may be hope.');
0: writeln('are still dead.');
otherwise writeln('You don''t seem to be in any condition at all.');
end;
putchars(chr(10)+old_prompt+line);
end;
healthcycle := 0;
end else
healthcycle := healthcycle + 1;
end;
procedure time_noises;
var
n: integer;
begin
if rnd100 <= 2 then begin
n := rnd100;
if n in [0..40] then
log_event(0,E_NOISES,rnd100,0)
else if n in [41..60] then
log_event(0,E_ALTNOISE,rnd100,0);
end;
end;
procedure time_trapdoor(silent: boolean);
var
fall: boolean;
begin
if rnd100 < here.trapchance then begin
{ trapdoor fires! }
if here.trapto > 0 then begin
{ logged action should cover {protected) }
if {(protected) or} (logged_act) then
fall := false
else if here.magicobj = 0 then
fall := true
else if obj_hold(here.magicobj) then
fall := false
else
fall := true;
end else
fall := false;
if fall then begin
do_exit(here.trapto);
if not(silent) then
putchars(chr(10)+old_prompt+line);
end;
end;
end;
procedure time_midnight;
begin
if systime = '12:00am' then
log_event(0,E_MIDNIGHT,rnd100,0);
end;
{ cause random events to occurr (ha ha ha) }
procedure rnd_event(silent: boolean := false);
var
n: integer;
begin
if rndcycle = 200 then begin { inside here 3 times/min }
time_noises;
time_health;
time_trapdoor(silent);
time_midnight;
rndcycle := 0;
end else
rndcycle := rndcycle + 1;
end;
procedure do_die;
var
some: boolean;
begin
writeln;
writeln(' *** You have died ***');
writeln;
some := drop_everything;
myhealth := 7;
take_token(myslot,location);
log_event(0,E_DIED,0,0,myname);
if put_token(2,myslot) then begin
location := 2;
inmem := false;
setevent;
{ log entry to death loc }
{ perhaps turn off refs to other people }
end else begin
writeln('The Monster universe regrets to inform you that you cannot be ressurected at');
writeln('the moment.');
halt;
end;
end;
procedure poor_health(p: integer);
var
some: boolean;
begin
if myhealth > p then begin
myhealth := myhealth - 1;
getroom;
here.people[myslot].health := myhealth;
putroom;
log_event(myslot,E_WEAKER,myhealth,0);
{ show new health rating }
write('You ');
case here.people[myslot].health of
9: writeln('are still in exceptional health.');
8: writeln('feel weaker, but are in better than average condition.');
7: writeln('are somewhat weaker, but are in perfect health.');
6: writeln('feel a little bit dazed.');
5: writeln('have some minor cuts and abrasions.');
4: writeln('have some wounds, but are still fairly strong.');
3: writeln('are suffering from some serious wounds.');
2: writeln('are very badly wounded.');
1: writeln('have many serious wounds, and are near death.');
0: writeln('are dead.');
otherwise writeln('don''t seem to be in any condition at all.');
end;
end else begin { they died }
do_die;
end;
end;
{ count objects here }
function find_numobjs: integer;
var
sum,i: integer;
begin
sum := 0;
for i := 1 to maxobjs do
if here.objs[i] <> 0 then
sum := sum + 1;
find_numobjs := sum;
end;
{ optional parameter is slot of player's objects to count }
function find_numhold(player: integer := 0): integer;
var
sum,i: integer;
begin
if player = 0 then
player := myslot;
sum := 0;
for i := 1 to maxhold do
if here.people[player].holding[i] <> 0 then
sum := sum + 1;
find_numhold := sum;
end;
procedure take_hit(p: integer);
var
i: integer;
begin
if p > 0 then begin
if rnd100 < (55 + (p-1) * 30) then { chance that they're hit }
poor_health(p);
if find_numobjs < maxobjs + 1 then begin
{ maybe they drop something if they're hit }
for i := 1 to p do
maybe_drop;
end;
end;
end;
function punch_force(sock: integer): integer;
var
p: integer;
begin
if sock in [2,3,6,7,8,11,12] then { no punch or a graze }
p := 0
else if sock in [4,9,10] then { hard punches }
p := 2
else { 1,5,13,14,15 }
p := 1; { all others are medium punches }
punch_force := p;
end;
procedure put_punch(sock: integer;s: string);
begin
case sock of
1: writeln('You deliver a quick jab to ',s,'''s jaw.');
2: writeln('You swing at ',s,' and miss.');
3: writeln('A quick punch, but it only grazes ',s,'.');
4: writeln(s,' doubles over after your jab to the stomach.');
5: writeln('Your punch lands square on ',s,'''s face!');
6: writeln('You swing wild and miss.');
7: writeln('A good swing, but it misses ',s,' by a mile!');
8: writeln('Your punch is blocked by ',s,'.');
9: writeln('Your roundhouse blow sends ',s,' reeling.');
10:writeln('You land a solid uppercut on ',s,'''s chin.');
11:writeln(s,' fends off your blow.');
12:writeln(s,' ducks and avoids your punch.');
13:writeln('You thump ',s,' in the ribs.');
14:writeln('You catch ',s,'''s face on your elbow.');
15:writeln('You knock the wind out of ',s,' with a punch to the chest.');
end;
end;
procedure get_punch(sock: integer;s: string);
begin
case sock of
1: writeln(s,' delivers a quick jab to your jaw!');
2: writeln(s,' swings at you but misses.');
3: writeln(s,'''s fist grazes you.');
4: writeln('You double over after ',s,' lands a mean jab to your stomach!');
5: writeln('You see stars as ',s,' bashes you in the face.');
6: writeln('You only feel the breeze as ',s,' swings wildly.');
7: writeln(s,'''s swing misses you by a yard.');
8: writeln('With lightning reflexes you block ',s,'''s punch.');
9: writeln(s,'''s blow sends you reeling.');
10:writeln('Your head snaps back from ',s,'''s uppercut!');
11:writeln('You parry ',s,'''s attack.');
12:writeln('You duck in time to avoid ',s,'''s punch.');
13:writeln(s,' thumps you hard in the ribs.');
14:writeln('Your vision blurs as ',s,' elbows you in the head.');
15:writeln(s,' knocks the wind out of you with a punch to your chest.');
end;
end;
procedure view_punch(a,b: string;p: integer);
begin
case p of
1: writeln(a,' jabs ',b,' in the jaw.');
2: writeln(a,' throws a wild punch at the air.');
3: writeln(a,'''s fist barely grazes ',b,'.');
4: writeln(b,' doubles over in pain with ',a,'''s punch');
5: writeln(a,' bashes ',b,' in the face.');
6: writeln(a,' takes a wild swing at ',b,' and misses.');
7: writeln(a,' swings at ',b,' and misses by a yard.');
8: writeln(b,'''s punch is blocked by ',a,'''s quick reflexes.');
9: writeln(b,' is sent reeling from a punch by ',a,'.');
10:writeln(a,' lands an uppercut on ',b,'''s head.');
11:writeln(b,' parrys ',a,'''s attack.');
12:writeln(b,' ducks to avoid ',a,'''s punch.');
13:writeln(a,' thumps ',b,' hard in the ribs.');
14:writeln(a,'''s elbow connects with ',b,'''s head.');
15:writeln(a,' knocks the wind out of ',b,'.');
end;
end;
procedure desc_health(n: integer;header:shortstring := '');
begin
if header = '' then
write(here.people[n].name,' ')
else
write(header);
case here.people[n].health of
9: writeln('is in exceptional health, and looks very strong.');
8: writeln('is in better than average condition.');
7: writeln('is in perfect health.');
6: writeln('looks a little dazed.');
5: writeln('has some minor cuts and abrasions.');
4: writeln('has some minor wounds.');
3: writeln('is suffering from some serious wounds.');
2: writeln('is very badly wounded.');
1: writeln('has many serious wounds, and is near death.');
0: writeln('is dead.');
otherwise writeln('doesn''t seem to be in any condition at all.');
end;
end;
function obj_part(objnum: integer;doread: boolean := TRUE): string;
var
s: string;
begin
if doread then begin
getobj(objnum);
freeobj;
end;
s := obj.oname;
case obj.particle of
0:;
1: s := 'a ' + s;
2: s := 'an ' + s;
3: s := 'some ' + s;
4: s := 'the ' + s;
end;
obj_part := s;
end;
procedure print_subs(n: integer;s: string);
begin
if (n > 0) and (n <> DEFAULT_LINE) then begin
getline(n);
freeline;
writeln(subs_parm(oneliner.theline,s));
end else if n = DEFAULT_LINE then
writeln('%<default line> in print_subs');
end;
{ print out a (up to) 10 line description block, substituting string s for
up to one occurance of # per line }
procedure block_subs(n: integer;s: string);
var
p,i: integer;
begin
if n < 0 then
print_subs(abs(n),s)
else if (n > 0) and (n <> DEFAULT_LINE) then begin
getblock(n);
freeblock;
i := 1;
while i <= block.desclen do begin
p := index(block.lines[i],'#');
if (p > 0) then
writeln(subs_parm(block.lines[i],s))
else
writeln(block.lines[i]);
i := i + 1;
end;
end;
end;
procedure show_noises(n: integer);
begin
if n < 33 then
writeln('There are strange noises coming from behind you.')
else if n < 66 then
writeln('You hear strange rustling noises behind you.')
else
writeln('There are faint noises coming from behind you.');
end;
procedure show_altnoise(n: integer);
begin
if n < 33 then
writeln('A chill wind blows, ruffling your clothes and chilling your bones.')
else if n < 66 then
writeln('Muffled scuffling sounds can be heard behind you.')
else
writeln('A loud crash can be heard in the distance.');
end;
procedure show_midnight(n: integer;var printed: boolean);
begin
if midnight_notyet then begin
if n < 50 then begin
writeln('A voice booms out of the air from all around you!');
writeln('The voice says, " It is now midnight. "');
end else begin
writeln('You hear a clock chiming in the distance.');
writeln('It rings twelve times for midnight.');
end;
midnight_notyet := false;
end else
printed := false;
end;
procedure handle_event(var printed: boolean);
var
n,send,act,targ,p: integer;
s: string;
sendname: string;
begin
printed := true;
if debug then
writeln('%handling event ',myevent);
with event.evnt[myevent] do begin
send := sender;
act := action;
targ := target;
p := parm;
s := msg;
end;
if send <> 0 then
sendname := here.people[send].name
else
sendname := '<Unknown>';
case act of
E_EXIT: begin
if here.exits[targ].goin = DEFAULT_LINE then
writeln(s,' has gone ',direct[targ],'.')
else if (here.exits[targ].goin <> 0) and
(here.exits[targ].goin <> DEFAULT_LINE) then begin
block_subs(here.exits[targ].goin,s);
end else
printed := false;
end;
E_ENTER: begin
if here.exits[targ].comeout = DEFAULT_LINE then
writeln(s,' has come into the room from: ',direct[targ])
else if (here.exits[targ].comeout <> 0) and
(here.exits[targ].comeout <> DEFAULT_LINE) then begin
block_subs(here.exits[targ].comeout,s);
end else
printed := false;
end;
E_BEGIN:writeln(s,' appears in a brilliant burst of multicolored light.');
E_QUIT:writeln(s,' vanishes in a brilliant burst of multicolored light.');
E_SAY: begin
if length(s) + length(sendname) > 73 then begin
writeln(sendname,' says,');
writeln('"',s,'"');
end else begin
if (rnd100 < 50) or (length(s) > 50) then
writeln(sendname,': "',s,'"')
else
writeln(sendname,' says, "',s,'"');
end;
end;
E_HIDESAY: begin
writeln('An unidentified voice speaks to you:');
writeln('"',s,'"');
end;
E_SETNAM: writeln(s);
E_POOFIN: writeln('In an explosion of orange smoke ',s,' poofs into the room.');
E_POOFOUT: writeln(s,' vanishes from the room in a cloud of orange smoke.');
E_DETACH: begin
writeln(s,' has destroyed the exit ',direct[targ],'.');
end;
E_EDITDONE:begin
writeln(sendname,' is done editing the room description.');
end;
E_NEWEXIT: begin
writeln(s,' has created an exit here.');
end;
E_CUSTDONE:begin
writeln(sendname,' is done customizing an exit here.');
end;
E_SEARCH: writeln(sendname,' seems to be looking for something.');
E_FOUND: writeln(sendname,' appears to have found something.');
E_DONEDET:begin
writeln(sendname,' is done adding details to the room.');
end;
E_ROOMDONE: begin
writeln(sendname,' is finished customizing this room.');
end;
E_OBJDONE: begin
writeln(sendname,' is finished customizing an object.');
end;
E_UNHIDE:writeln(sendname,' has stepped out of the shadows.');
E_FOUNDYOU: begin
if targ = myslot then begin { found me! }
writeln('You''ve been discovered by ',sendname,'!');
hiding := false;
getroom;
{ they're not hidden anymore } here.people[myslot].hiding := 0;
putroom;
end else
writeln(sendname,' has found ',here.people[targ].name,' hiding in the shadows!');
end;
E_PUNCH: begin
if targ = myslot then begin { punched me! }
get_punch(p,sendname);
take_hit( punch_force(p) );
{ relic, but not harmful } ping_answered := true;
healthcycle := 0;
end else
view_punch(sendname,here.people[targ].name,p);
end;
E_MADEOBJ: writeln(s);
E_GET: writeln(s);
E_DROP: begin
writeln(s);
if here.objdesc <> 0 then
print_subs(here.objdesc,obj_part(p));
end;
E_BOUNCEDIN: begin
if (targ = 0) or (targ = DEFAULT_LINE) then
writeln(obj_part(p),' has bounced into the room.')
else begin
print_subs(targ,obj_part(p));
end;
end;
E_DROPALL: writeln('Some objects drop to the ground.');
E_EXAMINE: writeln(s);
E_IHID: writeln(sendname,' has hidden in the shadows.');
E_NOISES: begin
if (here.rndmsg = 0) or
(here.rndmsg = DEFAULT_LINE) then begin
show_noises(targ);
end else
print_line(here.rndmsg);
end;
E_ALTNOISE: begin
if (here.xmsg2 = 0) or
(here.xmsg2 = DEFAULT_LINE) then
show_altnoise(targ)
else
block_subs(here.xmsg2,myname);
end;
E_REALNOISE: show_noises(targ);
E_HIDOBJ: writeln(sendname,' has hidden the ',s,'.');
E_PING: begin
if targ = myslot then begin
writeln(sendname,' is trying to ping you.');
log_event(myslot,E_PONG,send,0);
end else
writeln(sendname,' is pinging ',here.people[targ].name,'.');
end;
E_PONG: begin
ping_answered := true;
end;
E_HIDEPUNCH: begin
if targ = myslot then begin
writeln(sendname,' pounces on you from the shadows!');
take_hit(2);
end else begin
writeln(sendname,' jumps out of the shadows and attacks ',here.people[targ].name,'.');
end;
end;
E_SLIPPED: begin
writeln('The ',s,' has slipped from ',
sendname,'''s hands.');
end;
E_HPOOFOUT:begin
if rnd100 > 50 then
writeln('Great wisps of orange smoke drift out of the shadows.')
else
printed := false;
end;
E_HPOOFIN:begin
if rnd100 > 50 then
writeln('Some wisps of orange smoke drift about in the shadows.')
else
printed := false;
end;
E_FAILGO: begin
if targ > 0 then begin
write(sendname,' has failed to go ');
writeln(direct[targ],'.');
end;
end;
E_TRYPUNCH: begin
if targ = myslot then
writeln(sendname,' fails to punch you.')
else
writeln(sendname,' fails to punch ',here.people[targ].name,'.');
end;
E_PINGONE:begin
if targ = myslot then begin { ohoh---pinged away }
writeln('The Monster program regrets to inform you that a destructive ping has');
writeln('destroyed your existence. Please accept our apologies.');
halt; { ugggg }
end else
writeln(s,' shimmers and vanishes from sight.');
end;
E_CLAIM: writeln(sendname,' has claimed this room.');
E_DISOWN: writeln(sendname,' has disowned this room.');
E_WEAKER: begin
{ inmem := false;
gethere; }
here.people[send].health := targ;
{ This is a hack for efficiency so we don't read the room record twice;
we need the current data now for desc_health, but checkevents, our caller,
is about to re-read it anyway; we make an incremental fix here so desc_health
is happy, then checkevents will do the real read later }
desc_health(send);
end;
E_OBJCLAIM: writeln(sendname,' is now the owner of the ',s,'.');
E_OBJDISOWN: writeln(sendname,' has disowned the object ',s,'.');
E_SELFDONE: writeln(sendname,'''s self-description is finished.');
E_WHISPER: begin
if targ = myslot then begin
if length(s) < 39 then
writeln(sendname,' whispers to you, "',s,'"')
else begin
writeln(sendname,' whispers something to you:');
write(sendname,' whispers, ');
if length(s) > 50 then
writeln;
writeln('"',s,'"');
end;
end else if (privd) or (rnd100 > 85) then begin
writeln('You overhear ',sendname,' whispering to ',here.people[targ].name,'!');
write(sendname,' whispers, ');
if length(s) > 50 then
writeln;
writeln('"',s,'"');
end else
writeln(sendname,' is whispering to ',here.people[targ].name,'.');
end;
E_WIELD: writeln(sendname,' is now wielding the ',s,'.');
E_UNWIELD: writeln(sendname,' is no longer wielding the ',s,'.');
E_WEAR: writeln(sendname,' is now wearing the ',s,'.');
E_UNWEAR: writeln(sendname,' has taken off the ',s,'.');
E_DONECRYSTALUSE: begin
writeln(sendname,' emerges from the glow of the crystal.');
writeln('The orb becomes dark.');
end;
E_DESTROY: writeln(s);
E_OBJPUBLIC: writeln('The object ',s,' is now public.');
E_SYSDONE: writeln(sendname,' is no longer in system maintenance mode.');
E_UNMAKE: writeln(sendname,' has unmade ',s,'.');
E_LOOKDETAIL: writeln(sendname,' is looking at the ',s,'.');
E_ACCEPT: writeln(sendname,' has accepted an exit here.');
E_REFUSE: writeln(sendname,' has refused an Accept here.');
E_DIED: writeln(s,' expires and vanishes in a cloud of greasy black smoke.');
E_LOOKYOU: begin
if targ = myslot then begin
writeln(sendname,' is looking at you.')
end else
writeln(sendname,' looks at ',here.people[targ].name,'.');
end;
E_LOOKSELF: writeln(sendname,' is making a self-appraisal.');
E_FAILGET: writeln(sendname,' fails to get ',obj_part(targ),'.');
E_FAILUSE: writeln(sendname,' fails to use ',obj_part(targ),'.');
E_CHILL: if (targ = 0) or (targ = DEFAULT_LINE) then
writeln('A chill wind blows over you.')
else
print_desc(targ);
E_NOISE2:begin
case targ of
1: writeln('Strange, gutteral noises sound from everywhere.');
2: writeln('A chill wind blows past you, almost whispering as it ruffles your clothes.');
3: writeln('Muffled voices speak to you from the air!');
otherwise writeln('The air vibrates with a chill shudder.');
end;
end;
E_INVENT: writeln(sendname,' is taking inventory.');
E_POOFYOU: begin
if targ = myslot then begin
writeln;
writeln(sendname,' directs a firey burst of bluish energy at you!');
writeln('Suddenly, you find yourself hurtling downwards through misty orange clouds.');
writeln('Your descent slows, the smoke clears, and you find yourself in a new place...');
xpoof(p);
writeln;
end else begin
writeln(sendname,' directs a firey burst of energy at ',here.people[targ].name,'!');
writeln('A thick burst of orange smoke results, and when it clears, you see');
writeln('that ',here.people[targ].name,' is gone.');
end;
end;
E_WHO: begin
case p of
0: writeln(sendname,' produces a "who" list and reads it.');
1: writeln(sendname,' is seeing who''s playing Monster.');
otherwise writeln(sendname,' checks the "who" list.');
end;
end;
E_PLAYERS:begin
writeln(sendname,' checks the "players" list.');
end;
E_VIEWSELF: writeln(sendname,' is reading ',s,'''s self-description.');
E_MIDNIGHT: show_midnight(targ,printed);
E_ACTION:writeln(sendname,' is',desc_action(p,targ));
otherwise writeln('*** Bad Event ***');
end;
end;
[global]
procedure checkevents(silent: boolean := false);
var
gotone: boolean;
tmp,printed: boolean;
begin
getevent;
freeevent;
event := eventfile^;
gotone := false;
printed := false;
while myevent <> event.point do begin
myevent := myevent + 1;
if myevent > maxevent then
myevent := 1;
if debug then begin
writeln('%checking event ',myevent);
if event.evnt[myevent].loc = location then
writeln(' - event here')
else
writeln(' - event elsewhere');
writeln(' - event number = ',event.evnt[myevent].action:1);
end;
if (event.evnt[myevent].loc = location) then begin
if (event.evnt[myevent].sender <> myslot) then begin
{ if sent by me don't look at it }
{ will use global record event }
handle_event(tmp);
if tmp then
printed := true;
inmem := false; { re-read important data that }
gethere; { may have been altered }
gotone := true;
end;
end;
end;
if (printed) and (gotone) and not(silent) then begin
putchars(chr(10)+chr(13)+old_prompt+line);
end;
rnd_event(silent);
end;
{ count the number of people in this room; assumes a gethere has been done }
function find_numpeople: integer;
var
sum,i: integer;
begin
sum := 0;
for i := 1 to maxpeople do
if here.people[i].kind > 0 then
{ if here.people[i].username <> '' then }
sum := sum + 1;
find_numpeople := sum;
end;
{ don't give them away, but make noise--maybe
percent is percentage chance that they WON'T make any noise }
procedure noisehide(percent: integer);
begin
{ assumed gethere; }
if (hiding) and (find_numpeople > 1) then begin
if rnd100 > percent then
log_event(myslot,E_REALNOISE,rnd100,0);
{ myslot: don't tell them they made noise }
end;
end;
function checkhide: boolean;
begin
if (hiding) then begin
checkhide := false;
noisehide(50);
writeln('You can''t do that while you''re hiding.');
end else
checkhide := true;
end;
procedure clear_command;
begin
if logged_act then begin
getroom;
here.people[myslot].act := 0;
putroom;
logged_act := false;
end;
end;
{ forward procedure take_token(aslot, roomno: integer); }
procedure take_token;
{ remove self from a room's people list }
begin
getroom(roomno);
with here.people[aslot] do begin
kind := 0;
username:= '';
name := '';
end;
putroom;
end;
{ fowrard function put_token(room: integer;var aslot:integer;
hidelev:integer := 0):boolean;
put a person in a room's people list
returns myslot }
function put_token;
var
i,j: integer;
found: boolean;
savehold: array[1..maxhold] of integer;
begin
if first_puttoken then begin
for i := 1 to maxhold do
savehold[i] := 0;
first_puttoken := false;
end else begin
gethere;
for i := 1 to maxhold do
savehold[i] := here.people[myslot].holding[i];
end;
getroom(room);
i := 1;
found := false;
while (i <= maxpeople) and (not found) do begin
if here.people[i].name = '' then
found := true
else
i := i + 1;
end;
put_token := found;
if found then begin
here.people[i].kind := 1; { I'm a real player }
here.people[i].name := myname;
here.people[i].username := userid;
here.people[i].hiding := hidelev;
{ hidelev is zero for most everyone
unless you want to poof in and remain hidden }
here.people[i].wearing := mywear;
here.people[i].wielding := mywield;
here.people[i].health := myhealth;
here.people[i].self := myself;
here.people[i].act := 0;
for j := 1 to maxhold do
here.people[i].holding[j] := savehold[j];
putroom;
aslot := i;
for j := 1 to maxexit do { haven't found any exits in }
found_exit[j] := false; { the new room }
{ note the user's new location in the logfile }
getint(N_LOCATION);
anint.int[mylog] := room;
putint;
end else
freeroom;
end;
procedure log_exit(direction,room,sender_slot: integer);
begin
log_event(sender_slot,E_EXIT,direction,0,myname,room);
end;
procedure log_entry(direction,room,sender_slot: integer);
begin
log_event(sender_slot,E_ENTER,direction,0,myname,room);
end;
procedure log_begin(room:integer := 1);
begin
log_event(0,E_BEGIN,0,0,myname,room);
end;
procedure log_quit(room:integer;dropped:boolean);
begin
log_event(0,E_QUIT,0,0,myname,room);
if dropped then
log_event(0,E_DROPALL,0,0,myname,room);
end;
{ return the number of people you can see here }
function n_can_see: integer;
var
sum: integer;
i: integer;
selfslot: integer;
begin
if here.locnum = location then
selfslot := myslot
else
selfslot := 0;
sum := 0;
for i := 1 to maxpeople do
if ( i <> selfslot ) and
( length(here.people[i].name) > 0 ) and
( here.people[i].hiding = 0 ) then
sum := sum + 1;
n_can_see := sum;
if debug then
writeln('%n_can_see = ',sum:1);
end;
function next_can_see(var point: integer): string;
var
found: boolean;
selfslot: integer;
begin
if here.locnum <> location then
selfslot := 0
else
selfslot := myslot;
found := false;
while (not found) and (point <= maxpeople) do begin
if (point <> selfslot) and
(length(here.people[point].name) > 0) and
(here.people[point].hiding = 0) then
found := true
else
point := point + 1;
end;
if found then begin
next_can_see := here.people[point].name;
point := point + 1;
end else begin
next_can_see := myname; { error! error! }
writeln('%searching error in next_can_see; notify the Monster Manager');
end;
end;
procedure niceprint(var len: integer; s: string);
begin
if len + length(s) > 78 then begin
len := 0;
writeln;
end else begin
len := len + length(s);
end;
write(s);
end;
procedure people_header(where: shortstring);
var
point: integer;
tmp: string;
i: integer;
n: integer;
len: integer;
begin
point := 1;
n := n_can_see;
case n of
0:;
1: begin
writeln(next_can_see(point),' is ',where);
end;
2: begin
writeln(next_can_see(point),' and ',next_can_see(point),
' are ',where);
end;
otherwise begin
len := 0;
for i := 1 to n - 1 do begin { at least 1 to 2 }
tmp := next_can_see(point);
if i <> n - 1 then
tmp := tmp + ', ';
niceprint(len,tmp);
end;
niceprint(len,' and ');
niceprint(len,next_can_see(point));
niceprint(len,' are ' + where);
writeln;
end;
end;
end;
procedure desc_person(i: integer);
var
pname: shortstring;
begin
pname := here.people[i].name;
if here.people[i].act <> 0 then begin
write(pname,' is');
writeln(desc_action(here.people[i].act,
here.people[i].targ));
{ describes what person last did }
end;
if here.people[i].health <> GOODHEALTH then
desc_health(i);
if here.people[i].wielding > 0 then
writeln(pname,' is wielding ',obj_part(here.people[i].wielding),'.');
end;
procedure show_people;
var
i: integer;
begin
people_header('here.');
for i := 1 to maxpeople do begin
if (here.people[i].name <> '') and
(i <> myslot) and
(here.people[i].hiding = 0) then
desc_person(i);
end;
end;
procedure show_group;
var
gloc1,gloc2: integer;
gnam1,gnam2: shortstring;
begin
gloc1 := here.grploc1;
gloc2 := here.grploc2;
gnam1 := here.grpnam1;
gnam2 := here.grpnam2;
if gloc1 <> 0 then begin
gethere(gloc1);
people_header(gnam1);
end;
if gloc2 <> 0 then begin
gethere(gloc2);
people_header(gnam2);
end;
gethere;
end;
procedure desc_obj(n: integer);
begin
if n <> 0 then begin
getobj(n);
freeobj;
if (obj.linedesc = DEFAULT_LINE) then begin
writeln('On the ground here is ',obj_part(n,FALSE),'.');
{ the FALSE means obj_part shouldn't do its
own getobj, cause we already did one }
end else
print_line(obj.linedesc);
end;
end;
procedure show_objects;
var
i: integer;
begin
for i := 1 to maxobjs do begin
if (here.objs[i] <> 0) and (here.objhide[i] = 0) then
desc_obj(here.objs[i]);
end;
end;
function lookup_detail(var n: integer;s:string): boolean;
var
i,poss,maybe,num: integer;
begin
n := 0;
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to maxdetail do begin
if s = here.detail[i] then
num := i
else if index(here.detail[i],s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
if num <> 0 then begin
n := num;
lookup_detail := true;
end else if maybe = 1 then begin
n := poss;
lookup_detail := true;
end else if maybe > 1 then begin
lookup_detail := false;
end else begin
lookup_detail := false;
end;
end;
function look_detail(s: string): boolean;
var
n: integer;
begin
if lookup_detail(n,s) then begin
if here.detaildesc[n] = 0 then
look_detail := false
else begin
print_desc(here.detaildesc[n]);
log_event(myslot,E_LOOKDETAIL,0,0,here.detail[n]);
look_detail := true;
end;
end else
look_detail := false;
end;
function look_person(s: string): boolean;
var
objnum,i,n: integer;
first: boolean;
begin
if parse_pers(n,s) then begin
if n = myslot then begin
log_event(myslot,E_LOOKSELF,n,0);
writeln('You step outside of yourself for a moment to get an objective self-appraisal:');
writeln;
end else
log_event(myslot,E_LOOKYOU,n,0);
if here.people[n].self <> 0 then begin
print_desc(here.people[n].self);
writeln;
end;
desc_health(n);
{ Do an inventory of person S }
first := true;
for i := 1 to maxhold do begin
objnum := here.people[n].holding[i];
if objnum <> 0 then begin
if first then begin
writeln(here.people[n].name,' is holding:');
first := false;
end;
writeln(' ',obj_part(objnum));
end;
end;
if first then
writeln(here.people[n].name,' is empty handed.');
look_person := true;
end else
look_person := false;
end;
procedure do_examine(s: string;var three: boolean;silent:boolean := false);
var
n: integer;
msg: string;
begin
three := false;
if parse_obj(n,s) then begin
if obj_here(n) or obj_hold(n) then begin
three := true;
getobj(n);
freeobj;
msg := myname + ' is examining ' + obj_part(n) + '.';
log_event(myslot,E_EXAMINE,0,0,msg);
if obj.examine = 0 then
writeln('You see nothing special about the ',
objnam.idents[n],'.')
else
print_desc(obj.examine);
end else
if not(silent) then
writeln('That object cannot be seen here.');
end else
if not(silent) then
writeln('That object cannot be seen here.');
end;
procedure print_room;
begin
case here.nameprint of
0:; { don't print name }
1: writeln('You''re in ',here.nicename);
2: writeln('You''re at ',here.nicename);
end;
if not(brief) then begin
case here.which of
0: print_desc(here.primary);
1: print_desc(here.secondary);
2: begin
print_desc(here.primary);
print_desc(here.secondary);
end;
3: begin
print_desc(here.primary);
if here.magicobj <> 0 then
if obj_hold(here.magicobj) then
print_desc(here.secondary);
end;
4: begin
if here.magicobj <> 0 then begin
if obj_hold(here.magicobj) then
print_desc(here.secondary)
else
print_desc(here.primary);
end else
print_desc(here.primary);
end;
end;
writeln;
end; { if not(brief) }
end;
procedure do_look(s: string := '');
var
n: integer;
one,two,three: boolean;
begin
gethere;
if s = '' then begin { do an ordinary top-level room look }
if hiding then begin
writeln('You can''t get a very good view of the details of the room from where');
writeln('you are hiding.');
noisehide(67);
end else begin
print_room;
show_exits;
end; { end of what you can't see when you're hiding }
show_people;
show_group;
show_objects;
end else begin { look at a detail in the room }
one := look_detail(s);
two := look_person(s);
do_examine(s,three,TRUE);
if not(one or two or three) then
writeln('There isn''t anything here by that name to look at.');
end;
end;
procedure init_exit(dir: integer);
begin
with here.exits[dir] do begin
exitdesc := DEFAULT_LINE;
fail := DEFAULT_LINE; { default descriptions }
success := 0; { until they customize }
comeout := DEFAULT_LINE;
goin := DEFAULT_LINE;
closed := DEFAULT_LINE;
objreq := 0; { not a door (yet) }
hidden := 0; { not hidden }
reqalias := false; { don't require alias (i.e. can use
direction of exit North, east, etc. }
reqverb := false;
autolook := true;
alias := '';
end;
end;
procedure remove_exit(dir: integer);
var
targroom,targslot: integer;
hereacc,targacc: boolean;
begin
{ Leave residual accepts if player is not the owner of
the room that the exit he is deleting is in }
getroom;
targroom := here.exits[dir].toloc;
targslot := here.exits[dir].slot;
here.exits[dir].toloc := 0;
init_exit(dir);
if (here.owner = userid) or (privd) then
hereacc := false
else
hereacc := true;
if hereacc then
here.exits[dir].kind := 5 { put an "accept" in its place }
else
here.exits[dir].kind := 0;
putroom;
log_event(myslot,E_DETACH,dir,0,myname,location);
getroom(targroom);
here.exits[targslot].toloc := 0;
if (here.owner = userid) or (privd) then
targacc := false
else
targacc := true;
if targacc then
here.exits[targslot].kind := 5 { put an "accept" in its place }
else
here.exits[targslot].kind := 0;
putroom;
if targroom <> location then
log_event(0,E_DETACH,targslot,0,myname,targroom);
writeln('Exit destroyed.');
end;
{
User procedure to unlink a room
}
procedure do_unlink(s: string);
var
dir: integer;
begin
gethere;
if checkhide then begin
if lookup_dir(dir,s) then begin
if can_alter(dir) then begin
if here.exits[dir].toloc = 0 then
writeln('There is no exit there to unlink.')
else
remove_exit(dir);
end else
writeln('You are not allowed to remove that exit.');
end else
writeln('To remove an exit, type UNLINK <direction of exit>.');
end;
end;
function desc_allowed: boolean;
begin
if (here.owner = userid) or
(privd) then
desc_allowed := true
else begin
writeln('Sorry, you are not allowed to alter the descriptions in this room.');
desc_allowed := false;
end;
end;
function slead(s: string):string;
var
i: integer;
going: boolean;
begin
if length(s) = 0 then
slead := ''
else begin
i := 1;
going := true;
while going do begin
if i > length(s) then
going := false
else if (s[i]=' ') or (s[i]=chr(9)) then
i := i + 1
else
going := false;
end;
if i > length(s) then
slead := ''
else
slead := substr(s,i,length(s)+1-i);
end;
end;
function bite(var s: string): string;
var
i: integer;
begin
if length(s) = 0 then
bite := ''
else begin
i := index(s,' ');
if i = 0 then begin
bite := s;
s := '';
end else begin
bite := substr(s,1,i-1);
s := slead(substr(s,i+1,length(s)-i));
end;
end;
end;
procedure edit_help;
begin
writeln;
writeln('A Append text to end');
writeln('C Check text for correct length with parameter substitution (#)');
writeln('D # Delete line #');
writeln('E Exit & save changes');
writeln('I # Insert lines before line #');
writeln('P Print out description');
writeln('Q Quit: THROWS AWAY CHANGES');
writeln('R # Replace text of line #');
writeln('Z Zap all text');
writeln('@ Throw away text & exit with the default description');
writeln('? This list');
writeln;
end;
procedure edit_replace(n: integer);
var
prompt: string;
s: string;
begin
if (n > heredsc.desclen) or (n < 1) then
writeln('-- Bad line number')
else begin
writev(prompt,n:2,': ');
grab_line(prompt,s);
if s <> '**' then
heredsc.lines[n] := s;
end;
end;
procedure edit_insert(n: integer);
var
i: integer;
begin
if heredsc.desclen = descmax then
writeln('You have already used all ',descmax:1,' lines of text.')
else if (n < 1) or (n > heredsc.desclen) then begin
writeln('Invalid line #; valid lines are between 1 and ',heredsc.desclen:1);
writeln('Use A (add) to add text to the end of your description.');
end else begin
for i := heredsc.desclen+1 downto n + 1 do
heredsc.lines[i] := heredsc.lines[i-1];
heredsc.desclen := heredsc.desclen + 1;
heredsc.lines[n] := '';
end;
end;
procedure edit_doinsert(n: integer);
var
s: string;
prompt: string;
begin
if heredsc.desclen = descmax then
writeln('You have already used all ',descmax:1,' lines of text.')
else if (n < 1) or (n > heredsc.desclen) then begin
writeln('Invalid line #; valid lines are between 1 and ',heredsc.desclen:1);
writeln('Use A (add) to add text to the end of your description.');
end else repeat
writev(prompt,n:1,': ');
grab_line(prompt,s);
if s <> '**' then begin
edit_insert(n); { put the blank line in }
heredsc.lines[n] := s; { copy this line onto it }
n := n + 1;
end;
until (heredsc.desclen = descmax) or (s = '**');
end;
procedure edit_show;
var
i: integer;
begin
writeln;
if heredsc.desclen = 0 then
writeln('[no text]')
else begin
i := 1;
while i <= heredsc.desclen do begin
writeln(i:2,': ',heredsc.lines[i]);
i := i + 1;
end;
end;
end;
procedure edit_append;
var
prompt,s: string;
stilladding: boolean;
begin
if heredsc.desclen = descmax then
writeln('You have already used all ',descmax:1,' lines of text.')
else begin
stilladding := true;
writeln('Enter text. Terminate with ** at the beginning of a line.');
writeln('You have ',descmax:1,' lines maximum.');
writeln;
while (heredsc.desclen < descmax) and (stilladding) do begin
writev(prompt,heredsc.desclen+1:2,': ');
grab_line(prompt,s);
if s = '**' then
stilladding := false
else begin
heredsc.desclen := heredsc.desclen + 1;
heredsc.lines[heredsc.desclen] := s;
end;
end;
end;
end;
procedure edit_delete(n: integer);
var
i: integer;
begin
if heredsc.desclen = 0 then
writeln('-- No lines to delete')
else if (n > heredsc.desclen) or (n < 1) then
writeln('-- Bad line number')
else if (n = 1) and (heredsc.desclen = 1) then
heredsc.desclen := 0
else begin
for i := n to heredsc.desclen-1 do
heredsc.lines[i] := heredsc.lines[i + 1];
heredsc.desclen := heredsc.desclen - 1;
end;
end;
procedure check_subst;
var
i: integer;
begin
if heredsc.desclen > 0 then begin
for i := 1 to heredsc.desclen do
if (index(heredsc.lines[i],'#') > 0) and
(length(heredsc.lines[i]) > 59) then
writeln('Warning: line ',i:1,' is too long for correct parameter substitution.');
end;
end;
function edit_desc(var dsc: integer):boolean;
var
cmd: char;
s: string;
done: boolean;
n: integer;
begin
if dsc = DEFAULT_LINE then begin
heredsc.desclen := 0;
end else if dsc > 0 then begin
getblock(dsc);
freeblock;
heredsc := block;
end else if dsc < 0 then begin
n := (- dsc);
getline(n);
freeline;
heredsc.lines[1] := oneliner.theline;
heredsc.desclen := 1;
end else begin
heredsc.desclen := 0;
end;
edit_desc := true;
done := false;
if heredsc.desclen = 0 then
edit_append;
repeat
writeln;
repeat
grab_line('* ',s);
s := slead(s);
until length(s) > 0;
s := lowcase(s);
cmd := s[1];
if length(s)>1 then begin
n := number(slead(substr(s,2,length(s)-1)))
end else
n := 0;
case cmd of
'h','?': edit_help;
'a': edit_append;
'z': heredsc.desclen := 0;
'c': check_subst;
'p','l','t': edit_show;
'd': edit_delete(n);
'e': begin
check_subst;
if debug then
writeln('edit_desc: dsc is ',dsc:1);
{ what I do here may require some explanation:
dsc is a pointer to some text structure:
dsc = 0 : no text
dsc > 0 : dsc refers to a description block (descmax lines)
dsc < 0 : dsc refers to a description "one liner". abs(dsc)
is the actual pointer
If there are no lines of text to be written out (heredsc.desclen = 0)
then we deallocate whatever dsc is when edit_desc was invoked, if
it was pointing to something;
if there is one line of text to be written out, allocate a one liner
record, assign the string to it, and return dsc as negative;
if there is mmore than one line of text, allocate a description block,
store the lines in it, and return dsc as positive.
In all cases if there was already a record allocated to dsc then
use it and don't reallocate a new record.
}
{ kill the default } if (heredsc.desclen > 0) and
{ if we're gonna put real } (dsc = DEFAULT_LINE) then
{ texty in here } dsc := 0;
{ no lines, delete existing } if heredsc.desclen = 0 then
{ desc, if any } delete_block(dsc)
else if heredsc.desclen = 1 then begin
if (dsc = 0) then begin
if alloc_line(dsc) then;
dsc := (- dsc);
end else if dsc > 0 then begin
delete_block(dsc);
if alloc_line(dsc) then;
dsc := (- dsc);
end;
if dsc < 0 then begin
getline( abs(dsc) );
oneliner.theline := heredsc.lines[1];
putline;
end;
{ more than 1 lines } end else begin
if dsc = 0 then begin
if alloc_block(dsc) then;
end else if dsc < 0 then begin
delete_line(dsc);
if alloc_block(dsc) then;
end;
if dsc > 0 then begin
getblock(dsc);
block := heredsc;
{ This is a fudge } block.descrinum := dsc;
putblock;
end;
end;
done := true;
end;
'r': edit_replace(n);
'@': begin
delete_block(dsc);
dsc := DEFAULT_LINE;
done := true;
end;
'i': edit_doinsert(n);
'q': begin
grab_line('Throw away changes, are you sure? ',s);
s := lowcase(s);
if (s = 'y') or (s = 'yes') then begin
done := true;
edit_desc := false; { signal caller not to save }
end;
end;
otherwise writeln('-- Invalid command, type ? for a list.');
end;
until done;
end;
function alloc_detail(var n: integer;s: string): boolean;
var
found: boolean;
begin
n := 1;
found := false;
while (n <= maxdetail) and (not found) do begin
if here.detaildesc[n] = 0 then
found := true
else
n := n + 1;
end;
alloc_detail := found;
if not(found) then
n := 0
else begin
getroom;
here.detail[n] := lowcase(s);
putroom;
end;
end;
{
User describe procedure. If no s then describe the room
Known problem: if two people edit the description to the same room one of their
description blocks could be lost.
This is unlikely to happen unless the Monster Manager tries to edit a
description while the room's owner is also editing it.
}
procedure do_describe(s: string);
var
i: integer;
newdsc: integer;
begin
gethere;
if checkhide then begin
if s = '' then begin { describe this room }
if desc_allowed then begin
log_action(desc,0);
writeln('[ Editing the primary room description ]');
newdsc := here.primary;
if edit_desc(newdsc) then begin
getroom;
here.primary := newdsc;
putroom;
end;
log_event(myslot,E_EDITDONE,0,0);
end;
end else begin{ describe a detail of this room }
if length(s) > veryshortlen then
writeln('Your detail keyword can only be ',veryshortlen:1,' characters.')
else if desc_allowed then begin
if not(lookup_detail(i,s)) then
if not(alloc_detail(i,s)) then begin
writeln('You have used all ',maxdetail:1,' details.');
writeln('To delete a detail, DESCRIBE <the detail> and delete all the text.');
end;
if i <> 0 then begin
log_action(e_detail,0);
writeln('[ Editing detail "',here.detail[i],'" of this room ]');
newdsc := here.detaildesc[i];
if edit_desc(newdsc) then begin
getroom;
here.detaildesc[i] := newdsc;
putroom;
end;
log_event(myslot,E_DONEDET,0,0);
end;
end;
end;
{ clear_command; }
end;
end;
procedure del_room(n: integer);
var
i: integer;
begin
getnam;
nam.idents[n] := ''; { blank out name }
putnam;
getown;
own.idents[n] := ''; { blank out owner }
putown;
getroom(n);
for i := 1 to maxexit do begin
with here.exits[i] do begin
delete_line(exitdesc);
delete_line(fail);
delete_line(success);
delete_line(comeout);
delete_line(goin);
end;
end;
delete_block(here.primary);
delete_block(here.secondary);
putroom;
delete_room(n); { return room to free list }
end;
procedure createroom(s: string); { create a room with name s }
var
roomno: integer;
dummy: integer;
i:integer;
rand_accept: integer;
begin
if length(s) = 0 then begin
writeln('Please specify the name of the room you wish to create as a parameter to FORM.');
end else if length(s) > shortlen then begin
writeln('Please limit your room name to a maximum of ',shortlen:1,' characters.');
end else if exact_room(dummy,s) then begin
writeln('That room name has already been used. Please give a unique room name.');
end else if alloc_room(roomno) then begin
log_action(form,0);
getnam;
nam.idents[roomno] := lowcase(s); { assign room name }
putnam; { case insensitivity }
getown;
own.idents[roomno] := userid; { assign room owner }
putown;
getroom(roomno);
here.primary := 0;
here.secondary := 0;
here.which := 0; { print primary desc only by default }
here.magicobj := 0;
here.owner := userid; { owner and name are stored here too }
here.nicename := s;
here.nameprint := 1; { You're in ... }
here.objdrop := 0; { objects dropped stay here }
here.objdesc := 0; { nothing printed when they drop }
here.magicobj := 0; { no magic object default }
here.trapto := 0; { no trapdoor }
here.trapchance := 0; { no chance }
here.rndmsg := DEFAULT_LINE; { bland noises message }
here.pile := 0;
here.grploc1 := 0;
here.grploc2 := 0;
here.grpnam1 := '';
here.grpnam2 := '';
here.effects := 0;
here.parm := 0;
here.xmsg2 := 0;
here.exp2 := 0;
here.exp3 := 0;
here.exp4 := 0;
here.exitfail := DEFAULT_LINE;
here.ofail := DEFAULT_LINE;
for i := 1 to maxpeople do
here.people[i].kind := 0;
for i := 1 to maxpeople do
here.people[i].name := '';
for i := 1 to maxobjs do
here.objs[i] := 0;
for i := 1 to maxdetail do
here.detail[i] := '';
for i := 1 to maxdetail do
here.detaildesc[i] := 0;
for i := 1 to maxobjs do
here.objhide[i] := 0;
for i := 1 to maxexit do
with here.exits[i] do begin
toloc := 0;
kind := 0;
slot := 0;
exitdesc := DEFAULT_LINE;
fail := DEFAULT_LINE;
success := 0; { no success desc by default }
goin := DEFAULT_LINE;
comeout := DEFAULT_LINE;
closed := DEFAULT_LINE;
objreq := 0;
hidden := 0;
alias := '';
reqverb := false;
reqalias := false;
autolook := true;
end;
{ here.exits := zero; }
{ random accept for this room }
rand_accept := 1 + (rnd100 mod 6);
here.exits[rand_accept].kind := 5;
putroom;
end;
end;
procedure show_help;
var
i: integer;
s: string;
begin
writeln;
writeln('Accept/Refuse # Allow others to Link an exit here at direction # | Undo Accept');
writeln('Brief Toggle printing of room descriptions');
writeln('Customize [#] Customize this room | Customize exit # | Customize object #');
writeln('Describe [#] Describe this room | Describe a feature (#) in detail');
writeln('Destroy # Destroy an instance of object # (you must be holding it)');
writeln('Duplicate # Make a duplicate of an already-created object.');
writeln('Form/Zap # Form a new room with name # | Destroy room named #');
writeln('Get/Drop # Get/Drop an object');
writeln('#,Go # Go towards # (Some: N/North S/South E/East W/West U/Up D/Down)');
writeln('Health Show how healthy you are');
writeln('Hide/Reveal [#] Hide/Reveal yoursef | Hide object (#)');
writeln('I,Inventory See what you or someone else is carrying');
writeln('Link/Unlink # Link/Unlink this room to/from another via exit at direction #');
writeln('Look,L [#] Look here | Look at something or someone (#) closely');
writeln('Make # Make a new object named #');
writeln('Name # Set your game name to #');
writeln('Players List people who have played Monster');
writeln('Punch # Punch person #');
writeln('Quit Leave the game');
writeln('Relink Move an exit');
writeln;
grab_line('-more-',s);
writeln;
writeln('Rooms Show information about rooms you have made');
writeln('Say, '' (quote) Say line of text following command to others in the room');
writeln('Search Look around the room for anything hidden');
writeln('Self # Edit a description of yourself | View #''s self-description');
writeln('Show # Show option # (type SHOW ? for a list)');
writeln('Unmake # Remove the form definition of object #');
writeln('Use # Use object #');
writeln('Wear # Wear the object #');
writeln('Wield # Wield the weapon #; you must be holding it first');
writeln('Whisper # Whisper something (prompted for) to person #');
writeln('Who List of people playing Monster now');
writeln('Whois # What is a player''s username');
writeln('?,Help This list');
writeln('. (period) Repeat last command');
writeln;
end;
function lookup_cmd(s: string):integer;
var
i, { index for loop }
poss, { a possible match -- only for partial matches }
maybe, { number of possible matches we have: > 2 is ambig. }
num { the definite match }
: integer;
begin
s := lowcase(s);
i := 1;
maybe := 0;
num := 0;
for i := 1 to numcmds do begin
if s = cmds[i] then
num := i
else if index(cmds[i],s) = 1 then begin
maybe := maybe + 1;
poss := i;
end;
end;
if num <> 0 then begin
lookup_cmd := num;
end else if maybe = 1 then begin
lookup_cmd := poss;
end else if maybe > 1 then
lookup_cmd := error { "Ambiguous" }
else
lookup_cmd := error; { "Command not found " }
end;
procedure addrooms(n: integer);
var
i: integer;
begin
getindex(I_ROOM);
for i := indx.top+1 to indx.top+n do begin
locate(roomfile,i);
roomfile^.valid := i;
roomfile^.locnum := i;
roomfile^.primary := 0;
roomfile^.secondary := 0;
roomfile^.which := 0;
put(roomfile);
end;
indx.top := indx.top + n;
putindex;
end;
procedure addints(n: integer);
var
i: integer;
begin
getindex(I_INT);
for i := indx.top+1 to indx.top+n do begin
locate(intfile,i);
intfile^.intnum := i;
put(intfile);
end;
indx.top := indx.top + n;
putindex;
end;
procedure addlines(n: integer);
var
i: integer;
begin
getindex(I_LINE);
for i := indx.top+1 to indx.top+n do begin
locate(linefile,i);
linefile^.linenum := i;
put(linefile);
end;
indx.top := indx.top + n;
putindex;
end;
procedure addblocks(n: integer);
var
i: integer;
begin
getindex(I_BLOCK);
for i := indx.top+1 to indx.top+n do begin
locate(descfile,i);
descfile^.descrinum := i;
put(descfile);
end;
indx.top := indx.top + n;
putindex;
end;
procedure addobjects(n: integer);
var
i: integer;
begin
getindex(I_OBJECT);
for i := indx.top+1 to indx.top+n do begin
locate(objfile,i);
objfile^.objnum := i;
put(objfile);
end;
indx.top := indx.top + n;
putindex;
end;
procedure dist_list;
var
i,j: integer;
f: text;
where_they_are: intrec;
begin
writeln('Writing distribution list . . .');
open(f,'monsters.dis',history := new);
rewrite(f);
getindex(I_PLAYER); { Rec of valid player log records }
freeindex; { False if a valid player log }
getuser; { Corresponding userids of players }
freeuser;
getpers; { Personal names of players }
freepers;
getdate; { date of last play }
freedate;
if privd then begin
getint(N_LOCATION);
freeint;
where_they_are := anint;
getnam;
freenam;
end;
for i := 1 to maxplayers do begin
if not(indx.free[i]) then begin
write(f,user.idents[i]);
for j := length(user.idents[i]) to 15 do
write(f,' ');
write(f,'! ',pers.idents[i]);
for j := length(pers.idents[i]) to 21 do
write(f,' ');
write(f,adate.idents[i]);
if length(adate.idents[i]) < 19 then
for j := length(adate.idents[i]) to 18 do
write(f,' ');
if anint.int[i] <> 0 then
write(f,' * ')
else
write(f,' ');
if privd then begin
write(f,nam.idents[ where_they_are.int[i] ]);
end;
writeln(f);
end;
end;
writeln('Done.');
end;
procedure system_view;
var
used,free,total: integer;
begin
writeln;
getindex(I_BLOCK);
freeindex;
used := indx.inuse;
total := indx.top;
free := total - used;
writeln(' used free total');
writeln('Block file ',used:5,' ',free:5,' ',total:5);
getindex(I_LINE);
freeindex;
used := indx.inuse;
total := indx.top;
free := total - used;
writeln('Line file ',used:5,' ',free:5,' ',total:5);
getindex(I_ROOM);
freeindex;
used := indx.inuse;
total := indx.top;
free := total - used;
writeln('Room file ',used:5,' ',free:5,' ',total:5);
getindex(I_OBJECT);
freeindex;
used := indx.inuse;
total := indx.top;
free := total - used;
writeln('Object file ',used:5,' ',free:5,' ',total:5);
getindex(I_INT);
freeindex;
used := indx.inuse;
total := indx.top;
free := total - used;
writeln('Integer file ',used:5,' ',free:5,' ',total:5);
writeln;
end;
{ remove a user from the log records (does not handle ownership) }
procedure kill_user(s:string);
var
n: integer;
begin
if length(s) = 0 then
writeln('No user specified')
else begin
if lookup_user(n,s) then begin
getindex(I_ASLEEP);
freeindex;
if indx.free[n] then begin
delete_log(n);
writeln('Player deleted.');
end else
writeln('That person is playing now.');
end else
writeln('No such userid found in log information.');
end;
end;
{ disown everything a player owns }
procedure disown_user(s:string);
var
n: integer;
i: integer;
tmp: string;
theuser: string;
begin
if length(s) > 0 then begin
if debug then
writeln('calling lookup_user with ',s);
if not lookup_user(n,s) then
writeln('User not in log info, attempting to disown anyway.');
theuser := user.idents[n];
{ first disown all their rooms }
getown;
freeown;
for i := 1 to maxroom do
if own.idents[i] = theuser then begin
getown;
own.idents[i] := '*';
putown;
getroom(i);
tmp := here.nicename;
here.owner := '*';
putroom;
writeln('Disowned room ',tmp);
end;
writeln;
getobjown;
freeobjown;
getobjnam;
freeobjnam;
for i := 1 to maxroom do
if objown.idents[i] = theuser then begin
getobjown;
objown.idents[i] := '*';
putobjown;
tmp := objnam.idents[i];
writeln('Disowned object ',tmp);
end;
end else
writeln('No user specified.');
end;
procedure move_asleep;
var
pname,rname:string; { player & room names }
newroom,n: integer; { room number & player slot number }
begin
grab_line('Player name? ',pname);
grab_line('Room name? ',rname);
if lookup_user(n,pname) then begin
if lookup_room(newroom,rname) then begin
getindex(I_ASLEEP);
freeindex;
if indx.free[n] then begin
getint(N_LOCATION);
anint.int[n] := newroom;
putint;
writeln('Player moved.');
end else
writeln('That player is not asleep.');
end else
writeln('No such room found.');
end else
writeln('User not found.');
end;
procedure system_help;
begin
writeln;
writeln('B Add description blocks');
writeln('D Disown <user>');
writeln('E Exit (same as quit)');
writeln('I Add Integer records');
writeln('K Kill <user>');
writeln('L Add one liner records');
writeln('M Move a player who is asleep (not playing now)');
writeln('O Add object records');
writeln('P Write a distribution list of players');
writeln('Q Quit (same as exit)');
writeln('R Add rooms');
writeln('V View current sizes/usage');
writeln('? This list');
writeln;
end;
{ *************** FIX_STUFF ******************** }
procedure fix_stuff;
begin
end;
procedure do_system(s: string);
var
prompt: string;
done: boolean;
cmd: char;
n: integer;
p: string;
begin
if privd then begin
log_action(c_system,0);
prompt := 'System> ';
done := false;
repeat
repeat
grab_line(prompt,s);
s := slead(s);
until length(s) > 0;
s := lowcase(s);
cmd := s[1];
n := 0;
p := '';
if length(s) > 1 then begin
p := slead( substr(s,2,length(s)-1) );
n := number(p)
end;
if debug then begin
writeln('p = ',p);
end;
case cmd of
'h','?': system_help;
'1': fix_stuff;
{remove a user} 'k': kill_user(p);
{disown} 'd': disown_user(p);
{dist list of players} 'p': dist_list;
{move where user will wakeup} 'm': move_asleep;
{add rooms} 'r': begin
if n > 0 then begin
addrooms(n);
end else
writeln('To add rooms, say R <# to add>');
end;
{add ints} 'i': begin
if n > 0 then begin
addints(n);
end else
writeln('To add integers, say I <# to add>');
end;
{add description blocks} 'b': begin
if n > 0 then begin
addblocks(n);
end else
writeln('To add description blocks, say B <# to add>');
end;
{add objects} 'o': begin
if n > 0 then begin
addobjects(n);
end else
writeln('To add object records, say O <# to add>');
end;
{add one-liners} 'l': begin
if n > 0 then begin
addlines(n);
end else
writeln('To add one liner records, say L <# to add>');
end;
{view current stats} 'v': begin
system_view;
end;
{quit} 'q','e': done := true;
otherwise writeln('-- bad command, type ? for a list.');
end;
until done;
log_event(myslot,E_SYSDONE,0,0);
end else
writeln('Only the Monster Manger may enter system maintenance mode.');
end;
procedure do_version(s: string);
begin
writeln('Monster, a multiplayer adventure game where the players create the world');
writeln('and make the rules.');
writeln;
writeln('Written by Rich Skrenta at Northwestern University, 1988.');
end;
procedure rebuild_system;
var
i,j: integer;
begin
writeln('Creating index file 1-6');
for i := 1 to 7 do begin
{ 1 is blocklist
2 is linelist
3 is roomlist
4 is playeralloc
5 is player awake (playing game)
6 are objects
7 is intfile }
locate(indexfile,i);
for j := 1 to maxindex do
indexfile^.free[j] := true;
indexfile^.indexnum := i;
indexfile^.top := 0; { none of each to start }
indexfile^.inuse := 0;
put(indexfile);
end;
writeln('Initializing roomfile with 10 rooms');
addrooms(10);
writeln('Initializing block file with 10 description blocks');
addblocks(10);
writeln('Initializing line file with 10 lines');
addlines(10);
writeln('Initializing object file with 10 objects');
addobjects(10);
writeln('Initializing namfile 1-8');
for j := 1 to 8 do begin
locate(namfile,j);
namfile^.validate := j;
namfile^.loctop := 0;
for i := 1 to maxroom do begin
namfile^.idents[i] := '';
end;
put(namfile);
end;
writeln('Initializing eventfile');
for i := 1 to numevnts + 1 do begin
locate(eventfile,i);
eventfile^.validat := i;
eventfile^.point := 1;
put(eventfile);
end;
writeln('Initializing intfile');
for i := 1 to 6 do begin
locate(intfile,i);
intfile^.intnum := i;
put(intfile);
end;
getindex(I_INT);
for i := 1 to 6 do
indx.free[i] := false;
indx.top := 6;
indx.inuse := 6;
putindex;
{ Player log records should have all their slots initially,
they don't have to be allocated because they use namrec
and intfile for their storage; they don't have their own
file to allocate
}
getindex(I_PLAYER);
indx.top := maxplayers;
putindex;
getindex(I_ASLEEP);
indx.top := maxplayers;
putindex;
writeln('Creating the Great Hall');
createroom('Great Hall');
getroom(1);
here.owner := '';
putroom;
getown;
own.idents[1] := '';
putown;
writeln('Creating the Void');
createroom('Void'); { loc 2 }
writeln('Creating the Pit of Fire');
createroom('Pit of Fire'); { loc 3 }
{ note that these are NOT public locations }
writeln('Use the SYSTEM command to view and add capacity to the database');
writeln;
end;
procedure special(s: string);
begin
if (s = 'rebuild') and (privd) then begin
if REBUILD_OK then begin
writeln('Do you really want to destroy the entire universe?');
readln(s);
if length(s) > 0 then
if substr(lowcase(s),1,1) = 'y' then
rebuild_system;
end else
writeln('REBUILD is disabled; you must recompile.');
end else if s = 'version' then begin
{ Don't take this out please... }
writeln('Monster, written by Rich Skrenta at Northwestern University, 1988.');
end else if s = 'quit' then
done := true;
end;
{ put an object in this location
if returns false, there were no more free object slots here:
in other words, the room is too cluttered, and cannot hold any
more objects
}
function place_obj(n: integer;silent:boolean := false): boolean;
var
found: boolean;
i: integer;
begin
if here.objdrop = 0 then
getroom
else
getroom(here.objdrop);
i := 1;
found := false;
while (i <= maxobjs) and (not found) do begin
if here.objs[i] = 0 then
found := true
else
i := i + 1;
end;
place_obj := found;
if found then begin
here.objs[i] := n;
here.objhide[i] := 0;
putroom;
gethere;
{ if it bounced somewhere else then tell them }
if (here.objdrop <> 0) and (here.objdest <> 0) then
log_event(0,E_BOUNCEDIN,here.objdest,n,'',here.objdrop);
if not(silent) then begin
if here.objdesc <> 0 then
print_subs(here.objdesc,obj_part(n))
else
writeln('Dropped.');
end;
end else
freeroom;
end;
{ remove an object from this room }
function take_obj(objnum,slot: integer): boolean;
begin
getroom;
if here.objs[slot] = objnum then begin
here.objs[slot] := 0;
here.objhide[slot] := 0;
take_obj := true;
end else
take_obj := false;
putroom;
end;
function can_hold: boolean;
begin
if find_numhold < maxhold then
can_hold := true
else
can_hold := false;
end;
function can_drop: boolean;
begin
if find_numobjs < maxobjs then
can_drop := true
else
can_drop := false;
end;
function find_hold(objnum: integer;slot:integer := 0): integer;
var
i: integer;
begin
if slot = 0 then
slot := myslot;
i := 1;
find_hold := 0;
while i <= maxhold do begin
if here.people[slot].holding[i] = objnum then
find_hold := i;
i := i + 1;
end;
end;
{ put object number n into the player's inventory; returns false if
he's holding too many things to carry another }
function hold_obj(n: integer): boolean;
var
found: boolean;
i: integer;
begin
getroom;
i := 1;
found := false;
while (i <= maxhold) and (not found) do begin
if here.people[myslot].holding[i] = 0 then
found := true
else
i := i + 1;
end;
hold_obj := found;
if found then begin
here.people[myslot].holding[i] := n;
putroom;
getobj(n);
freeobj;
hold_kind[i] := obj.kind;
end else
freeroom;
end;
{ remove an object (hold) from the player record, given the slot that
the object is being held in }
procedure drop_obj(slot: integer;pslot: integer := 0);
begin
if pslot = 0 then
pslot := myslot;
getroom;
here.people[pslot].holding[slot] := 0;
putroom;
hold_kind[slot] := 0;
end;
{ maybe drop something I'm holding if I'm hit }
procedure maybe_drop;
var
i: integer;
objnum: integer;
s: string;
begin
i := 1 + (rnd100 mod maxhold);
objnum := here.people[myslot].holding[i];
if (objnum <> 0) and (mywield <> objnum) and (mywear <> objnum) then begin
{ drop something }
drop_obj(i);
if place_obj(objnum,TRUE) then begin
getobjnam;
freeobjnam;
writeln('The ',objnam.idents[objnum],' has slipped out of your hands.');
s := objnam.idents[objnum];
log_event(myslot,E_SLIPPED,0,0,s);
end else
writeln('%error in maybe_drop; unsuccessful place_obj; notify Monster Manager');
end;
end;
{ return TRUE if the player is allowed to program the object n
if checkpub is true then obj_owner will return true if the object in
question is public }
function obj_owner(n: integer;checkpub: boolean := FALSE):boolean;
begin
getobjown;
freeobjown;
if (objown.idents[n] = userid) or (privd) then begin
obj_owner := true;
end else if (objown.idents[n] = '') and (checkpub) then begin
obj_owner := true;
end else begin
obj_owner := false;
end;
end;
procedure do_duplicate(s: string);
var
objnum: integer;
begin
if length(s) > 0 then begin
if not is_owner(location,TRUE) then begin
{ only let them make things if they're on their home turf }
writeln('You may only create objects when you are in one of your own rooms.');
end else begin
if lookup_obj(objnum,s) then begin
if obj_owner(objnum,TRUE) then begin
if not(place_obj(objnum,TRUE)) then
{ put the new object here }
writeln('There isn''t enough room here to make that.')
else begin
{ keep track of how many there } getobj(objnum);
{ are in existence } obj.numexist := obj.numexist + 1;
putobj;
log_event(myslot,E_MADEOBJ,0,0,
myname + ' has created an object here.');
writeln('Object created.');
end;
end else
writeln('Power to create that object belongs to someone else.');
end else
writeln('There is no object by that name.');
end;
end else
writeln('To duplicate an object, type DUPLICATE <object name>.');
end;
{ make an object }
procedure do_makeobj(s: string);
var
objnum: integer;
begin
gethere;
if checkhide then begin
if not is_owner(location,TRUE) then begin
writeln('You may only create objects when you are in one of your own rooms.');
end else if s <> '' then begin
if length(s) > shortlen then
writeln('Please limit your object names to ',shortlen:1,' characters.')
else if exact_obj(objnum,s) then begin { object already exits }
writeln('That object already exits. If you would like to make another copy of it,');
writeln('use the DUPLICATE command.');
end else begin
if debug then
writeln('%beggining to create object');
if find_numobjs < maxobjs then begin
if alloc_obj(objnum) then begin
if debug then
writeln('%alloc_obj successful');
getobjnam;
objnam.idents[objnum] := lowcase(s);
putobjnam;
if debug then
writeln('%getobjnam completed');
getobjown;
objown.idents[objnum] := userid;
putobjown;
if debug then
writeln('%getobjown completed');
getobj(objnum);
obj.onum := objnum;
obj.oname := s; { name of object }
obj.kind := 0; { bland object }
obj.linedesc := DEFAULT_LINE;
obj.actindx := 0;
obj.examine := 0;
obj.numexist := 1;
obj.home := 0;
obj.homedesc := 0;
obj.sticky := false;
obj.getobjreq := 0;
obj.getfail := 0;
obj.getsuccess := DEFAULT_LINE;
obj.useobjreq := 0;
obj.uselocreq := 0;
obj.usefail := DEFAULT_LINE;
obj.usesuccess := DEFAULT_LINE;
obj.usealias := '';
obj.reqalias := false;
obj.reqverb := false;
if s[1] in ['a','A','e','E','i','I','o','O','u','U'] then
obj.particle := 2 { an }
else
obj.particle := 1; { a }
obj.d1 := 0;
obj.d2 := 0;
obj.exp3 := 0;
obj.exp4 := 0;
obj.exp5 := DEFAULT_LINE;
obj.exp6 := DEFAULT_LINE;
putobj;
if debug then
writeln('putobj completed');
end;
{ else: alloc_obj prints errors by itself }
if not(place_obj(objnum,TRUE)) then
{ put the new object here }
writeln('%error in makeobj - could not place object; notify the Monster Manager.')
else begin
log_event(myslot,E_MADEOBJ,0,0,
myname + ' has created an object here.');
writeln('Object created.');
end;
end else
writeln('This place is too crowded to create any more objects. Try somewhere else.');
end;
end else
writeln('To create an object, type MAKE <object name>.');
end;
end;
{ remove the type block for an object; all instances of the object must
be destroyed first }
procedure do_unmake(s: string);
var
n: integer;
tmp: string;
begin
if not(is_owner(location,TRUE)) then
writeln('You must be in one of your own rooms to UNMAKE an object.')
else if lookup_obj(n,s) then begin
tmp := obj_part(n);
{ this will do a getobj(n) for us }
if obj.numexist = 0 then begin
delete_obj(n);
log_event(myslot,E_UNMAKE,0,0,tmp);
writeln('Object removed.');
end else
writeln('You must DESTROY all instances of the object first.');
end else
writeln('There is no object here by that name.');
end;
{ destroy a copy of an object }
procedure do_destroy(s: string);
var
slot,n: integer;
begin
if length(s) = 0 then
writeln('To destroy an object you own, type DESTROY <object>.')
else if not is_owner(location,TRUE) then
writeln('You must be in one of your own rooms to destroy an object.')
else if parse_obj(n,s) then begin
getobjown;
freeobjown;
if (objown.idents[n] <> userid) and (objown.idents[n] <> '') and
(not privd) then
writeln('You must be the owner of an object to destroy it.')
else if obj_hold(n) then begin
slot := find_hold(n);
drop_obj(slot);
log_event(myslot,E_DESTROY,0,0,
myname + ' has destroyed ' + obj_part(n) + '.');
writeln('Object destroyed.');
getobj(n);
obj.numexist := obj.numexist - 1;
putobj;
end else if obj_here(n) then begin
slot := find_obj(n);
if not take_obj(n,slot) then
writeln('Someone picked it up before you could destroy it.')
else begin
log_event(myslot,E_DESTROY,0,0,
myname + ' has destroyed ' + obj_part(n,FALSE) + '.');
writeln('Object destroyed.');
getobj(n);
obj.numexist := obj.numexist - 1;
putobj;
end;
end else
writeln('Such a thing is not here.');
end else
writeln('No such thing can be seen here.');
end;
function links_possible: boolean;
var
i: integer;
begin
gethere;
links_possible := false;
if is_owner(location,TRUE) then
links_possible := true
else begin
for i := 1 to maxexit do
if (here.exits[i].toloc = 0) and (here.exits[i].kind = 5) then
links_possible := true;
end;
end;
{ make a room }
procedure do_form(s: string);
begin
gethere;
if checkhide then begin
if links_possible then begin
if s = '' then begin
grab_line('Room name: ',s);
end;
s := slead(s);
createroom(s);
end else begin
writeln('You may not create any new exits here. Go to a place where you can create');
writeln('an exit before FORMing a new room.');
end;
end;
end;
procedure xpoof; { loc: integer; forward }
var
targslot: integer;
begin
if put_token(loc,targslot,here.people[myslot].hiding) then begin
if hiding then begin
log_event(myslot,E_HPOOFOUT,0,0,myname,location);
log_event(myslot,E_HPOOFIN,0,0,myname,loc);
end else begin
log_event(myslot,E_POOFOUT,0,0,myname,location);
log_event(targslot,E_POOFIN,0,0,myname,loc);
end;
take_token(myslot,location);
myslot := targslot;
location := loc;
setevent;
do_look;
end else
writeln('There is a crackle of electricity, but the poof fails.');
end;
procedure do_poof(s: string);
var
n,loc: integer;
begin
if privd then begin
gethere;
if lookup_room(loc,s) then begin
xpoof(loc);
end else if parse_pers(n,s) then begin
grab_line('What room? ',s);
if lookup_room(loc,s) then begin
log_event(myslot,E_POOFYOU,n,loc);
writeln;
writeln('You extend your arms, muster some energy, and ',here.people[n].name,' is');
writeln('engulfed in a cloud of orange smoke.');
writeln;
end else
writeln('There is no room named ',s,'.');
end else
writeln('There is no room named ',s,'.');
end else
writeln('Only the Monster Manager may poof.');
end;
procedure link_room(origdir,targdir,targroom: integer);
begin
{ since exit creation involves the writing of two records,
perhaps there should be a global lock around this code,
such as a get to some obscure index field or something.
I haven't put this in because I don't believe that if this
routine fails it will seriously damage the database.
Actually, the lock should be on the test (do_link) but that
would be hard }
getroom;
with here.exits[origdir] do begin
toloc := targroom;
kind := 1; { type of exit, they can customize later }
slot := targdir; { exit it comes out in in target room }
init_exit(origdir);
end;
putroom;
log_event(myslot,E_NEWEXIT,0,0,myname,location);
if location <> targroom then
log_event(0,E_NEWEXIT,0,0,myname,targroom);
getroom(targroom);
with here.exits[targdir] do begin
toloc := location;
kind := 1;
slot := origdir;
init_exit(targdir);
end;
putroom;
writeln('Exit created. Use CUSTOM ',direct[origdir],' to customize your exit.');
end;
{
User procedure to link a room
}
procedure do_link(s: string);
var
ok: boolean;
orgexitnam,targnam,trgexitnam: string;
targroom, { number of target room }
targdir, { number of target exit direction }
origdir: integer;{ number of exit direction here }
firsttime: boolean;
begin
{ gethere; ! done in links_possible }
if links_possible then begin
log_action(link,0);
if checkhide then begin
writeln('Hit return alone at any prompt to terminate exit creation.');
writeln;
if s = '' then
firsttime := false
else begin
orgexitnam := bite(s);
firsttime := true;
end;
repeat
if not(firsttime) then
grab_line('Direction of exit? ',orgexitnam)
else
firsttime := false;
ok :=lookup_dir(origdir,orgexitnam);
if ok then
ok := can_make(origdir);
until (orgexitnam = '') or ok;
if ok then begin
if s = '' then
firsttime := false
else begin
targnam := s;
firsttime := true;
end;
repeat
if not(firsttime) then
grab_line('Room to link to? ',targnam)
else
firsttime := false;
ok := lookup_room(targroom,targnam);
until (targnam = '') or ok;
end;
if ok then begin
repeat
writeln('Exit comes out in target room');
grab_line('from what direction? ',trgexitnam);
ok := lookup_dir(targdir,trgexitnam);
if ok then
ok := can_make(targdir,targroom);
until (trgexitnam='') or ok;
end;
if ok then begin { actually create the exit }
link_room(origdir,targdir,targroom);
end;
end;
end else
writeln('No links are possible here.');
end;
procedure relink_room(origdir,targdir,targroom: integer);
var
tmp: exit;
copyslot,
copyloc: integer;
begin
gethere;
tmp := here.exits[origdir];
copyloc := tmp.toloc;
copyslot := tmp.slot;
getroom(targroom);
here.exits[targdir] := tmp;
putroom;
getroom(copyloc);
here.exits[copyslot].toloc := targroom;
here.exits[copyslot].slot := targdir;
putroom;
getroom;
here.exits[origdir].toloc := 0;
init_exit(origdir);
putroom;
end;
procedure do_relink(s: string);
var
ok: boolean;
orgexitnam,targnam,trgexitnam: string;
targroom, { number of target room }
targdir, { number of target exit direction }
origdir: integer;{ number of exit direction here }
firsttime: boolean;
begin
log_action(c_relink,0);
gethere;
if checkhide then begin
writeln('Hit return alone at any prompt to terminate exit relinking.');
writeln;
if s = '' then
firsttime := false
else begin
orgexitnam := bite(s);
firsttime := true;
end;
repeat
if not(firsttime) then
grab_line('Direction of exit to relink? ',orgexitnam)
else
firsttime := false;
ok :=lookup_dir(origdir,orgexitnam);
if ok then
ok := can_alter(origdir);
until (orgexitnam = '') or ok;
if ok then begin
if s = '' then
firsttime := false
else begin
targnam := s;
firsttime := true;
end;
repeat
if not(firsttime) then
grab_line('Room to relink exit into? ',targnam)
else
firsttime := false;
ok := lookup_room(targroom,targnam);
until (targnam = '') or ok;
end;
if ok then begin
repeat
writeln('New exit comes out in target room');
grab_line('from what direction? ',trgexitnam);
ok := lookup_dir(targdir,trgexitnam);
if ok then
ok := can_make(targdir,targroom);
until (trgexitnam='') or ok;
end;
if ok then begin { actually create the exit }
relink_room(origdir,targdir,targroom);
end;
end;
end;
{ print the room default no-go message if there is one;
otherwise supply the generic "you can't go that way" }
procedure default_fail;
begin
if (here.exitfail <> 0) and (here.exitfail <> DEFAULT_LINE) then
print_desc(here.exitfail)
else
writeln('You can''t go that way.');
end;
procedure exit_fail(dir: integer);
var
tmp: string;
begin
if (dir < 1) or (dir > maxexit) then
default_fail
else if (here.exits[dir].fail = DEFAULT_LINE) then begin
case here.exits[dir].kind of
5: writeln('There isn''t an exit there yet.');
6: writeln('You don''t have the power to go there.');
otherwise default_fail;
end;
end else if here.exits[dir].fail <> 0 then
block_subs(here.exits[dir].fail,myname);
{ now print the exit failure message for everyone else in the room:
if they tried to go through a valid exit,
and the exit has an other-person failure desc, then
substitute that one & use;
if there is a room default other-person failure desc, then
print that;
if they tried to go through a valid exit,
and the exit has no required alias, then
print default exit fail
else
print generic "didn't leave room" message
cases:
1) valid/alias exit and specific fail message
2) valid/alias exit and blanket fail message
3) valid exit (no specific or blanket) "x fails to go [direct]"
4) alias exit and blanket fail
5) blanket fail
6) generic fail
}
if dir <> 0 then
log_event(myslot,E_FAILGO,dir,0);
end;
procedure do_exit; { (exit_slot: integer)-- declared forward }
var
orig_slot,
targ_slot,
orig_room,
enter_slot,
targ_room: integer;
doalook: boolean;
begin
if (exit_slot < 1) or (exit_slot > 6) then
exit_fail(exit_slot)
else if here.exits[exit_slot].toloc > 0 then begin
block_subs(here.exits[exit_slot].success,myname);
orig_slot := myslot;
orig_room := location;
targ_room := here.exits[exit_slot].toloc;
enter_slot := here.exits[exit_slot].slot;
doalook := here.exits[exit_slot].autolook;
{ optimization for exit that goes nowhere;
why go nowhere? For special effects, we
don't want it to take too much time,
the logs are important because they force the
exit descriptions, but actually moving the
player is unnecessary }
if orig_room = targ_room then begin
log_exit(exit_slot,orig_room,orig_slot);
log_entry(enter_slot,targ_room,orig_slot);
{ orig_slot in log_entry 'cause we're not
really going anwhere }
if doalook then
do_look;
end else begin
take_token(orig_slot,orig_room);
if not put_token(targ_room,targ_slot) then begin
{ no room in room! }
{ put them back! Quick! } if not put_token(orig_room,myslot) then begin
writeln('%Oh no!');
halt;
end;
end else begin
log_exit(exit_slot,orig_room,orig_slot);
log_entry(enter_slot,targ_room,targ_slot);
myslot := targ_slot;
location := targ_room;
setevent;
if doalook then
do_look;
end;
end;
end else
exit_fail(exit_slot);
end;
function cycle_open: boolean;
var
ch: char;
s: string;
begin
s := systime;
ch := s[5];
if ch in ['1','3','5','7','9'] then
cycle_open := true
else
cycle_open := false;
end;
function which_dir(var dir:integer;s: string): boolean;
var
aliasdir, exitdir: integer;
aliasmatch,exitmatch,
aliasexact,exitexact: boolean;
exitreq: boolean;
begin
s := lowcase(s);
if lookup_alias(aliasdir,s) then
aliasmatch := true
else
aliasmatch := false;
if lookup_dir(exitdir,s) then
exitmatch := true
else
exitmatch := false;
if aliasmatch then begin
if s = here.exits[aliasdir].alias then
aliasexact := true
else
aliasexact := false;
end else
aliasexact := false;
if exitmatch then begin
if (s = direct[exitdir]) or (s = substr(direct[exitdir],1,1)) then
exitexact := true
else
exitexact := false;
end else
exitexact := false;
if exitmatch then
exitreq := here.exits[exitdir].reqalias
else
exitreq := false;
dir := 0;
which_dir := true;
if aliasexact and exitexact then
dir := aliasdir
else if aliasexact then
dir := aliasdir
else if exitexact and not exitreq then
dir := exitdir
else if aliasmatch then
dir := aliasdir
else if exitmatch and not exitreq then
dir := exitdir
else if exitmatch and exitreq then begin
dir := exitdir;
which_dir := false;
end else begin
which_dir := false;
end;
end;
procedure exit_case(dir: integer);
begin
case here.exits[dir].kind of
0: exit_fail(dir);
1: do_exit(dir); { more checking goes here }
3: if obj_hold(here.exits[dir].objreq) then
exit_fail(dir)
else
do_exit(dir);
4: if rnd100 < 34 then
do_exit(dir)
else
exit_fail(dir);
2: begin
if obj_hold(here.exits[dir].objreq) then
do_exit(dir)
else
exit_fail(dir);
end;
6: if obj_hold(here.exits[dir].objreq) then
do_exit(dir)
else
exit_fail(dir);
7: if cycle_open then
do_exit(dir)
else
exit_fail(dir);
end;
end;
{
Player wants to go to s
Handle everthing, this is the top level procedure
Check that he can go to s
Put him through the exit ( in do_exit )
Do a look for him ( in do_exit )
}
procedure do_go(s: string;verb:boolean := true);
var
dir: integer;
begin
gethere;
if checkhide then begin
if length(s) = 0 then
writeln('You must give the direction you wish to travel.')
else begin
if which_dir(dir,s) then begin
if (dir >= 1) and (dir <= maxexit) then begin
if here.exits[dir].toloc = 0 then begin
exit_fail(dir);
end else begin
exit_case(dir);
end;
end else
exit_fail(dir);
end else
exit_fail(dir);
end;
end;
end;
procedure nice_say(var s: string);
begin
{ capitalize the first letter of their sentence }
if s[1] in ['a'..'z'] then
s[1] := chr( ord('A') + (ord(s[1]) - ord('a')) );
{ put a period on the end of their sentence if
they don't use any punctuation. }
if s[length(s)] in ['a'..'z','A'..'Z'] then
s := s + '.';
end;
procedure do_say(s:string);
begin
if length(s) > 0 then begin
{ if length(s) + length(myname) > 79 then begin
s := substr(s,1,75-length(myname));
writeln('Your message was truncated:');
writeln('-- ',s);
end; }
nice_say(s);
if hiding then
log_event(myslot,E_HIDESAY,0,0,s)
else
log_event(myslot,E_SAY,0,0,s);
end else
writeln('To talk to others in the room, type SAY <message>.');
end;
procedure do_setname(s: string);
var
notice: string;
ok: boolean;
dummy: integer;
sprime: string;
begin
gethere;
if s <> '' then begin
if length(s) <= shortlen then begin
sprime := lowcase(s);
if (sprime = 'monster manager') and (userid <> MM_userid) then begin
writeln('Only the Monster Manager can have that personal name.');
ok := false;
end else if (sprime = 'vice manager') and (userid <> MVM_userid) then begin
writeln('Only the Vice Manager can have that name.');
ok := false;
end else if (sprime = 'faust') and (userid <> FAUST_userid) then begin
writeln('You are not Faust! You may not have that name.');
ok := false;
end else
ok := true;
if ok then
if exact_pers(dummy,sprime) then begin
if dummy = myslot then
ok := true
else begin
writeln('Someone already has that name. Your personal name must be unique.');
ok := false;
end;
end;
if ok then begin
myname := s;
getroom;
notice := here.people[myslot].name;
here.people[myslot].name := s;
putroom;
notice := notice + ' is now known as ' + s;
if not(hiding) then
log_event(0,E_SETNAM,0,0,notice);
{ slot 0 means notify this player also }
getpers; { note the new personal name in the logfile }
pers.idents[mylog] := s; { don't lowcase it }
putpers;
end;
end else
writeln('Please limit your personal name to ',shortlen:1,' characters.');
end else
writeln('You are known to others as ',myname);
end;
function sysdate:string;
var
thedate: packed array[1..11] of char;
begin
date(thedate);
sysdate := thedate;
end;
{
1234567890123456789012345678901234567890
example display for alignment:
Monster Status
19-MAR-1988 08:59pm
}
procedure do_who;
var
i,j: integer;
ok: boolean;
metaok: boolean;
roomown: veryshortstring;
begin
log_event(myslot,E_WHO,0,(rnd100 mod 4));
{ we need just about everything to print this list:
player alloc index, userids, personal names,
room names, room owners, and the log record }
getindex(I_ASLEEP); { Get index of people who are playing now }
freeindex;
getuser;
freeuser;
getpers;
freepers;
getnam;
freenam;
getown;
freeown;
getint(N_LOCATION); { get where they are }
freeint;
writeln(' Monster Status');
writeln(' ',sysdate,' ',systime);
writeln;
writeln('Username Game Name Where');
if (privd) { or has_kind(O_ALLSEEING) } then
metaok := true
else
metaok := false;
for i := 1 to indx.top do begin
if not(indx.free[i]) then begin
write(user.idents[i]);
j := length(user.idents[i]);
while j < 16 do begin
write(' ');
j := j + 1;
end;
write(pers.idents[i]);
j := length(pers.idents[i]);
while j <= 25 do begin
write(' ');
j := j + 1;
end;
if not(metaok) then begin
roomown := own.idents[anint.int[i]];
{ if a person is in a public or disowned room, or
if they are in the domain of the WHOer, then the player should know
where they are }
if (roomown = '') or (roomown = '*') or
(roomown = userid) then
ok := true
else
ok := false;
{ the player obviously knows where he is }
if i = mylog then
ok := true;
end;
if ok or metaok then begin
writeln(nam.idents[anint.int[i]]);
end else
writeln('n/a');
end;
end;
end;
function own_trans(s: string): string;
begin
if s = '' then
own_trans := '<public>'
else if s = '*' then
own_trans := '<disowned>'
else
own_trans := s;
end;
procedure list_rooms(s: shortstring);
var
first: boolean;
i,j,posit: integer;
begin
first := true;
posit := 0;
for i := 1 to indx.top do begin
if (not indx.free[i]) and (own.idents[i] = s) then begin
if posit = 3 then begin
posit := 1;
writeln;
end else
posit := posit + 1;
if first then begin
first := false;
writeln(own_trans(s),':');
end;
write(' ',nam.idents[i]);
for j := length(nam.idents[i]) to 21 do
write(' ');
end;
end;
if posit <> 3 then
writeln;
if first then
writeln('No rooms owned by ',own_trans(s))
else
writeln;
end;
procedure list_all_rooms;
var
i,j: integer;
tmp: packed array[1..maxroom] of boolean;
begin
tmp := zero;
list_rooms(''); { public rooms first }
list_rooms('*'); { disowned rooms next }
for i := 1 to indx.top do begin
if not(indx.free[i]) and not(tmp[i]) and
(own.idents[i] <> '') and (own.idents[i] <> '*') then begin
list_rooms(own.idents[i]); { player rooms }
for j := 1 to indx.top do
if own.idents[j] = own.idents[i] then
tmp[j] := TRUE;
end;
end;
end;
procedure do_rooms(s: string);
var
cmd: string;
id: veryshortstring;
listall: boolean;
begin
getnam;
freenam;
getown;
freeown;
getindex(I_ROOM);
freeindex;
listall := false;
s := lowcase(s);
cmd := bite(s);
if cmd = '' then
id := userid
else if cmd = 'public' then
id := ''
else if cmd = 'disowned' then
id := '*'
else if cmd = '<public>' then
id := ''
else if cmd = '<disowned>' then
id := '*'
else if cmd = '*' then
listall := true
else if length(cmd) > veryshortlen then
id := substr(cmd,1,veryshortlen)
else
id := cmd;
if listall then begin
if privd then
list_all_rooms
else
writeln('You may not obtain a list of all the rooms.');
end else begin
if privd or (userid = id) or (id = '') or (id = '*') then
list_rooms(id)
else
writeln('You may not list rooms that belong to another player.');
end;
end;
procedure do_objects;
var
i: integer;
total,public,disowned,private: integer;
begin
getobjnam;
freeobjnam;
getobjown;
freeobjown;
getindex(I_OBJECT);
freeindex;
total := 0;
public := 0;
disowned := 0;
private := 0;
writeln;
for i := 1 to indx.top do begin
if not(indx.free[i]) then begin
total := total + 1;
if objown.idents[i]='' then begin
writeln(i:4,' ','<public>':12,' ',objnam.idents[i]);
public := public + 1
end else if objown.idents[i]='*' then begin
writeln(i:4,' ','<disowned>':12,' ',objnam.idents[i]);
disowned := disowned + 1
end else begin
private := private + 1;
if (objown.idents[i] = userid) or
(privd) then begin
{ >>>>>> } writeln(i:4,' ',objown.idents[i]:12,' ',objnam.idents[i]);
end;
end;
end;
end;
writeln;
writeln('Public: ',public:4);
writeln('Disowned: ',disowned:4);
writeln('Private: ',private:4);
writeln(' ----');
writeln('Total: ',total:4);
end;
procedure do_claim(s: string);
var
n: integer;
ok: boolean;
tmp: string;
begin
if length(s) = 0 then begin { claim this room }
getroom;
if (here.owner = '*') or (privd) then begin
here.owner := userid;
putroom;
getown;
own.idents[location] := userid;
putown;
log_event(myslot,E_CLAIM,0,0);
writeln('You are now the owner of this room.');
end else begin
freeroom;
if here.owner = '' then
writeln('This is a public room. You may not claim it.')
else
writeln('This room has an owner.');
end;
end else if lookup_obj(n,s) then begin
getobjown;
freeobjown;
if objown.idents[n] = '' then
writeln('That is a public object. You may DUPLICATE it, but may not CLAIM it.')
else if objown.idents[n] <> '*' then
writeln('That object has an owner.')
else begin
getobj(n);
freeobj;
if obj.numexist = 0 then
ok := true
else begin
if obj_hold(n) or obj_here(n) then
ok := true
else
ok := false;
end;
if ok then begin
getobjown;
objown.idents[n] := userid;
putobjown;
tmp := obj.oname;
log_event(myslot,E_OBJCLAIM,0,0,tmp);
writeln('You are now the owner the ',tmp,'.');
end else
writeln('You must have one to claim it.');
end;
end else
writeln('There is nothing here by that name to claim.');
end;
procedure do_disown(s: string);
var
n: integer;
tmp: string;
begin
if length(s) = 0 then begin { claim this room }
getroom;
if (here.owner = userid) or (privd) then begin
getroom;
here.owner := '*';
putroom;
getown;
own.idents[location] := '*';
putown;
log_event(myslot,E_DISOWN,0,0);
writeln('You have disowned this room.');
end else begin
freeroom;
writeln('You are not the owner of this room.');
end;
end else begin { disown an object }
if lookup_obj(n,s) then begin
getobj(n);
freeobj;
tmp := obj.oname;
getobjown;
if objown.idents[n] = userid then begin
objown.idents[n] := '*';
putobjown;
log_event(myslot,E_OBJDISOWN,0,0,tmp);
writeln('You are no longer the owner of the ',tmp,'.');
end else begin
freeobjown;
writeln('You are not the owner of any such thing.');
end;
end else
writeln('You are not the owner of any such thing.');
end;
end;
procedure do_public(s: string);
var
ok: boolean;
tmp: string;
n: integer;
begin
if privd then begin
if length(s) = 0 then begin
getroom;
here.owner := '';
putroom;
getown;
own.idents[location] := '';
putown;
end else if lookup_obj(n,s) then begin
getobjown;
freeobjown;
if objown.idents[n] = '' then
writeln('That is already public.')
else begin
getobj(n);
freeobj;
if obj.numexist = 0 then
ok := true
else begin
if obj_hold(n) or obj_here(n) then
ok := true
else
ok := false;
end;
if ok then begin
getobjown;
objown.idents[n] := '';
putobjown;
tmp := obj.oname;
log_event(myslot,E_OBJPUBLIC,0,0,tmp);
writeln('The ',tmp,' is now public.');
end else
writeln('You must have one to claim it.');
end;
end else
writeln('There is nothing here by that name to claim.');
end else
writeln('Only the Monster Manager may make things public.');
end;
{ sum up the number of real exits in this room }
function find_numexits: integer;
var
i: integer;
sum: integer;
begin
sum := 0;
for i := 1 to maxexit do
if here.exits[i].toloc <> 0 then
sum := sum + 1;
find_numexits := sum;
end;
{ clear all people who have played monster and quit in this location
out of the room so that when they start up again they won't be here,
because we are destroying this room }
procedure clear_people(loc: integer);
var
i: integer;
begin
getint(N_LOCATION);
for i := 1 to maxplayers do
if anint.int[i] = loc then
anint.int[i] := 1;
putint;
end;
procedure do_zap(s: string);
var
loc: integer;
begin
gethere;
if checkhide then begin
if lookup_room(loc,s) then begin
gethere(loc);
if (here.owner = userid) or (privd) then begin
clear_people(loc);
if find_numpeople = 0 then begin
if find_numexits = 0 then begin
if find_numobjs = 0 then begin
del_room(loc);
writeln('Room deleted.');
end else
writeln('You must remove all of the objects from that room first.');
end else
writeln('You must delete all of the exits from that room first.');
end else
writeln('Sorry, you cannot destroy a room if people are still in it.');
end else
writeln('You are not the owner of that room.');
end else
writeln('There is no room named ',s,'.');
end;
end;
function room_nameinuse(num: integer; newname: string): boolean;
var
dummy: integer;
begin
if exact_obj(dummy,newname) then begin
if dummy = num then
room_nameinuse := false
else
room_nameinuse := true;
end else
room_nameinuse := false;
end;
procedure do_rename;
var
dummy: integer;
newname: string;
s: string;
begin
gethere;
writeln('This room is named ',here.nicename);
writeln;
grab_line('New name: ',newname);
if (newname = '') or (newname = '**') then
writeln('No changes.')
else if length(newname) > shortlen then
writeln('Please limit your room name to ',shortlen:1,' characters.')
else if room_nameinuse(location,newname) then
writeln(newname,' is not a unique room name.')
else begin
getroom;
here.nicename := newname;
putroom;
getnam;
nam.idents[location] := lowcase(newname);
putnam;
writeln('Room name updated.');
end;
end;
function obj_nameinuse(objnum: integer; newname: string): boolean;
var
dummy: integer;
begin
if exact_obj(dummy,newname) then begin
if dummy = objnum then
obj_nameinuse := false
else
obj_nameinuse := true;
end else
obj_nameinuse := false;
end;
procedure do_objrename(objnum: integer);
var
newname: string;
s: string;
begin
getobj(objnum);
freeobj;
writeln('This object is named ',obj.oname);
writeln;
grab_line('New name: ',newname);
if (newname = '') or (newname = '**') then
writeln('No changes.')
else if length(newname) > shortlen then
writeln('Please limit your object name to ',shortlen:1,' characters.')
else if obj_nameinuse(objnum,newname) then
writeln(newname,' is not a unique object name.')
else begin
getobj(objnum);
obj.oname := newname;
putobj;
getobjnam;
objnam.idents[objnum] := lowcase(newname);
putobjnam;
writeln('Object name updated.');
end;
end;
procedure view_room;
var
s: string;
i: integer;
begin
writeln;
getnam;
freenam;
getobjnam;
freeobjnam;
with here do begin
writeln('Room: ',nicename);
case nameprint of
0: writeln('Room name not printed');
1: writeln('"You''re in" precedes room name');
2: writeln('"You''re at" precedes room name');
otherwise writeln('Room name printing is damaged.');
end;
write('Room owner: ');
if owner = '' then
writeln('<public>')
else if owner = '*' then
writeln('<disowned>')
else
writeln(owner);
if primary = 0 then
writeln('There is no primary description')
else
writeln('There is a primary description');
if secondary = 0 then
writeln('There is no secondary description')
else
writeln('There is a secondary description');
case which of
0: writeln('Only the primary description will print');
1: writeln('Only the secondary description will print');
2: writeln('Both the primary and secondary descriptions will print');
3: begin
writeln('The primary description will print, followed by the seconary description');
writeln('if the player is holding the magic object');
end;
4: begin
writeln('If the player is holding the magic object, the secondary description will print');
writeln('Otherwise, the primary description will print');
end;
otherwise writeln('The way the room description prints is damaged');
end;
writeln;
if magicobj = 0 then
writeln('There is no magic object for this room')
else
writeln('The magic object for this room is the ',objnam.idents[magicobj],'.');
if objdrop = 0 then
writeln('Dropped objects remain here')
else begin
writeln('Dropped objects go to ',nam.idents[objdrop],'.');
if objdesc = 0 then
writeln('Dropped.')
else
print_line(objdesc);
if objdest = 0 then
writeln('Nothing is printed when object "bounces in" to target room')
else
print_line(objdest);
end;
writeln;
if trapto = 0 then
writeln('There is no trapdoor set')
else
writeln('The trapdoor sends players ',direct[trapto],
' with a chance factor of ',trapchance:1,'%');
for i := 1 to maxdetail do begin
if length(detail[i]) > 0 then begin
write('Detail "',detail[i],'" ');
if detaildesc[i] > 0 then
writeln('has a description')
else
writeln('has no description');
end;
end;
writeln;
end;
end;
procedure room_help;
begin
writeln;
writeln('D Alter the way the room description prints');
writeln('N Change how the room Name prints');
writeln('P Edit the Primary room description [the default one] (same as desc)');
writeln('S Edit the Secondary room description');
writeln('X Define a mystery message');
writeln;
writeln('G Set the location that a dropped object really Goes to');
writeln('O Edit the object drop description (for drop effects)');
writeln('B Edit the target room (G) "bounced in" description');
writeln;
writeln('T Set the direction that the Trapdoor goes to');
writeln('C Set the Chance of the trapdoor functioning');
writeln;
writeln('M Define the magic object for this room');
writeln('R Rename the room');
writeln;
writeln('V View settings on this room');
writeln('E Exit (same as quit)');
writeln('Q Quit (same as exit)');
writeln('? This list');
writeln;
end;
procedure custom_room;
var
done: boolean;
prompt: string;
n: integer;
s: string;
newdsc: integer;
bool: boolean;
begin
log_action(e_custroom,0);
writeln;
writeln('Customizing this room');
writeln('If you would rather be customizing an exit, type CUSTOM <direction of exit>');
writeln('If you would rather be customizing an object, type CUSTOM <object name>');
writeln;
done := false;
prompt := 'Custom> ';
repeat
repeat
grab_line(prompt,s);
s := slead(s);
until length(s) > 0;
s := lowcase(s);
case s[1] of
'e','q': done := true;
'?','h': room_help;
'r': do_rename;
'v': view_room;
{dir trapdoor goes} 't': begin
grab_line('What direction does the trapdoor exit through? ',s);
if length(s) > 0 then begin
if lookup_dir(n,s) then begin
getroom;
here.trapto := n;
putroom;
writeln('Room updated.');
end else
writeln('No such direction.');
end else
writeln('No changes.');
end;
{chance} 'c': begin
writeln('Enter the chance that in any given minute the player will fall through');
writeln('the trapdoor (0-100) :');
writeln;
grab_line('? ',s);
if isnum(s) then begin
n := number(s);
if n in [0..100] then begin
getroom;
here.trapchance := n;
putroom;
end else
writeln('Out of range.');
end else
writeln('No changes.');
end;
's': begin
newdsc := here.secondary;
writeln('[ Editing the secondary room description ]');
if edit_desc(newdsc) then begin
getroom;
here.secondary := newdsc;
putroom;
end;
end;
'p': begin
{ same as desc } newdsc := here.primary;
writeln('[ Editing the primary room description ]');
if edit_desc(newdsc) then begin
getroom;
here.primary := newdsc;
putroom;
end;
end;
'o': begin
writeln('Enter the line that will be printed when someone drops an object here:');
writeln('If dropped objects do not stay here, you may use a # for the object name.');
writeln('Right now it says:');
if here.objdesc = 0 then
writeln('Dropped. [default]')
else
print_line(here.objdesc);
n := here.objdesc;
make_line(n);
getroom;
here.objdesc := n;
putroom;
end;
'x': begin
writeln('Enter a line that will be randomly shown.');
writeln('Right now it says:');
if here.objdesc = 0 then
writeln('[none defined]')
else
print_line(here.rndmsg);
n := here.rndmsg;
make_line(n);
getroom;
here.rndmsg := n;
putroom;
end;
{bounced in desc} 'b': begin
writeln('Enter the line that will be displayed in the room where an object really');
writeln('goes when an object dropped here "bounces" there:');
writeln('Place a # where the object name should go.');
writeln;
writeln('Right now it says:');
if here.objdest = 0 then
writeln('Something has bounced into the room.')
else
print_line(here.objdest);
n := here.objdest;
make_line(n);
getroom;
here.objdest := n;
putroom;
end;
'm': begin
getobjnam;
freeobjnam;
if here.magicobj = 0 then
writeln('There is currently no magic object for this room.')
else
writeln(objnam.idents[here.magicobj],
' is currently the magic object for this room.');
writeln;
grab_line('New magic object? ',s);
if s = '' then
writeln('No changes.')
else if lookup_obj(n,s) then begin
getroom;
here.magicobj := n;
putroom;
writeln('Room updated.');
end else
writeln('No such object found.');
end;
'g': begin
getnam;
freenam;
if here.objdrop = 0 then
writeln('Objects dropped fall here.')
else
writeln('Objects dropped fall in ',nam.idents[here.objdrop],'.');
writeln;
writeln('Enter * for [this room]:');
grab_line('Room dropped objects go to? ',s);
if s = '' then
writeln('No changes.')
else if s = '*' then begin
getroom;
here.objdrop := 0;
putroom;
writeln('Room updated.');
end else if lookup_room(n,s) then begin
getroom;
here.objdrop := n;
putroom;
writeln('Room updated.');
end else
writeln('No such room found.');
end;
'd': begin
writeln('Print room descriptions how?');
writeln;
writeln('0) Print primary (main) description only [default]');
writeln('1) Print only secondary description.');
writeln('2) Print both primary and secondary descriptions togther.');
writeln('3) Print primary description first; then print secondary description only if');
writeln(' the player is holding the magic object for this room.');
writeln('4) Print secondary if holding the magic obj; print primary otherwise');
writeln;
grab_line('? ',s);
if isnum(s) then begin
n := number(s);
if n in [0..4] then begin
getroom;
here.which := n;
putroom;
writeln('Room updated.');
end else
writeln('Out of range.');
end else
writeln('No changes.');
end;
'n': begin
writeln('How would you like the room name to print?');
writeln;
writeln('0) No room name is shown');
writeln('1) "You''re in ..."');
writeln('2) "You''re at ..."');
writeln;
grab_line('? ',s);
if isnum(s) then begin
n := number(s);
if n in [0..2] then begin
getroom;
here.nameprint := n;
putroom;
end else
writeln('Out of range.');
end else
writeln('No changes.');
end;
otherwise writeln('Bad command, type ? for a list');
end;
until done;
log_event(myslot,E_ROOMDONE,0,0);
end;
procedure analyze_exit(dir: integer);
var
s: string;
begin
writeln;
getnam;
freenam;
getobjnam;
freeobjnam;
with here.exits[dir] do begin
s := alias;
if s = '' then
s := '(no alias)'
else
s := '(alias ' + s + ')';
if here.exits[dir].reqalias then
s := s + ' (required)'
else
s := s + ' (not required)';
if toloc <> 0 then
writeln('The ',direct[dir],' exit ',s,' goes to ',nam.idents[toloc])
else
writeln('The ',direct[dir],' exit goes nowhere.');
if hidden <> 0 then
writeln('Concealed.');
write('Exit type: ');
case kind of
0: writeln('no exit.');
1: writeln('Open passage.');
2: writeln('Door, object required to pass.');
3: writeln('No passage if holding object.');
4: writeln('Randomly fails');
5: writeln('Potential exit.');
6: writeln('Only exists while holding the required object.');
7: writeln('Timed exit');
end;
if objreq = 0 then
writeln('No required object.')
else
writeln('Required object is: ',objnam.idents[objreq]);
writeln;
if exitdesc = DEFAULT_LINE then
exit_default(dir,kind)
else
print_line(exitdesc);
if success = 0 then
writeln('(no success message)')
else
print_desc(success);
if fail = DEFAULT_LINE then begin
if kind = 5 then
writeln('There isn'' an exit there yet.')
else
writeln('You can''t go that way.');
end else
print_desc(fail);
if comeout = DEFAULT_LINE then
writeln('# has come into the room from: ',direct[dir])
else
print_desc(comeout);
if goin = DEFAULT_LINE then
writeln('# has gone ',direct[dir])
else
print_desc(goin);
writeln;
if autolook then
writeln('LOOK automatically done after exit used')
else
writeln('LOOK supressed on exit use');
if reqverb then
writeln('The alias is required to be a verb for exit use')
else
writeln('The exit can be used with GO or as a verb');
end;
writeln;
end;
procedure custom_help;
begin
writeln;
writeln('A Set an Alias for the exit');
writeln('C Conceal an exit');
writeln('D Edit the exit''s main Description');
writeln('E EXIT custom (saves changes)');
writeln('F Edit the exit''s failure line');
writeln('I Edit the line that others see when a player goes Into an exit');
writeln('K Set the object that is the Key to this exit');
writeln('L Automatically look [default] / don''t look on exit');
writeln('O Edit the line that people see when a player comes Out of an exit');
writeln('Q QUIT Custom (saves changes)');
writeln('R Require/don''t require alias for exit; ignore direction');
writeln('S Edit the success line');
writeln('T Alter Type of exit (passage, door, etc)');
writeln('V View exit information');
writeln('X Require/don''t require exit name to be a verb');
writeln('? This list');
writeln;
end;
procedure get_key(dir: integer);
var
s: string;
n: integer;
begin
getobjnam;
freeobjnam;
if here.exits[dir].objreq = 0 then
writeln('Currently there is no key set for this exit.')
else
writeln(objnam.idents[here.exits[dir].objreq],' is the current key for this exit.');
writeln('Enter * for [no key]');
writeln;
grab_line('What object is the door key? ',s);
if length(s) > 0 then begin
if s = '*' then begin
getroom;
here.exits[dir].objreq := 0;
putroom;
writeln('Exit updated.');
end else if lookup_obj(n,s) then begin
getroom;
here.exits[dir].objreq := n;
putroom;
writeln('Exit updated.');
end else
writeln('There is no object by that name.');
end else
writeln('No changes.');
end;
procedure do_custom(dirnam: string);
var
prompt: string;
done : boolean;
s: string;
dir: integer;
n: integer;
begin
gethere;
if checkhide then begin
if length(dirnam) = 0 then begin
if is_owner(location,TRUE) then
custom_room
else begin
writeln('You are not the owner of this room; you cannot customize it.');
writeln('However, you may be able to customize some of the exits. To customize an');
writeln('exit, type CUSTOM <direction of exit>');
end;
end else if lookup_dir(dir,dirnam) then begin
if can_alter(dir) then begin
log_action(c_custom,0);
writeln('Customizing ',direct[dir],' exit');
writeln('If you would rather be customizing this room, type CUSTOM with no arguments');
writeln('If you would rather be customizing an object, type CUSTOM <object name>');
writeln;
writeln('Type ** for any line to leave it unchanged.');
writeln('Type return for any line to select the default.');
writeln;
writev(prompt,'Custom ',direct[dir],'> ');
done := false;
repeat
repeat
grab_line(prompt,s);
s := slead(s);
until length(s) > 0;
s := lowcase(s);
case s[1] of
'?','h': custom_help;
'q','e': done := true;
'k': get_key(dir);
'c': begin
writeln('Type the description that a player will see when the exit is found.');
writeln('Make no text for description to unconceal the exit.');
writeln;
writeln('[ Editing the "hidden exit found" description ]');
n := here.exits[dir].hidden;
if edit_desc(n) then begin
getroom;
here.exits[dir].hidden := n;
putroom;
end;
end;
{req alias} 'r': begin
getroom;
here.exits[dir].reqalias :=
not(here.exits[dir].reqalias);
putroom;
if here.exits[dir].reqalias then
writeln('The alias for this exit will be required to reference it.')
else
writeln('The alias will not be required to reference this exit.');
end;
{req verb} 'x': begin
getroom;
here.exits[dir].reqverb :=
not(here.exits[dir].reqverb);
putroom;
if here.exits[dir].reqverb then
writeln('The exit name will be required to be used as a verb to use the exit')
else
writeln('The exit name may be used with GO or as a verb to use the exit');
end;
{autolook} 'l': begin
getroom;
here.exits[dir].autolook :=
not(here.exits[dir].autolook);
putroom;
if here.exits[dir].autolook then
writeln('A LOOK will be done after the player travels through this exit.')
else
writeln('The automatic LOOK will not be done when a player uses this exit.');
end;
'a': begin
grab_line('Alternate name for the exit? ',s);
if length(s) > veryshortlen then
writeln('Your alias must be less than ',veryshortlen:1,' characters.')
else begin
getroom;
here.exits[dir].alias := lowcase(s);
putroom;
end;
end;
'v': analyze_exit(dir);
't': begin
writeln;
writeln('Select the type of your exit:');
writeln;
writeln('0) No exit');
writeln('1) Open passage');
writeln('2) Door (object required to pass)');
writeln('3) No passage if holding key');
if privd then
writeln('4) exit randomly fails');
writeln('6) Exit exists only when holding object');
if privd then
writeln('7) exit opens/closes invisibly every minute');
writeln;
grab_line('Which type? ',s);
if isnum(s) then begin
n := number(s);
if n in [0..4,6..7] then begin
getroom;
here.exits[dir].kind := n;
putroom;
writeln('Exit type updated.');
writeln;
if n in [2,6] then
get_key(dir);
end else
writeln('Bad exit type.');
end else
writeln('Exit type not changed.');
end;
'f': begin
writeln('The failure description will print if the player attempts to go through the');
writeln('the exit but cannot for any reason.');
writeln;
writeln('[ Editing the exit failure description ]');
n := here.exits[dir].fail;
if edit_desc(n) then begin
getroom;
here.exits[dir].fail := n;
putroom;
end;
end;
'i': begin
writeln('Edit the description that other players see when someone goes into');
writeln('the exit. Place a # where the player''s name should appear.');
writeln;
writeln('[ Editing the exit "go in" description ]');
n := here.exits[dir].goin;
if edit_desc(n) then begin
getroom;
here.exits[dir].goin := n;
putroom;
end;
end;
'o': begin
writeln('Edit the description that other players see when someone comes out of');
writeln('the exit. Place a # where the player''s name should appear.');
writeln;
writeln('[ Editing the exit "come out of" description ]');
n := here.exits[dir].comeout;
if edit_desc(n) then begin
getroom;
here.exits[dir].comeout := n;
putroom;
end;
end;
{ main exit desc } 'd': begin
writeln('Enter a one line description of the exit.');
writeln;
n := here.exits[dir].exitdesc;
make_line(n);
getroom;
here.exits[dir].exitdesc := n;
putroom;
end;
's': begin
writeln('The success description will print when the player goes through the exit.');
writeln;
writeln('[ Editing the exit success description ]');
n := here.exits[dir].success;
if edit_desc(n) then begin
getroom;
here.exits[dir].success := n;
putroom;
end;
end;
otherwise writeln('-- Bad command, type ? for a list');
end;
until done;
log_event(myslot,E_CUSTDONE,0,0);
end else
writeln('You are not allowed to alter that exit.');
end else if lookup_obj(n,dirnam) then
{ if lookup_obj returns TRUE then dirnam is name of object to custom }
do_program(dirnam) { customize the object }
else begin
writeln('To customize this room, type CUSTOM');
writeln('To customize an exits, type CUSTOM <direction>');
writeln('To customize an object, type CUSTOM <object name>');
end;
{ clear_command; }
end;
end;
procedure reveal_people(var three: boolean);
var
retry,i: integer;
begin
if debug then
writeln('%revealing people');
three := false;
retry := 1;
repeat
retry := retry + 1;
i := (rnd100 mod maxpeople) + 1;
if (here.people[i].hiding > 0) and
(i <> myslot) then begin
three := true;
writeln('You''ve found ',here.people[i].name,' hiding in the shadows!');
log_event(myslot,E_FOUNDYOU,i,0);
end;
until (retry > 7) or three;
end;
procedure reveal_objects(var two: boolean);
var
tmp: string;
i: integer;
begin
if debug then
writeln('%revealing objects');
two := false;
for i := 1 to maxobjs do begin
if here.objs[i] <> 0 then { if there is an object here }
if (here.objhide[i] <> 0) then begin
two := true;
if here.objhide[i] = DEFAULT_LINE then
writeln('You''ve found ',obj_part(here.objs[i]),'.')
else begin
print_desc(here.objhide[i]);
delete_block(here.objhide[i]);
end;
end;
end;
end;
procedure reveal_exits(var one: boolean);
var
retry,i: integer;
begin
if debug then
writeln('%revealing exits');
one := false;
retry := 1;
repeat
retry := retry + 1;
i := (rnd100 mod maxexit) + 1; { a random exit }
if (here.exits[i].hidden <> 0) and (not found_exit[i]) then begin
one := true;
found_exit[i] := true; { mark exit as found }
if here.exits[i].hidden = DEFAULT_LINE then begin
if here.exits[i].alias = '' then
writeln('You''ve found a hidden exit: ',direct[i],'.')
else
writeln('You''ve found a hidden exit: ',here.exits[i].alias,'.');
end else
print_desc(here.exits[i].hidden);
end;
until (retry > 4) or (one);
end;
procedure do_search(s: string);
var
chance: integer;
found,dummy: boolean;
begin
if checkhide then begin
chance := rnd100;
found := false;
dummy := false;
if chance in [1..20] then
reveal_objects(found)
else if chance in [21..40] then
reveal_exits(found)
else if chance in [41..60] then
reveal_people(dummy);
if found then begin
log_event(myslot,E_FOUND,0,0);
end else if not(dummy) then begin
log_event(myslot,E_SEARCH,0,0);
writeln('You haven''t found anything.');
end;
end;
end;
procedure do_unhide(s: string);
begin
if s = '' then begin
if hiding then begin
hiding := false;
log_event(myslot,E_UNHIDE,0,0);
getroom;
here.people[myslot].hiding := 0;
putroom;
writeln('You are no longer hiding.');
end else
writeln('You were not hiding.');
end;
end;
procedure do_hide(s: string);
var
slot,n: integer;
founddsc: integer;
tmp: string;
begin
gethere;
if s = '' then begin { hide yourself }
{ don't let them hide (or hide better) if people
that they can see are in the room. Note that the
use of n_can_see instead of find_numpeople will
let them hide if other people are hidden in the
room that they have not seen. The previously hidden
people will see them hide }
if n_can_see > 0 then begin
if hiding then
writeln('You can''t hide any better with people in the room.')
else
writeln('You can''t hide when people are watching you.');
end else if (rnd100 > 25) then begin
if here.people[myslot].hiding >= 4 then
writeln('You''re pretty well hidden now. I don''t think you could be any less visible.')
else begin
getroom;
here.people[myslot].hiding :=
here.people[myslot].hiding + 1;
putroom;
if hiding then begin
log_event(myslot,E_NOISES,rnd100,0);
writeln('You''ve managed to hide yourself a little better.');
end else begin
log_event(myslot,E_IHID,0,0);
writeln('You''ve hidden yourself from view.');
hiding := true;
end;
end;
end else begin { unsuccessful }
if hiding then
writeln('You could not find a better hiding place.')
else
writeln('You could not find a good hiding place.');
end;
end else begin { Hide an object }
if parse_obj(n,s) then begin
if obj_here(n) then begin
writeln('Enter the description the player will see when the object is found:');
writeln('(if no description is given a default will be supplied)');
writeln;
writeln('[ Editing the "object found" description ]');
founddsc := 0;
if edit_desc(founddsc) then ;
if founddsc = 0 then
founddsc := DEFAULT_LINE;
getroom;
slot := find_obj(n);
here.objhide[slot] := founddsc;
putroom;
tmp := obj_part(n);
log_event(myslot,E_HIDOBJ,0,0,tmp);
writeln('You have hidden ',tmp,'.');
end else if obj_hold(n) then begin
writeln('You''ll have to put it down before it can be hidden.');
end else
writeln('I see no such object here.');
end else
writeln('I see no such object here.');
end;
end;
procedure do_punch(s: string);
var
sock,n: integer;
begin
if s <> '' then begin
if parse_pers(n,s) then begin
if n = myslot then
writeln('Self-abuse will not be tolerated in the Monster universe.')
else if protected(n) then begin
log_event(myslot,E_TRYPUNCH,n,0);
writeln('A mystic shield of force prevents you from attacking.');
end else if here.people[n].username = MM_userid then begin
log_event(myslot,E_TRYPUNCH,n,0);
writeln('You can''t punch the Monster Manager.');
end else begin
if hiding then begin
hiding := false;
getroom;
here.people[myslot].hiding := 0;
putroom;
log_event(myslot,E_HIDEPUNCH,n,0);
writeln('You pounce unexpectedly on ',here.people[n].name,'!');
end else begin
sock := (rnd100 mod numpunches)+1;
log_event(myslot,E_PUNCH,n,sock);
put_punch(sock,here.people[n].name);
end;
wait(1+random*3); { Ha ha ha }
end;
end else
writeln('That person cannot be seen in this room.');
end else
writeln('To punch somebody, type PUNCH <personal name>.');
end;
{ support for do_program (custom an object)
Give the player a list of kinds of object he's allowed to make his object
and update it }
procedure prog_kind(objnum: integer);
var
n: integer;
s: string;
begin
writeln('Select the type of your object:');
writeln;
writeln('0 Ordinary object (good for door keys)');
writeln('1 Weapon');
writeln('2 Armor');
writeln('3 Exit thruster');
if privd then begin
writeln;
writeln('100 Bag');
writeln('101 Crystal Ball');
writeln('102 Wand of Power');
writeln('103 Hand of Glory');
end;
writeln;
grab_line('Which kind? ',s);
if isnum(s) then begin
n := number(s);
if (n > 100) and (privd) then
writeln('Out of range.')
else if n in [0..3,100..103] then begin
getobj(objnum);
obj.kind := n;
putobj;
writeln('Object updated.');
end else
writeln('Out of range.');
end;
end;
{ support for do_program (custom an object)
Based on the kind it is allow the
user to set the various parameters for the effects associated with that
kind }
procedure prog_obj(objnum: integer);
begin
end;
procedure show_kind(p: integer);
begin
case p of
0: writeln('Ordinary object');
1: writeln('Weapon');
2: writeln('Armor');
100: writeln('Bag');
101: writeln('Crystal Ball');
102: writeln('Wand of Power');
103: writeln('Hand of Glory');
otherwise writeln('Bad object type');
end;
end;
procedure obj_view(objnum: integer);
begin
writeln;
getobj(objnum);
freeobj;
getobjown;
freeobjown;
writeln('Object name: ',obj.oname);
writeln('Owner: ',objown.idents[objnum]);
writeln;
show_kind(obj.kind);
writeln;
if obj.linedesc = 0 then
writeln('There is a(n) # here')
else
print_line(obj.linedesc);
if obj.examine = 0 then
writeln('No inspection description set')
else
print_desc(obj.examine);
{ writeln('Worth (in points) of this object: ',obj.worth:1); }
writeln('Number in existence: ',obj.numexist:1);
writeln;
end;
procedure program_help;
begin
writeln;
writeln('A "a", "an", "some", etc.');
writeln('D Edit a Description of the object');
writeln('F Edit the GET failure message');
writeln('G Set the object required to pick up this object');
writeln('1 Set the get success message');
writeln('K Set the Kind of object this is');
writeln('L Edit the label description ("There is a ... here.")');
writeln('P Program the object based on the kind it is');
writeln('R Rename the object');
writeln('S Toggle the sticky bit');
writeln;
writeln('U Set the object required for use');
writeln('2 Set the place required for use');
writeln('3 Edit the use failure description');
writeln('4 Edit the use success description');
writeln('V View attributes of this object');
writeln;
writeln('X Edit the extra description');
writeln('5 Edit extra desc #2');
writeln('E Exit (same as Quit)');
writeln('Q Quit (same as Exit)');
writeln('? This list');
writeln;
end;
procedure do_program; { (objnam: string); declared forward }
var
prompt: string;
done : boolean;
s: string;
objnum: integer;
n: integer;
newdsc: integer;
begin
gethere;
if checkhide then begin
if length(objnam) = 0 then begin
writeln('To program an object, type PROGRAM <object name>.');
end else if lookup_obj(objnum,objnam) then begin
if not is_owner(location,TRUE) then begin
writeln('You may only work on your objects when you are in one of your own rooms.');
end else if obj_owner(objnum) then begin
log_action(e_program,0);
writeln;
writeln('Customizing object');
writeln('If you would rather be customizing an EXIT, type CUSTOM <direction of exit>');
writeln('If you would rather be customizing this room, type CUSTOM');
writeln;
getobj(objnum);
freeobj;
prompt := 'Custom object> ';
done := false;
repeat
repeat
grab_line(prompt,s);
s := slead(s);
until length(s) > 0;
s := lowcase(s);
case s[1] of
'?','h': program_help;
'q','e': done := true;
'v': obj_view(objnum);
'r': do_objrename(objnum);
'g': begin
writeln('Enter * for no object');
grab_line('Object required for GET? ',s);
if s = '*' then begin
getobj(objnum);
obj.getobjreq := 0;
putobj;
end else if lookup_obj(n,s) then begin
getobj(objnum);
obj.getobjreq := n;
putobj;
writeln('Object modified.');
end else
writeln('No such object.');
end;
'u': begin
writeln('Enter * for no object');
grab_line('Object required for USE? ',s);
if s = '*' then begin
getobj(objnum);
obj.useobjreq := 0;
putobj;
end else if lookup_obj(n,s) then begin
getobj(objnum);
obj.useobjreq := n;
putobj;
writeln('Object modified.');
end else
writeln('No such object.');
end;
'2': begin
writeln('Enter * for no special place');
grab_line('Place required for USE? ',s);
if s = '*' then begin
getobj(objnum);
obj.uselocreq := 0;
putobj;
end else if lookup_room(n,s) then begin
getobj(objnum);
obj.uselocreq := n;
putobj;
writeln('Object modified.');
end else
writeln('No such object.');
end;
's': begin
getobj(objnum);
obj.sticky := not(obj.sticky);
putobj;
if obj.sticky then
writeln('The object will not be takeable.')
else
writeln('The object will be takeable.');
end;
'a': begin
writeln;
writeln('Select the article for your object:');
writeln;
writeln('0) None ex: " You have taken Excalibur "');
writeln('1) "a" ex: " You have taken a small box "');
writeln('2) "an" ex: " You have taken an empty bottle "');
writeln('3) "some" ex: " You have picked up some jelly beans "');
writeln('4) "the" ex: " You have picked up the Scepter of Power"');
writeln;
grab_line('? ',s);
if isnum(s) then begin
n := number(s);
if n in [0..4] then begin
getobj(objnum);
obj.particle := n;
putobj;
end else
writeln('Out of range.');
end else
writeln('No changes.');
end;
'k': begin
prog_kind(objnum);
end;
'p': begin
prog_obj(objnum);
end;
'd': begin
newdsc := obj.examine;
writeln('[ Editing the description of the object ]');
if edit_desc(newdsc) then begin
getobj(objnum);
obj.examine := newdsc;
putobj;
end;
end;
'x': begin
newdsc := obj.d1;
writeln('[ Editing extra description #1 ]');
if edit_desc(newdsc) then begin
getobj(objnum);
obj.d1 := newdsc;
putobj;
end;
end;
'5': begin
newdsc := obj.d2;
writeln('[ Editing extra description #2 ]');
if edit_desc(newdsc) then begin
getobj(objnum);
obj.d2 := newdsc;
putobj;
end;
end;
'f': begin
newdsc := obj.getfail;
writeln('[ Editing the get failure description ]');
if edit_desc(newdsc) then begin
getobj(objnum);
obj.getfail := newdsc;
putobj;
end;
end;
'1': begin
newdsc := obj.getsuccess;
writeln('[ Editing the get success description ]');
if edit_desc(newdsc) then begin
getobj(objnum);
obj.getsuccess := newdsc;
putobj;
end;
end;
'3': begin
newdsc := obj.usefail;
writeln('[ Editing the use failure description ]');
if edit_desc(newdsc) then begin
getobj(objnum);
obj.usefail := newdsc;
putobj;
end;
end;
'4': begin
newdsc := obj.usesuccess;
writeln('[ Editing the use success description ]');
if edit_desc(newdsc) then begin
getobj(objnum);
obj.usesuccess := newdsc;
putobj;
end;
end;
'l': begin
writeln('Enter a one line description of what the object will look like in any room.');
writeln('Example: "There is an as unyet described object here."');
writeln;
getobj(objnum);
freeobj;
n := obj.linedesc;
make_line(n);
getobj(objnum);
obj.linedesc := n;
putobj;
end;
otherwise writeln('-- Bad command, type ? for a list');
end;
until done;
log_event(myslot,E_OBJDONE,objnum,0);
end else
writeln('You are not allowed to program that object.');
end else
writeln('There is no object by that name.');
end;
end;
{ returns TRUE if anything was actually dropped }
function drop_everything;
{ forward function drop_everything(pslot: integer := 0): boolean; }
var
i: integer;
slot: integer;
didone: boolean;
theobj: integer;
tmp: string;
begin
if pslot = 0 then
pslot := myslot;
gethere;
didone := false;
mywield := 0;
mywear := 0;
for i := 1 to maxhold do begin
if here.people[pslot].holding[i] <> 0 then begin
didone := true;
theobj := here.people[pslot].holding[i];
slot := find_hold(theobj,pslot);
if place_obj(theobj,TRUE) then begin
drop_obj(slot,pslot);
end else begin { no place to put it, it's lost .... }
getobj(theobj);
obj.numexist := obj.numexist - 1;
putobj;
tmp := obj.oname;
writeln('The ',tmp,' was lost.');
end;
end;
end;
drop_everything := didone;
end;
procedure do_endplay(lognum: integer;ping:boolean := FALSE);
{ If update is true do_endplay will update the "last play" date & time
we don't want to do this if this endplay is called from a ping }
begin
if not(ping) then begin
{ Set the "last date & time of play" }
getdate;
adate.idents[lognum] := sysdate + ' ' + systime;
putdate;
end;
{ Put the player to sleep. Don't delete his information,
so it can be restored the next time they play. }
getindex(I_ASLEEP);
indx.free[lognum] := true; { Yes, I'm asleep }
putindex;
end;
function check_person(n: integer;id: string):boolean;
begin
inmem := false;
gethere;
if here.people[n].username = id then
check_person := true
else
check_person := false;
end;
function nuke_person(n: integer;id: string): boolean;
var
lognum: integer;
tmp: string;
begin
getroom;
if here.people[n].username = id then begin
{ drop everything they're carrying }
drop_everything(n);
tmp := here.people[n].username;
{ we'll need this for do_endplay }
{ Remove the person from the room }
here.people[n].kind := 0;
here.people[n].username := '';
here.people[n].name := '';
putroom;
{ update the log entries for them }
{ but first we have to find their log number
(mylog for them). We can do this with a lookup_user
give the userid we got above }
if lookup_user(lognum,tmp) then begin
do_endplay(lognum,TRUE);
{ TRUE tells do_endplay not to update the
"time of last play" information 'cause we
don't know how long the "zombie" has been
there. }
end else
writeln('%error in nuke_person; can''t fing their log number; notify the Monster Manager');
nuke_person := true;
end else begin
freeroom;
nuke_person := false;
end;
end;
function ping_player(n:integer;silent: boolean := false): boolean;
var
retry: integer;
id: string;
idname: string;
begin
ping_player := false;
id := here.people[n].username;
idname := here.people[n].name;
retry := 0;
ping_answered := false;
repeat
retry := retry + 1;
if not(silent) then
writeln('Sending ping # ',retry:1,' to ',idname,' . . .');
log_event(myslot,E_PING,n,0,myname);
wait(1);
checkevents(TRUE);
{ TRUE = don't reprint prompt }
if not(ping_answered) then
if check_person(n,id) then begin
wait(1);
checkevents(TRUE);
end else
ping_answered := true;
if not(ping_answered) then
if check_person(n,id) then begin
wait(1);
checkevents(TRUE);
end else
ping_answered := true;
until (retry >= 3) or ping_answered;
if not(ping_answered) then begin
if not(silent) then
writeln('That person is not responding to your pings . . .');
if nuke_person(n,id) then begin
ping_player := true;
if not(silent) then
writeln(idname,' shimmers and vanishes from sight.');
log_event(myslot,E_PINGONE,n,0,idname);
end else
if not(silent) then
writeln('That person is not a zombie after all.');
end else
if not(silent) then
writeln('That person is alive and well.');
end;
procedure do_ping(s: string);
var
n: integer;
dummy: boolean;
begin
if s <> '' then begin
if parse_pers(n,s) then begin
if n = myslot then
writeln('Don''t ping yourself.')
else
dummy := ping_player(n);
end else
writeln('You see no person here by that name.');
end else
writeln('To see if someone is really alive, type PING <personal name>.');
end;
procedure list_get;
var
first: boolean;
i: integer;
begin
first := true;
for i := 1 to maxobjs do begin
if (here.objs[i] <> 0) and
(here.objhide[i] = 0) then begin
if first then begin
writeln('Objects that you see here:');
first := false;
end;
writeln(' ',obj_part(here.objs[i]));
end;
end;
if first then
writeln('There is nothing you see here that you can get.');
end;
{ print the get success message for object number n }
procedure p_getsucc(n: integer);
begin
{ we assume getobj has already been done }
if (obj.getsuccess = 0) or (obj.getsuccess = DEFAULT_LINE) then
writeln('Taken.')
else
print_desc(obj.getsuccess);
end;
procedure do_meta_get(n: integer);
var
slot: integer;
begin
if obj_here(n) then begin
if can_hold then begin
slot := find_obj(n);
if take_obj(n,slot) then begin
hold_obj(n);
log_event(myslot,E_GET,0,0,
{ >>> } myname + ' has picked up ' + obj_part(n) + '.');
p_getsucc(n);
end else
writeln('Someone got to it before you did.');
end else
writeln('Your hands are full. You''ll have to drop something you''re carrying first.');
end else if obj_hold(n) then
writeln('You''re already holding that item.')
else
writeln('That item isn''t in an obvious place.');
end;
procedure do_get(s: string);
var
n: integer;
ok: boolean;
begin
if s = '' then begin
list_get;
end else if parse_obj(n,s,TRUE) then begin
getobj(n);
freeobj;
ok := true;
if obj.sticky then begin
ok := false;
log_event(myslot,E_FAILGET,n,0);
if (obj.getfail = 0) or (obj.getfail = DEFAULT_LINE) then
writeln('You can''t take ',obj_part(n,FALSE),'.')
else
print_desc(obj.getfail);
end else if obj.getobjreq > 0 then begin
if not(obj_hold(obj.getobjreq)) then begin
ok := false;
log_event(myslot,E_FAILGET,n,0);
if (obj.getfail = 0) or (obj.getfail = DEFAULT_LINE) then
writeln('You''ll need something first to get the ',obj_part(n,FALSE),'.')
else
print_desc(obj.getfail);
end;
end;
if ok then
do_meta_get(n); { get the object }
end else if lookup_detail(n,s) then begin
writeln('That detail of this room is here for the enjoyment of all Monster players,');
writeln('and may not be taken.');
end else
writeln('There is no object here by that name.');
end;
procedure do_drop(s: string);
var
slot,n: integer;
begin
if s = '' then begin
writeln('To drop an object, type DROP <object name>.');
writeln('To see what you are carrying, type INV (inventory).');
end else if parse_obj(n,s) then begin
if obj_hold(n) then begin
getobj(n);
freeobj;
if obj.sticky then
writeln('You can''t drop sticky objects.')
else if can_drop then begin
slot := find_hold(n);
if place_obj(n) then begin
drop_obj(slot);
log_event(myslot,E_DROP,0,n,
myname + ' has dropped '+obj_part(n) + '.');
if mywield = n then begin
mywield := 0;
getroom;
here.people[myslot].wielding := 0;
putroom;
end;
if mywear = n then begin
mywear := 0;
getroom;
here.people[myslot].wearing := 0;
putroom;
end;
end else
writeln('Someone took the spot where your were going to drop it.');
end else
writeln('It is too cluttered here. Find somewhere else to drop your things.');
end else begin
writeln('You''re not holding that item. To see what you''re holding, type INV.');
end;
end else
writeln('You''re not holding that item. To see what you''re holding, type INVENTORY.');
end;
procedure do_inv(s: string);
var
first: boolean;
i,n: integer;
objnum: integer;
begin
gethere;
if s = '' then begin
noisehide(50);
first := true;
log_event(myslot,E_INVENT,0,0);
for i := 1 to maxhold do begin
objnum := here.people[myslot].holding[i];
if objnum <> 0 then begin
if first then begin
writeln('You are holding:');
first := false;
end;
writeln(' ',obj_part(objnum));
end;
end;
if first then
writeln('You are empty handed.');
end else if parse_pers(n,s) then begin
first := true;
log_event(myslot,E_LOOKYOU,n,0);
for i := 1 to maxhold do begin
objnum := here.people[n].holding[i];
if objnum <> 0 then begin
if first then begin
writeln(here.people[n].name,' is holding:');
first := false;
end;
writeln(' ',objnam.idents[ objnum ]);
end;
end;
if first then
writeln(here.people[n].name,' is empty handed.');
end else
writeln('To see what someone else is carrying, type INV <personal name>.');
end;
{ translate a personal name into a real userid on request }
procedure do_whois(s: string);
var
n: integer;
begin
if lookup_pers(n,s) then begin
getuser;
freeuser;
{ getpers;
freepers; ! Already done in lookup_pers ! }
writeln(pers.idents[n],' is ',user.idents[n],'.');
end else
writeln('There is no one playing with that personal name.');
end;
procedure do_players(s: string);
var
i,j: integer;
tmpasleep: indexrec;
where_they_are: intrec;
begin
log_event(myslot,E_PLAYERS,0,0);
getindex(I_ASLEEP); { Rec of bool; False if playing now }
freeindex;
tmpasleep := indx;
getindex(I_PLAYER); { Rec of valid player log records }
freeindex; { False if a valid player log }
getuser; { Corresponding userids of players }
freeuser;
getpers; { Personal names of players }
freepers;
getdate; { date of last play }
freedate;
if privd then begin
getint(N_LOCATION);
freeint;
where_they_are := anint;
getnam;
freenam;
end;
getint(N_SELF);
freeint;
writeln;
writeln('Userid Personal Name Last Play');
for i := 1 to maxplayers do begin
if not(indx.free[i]) then begin
write(user.idents[i]);
for j := length(user.idents[i]) to 15 do
write(' ');
write(pers.idents[i]);
for j := length(pers.idents[i]) to 21 do
write(' ');
if tmpasleep.free[i] then begin
write(adate.idents[i]);
if length(adate.idents[i]) < 19 then
for j := length(adate.idents[i]) to 18 do
write(' ');
end else
write(' -playing now- ');
if (anint.int[i] <> 0) and (anint.int[i] <> DEFAULT_LINE) then
write(' * ')
else
write(' ');
if privd then begin
write(nam.idents[ where_they_are.int[i] ]);
end;
writeln;
end;
end;
writeln;
end;
procedure do_self(s: string);
var
n: integer;
begin
if length(s) = 0 then begin
log_action(c_self,0);
writeln('[ Editing your self description ]');
if edit_desc(myself) then begin
getroom;
here.people[myslot].self := myself;
putroom;
getint(N_SELF);
anint.int[mylog] := myself;
putint;
log_event(myslot,E_SELFDONE,0,0);
end;
end else if lookup_pers(n,s) then begin
getint(N_SELF);
freeint;
if (anint.int[n] = 0) or (anint.int[n] = DEFAULT_LINE) then
writeln('That person has not made a self-description.')
else begin
print_desc(anint.int[n]);
log_event(myslot,E_VIEWSELF,0,0,pers.idents[n]);
end;
end else
writeln('There is no person by that name.');
end;
procedure do_health(s: string);
begin
write('You ');
case myhealth of
9: writeln('are in exceptional health.');
8: writeln('are in better than average condition.');
7: writeln('are in perfect health.');
6: writeln('feel a little bit dazed.');
5: writeln('have some minor cuts and abrasions.');
4: writeln('have some wounds, but are still fairly strong.');
3: writeln('are suffering from some serious wounds.');
2: writeln('are very badly wounded.');
1: writeln('have many serious wounds, and are near death.');
0: writeln('are dead.');
otherwise writeln('don''t seem to be in any condition at all.');
end;
end;
procedure crystal_look(chill_msg: integer);
var
numobj,numppl,numsee: integer;
i: integer;
yes: boolean;
begin
writeln;
print_desc(here.primary);
log_event(0,E_CHILL,chill_msg,0,'',here.locnum);
numppl := find_numpeople;
numsee := n_can_see + 1;
if numppl > numsee then
writeln('Someone is hiding here.')
else if numppl = 0 then begin
writeln('Strange, empty shadows swirl before your eyes.');
end;
if rnd100 > 50 then
people_header('at this place.')
else case numppl of
0: writeln('Vague empty forms drift through your view.');
1: writeln('You can make out a shadowy figure here.');
2: writeln('There are two dark figures here.');
3: writeln('You can see the silhouettes of three people.');
otherwise
writeln('Many dark figures can be seen here.');
end;
numobj := find_numobjs;
if rnd100 > 50 then begin
if rnd100 > 50 then
show_objects
else if numobj > 0 then
writeln('Some objects are here.')
else
writeln('There are no objects here.');
end else begin
yes := false;
for i := 1 to maxobjs do
if here.objhide[i] <> 0 then
yes := true;
if yes then
writeln('Something is hidden here.');
end;
writeln;
end;
procedure use_crystal(objnum: integer);
var
done: boolean;
s: string;
n: integer;
done_msg,chill_msg: integer;
tmp: string;
i: integer;
begin
if obj_hold(objnum) then begin
log_action(e_usecrystal,0);
getobj(objnum);
freeobj;
done_msg := obj.d1;
chill_msg := obj.d2;
grab_line('',s);
if lookup_room(n,s) then begin
gethere(n);
crystal_look(chill_msg);
done := false;
end else
done := true;
while not(done) do begin
grab_line('',s);
if lookup_dir(n,s) then begin
if here.exits[n].toloc > 0 then begin
gethere(here.exits[n].toloc);
crystal_look(chill_msg);
end;
end else begin
s := lowcase(s);
tmp := bite(s);
if tmp = 'poof' then begin
if lookup_room(n,s) then begin
gethere(n);
crystal_look(chill_msg);
end else
done := true;
end else if tmp = 'say' then begin
i := (rnd100 mod 4) + 1;
log_event(0,E_NOISE2,i,0,'',n);
end else
done := true;
end;
end;
gethere;
log_event(myslot,E_DONECRYSTALUSE,0,0);
print_desc(done_msg);
end else
writeln('You must be holding it first.');
end;
procedure p_usefail(n: integer);
begin
{ we assume getobj has already been done }
if (obj.usefail = 0) or (obj.usefail = DEFAULT_LINE) then
writeln('It doesn''t work for some reason.')
else
print_desc(obj.usefail);
end;
procedure p_usesucc(n: integer);
begin
{ we assume getobj has already been done }
if (obj.usesuccess = 0) or (obj.usesuccess = DEFAULT_LINE) then
writeln('It seems to work, but nothing appears to happen.')
else
print_desc(obj.usesuccess);
end;
procedure do_use(s: string);
var
n: integer;
begin
if length(s) = 0 then
writeln('To use an object, type USE <object name>')
else if parse_obj(n,s) then begin
getobj(n);
freeobj;
if (obj.useobjreq > 0) and not(obj_hold(obj.useobjreq)) then begin
log_event(myslot,E_FAILUSE,n,0);
p_usefail(n);
end else if (obj.uselocreq > 0) and (location <> obj.uselocreq) then begin
log_event(myslot,E_FAILUSE,n,0);
p_usefail(n);
end else begin
p_usesucc(n);
case obj.kind of
O_BLAND:;
O_CRYSTAL: use_crystal(n);
otherwise ;
end;
end;
end else
writeln('There is no such object here.');
end;
procedure do_whisper(s: string);
var
n: integer;
begin
if length(s) = 0 then begin
writeln('To whisper to someone, type WHISPER <personal name>.');
end else if parse_pers(n,s) then begin
if n = myslot then
writeln('You can''t whisper to yourself.')
else begin
grab_line('>> ',s);
if length(s) > 0 then begin
nice_say(s);
log_event(myslot,E_WHISPER,n,0,s);
end else
writeln('Nothing whispered.');
end;
end else
writeln('No such person can be seen here.');
end;
procedure do_wield(s: string);
var
tmp: string;
slot,n: integer;
begin
if length(s) = 0 then begin { no parms means unwield }
if mywield = 0 then
writeln('You are not wielding anything.')
else begin
getobj(mywield);
freeobj;
tmp := obj.oname;
log_event(myslot,E_UNWIELD,0,0,tmp);
writeln('You are no longer wielding the ',tmp,'.');
mywield := 0;
getroom;
here.people[mylog].wielding := 0;
putroom;
end;
end else if parse_obj(n,s) then begin
if mywield <> 0 then begin
writeln('You are already wielding ',obj_part(mywield),'.');
end else begin
getobj(n);
freeobj;
tmp := obj.oname;
if obj.kind = O_WEAPON then begin
if obj_hold(n) then begin
mywield := n;
getroom;
here.people[myslot].wielding := n;
putroom;
log_event(myslot,E_WIELD,0,0,tmp);
writeln('You are now wielding the ',tmp,'.');
end else
writeln('You must be holding it first.');
end else
writeln('That is not a weapon.');
end;
end else
writeln('No such weapon can be seen here.');
end;
procedure do_wear(s: string);
var
tmp: string;
slot,n: integer;
begin
if length(s) = 0 then begin { no parms means unwield }
if mywear = 0 then
writeln('You are not wearing anything.')
else begin
getobj(mywear);
freeobj;
tmp := obj.oname;
log_event(myslot,E_UNWEAR,0,0,tmp);
writeln('You are no longer wearing the ',tmp,'.');
mywear := 0;
getroom;
here.people[mylog].wearing := 0;
putroom;
end;
end else if parse_obj(n,s) then begin
getobj(n);
freeobj;
tmp := obj.oname;
if (obj.kind = O_ARMOR) or (obj.kind = O_CLOAK) then begin
if obj_hold(n) then begin
mywear := n;
getroom;
here.people[mylog].wearing := n;
putroom;
log_event(myslot,E_WEAR,0,0,tmp);
writeln('You are now wearing the ',tmp,'.');
end else
writeln('You must be holding it first.');
end else
writeln('That cannot be worn.');
end else
writeln('No such thing can be seen here.');
end;
procedure do_brief;
begin
brief := not(brief);
if brief then
writeln('Brief descriptions.')
else
writeln('Verbose descriptions.');
end;
function p_door_key(n: integer): string;
begin
if n = 0 then
p_door_key := '<none>'
else
p_door_key := objnam.idents[n];
end;
procedure anal_exit(dir: integer);
begin
if (here.exits[dir].toloc = 0) and (here.exits[dir].kind <> 5) then
{ no exit here, don't print anything }
else with here.exits[dir] do begin
write(direct[dir]);
if length(alias) > 0 then begin
write('(',alias);
if reqalias then
write(' required): ')
else
write('): ');
end else
write(': ');
if (toloc = 0) and (kind = 5) then
write('accept, no exit yet')
else if toloc > 0 then begin
write('to ',nam.idents[toloc],', ');
case kind of
0: write('no exit');
1: write('open passage');
2: write('door, key=',p_door_key(objreq));
3: write('~door, ~key=',p_door_key(objreq));
4: write('exit open randomly');
5: write('potential exit');
6: write('xdoor, key=',p_door_key(objreq));
7: begin
write('timed exit, now ');
if cycle_open then
write('open')
else
write('closed');
end;
end;
if hidden <> 0 then
write(', hidden');
if reqverb then
write(', reqverb');
if not(autolook) then
write(', autolook off');
if here.trapto = dir then
write(', trapdoor (',here.trapchance:1,'%)');
end;
writeln;
end;
end;
procedure do_s_exits;
var
i: integer;
accept,one: boolean; { accept is true if the particular exit is
an "accept" (other players may link there)
one means at least one exit was shown }
begin
one := false;
gethere;
for i := 1 to maxexit do begin
if (here.exits[i].toloc = 0) and (here.exits[i].kind = 5) then
accept := true
else
accept := false;
if (can_alter(i)) or (accept) then begin
if not(one) then begin { first time we do this then }
getnam; { read room name list in }
freenam;
getobjnam;
freeobjnam;
end;
one := true;
anal_exit(i);
end;
end;
if not(one) then
writeln('There are no exits here which you may inspect.');
end;
procedure do_s_object(s: string);
var
n: integer;
x: objectrec;
begin
if length(s) = 0 then begin
grab_line('Object? ',s);
end;
if lookup_obj(n,s) then begin
if obj_owner(n,TRUE) then begin
write(obj_part(n),': ');
write(objown.idents[n],' is owner');
x := obj;
if x.sticky then
write(', sticky');
if x.getobjreq > 0 then
write(', ',obj_part(x.getobjreq),' required to get');
if x.useobjreq > 0 then
write(', ',obj_part(x.useobjreq),' required to use');
if x.uselocreq > 0 then begin
getnam;
freenam;
write(', used only in ',nam.idents[x.uselocreq]);
end;
if x.usealias <> '' then begin
write(', use="',x.usealias,'"');
if x.reqalias then
write(' (required)');
end;
writeln;
end else
writeln('You are not allowed to see the internals of that object.');
end else
writeln('There is no such object.');
end;
procedure do_s_details;
var
i: integer;
one: boolean;
begin
gethere;
one := false;
for i := 1 to maxdetail do
if (here.detail[i] <> '') and (here.detaildesc[i] <> 0) then begin
if not(one) then begin
one := true;
writeln('Details here that you may inspect:');
end;
writeln(' ',here.detail[i]);
end;
if not(one) then
writeln('There are no details of this room that you can inspect.');
end;
procedure do_s_help;
begin
writeln;
writeln('Exits Lists exits you can inspect here');
writeln('Object Show internals of an object');
writeln('Details Show details you can look at in this room');
writeln;
end;
procedure s_show(n: integer;s: string);
begin
case n of
s_exits: do_s_exits;
s_object: do_s_object(s);
s_quest: do_s_help;
s_details: do_s_details;
end;
end;
procedure do_y_altmsg;
var
newdsc: integer;
begin
if is_owner then begin
gethere;
newdsc := here.xmsg2;
writeln('[ Editing the alternate mystery message for this room ]');
if edit_desc(newdsc) then begin
getroom;
here.xmsg2 := newdsc;
putroom;
end;
end;
end;
procedure do_y_help;
begin
writeln;
writeln('Altmsg Set the alternate mystery message block');
writeln;
end;
procedure do_group1;
var
grpnam: string;
loc: integer;
tmp: string;
begin
if is_owner then begin
gethere;
if here.grploc1 = 0 then
writeln('No primary group location set')
else begin
getnam;
freenam;
writeln('The primary group location is ',nam.idents[here.grploc1],'.');
writeln('Descriptor string: [',here.grpnam1,']');
end;
writeln;
writeln('Type * to turn off the primary group location');
grab_line('Room name of primary group? ',grpnam);
if length(grpnam) = 0 then
writeln('No changes.')
else if grpnam = '*' then begin
getroom;
here.grploc1 := 0;
putroom;
end else if lookup_room(loc,grpnam) then begin
writeln('Enter the descriptive string. It will be placed after player names.');
writeln('Example: Monster Manager is [descriptive string, instead of "here."]');
writeln;
grab_line('Enter string? ',tmp);
if length(tmp) > shortlen then begin
writeln('Your string was truncated to ',shortlen:1,' characters.');
tmp := substr(tmp,1,shortlen);
end;
getroom;
here.grploc1 := loc;
here.grpnam1 := tmp;
putroom;
end else
writeln('No such room.');
end;
end;
procedure do_group2;
var
grpnam: string;
loc: integer;
tmp: string;
begin
if is_owner then begin
gethere;
if here.grploc2 = 0 then
writeln('No secondary group location set')
else begin
getnam;
freenam;
writeln('The secondary group location is ',nam.idents[here.grploc1],'.');
writeln('Descriptor string: [',here.grpnam1,']');
end;
writeln;
writeln('Type * to turn off the secondary group location');
grab_line('Room name of secondary group? ',grpnam);
if length(grpnam) = 0 then
writeln('No changes.')
else if grpnam = '*' then begin
getroom;
here.grploc2 := 0;
putroom;
end else if lookup_room(loc,grpnam) then begin
writeln('Enter the descriptive string. It will be placed after player names.');
writeln('Example: Monster Manager is [descriptive string, instead of "here."]');
writeln;
grab_line('Enter string? ',tmp);
if length(tmp) > shortlen then begin
writeln('Your string was truncated to ',shortlen:1,' characters.');
tmp := substr(tmp,1,shortlen);
end;
getroom;
here.grploc2 := loc;
here.grpnam2 := tmp;
putroom;
end else
writeln('No such room.');
end;
end;
procedure s_set(n: integer;s: string);
begin
case n of
y_quest: do_y_help;
y_altmsg: do_y_altmsg;
y_group1: do_group1;
y_group2: do_group2;
end;
end;
procedure do_show(s: string);
var
n: integer;
cmd: string;
begin
cmd := bite(s);
if length(cmd) = 0 then
grab_line('Show what attribute? (type ? for a list) ',cmd);
if length(cmd) = 0 then
else if lookup_show(n,cmd) then
s_show(n,s)
else
writeln('Invalid show option, type SHOW ? for a list.');
end;
procedure do_set(s: string);
var
n: integer;
cmd: string;
begin
cmd := bite(s);
if length(cmd) = 0 then
grab_line('Set what attribute? (type ? for a list) ',cmd);
if length(cmd) = 0 then
else if lookup_set(n,cmd) then
s_set(n,s)
else
writeln('Invalid set option, type SET ? for a list.');
end;
procedure parser;
var
s: string;
cmd: string;
n: integer;
dummybool: boolean;
begin
repeat
grab_line('> ',s);
s := slead(s);
until length(s) > 0;
if s = '.' then
s := oldcmd
else
oldcmd := s;
if (s[1]='''') and (length(s) > 1) then
do_say(substr(s,2,length(s)-1))
else begin
cmd := bite(s);
case lookup_cmd(cmd) of
{ try exit alias } error:begin
if (lookup_alias(n,cmd)) or
(lookup_dir(n,cmd)) then begin
do_go(cmd);
end else
writeln('Bad command, type ? for a list.');
end;
setnam: do_setname(s);
help,quest: show_help;
quit: done := true;
c_l,look: do_look(s);
go: do_go(s,FALSE); { FALSE = dir not a verb }
form: do_form(s);
link: do_link(s);
unlink: do_unlink(s);
poof: do_poof(s);
desc: do_describe(s);
say: do_say(s);
c_rooms: do_rooms(s);
c_claim: do_claim(s);
c_disown: do_disown(s);
c_public: do_public(s);
c_accept: do_accept(s);
c_refuse: do_refuse(s);
c_zap: do_zap(s);
c_north,c_n,
c_south,c_s,
c_east,c_e,
c_west,c_w,
c_up,c_u,
c_down,c_d: do_go(cmd);
c_who: do_who;
c_custom: do_custom(s);
c_search: do_search(s);
c_system: do_system(s);
c_hide: do_hide(s);
c_unhide: do_unhide(s);
c_punch: do_punch(s);
c_ping: do_ping(s);
c_create: do_makeobj(s);
c_get: do_get(s);
c_drop: do_drop(s);
c_i,c_inv: do_inv(s);
c_whois: do_whois(s);
c_players: do_players(s);
c_health: do_health(s);
c_duplicate: do_duplicate(s);
c_version: do_version(s);
c_objects: do_objects;
c_self: do_self(s);
c_use: do_use(s);
c_whisper: do_whisper(s);
c_wield: do_wield(s);
c_brief: do_brief;
c_wear: do_wear(s);
c_destroy: do_destroy(s);
c_relink: do_relink(s);
c_unmake: do_unmake(s);
c_show: do_show(s);
c_set: do_set(s);
dbg: begin
debug := not(debug);
if debug then
writeln('Debugging is on.')
else
writeln('Debugging is off.');
end;
otherwise begin
writeln('%Parser error, bad return from lookup');
end;
end;
clear_command;
end;
end;
procedure init;
var
i: integer;
begin
rndcycle := 0;
location := 1; { Great Hall }
mywield := 0; { not initially wearing or weilding any weapon }
mywear := 0;
myhealth := 7; { how healthy they are to start }
healthcycle := 0; { pretty much meaningless at the start }
userid := lowcase(get_userid);
if (userid = MM_userid) then begin
myname := 'Monster Manager';
privd := true;
end else if (userid = MVM_userid) then begin
privd := true;
myname := 'Vice Manager';
end else if (userid = FAUST_userid) then begin
privd := true;
end else begin
myname := lowcase(userid);
myname[1] := chr( ord('A') + (ord(myname[1]) - ord('a')) );
privd := false;
end;
numcmds:= 66;
show[s_exits] := 'exits';
show[s_object] := 'object';
show[s_quest] := '?';
show[s_details] := 'details';
numshow := 4;
setkey[y_quest] := '?';
setkey[y_altmsg] := 'altmsg';
setkey[y_group1] := 'group1';
setkey[y_group2] := 'group2';
numset := 4;
numspells := 0;
open(roomfile,root+'ROOMS.MON',access_method := direct,
sharing := readwrite,
history := unknown);
open(namfile,root+'NAMS.MON',access_method := direct,
sharing := readwrite,
history := unknown);
open(eventfile,root+'EVENTS.MON',access_method := direct,
sharing := readwrite,
history := unknown);
open(descfile,root+'DESC.MON',access_method := direct,
sharing := readwrite,
history := unknown);
open(indexfile,root+'INDEX.MON',access_method := direct,
sharing := readwrite,
history := unknown);
open(linefile,root+'LINE.MON',access_method := direct,
sharing := readwrite,
history := unknown);
open(intfile,root+'INTFILE.MON',access_method := direct,
sharing := readwrite,
history := unknown);
open(objfile,root+'OBJECTS.MON',access_method := direct,
sharing := readwrite,
history := unknown);
open(spellfile,root+'SPELLS.MON',access_method := direct,
sharing := readwrite,
history := unknown);
end;
procedure prestart;
var
s: string;
begin
write('Welcome to Monster! Hit return to start: ');
readln(s);
writeln;
writeln;
if length(s) > 0 then
special(lowcase(s));
end;
procedure welcome_back(var mylog: integer);
var
tmp: string;
sdate,stime: shortstring;
begin
getdate;
freedate;
write('Welcome back, ',myname,'.');
if length(myname) > 18 then
writeln;
write(' Your last play was on');
if length(adate.idents[mylog]) < 11 then begin
writeln(' ???');
end else begin
sdate := substr(adate.idents[mylog],1,11); { extract the date }
if length(adate.idents[mylog]) = 19 then
stime := substr(adate.idents[mylog],13,7)
else
stime := '???';
if sdate[1] = ' ' then
tmp := sdate
else
tmp := ' ' + sdate;
if stime[1] = ' ' then
tmp := tmp + ' at' + stime
else
tmp := tmp + ' at ' + stime;
writeln(tmp,'.');
end;
writeln;
end;
function loc_ping:boolean;
var
i: integer;
found: boolean;
begin
inmem := false;
gethere;
i := 1;
found := false;
{ first get the slot that the supposed "zombie" is in }
while (not found) and (i <= maxpeople) do begin
if here.people[i].name = myname then
found := true
else
i := i + 1;
end;
myslot := 0; { setup for ping_player }
if found then begin
setevent;
loc_ping := ping_player(i,TRUE); { TRUE = silent operation }
end else
loc_ping := true;
{ well, if we can't find them, let's assume
that they're not in any room records, so they're
ok . . . Let's hope... }
end;
{ attempt to fix the player using loc_ping if the database incorrectly
shows someone playing who isn' playing }
function fix_player:boolean;
var
ok: boolean;
begin
writeln('There may have been some trouble the last time you played.');
writeln('Trying to fix it . . .');
if loc_ping then begin
writeln('All should be fixed now.');
writeln;
fix_player := true;
end else begin
writeln('Either someone else is playing Monster on your account, or something is');
writeln('very wrong with the database.');
writeln;
fix_player := false;
end;
end;
function revive_player(var mylog: integer): boolean;
var
ok: boolean;
i,n: integer;
begin
if exact_user(mylog,userid) then begin { player has played before }
getint(N_LOCATION);
freeint;
location := anint.int[mylog]; { Retrieve their old loc }
getpers;
freepers;
myname := pers.idents[mylog]; { Retrieve old personal name }
getint(N_EXPERIENCE);
freeint;
myexperience := anint.int[mylog];
getint(N_SELF);
freeint;
myself := anint.int[mylog];
getindex(I_ASLEEP);
freeindex;
if indx.free[mylog] then begin
{ if player is asleep, all is well }
ok := true;
end else begin
{ otherwise, there is one of two possibilities:
1) someone on the same account is
playing Monster
2) his last play terminated abnormally
}
ok := fix_player;
end;
if ok then
welcome_back(mylog);
end else begin { must allocate a log block for the player }
if alloc_log(mylog) then begin
writeln('Welcome to Monster, ',myname,'!');
writeln('You will start in the Great Hall.');
writeln;
{ Store their userid }
getuser;
user.idents[mylog] := lowcase(userid);
putuser;
{ Set their initial location }
getint(N_LOCATION);
anint.int[mylog] := 1; { Start out in Great Hall }
putint;
location := 1;
getint(N_EXPERIENCE);
anint.int[mylog] := 0;
putint;
myexperience := 0;
getint(N_SELF);
anint.int[mylog] := 0;
putint;
myself := 0;
{ initialize the record containing the
level of each spell they have to start;
all start at zero; since the spellfile is
directly parallel with mylog, we can hack
init it here without dealing with SYSTEM }
locate(spellfile,mylog);
for i := 1 to maxspells do
spellfile^.level[i] := 0;
spellfile^.recnum := mylog;
put(spellfile);
ok := true;
end else
ok := false;
end;
if ok then begin { Successful, MYLOG is my log slot }
{ Wake up the player }
getindex(I_ASLEEP);
indx.free[mylog] := false; { I'm NOT asleep now }
putindex;
{ Set the "last date of play" }
getdate;
adate.idents[mylog] := sysdate + ' ' + systime;
putdate;
end else
writeln('There is no place for you in Monster. Contact the Monster Manager.');
revive_player := ok;
end;
function enter_universe:boolean;
var
orignam: string;
dummy,i: integer;
ok: boolean;
begin
{ take MYNAME given to us by init or revive_player and make
sure it's unique. If it isn't tack _1, _2, etc onto it
until it is. Code must come before alloc_log, or there
will be an invalid pers record in there cause we aren't in yet
}
orignam := myname;
i := 0;
repeat { tack _n onto pers name until a unique one is found }
ok := true;
{*** Should this use exact_pers instead? Is this a copy of exact_pers code? }
if lookup_pers(dummy,myname) then
if lowcase(pers.idents[dummy]) = lowcase(myname) then begin
ok := false;
i := i + 1;
writev(myname,orignam,'_',i:1);
end;
until ok;
if revive_player(mylog) then begin
if put_token(location,myslot) then begin
getpers;
pers.idents[mylog] := myname;
putpers;
enter_universe := true;
log_begin(location);
setevent;
do_look;
end else begin
writeln('put_token failed.');
enter_universe := false;
end;
end else begin
writeln('revive_player failed.');
enter_universe := false;
end;
end;
procedure leave_universe;
var
diddrop: boolean;
begin
diddrop := drop_everything;
take_token(myslot,location);
log_quit(location,diddrop);
do_endplay(mylog);
writeln('You vanish in a brilliant burst of multicolored light.');
if diddrop then
writeln('All of your belongings drop to the ground.');
end;
begin
done := false;
setup_guts;
init;
prestart;
if not(done) then begin
if enter_universe then begin
repeat
parser;
until done;
leave_universe;
end else
writeln('You attempt to enter the Monster universe, but a strange force repels you.');
end;
finish_guts;
end.
{ Notes to other who may inherit this program:
Change all occurances in this file of dolpher to the account which
you will use for maintenance of this program. That account will
have special administrative powers.
This program uses several data files. These files are in a directory
specified by the variable root in procedure init. In my implementation,
I have a default ACL on the directory allowing everyone READ and WRITE
access to the files created in that directory. Whoever plays the game
must be able to write to these data files.
Written by Rich Skrenta, 1988.
Brief program organization overview:
------------------------------------
Monster's Shared Files:
Monster uses several shared files for communication.
Each shared file is accessed within Monster by a group of 3 procedures of the
form: getX(), freeX and putX.
getX takes an integer and attempts to get and lock that record from the
appropriate data file. If it encounters a "collision", it waits a short
random amount of time and tries again. After maxerr collisions it prints
a deadlock warning message.
If data is to be read but not changed, a freeX should immediately follow
the getX so that other Monster processes can access the record. If the
record is to be written then a putX must eventually follow the getX.
Monster's Record Allocation:
Monster dynamically allocates some resources such as description blocks and
lines and player log entries. The allocation is from a bitmap. I chose a
bitmap over a linked list to make the multiuser access to the database
more stable. A particular resource (such as log entries) will have a
particular bitmap in the file INDEXFILE. A getindex(I_LOG) will retrieve
the bitmap for it.
Actually allocation and deallocation is done through the group of functions
alloc_X and delete_X. If alloc_X returns true, the allocation was successful,
and the integer parameter is the number of the block allocated.
The top available record in each group is stored in indexrec. To increase
the top, the new records must be initially written so that garbage data is
not in them and the getX routines can locate them. This can be done with
the addX(n) group of routines, which add capacity to resources.
Parsing in Monster:
The main parser(s) use a first-unique-characters method to lookup command
keywords and parameters. The format of these functions is lookup_x(n,s).
If it returns true, it successfully found an unambiguous match to string s.
The integer index will be in n.
If an unambiguating match is needed (for example, if someone makes a new room,
the match to see if the name exists shouldn't disambiguate), the group of
routines exact_X(n,s) are called. They function similarly to lookup_x(n,s).
The customization subsystems and the editor use very primitive parsers
which only use first character match and integer arguments.
Asynchronous events in Monster:
When someone comes into a room, the other players in that room need
to be notified, even if they might be typing a command on their terminal.
This is done in a two part process (producer/consumer problem):
When an event takes place, the player's Monster that caused the event
makes a call to log_event. Parameters include the slot of the sender (which
person in the room caused the event), the actual event that occurred
(E_something) and parameters. Log_event works by sticking the event
into a circular buffer associated with the room (room may be specified on
log_event).
Note: there is not an event record for every room; instead, the event
record used is ROOM # mod ACTUAL NUMBER of EVENT RECORDS
The other half of the process occurrs when a player's Monster calls
grab_line to get some input. Grab line looks for keystrokes, and if
there are none, it calls checkevent and then sleeps for a short time
(.1 - .2 seconds). Checkevent loads the event record associated with this
room and compare's the player's buffer pointer with the record's buffer
pointer. If they are different, checkevent bites off events and sends them
to handle_event until there are no more events to be processed. Checkevent
ignores events logged by it's own player.
}