PROGRAM FONTS(INPUT,OUTPUT);
CONST
      KEY1='TOGGLE'; KEY2=' '; KEY3='SHLT'; KEY4='SHRT'; KEY5='SHUP';
      KEY6='SHDN'; KEY7='CLR'; KEY8='FILL'; KEY9='#'; KEY10='MENU';
      KEYINS='+1'; KEYDEL='-1';

      MAXFONT=255; BIT1=0; BIT8=7;

      DOT=22; HLINE=205; VLINE=186; LUC=201; RUC=187; RLC=188; LLC=200;
 {                   Í          º        É        »        ¼        È    }

      { LOCATION OF FRAME. LUCR0 & LUCC0 LOCATE UPPER LEFT-HAND CORNER, WHILE
        HSTEP & VSTEP DETERMINE ITS SIZE. }

      LUCR0=3; LUCC0=4; HSTEP=2; VSTEP=1;

      MENUR=5; MENUC=40;

TYPE
    BIGSTR = STRING[80];
    BYTEBITS = BIT1..BIT8;
    PATTERN_SET = SET OF BYTEBITS; CHAR_PATTERN = ARRAY[1..8] OF PATTERN_SET;
    FILE_NAME_TYPE = STRING[14];
    CHAR_PATTERN_FILE = FILE OF CHAR_PATTERN;
    REG_LENGTH = (REG_WORD,REG_BYTE);
    REGPACK = RECORD CASE REG_LENGTH OF
                     REG_WORD: (AX,BX,CX,DX,BPX,SIX,DIX,DSX,ESX,FLAGX: INTEGER);
                     REG_BYTE: (AL,AH,BL,BH,CL,CH,DL,DH:BYTE;
                                BP,SI,DI,DS,ES,FLAG:INTEGER);
                     END;

   KEYS = (NOKEY,NOTFCT,
           F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,
           HOME,UP,PGUP,LT,RT,EN,DN,PGDN,INS,DEL);

   ON_OFF = (ON,OFF);

VAR
    FONTS: ARRAY[0..MAXFONT] OF CHAR_PATTERN;
    FILENAME1,FILENAME2: FILE_NAME_TYPE;
    FILE1,FILE2:CHAR_PATTERN_FILE;
    FONTNO,FONTNR,FONTNC,XYR,XYC: INTEGER;
    KEY:KEYS; CH,CHX:CHAR;
    I,J:INTEGER;
    CURROW,CURCOL:INTEGER; { CURRENT LOGICAL CURSOR POSITION }
    QUIT:BOOLEAN;

{*************************** P R O C E D U R E S  **************************}
PROCEDURE REVERSE; { CHANGES OUTPUT TO REVERSE VIDEO }
          BEGIN TEXTCOLOR(BLACK); TEXTBACKGROUND(WHITE); END;

PROCEDURE NORMAL; { CHANGES OUTPUT TO NORMAL VIDEO }
          BEGIN TEXTCOLOR(WHITE); TEXTBACKGROUND(BLACK); END;

FUNCTION GETKEY(VAR CHX,CH:CHAR): KEYS;
CONST ESC=27;
BEGIN
IF KEYPRESSED THEN BEGIN  { READ KEYBOARD, AND MAP INTO 'KEYS' TYPE }
   READ(KBD,CH); CHX:=CHR(0);
   IF ORD(CH)=ESC THEN
      IF KEYPRESSED THEN BEGIN CHX:=CH; READ(KBD,CH) END;

   IF CHX=CHR(0) THEN GETKEY:=NOTFCT
   ELSE CASE CH OF
        ';':  GETKEY:=F1;
        '<':  GETKEY:=F2;
        '=':  GETKEY:=F3;
        '>':  GETKEY:=F4;
        '?':  GETKEY:=F5;
        '@':  GETKEY:=F6;
        'A':  GETKEY:=F7;
        'B':  GETKEY:=F8;
        'C':  GETKEY:=F9;
        'D':  GETKEY:=F10;
        'G':  GETKEY:=HOME;
        'H':  GETKEY:=UP;
        'I':  GETKEY:=PGUP;
        'K':  GETKEY:=LT;
        'M':  GETKEY:=RT;
        'O':  GETKEY:=EN;
        'P':  GETKEY:=DN;
        'Q':  GETKEY:=PGDN;
        'R':  GETKEY:=INS;
        'S':  GETKEY:=DEL;
        ELSE GETKEY:=NOTFCT;
        END { CASE }
    END {KEYPRESSED}
ELSE GETKEY:=NOKEY;
END; {GETKEY}

PROCEDURE BLINKVIDEO;
          BEGIN TEXTCOLOR(WHITE+BLINK) END;

FUNCTION LOCATE_ROW(I:INTEGER): INTEGER;
         BEGIN LOCATE_ROW:=LUCR0+VSTEP*I; END;

FUNCTION LOCATE_COL(I:BYTEBITS): INTEGER;
         BEGIN LOCATE_COL:=LUCC0+HSTEP*(I+1); END;

PROCEDURE GOTORC(ROW,COL:INTEGER);
          BEGIN GOTOXY(COL,ROW); END;

{**** REVERSE THE BITS IN A SET TYPE.  THE BIT NUMBERING FOR GRAPHICS
      PATTERNS IS A MIRROR IMAGE OF THE BIT NUMBERING FOR PASCAL SETS. }
PROCEDURE REVFONT(FONT:CHAR_PATTERN;VAR TFONT:CHAR_PATTERN);
VAR I:INTEGER;

{*} PROCEDURE REVSET(PSET:PATTERN_SET;VAR TPSET:PATTERN_SET);
    VAR I:BYTEBITS;
    BEGIN TPSET:=[];
          FOR I:=BIT1 TO BIT8 DO IF I IN PSET THEN TPSET:=TPSET + [BIT8-I];
    END;

BEGIN
   FOR I:=1 TO 8 DO REVSET(FONT[I],TFONT[I]);
END;

PROCEDURE DISPLAY_COORD(ROW:INTEGER;COL:BYTEBITS);
VAR X,Y:INTEGER;
BEGIN X:=WHEREX; Y:=WHEREY; GOTORC(XYR,XYC); REVERSE;
      WRITE(' ',ROW:1,',',COL+1:1,' '); NORMAL;
      GOTOXY(X,Y); END;

PROCEDURE DOT_CLR(I:INTEGER;J:BYTEBITS; CURSOR:ON_OFF);
          BEGIN FONTS[FONTNO][I]:= FONTS[FONTNO][I] - [J];
                GOTORC(LOCATE_ROW(I),LOCATE_COL(J));
                IF CURSOR=ON THEN BEGIN
                   DISPLAY_COORD(I,J); BLINKVIDEO; WRITE(CHR(DOT)); NORMAL; END
                ELSE WRITE(' ');
          END;

PROCEDURE DOT_SET(I:INTEGER;J:BYTEBITS; CURSOR:ON_OFF);
          BEGIN FONTS[FONTNO,I] := FONTS[FONTNO,I] + [J];
                GOTORC(LOCATE_ROW(I),LOCATE_COL(J));
                IF CURSOR=ON THEN BEGIN
                   DISPLAY_COORD(I,J); HIGHVIDEO END
                ELSE LOWVIDEO;
                WRITE(CHR(DOT));
          NORMAL;
          END;

PROCEDURE DOT_CURSOR(ROW:INTEGER;COL:BYTEBITS;CURSOR:ON_OFF);
          BEGIN GOTORC(LOCATE_ROW(ROW),LOCATE_COL(COL));
                IF COL IN FONTS[FONTNO,ROW] THEN BEGIN
                   IF CURSOR=ON THEN BEGIN
                      DISPLAY_COORD(ROW,COL); HIGHVIDEO END
                   ELSE LOWVIDEO; WRITE(CHR(DOT)) END
                ELSE IF CURSOR=ON THEN BEGIN
                        DISPLAY_COORD(ROW,COL);BLINKVIDEO; WRITE(CHR(DOT)); END
                     ELSE WRITE(' ');
           NORMAL;
           END;

PROCEDURE LINE25; { PRINTOUT THE LINE 25 INFORMATION }
VAR KEYNO:INTEGER;
  PROCEDURE WRITEKEY(KEY:BIGSTR);
            BEGIN NORMAL; KEYNO:=KEYNO+1;
            IF KEYNO<>1 THEN WRITE(' ');
            IF KEYNO<=10 THEN WRITE(KEYNO:1)
            ELSE IF KEYNO=11 THEN WRITE('INS') ELSE WRITE('DEL');
            REVERSE; WRITE(KEY); NORMAL; END;

BEGIN
   GOTOXY(1,25);  KEYNO:=0;
   WRITEKEY(KEY1); WRITEKEY(KEY2); WRITEKEY(KEY3); WRITEKEY(KEY4); WRITEKEY(KEY5);
   WRITEKEY(KEY6); WRITEKEY(KEY7); WRITEKEY(KEY8); WRITEKEY(KEY9); WRITEKEY(KEY10);
   WRITEKEY(KEYINS); WRITEKEY(KEYDEL);
END; {LINE25}

PROCEDURE DISPLAY_BORDER;
VAR I,RTCOL,BTMROW:INTEGER;
BEGIN
   HIGHVIDEO;

   { WRITE OUT CORNER CHARACTERS }
   GOTORC(LUCR0,LUCC0); WRITE(CHR(LUC));
   RTCOL:=LUCC0+9*HSTEP; GOTORC(LUCR0,RTCOL); WRITE(CHR(RUC));
   BTMROW:=LUCR0+9*VSTEP; GOTORC(BTMROW,LUCC0); WRITE(CHR(LLC));
   GOTORC(BTMROW,RTCOL); WRITE(CHR(RLC));

   { WRITE OUT LINES OF FRAME }
   FOR I:=LUCC0+1 TO RTCOL-1 DO BEGIN
       GOTORC(LUCR0,I); WRITE(CHR(HLINE)); GOTORC(BTMROW,I); WRITE(CHR(HLINE)); END;
   FOR I:=LUCR0+1 TO BTMROW-1 DO BEGIN
       GOTORC(I,LUCC0); WRITE(CHR(VLINE)); GOTORC(I,RTCOL); WRITE(CHR(VLINE)); END;

   { INITIALIZE THE SCREEN POSITION OF THE FONT NUMBER }
   FONTNR:=LUCR0-1; FONTNC:=RTCOL-4;
   XYR:=FONTNR; XYC:=LUCC0;

END; { DISPLAY_BORDER }

PROCEDURE DISPLAY_FONTNO(FONTNO:INTEGER);
          BEGIN REVERSE; GOTORC(FONTNR,FONTNC); WRITE(' ',FONTNO:3,' '); NORMAL; END;

PROCEDURE DISPLAY_FONTS(FONT:CHAR_PATTERN);
VAR I,ROW:INTEGER; COL,J:BYTEBITS;
BEGIN
    LOWVIDEO;
    FOR I:=1 TO 8 DO BEGIN
        ROW:=LOCATE_ROW(I); { GET SCREEN POSITION OF THE Ith ROW }
        FOR J:=BIT1 TO BIT8 DO BEGIN
            COL:=LOCATE_COL(J); { GET SCREEN POSITION OF THE Jth COLUMN }
            GOTORC(ROW,COL);
            IF J IN FONT[I] THEN WRITE(CHR(DOT)) ELSE WRITE(' ');
            END;
        END;
    CURROW:=1; CURCOL:=BIT1; DOT_CURSOR(CURROW,CURCOL,ON);
END; { DISPLAY A FONT }

PROCEDURE DISPLAY_FONT(FONTNO:INTEGER);
BEGIN DISPLAY_FONTS(FONTS[FONTNO]); END;

PROCEDURE MENUS;
LABEL TO_LBL,FROM_LBL,NUM_LBL;
CONST ROMOFS=$FA6E; ROMSEG=$F000;
VAR CMD:1..4; QROW:INTEGER;
    FONT:CHAR_PATTERN;
    SFONT,DFONT,CODE,NUM,I,STRPOS,XPOS,YPOS:INTEGER;
    INSTRING: STRING[80];
    ROM:BOOLEAN;
    PATTERN: PATTERN_SET; MEMBYTE:BYTE ABSOLUTE PATTERN;
    ANS:CHAR;
    FILENAME:FILE_NAME_TYPE;

  {*}PROCEDURE WRITE_OPTION(ROW:INTEGER;STR:BIGSTR);
  BEGIN
     GOTORC(ROW,MENUC); WRITE(STR); END;
  {*}PROCEDURE CLEAR_ROWS(ROW:INTEGER);
  VAR I:INTEGER;
  BEGIN
      FOR I:=ROW TO 24 DO BEGIN GOTORC(I,MENUC); CLREOL; END;
  END;
  {*}FUNCTION OPEN_INPUT_FILE(VAR FILEVAR:CHAR_PATTERN_FILE;FILENAME:FILE_NAME_TYPE):BOOLEAN;
  BEGIN
      OPEN_INPUT_FILE:=TRUE;
      ASSIGN(FILEVAR,FILENAME); {$I-} RESET(FILEVAR); {$I+}
      IF IORESULT <> 0 THEN BEGIN
         GOTORC(24,MENUC); WRITE('NON-EXISTENT FILE'); OPEN_INPUT_FILE:=FALSE END;
  END;
  {*}PROCEDURE STRIP_LBLANKS(VAR STR:BIGSTR);
     VAR I:INTEGER; DONE:BOOLEAN;
     BEGIN DONE:=FALSE;
           WHILE (STR[1]=' ') AND (NOT DONE) DO
                 BEGIN MOVE(STR[2],STR[1],LENGTH(STR)-1);
                       STR[0]:=CHR(ORD(STR[0])-1);
                       IF ORD(STR[0])<=0 THEN DONE:=TRUE; END;
        END; { STRIP }

BEGIN
     WRITE_OPTION(MENUR,'1. QUIT');
     WRITE_OPTION(MENUR+1,'2. READ FILE');
     WRITE_OPTION(MENUR+2, '3. WRITE FILE');
     WRITE_OPTION(MENUR+3,'4. COPY FONTS');
     WRITE_OPTION(MENUR+5,'COMMAND: ');
     READ(CMD);
     QROW:=MENUR+7; CLEAR_ROWS(QROW);
     CASE CMD OF
     1: BEGIN GOTORC(QROW,MENUC); WRITE('SURE ? (Y/N): ');
              READ(ANS); IF (ANS='y') OR (ANS='Y') THEN QUIT:=TRUE; END;
     2: BEGIN
          GOTORC(QROW,MENUC); WRITE('INPUT FILENAME:'); READ(FILENAME1);
          IF OPEN_INPUT_FILE(FILE1,FILENAME1) THEN BEGIN
             DFONT:=0; WHILE NOT EOF(FILE1) DO BEGIN
                              READ(FILE1,FONT);
                              REVFONT(FONT,FONTS[DFONT]);
                              DFONT:=(DFONT+1) MOD 256; END;
             CLOSE (FILE1); END;
          WRITE(' OK'); DISPLAY_FONT(FONTNO); END;
     3: BEGIN
          GOTORC(QROW,MENUC);
          IF LENGTH(FILENAME2)=0 THEN FILENAME2:=FILENAME1;
          WRITE('OUTPUT FILENAME (',FILENAME2,'): '); READ(FILENAME);
          IF LENGTH(FILENAME)<>0 THEN FILENAME2:=FILENAME;
          ASSIGN(FILE2,FILENAME2); REWRITE(FILE2);
          FOR SFONT:=0 TO MAXFONT DO BEGIN
              REVFONT(FONTS[SFONT],FONT); WRITE(FILE2,FONT); END;
          CLOSE(FILE2); WRITE(' OK'); END;
     4: BEGIN
TO_LBL:
           GOTORC(QROW,MENUC); WRITE('TO (',FONTNO:1,'):');
           DFONT:=FONTNO; {$I-} READ(DFONT); {$I+}
           IF IORESULT <> 0 THEN GOTO TO_LBL;

FROM_LBL:  GOTORC(QROW+1,MENUC); WRITE('FROM (<FONT#> | ROM <FONT#>):');
           XPOS:=WHEREX; YPOS:=WHEREY; READ(INSTRING);
           { PARSE INSTRING; IF CONTAINS WORD 'ROM' THEN COPY FROM ROM }
           STRPOS:=POS('ROM',INSTRING); ROM:=FALSE;
           IF STRPOS<>0 THEN BEGIN ROM:=TRUE; DELETE(INSTRING,STRPOS,3);END;
           STRIP_LBLANKS(INSTRING); VAL(INSTRING,SFONT,CODE);
           IF CODE<>0 THEN BEGIN
              GOTOXY(XPOS,YPOS); CLREOL; GOTO FROM_LBL; END;

NUM_LBL:
           GOTORC(QROW+2,MENUC); WRITE('NUM (1):'); NUM:=1; {$I-}READ(NUM); {$I+}
           IF IORESULT <> 0 THEN GOTO NUM_LBL;

           IF ROM THEN BEGIN
              MOVE(MEM[ROMSEG:(ROMOFS+SFONT*8)],FONTS[DFONT],NUM*8);
              FOR I:=DFONT TO DFONT+NUM-1 DO {REVERSE BIT PATTERNS}
                  REVFONT(FONTS[I],FONTS[I]);
              END
           ELSE MOVE(FONTS[SFONT],FONTS[DFONT],NUM*8);
           WRITE(' OK'); DISPLAY_FONT(FONTNO); END; { 4 }

      ELSE { DO NOTHING } END; { CASE }
END; { MENUS }

PROCEDURE PERFORM(KEY:KEYS); { MAJOR ROUTINE FOR EXECUTING THE NON-MENU COMMANDS }
VAR I:INTEGER; J:BYTEBITS;
BEGIN
    CASE KEY OF
    F1: { TURN ON BIT }
        IF CURCOL IN FONTS[FONTNO,CURROW] THEN DOT_CLR(CURROW,CURCOL,ON)
                                          ELSE DOT_SET(CURROW,CURCOL,ON);
    F2: { NOTHING IMPLEMENTED };
    F3: BEGIN { SHIFT LEFT }
        FOR J:=BIT1 TO BIT8 DO FOR I:=1 TO 8 DO
            IF J=BIT8 THEN DOT_CLR(I,J,OFF)
            ELSE IF J+1 IN FONTS[FONTNO,I] THEN DOT_SET(I,J,OFF)
                                           ELSE DOT_CLR(I,J,OFF);
        DOT_CURSOR(CURROW,CURCOL,ON); END;
    F4: BEGIN { SHIFT RIGHT }
        FOR J:=BIT8 DOWNTO BIT1 DO FOR I:=1 TO 8 DO
            IF J=BIT1 THEN DOT_CLR(I,J,OFF)
            ELSE IF J-1 IN FONTS[FONTNO,I] THEN DOT_SET(I,J,OFF)
                                           ELSE DOT_CLR(I,J,OFF);
        DOT_CURSOR(CURROW,CURCOL,ON); END;
    F5: BEGIN { SHIFT UP }
        FOR I:=1 TO 8 DO FOR J:=BIT1 TO BIT8 DO
            IF I=8 THEN DOT_CLR(I,J,OFF)
            ELSE IF J IN FONTS[FONTNO,I+1] THEN DOT_SET(I,J,OFF)
                                           ELSE DOT_CLR(I,J,OFF);
        DOT_CURSOR(CURROW,CURCOL,ON); END;
    F6: BEGIN { SHIFT DOWN }
        FOR I:=8 DOWNTO 1 DO FOR J:=BIT1 TO BIT8 DO
            IF I=1 THEN DOT_CLR(I,J,OFF)
            ELSE IF J IN FONTS[FONTNO,I-1] THEN DOT_SET(I,J,OFF)
                                           ELSE DOT_CLR(I,J,OFF);
        DOT_CURSOR(CURROW,CURCOL,ON); END;
    F7: BEGIN { CLEAR FONT }
        FOR I:=1 TO 8 DO FOR J:=BIT1 TO BIT8 DO DOT_CLR(I,J,OFF);
        CURROW:=1; CURCOL:=0; DOT_CURSOR(1,0,ON); END;
    F8: BEGIN { FILL FONT }
        FOR I:=1 TO 8 DO FOR J:=BIT1 TO BIT8 DO DOT_SET(I,J,OFF);
        CURROW:=1; CURCOL:=0; DOT_CURSOR(1,0,ON); END;
    F9: { GET NEW FONT NUMBER TO DISPLAY }
        BEGIN GOTORC(FONTNR,FONTNC); REVERSE; READ(FONTNO);
        DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO) END;
    INS:{ NEXT FONT }
        BEGIN FONTNO:=(FONTNO+1)MOD 256;
        DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO) END;
    DEL:{ PREVIOUS FONT }
        BEGIN FONTNO:=(FONTNO+255) MOD 256;
        DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO) END;
    F10:{ MENUS }
        MENUS;
    { CURSOR MOVEMENT ROUTINES }
    HOME: BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
                CURROW:=(CURROW+6)MOD 8+1; CURCOL:=(CURCOL+7)MOD 8;
                DOT_CURSOR(CURROW,CURCOL,ON); END;
    UP:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
                CURROW:=(CURROW+6)MOD 8+1;
                DOT_CURSOR(CURROW,CURCOL,ON); END;
    PGUP: BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
                CURROW:=(CURROW+6)MOD 8+1; CURCOL:=(CURCOL+1) MOD 8;
                DOT_CURSOR(CURROW,CURCOL,ON); END;
    LT:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
                CURCOL:=(CURCOL+7)MOD 8;
                DOT_CURSOR(CURROW,CURCOL,ON); END;
    RT:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
                CURCOL:=(CURCOL+1) MOD 8;
                DOT_CURSOR(CURROW,CURCOL,ON); END;
    EN:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
                CURROW:=CURROW MOD 8+1; CURCOL:=(CURCOL+7)MOD 8;
                DOT_CURSOR(CURROW,CURCOL,ON); END;
    DN:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
                CURROW:=CURROW MOD 8+1;
                DOT_CURSOR(CURROW,CURCOL,ON); END;
    PGDN: BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
                CURROW:=CURROW MOD 8+1; CURCOL:=(CURCOL+1) MOD 8;
                DOT_CURSOR(CURROW,CURCOL,ON); END;
    END;
END; { PERFORM }

PROCEDURE CENTER_WRITE(ROW:INTEGER; STR:BIGSTR);
VAR COL:INTEGER;
BEGIN COL:=41-LENGTH(STR) DIV 2; GOTOXY(COL,ROW); WRITE(STR); END;

BEGIN  {************** MAIN PROGRAM ********************}
    { SIGN ON }
    CLRSCR; REVERSE;
    CENTER_WRITE(8,' C R E A T E   F O N T S ');
    CENTER_WRITE(10,' B Y ');
    CENTER_WRITE(12, ' L .  J .  W I N K L E R ');
    CENTER_WRITE(16,' COPYRIGHT 1984 LAWRENCE J. WINKLER ');
    NORMAL; DELAY(4000); CLRSCR;

    { INITIALIZE VARIABLES }
    FOR FONTNO:=0 TO MAXFONT DO FOR I:=1 TO 8 DO FONTS[FONTNO,I]:=[];
    FONTNO:=0; CURROW:=1; CURCOL:=BIT1; QUIT:=FALSE;
    FILENAME1:=''; FILENAME2:='';
    LINE25;
    DISPLAY_BORDER;
    DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO);

    WHILE NOT QUIT DO
          IF KEYPRESSED THEN BEGIN
             KEY:=GETKEY(CHX,CH);
             IF (KEY <> NOKEY) AND (KEY <> NOTFCT) THEN PERFORM(KEY);
             END;

    GOTORC(24,10); WRITELN(' C R E A T E   F O N T S   TERMINATING');

END.