Turbo Toolbox/Turbo_Toolbox.iso/1990/07/praxis/fed.pas

Pascal/Delphi Source File | 1990-04-03 | 22.5 KB | 826 lines

(* ====================================================== *)
(*                  Editor für Pixelfonts                 *)
(*           (C) 1990 Matthias Uphoff & TOOLBOX           *)
(*               Compiler: Turbo Pascal 5.5               *)
(* ====================================================== *)

(*$V-*)
(*$D-*)
(*$S-*)

USES Dos, Crt, Bios3;        (* Unit Bios3 aus tx 6/90 *)

CONST MaxCSize = 32;              (* Maximale Zeichenhöhe *)
      FSize = MaxCSize*256;       (* Maximale Fontgröße   *)

TYPE FileName = String[64];
     FrameStr = String[8];     (* Grafikzeichen f. Rahmen *)
     FArray = ARRAY[0..FSize-1] OF Byte;
     CharSet = SET OF CHAR;

CONST SingleFrame = '┌─┐││└─┘';
      Hex: String[16] = '0123456789ABCDEF';
      (* --- Für Dateinamen erlaubte Zeichen --- *)
      FileChar: CharSet =
                  ['.','0'..'9','a'..'z','A'..'Z','\'];
      (* --- Daten für Menue --- *)
      MLength = 22;  (* Länge *)
      MWidth = 39;   (* Breite *)
      MLeft = 40;    (* Ecke links/oben *)
      MTop = 2;
      Menu: ARRAY[1..MLength] OF String[MWidth] =
        ('┌───────────── Kommandos ─────────────┐',
         '│   Cursor nach                       │',
         '│ ['#27']    links      ['#26']    rechts     │',
         '│ ['#24']    oben       ['#25']    unten      │',
         '│ [Pos1] Spalte 1   [Ende] Spalte 8   │',
         '│                                     │',
         '│ [L]aden           [S]peichern       │',
         '│ [Z]eichen wählen  [K]opieren        │',
         '│ [B]lank           [I]nvertieren     │',
         '│ [R]ückgängig      [F]ont zeigen     │',
         '│ [Strg] [L]inks    [Strg] [R]echts   │',
         '│ [Strg] [O]ben     [Strg] [U]nten    │',
         '│                                     │',
         '│ [<─┘]          Punkt setzen/löschen │',
         '│ [Bild'#24']        1  Zeichen zurück    │',
         '│ [Bild'#25']        1  Zeichen weiter    │',
         '│ [Strg] [Bild'#24'] 10 Zeichen zurück    │',
         '│ [Strg] [Bild'#25'] 10 Zeichen weiter    │',
         '│ [Einfg]        Reihe hinzufügen     │',
         '│ [Entf]         Reihe entfernen      │',
         '│ [ESC]          Abbruch/Programmende │',
         '└─────────────────────────────────────┘');
      (* Daten für Editierfeld *)
      ELength = 7;   (* Länge *)
      EWidth = 20;   (* Breite *)
      ELeft = 11;    (* Ecke links/oben *)
      ETop = 2;
      EFrame: ARRAY[1..ELength] OF String[EWidth] =
        ('╔════╦════════╦════╗',
         '║    ║12345678║    ║',
         '╠════╬════════╬════╣',
         '║    ║        ║    ║',
         '╠════╩════════╩════╣',
         '║   Zeichen        ║',
         '╚══════════════════╝');

VAR R: Registers;            (* Prozessorregister *)
    Font: FArray;            (* Aktueller Font *)
    FontName: FileName;      (* Aktueller Font-Dateiname *)
    VMode,                   (* Videomodus *)
    CSize,                   (* Aktuelle Zeichenhöhe *)
    MsLine,                  (* Ausgabezeile f. Meldungen *)
    c,                       (* Aktuelle Zeichennummer *)
    LastLine: Word;          (* Letzte Bildschirmzeile *)
    EGA,                     (* TRUE wenn EGA vorhanden *)
    VGA,                     (* TRUE wenn VGA vorhanden *)
    changed: Boolean;        (* TRUE wenn Font geändert *)
    UndoBuffer: Array[0..MaxCSize-1] OF Byte;

(* ----- Diverse Prozeduren für das Screen-Handling ----- *)

PROCEDURE Cursor(on: Boolean);
   (* Schaltet Blockcursor ein/aus *)
BEGIN
  R.AX := $100;
  IF on THEN R.CX := $1F ELSE R.CX := $2020;
  Intr($10,R);
END;


PROCEDURE WriteBlanks(n: Word);
   (* Gibt n Blanks aus *)
   VAR i: Word;
BEGIN
  FOR i := 1 TO n DO Write(' ');
END;


PROCEDURE EraseMs;
   (* Löscht Zeile mit Bildschirm-Meldung *)
BEGIN
  Cursor(FALSE);
  GotoXY(2,MsLine);
  WriteBlanks(78);
END;


PROCEDURE Message(x: Word; s: String);
   (* Gibt Meldung s ab Spalte x in Zeile MsLine aus *)
BEGIN
  TextColor(White);
  GotoXY(x,MsLine);
  Write(s);
  TextColor(LightGray);
  Cursor(TRUE);
END;


PROCEDURE Error(s: String);
   (* Gibt Fehlermeldung aus, wartet auf ESC *)
BEGIN
  Message(3,#7 + s + ': ESC drücken ');
  REPEAT UNTIL ReadKey = #27;
  EraseMs;
END;


PROCEDURE Frame(x1,y1,x2,y2,c: Word; fs: FrameStr);
   (* Zeichnet Rahmen mit den Linienelementen in fs *)
   (* x1,y1 liegt links oben, x2,y2 rechts unten    *)
   VAR x,y: Word;
BEGIN
  TextColor(c);
  GotoXY(x1,y1); Write(fs[1]);
  FOR x := x1+1 TO x2-1 DO Write(fs[2]);
  Write(fs[3]);
  FOR y := y1+1 TO y2-1 DO BEGIN
    GotoXY(x1,y); Write(fs[4]);
    GotoXY(x2,y); Write(fs[5])
  END;
  GotoXY(x1,y2); Write(fs[6]);
  FOR x := x1+1 TO x2-1 DO Write(fs[7]);
  Write(fs[8]);
END;


PROCEDURE WriteMenu;
   (* Gibt das Menue aus *)
   VAR x,y: Word;
       c: Char;
BEGIN
  FOR y := 1 TO MLength DO BEGIN
    GotoXY(MLeft,MTop+y-1);
    FOR x := 1 TO MWidth DO BEGIN
      c := Menu[y,x];
      IF c = '[' THEN TextColor(White);
      Write(c);
      IF c = ']' THEN TextColor(LightGray);
    END;
  END;
END;


PROCEDURE WriteEdit;
   (* Baut das Editierfeld auf *)
   VAR y,i: Word;
BEGIN
  TextColor(LightGray);
  y := ETop;
  FOR i := 1 TO 3 DO BEGIN
    GotoXY(ELeft,y); Write(EFrame[i]);
    Inc(y);
  END;
  FOR i := 1 TO CSize DO BEGIN
    GotoXY(ELeft,y); Write(EFrame[4]);
    GotoXY(ELeft+2,y); Write(i:2);
    Inc(y);
  END;
  FOR i := 5 TO 7 DO BEGIN
    GotoXY(ELeft,y); Write(EFrame[i]);
    Inc(y);
  END;
  FOR i := y TO LastLine-1 DO BEGIN
    GotoXY(ELeft,i);
    WriteBlanks(EWidth);
  END;
END;


PROCEDURE CharRow(c,r: Word);
   (* Gibt die Pixelreihe r des Zeichens c aus *)
   VAR x: Word;
       b: Byte;
BEGIN
  b := Font[c*CSize+r-1];
  GotoXY(ELeft+16,ETop+r+2);
  Write(Hex[(b SHR 4) + 1],Hex[(b AND $F) + 1]);
  TextColor(White);
  GotoXY(ELeft+6,ETop+r+2);
  FOR x := 1 TO 8 DO BEGIN
    IF b AND $80 <> 0 THEN Write(#177) ELSE Write(#250);
    b := b SHL 1;
  END;
  TextColor(LightGray);
END;


PROCEDURE ShowChar(c: Word);
   (* Gibt Matrix von Zeichen c im Editierfeld aus *)
   VAR y: Word;
BEGIN
  FOR y := 1 TO CSize DO CharRow(c,y);
  GotoXY(ELeft+13,ETop+CSize+4);
  Write(c:3);
  GotoXY(ELeft+3,ETop+1);
  IF c IN [7,8,10,13] THEN c := 0;    (* Steuerzeichen *)
  Write(CHR(c));
END;


PROCEDURE SaveChar(c: Word);
   (* Matrix von Zeichen c in den Undo-Puffer retten *)
   (* und im Editierfeld ausgeben                    *)
BEGIN
  Move(Font[c*CSize],UndoBuffer,CSize);
  ShowChar(c);
END;


PROCEDURE InitScreen(size: Word);
   (* Baut den Bildschirm auf. Wenn Size > 16, wird in *)
   (* den 43 bzw. 50-Zeilen-Modus geschaltet (EGA/VGA) *)
BEGIN
  IF EGA AND (size > 16) THEN BEGIN
    TextMode(VMode + Font8x8);
    IF VGA THEN LastLine := 50 ELSE LastLine := 43;
  END
  ELSE BEGIN
    TextMode(VMode);
    LastLine := 25;
  END;
  Cursor(FALSE);
  MsLine := LastLine-1;;
  WindMax := LastLine*256+79;
  Frame(1,1,80,LastLine,7,SingleFrame);
  WriteEdit;
  WriteMenu;
  GotoXY(13,1);
  Write(' Font-Editor 2.0  ' +
        ' (C) 1990 Matthias Uphoff & TOOLBOX ');
END;


FUNCTION CheckSize(size: Word): Boolean;
   (* Überprüft die Zeichenhöhe, gibt FALSE zurück,    *)
   (* wenn sie zu klein oder zu groß ist. Schaltet     *)
   (* in den 43/50-Zeilen-Modus, falls nötig (EGA/VGA) *)
BEGIN
  IF (size >= 4) AND (size <= 16) THEN BEGIN
    IF LastLine > 25 THEN InitScreen(size);
    CheckSize := TRUE;
  END
  ELSE IF (size<4) OR (size>MaxCSize) OR NOT EGA THEN BEGIN
    CheckSize := FALSE
  END
  ELSE BEGIN
    IF LastLine = 25 THEN InitScreen(size);
    CheckSize := TRUE;
  END;
END;


PROCEDURE Input(max: Word; Allowed: CharSet; VAR s: String);
   (* Eingabe an der akt. Cursorpos. mit Zeileneditor *)
   (* max ist die max. Länge, Allowed enthält die er- *)
   (* laubten Zeichen. s kann eine Vorgabe enthalten. *)
   (* Bei Abbruch mit ESC wird s leer zurückgegeben   *)
   VAR new, flag: Boolean;
       x,y,xp: Word;
       ch: Char;
BEGIN
  new := TRUE; flag := FALSE;
  x := WhereX; y := WhereY;
  TextColor(White);
  Write(s);                      (* Vorgabe ausgeben *)
  xp := Length(s) + 1;           (* Eingabeposition *)
  REPEAT
    GotoXY(x+xp-1,y);
    ch := ReadKey;
    CASE ch OF
      #0:   CASE ReadKey OF         (* Extenden Code *)
               #71: BEGIN           (* Pos1 *)
                      new := false;
                      xp := 1;
                    END;
               #75: BEGIN           (* Cursor links *)
                      new := FALSE;
                      IF xp > 1 THEN Dec(xp);
                    END;
               #77: BEGIN           (* Cursor rechts *)
                      new := FALSE;
                      IF xp < Length(s)+1 THEN Inc(xp);
                    END;
               #79: BEGIN           (* Ende *)
                      new := FALSE;
                      xp := Length(s) + 1; END;
               #83: BEGIN           (* Entf *)
                      new := FALSE;
                      Delete(s,xp,1);
                      GotoXY(x,y);
                      Write(s,' ');
                    END;
            END;
      #8:   BEGIN                   (* Backspace *)
              new := FALSE;
              IF xp > 1 THEN Dec(xp);
              Delete(s,xp,1);
              GotoXY(x,y);
              Write(s,' ');
            END;
      #13:  BEGIN                (* Return *)
              GotoXY(x,y);
              WriteBlanks(Length(s));
              flag := TRUE;
            END;
      #27:  BEGIN                (* ESC *)
              GotoXY(x,y);
              WriteBlanks(Length(s));
              s := '';
              flag := TRUE;
            END
      ELSE IF (ch IN Allowed) AND (Length(s)<max) THEN BEGIN
        IF new THEN BEGIN        (* Vorgabe rauswerfen *)
          GotoXY(x,y); WriteBlanks(Length(s));
          new := FALSE; s := ''; xp := 1;
        END;
        Insert(ch,s,xp);         (* neues Zeichen *)
        GotoXY(x,y); Write(s);
        Inc(xp);
      END;
    END;
  UNTIL flag;
  TextColor(LightGray);
END;

(* -------------- Diverse Editorfunktionen -------------- *)

PROCEDURE Pixel(c,x,y: Word);
   (* Invertiert Pixel x,y im Zeichen c *)
   VAR i: Word;
BEGIN
  i := c*CSize+y-1;
  Font[i] := Font[i] XOR ($80 SHR (x-1));
  CharRow(c,y);
  changed := TRUE;
END;


FUNCTION GetChar(fs: String): Word;
  (* Zeichen(nummer) von der Tastatur anfordern *)
  VAR key: CHAR;
BEGIN
  Message(3,fs + ': Taste drücken oder ALT niederhalten' +
                 ' und Ziffern eingeben ');
  REPEAT
    key := ReadKey;
    IF key = #0 THEN BEGIN
      key := ReadKey; key := #0;
    END;
  UNTIL key <> #0;
  EraseMs;
  GetChar := ORD(key);
END;


PROCEDURE CopyChar(c: Word);
  (* Fordert Zeichen sc von der Tastatur an und   *)
  (* kopiert die Matrix in das Feld von Zeichen c *)
  VAR sc: Word;
BEGIN
  sc := GetChar('Matrix kopieren');
  IF sc <> 27 THEN BEGIN
    Move(Font[sc*CSize],Font[c*CSize],CSize);
    ShowChar(c);
    changed := TRUE;
  END;
END;


PROCEDURE InvertChar(c: Word);
   (* Invertiert die Matrix von Zeichen c *)
   VAR i: Word;
BEGIN
  FOR i := c*CSize TO (c+1)*CSize-1 DO
    Font[i] := NOT Font[i];
  ShowChar(c);
  changed := TRUE;
END;


PROCEDURE ClearChar(c: Word);
   (* Löscht Matrix des Zeichen c (Blank) *)
BEGIN
  FillChar(Font[c*CSize],CSize,0);
  ShowChar(c);
  changed := TRUE;
END;


PROCEDURE Undo(c: Word);
   (* Stellt den Originalzustand des Zeichens c her *)
BEGIN
  Move(UndoBuffer,Font[c*CSize],CSize);
  ShowChar(c);
END;


PROCEDURE ShiftR(c: Word);
   (* Schiebt die Punktreihen des Zeichens c nach rechts *)
   VAR i: Word;
BEGIN
  FOR i := c*CSize TO (c+1)*CSize-1 DO
    Font[i] := Font[i] SHR 1;
  ShowChar(c);
  changed := TRUE;
END;


PROCEDURE ShiftL(c: Word);
   (* Schiebt die Punktreihen des Zeichens c nach links *)
   VAR i: Word;
BEGIN
  FOR i := c*CSize TO (c+1)*CSize-1 DO
    Font[i] := Font[i] SHL 1;
  ShowChar(c);
  changed := TRUE;
END;


PROCEDURE ShiftU(c: Word);
   (* Schiebt die Punktreihen des Zeichens c nach oben *)
   VAR i: Word;
BEGIN
  i := c*CSize;
  Move(Font[i+1],Font[i],CSize-1);
  Font[i+CSize-1] := 0;
  ShowChar(c);
  changed := TRUE;
END;


PROCEDURE ShiftD(c: Word);
   (* Schiebt die Punktreihen des Zeichens c nach unten *)
   VAR i: Word;
BEGIN
  i := c*CSize;
  Move(Font[i],Font[i+1],CSize-1);
  Font[i] := 0;
  ShowChar(c);
  changed := TRUE;
END;


PROCEDURE Leave;
   (* Beendet das Programm nach Sicherheitsabfrage *)
   VAR key: CHAR;
BEGIN
  TextColor(White);
  IF changed THEN
    Message(6,'Der Zeichensatz wurde nicht gespeichert' +
              ' - das Programm beenden? (J/N) ')
  ELSE
    Message(25,'Das Programm beenden? (J/N) ');
  REPEAT
    key := UpCase(ReadKey);
    IF key = #0 THEN BEGIN
      key := ReadKey; key := #0;
    END;
  UNTIL (key = 'J') OR (key = 'N') OR (key = #27);
  IF key = 'J' THEN BEGIN
    TextMode(VMode);
    Halt;
  END;
  EraseMs;
END;


PROCEDURE InsLine;
   (* Vergrößert alle Zeichen um eine Punktreihe *)
   VAR key: Char;
       i: Word;
       tmp: FArray;
BEGIN
  Message(20,'Reihe hinzufügen - [O]ben oder [U]nten? ');
  REPEAT
    key := UpCase(ReadKey);
    IF key = #0 THEN BEGIN
      key := ReadKey; key := #0;
    END;
  UNTIL (key = 'O') OR (key = 'U') OR (key = #27);
  EraseMs;
  IF key <> #27 THEN BEGIN
    IF NOT CheckSize(CSize+1) THEN BEGIN
      Error('Zu große Zeichenhöhe');
      Exit;
    END;
    Tmp := Font;
    FillChar(Font,SizeOf(Font),0);
    FOR i := 0 TO 255 DO
      IF key = 'O' THEN
        Move(Tmp[i*CSize],Font[i*(CSize+1)+1],CSize)
      ELSE
        Move(Tmp[i*CSize],Font[i*(CSize+1)],CSize);
    Inc(CSize);
    WriteEdit;
    SaveChar(c);
    changed := TRUE;
  END;
END;


PROCEDURE DelLine;
   (* Verkleinert alle zeichen um eine Punktreihe *)
   VAR key: Char;
       i: Word;
       tmp: FArray;
BEGIN
  Message(20,'Reihe entfernen - [O]ben oder [U]nten? ');
  REPEAT
    key := UpCase(ReadKey);
    IF key = #0 THEN BEGIN
      key := ReadKey; key := #0;
    END;
  UNTIL (key = 'O') OR (key = 'U') OR (key = #27);
  EraseMs;
  IF key <> #27 THEN BEGIN
    IF NOT CheckSize(CSize-1) THEN BEGIN
      Error('Zu kleine Zeichenhöhe');
      Exit;
    END;
    Tmp := Font;
    FOR i := 0 TO 255 DO BEGIN
      IF key = 'O' THEN
        Move(Tmp[i*CSize+1],Font[i*(CSize-1)],CSize-1)
      ELSE
        Move(Tmp[i*CSize],Font[i*(CSize-1)],CSize-1)
    END;
    Dec(CSize);
    WriteEdit;
    SaveChar(c);
    changed := TRUE;
  END;
END;


PROCEDURE ShowFont;
   (* Zeigt den gesamten aktuellen Zeichensatz an *)
   VAR x,y: Word;
       ch: Char;
   PROCEDURE CharOut;
      (* Textausgabe ohne Steuerzeichen über das BIOS *)
   BEGIN
     R.AX := $200;                (* Funktionsnr. in AH *)
     R.BH := 0;                   (* Bildseite 0 *)
     R.DH := (y-1)*2;
     R.DL := x*2 + 7;
     Intr($10,R);       (* Cursorposition setzen *)
     R.AH := 9;                   (* Funktionsnr. in AH *)
     R.AL := ORD(ch);             (* Zeichen in AL *)
     R.BH := 0;                   (* Bildseite 0 *)
     R.BL := Red * 16 + White;    (* Weiß auf Rot *)
     R.CX := 1;                   (* 1 mal wiederholen *)
     Intr($10,R);       (* Zeichen ausgeben *)
   END;
BEGIN
  IF NOT EGA THEN
    Error('Für diese Funktion ist eine' +
          ' EGA/VGA-Karte erforderlich')
  ELSE BEGIN
    TextMode(VMode);              (* Bildschirm löschen *)
    (* aktuellen Font installieren: *)
    UserTextFont(0,CSize,256,0,TRUE,Font);
    ch := #0;
    FOR y := 1 TO 8 DO
      FOR x := 1 TO 32 DO BEGIN
        CharOut; Inc(ch);
      END;
    REPEAT ch := ReadKey UNTIL ch <> #0;
    InitScreen(CSize);
    ShowChar(c);
  END;
END;

(* -- Prozeduren für das Laden und Speichern von Fonts -- *)

PROCEDURE InitFont;
   (* Defaultfont aus ROM laden (EGA/VGA) *)
   VAR p: Pointer;
BEGIN
  IF VGA THEN BEGIN
    p := FontAddr(ROM8x16);
    CSize := 16;
    Move(p^,Font,256*CSize);
    FontName := 'ROM8x16';
  END
  ELSE IF EGA THEN BEGIN
    p := FontAddr(ROM8x14);
    CSize := 14;
    Move(p^,Font,256*CSize);
    FontName := 'ROM8x14';
  END
  ELSE BEGIN
    FillChar(Font,SizeOf(Font),0);
    CSize := 8;
    FontName := '';
  END;
END;


FUNCTION SaveFont(fn: Filename;
                  VAR MTable: FArray): Boolean;
   (* Font in MTable abspeichern. Gibt FALSE zurück,  *)
   (* wenn während des Speicherns ein Fehler auftritt *)
   VAR f: File;
       flag: BOOLEAN;
BEGIN
  (*$I-*)
  Assign(f,fn);
  ReWrite(f,1);
  flag := IOResult = 0;
  IF flag THEN BEGIN
    BlockWrite(f,MTable,CSize*256);
    flag := IOResult = 0;
    IF flag THEN Close(f);
  END;
  (*$I+*)
  SaveFont := flag;
END;


PROCEDURE Save;
   (* Dateiname anfordern und aktuellen Font abspeichern *)
   VAR fn: FileName;
        c: CHAR;
BEGIN
  Message(3,'Zeichensatz speichern - Dateiname: ');
  fn := FontName;
  Input(40,FileChar,fn);
  EraseMs;
  IF fn <> '' THEN
    IF SaveFont(fn,Font) THEN BEGIN
      FontName := fn;
      changed := FALSE;
    END
    ELSE Error('Fehler beim Speichern von ' + fn);
END;


PROCEDURE GetFont(fn: FileName);
   (* Font mit Dateinamen fn holen. Die Namen '8', '14'  *)
   (* und 16 laden die Fonts mit der entsprechenden      *)
   (* Zeichenhöhe aus dem EGA/VGA-BIOS-ROM               *)
   VAR FontSize: Integer;
       p: Pointer;
BEGIN
  IF (fn = '8') AND EGA THEN BEGIN
    p := FontAddr(ROM8x8);
    CSize := 8;
    Move(p^,Font,256*CSize);
    FontName := 'ROM8x8';
  END
  ELSE IF (fn = '14') AND EGA THEN BEGIN
    p := FontAddr(ROM8x14);
    CSize := 14;
    Move(p^,Font,256*CSize);
    FontName := 'ROM8x14';
  END
  ELSE IF (fn = '16') AND VGA THEN BEGIN
    p := FontAddr(ROM8x16);
    CSize := 16;
    Move(p^,Font,256*CSize);
    FontName := 'ROM8x16';
  END
  ELSE BEGIN
    FontSize := LoadFont(fn,Font);    (* siehe Unit Bios3 *)
    IF FontSize = 0 THEN
      Error('Datei '+ fn +' konnte nicht geladen werden')
    ELSE IF FontSize = -1 THEN
      Error(fn + ' ist keine Fontdatei')
    ELSE BEGIN
      FontName := fn;
      CSize := FontSize DIV 256;
      IF NOT CheckSize(CSize) THEN BEGIN
        Error('Zu große Zeichenhöhe');
        InitFont;
      END;
    END;
  END;
  InitScreen(CSize);
  SaveChar(c);
  changed := FALSE;
END;


PROCEDURE Load;
   (* Dateinamen anfordern und Font laden *)
   VAR fn: FileName;
       key: Char;
BEGIN
  IF changed THEN BEGIN
    Message(7,'Der Zeichensatz wurde nicht gespeichert' +
              ' - trotzdem laden? (J/N) ');
    REPEAT
      key := UpCase(ReadKey);
      IF key = #0 THEN BEGIN
        key := ReadKey; key := #0;
      END;
    UNTIL (key = 'J') OR (key = 'N') OR (key = #27);
    EraseMs;
    IF key <> 'J' THEN Exit;
  END;
  Message(3,'Zeichensatz laden - Dateiname: ');
  fn := '';
  Input(40,FileChar,fn);
  EraseMs;
  IF fn <> '' THEN GetFont(fn);
END;

(* --------- Editorschleife mit Tastaturabfrage ---.----- *)

PROCEDURE Edit;
   VAR x,y: Word;
   ch: Char;
BEGIN
  x := 1; y := 1;
  REPEAT
    IF y > CSize THEN y := CSize;
    GotoXY(ELeft+5+x,ETop+2+y);
    WHILE KeyPressed DO ch := ReadKey;
    Cursor(TRUE);
    ch := UpCase(ReadKey);
    Cursor(FALSE);
    CASE ch OF
      #0:  CASE ReadKey OF          (* Extended Code *)
             #71:  x := 1;
             #72:  IF y = 1 THEN         (* Cursor oben *)
                     y := CSize ELSE Dec(y);
             #75:  IF x = 1 THEN         (* Cursor links *)
                     x := 8 ELSE Dec(x);
             #77:  IF x = 8 THEN         (* Cursor rechts *)
                     x := 1 ELSE Inc(x);
             #79:  x := 8;               (* Ende *)
             #80:  IF y = CSize THEN     (* Cursor unten *)
                     y := 1 ELSE Inc(y);
             #82:  InsLine;              (* Einfg *)
             #83:  DelLine;              (* Entf *)
             #73:  BEGIN                 (* Bild oben *)
                     IF c = 0 THEN c := 255 ELSE Dec(c);
                     SaveChar(c);
                   END;
             #81:  BEGIN                 (* Bild unten *)
                     IF c = 255 THEN c := 0 ELSE Inc(c);
                     SaveChar(c);
                   END;
             #118: BEGIN               (* Strg Bild unten *)
                     IF c > 245 THEN
                       c := 255
                     ELSE
                       Inc(c,10);
                     SaveChar(c);
                   END;
             #132: BEGIN               (* Strg Bild oben *)
                     IF c < 10 THEN c := 0 ELSE Dec(c,10);
                     SaveChar(c);
                   END;
           END;
      #12: ShiftL(c);        (* ^L, links schieben *)
      #13: Pixel(c,x,y);     (* Return, Punkt invertieren *)
      #15: ShiftU(c);        (* ^O, nach oben schieben *)
      #18: ShiftR(c);        (* ^R, rechts schieben *)
      #21: ShiftD(c);        (* ^U, nach unten schieben *)
      #27: Leave;            (* ESC, Programmende *)
      #32: Pixel(c,x,y);     (* Space, Punkt invertieren *)
      'B': ClearChar(c);     (* Zeichen löschen (Blank) *)
      'F': ShowFont;         (* Font anzeigen *)
      'L': Load;             (* Font laden *)
      'I': InvertChar(c);    (* Zeichen invertieren *)
      'K': CopyChar(c);      (* Zeichenmatrix kopieren *)
      'R': Undo(c);          (* Rückgängig machen *)
      'S': Save;             (* Font speichern *)
      'Z': BEGIN             (* Zeichen wählen *)
             c := GetChar('Zeichen wählen');
             SaveChar(c);
           END;
    END;
  UNTIL FALSE;
END;

(* ------------------------- Main ----------------------- *)

BEGIN
  SetCBreak(FALSE);          (* Ctrl Break unterbinden *)
  (* --- Hardware ermitteln --- *)
  IF (LastMode AND $7F) = 7 THEN
    VMode := Mono            (* Monochrom-Bildschirm *)
  ELSE
    VMode := CO80;           (* Farbbildschirm *)
  R.AX := $1A00;             (* Fkt. Read Display Code *)
  Intr($10,R);
  VGA := R.AL = $1A;
  R.AX := $1200;             (* Fkt. Alternate Select *)
  R.BL := $10;               (* UFkt. Return Video Info *)
  Intr($10,R);
  EGA := (R.BL = 3) OR VGA;  (* Rückgabe 3 für 256 K RAM *)
  InitFont;
  InitScreen(CSize);
  IF ParamCount > 0 THEN GetFont(ParamStr(1));
  changed := FALSE;
  c := ORD('A');
  SaveChar(c);
  Edit;
END.

(* ------------------------------------------------------ *)