Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/games/volume5/monster/part03/mon2.pas

Pascal/Delphi Source File | 1988-11-30 | 55KB | 2,336 lines

{ 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;