Jason Aller Floppy Collection/341.img/TCS161S.ZIP/CHATSTUF.PAS

Pascal/Delphi Source File | 1980-10-06 | 31KB | 1,336 lines

{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
{$M 65500,0,0 }

unit chatstuf;

interface

uses crt,dos,
     gentypes,gensubs,subs1,userret,flags,mainr1,modem,windows,statret,
     configrt,qwik;

function specialcommand:boolean;
procedure specialseries;
procedure chat (gotospecial:boolean);

implementation

const c1=15;
      c2=12;
      c3=15;
      c4=11;
      w2=24;
      w3=42;
      axis1=9;
      axis2=10;
      edituser:array [1..12] of string=
       ('╤═══════════════════╤',
        '│ User Name         │',
        '│ User Level        │',
        '│ Xfer Level        │',
        '│ Xfer Points       │',
        '│ User Note         │',
        '│ Time Left         │',
        '│ Password          │',
        '│ G-File Level      │',
        '│ Board Access      │',
        '│ Sysop Access      │',
        '╘═══════════════════╛');
      utils:array [1..12] of string=
       ('╤═══════════════════╤',
        '│ Hang up on User   │',
        '│ NUKE User!        │',
        '│ Snoop Mode [On]   │',
        '│ Snoop Mode [Off]  │',
        '╘═══════════════════╛',
        '',
        '',
        '',
        '',
        '',
        '');
      extra:array [1..12] of string=
       ('╤═══════════════════════════╤',
        '│ Drop to DOS (all memory)  │',
        '│ Drop to DOS (part memory) │',
        '│ Run Config Program        │',
        '│ Run Text Editor           │',
        '╘═══════════════════════════╛',
        '',
        '',
        '',
        '',
        '',
        '');

var dscinc:array [1..6] of array [1..60] of word;
    Status:word;
type brdrrec = record
                TL,TH,TR,LV,RV,BL,BH,BR:char;
               end;

const border:brdrrec = (TL:'╔';TH:'═';TR:'╗';
                        LV:'║';       RV:'║';
                        BL:'╚';BH:'═';BR:'╝');

function specialcommand:boolean;

  function getstring (t:anystr):anystr;
  var mm,lz:anystr;
  begin
    textbackground (7);
    textcolor (4);
    gotoxy (axis1+3,axis2+2);
    write (usr,t);
    readline (mm);
    getstring:=mm;
  end;

  function getint (t:lstr):integer;
  var s:sstr;
  begin
    s:=getstring (t);
    getint:=valu(s)
  end;

  function getboo (t:lstr):boolean;
  var s:sstr;
  begin
    s:=getstring (t);
    getboo:=upcase(s[1])='Y'
  end;

 procedure box;

   procedure qbox (row,col,rows,cols:byte;wndwattr,brdrattr:integer;brdr:brdrrec);
   begin
    if (rows>=2) and (cols>=2) then
    begin
      with brdr do
      begin
        qwrite    (row       ,col                     ,brdrattr,TL);
        qfilleos  (                           1,cols-2,brdrattr,TH);
        qwriteeos (                                    brdrattr,TR);
        qfill     (row+1     ,col       ,rows-2,1     ,brdrattr,LV);
        qfill     (row+1     ,col+cols-1,rows-2,1     ,brdrattr,RV);
        qwrite    (row+rows-1,col                     ,brdrattr,BL);
        qfilleos  (                           1,cols-2,brdrattr,BH);
        qwriteeos (                                    brdrattr,BR);
        qfill     (row+1     ,col+1     ,rows-2,cols-2,wndwattr,' ')
     end;
    end;
   end;

  begin
   qstoretomem (axis1,axis2,6,60,dscinc);
   qbox (axis1,axis2,6,60,15+lightgraybg,14,border);
  end;

  procedure done1;
  begin
   qstoretoscr (axis1,axis2,6,60,dscinc);
  end;

  procedure write1 (l:lstr);
  begin
   gotoxy (axis1+3,axis2+1);
   textcolor (1);
   textbackground (7);
   writeln (usr,l);
  end;

  procedure getnewtime;
  var q:integer;
      n:integer;
  begin
    n:=timeleft;
    box;
    write1 ('The user has '+strr(n)+' minutes left.');
    q:=getint ('New time left for today? ');
    if q>0 then begin
      urec.timetoday:=urec.timetoday+(q-n);
      writeurec;
      writeln ('You have been granted '+strr(timeleft)+' minutes for today.')
    end;
  end;

  procedure getnewlevel;
  var q,n:integer;
  begin
    box;
    write1 ('Current Level: '+strr(ulvl));
    q:=getint ('New Level [-1 to TRASH]: ');
    if q>0 then begin
     n:=q;
     ulvl:=n;
     urec.level:=n;
     writeurec;
     writeln ('You have been granted Level ',n,' access.');
     if n=-1 then writeln ('That means you''ve been thrown off this system. Hahah.')
    end
  end;

  procedure getnewgflevel;
  var q,n:integer;
  begin
    box;
    write1 ('Current G-File Level: '+strr(urec.gflevel));
    q:=getint ('New G-File Level: ');
    if q>0 then begin
     n:=q;
     urec.gflevel:=n;
     writeurec;
     writeln ('You have been granted Level ',n,' G-File access.');
    end
  end;

  procedure getnewaccess;
  var q,bname:sstr;
      bn:integer;
      ac:accesstype;
      wasopen:boolean;
      k:char;

    function inputaccess (q:sstr):accesstype;
    begin
      inputaccess:=invalid;
      if length(q)=0 then exit;
      case upcase(q[1]) of
        'L':inputaccess:=letin;
        'B':inputaccess:=bylevel;
        'K':inputaccess:=keepout
      end
    end;

    procedure getallaccess;

      procedure setallaccess (ac:accesstype);
      var cnt:integer;
      begin
        setalluserflags (urec,ac);
        writeln ('Your access to all sub-boards: ',accessstr[ac]);
        writeurec
      end;

    begin
      buflen:=1;
      q:=getstring ('ALL acc. ([B]y level, [L]et in, [K]eep out, or CR): ');
      ac:=inputaccess(q);
      if ac<>invalid then setallaccess(ac)
    end;

  var bd:boardrec;
  begin
    box;
    write1 ('Change Sub-Board Access');
    buflen:=10;
    bname:=getstring ('Which sub-board to change access for [''*''/All]: ');
    if length(bname)<1 then exit;
    if bname='*' then
      begin
        getallaccess;
        exit
      end;
    opentempbdfile;
    bn:=searchboard(bname);
    if bn=-1 then
      begin
        closetempbdfile;
        write1 ('No such board!  Press any key..');
        k:=bioskey;
        exit
      end;
    write1 ('Board '+bname+'... Current access: '+accessstr[getuseraccflag(urec,bn)]);
    buflen:=1;
    q:=getstring ('Access ([B]y level, [L]et in, [K]eep out, or [CR]: ');
    ac:=inputaccess(q);
    if ac=invalid then begin
      closetempbdfile;
      exit
    end;
    setuseraccflag (urec,bn,ac);
    writeurec;
    closetempbdfile;
    writeln ('New access for sub-board ',bname,': ',accessstr[ac])
  end;

  procedure hangupyn;
  var q:sstr;
  begin
    box;
    write1 ('Hang up on User');
    q:=getstring ('Hang up on him [y/n]? ');
    if length(q)>0 then if upcase(q[1])='Y' then
      begin
        writeln ('<<< ',unam,' the System is going DOWN >>>    '^M^M);
        hangup;
        forcehangup:=true;
        specialcommand:=true
      end
  end;

  procedure getnewname;
  var m:mstr;
      n:integer;
      t:string[1];
  begin
    box;
    write1 ('Current Name: '+unam);
    m:=getstring ('New User Name: ');
    if length(m)<>0 then begin
      n:=lookupuser(m);
      if n<>0 then begin
        buflen:=1;
        t:=getstring ('Name already exists!  Are you sure? ');
        if upcase(t[1])<>'Y' then exit
      end;
      unam:=m;
      urec.handle:=m;
      writeurec;
      writeln ('Your Name has been changed to ',unam,'.')
    end
  end;

  procedure getnewpassword;
  var m:mstr;
  begin
    box;
    write1 ('Current Password: '+urec.password);
    m:=getstring ('New Password: ');
    if length(m)<>0 then
    begin
      urec.password:=m;
      writeurec;
      writeln ('Your Password has been changed.')
    end
  end;

  procedure getxferlevel;
  var i:integer;
  begin
    box;
     write1 ('Current Xfer Level: '+strr(urec.udlevel));
     i:=getint ('New File Xfer Level: ');
     if i<0 then exit
      else begin
       writeln ('You have been granted Level ',i,' File Xfer access.');
       urec.udlevel:=i;
       writeurec;
      end;
  end;

  procedure getxferpoints;
  var i:integer;
  begin
   box;
    write1 ('Current Xfer Points: '+strr(urec.udpoints));
    i:=getint ('New File Xfer Points: ');
     if i<0 then exit
      else begin
       writeln ('You have been granted ',i,' File Xfer points.');
       urec.udpoints:=i;
       writeurec;
      end;
  end;

  procedure snoopmode;
  begin
    box;
    write1 ('All I/O to the modem is locked.');
    delay (500);
    modeminlock:=true;
    setoutlock (true)
  end;

  procedure unsnoop;
  begin
    box;
    write1 ('I/O to the modem is re-enabled.');
    delay (500);
    modeminlock:=false;
    setoutlock (false)
  end;

  procedure makenote;
  var mastermind:mstr;
  begin
   box;
   write1 ('Current Note: '+urec.note);
   buflen:=30;
   mastermind:=getstring ('New Note: ');
   if length(mastermind)<>0 then begin
    urec.note:=mastermind;
    writeurec;
    writeln ('Your User Note has been changed to: ',mastermind);
   end;
  end;

  procedure gotodos (i:integer);
  begin
    writeln ('[ Sysop in DOS ]');
    window (1,1,80,25);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
    updateuserstats (false);
    if i=1 then execcomcom else
    if i=2 then begin
     ensureclosed;
     writereturnbat;
     halt (4);
    end;
    ClrScr;
  end;

  procedure dotexteditor;
  begin
    if length(editor)<1 then exit;
    writeln ('[ Sysop is loading text editor ]');
    window (1,1,80,25);
    gotoxy (1,25);
    writeln (usr,^M^J^J^J);
    updateuserstats (false);
    ensureclosed;
    exec(GetEnv('COMSPEC'), '/C '+editor);
  end;

  procedure printf (fn:lstr);

  procedure getextension (var fname:lstr);

    procedure tryfiles (a,b,c,d:integer);
    var q:boolean;

      function tryfile (n:integer):boolean;
      const exts:array [1..4] of string[3]=('','ANS','ASC','40');
      begin
        if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
          tryfile:=true;
          fname:=fname+'.'+exts[n]
        end
      end;

    begin
      if tryfile (a) then exit;
      if tryfile (b) then exit;
      if tryfile (c) then exit;
      q:=tryfile (d)
    end;

  begin
    if pos ('.',fname)<>0 then exit;
    if ansigraphics in urec.config  then tryfiles (2,3,1,4) else
    if asciigraphics in urec.config then tryfiles (3,1,4,2) else
    if eightycols in urec.config    then tryfiles (1,4,3,2) else
                                         tryfiles (4,1,3,2)
  end;

var tf:text;
    k:char;
begin
  clearbreak;
  writeln;
  getextension (fn);
  assign (tf,fn);
  reset (tf);
  iocode:=ioresult;
  if iocode<>0 then begin
    fileerror ('Printfile',fn);
    exit
  end;
  clearbreak;
  while not (eof(tf) or break or hungupon) do
    begin
      read (tf,k);
      write (k)
    end;
  if break then writeln (^B);
  writeln;
  textclose (tf);
  curattrib:=0;
  ansireset
end;

  procedure nuke;
  var q:sstr;
  begin
    box;
    q:=getstring ('NUKE the lamer [y/n]? ');
    if length(q)>0 then if upcase(q[1])='Y' then
      begin
        write1 ('BOOM!!');
        if exist (textfiledir+'Nuke') then
         printf (textfiledir+'Nuke') else
        writeln ('Your NUKED!!'^M^M);
        hangup;
        forcehangup:=true;
        specialcommand:=true
      end
  end;

  procedure getsysopaccess;
  const sysopstr:array [false..true] of string[6]=('Normal','Sysop');
        sectionnames:array [udsysop..gfsysop] of string[20]=
          ('File Transfer','Bulletin Section','Voting Booths',
           'E-Mail Section','Doors','Main Menu','Databases','Trivia Sysop',
           'G-File Section');
  var cnt:configtype;
      x:string[10];
      n,mx:integer;
      v:boolean;
  begin
    repeat
      splitscreen (12);
      mx:=1;
      for cnt:=udsysop to gfsysop do begin
        write (usr,mx:3,'. ',sectionnames[cnt]);
        mx:=mx+1;
        gotoxy (25,wherey);
        writeln (usr,sysopstr[cnt in urec.config])
      end;
      write (usr,^M^J'Number to toggle [CR/Exit]: ');
      buflen:=1;
      readline (x);
      n:=valu(x);
      v:=(n>0) and (n<mx);
      if v then begin
        cnt:=configtype(ord(udsysop)+n-1);
        if cnt in urec.config
          then
            begin
              urec.config:=urec.config-[cnt];
              x:='denied'
            end
          else
            begin
              urec.config:=urec.config+[cnt];
              x:='granted'
            end;
        writeln ('You have been ',x,' sysop priveleges for the ',
                 sectionnames[cnt],'.')
      end
    until not v;
    writeurec;
    splitscreen (17);
    exit;
  end;

procedure runconfig;
begin
 if forumdir[length(forumdir)]<>'\' then forumdir:=forumdir+'\';
 Exec(GetEnv('COMSPEC'), '/C CONFIG.EXE');
 readconfig;
 if datascrambling then scrambled:=true else scrambled:=false;
end;

procedure cursor (csize:byte);
var regs:registers;
begin
   case (csize) of
      1: if mem[0:$449]=7 then regs.cx:=$0c0d  { Underline  = 1 }
         else regs.cx:=$0607;
      2: if mem[0:$449]=7 then regs.cx:=$060d  { Full Block = 2 }
         else regs.cx:=$0007;
      3: regs.cx:=$2000;                       { No Cursor  = 3 }
   end;
   regs.ax:=$0100;
   intr ($10,regs);
end;

const memrows=25;
      memcols=80;
var scom:char;
    k,c:char;
    quit:boolean;
    x,y:integer;

procedure writetop;
begin
  gotoxy (1,1);
  textbackground (1);
  textcolor (c1);
  cursor (3);
  write (usr,'╒═══════════════════════[ ');
  textcolor (c2);
  write (usr,'On-Line Sysop Commands');
  textcolor (c1);
  writeln (usr,' ]══════════════════════╕');
  write (usr,'│ ');
  textcolor (12);
  write (usr,'User Editing          Utilities         Extra Commands');
  textcolor (c1);
  writeln (usr,'                │');
  writeln (usr,'╘═══════════════════════════════════════════════════════════════════════╛');
  gotoxy (1,16);
  textcolor (15);
  textbackground (4);

  write (usr,'< TCS Sysop Pull-Down Menu System - '+#24+','+#25+','+#26+','+#27+',Home,End to Move - [CR] to Select >');
  textbackground (0);
end;

procedure writebar (s:anystr);
var monolith:integer;
begin
 textbackground (7);
 textcolor (1);
 for monolith:=1 to length(s) do
 begin
  if s[monolith] in [' '..'~'] then begin
   textbackground (7);
   textcolor (1);
   write (usr,s[monolith]);
  end else
  begin
   textbackground (1);
   textcolor (c3);
   write (usr,s[monolith]);
  end;
 end;
 textbackground (1);
end;

procedure movebar (xx:integer; dir:char);
var satan,dogchild,floyd:integer;
begin
 dir:=upcase(dir);
 case x of
  1:begin
     textcolor (c1);
     textbackground (1);
     satan:=y;
     gotoxy (3,satan+2);
     write (usr,edituser[satan]);
     if dir='U' then y:=y-1 else
     if dir='D' then y:=y+1 else
     if dir='S' then y:=y;
     if y>11 then y:=2;
     if y<2 then y:=11;
     gotoxy (3,y+2);
     writebar (edituser[y]);
    end;
  2:begin
     textcolor (c1);
     textbackground (1);
     dogchild:=y;
     gotoxy (w2,dogchild+2);
     write (usr,utils[dogchild]);
     if dir='U' then y:=y-1 else
     if dir='D' then y:=y+1 else
     if dir='S' then y:=y;
     if y>5 then y:=2;
     if y<2 then y:=5;
     gotoxy (w2,y+2);
     writebar (utils[y]);
    end;
  3:begin
     textcolor (c1);
     textbackground (1);
     floyd:=y;
     gotoxy (w3,floyd+2);
     write (usr,extra[floyd]);
     if dir='U' then y:=y-1 else
     if dir='D' then y:=y+1 else
     if dir='S' then y:=y;
     if y>5 then y:=2;
     if y<2 then y:=5;
     gotoxy (w3,y+2);
     writebar (extra[y]);
    end;
 end;
end;

procedure movebox (ex,ey:integer);
var anarky,burger,two:integer;
begin
 cursor (3);
 case ex of
  1:begin
     if x=2 then begin
      gotoxy (w2,2);
      textcolor (c2);
      textbackground (1);
      write (usr,' Utilities');
      textcolor (c1);
      gotoxy (w2,3);
      write (usr,'═══════════════════════════');
     end else
     if x=3 then begin
      gotoxy (w3,2);
      textcolor (c2);
      textbackground (1);
      write (usr,' Extra Commands');
      textcolor (c1);
      gotoxy (w3,3);
      write (usr,'═════════════════════════════');
     end;
     x:=1;
     gotoxy (3,2);
     textbackground (1);
     textcolor (c4);
     write (usr,'User Editing');
     textcolor (c3);
     for anarky:=1 to 12 do
     begin
      gotoxy (3,anarky+2);
      write (usr,edituser[anarky]);
     end;
     if y>10 then y:=1;
     textbackground (1);
    end;
  2:begin
     if x=1 then begin
      gotoxy (3,2);
      textcolor (c2);
      textbackground (1);
      write (usr,'User Editing');
      textcolor (c1);
      gotoxy (3,3);
      write (usr,'═════════════════════');
     end else
     if x=3 then begin
      gotoxy (w3,2);
      textcolor (c2);
      textbackground (1);
      write (usr,' Extra Commands');
      textcolor (c1);
      gotoxy (w3,3);
      write (usr,'═════════════════════════════');
     end;
     x:=2;
     gotoxy (w2,2);
     textbackground (1);
     textcolor (c4);
     write (usr,' Utilities');
     textcolor (c3);
     for burger:=1 to 6 do
     begin
      gotoxy (w2,burger+2);
      write (usr,utils[burger]);
      textbackground (1);
      textcolor (c3);
     end;
    end;
  3:begin
     if x=1 then begin
      gotoxy (3,2);
      textcolor (c2);
      textbackground (1);
      write (usr,'User Editing');
      textcolor (c1);
      gotoxy (3,3);
      write (usr,'═════════════════════');
     end else
     if x=2 then begin
      gotoxy (w2,2);
      textcolor (c2);
      textbackground (1);
      write (usr,' Utilities');
      textcolor (c1);
      gotoxy (w2,3);
      write (usr,'══════════════════════');
     end;
     x:=3;
     gotoxy (w3,2);
     textbackground (1);
     textcolor (c4);
     write (usr,' Extra Commands');
     textcolor (c3);
     for two:=1 to 6 do
     begin
      gotoxy (w3,two+2);
      write (usr,extra[two]);
      textbackground (1);
      textcolor (c3);
     end;
    end;
 end;
end;

procedure eraseall;
begin
 qfill (4,1,11,80,black+blackbg,' ');
 writetop;
end;

procedure movedown (x,y:integer);
begin
 movebar (x,'D'); {y+1}
end;

procedure moveup (x,y:integer);
begin
 movebar (x,'U'); {y-1}
end;

procedure moveright (x,y:integer);
begin
 y:=1;
 x:=x+1;
 if x>3 then x:=1;
 eraseall;
 y:=1;
 movebox (x,y);
 movebar (x,'S');
end;

procedure moveleft (x,y:integer);
begin
 y:=1;
 x:=x-1;
 if x<1 then x:=3;
 eraseall;
 y:=1;
 movebox (x,y);
 y:=1;
 movebar (x,'S');
end;

function processcommand:char;
begin
 cursor (1);
 case x of
  1:begin
     case y of
      2:getnewname;
      3:getnewlevel;
      4:getxferlevel;
      5:getxferpoints;
      6:makenote;
      7:getnewtime;
      8:getnewpassword;
      9:getnewgflevel;
      10:getnewaccess;
      11:getsysopaccess;
     end;
    end;
  2:begin
     case y of
      2:hangupyn;
      3:nuke;
      4:snoopmode;
      5:unsnoop;
     end;
    end;
  3:begin
     case y of
      2:Begin
         gotodos (2);
         Writetop;
        End;
      3:gotodos (1);
      4:runconfig;
      5:dotexteditor;
     end;
    end;
 end;
 cursor (3);
 case x of
  1:begin
     case y of
      2:processcommand:='N';
      3:processcommand:='L';
      4:processcommand:='F';
      5:processcommand:='F';
      6:processcommand:='R';
      7:processcommand:='T';
      8:processcommand:='P';
      9:processcommand:='G';
      10:processcommand:='B';
      11:processcommand:='Y';
     end;
    end;
  2:begin
     case y of
      2:processcommand:='H';
      3:processcommand:='N';
      4:begin
         processcommand:='S';
         quit:=true;
        end;
      5:begin
         processcommand:='Z';
         quit:=true;
        end;
     end;
    end;
  3:begin
     case y of
      2:processcommand:='D';
      3:processcommand:='2';
      4:processcommand:='C';
      5:processcommand:='E';
     end;
     quit:=true;
    end;
 end;
 done1;
end;

begin
  writeln (^B^M'[ Please wait ]');
  splitscreen (17);
  top;
  clrscr;
  specialcommand:=false;
  x:=1;
  y:=2;
  writetop;
  movebox (x,y);
  movebar (x,'S');
  quit:=false;
  repeat
   c:=bioskey;
   case ord(c) of
    27:begin
        quit:=true;
        scom:='Q';
       end;
    13:scom:=processcommand;
    208:movedown (x,y);
    200:moveup (x,y);
    203:moveleft (x,y);
    205:moveright (x,y);
    199:begin
         y:=2;
         movebox (x,y);
         movebar (x,'S');
        end;
    207:begin
         if x>1 then y:=5 else y:=11;
         movebox (x,y);
         movebar (x,'S');
        end;
   end;
  until quit;
  cursor (1);
  bottomline;
  specialcommand:=scom in ['Q','S','Z','D','2','C','E'];
  unsplit
end;

procedure specialseries;
begin
  repeat until specialcommand
end;

procedure chat (gotospecial:boolean);
var k:char;
    cnt,displaywid:integer;
    quit,carrierloss,fromkbd:boolean;
    baudstr,commstr:mstr;

                       (*--Variable Definitions----*)


    xsys     :byte;       (*--X location of cursor for sysop--*)
    ysys     :byte;       (*--Y locaiton of cursor for sysop--*)
    xusr     :byte;       (*--X location of cursor for user---*)
    yusr     :byte;       (*--Y location of cursor for user---*)
    curcolor :byte;       (*--Stores current typists color----*)
    ec       :byte;       (*--Stores old color for speed inc--*)
    initi    :boolean;    (*--Amount of times of initia-------*)
    linebufs :string[80]; (*--Storage of what sysop types-----*)
    linebufu :string[80]; (*--Storage of what usr types-------*)

(*-Initialization of all the variables takes place-------------------------*)
procedure init;
begin
  xsys     :=1;
  ysys     :=4;
  xusr     :=1;
  yusr     :=14;
  curcolor :=1;
  ec       :=1;
  initi    :=true;
  linebufs :='';
  linebufu :='';
end;


(*-Sends to screen location X,Y depending on values passed as X,Y----------*)
procedure sendxy (x,y:byte);
begin
 write(#27+'[',y,';',x,'f');

end;


(*-Clears entire screen via esc[2J-----------------------------------------*)
Procedure clearscre;
var i:byte;
 begin
for I:=4 to 22 do
  begin
   sendxy(1,i);
   write(#27'[K');
  end;
 end;


(*-Sets color if color is same as old, increases speed by not re-setting it*)
Procedure setc;
begin
   if fromkbd then ec:=urec.statcolor else ec:=urec.inputcolor;
   if curcolor<>ec then begin
   curcolor:=ec;
   modeminlock:=true;
   ansicolor (curcolor);
   modeminlock:=false;
  end;
end;

function parsedate (date:anystr):lstr;
const months: array[1..12] of string[3]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');

var m,d,y,inc,gog:sstr;
    year,month,day,dayofweek:word;
begin
 if length(date)<>8 then begin
  parsedate:=date;
  exit;
 end else
 begin
  m:=copy (date,1,2);
  d:=copy (date,4,2);
  y:=copy (date,7,2);
  gog:=months[valu(m)];
  getdate (year,month,day,dayofweek);
  inc:=copy (strr(year),1,2);
  parsedate:=gog+' '+d+' '+inc+y;
 end;
end;

(*---Displays middle line in urec.regular color----------------------------*)
 procedure midline;
 begin
   sendxy(1,13);
   write(^R'═══════════════════════════════════════════════════════════════════════════════');
   sendxy(25,13);
   write (^S'[ '^P'TCS '+ver+' - '+parsedate(date)+^S' ]');

   sendxy(trunc((21-length(sysopname))/2),13);
   write (^R'╡ '^S+sysopname+^R' ╞');
   sendxy(trunc((24-length(urec.handle))/2)+52,13);
   write (^R'╡ '^S+urec.handle+^R' ╞');
 end;

(*-Procedure Clears either lines 4-13 or 14-22 depending on WHERE:boo------*)
Procedure cle (malig:byte);
var i    :byte;  (*Loop variable - no usage*)
begin
if malig=0 then
begin
  for i:=4 to 12 do
 begin
  sendxy(1,i);
  write(#27'[K');
 end;
 sendxy(1,4);
 malig:=0;
 midline;
end;  (*  lines 4-12  *)

if malig=1 then
begin
  for i:=14 to 22 do
 begin
  sendxy(1,i);
  write(#27,'[K');
 end;
 sendxy(1,14);
 malig:=0;
 midline;
end;  (*  lines 14-22  *)


(*NOTE:  Line 13 is taken up by the middle line *)

end;



  procedure wordwrapit(yeanea:byte);
  var cnt       :byte;
      wl        :integer;
      ww        :lstr;
      cutarea   :byte;
      done      :boolean;
  begin
   done:=false;
   cutarea:=0;
   cnt:=80;
   if yeanea=0 then
     begin
    repeat
      if not done and (copy(linebufs,cnt,1)=' ') then cutarea:=cnt;
      if (cutarea>0) and not done then
        begin
         ansicolor(urec.statcolor);
         sendxy(cutarea,ysys);
         write(#27'[K');
         inc(ysys);
         xsys:=1;
         sendxy(xsys,ysys);
         write(copy(linebufs,cutarea+1,80-cutarea));
         xsys:=length(copy(linebufs,cutarea+1,80-cutarea))+1;
         sendxy(xsys,ysys);
         dec(ysys);
         done:=true
        end;      (*If loop     *)
      dec(cnt);   (*decrements c*)
     until cnt=1; (*For CNT loop*)
    linebufs:='';
   end;           (*For YEANEA  *)

   if yeanea=1 then
   begin
   done:=false;
   cutarea:=0;
   cnt:=80;
    repeat
      if not done and (copy(linebufu,cnt,1)=' ') then cutarea:=cnt;
      if (cutarea>0) and not done then
        begin
         ansicolor(urec.inputcolor);
         sendxy(cutarea,yusr);
         write(#27'[K');
         inc(yusr);
         xusr:=1;
         sendxy(xusr,yusr);
         write(copy(linebufu,cutarea+1,80-cutarea));
         xusr:=length(copy(linebufu,cutarea+1,80-cutarea))+1;
         sendxy(xusr,yusr);
         dec(yusr);
         done:=true
        end;      (*If loop     *)
      dec(cnt);   (*decrements c*)
     until cnt=1; (*For CNT loop*)
    linebufu:='';
   end;           (*For YEANEA  *)

end;              (*For wordwrap*)


(*---Places cursor at correct position------------------------------------*)
 Procedure locate;
 begin
   if fromkbd then     (*Checks if typed by sysop*)
 begin

   if (xsys=80) and (ysys<12) then     (*Checks if at end of line*)
  begin
   wordwrapit(0);
   inc(ysys);
   if not ysys=13 then linebufs:='';
  end;
  if (ysys=12) and (xsys=80) then
  begin
  cle(0);
  ysys:=4;
  xsys:=1;
  sendxy(xsys,ysys);
  write(linebufs);
  sendxy(80-length(linebufs)+1,ysys);
  wordwrapit(0);
  inc(ysys);
  sendxy(xsys,ysys);
 end;

  sendxy(xsys,ysys);
  inc(xsys);
 end;
   if not fromkbd then     (*Checks if typed by user*)
 begin
   if (xusr=80) and (yusr<22) then     (*Checks if at end of line*)
  begin
   wordwrapit(1);
   inc(yusr);
   if not yusr=23 then linebufu:='';
  end;
if (yusr=22) and (xusr=80) then
 begin
   cle(1);
   yusr:=14;
   xusr:=1;
   sendxy(xusr,yusr);
   write(linebufu);
   sendxy(80-length(linebufu)+1,yusr);
   wordwrapit(1);
   inc(yusr);
   sendxy(xusr,yusr);
 end;

   sendxy(xusr,yusr);
   inc(xusr);
 end;
end;                   (*end of procedure*)

  procedure instruct;
  var i:integer;
  begin
 for i:=1 to 5 do
   begin
     sendxy(1,i);
     write(#27,'[K');
   end;
    splitscreen (3);
    top;
    clrscr;
    write (usr,'Now in Chat mode. Press [F1] to leave or [F2] for commands.');
    initi:=false;
    bottom;
    sendxy(1,4);
  end;


  procedure typedchar (k:char);



  begin

   locate;    (*  Puts cursor in right place *)
   begin;
   if fromkbd then linebufs:=linebufs+K;
   if not fromkbd then linebufu:=linebufu+K;
    setc;      (*  Sets up color for typing   *)
    write(k)
   end;
  end;

begin
  carrierloss:=false;
  chatmode:=false;
  writeln (^B^M);
  if wanted in urec.config then begin
    specialmsg ('(No longer wanted)');
    urec.config:=urec.config-[wanted];
    writeurec;
  end;
  if eightycols in urec.config then displaywid:=80 else displaywid:=40;
  if gotospecial then begin
    specialseries;
    exit
  end;
  clearbreak;
  nobreak:=true;
  writeln (^S'[SysOp Chat Started at ',Timestr(now),']');
  write (^M);
  writeln (^M^M^S,appear,^M^R);
  instruct;
  if not initi then
begin
   init;      (*  Sets up variables          *)
   clearscre; (*  Clears screen lines 4-22   *)
   midline;   (*  Draws middle line for chat *)
end;

  quit:=false;

  repeat
    linecount:=0;
    if (not carrierloss) and (not carrier) then begin
      carrierloss:=true;
      writeln (^M'Warning: There is no carrier present.'^M)

    end;
    repeat until keyhit or (carrier and (numchars>0));
    fromkbd:=keyhit;
    ingetstr:=true;

    read (directin,k);
    if k=#127 then k:=#8;
    if requestchat
      then if requestcom
        then
          begin
            quit:=specialcommand;
            if not quit then instruct;
            clearbreak;
            nobreak:=true;
          end
        else
          begin
            unsplit;

            writeln (^M^M^S,disappear,^M^R);
            write (^M);
             writeln (^S'[SysOp Chat ended at ',timestr(now),']');
            clearscre;
            quit:=true
          end;
    case ord(k) of
      8:begin
      if (xsys>0) and fromkbd then
       begin
          modeminlock:=true;
          dec(xsys);
          sendxy(xsys,ysys);
          write (' ');
          sendxy(xsys,ysys);
          linebufs:=copy(linebufs,1,length(linebufs)-1);
          modeminlock:=false;
        end;
      if (xusr>0) and not fromkbd then
       begin
          modeminlock:=true;
          dec(xusr);
          sendxy(xusr,yusr);
          write (' ');
          sendxy(xsys,ysys);
          linebufu:=copy(linebufu,1,length(linebufu)-1);
          modeminlock:=false;
        end;
     end;
      0:;
      13:begin
           writeln;
           bottomline;
          if fromkbd then begin
           xsys:=1;
           inc(ysys);
             if (ysys=13) and (xusr>-1) then    (*Checks if at end of row *)
              begin
                 cle(0);
                  setc;
                  ysys:=4;
                  xsys:=1;
                  sendxy(xsys,ysys);
                  write(linebufs);
                  ysys:=5;
                  sendxy(xsys,ysys);
                  setc;
              end;
          sendxy(xsys,ysys);
          linebufs:='';
          end;

          if not fromkbd then begin
           xusr:=1;
           inc(yusr);
             if (yusr=23) and (xusr>-1) then    (*Checks if at end of row *)
              begin
                 cle(1);
                  setc;
                  yusr:=14;
                  xusr:=1;
                  sendxy(xusr,yusr);
                  write(linebufu);
                  yusr:=15;
                  sendxy(xusr,yusr);
                  setc;
              end;
            sendxy(xusr,yusr);
          linebufu:='';
          end;
         end;
      32..126:typedchar (k);
      1..31:if fromkbd and carrier then sendchar(k)
    end
  until quit;
  clearbreak
end;

begin
end.