[inherit ('SYS$LIBRARY:STARLET')]
program figedt (input, output);
const sxdim = 22; pxdim = 132; pydim = 132;
 esc = 27; bel = 7; TAB = 9; cr = 13;
type
 str = varying [pydim] of char;
 line = packed array [1..pydim] of char;
 $word = [word] 0..65535;
 iosb = record status: $word; count: $word; term: $word; termct: $word end;
var cx, cy, ox, oy, lx, ly, nx, ny, mx0, my0, mx1, my1: integer;
 mkct, rs, sydim: integer;
 ichan, ochan: $word; iostat: iosb;
 cmch, c1, c2: char; gold: boolean; ln: str; workflnm: str;
 work: array [1..pxdim] of line; workfl: text;

{ Utility Procedures }
procedure rdln (len: integer);
 begin
  rs := $qiow (, ichan, io$_readvblk + io$m_escape, iostat,,, ln.body, len);
  ln.length := iostat.count
 end;

procedure rddec (ln: str; var indx, val: integer);
 begin val := 0;
  while (indx < length(ln)) and (ln[indx] = ' ') do indx := indx + 1;
  if ln[indx] in ['0'..'9'] then begin
   while (indx < length(ln)) and (ln[indx] in ['0'..'9']) do begin
    val := 10*val + (ord(ln[indx]) - 48); indx := indx + 1 end end
  else val := 1
 end;

function uc (ch: char): char;
 begin
  if ch >= '`' then uc := chr (ord (ch) - 32) else uc := ch
 end;

procedure wrtstr (oln: str);
 begin
  rs := $qiow (,ochan, io$_writevblk,,,, oln.body, oln.length,, 0)
 end;

procedure newlin;
 begin wrtstr (''(cr)''(10)) end;

procedure wrtchr (ch: char);
 var st: str;
 begin st := ch; wrtstr (st) end;

function onscreen (x, y: integer): boolean;
 begin onscreen := (x>=ox) and (x-ox<sxdim) and (y>=oy) and (y-oy<sydim) end;

procedure cursor (x, y: integer);
 var st: str;
 begin writev (st, ''(esc)'[', x-ox+1:1, ';', y-oy+1:1, 'f');
  wrtstr (st); lx := x; ly := y end;

procedure abscursor (x, y: integer);
 var st: str;
 begin writev (st, ''(esc)'[', x:1, ';', y:1, 'f');
  wrtstr (st); lx := 0; ly := 0 end;

procedure normal (x, y: integer);
 begin if onscreen(x, y) then begin
   cursor (x, y); wrtchr (work [x, y]); ly := ly + 1 end end;

procedure reverse (x, y: integer);
 begin if onscreen(x, y) then begin cursor (x, y);
   wrtstr (''(esc)'[7m' + work [x, y] + ''(esc)'[0m'); ly := ly + 1 end end;

procedure newch (ch: char; x, y: integer);
 begin if onscreen (x, y) then begin
   if (x<>lx) or (y<>ly) then cursor (x, y);
   wrtstr (ch); ly := ly + 1 end;
  work[x, y] := ch
 end;

procedure newstr (st: str; x, y: integer);
 var i: integer;
 begin for i := 1 to length(st) do newch (st[i], x, y+i-1) end;

procedure hline (x, y1, y2: integer);
 var y: integer;
 begin for y := y1 to y2 do 
   if work[x,y] = '|' then newch ('+', x, y)
   else newch ('-', x, y)
 end;

procedure vline (x1, x2, y: integer);
 var x: integer;
 begin for x := x1 to x2 do
   if work[x,y] = '-' then newch ('+', x, y)
   else newch ('|', x, y)
 end;

{ Command Procedures }
procedure mvcursor (x, y: integer);
 var i: integer;
 procedure wrtlin (cln: line);
  var k: integer;
  begin
   k := oy + sydim;
   repeat k := k - 1 until (k=oy) or (cln[k] <> ' ');
   wrtstr (substr (cln, oy, k-oy+1))
  end;
 begin
  if y<oy then y := oy;
  if y-oy >= sydim then y := oy + sydim-1;
  if x<ox then begin if x<=0 then x := 1;
   for i := ox-1 downto x do begin abscursor (1,1);
    wrtstr (''(esc)'M'); wrtlin (work[i]) end; ox := x end
  else if x-ox >= sxdim then begin if x > pxdim then x := pxdim;
   abscursor (sxdim+1, 1); for i := ox+sxdim to x do begin
    wrtlin (work[i]); newlin end;
   for i := sxdim to 22 do newlin;
   ox := x-sxdim+1 end;
  cx := x; cy := y end;

procedure origin (x, y: integer);
 var i, j, k: integer;
 begin if (x <= pxdim+1-sxdim) and (y <= pydim+1-sydim) then begin
   ox := x; oy := y; if not onscreen(cx, cy) then begin cx := x; cy := y end;
   wrtstr (''(esc)'[2J'(esc)'[f') {Erase screen and Home};
   for i := x to x+sxdim-1 do begin k := y + sydim;
    repeat k:= k - 1 until (k=y) or (work [i, k] <> ' ');
    wrtstr (substr (work[i], y, k-y+1)); newlin end;
   for i := sxdim to 22 do newlin end
 end;

procedure instext;
 var i: integer;
 begin cursor (cx, cy); rdln (oy+sydim-cy+3);
  for i := 1 to length(ln) do begin work [cx, cy] := ln[i]; cy := cy + 1 end
 end;

procedure filltext;
 var i, j, k, y: integer;
 begin i := 1; ln := ln + ' '; repeat j := i;
   while (i < length(ln)) and (ln[i] <> ' ') do i := i + 1;
   if i <> j then begin y := cy;
    while (y < pydim) and (work [cx, y] = ' ') do y := y + 1;
    if y-cy <= i-j then begin cx := cx + 1;
     while (cy > 2) and (work [cx, cy-2] = ' ') do cy := cy - 1 end;
    if y-cy > i-j then begin
     for k := j to i-1 do newch (ln[k], cx, k-j+cy);
     i := i + 1; cy := cy + i-j end
    else j := i end
  until j = i
 end;

procedure centertext;
 var i, k, y, y2, lno: integer;
 begin i := 0;
  while (cy+i < pydim) and (cy-i > 1) and (work[cx, cy+i] = ' ') and
   (work[cx, cy-i] = ' ') do i := i + 1;
  if i*2-1 >= length(ln) then begin
   i := cy - length(ln) div 2;
   for k := 1 to length(ln) do begin newch (ln[k], cx, i); i := i + 1 end end
  else begin lno := 0; ln := ln + ' '; normal (cx, cy);
   repeat y := cy; y2 := cy;
    while (y>1) and (work[cx, y] = ' ') do y := y-1;
    while (y2 < pydim) and (work[cx, y2] = ' ') do y2 := y2 + 1;
    i := length(ln);
    while (lno < i-1) and (ln[lno+1] = ' ') do lno := lno + 1;
    while (i<>lno) and ((i-lno > y2-y-2) or (ln[i] <> ' ')) do i := i - 1;
    while (i<>lno) and (ln[i] = ' ') do i := i - 1;
    if i<>lno then begin y := (y + y2 + lno - i + 1) div 2;
     for k := lno + 1 to i do begin newch (ln[k], cx, y); y := y + 1 end;
     cx := cx + 1; lno := i end
    else lno := length(ln)
   until lno = length(ln) end
 end;

procedure mark {Set cursor mark};
 begin case mkct of
  0: begin mx0 := cx; my0 := cy; mkct := mkct + 1 end;
  1: begin normal (mx0, my0);
   if mx0>cx then begin mx1 := mx0; mx0 := cx end else mx1 := cx;
   if my0>cy then begin my1 := my0; my0 := cy end else my1 := cy;
   mkct := mkct + 1; mvcursor (mx0, my0) end;
  otherwise wrtchr (''(bel)) end
 end;

procedure blank {Remove cursor mark};
 begin case mkct of
  1: begin normal (mx0, my0); mkct := mkct - 1 end;
  2: begin normal (mx1, my1); normal (cx+mx1-mx0, cy+my1-my0);
   mkct := mkct - 1 end
  end
 end;

procedure copy;
 var i, j: integer;
 begin if mkct = 2 then begin
   if (pxdim-cx >= mx1-mx0) and (pydim-cy >= my1-my0) then
    if (cx<mx0) or ((cx=mx0) and (cy<my0)) then
     for i := mx0 to mx1 do
      newstr (substr (work [i], my0, my1-my0+1), i-mx0+cx, cy)
    else
     for i := mx1 downto mx0 do
      newstr (substr (work [i], my0, my1-my0+1), i-mx0+cx, cy)
  end
 end;

procedure move;
 var i, j: integer; st: str;
 begin if mkct = 2 then begin
   if (pxdim-cx >= mx1-mx0) and (pydim-cy >= my1-my0) then begin
    if (cx<mx0) or ((cx=mx0) and (cy<my0)) then
     for i := mx0 to mx1 do begin st := substr (work[i], my0, my1-my0+1);
      for j := my0 to my1 do newch (' ', i, j);
      newstr (st, i-mx0+cx, cy) end
    else
     for i := mx1 downto mx0 do begin st := substr (work[i], my0, my1-my0+1);
      for j := my0 to my1 do newch (' ', i, j);
      newstr (st, i-mx0+cx, cy) end
   end;
   blank; blank end
 end;

procedure drawline;
 var z: integer;
 begin if mkct = 1 then begin
   if cy = my0 then begin
    if cx < mx0 then begin z := mx0; mx0 := cx end else z := cx;
    vline (mx0, z, cy) end
   else if cx = mx0 then begin
    if cy < my0 then begin z := my0; my0 := cy end else z := cy;
    hline (cx, my0, z) end;
   blank; mark end
 end;

procedure drawbox {Draw a box};
 var x, y: integer;
 begin if (mkct = 1) and (cx <> mx0) and (cy <> my0) then begin
   if cx < mx0 then begin x := mx0; mx0 := cx end else x := cx;
   if cy < my0 then begin y := my0; my0 := cy end else y := cy;
   newch ('+', mx0, my0); hline (mx0, my0+1, y-1); newch ('+', mx0, y);
   vline (mx0+1, x-1, my0); vline (mx0+1, x-1, y);
   newch ('+', x, my0); hline (x, my0+1, y-1); newch ('+', x, y); blank
  end
 end;

procedure zap {Clear a region to blanks};
 var i, j, x, y: integer;
 begin if mkct = 1 then begin
   if cx < mx0 then begin x := mx0; mx0 := cx end else x := cx;
   if cy < my0 then begin y := my0; my0 := cy end else y := cy;
   for i := mx0 to x do begin
    for j := my0 to y do begin newch (' ', i, j) end end;
   blank end
 end;

procedure include (flnm: str);
 var wfl: str; j, k: integer; ch: char;
 begin open (workfl, flnm, unknown); reset (workfl); 
  while (cx <= pxdim) and (not eof (workfl)) do begin 
   readln (workfl, wfl); j := 0; k := 0;
   while k <> length(wfl) do begin k := k + 1; ch := wfl [k];
    if ch = ''(tab) then repeat j := j + 1; work[cx,j] := ' ' until j mod 8 = 0
    else begin work[cx,j+1] := ch; j := j + 1 end
   end;
   for j := j+1 to pydim do work [cx, j] := ' '; cx := cx + 1
  end;
  close (workfl)
 end; 

procedure inslin;
 var i, j: integer;
 begin for i := pxdim-nx downto cx do work[i+nx] := work[i];
  for i := cx to cx+nx-1 do for j := 1 to pydim do work[i, j] := ' ';
  origin (ox, oy)
 end;

procedure dellin;
 var i, j: integer;
 begin for i := cx to pxdim-nx do work[i] := work[i+nx];
  for i := pxdim-nx+1 to pxdim do for j := 1 to pydim do work[i, j] := ' ';
  origin (ox, oy)
 end;

procedure inscol;
 var i, j: integer;
 begin for i := 1 to pxdim do begin
   for j := pydim-nx downto cy do work[i, j+nx] := work[i, j];
   for j := cy to cy+nx-1 do work[i, j] := ' ' end;
  origin (ox, oy)
 end;

procedure delcol;
 var i, j: integer;
 begin for i := 1 to pxdim do begin
   for j := cy to pydim-nx do work[i, j] := work[i, j+nx];
   for j := pydim-nx+1 to pydim do work[i, j] := ' ' end;
  origin (ox, oy)
 end;

procedure getcmd;
 var i: integer;
 begin reverse (cx, cy); if mkct <>0 then begin reverse (mx0, my0);
   if mkct = 2 then begin reverse (mx1, my1); reverse (cx+mx1-mx0, cy+my1-my0)
  end end;
  abscursor (sxdim+1, 1); wrtstr ('+'(esc)'[0J'(esc)'='); rdln (pydim);
  if iostat.term = esc then begin cmch := chr(esc);
   c2 := ln.body[iostat.count + 3]; ln := ln + ' ';
   i := 1; rddec (ln, i, nx) end
  else begin cmch := uc (ln.body[1]);
   if length(ln) > 0 then ln := substr (ln, 2, length(ln)-1);
   case cmch of
   'O','P': begin i := 1; ln := ln + ' ';
    rddec (ln, i, nx); rddec (ln, i, ny) end
   end
  end;
  normal (cx, cy); if mkct=2 then normal (cx+mx1-mx0, cy+my1-my0)
 end;

procedure init;
 var i, j: integer;
 begin mkct := 0; sydim := 80;
  {Set no-wrap, key pad application mode, and get file name}
  writeln (''(esc)'[?7lRev 850125'); writeln;
  write ('Figure file: '); readln (workflnm); cx := 1; include (workflnm);
  for i := cx to pxdim do for j := 1 to pydim do work [i, j] := ' ';
  $assign ('SYS$INPUT', ichan); $assign ('SYS$OUTPUT', ochan);
  cx := 1; cy := 1; origin (1, 1)
 end;

procedure finish;
 var i, j, lastln, lastch: integer;
 function blankline: boolean;
  var z: integer;
  begin z := pydim;
   while (z<>1) and (work [lastln, z] = ' ') do z := z - 1;
   blankline := (z = 1) and (work [lastln, 1] = ' ')
  end;
 begin open (workfl, workflnm, new); rewrite (workfl); lastln := pxdim;
  while blankline do lastln := lastln - 1;
  for i := 1 to lastln do begin lastch := pydim;
   while (lastch <> 1) and (work [i, lastch] = ' ') do lastch := lastch - 1;
   for j := 1 to lastch do write (workfl, work [i, j]); writeln (workfl)
  end;
  close (workfl)
 end;

begin init; gold := false;
 repeat getcmd;
  case cmch of
  'I': begin nx := cx; include (ln); origin (ox, oy); cx := nx end;
  'F': filltext;
  'C': centertext;
  'W': begin sydim := pydim; oy := 1;
   wrtstr (''(esc)'[?3h'); origin (ox, oy) end;
  'N': begin sydim := 80; wrtstr (''(esc)'[?3l'); origin (ox, oy) end;
  'O': origin (nx, ny);
  'P': mvcursor (nx, ny);
  ''(cr): if mkct=0 then mvcursor (cx, oy) else mvcursor (cx, my0);
  ''(esc): case c2 of
   'B', 't': if gold then mvcursor (ox+sxdim-1, cy) else mvcursor (cx+nx, cy);
   'A', 'w': if gold then mvcursor (ox, cy) else mvcursor (cx-nx, cy);
   'D', 'q': if gold then mvcursor (cx, oy) else mvcursor (cx, cy-nx);
   'C', 'r': if gold then mvcursor (cx, oy+sydim-1) else mvcursor (cx, cy+nx); 
{   'q': mvcursor (cx, cy-8); 'r': mvcursor (cx, cy+8);
   'w': mvcursor (cx-8, cy); 't': mvcursor (cx+8, cy);
}   'R': begin while (cy < oy+sydim-1) and (work[cx,cy] <> ' ') do cy := cy + 1;
    while (cy < oy+sydim-1) and (work[cx,cy] = ' ') do cy := cy + 1 end;
   'S': instext;
   'p': if gold then dellin else inslin;
   'M': if gold then delcol else inscol;
   'y': copy; 'v': move; 's': zap;
   'x': drawline; 'u': drawbox;
   'n': if gold then blank else mark
   end
  end;
  gold := (cmch = ''(esc)) and (c2 = 'P')
 until (cmch = 'E') or (cmch = 'Q'); abscursor (sxdim+1, 1);
 if cmch = 'E' then finish;
 $dassgn (ichan); $dassgn (ochan);
end.
