
unit rgoods;
{$N+,E+}
{$O+,F+}
interface
uses dos;

{$I rn-struc.pas}

const crlf:string[2]=#13+#10;
      version:string[5]='5.01 '; {This MUST be 5 chars for cosmetic reasons!}
      ver_num:word=501;
      game_ident:longint=$FBEAD9C8;
      ufname= 'RANCHO.USR';
      mazname='RANCHO.MAZ';
      mkrname='RANCHO.MKR';
      msgname='RANCHO.MSG';
      evtname='RANCHO.EVT';
      roomname='RANCHO.ROO';
      yes=true;
      no=false;
      maxspell:byte=16;
      hasvkrkey:boolean=false;

type {roomptr=^roomrec;
     nameptr=^namestr;}
     rooms=array[1..800] of roomrec;
     _ultype=array[1..256] of userrec;
     ultype=^_ultype;

var user        : userrec;
    UF          : File;
    userlog     : ultype;
    maxuser     : integer;
    youwon      : boolean;
    asleep      : integer;
    thisusernumber:word;
    editmode    : boolean;
    nocr        : boolean;
    TmpUser     : UserRec;
    User2       : userrec;
    I,J,K,L,M,U : LongInt;
    ITmp        : Integer;
    STmp        : String[80];    {Temporary string}
    ctmp        : Char;          {Temporary Char}
    LTmp        : LongInt;       {Temporary LongInt}
    BTmp        : Boolean;       {Temporary Boolean}
    itemswaptemp: longint;
    fsiz        : word;
    index       : word;
    cmdparm     : string[16];
    lockbaud    : boolean;
    opensuccess : boolean;
    tempb       : boolean;
    RecFile     : File;
    config      : configrec;
    configfile  : file of configrec;
    verbbump    : boolean;
    TF          : Text;          {Filename for plain files}
    AnsiF       : Text;          {Used for ANSI files...}
    champion    : namestr;
    spellpriv   : array[1..24] of boolean;
    yndefault   : boolean;
    send2robot:boolean;
    room:^rooms;
    maxweapon, maxarmor:word;
    hasattacked:array[1..256] of boolean;

    mazefile:file of roomrec;
    temproom:roomrec;
    doortype:byte;
    exitsave:pointer;

    tempevent:eventrec;
    eventfile:file of eventrec;

    statname:string[12];
    using16:boolean;
    cret:char;
    userfiledate:longint;
    whoroomdate:longint;
    useronname:string[12];

    controlstring:string;
    controlcode:string[32];
    controlparm:comp;

    safelog:boolean;

    datein:longint;
    ignorecheck:boolean;

    keyloc:array[1..4] of integer;
    usingmachine:boolean; {For buying condoms: are we using a machine?}

type _uonelement=record
                   online: boolean;
                   room  : word;
                   expansion:byte;
                   time  : longint;
                 end;

    _uonarray=array[1..256] of _uonelement;
var uon:_uonarray;

procedure ufsafe;
procedure nukefile(f:string);
function  nextlevelxp(level:longint):extended;
Procedure ReadUser(X:integer);
Procedure WriteUser(X:string; var tempuser:userrec);
procedure updatesbar;
procedure takedownsbar;
procedure makesbar;
procedure titlebar;
Procedure sysopkey;
Procedure Get(X:String);
Procedure Getany;
Function  GetLn(X:Byte):String;
Function  GetLnZ(X:Byte):String;
procedure anykey;
function  i2sc(x:longint):string;
function  c2sc(x:extended):string;
function  c2sa(x:extended):string;
function  c2s(x:extended):string;
function  mixedcase(temp1:string):string;
Function  FindUser(Name:namestr):Boolean;
Function  FindUser2(Name:namestr):Boolean;
procedure ansi3dn(s:string);
procedure ansi3d(s:string);
function  yn:char;
function  fsize(fnm:string):longint;
function  bigrnd(maximum:longint):longint;
function  hugernd(maximum:extended):extended;
function  countline(x:string):integer;
function  lastline(x:string):string;
function  grabline(x:integer; y:string):string;
function  raisepower(x,power:extended):extended;
procedure randsendtext(name:String);
Procedure SendText(Name:String);
procedure process_imbedded(tch1:char);
function  getgen(gender:t_gender; x:byte):string;
procedure newsbar;
procedure log(s:string);
function  synthname(sex:t_gender):string;
procedure shutdown; 
procedure writeuserlog;
procedure readuserlog;
procedure chrpadr(var s:string; c:char; x:byte);
Procedure Tab(X:integer; S:Char);
function  spellname(n:byte):string;
function  getamode(x:integer):string;
function  margin(att,def,mar:longint):boolean;
procedure addevent(evt:eventrec);
function  badbutter(u1,u2:userrec):boolean;
function  goodroom(roomno:word):boolean;
function  isnum(c:char):boolean;
function  userlogsize:integer;
procedure checkuserfile;
(*procedure writewhoroom;
procedure checkwhoroom; *)
procedure listwhoson;
function checkwhoson:boolean; {Returns true if something happened}
procedure updatewhoson;
function  whichway(myroom,thatroom:integer):string;
procedure sayit;
procedure saywent(smcode:integer); {90=N 91=S 92=E 93=W 94=U 95=D} {per sysmsgs}
procedure saycame;
procedure saywhoosh;
procedure global_oneannounce(s:String); {Sends a string to everyone in the game}
procedure oneannounce(s:String);
function  lookupuser(s:String):integer;
procedure control(i:integer; s:String); {Sends a string to user i}
function  checkcontrol:boolean;
function  isinvkr(i:integer):boolean;
function  randzap:integer;
function strip_embed(s:string):string;

implementation

uses crt,bbskv,bbskern,engine2,usered,toyinfo,winner,miscpl5,
     sys_msg,cheaplok,nanocore,nanostr,readonce,gelin,iconfig,
     encores;

function spellname(n:byte):string;
var tmp:string[40];
begin
  tmp:='';
  if (n<1) or (n>maxspell) then begin spellname:=tmp; exit; end;
  case n of
    1: tmp:=g_sysmsg(721);
    2: tmp:=g_sysmsg(722);
    3: tmp:=g_sysmsg(723);
    4: tmp:=g_sysmsg(724);
    5: tmp:=g_sysmsg(725);
    6: tmp:=g_sysmsg(726);
    7: tmp:=g_sysmsg(727);
    8: tmp:=g_sysmsg(728);
    9: tmp:=g_sysmsg(729);
   10: tmp:=g_sysmsg(730);
   11: tmp:=g_sysmsg(731);
   12: tmp:=g_sysmsg(732);
   13: tmp:=g_sysmsg(733);
   14: tmp:=g_sysmsg(734);
   15: tmp:=g_sysmsg(735);
   16: tmp:=g_sysmsg(736);
  end;
  spellname:=tmp;
end;

Procedure Tab(X:integer; S:Char);
{Move cursor over X spaces using S as 'filler'}
begin
  while not(lostcarrier or (wherex>=x)) do
    begin
      com_tx(s);
      write(s);
    end;
  if lostcarrier then nocarrier;
end;

procedure chrpadr(var s:string; c:char; x:byte);
var tmp:string[128];
    index:byte;
begin
  fillchar(tmp,sizeof(tmp),c);
  s:=s+tmp;
  s:=copy(s,1,x);
end;

function userlogsize:integer;
var uf:file of userrec;
begin
  if not(exist(ufname)) then begin userlogsize:=0; exit; end;
  assign(uf,ufname);
  reset(uf);
  userlogsize:=filesize(uf);
  close(uf);
end;

procedure readuserlog;
var index:integer;
    tu:userrec;
    numread:integer;
begin
  index:=1;
  maxuser:=0;
  ufsafe;
  if not(exist(ufname)) then exit;
  if not waitlock(ufname) then unlock(ufname);
  lock(ufname);
  assign(uf,ufname);
  reset(uf,sizeof(user));
  getftime(uf,userfiledate);
  blockread(uf,userlog^,256,numread);
  maxuser:=numread;
  close(uf);
  unlock(ufname);
end;

procedure rereaduserlog;
var index:integer;
    tu:userrec;
    numread:integer;
begin
  index:=1;
  maxuser:=0;
  ufsafe;
  if not(exist(ufname)) then exit;
  if not waitlock(ufname) then unlock(ufname);
  lock(ufname);
  assign(uf,ufname);
  reset(uf,sizeof(user));
  getftime(uf,userfiledate);
  blockread(uf,userlog^,256,numread);
  close(uf);
  unlock(ufname);
  maxuser:=numread;
  for index:=1 to 256 do
    if
      upcasestr(userlog^[index].bbsname)=upcasestr(user.name)
    then
      begin
        userlog^[index]:=user;
        exit;
      end;
end;

procedure writeuserlog;
var index:integer;
    numwritten:integer;
    retries:integer;
    crap:integer;
label retry,donetry;
begin
  checkuserfile;
  if not waitlock(ufname) then unlock(ufname);
  lock(ufname);
  if desqview then timeslice else delay(100);
  if maxuser=0 then begin nukefile (ufname); exit; end;
  index:=1;
{$I-}
  retries:=0;
  assign(uf,ufname);
retry:
  if retries>1 then begin if desqview then timeslice else delay(100); end;
  if retries>100 then goto donetry;
  inc(retries);
  rewrite(uf,sizeof(user)); crap:=ioresult; if crap<>0 then goto retry;
  blockwrite(uf,userlog^,maxuser,numwritten); crap:=ioresult; if crap<>0 then goto retry;
donetry:
  close(uf); crap:=ioresult;
{$I+}
  unlock(ufname);
end;

procedure shutdown;
begin
  if (not editmode) and not(youwon) then WriteUser(User.name,user);
  writeuserlog;
  textattr:=lightgray; WIndow(1,1,80,4); clrscr;
  Window(1,24,80,25); ClrScr; Window(1,1,80,25); GotoXY(1,24);
  halt;
end;

function synthname(sex:t_gender):string;
const fn1='BOYSNAME.LST';
      fn2='GIRLNAME.LST';
      fn3='LASTNAME.LST';
var f:text;
    build:string[36];
    index,crap:word;
    i:integer;
label retry;
begin
  if
    sex=male
  then
    assign(f,fn1)
  else
    assign(f,fn2);
retry:
  reset(f);
  if sex=male then crap:=random(658)+1 else crap:=random(702)+1;
  for index:=1 to crap do if not (eof(f)) then readln(f,stmp);
  close(f);
  if
    config.robotlastname=1
  then
    begin
      if pos('.',stmp)<>0 then goto retry;
      for i:=1 to maxuser do if upcasestr(stmp)=upcasestr(userlog^[i].name) then goto retry;
      synthname:=stmp;
      exit;
    end;
  build:=stmp+' ';
  assign(f,fn3);
  reset(f);
  crap:=random(1220)+1;
  for index:=1 to crap do if not (eof(f)) then readln(f,stmp);
  close(f);
  stmp:=build+stmp;
  for i:=1 to maxuser do if upcasestr(stmp)=upcasestr(userlog^[i].name) then goto retry;
  synthname:=stmp;
end;

procedure nukefile(f:string);
var x:file;
    crap:integer;
    retries:integer;
label _ret;
begin
  retries:=0;
  if
    exist(f)
  then
    begin
{$I-}
      assign(x,f);
_ret:
      erase(x); crap:=ioresult;
      if (crap<>0) and (retries<100) then begin delay(25); inc(retries); goto _ret; end;
{$I+}
    end
end;

function getgen(gender:t_gender; x:byte):string;
var tstr:string[6];
begin
  tstr:='void';
  if
    gender=male
  then
    tstr:=g_sysmsg(59+x)
  else
    tstr:=g_sysmsg(69+x);
  getgen:=tstr;
end;


procedure process_imbedded(tch1:char);
begin
  case tch1 of
    'W' : send(champion);
    'X' : send(int2str(user.level));
    'Y' : send('`L'+user2.name+'`G');
    'Z' : anykey;
  else
    send(#96+tch1);
  end;
end;

procedure randsendtext(name:String);
var dirinfo:searchrec;
    randarray:array[1..32] of string[13];
    i,maxfound:integer;
begin
  maxfound:=0;
  findfirst(name,archive,dirinfo);
  while (doserror=0) and (maxfound<32) do
    begin
      inc(maxfound);
      randarray[maxfound]:=dirinfo.name;
      findnext(dirinfo);
    end;
  if maxfound=0 then exit;
  i:=random(maxfound)+1;
  sendtext(randarray[i]);
end;

Procedure SendText(Name:String);
{Send text file to screen & modem, using Ansi if available}
var lines:longint;
begin
  if quitnow then exit;
  yndefault:=yes;
  lines:=0;
  if lostcarrier then begin nocarrier; exit; end;
  if
    Not(Exist(Name))
  then
    begin
      if directmode then sendln('No Results.') else Sendln('Unable to open :'+Name);
      Exit;
    End;
  Assign(TF,Name);
  Reset(TF);
  Repeat
    if lostcarrier then begin nocarrier; close(tf); exit; end;
    Read(TF,ctmp);
    if lostcarrier then begin nocarrier; close(tf); exit; end;
    CASE ctmp OF
      esc: process_ansi(tf);
      '~',
      '',
      #96: begin
             read(tf,ctmp);
             if
               (ctmp in ['w'..'z']) or (ctmp in ['W'..'Z'])
             then
               process_imbedded(ctmp)
             else
               changecolour(ctmp);
           end;
      #7,
      #10: begin
             nothing;
             if lostcarrier then begin nocarrier; close(tf); exit; end;
             write(ctmp);
             if not consoleonly then com_tx(ctmp);
             if lostcarrier then begin nocarrier; close(tf); exit; end;
             inc(lines);
             if (lines mod 20)=0 then if not(more) then begin close(tf); exit; end;
           end;
    ELSE
      begin
        if lostcarrier then begin nocarrier; close(tf); end;
        if not (noecho or directmode) then write(ctmp);
        if not consoleonly then com_tx(ctmp);
        if lostcarrier then begin nocarrier; close(tf); end;
      end;
    END; {case}
  Until (EOF(TF)) or quitnow or lostcarrier;
  Close(TF);
  NoEcho := False;
  if lostcarrier then begin nocarrier; exit; end;
end;

procedure ansi3dn(s:string);
begin
  if lostcarrier then nocarrier;
  send('`('+s+'`)');
  if lostcarrier then begin nocarrier; exit; end;
end;

procedure ansi3d(s:string);
begin
  ansi3dn(s);
  sendln('');
end;

procedure ufsafe;
var uf:file of userrec;
begin
  if not waitlock(ufname) then unlock(ufname);
  if not(exist(ufname)) then exit;
  if fsize(ufname)=0 then nukefile(ufname);
end;

Procedure ReadUser(X:integer);
{Read TmpUser from record X in RANCHO.USR}
begin
  tmpuser:=userlog^[x+1];
end;

Function FindUser(Name:namestr):Boolean;
var fsiz:word;
    tmpname:namestr;
begin
name:=upcasestr(name);
u:=0;
  if
    maxuser=0
  then
    Begin
      finduser:=false;
      Exit;
    End;
  repeat
    tmpname:=userlog^[u+1].bbsname;
    tmpname:=upcasestr(tmpname);
    if not(tmpname=name) then inc(u);
  until (tmpname=name) or (u>maxuser) or lostcarrier;
  if not(tmpname=name) then finduser:=false else finduser:=true;
end;

Function FindUser2(Name:namestr):Boolean;
{Find User "GameName" and return with 'User' = his data & 'I' his #}
var fsiz:word;
    tmpname:namestr;
begin
ufsafe;
u:=0;
  if
    maxuser=0
  then
    Begin
      finduser2:=false;
      Exit;
    End;
  repeat
    tmpname:=userlog^[u+1].name;
    tmpname:=upcasestr(tmpname);
    if not(tmpname=name) then inc(u);
  until (tmpname=name) or (u>maxuser) or lostcarrier;
  if not(tmpname=name) then finduser2:=false else finduser2:=true;
end;

Procedure WriteUser(X:string; var tempuser:userrec);
var z:word;
    founduser:boolean;
    whereto:integer;
begin
  tempuser.version:=ver_num;
  z:=1;
  founduser:=false;
  if
    maxuser=0
  then
    begin {There were no users previously; this must be the first!}
      maxuser:=1;
      userlog^[1]:=tempuser;
      exit;
    end;
  if
    maxuser>0
  then
    repeat
      founduser:=(upcasestr(tempuser.bbsname)=upcasestr(userlog^[z].bbsname));
      if
        founduser
      then
        userlog^[z]:=tempuser
      else
        inc(z);
    until (z>maxuser) or founduser or lostcarrier;
  if
    (not founduser)
  then
    begin
      whereto:=firstfree;
      if (whereto=-1) then begin inc(maxuser); whereto:=maxuser; end;
      userlog^[whereto]:=tempuser;
    end;
end;

function mixedcase(temp1:string):string;
var position,index:integer;
    tch:char;
begin   {Return string in mixed case}
  for index:=1 to length(temp1) do
    if
      (temp1[index] >='A')
    and
      (temp1[index] <='Z')
    then
      temp1[index]:=chr(ord(temp1[index])+32);
  temp1[1]:=upcase(temp1[1]);
  for index:=2 to length(temp1) do
    begin
      tch:=temp1[index-1];
      if
        tch=' '
      then
        temp1[index]:=upcase(temp1[index]);
    end;
  for i:=1 to length(temp1) do if i<length(temp1) then if temp1[i]=#96 then temp1[i+1]:=upcase(temp1[i+1]);
  mixedcase:=temp1;
end;

procedure updatesbar;
var tx,ty,tattr:byte;
    tstr:string[80] absolute stmp;
begin
  if not(usesuperbar) then exit;
  tx:=wherex;
  ty:=wherey;
  tattr:=textattr;
  window(1,1,80,4);
  textattr:=white+(16*blue);
  if (not(localansi)) then textattr:=black+(16*lightgray);
  clrscr;
  gotoxy(72,1); write('St:'+int2str(user.stamina));
  gotoxy(72,2); write('Sk:'+int2str(user.skill));
  gotoxy(72,3); write('Kn:'+int2str(user.knowledge));
  gotoxy(72,4); write('Ta:'+int2str(user.talent));
  gotoxy(63,1); write('DW:'+int2str(user.jwins));
  gotoxy(63,2); write('DL:'+int2str(user.jlosses));
  gotoxy(63,3); write('DT:'+int2str(user.jwins+user.skill+user.stamina-user.jlosses));
  gotoxy(3,2); write('Cm:'+int2str(user.condoms));
  gotoxy(11,2); write('Co:'+int2str(user.coord));
  gotoxy(20,2); write('MCo:'+int2str(user.maxcoord));
  tstr:=int2str(user.weapon)+' '+weaponname(user.weapon);
  tstr:='ST:#'+tstr;
  tstr:=copy(tstr,1,27);
  gotoxy(1,4); w(tstr);
  textattr:=white+(16*blue);
  tstr:=int2str(user.armor)+' '+armorname(user.armor);
  tstr:='DI:#'+tstr;
  tstr:=copy(tstr,1,27);
  gotoxy(29,4); w(tstr);
  textattr:=white+(16*blue);
  gotoxy(57,4); write('Emp:'); if user.robot then write('Yes ') else write('No ');
  gotoxy(65,4); write('Rcv:'); if user.recovering then write('Yes ') else write('No ');
  gotoxy(45,1); write('Xp:'+c2sa(user.xp));
  gotoxy(45,2); write('Lv:'+int2str(user.level));
  gotoxy(52,2); write('Rm:'+int2str(user.room));
  gotoxy(34,3); write(' PT:'+int2str(user.playstoday));
  gotoxy(42,3); write('LR:'+int2str(user.hp));
  gotoxy(52,3); write('MLR:'+int2str(user.maxhp));
  gotoxy(1,1); textattr:=white; write('                         ');
  gotoxy(1,1); w(copy(user.name,1,25));
  textattr:=white+(16*blue);
  tstr:='Ca$'+c2sa(user.gp);
  tstr:=copy(tstr,1,13);
  gotoxy(32,1); write(tstr);
  tstr:='Bk$'+c2sa(user.bankgp);
  tstr:=copy(tstr,1,13);
  gotoxy(32,2); write(tstr);
  tstr:=convertdate((user.lastplayed),2)+'/'
       +convertdate((user.lastplayed),3)+'/'
       +convertdate((user.lastplayed),7)+' ';
  gotoxy(1,3);
  write('  LP:'+tstr);
  gotoxy(19,3);
  case user.orientation of
    straight:write('St. ');
    bi:write('Bi  ');
    gay:write('Gay ');
  end;
  if user.gender=female then write('Female') else write('Male');
  window(1,5,80,24);
  gotoxy(tx,ty);
  textattr:=tattr;
end;

procedure takedownsbar;
var x,y,z:byte;
begin
  x:=wherex; y:=wherey; z:=textattr;
  window(1,1,80,4);
  textattr:=black;
  clrscr;
  window(1,1,80,24);
  textattr:=z; gotoxy(x,y+4);
end;

procedure newsbar;
var x,y,z:byte;
begin
  if not(usesuperbar) then exit;
  x:=wherex; y:=wherey; z:=textattr;
  window(1,1,80,4);
  textattr:=white+(16*blue);
  if (not(localansi)) then textattr:=black+(16*lightgray);
  clrscr;
  window(1,5,80,24);
  gotoxy(x,y);
  textattr:=z;
  updatesbar;
end;

procedure makesbar;
var tx,ty,tattr:byte;
begin
  tx:=wherex;
  ty:=wherey;
  tattr:=textattr;
  window(1,1,80,4);
  textattr:=white+(16*blue);
  if (not(localansi)) then textattr:=black+(16*lightgray);
  clrscr;
  window(1,5,80,24);
  gotoxy(tx,ty-4);
  textattr:=tattr;
  updatesbar;
end;

procedure titlebar;
var x,y,z:byte;
s:string[16];
begin
  x:=wherex;
  y:=wherey;
  z:=textattr;
  window(1,25,80,25);
  textattr:=white+(16*blue);
  if (not(localansi)) then textattr:=black+(16*lightgray);
  clrscr;
  clreol;
  s:=mixedcase(user.bbsname);
  write(' Rancho Nevada '+version+' Alt-Chat Alt-Dump Alt-Edit F1:SBar On:'+s);
  clreol;
  if
    usesuperbar
  then
    window(1,5,80,24)
  else
    window(1,1,80,24);
  gotoxy(x,y);
  textattr:=z;
  if
    usesuperbar
  then
    makesbar;
end;

procedure sysopkey;
begin
  ctmp:=readkey;
  cret:=#00;
  case ctmp of
    #72 : cret:='N';  {Arrow key North}
    #80 : cret:='S';  {Arrow key South}
    #75 : cret:='W';  {Arrow key West}
    #77 : cret:='E';  {Arrow key East}
    #59 : begin
            usesuperbar:=not(usesuperbar);
            if
              usesuperbar
            then
              makesbar
            else
              takedownsbar;
          end;
    #18 : begin
            sysmsg(680);
            btmp:=consoleonly;
            consoleonly:=true;
            writeuser(user.bbsname,user);
            edituser(thisusernumber);
            consoleonly:=btmp;
            sysmsg(681);
            readuser(thisusernumber-1);
            updatesbar;
            user:=tmpuser;
            ctmp:=#13;
          end; {Alt-Edit}
    #32 : quitnow:=true;                                 {Alt-Dump}
    #46 : begin chatmode; ctmp:=#13; end;                 {Alt-Chat}
  end;
  if ctmp<>#13 then ctmp:=#1;
end;

function ansiarrow:char;
var tch:char;
    ii:longint;
begin
  ii:=sec70;
  repeat nothing until charinbuffer or (ii<>sec70) or quitnow or lostcarrier;
  if not charinbuffer then begin ansiarrow:=#27; exit; end;
  tch:=com_rx;
  if not (tch='[') then begin ansiarrow:=#27; exit; end;
  tch:=com_rx;
  case upcase(tch) of
    'A':ansiarrow:='N';
    'B':ansiarrow:='S';
    'C':ansiarrow:='E';
    'D':ansiarrow:='W';
  else
    ansiarrow:=#27;
  end;
end;

procedure get(x:string);
var entersec:longint;
    tch:char;
    xx:longint;
label _exit;
begin
  totallines:=0;
  ctmp:=#00;
  entersec:=sec70; tch:=#00; xx:=config.timeout*60; x:=upcasestr(x);
  repeat
    if not(ignorecheck) then if checkwhoson then goto _exit;
    { Put code here to deal with something happening }
    if ((sec70-entersec)>xx) then begin cardiac; goto _exit; end;
    if lostcarrier then begin nocarrier; goto _exit; end;
    if
      (dcd and not(localmode) and charinbuffer)
    then
      begin
        if lostcarrier then begin nocarrier; goto _exit; end;
        tch:=upcase(com_rx);
        if tch=#27 then tch:=ansiarrow;
      end;
    if
      keypressed
    then
      begin
        tch:=upcase(readkey);
        if
          tch=#00
        then
          begin
            sysopkey; entersec:=sec70;
            if cret<>#00 then tch:=cret;
          end;
      end;
    if lostcarrier then goto _exit;
  until quitnow or not(pos(tch,x)=0) or lostcarrier;
  ctmp:=tch;
_exit:
  ignorecheck:=false;
end;

procedure getany;
var ls,dl:longint;
    timeout:boolean;
    tch:char;
begin
  if lostcarrier then exit;
  ls:=sec70; timeout:=false;
  repeat
    nothing;
    dl:=longint(sec70-ls) div 60;
    if dl>=config.timeout then timeout:=true;
  until charwaiting or lostcarrier or quitnow or timeout;
  if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
  if charwaiting then tch:=getchr;
end;

function getlnz(X:Byte):String;
{Input line from modem, X chars Max}
begin
  totallines:=0;
  maximuminput:=x;
  minimuminput:=0;
  getlnz:=getln1;
end;

function getln(x:byte):string;
begin
  getln:=getlnz(x);
  sendln('');
end;

procedure anykey;
begin
  if lostcarrier then exit;
  totallines:=0;
  lastattr:=textattr;
  sysmsg(682);
  getany;
  setattr(lastattr);
  sendln('');
end;

function c2sc(x:extended):string;
var tmp:string[80];
    i:integer;
    ofs:integer;
    c2:extended;
begin
  c2:=int(x); tmp:=c2s(c2); c2sc:=tmp;
  if length(tmp)<=3 then exit;
  ofs:=length(tmp) mod 3; ofs:=ofs+2;
  i:=length(tmp)-2;
  while i>1 do begin insert(',',tmp,i); dec(i,3); end;
  c2sc:=tmp;
end;

function i2sc(x:longint):string;
var tmp:string[80];
    i:integer;
    ofs:integer;
    c2:extended;
begin
  tmp:=int2str(x); i2sc:=tmp;
  if length(tmp)<=3 then exit;
  ofs:=length(tmp) mod 3; ofs:=ofs+2;
  i:=length(tmp)-2;
  while i>1 do begin insert(',',tmp,i); dec(i,3); end;
  i2sc:=tmp;
end;

function c2s(x:extended):string;
var tmp:string[40];
begin
  str(x:1:0,tmp);
  c2s:=tmp;
end;

function c2sa(x:extended):string;
var tmp:string[40];
begin
  if
    x>=10e+12
  then
    begin
      str(x:13,tmp);
      tmp:=copy(tmp,2,12);
    end
  else
    str(x:1:0,tmp);
  c2sa:=tmp;
end;

function yn:char;
var tmp:char;
    done:boolean;
begin
  totallines:=0;
  ctmp:=' ';
  tmp:='N';
  done:=false;
  repeat
    begin
      if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
      if yndefault then sysmsg(683) else sysmsg(684);
      if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
      get('yn? '#13); ctmp:=upcase(ctmp);
      if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
      if (ctmp=#13) or (ctmp=' ') then if yndefault then ctmp:='Y' else ctmp:='N';
      case ctmp of
        'Y' : begin tmp:='Y'; sysmsg(685); if not(nocr) then sendln(''); done:=true; end;
        'N' : begin tmp:='N'; sysmsg(686); if not(nocr) then sendln(''); done:=true; end;
        '?' : sysmsg(687);
      end; {case}
      if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
    end;
  until done or quitnow or lostcarrier;
  if lostcarrier then begin nocarrier; quitnow:=true; exit; end;
  yn:=tmp;
  ctmp:=#1;
  nocr:=false;
end;

function fsize(fnm:string):longint;
var fshit:file of byte;
    tshit,pftime,cft:longint;
begin
  tshit:=0;
  if
    not exist(fnm)
  then
    tshit:=-1
  else
    begin
      {$I-}
      assign(fshit,fnm);
      reset(fshit);
      tshit:=filesize(fshit);
      close(fshit);
      {$I+}
    end;
  fsize:=tshit;
end;

function bigrnd(maximum:longint):longint;
    { A quick and dirty 32-bit random number generator!                    }
    { What this code does is generate a random number between 0 and maxint }
    { and then mods it by the desired amount.  Statistically it should be  }
    { evenly random up to maxint/2, after that it will favour lower        }
    { numbers because of the mod                                           }
var b1,b3:longint;
begin
  b1:=random(32768);
  b1:=b1 shl 16;
  b1:=b1+random(65535);
  b3:=abs(b1 mod maximum);
  b3:=b3 and $7FFFFFFF;
  bigrnd:=b3;
end;

function hugernd(maximum:extended):extended;
    { A quick and dirty real/comp random number generator!                 }
var b1:extended;
begin
  b1:=random*maximum;
  hugernd:=b1;
end;


function countline(x:string):integer;
var xxx:text;
    index:word;
    tmp:string[1];
begin
  if
    not(exist(x))
  then
    begin
      countline:=0;
      exit;
    end
  else
    begin
      assign(xxx,x);
      reset(xxx);
      index:=0;
      repeat
        readln(xxx,tmp);
        inc(index);
      until eof(xxx);
      close(xxx);
      countline:=index;
    end;
end;

function lastline(x:string):string;
var xxx:text;
    index:word;
    tmp:string;
begin
  if
    not(exist(x))
  then
    begin
      lastline:='';
      exit;
    end
  else
    begin
      assign(xxx,x);
      reset(xxx);
      repeat
        readln(xxx,tmp);
      until eof(xxx);
      close(xxx);
      lastline:=tmp;
    end;
end;

function grabline(x:integer; y:string):string;
var xxx:text;
    index:integer;
    tmp:string;
begin
  if
    not(exist(y))
  then
    begin
      grabline:='';
      exit;
    end
  else
    begin
      index:=0;
      assign(xxx,y);
      reset(xxx);
      repeat
        readln(xxx,tmp);
        inc(index);
      until eof(xxx) or (index>=x);
      close(xxx);
      grabline:=tmp;
    end;
end;

function raisepower(x,power:extended):extended;
var tmp:extended;
begin
  tmp:=0;
  if (x=0) then begin raisepower:=0; exit; end; {crash protection!}
  tmp:=ln(x)*power;
  tmp:=exp(tmp);
  raisepower:=tmp;
end;

function nextlevelxp(level:longint):extended;
begin
  nextlevelxp:=(raisepower(1.4,level)*2000)-2000;
end;

procedure log(s:string);
const fname='RANCHO.LOG';
var f:text;
begin
  assign(f,fname);
  if
    exist(fname)
  then
    append(f)
  else
    rewrite(f);
  if safelog then writeln(f,'  `O'+s) else writeln(f,'`O'+s);
  writeln(f,g_sysmsg(740));
  safelog:=true;
  flush(f);
  close(f);
end;

function getamode(x:integer):string;
var tmp:string[24];
begin
  tmp:='';
  case x of
    0 : tmp:=g_sysmsg(688);
    1 : tmp:=g_sysmsg(689);
    2 : tmp:=g_sysmsg(690);
    3 : tmp:=g_sysmsg(691);
    4 : tmp:=g_sysmsg(692);
    5 : tmp:=g_sysmsg(693);
    6 : tmp:=g_sysmsg(694);
  end;
  getamode:=tmp;
end;

function margin(att,def,mar:longint):boolean;
var result:boolean;
    diff,maxmar,test:longint;
    megmar:longint;
    tmp:longint;
begin
  result:=false;
  diff:=att-def;

  if
    (((abs(diff)*100) div att) >(mar*2))  {If we are outside the random margin}
  then                          {then return true or false depending}
    if                          {on which value is greater...       }
      (diff>=0)
    then
      begin
        margin:=true;
        exit;
      end
    else
      begin
        margin:=false;
        exit;
      end;
  test:=random(def);
  diff:=def-att;
  tmp:=(def-diff) div 2;
  if
    test<=tmp
  then
    result:=true
  else
    result:=false;
  margin:=result;
end;

procedure addevent(evt:eventrec);
begin
  if onlineencounter then exit;
  if
    exist(evtname)
  then
    begin
      assign(eventfile,evtname);
      reset(eventfile);
      seek(eventfile,filesize(eventfile));
      evt.datewritten:=sec70;
      write(eventfile,evt);
      close(eventfile);
    end
  else
    begin
      assign(eventfile,evtname);
      rewrite(eventfile);
      evt.datewritten:=sec70;
      write(eventfile,evt);
      close(eventfile);
    end;
  {We're done so clear the variable for next time - security reasons!}
  fillchar(tempevent,sizeof(tempevent),#00);
end;

function badbutter(u1,u2:userrec):boolean;
var tmp:boolean;
begin
  tmp:=false;
  if
    ((u1.gender=u2.gender) and ((u1.orientation=straight) or (u2.orientation=straight)))
  or
    ((u1.gender<>u2.gender) and ((u1.orientation=gay) or (u2.orientation=gay)))
  then
    tmp:=true;
  badbutter:=tmp;
end;

function goodroom(roomno:word):boolean;
var tmp:boolean;
    t2:word;
begin
  tmp:=true;
  t2:=(room^[roomno].room_north)
     +(room^[roomno].room_south)
     +(room^[roomno].room_east)
     +(room^[roomno].room_west)
     +(room^[roomno].room_up)
     +(room^[roomno].room_down);
  tmp:=(t2>0);
  goodroom:=tmp;
end;

function isnum(c:char):boolean;
var tmp:boolean;
begin
  tmp:=false;
  case c of
    '0'..'9':tmp:=true;
  end;
  isnum:=tmp;
end;

function checksay:boolean;
var f:text;
    s,filename:string;
    crap:integer;
    dirinfo:searchrec;
begin
  checksay:=false;
  findfirst('????-'+int2str(thisusernumber)+'.SAY',archive,dirinfo);
  while doserror=0 do
    begin
      filename:=dirinfo.name;
      checksay:=true;
      if not waitlock(filename) then unlock(filename);
      lock(filename);
      assign(f,filename);
    {$I-}
      reset(f); crap:=ioresult;
      repeat
        readln(f,s); crap:=ioresult;
        sendln(s);
      until eof(f) or (crap<>0);
      close(f);
      crap:=ioresult;
    {$I+}
      unlock(filename);
      nuke(filename);
      findnext(dirinfo);
    end;
end;

function checkcontrol:boolean;
var f:text;
    s,t,filename:string;
    crap:integer;
    dirinfo:searchrec;
    i:longint;
label _exit,_defender,_acksync;
begin
  checkcontrol:=false;
  findfirst('????-'+int2str(thisusernumber)+'.CNT',archive,dirinfo);
  while doserror=0 do
    begin
      filename:=dirinfo.name;
      writeln('Processing ',filename);
      checkcontrol:=true;
      if not waitlock(filename) then unlock(filename);
      lock(filename);
      assign(f,filename);
    {$I-}
      reset(f); crap:=ioresult;
      repeat
        readln(f,s); crap:=ioresult;
        textattr:=white; writeln(crlf+crlf+'Control: "',s,'"'+crlf);
        t:=upcasestr(s); linein:=t; parse;
        controlstring:=s; i:=str2int(parses[2]);
        controlcode:=parses[1]; val(parses[2],controlparm,crap);
        if controlcode='SYNCUSERLOG' then goto _acksync;
        if parses[1]='ICHALLENGEYOU' then goto _defender;
        {Put additional processing commands here}
      until eof(f) or (crap<>0);
      close(f);
      crap:=ioresult;
    {$I+}
      unlock(filename);
      nuke(filename);
      findnext(dirinfo);
    end;

goto _exit;

_defender:
{$I-}
  close(f); crap:=ioresult; unlock(filename); nuke(filename);
  online_defend(str2int(parses[2]));
  goto _exit;
{$I+}

_acksync:
{$I-}
  close(f); crap:=ioresult; unlock(filename); nuke(filename);
  rereaduserlog;
  writeuserlog;
  control(i,'USYNC_ACK');
  goto _exit;
{$I+}

_exit:

end;

procedure sayit;
var f:text;
    s,filename:string;
    i:integer;
    crap:integer;
begin
  checkwhoson;
  sysmsg(792);
  s:=getln(72);
  for i:=1 to 256 do
   begin
    if
      (uon[i].online) and (uon[i].room=user.room)
    then
      begin
        filename:='USER-'+int2str(i)+'.SAY';
        waitlock(filename); lock(filename);
{$I-}
        assign(f,filename);
        rewrite(f); crap:=ioresult;
        parameter[1]:=user.name;
        writeln(f,g_sysmsg(793)); crap:=ioresult;
        writeln(f,'  '+s); crap:=ioresult;
        flush(f); crap:=ioresult;
        close(f); crap:=ioresult;
{$I+}
        unlock(filename);
      end;
   end;
end;

procedure oneannounce(s:String); {Sends a string to everyone in the room}
var f:text;
    filename:string;
    i:integer;
    crap:integer;
begin
  checkwhoson;
  for i:=1 to 256 do
   begin
    if
      (uon[i].online) and (uon[i].room=user.room)
    then
      begin
        filename:=rand4char+'-'+int2str(i)+'.SAY';
        waitlock(filename); lock(filename);
{$I-}
        assign(f,filename);
        rewrite(f); crap:=ioresult;
        parameter[1]:=user.name;
        writeln(f,'  '+s); crap:=ioresult;
        flush(f); crap:=ioresult;
        close(f); crap:=ioresult;
{$I+}
        unlock(filename);
      end;
   end;
end;

procedure control(i:integer; s:String); {Sends a string to user i}
var f:text;
    filename:string;
    crap:integer;
begin
  checkwhoson;
  if
    (uon[i].online) and (uon[i].room=user.room)
  then
    begin
      filename:=rand4char+'-'+int2str(i)+'.CNT';
      waitlock(filename); lock(filename);
{$I-}
      assign(f,filename);
      rewrite(f); crap:=ioresult;
      parameter[1]:=user.name;
      writeln(f,s); crap:=ioresult;
      flush(f); crap:=ioresult;
      close(f); crap:=ioresult;
{$I+}
      unlock(filename);
    end;
end;

procedure global_oneannounce(s:String); {Sends a string to everyone in the game}
var f:text;
    filename:string;
    i:integer;
    crap:integer;
begin
  checkwhoson;
  for i:=1 to 256 do
   begin
    if
      (uon[i].online)
    then
      begin
        filename:=rand4char+'-'+int2str(i)+'.SAY';
        waitlock(filename); lock(filename);
{$I-}
        assign(f,filename);
        rewrite(f); crap:=ioresult;
        parameter[1]:=user.name;
        writeln(f,'  '+s); crap:=ioresult;
        flush(f); crap:=ioresult;
        close(f); crap:=ioresult;
{$I+}
        unlock(filename);
      end;
   end;
end;

procedure checkuserfile;
var dirinfo:searchrec;
begin
  fillchar(dirinfo,sizeof(dirinfo),#00);
  findfirst(ufname,archive,dirinfo);
  if doserror<>0 then exit;
  if dirinfo.time>userfiledate then rereaduserlog;
  userfiledate:=dirinfo.time;
end;

procedure saywent(smcode:integer); {90=N 91=S 92=E 93=W 94=U 95=D} {per sysmsgs}
begin
  parameter[1]:=user.name;
  parameter[2]:=g_sysmsg(smcode);
  oneannounce(g_sysmsg(751));
end;

procedure saycame;
begin
  parameter[1]:=user.name;
  oneannounce(g_sysmsg(750));
end;

procedure saywhoosh;
begin
  parameter[1]:=user.name;
  oneannounce(g_sysmsg(752));
end;

function checkwhoson:boolean; {Returns true if something happened}
var dirinfo:searchrec;
    p:dos.pathstr; d:dos.dirstr; n:dos.namestr; e:dos.extstr;
    c,i,k:integer; j:word;
    tuon:_uonarray;
    f:file of word;
    tr:integer;
    where:string[12];
begin
  checkwhoson:=false;
  fillchar(tuon,sizeof(tuon),#00);
  findfirst('USER-*.ON',archive,dirinfo);
  while doserror=0 do
    begin
      p:=dirinfo.name; fsplit(p,d,n,e);
      k:=str2int(copy(n,6,127));
      if
        (k>0) and (k<=256) and (not (k=thisusernumber))
      then
        begin
          tuon[k].online:=true;
          tuon[k].time:=dirinfo.time;
          tuon[k].room:=uon[k].room;
          if
            dirinfo.time>uon[k].time
          then
            begin
              tr:=userlog^[k].room;
              filemode:=0; assign(f,dirinfo.name);
              {$I-} reset(f); c:=ioresult; read(f,j); c:=ioresult; close(f); c:=ioresult;
              {$I+} filemode:=2;
              tuon[k].room:=j;
              userlog^[k].room:=j;
            end;
        end;
      findnext(dirinfo);
    end;
  uon:=tuon;
  if checkcontrol then checkwhoson:=true;
  if checkemail then checkwhoson:=true;
  if checksay then checkwhoson:=true;
end;

procedure getrnsinfo(filename:string);
var f:text;
    l:longint;
    dt:datetime;
begin
  parameter[1]:='';
  parameter[2]:='';
  if not exist(filename) then exit;
  assign(f,filename);
  reset(f);
  getftime(f,l);
  readln(f,parameter[1]);
  close(f);
  unpacktime(l,dt);
  parameter[2]:=zeropad(int2str(dt.hour))+':'+zeropad(int2str(dt.min));
end;

procedure listwhoson;
var i:integer;
    dirinfo:searchrec;
begin
  checkwhoson;
  sysmsg(794);
  findfirst('*.RNS',archive,dirinfo);
  while doserror=0 do
    begin
      getrnsinfo(dirinfo.name); sysmsg(795);
      findnext(dirinfo);
    end;
  sendln(''); anykey;
end;

procedure updatewhoson;
var f:file of word;
    retries:integer;
    c:integer;
label _retry,_ohwell;
begin
  user.room:=user.room;
  if useronname='' then exit;
{$I-}
  assign(f,useronname);
  retries:=0;
_retry:
  inc(retries); if retries>35 then goto _ohwell;
  rewrite(f); c:=ioresult; if c<>0 then begin delay(12); goto _retry; end;
  write(f,user.room); c:=ioresult; if c<>0 then begin delay(12); goto _retry; end;
_ohwell:
  close(f); c:=ioresult;
{$I+}
end;

function strip_embed(s:string):string;
var x:integer;
begin
  x:=pos(#96,s);
  while (x<>0) and (s[0]>#0) do
    begin
      delete(s,x,2);
      x:=pos(#96,s);
    end;
  x:=1;
  while (s[0]>#0) and (x<=length(s)) do
    case s[x] of
      #0..#31,#96,#127..#255:delete(s,x,1);
    else
      inc(x);
    end;
  strip_embed:=qualify(s);
end;

function isinvkr(i:integer):boolean;
var f:string;
    lnow,lthen,ldiff:longint;
begin
  f:='USER-'+int2str(i)+'.VKR';
  isinvkr:=false;
  if not exist(f) then exit;
  ldiff:=f_size(f);
  lnow:=sec70; lthen:=currentfiledate; ldiff:=longint(lnow-lthen);
  if (ldiff>1800) then begin nuke(f); exit; end; {Kill if over 30 minutes old}
  isinvkr:=true;
end;

function lookupuser(s:String):integer;
var i:integer;
    t:string;
    tch:char;
begin
  lookupuser:=-1;
  s:=upcasestr(strip_embed(s));
  if s='' then exit;

  if
    isnums(s)         { FIRST : is this a valid user number? }
  then
    begin
      i:=str2int(s);
      if
        (i>0) and (i<=maxuser)
      then
        if
          (not(userlog^[i].deleted))
        then
          begin
            parameter[1]:=userlog^[i].name;
            sysmsg(789);
            yndefault:=true; tch:=upcase(yn);
            if
              tch='Y'
            then
              begin
                lookupuser:=i;
                exit;
              end;
          end;
    end;

  for i:=1 to maxuser do    { Not a user number; go with alpha search }
    begin
      t:=upcasestr(strip_embed(userlog^[i].name));
      if pos(s,t)<>0 then
        begin
          parameter[1]:=userlog^[i].name;
          sysmsg(789);
          yndefault:=true; tch:=upcase(yn);
          if
            tch='Y'
          then
            begin
              lookupuser:=i;
              exit;
            end;
        end;
    end;
end;

function whichway(myroom,thatroom:integer):string;
var tr:roomrec;
begin
  whichway:=''; {blank means that "thatroom" is not linked by this room}
  tr:=room^[myroom];
  if tr.room_north=thatroom then whichway:=g_sysmsg(90);
  if tr.room_south=thatroom then whichway:=g_sysmsg(91);
  if tr.room_east=thatroom then whichway:=g_sysmsg(92);
  if tr.room_west=thatroom then whichway:=g_sysmsg(93);
  if tr.room_up=thatroom then whichway:=g_sysmsg(94);
  if tr.room_down=thatroom then whichway:=g_sysmsg(95);
end;

function randzap:integer;
var i:integer;
begin
  repeat i:=random(800)+1 until goodroom(i);
  randzap:=i;
end;

begin
  userfiledate:=0; whoroomdate:=0;
  useronname:='';
{  fillchar(userrmnum,sizeof(userrmnum),#00); }
  fillchar(hasattacked,sizeof(hasattacked),#00);
  statname:='@@@@@@@@.@@@';
  verbbump:=true;
  yndefault:=yes;
  maxuser:=userlogsize; if maxuser>256 then maxuser:=256;
  new(userlog);
  readuserlog;
  editmode:=false;
  youwon:=false;
  spellpriv[13]:=true; spellpriv[14]:=true; spellpriv[15]:=true; spellpriv[16]:=true;
  safelog:=true;
  datein:=ds1970;
  ignorecheck:=false;
  usingmachine:=false;
end.
