home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / 30TURUTL.ZIP / CRFONTS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-02-18  |  15.5 KB  |  419 lines
  1.  
  2. PROGRAM FONTS(INPUT,OUTPUT);
  3. CONST
  4.       KEY1='TOGGLE'; KEY2=' '; KEY3='SHLT'; KEY4='SHRT'; KEY5='SHUP';
  5.       KEY6='SHDN'; KEY7='CLR'; KEY8='FILL'; KEY9='#'; KEY10='MENU';
  6.       KEYINS='+1'; KEYDEL='-1';
  7.  
  8.       MAXFONT=255; BIT1=0; BIT8=7;
  9.  
  10.       DOT=22; HLINE=205; VLINE=186; LUC=201; RUC=187; RLC=188; LLC=200;
  11.  {                   M          :        I        ;        <        H    }
  12.  
  13.       { LOCATION OF FRAME. LUCR0 & LUCC0 LOCATE UPPER LEFT-HAND CORNER, WHILE
  14.         HSTEP & VSTEP DETERMINE ITS SIZE. }
  15.  
  16.       LUCR0=3; LUCC0=4; HSTEP=2; VSTEP=1;
  17.  
  18.       MENUR=5; MENUC=40;
  19.  
  20. TYPE
  21.     BIGSTR = STRING[80];
  22.     BYTEBITS = BIT1..BIT8;
  23.     PATTERN_SET = SET OF BYTEBITS; CHAR_PATTERN = ARRAY[1..8] OF PATTERN_SET;
  24.     FILE_NAME_TYPE = STRING[14];
  25.     CHAR_PATTERN_FILE = FILE OF CHAR_PATTERN;
  26.     REG_LENGTH = (REG_WORD,REG_BYTE);
  27.     REGPACK = RECORD CASE REG_LENGTH OF
  28.                      REG_WORD: (AX,BX,CX,DX,BPX,SIX,DIX,DSX,ESX,FLAGX: INTEGER);
  29.                      REG_BYTE: (AL,AH,BL,BH,CL,CH,DL,DH:BYTE;
  30.                                 BP,SI,DI,DS,ES,FLAG:INTEGER);
  31.                      END;
  32.  
  33.    KEYS = (NOKEY,NOTFCT,
  34.            F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,
  35.            HOME,UP,PGUP,LT,RT,EN,DN,PGDN,INS,DEL);
  36.  
  37.    ON_OFF = (ON,OFF);
  38.  
  39. VAR
  40.     FONTS: ARRAY[0..MAXFONT] OF CHAR_PATTERN;
  41.     FILENAME1,FILENAME2: FILE_NAME_TYPE;
  42.     FILE1,FILE2:CHAR_PATTERN_FILE;
  43.     FONTNO,FONTNR,FONTNC,XYR,XYC: INTEGER;
  44.     KEY:KEYS; CH,CHX:CHAR;
  45.     I,J:INTEGER;
  46.     CURROW,CURCOL:INTEGER; { CURRENT LOGICAL CURSOR POSITION }
  47.     QUIT:BOOLEAN;
  48.  
  49. {*************************** P R O C E D U R E S  **************************}
  50. PROCEDURE REVERSE; { CHANGES OUTPUT TO REVERSE VIDEO }
  51.           BEGIN TEXTCOLOR(BLACK); TEXTBACKGROUND(WHITE); END;
  52.  
  53. PROCEDURE NORMAL; { CHANGES OUTPUT TO NORMAL VIDEO }
  54.           BEGIN TEXTCOLOR(WHITE); TEXTBACKGROUND(BLACK); END;
  55.  
  56. FUNCTION GETKEY(VAR CHX,CH:CHAR): KEYS;
  57. CONST ESC=27;
  58. BEGIN
  59. IF KEYPRESSED THEN BEGIN  { READ KEYBOARD, AND MAP INTO 'KEYS' TYPE }
  60.    READ(KBD,CH); CHX:=CHR(0);
  61.    IF ORD(CH)=ESC THEN
  62.       IF KEYPRESSED THEN BEGIN CHX:=CH; READ(KBD,CH) END;
  63.  
  64.    IF CHX=CHR(0) THEN GETKEY:=NOTFCT
  65.    ELSE CASE CH OF
  66.         ';':  GETKEY:=F1;
  67.         '<':  GETKEY:=F2;
  68.         '=':  GETKEY:=F3;
  69.         '>':  GETKEY:=F4;
  70.         '?':  GETKEY:=F5;
  71.         '@':  GETKEY:=F6;
  72.         'A':  GETKEY:=F7;
  73.         'B':  GETKEY:=F8;
  74.         'C':  GETKEY:=F9;
  75.         'D':  GETKEY:=F10;
  76.         'G':  GETKEY:=HOME;
  77.         'H':  GETKEY:=UP;
  78.         'I':  GETKEY:=PGUP;
  79.         'K':  GETKEY:=LT;
  80.         'M':  GETKEY:=RT;
  81.         'O':  GETKEY:=EN;
  82.         'P':  GETKEY:=DN;
  83.         'Q':  GETKEY:=PGDN;
  84.         'R':  GETKEY:=INS;
  85.         'S':  GETKEY:=DEL;
  86.         ELSE GETKEY:=NOTFCT;
  87.         END { CASE }
  88.     END {KEYPRESSED}
  89. ELSE GETKEY:=NOKEY;
  90. END; {GETKEY}
  91.  
  92. PROCEDURE BLINKVIDEO;
  93.           BEGIN TEXTCOLOR(WHITE+BLINK) END;
  94.  
  95. FUNCTION LOCATE_ROW(I:INTEGER): INTEGER;
  96.          BEGIN LOCATE_ROW:=LUCR0+VSTEP*I; END;
  97.  
  98. FUNCTION LOCATE_COL(I:BYTEBITS): INTEGER;
  99.          BEGIN LOCATE_COL:=LUCC0+HSTEP*(I+1); END;
  100.  
  101. PROCEDURE GOTORC(ROW,COL:INTEGER);
  102.           BEGIN GOTOXY(COL,ROW); END;
  103.  
  104. {**** REVERSE THE BITS IN A SET TYPE.  THE BIT NUMBERING FOR GRAPHICS
  105.       PATTERNS IS A MIRROR IMAGE OF THE BIT NUMBERING FOR PASCAL SETS. }
  106. PROCEDURE REVFONT(FONT:CHAR_PATTERN;VAR TFONT:CHAR_PATTERN);
  107. VAR I:INTEGER;
  108.  
  109. {*} PROCEDURE REVSET(PSET:PATTERN_SET;VAR TPSET:PATTERN_SET);
  110.     VAR I:BYTEBITS;
  111.     BEGIN TPSET:=[];
  112.           FOR I:=BIT1 TO BIT8 DO IF I IN PSET THEN TPSET:=TPSET + [BIT8-I];
  113.     END;
  114.  
  115. BEGIN
  116.    FOR I:=1 TO 8 DO REVSET(FONT[I],TFONT[I]);
  117. END;
  118.  
  119. PROCEDURE DISPLAY_COORD(ROW:INTEGER;COL:BYTEBITS);
  120. VAR X,Y:INTEGER;
  121. BEGIN X:=WHEREX; Y:=WHEREY; GOTORC(XYR,XYC); REVERSE;
  122.       WRITE(' ',ROW:1,',',COL+1:1,' '); NORMAL;
  123.       GOTOXY(X,Y); END;
  124.  
  125. PROCEDURE DOT_CLR(I:INTEGER;J:BYTEBITS; CURSOR:ON_OFF);
  126.           BEGIN FONTS[FONTNO][I]:= FONTS[FONTNO][I] - [J];
  127.                 GOTORC(LOCATE_ROW(I),LOCATE_COL(J));
  128.                 IF CURSOR=ON THEN BEGIN
  129.                    DISPLAY_COORD(I,J); BLINKVIDEO; WRITE(CHR(DOT)); NORMAL; END
  130.                 ELSE WRITE(' ');
  131.           END;
  132.  
  133. PROCEDURE DOT_SET(I:INTEGER;J:BYTEBITS; CURSOR:ON_OFF);
  134.           BEGIN FONTS[FONTNO,I] := FONTS[FONTNO,I] + [J];
  135.                 GOTORC(LOCATE_ROW(I),LOCATE_COL(J));
  136.                 IF CURSOR=ON THEN BEGIN
  137.                    DISPLAY_COORD(I,J); HIGHVIDEO END
  138.                 ELSE LOWVIDEO;
  139.                 WRITE(CHR(DOT));
  140.           NORMAL;
  141.           END;
  142.  
  143. PROCEDURE DOT_CURSOR(ROW:INTEGER;COL:BYTEBITS;CURSOR:ON_OFF);
  144.           BEGIN GOTORC(LOCATE_ROW(ROW),LOCATE_COL(COL));
  145.                 IF COL IN FONTS[FONTNO,ROW] THEN BEGIN
  146.                    IF CURSOR=ON THEN BEGIN
  147.                       DISPLAY_COORD(ROW,COL); HIGHVIDEO END
  148.                    ELSE LOWVIDEO; WRITE(CHR(DOT)) END
  149.                 ELSE IF CURSOR=ON THEN BEGIN
  150.                         DISPLAY_COORD(ROW,COL);BLINKVIDEO; WRITE(CHR(DOT)); END
  151.                      ELSE WRITE(' ');
  152.            NORMAL;
  153.            END;
  154.  
  155. PROCEDURE LINE25; { PRINTOUT THE LINE 25 INFORMATION }
  156. VAR KEYNO:INTEGER;
  157.   PROCEDURE WRITEKEY(KEY:BIGSTR);
  158.             BEGIN NORMAL; KEYNO:=KEYNO+1;
  159.             IF KEYNO<>1 THEN WRITE(' ');
  160.             IF KEYNO<=10 THEN WRITE(KEYNO:1)
  161.             ELSE IF KEYNO=11 THEN WRITE('INS') ELSE WRITE('DEL');
  162.             REVERSE; WRITE(KEY); NORMAL; END;
  163.  
  164. BEGIN
  165.    GOTOXY(1,25);  KEYNO:=0;
  166.    WRITEKEY(KEY1); WRITEKEY(KEY2); WRITEKEY(KEY3); WRITEKEY(KEY4); WRITEKEY(KEY5);
  167.    WRITEKEY(KEY6); WRITEKEY(KEY7); WRITEKEY(KEY8); WRITEKEY(KEY9); WRITEKEY(KEY10);
  168.    WRITEKEY(KEYINS); WRITEKEY(KEYDEL);
  169. END; {LINE25}
  170.  
  171. PROCEDURE DISPLAY_BORDER;
  172. VAR I,RTCOL,BTMROW:INTEGER;
  173. BEGIN
  174.    HIGHVIDEO;
  175.  
  176.    { WRITE OUT CORNER CHARACTERS }
  177.    GOTORC(LUCR0,LUCC0); WRITE(CHR(LUC));
  178.    RTCOL:=LUCC0+9*HSTEP; GOTORC(LUCR0,RTCOL); WRITE(CHR(RUC));
  179.    BTMROW:=LUCR0+9*VSTEP; GOTORC(BTMROW,LUCC0); WRITE(CHR(LLC));
  180.    GOTORC(BTMROW,RTCOL); WRITE(CHR(RLC));
  181.  
  182.    { WRITE OUT LINES OF FRAME }
  183.    FOR I:=LUCC0+1 TO RTCOL-1 DO BEGIN
  184.        GOTORC(LUCR0,I); WRITE(CHR(HLINE)); GOTORC(BTMROW,I); WRITE(CHR(HLINE)); END;
  185.    FOR I:=LUCR0+1 TO BTMROW-1 DO BEGIN
  186.        GOTORC(I,LUCC0); WRITE(CHR(VLINE)); GOTORC(I,RTCOL); WRITE(CHR(VLINE)); END;
  187.  
  188.    { INITIALIZE THE SCREEN POSITION OF THE FONT NUMBER }
  189.    FONTNR:=LUCR0-1; FONTNC:=RTCOL-4;
  190.    XYR:=FONTNR; XYC:=LUCC0;
  191.  
  192. END; { DISPLAY_BORDER }
  193.  
  194. PROCEDURE DISPLAY_FONTNO(FONTNO:INTEGER);
  195.           BEGIN REVERSE; GOTORC(FONTNR,FONTNC); WRITE(' ',FONTNO:3,' '); NORMAL; END;
  196.  
  197. PROCEDURE DISPLAY_FONTS(FONT:CHAR_PATTERN);
  198. VAR I,ROW:INTEGER; COL,J:BYTEBITS;
  199. BEGIN
  200.     LOWVIDEO;
  201.     FOR I:=1 TO 8 DO BEGIN
  202.         ROW:=LOCATE_ROW(I); { GET SCREEN POSITION OF THE Ith ROW }
  203.         FOR J:=BIT1 TO BIT8 DO BEGIN
  204.             COL:=LOCATE_COL(J); { GET SCREEN POSITION OF THE Jth COLUMN }
  205.             GOTORC(ROW,COL);
  206.             IF J IN FONT[I] THEN WRITE(CHR(DOT)) ELSE WRITE(' ');
  207.             END;
  208.         END;
  209.     CURROW:=1; CURCOL:=BIT1; DOT_CURSOR(CURROW,CURCOL,ON);
  210. END; { DISPLAY A FONT }
  211.  
  212. PROCEDURE DISPLAY_FONT(FONTNO:INTEGER);
  213. BEGIN DISPLAY_FONTS(FONTS[FONTNO]); END;
  214.  
  215. PROCEDURE MENUS;
  216. LABEL TO_LBL,FROM_LBL,NUM_LBL;
  217. CONST ROMOFS=$FA6E; ROMSEG=$F000;
  218. VAR CMD:1..4; QROW:INTEGER;
  219.     FONT:CHAR_PATTERN;
  220.     SFONT,DFONT,CODE,NUM,I,STRPOS,XPOS,YPOS:INTEGER;
  221.     INSTRING: STRING[80];
  222.     ROM:BOOLEAN;
  223.     PATTERN: PATTERN_SET; MEMBYTE:BYTE ABSOLUTE PATTERN;
  224.     ANS:CHAR;
  225.     FILENAME:FILE_NAME_TYPE;
  226.  
  227.   {*}PROCEDURE WRITE_OPTION(ROW:INTEGER;STR:BIGSTR);
  228.   BEGIN
  229.      GOTORC(ROW,MENUC); WRITE(STR); END;
  230.   {*}PROCEDURE CLEAR_ROWS(ROW:INTEGER);
  231.   VAR I:INTEGER;
  232.   BEGIN
  233.       FOR I:=ROW TO 24 DO BEGIN GOTORC(I,MENUC); CLREOL; END;
  234.   END;
  235.   {*}FUNCTION OPEN_INPUT_FILE(VAR FILEVAR:CHAR_PATTERN_FILE;FILENAME:FILE_NAME_TYPE):BOOLEAN;
  236.   BEGIN
  237.       OPEN_INPUT_FILE:=TRUE;
  238.       ASSIGN(FILEVAR,FILENAME); {$I-} RESET(FILEVAR); {$I+}
  239.       IF IORESULT <> 0 THEN BEGIN
  240.          GOTORC(24,MENUC); WRITE('NON-EXISTENT FILE'); OPEN_INPUT_FILE:=FALSE END;
  241.   END;
  242.   {*}PROCEDURE STRIP_LBLANKS(VAR STR:BIGSTR);
  243.      VAR I:INTEGER; DONE:BOOLEAN;
  244.      BEGIN DONE:=FALSE;
  245.            WHILE (STR[1]=' ') AND (NOT DONE) DO
  246.                  BEGIN MOVE(STR[2],STR[1],LENGTH(STR)-1);
  247.                        STR[0]:=CHR(ORD(STR[0])-1);
  248.                        IF ORD(STR[0])<=0 THEN DONE:=TRUE; END;
  249.         END; { STRIP }
  250.  
  251. BEGIN
  252.      WRITE_OPTION(MENUR,'1. QUIT');
  253.      WRITE_OPTION(MENUR+1,'2. READ FILE');
  254.      WRITE_OPTION(MENUR+2, '3. WRITE FILE');
  255.      WRITE_OPTION(MENUR+3,'4. COPY FONTS');
  256.      WRITE_OPTION(MENUR+5,'COMMAND: ');
  257.      READ(CMD);
  258.      QROW:=MENUR+7; CLEAR_ROWS(QROW);
  259.      CASE CMD OF
  260.      1: BEGIN GOTORC(QROW,MENUC); WRITE('SURE ? (Y/N): ');
  261.               READ(ANS); IF (ANS='y') OR (ANS='Y') THEN QUIT:=TRUE; END;
  262.      2: BEGIN
  263.           GOTORC(QROW,MENUC); WRITE('INPUT FILENAME:'); READ(FILENAME1);
  264.           IF OPEN_INPUT_FILE(FILE1,FILENAME1) THEN BEGIN
  265.              DFONT:=0; WHILE NOT EOF(FILE1) DO BEGIN
  266.                               READ(FILE1,FONT);
  267.                               REVFONT(FONT,FONTS[DFONT]);
  268.                               DFONT:=(DFONT+1) MOD 256; END;
  269.              CLOSE (FILE1); END;
  270.           WRITE(' OK'); DISPLAY_FONT(FONTNO); END;
  271.      3: BEGIN
  272.           GOTORC(QROW,MENUC);
  273.           IF LENGTH(FILENAME2)=0 THEN FILENAME2:=FILENAME1;
  274.           WRITE('OUTPUT FILENAME (',FILENAME2,'): '); READ(FILENAME);
  275.           IF LENGTH(FILENAME)<>0 THEN FILENAME2:=FILENAME;
  276.           ASSIGN(FILE2,FILENAME2); REWRITE(FILE2);
  277.           FOR SFONT:=0 TO MAXFONT DO BEGIN
  278.               REVFONT(FONTS[SFONT],FONT); WRITE(FILE2,FONT); END;
  279.           CLOSE(FILE2); WRITE(' OK'); END;
  280.      4: BEGIN
  281. TO_LBL:
  282.            GOTORC(QROW,MENUC); WRITE('TO (',FONTNO:1,'):');
  283.            DFONT:=FONTNO; {$I-} READ(DFONT); {$I+}
  284.            IF IORESULT <> 0 THEN GOTO TO_LBL;
  285.  
  286. FROM_LBL:  GOTORC(QROW+1,MENUC); WRITE('FROM (<FONT#> | ROM <FONT#>):');
  287.            XPOS:=WHEREX; YPOS:=WHEREY; READ(INSTRING);
  288.            { PARSE INSTRING; IF CONTAINS WORD 'ROM' THEN COPY FROM ROM }
  289.            STRPOS:=POS('ROM',INSTRING); ROM:=FALSE;
  290.            IF STRPOS<>0 THEN BEGIN ROM:=TRUE; DELETE(INSTRING,STRPOS,3);END;
  291.            STRIP_LBLANKS(INSTRING); VAL(INSTRING,SFONT,CODE);
  292.            IF CODE<>0 THEN BEGIN
  293.               GOTOXY(XPOS,YPOS); CLREOL; GOTO FROM_LBL; END;
  294.  
  295. NUM_LBL:
  296.            GOTORC(QROW+2,MENUC); WRITE('NUM (1):'); NUM:=1; {$I-}READ(NUM); {$I+}
  297.            IF IORESULT <> 0 THEN GOTO NUM_LBL;
  298.  
  299.            IF ROM THEN BEGIN
  300.               MOVE(MEM[ROMSEG:(ROMOFS+SFONT*8)],FONTS[DFONT],NUM*8);
  301.               FOR I:=DFONT TO DFONT+NUM-1 DO {REVERSE BIT PATTERNS}
  302.                   REVFONT(FONTS[I],FONTS[I]);
  303.               END
  304.            ELSE MOVE(FONTS[SFONT],FONTS[DFONT],NUM*8);
  305.            WRITE(' OK'); DISPLAY_FONT(FONTNO); END; { 4 }
  306.  
  307.       ELSE { DO NOTHING } END; { CASE }
  308. END; { MENUS }
  309.  
  310. PROCEDURE PERFORM(KEY:KEYS); { MAJOR ROUTINE FOR EXECUTING THE NON-MENU COMMANDS }
  311. VAR I:INTEGER; J:BYTEBITS;
  312. BEGIN
  313.     CASE KEY OF
  314.     F1: { TURN ON BIT }
  315.         IF CURCOL IN FONTS[FONTNO,CURROW] THEN DOT_CLR(CURROW,CURCOL,ON)
  316.                                           ELSE DOT_SET(CURROW,CURCOL,ON);
  317.     F2: { NOTHING IMPLEMENTED };
  318.     F3: BEGIN { SHIFT LEFT }
  319.         FOR J:=BIT1 TO BIT8 DO FOR I:=1 TO 8 DO
  320.             IF J=BIT8 THEN DOT_CLR(I,J,OFF)
  321.             ELSE IF J+1 IN FONTS[FONTNO,I] THEN DOT_SET(I,J,OFF)
  322.                                            ELSE DOT_CLR(I,J,OFF);
  323.         DOT_CURSOR(CURROW,CURCOL,ON); END;
  324.     F4: BEGIN { SHIFT RIGHT }
  325.         FOR J:=BIT8 DOWNTO BIT1 DO FOR I:=1 TO 8 DO
  326.             IF J=BIT1 THEN DOT_CLR(I,J,OFF)
  327.             ELSE IF J-1 IN FONTS[FONTNO,I] THEN DOT_SET(I,J,OFF)
  328.                                            ELSE DOT_CLR(I,J,OFF);
  329.         DOT_CURSOR(CURROW,CURCOL,ON); END;
  330.     F5: BEGIN { SHIFT UP }
  331.         FOR I:=1 TO 8 DO FOR J:=BIT1 TO BIT8 DO
  332.             IF I=8 THEN DOT_CLR(I,J,OFF)
  333.             ELSE IF J IN FONTS[FONTNO,I+1] THEN DOT_SET(I,J,OFF)
  334.                                            ELSE DOT_CLR(I,J,OFF);
  335.         DOT_CURSOR(CURROW,CURCOL,ON); END;
  336.     F6: BEGIN { SHIFT DOWN }
  337.         FOR I:=8 DOWNTO 1 DO FOR J:=BIT1 TO BIT8 DO
  338.             IF I=1 THEN DOT_CLR(I,J,OFF)
  339.             ELSE IF J IN FONTS[FONTNO,I-1] THEN DOT_SET(I,J,OFF)
  340.                                            ELSE DOT_CLR(I,J,OFF);
  341.         DOT_CURSOR(CURROW,CURCOL,ON); END;
  342.     F7: BEGIN { CLEAR FONT }
  343.         FOR I:=1 TO 8 DO FOR J:=BIT1 TO BIT8 DO DOT_CLR(I,J,OFF);
  344.         CURROW:=1; CURCOL:=0; DOT_CURSOR(1,0,ON); END;
  345.     F8: BEGIN { FILL FONT }
  346.         FOR I:=1 TO 8 DO FOR J:=BIT1 TO BIT8 DO DOT_SET(I,J,OFF);
  347.         CURROW:=1; CURCOL:=0; DOT_CURSOR(1,0,ON); END;
  348.     F9: { GET NEW FONT NUMBER TO DISPLAY }
  349.         BEGIN GOTORC(FONTNR,FONTNC); REVERSE; READ(FONTNO);
  350.         DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO) END;
  351.     INS:{ NEXT FONT }
  352.         BEGIN FONTNO:=(FONTNO+1)MOD 256;
  353.         DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO) END;
  354.     DEL:{ PREVIOUS FONT }
  355.         BEGIN FONTNO:=(FONTNO+255) MOD 256;
  356.         DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO) END;
  357.     F10:{ MENUS }
  358.         MENUS;
  359.     { CURSOR MOVEMENT ROUTINES }
  360.     HOME: BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  361.                 CURROW:=(CURROW+6)MOD 8+1; CURCOL:=(CURCOL+7)MOD 8;
  362.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  363.     UP:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  364.                 CURROW:=(CURROW+6)MOD 8+1;
  365.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  366.     PGUP: BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  367.                 CURROW:=(CURROW+6)MOD 8+1; CURCOL:=(CURCOL+1) MOD 8;
  368.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  369.     LT:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  370.                 CURCOL:=(CURCOL+7)MOD 8;
  371.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  372.     RT:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  373.                 CURCOL:=(CURCOL+1) MOD 8;
  374.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  375.     EN:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  376.                 CURROW:=CURROW MOD 8+1; CURCOL:=(CURCOL+7)MOD 8;
  377.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  378.     DN:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  379.                 CURROW:=CURROW MOD 8+1;
  380.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  381.     PGDN: BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  382.                 CURROW:=CURROW MOD 8+1; CURCOL:=(CURCOL+1) MOD 8;
  383.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  384.     END;
  385. END; { PERFORM }
  386.  
  387. PROCEDURE CENTER_WRITE(ROW:INTEGER; STR:BIGSTR);
  388. VAR COL:INTEGER;
  389. BEGIN COL:=41-LENGTH(STR) DIV 2; GOTOXY(COL,ROW); WRITE(STR); END;
  390.  
  391. BEGIN  {************** MAIN PROGRAM ********************}
  392.     { SIGN ON }
  393.     CLRSCR; REVERSE;
  394.     CENTER_WRITE(8,' C R E A T E   F O N T S ');
  395.     CENTER_WRITE(10,' B Y ');
  396.     CENTER_WRITE(12, ' L .  J .  W I N K L E R ');
  397.     CENTER_WRITE(16,' COPYRIGHT 1984 LAWRENCE J. WINKLER ');
  398.     NORMAL; DELAY(4000); CLRSCR;
  399.  
  400.     { INITIALIZE VARIABLES }
  401.     FOR FONTNO:=0 TO MAXFONT DO FOR I:=1 TO 8 DO FONTS[FONTNO,I]:=[];
  402.     FONTNO:=0; CURROW:=1; CURCOL:=BIT1; QUIT:=FALSE;
  403.     FILENAME1:=''; FILENAME2:='';
  404.     LINE25;
  405.     DISPLAY_BORDER;
  406.     DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO);
  407.  
  408.     WHILE NOT QUIT DO
  409.           IF KEYPRESSED THEN BEGIN
  410.              KEY:=GETKEY(CHX,CH);
  411.              IF (KEY <> NOKEY) AND (KEY <> NOTFCT) THEN PERFORM(KEY);
  412.              END;
  413.  
  414.     GOTORC(24,10); WRITELN(' C R E A T E   F O N T S   TERMINATING');
  415.  
  416. END.
  417.  
  418.  
  419.