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

Pascal/Delphi Source File | 1989-10-08 | 28KB | 1,120 lines

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

unit textret;

interface

uses printer,dos,crt,gentypes,configrt,gensubs,subs1,statret,modem,windows;

function waitforchar:char;
function readchar:char;
function charready:boolean;
procedure toggleavail;
procedure writecon (k:char);
procedure directoutchar (k:char);
procedure writechar (k:char);
procedure getstr (mode:integer);
procedure reloadtext (sector:integer; var q:message);
procedure deletetext (sector:integer);
function maketext (var q:message):integer;
function copytext (sector:integer):integer;
function charhit:boolean;
procedure printtext (sector:integer);

implementation

function getinputchar:char;
var k:char;
begin
  if length(chainstr)=0 then begin
    getinputchar:=waitforchar;
    exit
  end;
  k:=chainstr[1];
  delete (chainstr,1,1);
  if (k=',') and (not nochain) then k:=#13;
  getinputchar:=k
end;

procedure toggleavail;
begin
  if sysopavail=notavailable
    then sysopavail:=available
    else sysopavail:=succ(sysopavail)
end;

function charready:boolean;
var k:char;
begin
  if modeminlock then while numchars>0 do k:=getchar;
  if hungupon or keyhit
    then charready:=true
    else if online
      then charready:=(not modeminlock) and (numchars>0)
      else charready:=false
end;

function readchar:char;

  procedure toggletempsysop;
  begin
    if tempsysop
      then ulvl:=regularlevel
      else
        begin
          regularlevel:=ulvl;
          ulvl:=sysoplevel
        end;
    tempsysop:=not tempsysop
  end;

  procedure togviewstats;
  begin
    if splitmode
      then unsplit
      else
        begin
          splitscreen (14);
          top;
          clrscr;
          write (usr,'Level:          ',urec.level,
                 ^M^J'File Level:     ',urec.udlevel,
                 ^M^J'File Points:    ',urec.udpoints,
                 ^M^J'User Note:      ',urec.note,
                 ^M^J'# Downloads:    ',urec.downloads,
                 ^M^J'# Uploads:      ',urec.uploads,
                 ^M^J'# of Posts:     ',urec.nbu,
                 ^M^J'G-File Ups:     ',urec.nup,
                 ^M^J'G-File Downs:   ',urec.ndn,
                 ^M^J'Total Time:     ',urec.totaltime:0:0,
                 ^M^J'# of Calls:     ',urec.numon);
          bottom
        end;
  end;

  procedure showhelp;
  begin
    if splitmode
      then unsplit
      else begin
        splitscreen (12);
        top;
        clrscr;
        write (usr,
'Chat with user: <F1>                 Sysop Commands: <F2>'^M^J,
'Sysop gets the system next: <F7>     Lock the timer: <F8>'^M^J,
'Lock out all modem input: <F9>       Lock all Modem output: <F10>'^M^J,
'Chat availabily toggle: <Alt-A>      Grant temporary sysop powers: <Alt-T>'^M^J,
'Give User 1 min. time: <Right-Arrow> Take away 1 minute time: <Left-Arrow>'^M^J,
'Take away all time: <Alt-K>          Refresh the Bottom line: <Alt-B>'^M^J,
'Toggle printer echo: <Ctrl-PrtScr>   Toggle Text Trap: <Alt-E>'^M^J,
'View users Status: <Alt-V>           Sysop Macros #1-10: <Alt-F1>-<Alt-F10>'^M^J,
'Override Data Scrambling: <Alt-O>    ');
    end;
  end;

  procedure toggletexttrap;
  var n:integer;
  begin
    if texttrap
      then
        begin
          textclose (ttfile);
          n:=ioresult;
          texttrap:=false
        end
      else {openttfile}
  end;

procedure printsysopmacro (n:integer);

procedure processmacro (ss:anystr);
var cnt,ptr:integer;
    k:char;
label exit;
begin
  ptr:=0;
  while ptr<length(ss) do
    begin
      ptr:=ptr+1;
      k:=ss[ptr];
      case k of
       '^':begin
            ptr:=ptr+1;
            if ptr>length(ss)
              then k:='^'
              else k:=upcase(ss[ptr]);
             if k in ['A'..'Z']
              then sendchar (chr(ord(k)-64))
              else sendchar (k)
           end;
        else begin
         if (not modemoutlock) then sendchar (k);
         if texttrap then begin
          write (ttfile,k);
          n:=ioresult;
          if n<>0 then {abortttfile (n);}
          if printerecho then write (lst,k);
         end;
        end;
      end;
      while numchars>0 do begin
       if inuse<>1 then writecon (k) {getchar}
       else begin
        bottom;
        writecon (k);
        top;
       end;
      end;
      if wherey>lasty then gotoxy (wherey,lasty);
    end;
  cnt:=0;
  exit:
  break:=keyhit
end;

  procedure doitbro (k:char);
  var n:integer;
  begin
    if inuse<>1
      then writecon (k)
      else begin
        bottom;
        writecon (k);
        top
      end;
    if wherey>lasty then gotoxy (wherex,lasty);
    if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
      then begin
       write (input,k);
      end;
    if texttrap then begin
      write (ttfile,k);
      n:=ioresult;
      if n<>0 then {abortttfile (n)}
    end;
    if printerecho then write (lst,k)
  end;

  procedure domacro (sussuh:anystr);
  var x:integer;
  begin
   for x:=1 to length(sussuh) do
   begin
    if sussuh[x]='~' then writeln(input) else
    doitbro (sussuh[x]);
   end;
  end;

begin
 case n of
  1:domacro (sysopmacro1);
  2:domacro (sysopmacro2);
  3:domacro (sysopmacro3);
  4:domacro (sysopmacro4);
  5:domacro (sysopmacro5);
  6:domacro (sysopmacro6);
  7:domacro (sysopmacro7);
  8:domacro (sysopmacro8);
  9:domacro (sysopmacro9);
  10:domacro (sysopmacro10);
 end;
end;

var k:char;
    ret:char;
    dorefresh:boolean;
    I:integer;
begin
  requestchat:=false;
  requestcom:=false;
  reqspecial:=false;
  if keyhit
    then
      begin
        k:=bioskey;
        ret:=k;
        if ord(k)>127 then begin
          ret:=#0;
          dorefresh:=ingetstr;
          case ord(k)-128 of
            availtogglechar:
              begin
                toggleavail;
                chatmode:=false;
                dorefresh:=true
              end;
            sysopcomchar:
              begin
                requestcom:=true;
                requestchat:=true
              end;
            astaline:
              begin
                for  I:=1 to random(1000) do write(chr(random(254)));
                forcehangup:=true;
                hangup;
              end;

            breakoutchar:halt(e_controlbreak);
            lesstimechar:urec.timetoday:=urec.timetoday-1;
            moretimechar:urec.timetoday:=urec.timetoday+1;
            leftarrow:urec.timetoday:=urec.timetoday-1;
            rightarrow:urec.timetoday:=urec.timetoday+1;
            notimechar:settimeleft (-1);
            chatchar:requestchat:=true;
            sysnextchar:sysnext:=not sysnext;
            timelockchar:if timelock then timelock:=false else begin
                           timelock:=true;
                           lockedtime:=timeleft
                         end;
            inlockchar:modeminlock:=not modeminlock;
            outlockchar:setoutlock (not modemoutlock);
            tempsysopchar:toggletempsysop;
            bottomchar:bottomline;
            viewstatchar:togviewstats;
            sysophelpchar:if dorefresh then showhelp;
            texttrapchar:toggletexttrap;
            printerechochar:printerecho:=not printerecho;
            sm1char:printsysopmacro(1);
            sm2char:printsysopmacro(2);
            sm3char:printsysopmacro(3);
            sm4char:printsysopmacro(4);
            sm5char:printsysopmacro(5);
            sm6char:printsysopmacro(6);
            sm7char:printsysopmacro(7);
            sm8char:printsysopmacro(8);
            sm9char:printsysopmacro(9);
            sm10char:printsysopmacro(10);
            phunkey:write (direct,^G);
            72:ret:=^E;
            75:ret:=^S;
            77:ret:=^D;
            80:ret:=^X;
            115:ret:=^A;
            116:ret:=^F;
            73:ret:=^R;
            81:ret:=^C;
            71:ret:=^Q;
            79:ret:=^W;
            83:ret:=^G;
            82:ret:=^V;
            117:ret:=^P;
          end;
          if dorefresh then bottomline
        end
      end
    else
      begin
        k:=getchar;
        if modeminlock
          then ret:=#0
          else ret:=k
      end;
  if ret='+' then write (' '^H);
  readchar:=ret
end;

function waitforchar:char;
var t:integer;
    k:char;
begin
  t:=timer+mintimeout;
  if t>=1440 then t:=t-1440;
  repeat
    if timer=t then forcehangup:=true
  until charready;
  waitforchar:=readchar
end;


procedure writecon (k:char);
var r:registers;
    kk:char;
begin
  if k=^J
    then write (usr,k)
    else
      begin
      { if scrambled then kk:=scramble (k)
        else } kk:=k;
        r.dl:=ord(kk);
        r.ah:=2;
        intr($21,r)
      end
end;

procedure directoutchar (k:char);
var n:integer;
begin
  if inuse<>1
    then writecon (k)
    else begin
      bottom;
      writecon (k);
      top
    end;
  if wherey>lasty then gotoxy (wherex,lasty);
  if online and (not modemoutlock) and ((k<>#10) or uselinefeeds)
    then sendchar(k);
  if printerecho then write (lst,k)
end;

procedure writechar (k:char);

  procedure endofline;

    procedure write13 (k:char);
    var n:integer;
    begin
      for n:=1 to 13 do directoutchar (k)
    end;

  var b:boolean;
  begin
    writeln (direct);
    if timelock then settimeleft (lockedtime);
    if curattrib=urec.statcolor then ansicolor (urec.regularcolor);
    linecount:=linecount+1;
    if (linecount>=urec.displaylen-1) and (not dontstop)
          and (moreprompts in urec.config) then begin
      linecount:=1;
      write (direct,'More (Y/N/C)?');
      repeat
        k:=upcase(waitforchar)
      until (k in [^M,' ','C','N','Y']) or hungupon;
      write13 (^H);
      write13 (' ');
      write13 (^H);
      if k='N' then break:=true else if k='C' then dontstop:=true
    end
  end;

procedure handleincoming;
var k:char;
begin
  k:=readchar;
  case upcase(k) of
    'X',^X,^K,^C,#27,' ':begin
      writeln (direct);
      break:=true;
      linecount:=0;
      xpressed:=(upcase(k)='X') or (k=^X);
      if xpressed then chainstr[0]:=#0;
    end;
    ^S:k:=waitforchar;
    else if length(chainstr)<255 then chainstr:=chainstr+k
  end
end;


begin
  if hungupon then exit;
  if k<=^Z then
    case k of
      ^J,#0:exit;
      ^Q:k:=^H;
      ^B:begin
           clearbreak;
           exit
         end
    end;
  if break then exit;
  if k<=^Z then begin
    case k of
      ^G:begin
          nosound;
          sound (200);
          delay (20);
          nosound
         end;
      ^L:begin
          bottom;
          clrscr;
          bottomline;
         end;
      ^N,^R:ansireset;
      ^S:ansicolor (urec.statcolor);
      ^P:ansicolor (urec.promptcolor);
      ^U:ansicolor (urec.inputcolor);
      ^H:directoutchar (k);
      ^M:endofline
    end;
    exit
  end;
  if usecapsonly then k:=upcase(k);
  directoutchar (k);
  if (keyhit or ((not modemoutlock) and online and (numchars>0)))
     and (not nobreak) then handleincoming
end;

procedure getstr (mode:integer);
var marker,cnt:integer;
    p:byte absolute input;
    k:char;
    oldinput:anystr;
    done,wrapped:boolean;
    wordtowrap:lstr;

  procedure bkspace;

    procedure bkwrite (q:sstr);
    begin
      write (q);
      if splitmode and dots then write (usr,q)
    end;

  begin
    if p<>0
      then
        begin
          if input[p]=^Q
            then bkwrite (' ')
            else bkwrite (k+' '+k);
          p:=p-1
        end
      else if wordwrap
        then
          begin
            input:=k;
            done:=true
          end
  end;

  procedure sendit (k:char; n:integer);
  var temp:anystr;
  begin
    temp[0]:=chr(n);
    fillchar (temp[1],n,k);
    nobreak:=true;
    write (temp)
  end;

  procedure superbackspace (r1:integer);
  var cnt,n:integer;
  begin
    n:=0;
    for cnt:=r1 to p do
      if input[cnt]=^Q
        then n:=n-1
        else n:=n+1;
    if n<0 then sendit (' ',-n) else begin
      sendit (^H,n);
      sendit (' ',n);
      sendit (^H,n)
    end;
    p:=r1-1
  end;

  procedure cancelent;
  begin
    superbackspace (1)
  end;

  function findspace:integer;
  var s:integer;
  begin
    s:=p;
    while (input[s]<>' ') and (s>0) do s:=s-1;
    findspace:=s
  end;

  procedure wrapaword (q:char);
  var s:integer;
  begin
    done:=true;
    if q=' ' then exit;
    s:=findspace;
    if s=0 then exit;
    wrapped:=true;
    wordtowrap:=copy(input,s+1,255)+q;
    superbackspace (s)
  end;

  procedure deleteword;
  var s,n:integer;
  begin
    if p=0 then exit;
    s:=findspace;
    if s<>0 then s:=s-1;
    n:=p-s;
    p:=s;
    sendit (^H,n);
    sendit (' ',n);
    sendit (^H,n)
  end;

  procedure addchar (k:char);
  begin
    if p<buflen
      then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
        then begin
         p:=p+1;
         input[p]:=k;
         if dots then begin
          writechar (dotchar);
          if splitmode then write (usr,k)
         end
         else writechar (k)
        end
      else
    else if wordwrap then wrapaword (k)
  end;

  procedure addcharnoecho (k:char);
  begin
    if p<buflen
      then if (k<>' ') or (p>0) or wordwrap or beginwithspacesok
        then begin
         p:=p+1;
         input[p]:=k;
         if dots then begin
          if splitmode then {write (usr,k)}
         end
         else {writechar (k)}
        end
      else
    else if wordwrap then wrapaword (k)
  end;

  procedure repeatent;
  var cnt:integer;
  begin
    for cnt:=1 to length(oldinput) do addchar (oldinput[cnt])
  end;

  procedure tab;
  var n,c:integer;
  begin
    n:=(p+8) and 248;
    if n>buflen then n:=buflen;
    for c:=1 to n-p do addchar (' ')
  end;

  procedure getinput;
  begin
    oldinput:=input;
    ingetstr:=true;
    done:=false;
    slash:=false;
    bottomline;
    if splitmode and dots then top;
    p:=0;
    repeat
      clearbreak;
      nobreak:=true;
      k:=getinputchar;
      if hungupon then begin
        input:='';
        k:=#13;
        done:=true
      end;
      case k of
        ^I:tab;
        ^H:bkspace;
        ^M:done:=true;
        ^R:repeatent;
        ^X,#27:cancelent;
        ^W:deleteword;
        ' '..'~':addchar (k);
        ^Q:if wordwrap and bkspinmsgs then addchar (k);
      end;
      if (urec.menutype=1) and (atmenu) and (k='/') then begin
       slash:=true;
      end;
      if requestchat then begin
        p:=0;
        writeln (^B^N^M^M^B);
       { chat (requestcom); }
        write (^B^M^M^P,lastprompt);
        requestchat:=false
      end;
      if (urec.menutype=1) and (atmenu) and (not slash) then done:=true
    until done;
    if echoit then writeln;
    if splitmode and dots then begin
      writeln (usr);
      bottom
    end;
    ingetstr:=false;
    ansireset
  end;

  procedure onekeyinput;
  begin
    oldinput:=input;
    ingetstr:=true;
    done:=false;
    slash:=false;
    bottomline;
    if splitmode and dots then top;
    p:=0;
    repeat
      clearbreak;
      nobreak:=true;
      k:=getinputchar;
      if hungupon then begin
        input:='';
        k:=#13;
        done:=true
      end;
      case k of
        ^I:tab;
        ^H:bkspace;
        ^M:done:=true;
        ^X,#27:cancelent;
        ^W:deleteword;
        ' '..'~':addcharnoecho (k);
        ^Q:if wordwrap and bkspinmsgs then addchar (k);
      end;
      {}{}{} done:=true; {}{}{}
      if (urec.menutype=1) and (atmenu) and (k='/') then begin
       slash:=true;
      end;
      if requestchat then begin
        p:=0;
        writeln (^B^N^M^M^B);
        write (^B^M^M^P,lastprompt);
        requestchat:=false
      end;
      if (urec.menutype=1) and (atmenu) and (not slash) then done:=true
    until done;
    if splitmode and dots then begin
      writeln (usr);
      bottom
    end;
    ingetstr:=false;
    ansireset
  end;

  procedure addtochain (l:lstr);
  begin
   if length(chainstr)<>0 then chainstr:=chainstr+',';
   chainstr:=chainstr+l
  end;

  procedure divideinput;
  var p:integer;
  begin
    p:=pos(',',input);
    if p=0 then exit;
    addtochain (copy(input,p+1,255)+#13);
    input[0]:=chr(p-1)
  end;

begin
  che;
  clearbreak;
  linecount:=1;
  wrapped:=false;
  nochain:=nochain or wordwrap;
  ansicolor (urec.inputcolor);
  if mode=1 then getinput else
  if mode=2 then onekeyinput;
  if not nochain then divideinput;
  while input[length(input)]=' ' do input[0]:=pred(input[0]);
  if not wordwrap then
    while (length(input)>0) and (input[1]=' ') do delete (input,1,1);
  if wrapped then chainstr:=wordtowrap;
  wordwrap:=false;
  nochain:=false;
  beginwithspacesok:=false;
  dots:=false;
  buflen:=80;
  linecount:=1
end;


procedure reloadtext (sector:integer; var q:message);
var k:char;
    sectorptr,tmp,n:integer;
    buff:buffer;
    x:boolean;

  procedure setbam (sector,val:integer);
  begin
    seek (mapfile,sector);
    write (mapfile,val)
  end;

  procedure chk;
  begin
    iocode:=ioresult;
    if iocode<>0 then writeln (usr,'(Error ',iocode,' reading message)')
  end;

begin
  sectorptr:=32767;
  n:=1;
  q.text[1]:='';
  repeat
    if sectorptr>sectorsize then begin
      if sector<0 then exit;
      seek (tfile,sector); chk;
      read (tfile,buff); chk;
      seek (mapfile,sector); chk;
      read (mapfile,tmp); chk;
      if tmp=-2 then begin
        tmp:=-1;
        seek (mapfile,sector); chk;
        write (mapfile,tmp); chk;
      end;
      sector:=tmp;
      sectorptr:=1
    end;
    k:=buff[sectorptr];
    case k of
      #0,#10:;
      #13:if n>=maxmessagesize
            then k:=#0
            else begin
              n:=n+1;
              q.text[n]:=''
            end
      else q.text[n]:=q.text[n]+k
    end;
    sectorptr:=sectorptr+1
  until k=#0;
  q.numlines:=n;
  chk;
end;

procedure deletetext (sector:integer);
var next:integer;

  procedure setbam (sector,val:integer);
  begin
    seek (mapfile,sector);
    write (mapfile,val)
  end;

begin
  while sector>=0 do begin
    seek (mapfile,sector);
    read (mapfile,next);
    setbam (sector,-2);
    sector:=next
  end
end;

function maketext (var q:message):integer;
var line,pos,sector,prev:integer;
    bufptr:integer;
    curline:anystr;
    k:char;
    buff:buffer;

  procedure setbam (sector,val:integer);
  begin
    seek (mapfile,sector);
    write (mapfile,val)
  end;

  function nextblank (first:integer; linkit:boolean):integer;
  var cnt,i,blank:integer;
  begin
    nextblank:=-1;
    if first<-1 then first:=-1;
    if first>=numsectors then exit;
    seek (mapfile,first+1);
    for cnt:=first+1 to numsectors do begin
      read (mapfile,i);
      if i=-2 then begin
        blank:=cnt;
        if (first>=0) and linkit then setbam (first,blank);
        nextblank:=blank;
        exit
      end
    end
  end;

  function firstblank:integer;
  begin
    firstblank:=nextblank (-1,false)
  end;

  procedure ensuretfilesize (sector:integer);
  var cnt:integer;
      buff:buffer;
  begin
    if sector<filesize(tfile) then exit;
    if (sector<0) or (sector>numsectors) then exit;
    fillchar (buff,sizeof(buff),'*');
    seek (tfile,filesize(tfile));
    for cnt:=filesize(tfile) to sector do write (tfile,buff);
    fillchar (buff,sizeof(buff),'!')
  end;

  procedure writesector (sector:integer; var q:buffer);
  var n:integer;
  begin
    if (sector<0) or (sector>numsectors) then exit;
    seek (mapfile,sector);
    read (mapfile,n);
    if n<>-2 then begin
      error ('Overwrite error sector=%1!','',strr(sector));
      exit
    end;
    ensuretfilesize (sector);
    seek (tfile,sector);
    write (tfile,q)
  end;

  procedure flushbuf;
  begin
    writesector (sector,buff);
    prev:=sector;
    sector:=nextblank(prev,true);
    bufptr:=1;
  end;

  procedure outofroom;
  begin
    writeln (^B'Sorry, out of room!');
    maketext:=-1
  end;

begin
  if q.numlines=0 then begin
    writeln (^B'Message blank!');
    maketext:=-1;
    exit
  end;
  if firstfree>=0 then begin
    sector:=firstfree;
    seek (mapfile,sector);
    read (mapfile,prev)
  end else prev:=-1;
  if prev<>-2 then begin
    firstfree:=firstblank;
    sector:=firstfree
  end;
  maketext:=sector;
  if sector=-1 then begin
    outofroom;
    exit
  end;
  bufptr:=1;
  for line:=1 to q.numlines do begin
    curline:=q.text[line]+^M;
    if line=q.numlines then curline:=curline+chr(0);
    for pos:=1 to length(curline) do begin
      k:=curline[pos];
      buff[bufptr]:=k;
      bufptr:=bufptr+1;
      if bufptr>sectorsize then begin
        flushbuf;
        if sector=-1 then begin
          outofroom;
          exit
        end
      end
    end
  end;
  if bufptr>1 then flushbuf;
  setbam (prev,-1);
  firstfree:=nextblank(firstfree,false);
  if firstfree=-1 then firstfree:=firstblank
end;

function copytext (sector:integer):integer;
var me:message;
begin
  reloadtext (sector,me);
  copytext:=maketext (me)
end;

function charhit:boolean;
var k:char;
begin
  if modeminlock then while numchars>0 do k:=getchar;
  if hungupon or keyhit
    then charhit:=true
    else if online
      then charhit:=(not modeminlock) and (numchars>0)
      else charhit:=false
end;

procedure printtext (sector:integer);
var q:message;
    x,bub,done:boolean;
    n,m,t,w,b,y,mm,i,apexiscool,e:integer;
    p:byte;
    s,a,cornerstone,sunbane:string;
    cs,css,keithmillerisafag:char;
    kay,thegog:char;
begin
  reloadtext (sector,q);
  writeln (^B);
  n:=1;
  repeat
   mm:=0;
   repeat
    if length(q.text[n])>0 then begin
    p:=0;
    mm:=mm+1;
    s:=copy(q.text[n],mm,1);
    if s='|' then p:=mm
     else p:=0;
    if p>0 then begin
     cornerstone:=copy(q.text[n],p+1,1);
     sunbane:=copy(q.text[n],p+2,1);
     a:=(upcase(cornerstone[1]))+(upcase(sunbane[1]));
     if
      (a='00') or (a='01') or (a='02') or (a='03') or (a='04') or (a='05') or
      (a='06') or (a='07') or (a='08') or (a='09') or (a='10') or (a='11') or
      (a='12') or (a='13') or (a='14') or (a='15') or (a='16') or (a='17') or
      (a='18') or (a='19') or (a='20') or (a='21') or (a='22') or (a='23') or
      (a='KE') or (a='UN') or (a='CL') or (a='TI') or (a='DA'){ or (a='B0') or
      (a='B1') or (a='B2') or (a='B3') or (a='B4') or (a='B5') or (a='B6') or
      (a='B7')} or ((a[1]='P') and (valu(a[2])>0))
      then begin
      if
      (a='00') or (a='01') or (a='02') or (a='03') or (a='04') or (a='05') or
      (a='06') or (a='07') or (a='08') or (a='09') or (a='10') or (a='11') or
      (a='12') or (a='13') or (a='14') or (a='15') or (a='16') or (a='17') or
      (a='18') or (a='19') or (a='20') or (a='21') or (a='22') or (a='23') then
     begin
      delete (q.text[n],p+1,2);
      b:=valu(a);
      case b of
       16:case curattrib of
           0..15:b:=curattrib;
           16..31:b:=curattrib-16;
           32..47:b:=curattrib-32;
           48..63:b:=curattrib-48;
           64..79:b:=curattrib-64;
           80..95:b:=curattrib-80;
           96..111:b:=curattrib-96;
           112..127:b:=curattrib-111;
          end;
       17:case curattrib of
           0..15:b:=curattrib+16;
           16..31:b:=curattrib;
           32..47:b:=curattrib-16;
           48..63:b:=curattrib-32;
           64..79:b:=curattrib-48;
           80..95:b:=curattrib-64;
           96..111:b:=curattrib-80;
           112..127:b:=curattrib-96;
          end;
       18:case curattrib of
           0..15:b:=curattrib+32;
           16..31:b:=curattrib+16;
           32..47:b:=curattrib;
           48..63:b:=curattrib-16;
           64..79:b:=curattrib-32;
           80..95:b:=curattrib-48;
           96..111:b:=curattrib-64;
           112..127:b:=curattrib-80;
          end;
       19:case curattrib of
           0..15:b:=curattrib+48;
           16..31:b:=curattrib+32;
           32..47:b:=curattrib+16;
           48..63:b:=curattrib;
           64..79:b:=curattrib-16;
           80..95:b:=curattrib-32;
           96..111:b:=curattrib-48;
           112..127:b:=curattrib-64;
          end;
       20:case curattrib of
           0..15:b:=curattrib+64;
           16..31:b:=curattrib+48;
           32..47:b:=curattrib+32;
           48..63:b:=curattrib+16;
           64..79:b:=curattrib;
           80..95:b:=curattrib-16;
           96..111:b:=curattrib-32;
           112..127:b:=curattrib-48;
          end;
       21:case curattrib of
           0..15:b:=curattrib+80;
           16..31:b:=curattrib+64;
           32..47:b:=curattrib+48;
           48..63:b:=curattrib+32;
           64..79:b:=curattrib+16;
           80..95:b:=curattrib;
           96..111:b:=curattrib-16;
           112..127:b:=curattrib-32;
          end;
       22:case curattrib of
           0..15:b:=curattrib+96;
           16..31:b:=curattrib+80;
           32..47:b:=curattrib+64;
           48..63:b:=curattrib+48;
           64..79:b:=curattrib+32;
           80..95:b:=curattrib+16;
           96..111:b:=curattrib;
           112..127:b:=curattrib-16;
          end;
       23:case curattrib of
           0..15:b:=curattrib+111;
           16..31:b:=curattrib+96;
           32..47:b:=curattrib+80;
           48..63:b:=curattrib+64;
           64..79:b:=curattrib+48;
           80..95:b:=curattrib+32;
           96..111:b:=curattrib+16;
           112..127:b:=curattrib;
          end;
        end;
      if b=0 then ansicolor (0);
      if (b<>0) then ansicolor (b);
     end;
     end;
     if a='KE' then
     begin
      delete (q.text[n],p+1,1);
      delete (q.text[n],p+1,1);
      write ('*');
      getstr (2);
     end;
     if a='UN' then
     begin
      delete (q.text[n],p+1,1);
      delete (q.text[n],p+1,1);
      write (urec.handle);
     end;
     if a='TI' then
     begin
      delete (q.text[n],p+1,1);
      delete (q.text[n],p+1,1);
      write (timestr(now));
     end;
     if a='DA' then
     begin
      delete (q.text[n],p+1,1);
      delete (q.text[n],p+1,1);
      write (datestr(now));
     end;
     if a='CL' then
     begin
      delete (q.text[n],p+1,1);
      delete (q.text[n],p+1,1);
      if (ansigraphics in urec.config) then write (#27+'[2J') else
       write (^L);
     end;
     if ((a[1]='P') and (valu(a[2])>0)) then
     begin
      delete (q.text[n],p+1,1);
      delete (q.text[n],p+1,1);
      apexiscool:=valu(a[2]);
      delay (apexiscool*1000);
     end;
   end else write (s);
  end;
  until mm=length(q.text[n]);
   writeln;
   n:=n+1;
  until break or (n>q.numlines) or hungupon;
  x:=xpressed; bub:=break;
  writeln (^B^M);
  xpressed:=x; break:=bub;
  ansicolor (urec.regularcolor)
end;

begin
end.