program matedit(input,output);
(*
Simpler Editor fuer Zeichen Matrix Dateien
Programm benoetigt ASCII hex kodierte Datei

Optimierte Uebersetzung eines BASIC Programmes nach TURBO Pascal.
Anpassung von BASIC ESCape-Sequenzen.
Namen fuer Prozeduren und Funktionen statt Teilennummern vergeben.
Weitere Optimierungen.

Copyright (C)      W.Cirsovius
                   Hohe Weide 44
                   D-2000 Hamburg 2O
                   Tel.:040/4223247
                   Version 1.2, Juli 1987
*)
const
                                                 (* Joyce Bildschirmelemente *)
                                                 (* ------------------------ *)
  oben         = #$86;                           (* 134: Oberer linker Rand  *)
  vert         = #$85;                           (* 133: Vertikale Linie     *)
  links        = #$87;                           (* 135: Linke Begrenzung    *)
  hor          = #$8a;                           (* 138: Horizintale Linie   *)
  mittig       = #$8f;                           (* 143: Kreuz               *)
  rechts       = #$8d;                           (* 141: Rechte Begrenzung   *)
  unten        = #$83;                           (* 131: Unterer linker Rand *)
                                                 (* ------------------------ *)
                                                 (* Joyce Befehle            *)
                                                 (* ------------------------ *)
  cup          = ^_;                             (* Cursor hoch              *)
  cdwn         = ^^;                             (* Cursor runter            *)
  clft         = ^A;                             (* Cursor links             *)
  crgt         = ^F;                             (* Cursor rechts            *)
  CAN          = ^H;                             (* Taste CAN                *)
  EXIT         = ^[;                             (* Taste EXIT               *)
  RETURN       = ^M;                             (* Taste RETURN             *)
  PLUS         = ^V;                             (* Taste [+]                *)
                                                 (* ------------------------ *)
                                                 (* Bildschirm Dimension     *)
                                                 (* ------------------------ *)
  left         =  2;
  right        = 16;
  top          =  2;
  bottom       = 16;

  defs         : string[16] = '0123456789ABCDEF';
  esc          = #27;
  bel          = #07;
  MSBIT        = $80;
type
  hexstrg      = string[ 2];
  CPMfile      = string[14];
  MATstrg      = string[16];
  CTRstrg      = string[80];
var
  endedit,
  modified,
  fbel,
  done,
  break,
  single       : boolean;
  oldchar,
  keys         : char;
  divm,
  inmat,
  cursx,
  cursy,
  chari        : byte;
  reihe,
  zeile,
  key          : integer;
  hxs          : hexstrg;
  matrix       : array[1..8,1..8] of boolean;
  com          : string[8];
  infil,
  fil          : CPMfile;
  f1,
  f2           : file;
  oldchars,
  chars        : MATstrg;
  record_buf,
  work_buf     : array[0..4095] of byte;  (*   256*8*2 Bytes -> 128*32 Rekords   *)

(* +++++++++++++++++++++++++++++++++++++ *)
(* Joyce spezifische Bildschirmattribute *)
(* ------------------------------------- *)
procedure CursorOn;
(* Cursor einschalten *)
Begin
  write(esc,'e');
End;

procedure CursorOff;
(* Cursor ausschalten *)
Begin
  write(esc,'f');
End;

procedure UnderlineOn;
(* Unterstreichen einschalten *)
Begin
  write(esc,'r');
End;

procedure UnderlineOff;
(* Unterstreichen ausschalten *)
Begin
  write(esc,'u');
End;
(* +++++++++++++++++++++++++++++++++++++ *)

function Ja_oder_Nein:boolean;
(* JA oder NEIN als Antwort -> TRUE oder FALSE *)
var
  x            : char;
Begin
  repeat
    repeat until keypressed;
    read(kbd,x);
    x:=upcase(x);
  until x in ['J','N'];
  writeln(x);
  Ja_oder_Nein:=x='J';
End;

procedure upper(var f:CPMfile);
(* Zeichenkette in Grossbuchstaben wandeln *)
var
  i            : integer;
Begin
  for i:=1 to length(f) do f[i]:=UpCase(f[i]);
End;

function finds(fname:CPMfile):CPMfile;
(* Datei finden, leere Zeichenkette falls nicht gefunden *)
var
  f            : file;
begin
  assign(f,fname);
  {$I-}
  reset(f);
  {$I+}
  if IOResult=0 then begin
                       close(f);
                       finds:=fname;
                     end
                else finds:='';
  
End;

procedure kill(fname:CPMfile);
(* Datei loeschen *)
var
  f            : file;
begin
  assign(f,fname);
  {$I-}
  close(f);
  erase(f);
  {$I+}
End;

procedure SaveFile;
(* Neue Definitionsdatei speichern *)
Begin
  assign(f2,fil);
  rewrite(f2);
  blockwrite(f2,record_buf,32);
  close(f2);
End;

procedure SatzLesen; (* BASIC 410 *)
(* Definitionsdatei laden *)
var
  i            : integer;
Begin
  assign(f1,infil);
  reset(f1);
  if filesize(f1)<>32 then break:=true
  else
  begin
    writeln('Datensatz wird eingelesen. Bitte warten ...');
    blockread(f1,work_buf,32);
    for i:=0 to 4095 do
      if pos(chr(work_buf[i]),defs)=0 then break:=true;    
    record_buf:=work_buf;
    SaveFile;
  end;
  close(f1);
  modified:=false;
End;

function get(ri:integer):MATstrg;
(* Liest den Matrixstring aus dem Dateipuffer *)
var
  i,
  idx          : integer;
  resrec       : MATstrg;
Begin
  idx:=ri shl 4;
  resrec:='';
  for i:=0 to 15 do resrec:=resrec+chr(work_buf[idx+i]);
  get:=resrec;
End;

procedure put(ri:integer;var mtx:MATstrg);
(* Schreibt den Matrixstring in den Dateipuffer *)
var
  i,
  idx          : integer;
Begin
  idx:=ri shl 4;
  for i:=0 to 15 do record_buf[idx+i]:=ord(mtx[succ(i)]);
  modified:=true;
End;

function hex(hx:byte):hexstrg;
(* Byte in ASCII-Zeichen wandeln *)

  function hexc(hxc:byte):char;
  begin
    hexc:=defs[succ(hxc and $0F)]
  end;

Begin { hex }
  hex:=hexc(hx shr 4)+hexc(hx);
End;

procedure get_reihe;
(* Reihe und Zeile aus Cursor-Koordinate berechnen *)
Begin
  reihe:=cursx shr 1;
  zeile:=cursy shr 1;
End;

procedure get_cursor;
(* Cursor-Koordinate aus Reihe und Zeile berechnen *)
Begin
  cursx:=reihe shl 1;
  cursy:=zeile shl 1;
End;

procedure MatrixBitEin; (* BASIC 1930 *)
(* Setzen eines Bits in der Matrix *)
Begin
  get_cursor;
  GotoXY(cursx,cursy);
  LowVideo;
  write(' ');
  NormVideo;
End;

procedure MatrixBitLoeschen; (* BASIC 2040 *)
(* R}cksetzen eines Bits in der Matrix *)
Begin
  GotoXY(cursx,cursy);
  write(' ');
End;

procedure MatrixBitAus; (* BASIC 2000 *)
(* R}cksetzen eines Bits in der Matrix *)
Begin
  get_cursor;
  MatrixBitLoeschen;
End;

procedure EditierMarker; (* BASIC 2090 *)
(* Setzen des Editiermarkers *)
Begin
  GotoXY(cursx,cursy);
  if matrix[cursy shr 1,cursx shr 1]
     then
     begin
       LowVideo;
       write('X');
       NormVideo;
     end else write('_');
End;

procedure Taste_CAN; (* BASIC 2330 *)
(* CAN *)
Begin
  endedit:=true;
  GotoXY(30,7);
  UnderlineOn;
  write('Bitte warten');
  UnderlineOff;
  write(' ');
End;

procedure PixelEditieren; (* BASIC 2160 *)
(* Editieren der Pixels *)

  procedure MarkerUmsetzen(dx,dy:byte); (* BASIC 2660 *)
  (* Alten Marker loeschen, neuen setzen *)
  var
    cy,
    cx         : byte;

    procedure swp(var a1,a2:byte);
    var
      a3       : byte;
    begin
      a3:=a1;
      a1:=a2;
      a2:=a3;
    end;

  begin { MarkerUmsetzen }
    get_reihe;
    cx:=cursx;
    cy:=cursy;
    MatrixBitLoeschen;
    cursx:=cursx+dx;
    cursy:=cursy+dy;
    EditierMarker;
    if matrix[zeile,reihe] then
    begin
      swp(cx,cursx);
      swp(cy,cursy);
      MatrixBitEin;
      swp(cx,cursx);
      swp(cy,cursy);
    end;
  end;

  procedure Taste_PLUS; (* BASIC 2250 *)
  (* [+] *)
  begin
    if not single then
    begin
     done:=true;
     single:=true;
    end;
  end;

  procedure CursorHoch; (* BASIC 2370 *)
  (* Cursor hoch *)
  begin
    if not ((cursy-2)<top) then MarkerUmsetzen(0,-2);
  end;

  procedure CursorRunter; (* BASIC 2420 *)
  (* Cursor runter *)
  begin
    if not ((cursy+2)>bottom) then MarkerUmsetzen(0,2);
  end;

  procedure CursorLinks; (* BASIC 2470 *)
  (* Cursor linkst *)
  begin
    if not ((cursx-2)<left) then MarkerUmsetzen(-2,0);
  end;

  procedure CursorRechts; (* BASIC 2520 *)
  (* Cursor rechts *)
  begin
    if not ((cursx+2)>right) then MarkerUmsetzen(2,0);
  end;

  procedure Taste_ENTER; (* BASIC 2570 *)
  (* ENTER *)
  begin
    get_reihe;
    matrix[zeile,reihe]:=not matrix[zeile,reihe];
    EditierMarker;
  end;

  procedure Taste_EXIT; (* BASIC 2290 *)
  (* EXIT *)
  begin
    if not single then
    begin
     done:=true;
     Taste_CAN;
    end;
  end;

Begin { PixelEditieren }
  GotoXY(30,7);LowVideo;write('!! Eingabe !!');NormVideo;
  if fbel then write(bel);
  endedit:=false;
  repeat
    while not keypressed do;
    read(kbd,keys);
    key:=pos(keys,com);
    case key of
      1 : CursorHoch;   (* Cursor hoch *)
      2 : CursorRunter; (* Cursor runter *)
      3 : CursorLinks;  (* Cursor links *)
      4 : CursorRechts; (* Cursor rechts *)
      5 : Taste_CAN;    (* CAN *)
      6 : Taste_EXIT;   (* EXIT *)
      7 : Taste_ENTER;  (* ENTER *)
      8 : Taste_PLUS;   (* [+] *)
    end;
  until endedit;
End;

procedure MatrixAusgabe; (* BASIC 1520 *)
(* Initialisierung der Matrix auf Bildschirm *)
Begin
  for zeile:=1 to 8 do
    for reihe:=1 to 8 do if matrix[zeile,reihe] then MatrixBitEin
                                                else MatrixBitAus;
  cursx:=2;
  cursy:=2;
  EditierMarker;
End;

procedure Binaer_aus_Matrix; (* BASIC 1210 *)
(* Numerische Matrix aus Zeichen berechnen *)
Begin
  for zeile:=1 to 8 do
  begin
    inmat:=pred(pos(chars[zeile+zeile],      defs))+
          (pred(pos(chars[pred(zeile+zeile)],defs)) shl 4);
    divm:=MSBIT;
    for reihe:=1 to 8 do
    begin
      matrix[zeile,reihe]:=(inmat and divm)<>0;
      divm:=divm shr 1;
    end;
  end;
End;

procedure Zeichen_aus_Matrix; (* BASIC 1380 *)
(* Zeichen aus numerischer Matrix berechnen *)
Begin
  chars:='';
  for zeile:=1 to 8 do
  begin
    inmat:=0;
    divm:=MSBIT;
    for reihe:=1 to 8 do
    begin
      if matrix[zeile,reihe] then inmat:=inmat+divm;
      divm:=divm shr 1;
    end;
    chars:=chars+hex(inmat);
  end;
End;

procedure OptionenEin; (* BASIC 2850 *)
(* Alle Optionen einschalten *)
Begin
  LowVideo;
  GotoXY(30,16);write('EXIT bricht Bearbeitung ab');
  GotoXY(30,17);write('    Einzelpixel mit [+]   ');
  NormVideo;
End;

procedure OptionenAus; (* BASIC 2910 *)
(* Einige Optionen abschalten *)
Begin
  GotoXY(30,16);ClrEol;
  GotoXY(30,17);ClrEol;
End;

procedure Editieren; (* BASIC 1780 *)
(* Gemeinsame Editor-Routine *)
Begin
  GotoXY(40,2);
  LowVideo;write(hex(chari));NormVideo;
  Binaer_aus_Matrix;
  if not break then
  begin
    MatrixAusgabe;
    PixelEditieren;
  end;
End;

procedure EditorInit; (* BASIC 170 *)
(* Matrix-Editor initialisieren *)
Begin
  com:=cup+cdwn+clft+crgt+CAN+EXIT+RETURN+PLUS;
  done:=false;
  break:=false;
  single:=false;
  ClrScr;
  write('Mit akustischer Anzeige, wenn Operation beendet (j/n) :');
  fbel:=Ja_oder_Nein;
  ClrScr;
  writeln(' ':25);
  UnderlineOn;write('M A T R I X   E D I T O R');UnderlineOff;
  writeln;
  writeln;
End;

procedure EingabeName; (* BASIC 360 *)
(* Eingabedatei bestimmen *)
var
  IO           : boolean;
  p            : integer;
Begin
  repeat
    write('File-Name: ');
    readln(fil);
    upper(fil);
    infil:=fil;
    if pos('.',fil)=0 then infil:=infil+'.ALT';
    p:=pos('.',infil);
    fil:=copy(infil,1,p);
    IO:=finds(infil)<>'';
    if not IO then writeln(bel,'File ist unbekannt');
  until IO;
End;

procedure AusgabeName; (* BASIC 2970 *)
(* Ausgabedatei bestimmen *)
var
  i            : integer;
  new_file     : boolean;
  ext          : string[3];
Begin
  i:=0;
  repeat
    str(i,ext);
    while length(ext)<3 do ext:='0'+ext;
    fil:=fil+ext;
    new_file:=finds(fil)='';
    i:=succ(i);
  until (i=1000) or (new_file);
  if (i=1000) then
  begin
    ClrScr;
    writeln('Keine freie Standard Datei gefunden');
    repeat
      write('Ausgabe Datei : ');
      readln(fil);
      upper(fil);
      new_file:=finds(fil)='';
      if not new_file then
      begin
        ClrScr;
        write('Ausgabedatei existiert bereits, l|schen (j/n) :');
        new_file:=Ja_oder_Nein;
        if new_file then kill(fil);
      end;
    until new_file;
  end;
End;

procedure Bildschirmaufbau; (* BASIC 1050 *)
(* Bildschirmaufbau *)
var
  i,j          : integer;

  procedure RandAufbau(anfang:byte;patt:char); (* BASIC 900 *)
  (* Oberen oder unteren Rand setzen *)
  begin
    GotoXY(1,anfang);
    write(patt);
    for i:=1 to 7 do write(hor,chr(ord(patt)+8));
    write(hor,chr(ord(patt)+6));
  end;

  procedure Mittelteil(anfang,ende:byte;p1,p2,p3,p4:char); (* BASIC 970 *)
  (* Mittelteil setzen *)
  begin
    i:=anfang;
    while (i<=ende) do
    begin
      GotoXY(1,i);
      write(p1);
      for j:=1 to 7 do write(p2,p3);
      write(p2,p4);
      i:=i+2;
    end;
  end;

Begin (*  Bildschirmaufbau *)
  RandAufbau(1,oben);                       (* Oberen Rand setzen *)
  Mittelteil(2,16,vert, ' ',vert,  vert);   (* Leeren Mittelteil setzen *)
  Mittelteil(3,15,links,hor,mittig,rechts); (* Mittelteil setzen *)
  RandAufbau(17,unten);                     (* Unteren Rand setzen *)
  LowVideo;
  GotoXY(30, 2);write('Hexwert : ..');
  GotoXY(30,13);write(' Cursor setzen mit Pfeilen');
  GotoXY(30,14);write('     ENTER {ndert Bit     ');
  GotoXY(30,15);write('    CAN beendet Eingabe   ');
  GotoXY(30,24);write('> M  A  T  R  I  X     E  D  I  T  O  R <');
  GotoXY(30,25);write('> Copyright (C) Werner Cirsovius - 1987 <');
  NormVideo;
  GotoXY(1,20);write('Originaldatei : ');UnderlineOn;write(infil);UnderlineOff;
  GotoXY(1,22);write('   Neue Datei : ');UnderlineOn;write(  fil);UnderlineOff;
  Taste_CAN;
End;

function ASCII2hex:boolean; (* BASIC 2740 *)
(* Umwandlung ASCII Hex Digit in Zahl *)
var
  hexflag      : boolean;
  oldcharb     : byte;
  x,
  i,
  hexlen       : integer;
Begin
  hexflag:=false;
  for hexlen:=1 to length(hxs) do hxs[hexlen]:=upcase(hxs[hexlen]);
  hexlen:=length(hxs);
  if hexlen<1 then hexflag:=true
  else
  begin
    oldcharb:=0;
    for i:=1 to hexlen do
    begin
      x:=pos(hxs[i],defs);
      if x=0 then hexflag:=true;
      oldcharb:=pred(x)+(oldcharb shl 4);
    end;
    oldchar:=chr(oldcharb);
  end;
  ASCII2hex:=hexflag;
End;

procedure EditMatrix; (* BASIC 1600 *)
(* Editieren der Matrix *)

  procedure swpchr;
  var
    o          : char;
    os         : MATstrg;
  begin
    o:=oldchar;
    oldchar:=chr(chari);
    chari:=ord(o);
    os:=oldchars;
    oldchars:=chars;
    chars:=os;
  end;

Begin { EditMatrix }
  repeat
    OptionenEin;
    Editieren;
    if not break then
    begin
      if not single then Zeichen_aus_Matrix
        else
        begin
          repeat
            GotoXY(30,7);
            write('Welcher Hex Matrixwert (00..FF) :');
            if fbel then write(bel);
            readln(hxs);
            GotoXY(30,7);
            ClrEol;
            Taste_CAN;
          until not ASCII2hex;
          swpchr;
          chars:=get(chari);
          OptionenAus;
          Editieren;
          if not break then
          begin
            Zeichen_aus_Matrix;
            put(chari,chars);
            swpchr;
            single:=false;
          end;
        end;
    end;
  until (break or (not single));
End;

procedure endit(endmsg:CTRstrg);
(* Letzte Meldung ausgeben und Matrix Editor beenden *)
Begin
  writeln(endmsg);
  halt;
End;

procedure LetzteMeldung; (* BASIC 640 *)
(* Letzte Meldung ausgeben und Matrix Editor beenden *)
Begin
  if not break then endit('Definition beendet')
               else endit('Definition abgebrochen');
End;

procedure Datei_schliessen; (* BASIC 630 *)
(* Ausgabedatei schliessen *)
Begin
  if modified then SaveFile;
  writeln('Neue Datei : ',fil,' geschlossen');
  LetzteMeldung;
End;

procedure Datei_beenden; (* BASIC 660 *)
(* Datei beenden *)
Begin
  ClrScr;
  CursorOn;
  if not break then
  begin
    write('EXIT bet{tigt. Datei retten (j/n) ');
    if Ja_oder_Nein then Datei_schliessen;
  end;
  kill(fil);
  LetzteMeldung;
End;

BEGIN { MAIN }
  EditorInit;
  EingabeName;
  AusgabeName;
  SatzLesen;
  if not break then
  begin
    ClrScr;
    CursorOff;
    Bildschirmaufbau;
    (* Hauptschleife *)
    for chari:=0 to 255 do
    begin
      chars:=get(chari);
      EditMatrix;
      if break then Datei_beenden;
      put(chari,chars);
      if done then Datei_beenden;
    end;
  end;
  ClrScr;
  Datei_schliessen;
END.