Jason Aller Floppy Collection/276.img/FORUM21S.ZIP/ANSIEDIT.PAS

Pascal/Delphi Source File | 1988-02-13 | 20KB | 1,038 lines

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

{$ifdef testansieditor}
{*}
{*} {*} indicates test code
{*}
{*}uses crt,modem;
{*}
{*}const maxmessagesize=100;
{*}      hungupon=false;
{*}
{*}type anystr=string[255];
{*}     lstr=string[80];
{*}     mstr=string[30];
{*}     sstr=string[15];
{*}
{*}     message=record
{*}       text:array [1..maxmessagesize] of lstr;
{*}       title:mstr;
{*}       anon:boolean;
{*}       numlines:integer
{*}     end;
{*}
{*}     regs=record
{*}       case byte of
{*}         0:(ax,bx,cx,dx,bp,si,di,ds,es,flags:integer);
{*}         1:(al,ah,bl,bh,cl,ch,dl,dh:byte)
{*}     end;
{*}
{*}type configtype=(moreprompts,eightycols,ansigraphics);
{*}
{*}var input:anystr;
{*}    nobreak:boolean;
{*}    urec:record
{*}      displaylen:integer;
{*}      config:set of configtype
{*}    end;
{*}    winds:array [0..0] of record y2:integer end;
{*}
{*}
{*}function strr (n:integer):mstr;
{*}var q:mstr;
{*}begin
{*}  str (n,q);
{*}  strr:=q
{*}end;
{*}
{*}function waitforchar:char;
{*}var k:char;
{*}begin
{*}  repeat until keypressed or (numchars>0);
{*}  read (kbd,k);
{*}  waitforchar:=k
{*}end;
{*}
{*}procedure clearbreak;
{*}begin
{*}end;
{*}
{*}function yes:boolean;
{*}begin
{*}  yes:=false;
{*}  if length(input)>0
{*}    then if upcase(input[1])='Y'
{*}      then yes:=true
{*}end;
{*}
{*}function readchar:char;
{*}var r:regs;
{*}begin
{*}  if keypressed then begin
{*}    r.ah:=0;
{*}    intr ($16,r);
{*}    readchar:=chr(r.al);
{*}    if r.al=29 then halt;
{*}    if r.al=0 then case r.ah of
{*}      72:readchar:=^E;
{*}      75:readchar:=^S;
{*}      77:readchar:=^D;
{*}      80:readchar:=^X;
{*}      115:readchar:=^A;
{*}      116:readchar:=^F;
{*}      73:readchar:=^R;
{*}      81:readchar:=^C;
{*}      71:readchar:=^Q;
{*}      79:readchar:=^W;
{*}      83:readchar:=^G;
{*}      82:readchar:=^V;
{*}      117:readchar:=^P;
{*}    end;
{*}    exit
{*}  end;
{*}  if (numchars>0) and carrier
{*}    then readchar:=getchar
{*}    else readchar:=#0
{*}end;
{*}
{*}procedure writeturbo (k:char);
{*}begin
{*}  inline ($8A/$86/k/$50/$ff/$16/usroutptr)
{*}end;
{*}
{*}procedure writechar (k:char);
{*}var r:regs;
{*}begin
{*}  if k=^J then writeturbo (k) else begin
{*}    r.dl:=ord(k);
{*}    r.ah:=2;
{*}    intr ($21,r)
{*}  end;
{*}  if carrier then sendchar (k)
{*}end;
{*}
{*}procedure getstr;
{*}begin
{*}  readln (input)
{*}end;
{*}
{*}procedure printfile (l:lstr);
{*}begin
{*}end;
{*}
{*}procedure wholescreen;
{*}begin
{*}  window (1,1,80,winds[0].y2)
{*}end;
{*}
{*}procedure bottom;
{*}begin
{*}end;
{*}
{*}procedure bottomline;
{*}begin
{*}end;
{*}
{*}procedure unsplit;
{*}begin
{*}end;
{*}
{*}function ansireedit (var m:message; gettitle:boolean):boolean;
{*}
{$else}

unit ansiedit;

interface

uses crt,
     gentypes,modem,configrt,windows,gensubs,subs1,subs2;

function ansireedit (var m:message; gettitle:boolean):boolean;

implementation

function ansireedit (var m:message; gettitle:boolean):boolean;

{$endif}

var topline,curline,cx,cy,cols,scrnsize,lines,
    rightmargin,savedx,savedy,topscrn:integer;
    insertmode,msgdone,ansimode:boolean;

function curx:integer;
begin
  curx:=wherex
end;

function cury:integer;
begin
  cury:=wherey-topscrn+1
end;

procedure writevt52 (q:lstr);
var cnt:integer;
begin
  if not carrier then exit;
  for cnt:=1 to length(q) do sendchar (q[cnt])
end;

procedure moveto (x,y:integer);
begin
  y:=y+topscrn-1;
  if ansimode then begin
    write (direct,#27'[');
    if y<>1 then write (direct,strr(y));
    if x<>1 then write (direct,';',strr(x));
    write ('H')
  end else begin
    gotoxy (x,y);
    writevt52 (#27'Y'+chr(y+31)+chr(x+31))
  end
end;

procedure clearscr;
begin
  if ansimode
    then write (direct,#27'[2J')
    else begin
      writevt52 (#27'H'#27'J');
      clrscr
    end
end;

procedure cleareol;
begin
  if ansimode
    then write (direct,#27'[K')
    else begin
      writevt52 (#27'K');
      clreol
    end
end;

procedure savecsr;
begin
  if ansimode
    then write (direct,#27'[s')
    else begin
      savedx:=curx;
      savedy:=cury
    end
end;

procedure restorecsr;
begin
  if ansimode
    then write (direct,#27'[u')
    else moveto (savedx,savedy)
end;

procedure cmove (k:char; n,dx,dy:integer);
var cnt:integer;
begin
  if n<1 then exit;
  if ansimode then begin
    write (direct,#27'[');
    if n<>1 then write (direct,strr(n));
    write (direct,k)
  end else
    for cnt:=1 to n do begin
      writevt52 (#27+k);
      gotoxy (wherex+dx,wherey+dy)
    end
end;

procedure cup (n:integer);
begin
  cmove ('A',n,0,-1)
end;

procedure cdn (n:integer);
begin
  cmove ('B',n,0,1)
end;

procedure clf (n:integer);
var cnt:integer;
begin
  cmove ('D',n,-1,0)
end;

procedure crg (n:integer);
begin
  cmove ('C',n,1,0)
end;

procedure checkspaces;
var q:^lstr;
begin
  q:=addr(m.text[curline]);
  while q^[length(q^)]=' ' do q^[0]:=pred(q^[0])
end;

procedure checkcx;
var n:integer;
begin
  n:=length(m.text[curline])+1;
  if cx>n then cx:=n
end;

procedure computecy;
begin
  cy:=curline-topline+1
end;

procedure updatecpos;
begin
  computecy;
  moveto (cx,cy)
end;

procedure insertabove;
var cnt:integer;
begin
  if m.numlines=maxmessagesize then exit;
  for cnt:=m.numlines downto curline do m.text[cnt+1]:=m.text[cnt];
  m.text[curline]:='';
  m.numlines:=m.numlines+1
end;

procedure deletethis;
var cnt:integer;
begin
  if m.numlines=1 then begin
    m.text[1]:='';
    exit
  end;
  for cnt:=curline+1 to m.numlines do m.text[cnt-1]:=m.text[cnt];
  m.text[m.numlines]:='';
  m.numlines:=m.numlines-1;
  checkcx
end;

procedure fullrefresh;
var cnt,n:integer;
begin
  clearscr;
  if topline<1 then topline:=1;
  computecy;
  moveto (1,1);
  for cnt:=1 to lines do begin
    n:=cnt+topline-1;
    if n<=m.numlines then begin
      write (m.text[n]);
      if cnt<>lines then writeln
    end
  end;
  updatecpos
end;

procedure repos (dorefresh:boolean);
var cl,tl:integer;
begin
  checkspaces;
  cl:=curline;
  tl:=topline;
  if curline<1 then curline:=1;
  if curline>m.numlines then curline:=m.numlines;
  if topline>curline then topline:=curline;
  if topline+lines<curline then topline:=curline-lines;
  if topline<1 then topline:=1;
  checkcx;
  computecy;
  if (cl=curline) and (tl=topline) and (not dorefresh)
    then updatecpos
    else fullrefresh
end;

procedure partrefresh;  { Refreshes from CY }
var cnt,n:integer;
begin
  if topline<1 then repos(true) else begin
    moveto (1,cy);
    for cnt:=cy to lines do begin
      n:=cnt+topline-1;
      if n<=m.numlines then write (m.text[n]);
      cleareol;
      if cnt<>lines then writeln
    end;
    updatecpos
  end
end;

procedure pageup;
begin
  checkspaces;
  if curline=1 then exit;
  curline:=curline-lines+4;
  topline:=topline-lines+4;
  repos (true)
end;

procedure pagedn;
begin
  checkspaces;
  if curline=m.numlines then exit;
  curline:=curline+lines-4;
  topline:=topline+lines-4;
  repos (true)
end;

procedure toggleins;
begin
  insertmode:=not insertmode
end;

procedure scrolldown;
begin
  topline:=curline-lines+2;
  repos (true)
end;

procedure scrollup;
begin
  if topline<1 then begin
    topline:=topline+1;
    moveto (1,lines);
    computecy;
    writeln
  end else begin
    topline:=curline-1;
    repos (true)
  end
end;

procedure topofmsg;
begin
  checkspaces;
  cx:=1;
  cy:=1;
  curline:=1;
  if topline=1
    then updatecpos
    else
      begin
        topline:=1;
        fullrefresh
      end
end;

procedure updatetoeol;
var cnt:integer;
begin
  savecsr;
  write (copy(m.text[curline],cx,255));
  cleareol;
  restorecsr
end;

procedure letterkey (k:char);
var l:^lstr;
    w:lstr;
    n,ox:integer;
    q:char;
    inserted,refr:boolean;

  procedure scrollwwrap;
  begin
    if topline>0 then begin
      scrollup;
      exit
    end;
    cy:=cy-1;
    moveto (length(m.text[curline-1])+1,cy);
    cleareol;
    writeln;
    write (m.text[curline]);
    topline:=topline+1;
    cx:=curx
  end;

begin
  l:=addr(m.text[curline]);
  if length(l^)>=rightmargin then begin
    if curline=maxmessagesize then exit;
    if cx<=length(l^) then exit;
    l^:=l^+k;
    w:='';
    cx:=length(l^);
    repeat
      q:=l^[cx];
      if q<>' ' then insert (q,w,1);
      cx:=cx-1
    until (q=' ') or (cx<1);
    if cx<1 then begin
      cx:=length(l^)-1;
      w:=k
    end;
    l^[0]:=chr(cx);
    checkspaces;
    curline:=curline+1;
    if curline>m.numlines then m.numlines:=curline;
    inserted:=m.text[curline]<>'';
    if inserted then insertabove;
    m.text[curline]:=w;
    cy:=cy+1;
    ox:=cx;
    cx:=length(w)+1;
    refr:=cy>lines;
    if refr
      then scrollwwrap
      else begin
        if length(w)>0 then begin
          moveto (ox+1,cy-1);
          for n:=1 to length(w) do write (' ')
        end;
        if inserted and (m.numlines>curline)
          then partrefresh
          else begin
            moveto (1,cy);
            write (m.text[curline]);
          end
      end;
    exit
  end;
  if insertmode
    then insert (k,l^,cx)
    else begin
      while length(l^)<cx do l^:=l^+' ';
      l^[cx]:=k
    end;
  write (k);
  cx:=cx+1;
  if insertmode and (cx<=length(l^)) then updatetoeol
end;

procedure back;
begin
  if cx=1 then begin
    if curline=1 then exit;
    checkspaces;
    curline:=curline-1;
    cy:=cy-1;
    cx:=length(m.text[curline])+1;
    if cy<1 then scrolldown else updatecpos;
  end else begin
    cx:=cx-1;
    clf (1)
  end
end;

procedure fowrd;
begin
  if cx>length(m.text[curline]) then begin
    if curline=maxmessagesize then exit;
    checkspaces;
    curline:=curline+1;
    if curline>m.numlines then m.numlines:=curline;
    cy:=cy+1;
    cx:=1;
    if cy>lines then scrollup else updatecpos
  end else begin
    cx:=cx+1;
    crg (1)
  end
end;

procedure del;
begin
  if length(m.text[curline])=0 then begin
    deletethis;
    partrefresh;
    exit
  end;
  delete (m.text[curline],cx,1);
  if cx>length(m.text[curline])
    then write (' '^H)
    else updatetoeol
end;

procedure bkspace;
begin
  if length(m.text[curline])=0 then begin
    if curline=1 then exit;
    deletethis;
    checkspaces;
    curline:=curline-1;
    cy:=cy-1;
    cx:=length(m.text[curline])+1;
    if cy<1
      then scrolldown
      else partrefresh;
    exit
  end;
  if cx=1 then exit;
  cx:=cx-1;
  write (^H);
  del
end;

procedure beginline;
begin
  if cx=1 then exit;
  cx:=1;
  updatecpos
end;

procedure endline;
var dx:integer;
begin
  dx:=length(m.text[curline])+1;
  if cx=dx then exit;
  cx:=dx;
  updatecpos
end;

procedure upline;
var chx:boolean;
    l:integer;
begin
  checkspaces;
  if curline=1 then exit;
  curline:=curline-1;
  l:=length(m.text[curline]);
  chx:=cx>l;
  if chx then cx:=l+1;
  cy:=cy-1;
  if cy>0
    then if chx
      then updatecpos
      else cup (1)
    else scrolldown
end;

procedure downline;
var chx:boolean;
    l:integer;
begin
  checkspaces;
  if curline=maxmessagesize then exit;
  curline:=curline+1;
  if curline>m.numlines then m.numlines:=curline;
  l:=length(m.text[curline]);
  chx:=cx>l;
  if chx then cx:=l+1;
  cy:=cy+1;
  if cy<=lines
    then if chx
      then updatecpos
      else cdn (1)
    else scrollup
end;

procedure crlf;
var k:char;
begin
  if (length(m.text[curline])=2) and (m.text[curline][1]='/') then begin
    k:=upcase(m.text[curline][2]);
    case k of
      'S':begin
        deletethis;
        msgdone:=true;
        ansireedit:=true;
        exit
      end
    end
  end;
  beginline;
  downline
end;

function conword:boolean;
var l:^lstr;
begin
  l:=addr(m.text[curline]);
  conword:=false;
  if (cx>length(l^)) or (cx=0) then exit;
  conword:=true;
  if cx=1 then exit;
  if (l^[cx-1]=' ') and (l^[cx]<>' ') then exit;
  conword:=false
end;

procedure wordleft;
begin
  repeat
    cx:=cx-1;
    if cx<1 then begin
      if curline=1 then begin
        cx:=1;
        repos (false);
        exit
      end;
      checkspaces;
      curline:=curline-1;
      cy:=cy-1;
      cx:=length(m.text[curline])
    end;
  until conword;
  if cx=0 then cx:=1;
  if cy<1
    then repos (true)
    else updatecpos
end;

procedure wordright;
begin
  repeat
    cx:=cx+1;
    if cx>length(m.text[curline]) then begin
      if curline=m.numlines then begin
        repos (false);
        exit
      end;
      checkspaces;
      curline:=curline+1;
      cy:=cy+1;
      cx:=1
    end;
  until conword;
  if cy>lines
    then repos (true)
    else updatecpos
end;

procedure worddel;
var l:^lstr;
    b:byte;
    s,n:integer;
begin
  l:=addr(m.text[curline]);
  b:=length(l^);
  if cx>b then exit;
  s:=cx;
  repeat
    cx:=cx+1
  until conword or (cx>b);
  n:=cx-s;
  delete (l^,s,n);
  cx:=s;
  updatetoeol
end;

procedure deleteline;
begin
  deletethis;
  partrefresh
end;

procedure insertline;
begin
  if m.numlines>=maxmessagesize then exit;
  insertabove;
  checkcx;
  partrefresh
end;

procedure help;
var k:char;
begin
  clearscr;
  printfile (textfiledir+'Edithelp.ANS');
  write (^B^M'Press any key...');
  k:=waitforchar;
  fullrefresh
end;

procedure breakline;
begin
  if (m.numlines>=maxmessagesize) or (cy=lines) or
    (cx=1) or (cx>length(m.text[curline])) then exit;
  insertabove;
  m.text[curline]:=copy(m.text[curline+1],1,cx-1);
  delete (m.text[curline+1],1,cx-1);
  partrefresh
end;

procedure joinlines;
var n:integer;
begin
  if curline=m.numlines then exit;
  if length(m.text[curline])+length(m.text[curline+1])>rightmargin then exit;
  m.text[curline]:=m.text[curline]+m.text[curline+1];
  n:=cx;
  curline:=curline+1;
  deletethis;
  curline:=curline-1;
  cx:=n;
  partrefresh
end;

procedure userescape;
var k:char;
begin
  repeat
  k:=waitforchar;
    case k of
      'A':upline;
      'B':downline;
      'C':fowrd;
      'D':back
    end
  until (k<>'[') or hungupon
end;

procedure deleteeol;
begin
  cleareol;
  m.text[curline][0]:=chr(cx-1)
end;

procedure tab;
var nx,n,cnt:integer;
begin
  nx:=((cx+8) and 248)+1;
  n:=nx-cx;
  if (n+length(m.text[curline])>=cols) or (nx>=cols) then exit;
  for cnt:=1 to n do insert (' ',m.text[curline],cx);
  updatetoeol;
  cx:=cx+n;
  updatecpos
end;

procedure commands;

  function youaresure:boolean;
  var q:string[1];
  begin
    youaresure:=false;
    moveto (1,0);
    write ('Are you sure? ');
    buflen:=1;
    getstr;
    cup (1);
    write ('               ');
    youaresure:=yes;
    clearbreak;
    nobreak:=true
  end;

  procedure savemes;
  begin
    msgdone:=true;
    ansireedit:=true
  end;

  procedure abortmes;
  begin
    if youaresure then begin
      m.numlines:=0;
      msgdone:=true
    end
  end;

  procedure formattext;
  var ol,il,c:integer;
      oln,wd,iln:lstr;
      k:char;

    procedure putword;
    var cnt:integer;
        b:boolean;
    begin
      b:=true;
      for cnt:=1 to length(wd) do if wd[cnt]<>' ' then b:=false;
      if b then exit;
      while wd[length(wd)]=' ' do wd[0]:=pred(wd[0]);
      if length(wd)=0 then exit;
      if length(wd)+length(oln)>rightmargin then begin
        m.text[ol]:=oln;
        ol:=ol+1;
        while (wd[1]=' ') and (length(wd)>0) do delete (wd,1,1);
        oln:=wd
      end else oln:=oln+wd;
      if wd[length(wd)] in ['.','?','!']
        then wd:='  '
        else wd:=' '
    end;

  begin
    il:=curline;
    ol:=il;
    c:=1;
    oln:='';
    wd:='';
    iln:=m.text[il];
    repeat
      if length(iln)=0 then begin
        putword;
        m.text[ol]:=oln;
        partrefresh;
        checkcx;
        updatecpos;
        exit
      end;
      if c>length(iln) then begin
        il:=il+1;
        if il>m.numlines
          then iln:=''
          else begin
            iln:=m.text[il];
            m.text[il]:=''
          end;
        c:=0;
        k:=' '
      end else k:=iln[c];
      c:=c+1;
      if k=' '
        then putword
        else wd:=wd+k
    until 0=1
  end;

var cmd:string[1];
    k:char;
begin
  clearbreak;
  nobreak:=true;
  moveto (1,0);
  write ('Cmd: ');
  buflen:=1;
  getstr;
  clearbreak;
  nobreak:=true;
  cup (1);
  write ('      ');
  if length(input)=0 then begin
    updatecpos;
    exit
  end;
  k:=upcase(input[1]);
  case k of
    'S':savemes;
    'A':abortmes;
    'F':formattext;
    '?':help
  end;
  updatecpos
end;

procedure processkey;
var k:char;
begin
  clearbreak;
  nobreak:=true;
  k:=waitforchar;
  case k of
    ' '..'~':letterkey (k);
    ^S:back;
    ^D:fowrd;
    ^H:bkspace;
    ^M:crlf;
    ^V:toggleins;
    ^E:upline;
    ^X:downline;
    ^U:help;
    ^K:commands;
    ^R:pageup;
    ^C:pagedn;
    ^G:del;
    ^A:wordleft;
    ^F:wordright;
    ^T:worddel;
    ^Q:beginline;
    ^W:endline;
    ^L:fullrefresh;
    ^Y:deleteline;
    ^N:insertline;
    ^I:tab;
    ^B:breakline;
    ^P:deleteeol;
    ^J:joinlines;
    #27:userescape
  end
end;

var cnt:integer;
    mp:boolean;
begin
  clearbreak;
  nobreak:=true;
  ansireedit:=false;

  for cnt:=m.numlines+1 to maxmessagesize do m.text[cnt]:='';
  scrnsize:=urec.displaylen;
  winds[0].y2:=scrnsize;
  unsplit;
  wholescreen;
  gotoxy (1,25);
  clreol;
  if eightycols in urec.config
    then cols:=80
    else cols:=40;
  ansimode:=ansigraphics in urec.config;
  mp:=moreprompts in urec.config;
  if mp then urec.config:=urec.config-[moreprompts];
  lines:=15;
  topscrn:=scrnsize-lines+1;
  insertmode:=false;
  rightmargin:=cols-1;
  msgdone:=false;
  cx:=1;
  curline:=1;
  topline:=2-lines;
  computecy;
  updatecpos;
  if m.numlines>0
    then fullrefresh
    else
      begin
        writeln (^M'Press ^U for help.'^M);
        m.numlines:=1
      end;
  repeat
    processkey
  until msgdone or hungupon;
  moveto (1,lines);
  cleareol;
  writeln (^M^M^M^M);
  if mp then urec.config:=urec.config+[moreprompts];
  winds[0].y2:=25;
  bottom;
  bottomline
end;


{$ifdef testansieditor}
{*}
{*}procedure termmode;
{*}var k:char;
{*}begin
{*}  setparam (1,1200,false);
{*}  writeln ('Press ^D when connected.');
{*}  repeat
{*}    if keypressed then begin
{*}      read (kbd,k);
{*}      if k=#4 then exit;
{*}      if k=#3 then halt;
{*}      sendchar (k)
{*}    end;
{*}    while numchars>0 do write (getchar)
{*}  until 0=1
{*}end;
{*}
{*}var m:message;
{*}    cnt:integer;
{*}begin
{*}  checkbreak:=false;
{*}  urec.displaylen:=22;
{*}  urec.config:=[eightycols]; { ,ansigraphics]; }
{*}  if not driverpresent then begin
{*}    writeln ('You fool.');
{*}    halt
{*}  end;
{*}  termmode;
{*}  coninptr:=ofs(readchar);
{*}  conoutptr:=ofs(writechar);
{*}  m.numlines:=0;
{*}  for cnt:=1 to 100 do m.text[cnt]:='Hello line '+chr(cnt+64);
{*}  writeln (ansireedit(m,false))
{*}
{$endif}

end.