mon.pas

{

	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.


}