Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SYSPC22.ZIP/ANSIEDIT.PAS

Pascal/Delphi Source File | 1987-12-13 | 18.1 KB | 1,012 lines

(*****

{$C-}

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;

{$IModem.pas}

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;

*****)



overlay function ansireedit (var m:message; gettitle:boolean):boolean;
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 (#27'[');
    if y<>1 then write (strr(y));
    if x<>1 then write (';',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 (#27'[2J')
    else begin
      writevt52 (#27'H'#27'J');
      clrscr
    end
end;

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

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

procedure restorecsr;
begin
  if ansimode
    then write (#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 (#27'[');
    if n<>1 then write (strr(n));
    write (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 crt (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;
    crt (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;
  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;

(****

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
  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))
end.

****)