'===========================================================================
' Subject: FONT DESIGN                        Date: Year of 1992 (00:00)   
'  Author: Jon Springer                       Code: QB, QBasic, PDS        
'  Origin: FONT,DESIGN                      Packet: EGAVGA.ABC
'===========================================================================
DEFINT A-Z
DECLARE SUB Get.input ()
DECLARE SUB Editor ()
DECLARE SUB In.key ()
DECLARE SUB Out.alphabet ()
DECLARE SUB Save.font ()
DECLARE SUB Load.font ()
DECLARE SUB Put.pixel ()
DECLARE SUB Help ()
DECLARE SUB Fill ()
DECLARE SUB Insert ()
DECLARE SUB Delete ()
DECLARE SUB Gets.puts ()
DIM SHARED font(62, 16, 16), store(16, 16), box(1 TO 2), grid(16, 16)
DIM SHARED i, z, a$, k$, name$, flag, delay, down, across, X, Y
DIM SHARED maxacross, maxdown, cell, gonk
ON ERROR GOTO Handler
LET box(1) = 16: box(2) = 16: maxacross = 64: maxdown = 35
    down = 1: across = 1: name$ = "default": delay = 60
KEY 1, CHR$(176): KEY 2, CHR$(177): SCREEN 9: COLOR 11, 8: WIDTH 80, 25
'-----------------------------------------------------------------
main:
CLS : Get.input: CLS
maxacross = INT(640 / box(1)): maxdown = INT(350 / box(2)): z = 0: i = 0: a$ = ""
edit.start:
   Editor
GOTO main:
Handler:
     BEEP
     SELECT CASE ERR
     CASE 52 TO 67
     PRINT : PRINT "An error in file-handling has occurred..."
     PRINT "Any key...": a$ = INPUT$(1)
     CLOSE : SCREEN , , 0, 0: COLOR 13, 8
     CASE 6
     PRINT "Bad input...Try again"; : a$ = INPUT$(1)
     RESUME main
     CASE ELSE
     SCREEN , , 0, 0: CLS : PRINT "Unrecoverable Error #"; ERR
     IF ERR = 5 THEN PRINT "256k EGA required for FONT...": a$ = INPUT$(1)
     END
     END SELECT
     RESUME edit.start
 

SUB Delete
PALETTE 12, 13
  FOR i = cell + 1 TO 62
    FOR glom = 1 TO box(1)
      FOR glim = 1 TO box(2)
        LET font(i - 1, glom, glim) = font(i, glom, glim)
      NEXT
    NEXT
  NEXT
    FOR glom = 1 TO box(1)
      FOR glim = 1 TO box(2)
        LET font(62, glom, glim) = 0
      NEXT
    NEXT: Out.alphabet: i = 0
END SUB

SUB Editor
start.editor:
     cell = 1
     COLOR 14, 8
     LOCATE 1, 1: PRINT "Editing "; CHR$(34); name$; CHR$(34); "  ";
     PRINT box(1); "across"; box(2); "down";
     PRINT "              Font Display Window"
     LINE (0, 13)-(639, 15), 12, BF: LINE (320, 0)-(323, 300), 12, BF
     LINE (0, 300)-(639, 303), 12, BF
     LOCATE 23, 1: PRINT "<?> displays other useful keys.        ";
     PRINT "         <Esc> Exits Editor";
     LOCATE 25, 1: PRINT "<Space> & cursor keys edit cell.";
     PRINT "               <F1> Save  <F2> Load";
     LINE (320, 303)-(323, 350), 12, BF: LINE (0, 325)-(639, 327), 12, BF
     IF gonk = 1 THEN Out.alphabet
     COLOR 13, 8
     LOCATE 4, 1: PRINT "Enter lower/upper case letters or"
     PRINT " # 0/9 to move among cells.": COLOR 14, 8
do.grid:
     LOCATE 20, 1: PRINT "You are at cell"; cell; "; "
     IF cell < 27 THEN
        PRINT "The letter "; CHR$(cell + 64); "                  "
     END IF
     IF cell > 26 AND cell < 53 THEN
        PRINT "The letter "; CHR$(cell - 26 + 96); "         "
     END IF
     IF cell > 52 THEN PRINT "A user defined cell"
     LINE (10, 100)-(200, 260), 0, BF
     FOR i = 1 TO box(2)
       FOR z = 1 TO box(1)
        IF font(cell, z, i) = 0 THEN
          LINE (10 * z, 100 + ((i - 1) * 10))-(10 * z + 10, 100 + ((i - 1) * 10) + 10), 15, B
        ELSE
          LINE (10 * z, 100 + ((i - 1) * 10))-(10 * z + 10, 100 + ((i - 1) * 10) + 10), 15, BF
        END IF
       NEXT z
     NEXT i
in.k:
     In.key
     IF i = 6 THEN GOTO do.grid
     IF i = 2 THEN GOTO animate
     IF i = 3 THEN EXIT SUB
     IF i = 4 THEN Save.font
     IF i = 5 THEN Load.font
     IF i = 1 THEN Out.alphabet
     IF i = 13 THEN Help
     IF i = 7 THEN Insert
     IF i = 8 THEN Delete
     IF i = 9 OR i = 10 THEN Fill
     IF i = 11 OR i = 12 THEN Gets.puts
   IF flag = 1 THEN LET flag = 0: GOTO start.editor
   GOTO do.grid
animate:
    LET font(cell, across, down) = font(cell, across, down) + 1
    IF font(cell, across, down) = 2 THEN LET font(cell, across, down) = 0
      IF font(cell, across, down) = 1 THEN
      LINE (10 * across, 100 + ((down - 1) * 10))-(10 * across + 10, 100 + ((down - 1) * 10) + 10), 15, BF
      ELSE
      LINE (10 * across, 100 + ((down - 1) * 10))-(10 * across + 10, 100 + ((down - 1) * 10) + 10), 0, BF
      LINE (10 * across, 100 + ((down - 1) * 10))-(10 * across + 10, 100 + ((down - 1) * 10) + 10), 15, B
    END IF
  gonk = 1:  Put.pixel:  GOTO in.k
END SUB

SUB Fill
  IF i = 9 THEN LET g = 0 ELSE g = 1
  FOR glom = 1 TO box(1)
     FOR glim = 1 TO box(2)
     LET font(cell, glom, glim) = g
     LET across = glom: LET down = glim: Put.pixel
     NEXT
  NEXT
LET down = 1: LET across = 1
END SUB

SUB Get.input
  LOCATE 1, 12: PRINT "Font Des";
  LINE (30, 20)-(610, 260), 13, B
  PRINT "ign   vers.";
  LINE (40, 30)-(600, 250), 13, B
  PAINT (31, 21), 1, 13
  PRINT "2.5   ****   written by Jon Springer    "
  LOCATE 4, 23: PRINT "Enter a number to change options": COLOR 14, 8
  LOCATE 5, 21: PRINT STRING$(40, "- ")
  LOCATE 7, 22: PRINT "1>   Character box across."
  LOCATE 9, 22: PRINT "2>   Character box down..."
  LOCATE 11, 22: PRINT "3>   Font Set name........"
  LOCATE 13, 22: PRINT "4>   Screen blanker......."
  LOCATE 14, 21: PRINT STRING$(40, "- "): COLOR 11
  LOCATE 16, 22: PRINT "Esc>   Go to Editor"
  LOCATE 17, 22: PRINT "Q>     System"
  GOSUB print.options
'--------------------------------------------------------------------
stuff.input:
  LOCATE 23, 1: a$ = INKEY$: z = z + 1: IF z = 5000 THEN z = 1
  IF z = 1 THEN PRINT CHR$(219)
  IF z = 2500 THEN PRINT " "
  IF a$ = "" THEN GOTO stuff.input
  IF a$ = "Q" OR a$ = "q" THEN GOTO end.message
  IF a$ = CHR$(27) THEN EXIT SUB
  IF a$ = "1" THEN GOSUB one
  IF a$ = "2" THEN GOSUB two
  IF a$ = "3" THEN GOSUB three
  IF a$ = "4" THEN GOSUB four
  GOSUB print.options
  LOCATE 23, 1: PRINT STRING$(78, " ")
  GOTO stuff.input
one:
INPUT "Enter character box across "; a$
i = VAL(a$)
IF i > 16 THEN LET i = 16
IF i < 2 THEN LET i = 2
box(1) = INT(i)
a$ = ""
RETURN
two: 
INPUT "Enter character box down "; a$
i = VAL(a$)
IF i > 16 THEN LET i = 16
IF i < 2 THEN LET i = 2
box(2) = INT(i)
a$ = ""
RETURN
three:
LINE INPUT "Enter new name > "; k$
IF k$ = "" THEN RETURN
IF LEN(k$) > 8 OR LEN(k$) < 1 THEN LOCATE 23, 1: GOTO three
LET name$ = k$
RETURN
four:
INPUT "Enter new screen blanker delay "; a$
i = VAL(a$)
IF i > 200 THEN LET i = 200
IF i < 10 THEN LET i = 10
delay = INT(i) * 2
a$ = ""
RETURN
print.options:
  LOCATE 7, 48: PRINT box(1): LOCATE 9, 48: PRINT box(2)
  LOCATE 11, 49: PRINT name$; "                ":
  LOCATE 13, 48: PRINT delay / 2; "   ": RETURN
end.message:
SCREEN 0: COLOR 14: PRINT "FONT DESIGN 2.5...1992": PRINT : COLOR 7, 0: END
END SUB

SUB Gets.puts
  IF i = 11 THEN GOTO gets
puts:
  FOR lom = 1 TO box(1)
     FOR lim = 1 TO box(2)
     LET font(cell, lom, lim) = store(lom, lim)
     LET across = lom: LET down = lim: Put.pixel
     NEXT
  NEXT
  EXIT SUB
gets:
  FOR lom = 1 TO box(1)
     FOR lim = 1 TO box(2)
     LET store(lom, lim) = font(cell, lom, lim)
     NEXT
  NEXT
END SUB

SUB Help
SCREEN , , 1, 1: CLS
LOCATE 2, 30: COLOR 13, 8: PRINT "*** Help Screen ***"
LOCATE 20, 30: PRINT "***** Any Key *****"
LOCATE 3, 30: COLOR 1: PRINT STRING$(80, 176): PRINT : PRINT : COLOR 14
PRINT "<Enter>   = Refresh font display window": PRINT
PRINT "<Insert>  = Insert a blank cell, bumping last cell in the font"
PRINT "<Delete>  = Delete a cell, moving all cells after it up one "
PRINT : PRINT "<Home>    = Clear a cell"
PRINT "<End>     = Fill a cell": PRINT
PRINT "<Pg Up>   = Store a cell"
 PRINT "<Pg Down> = Paste the stored cell"
LOCATE 17, 30: COLOR 1: PRINT STRING$(80, 176): COLOR 15
stuf.input:
  LOCATE 25, 1: a$ = INKEY$: z = z + 1: IF z = 5000 THEN z = 1
  IF z = 1 THEN PRINT CHR$(219);
  IF z = 2500 THEN PRINT " ";
  IF a$ = "" THEN GOTO stuf.input
a$ = "": SCREEN , , 0, 0: COLOR 14
END SUB

SUB In.key
   flag = 0: Null$ = CHR$(0)
main.input:
     LINE (10 * across, 100 + ((down - 1) * 10))-(10 * across + 10, 100 + ((down - 1) * 10) + 10), col, B
     a$ = INKEY$: z = z + 1: IF z > 1000 THEN LET z = 1
     IF z = 1 THEN col = 14 ELSE IF z = 500 THEN col = 4: LET nerf = nerf + 1
      IF nerf = delay THEN GOSUB blanker
     IF a$ = "" THEN GOTO main.input
     nerf = 0
     IF a$ = CHR$(8) THEN LET i = 1: flag = 1: EXIT SUB
     IF a$ = CHR$(13) THEN LET i = 1: EXIT SUB
     IF a$ = " " THEN LET i = 2: EXIT SUB
     IF a$ = CHR$(27) THEN LET i = 3: EXIT SUB
     IF a$ = CHR$(176) THEN LET i = 4: EXIT SUB
     IF a$ = CHR$(177) THEN LET i = 5: EXIT SUB
     IF a$ = "?" OR a$ = "/" THEN LET i = 13: EXIT SUB
   SELECT CASE a$
     CASE Null$ + CHR$(75)   ' LEFT key: move cursor left
         flag = 1
         LINE (10 * across, 100 + ((down - 1) * 10))-(10 * across + 10, 100 + ((down - 1) * 10) + 10), 15, B
         across = across - 1: IF across = 0 THEN across = box(1)
     CASE Null$ + CHR$(77)   ' RIGHT key: move cursor right
         flag = 1
         LINE (10 * across, 100 + ((down - 1) * 10))-(10 * across + 10, 100 + ((down - 1) * 10) + 10), 15, B
         across = across + 1: IF across > box(1) THEN across = 1
     CASE Null$ + CHR$(72)   ' UP key: move cursor up
         flag = 1
         LINE (10 * across, 100 + ((down - 1) * 10))-(10 * across + 10, 100 + ((down - 1) * 10) + 10), 15, B
         down = down - 1: IF down = 0 THEN down = box(2)
     CASE Null$ + CHR$(80)   ' DOWN key: move cursor down
         flag = 1
         LINE (10 * across, 100 + ((down - 1) * 10))-(10 * across + 10, 100 + ((down - 1) * 10) + 10), 15, B
         down = down + 1: IF down > box(2) THEN down = 1
     CASE Null$ + CHR$(82)
         i = 7: EXIT SUB
     CASE Null$ + CHR$(83)
         i = 8: EXIT SUB
     CASE Null$ + CHR$(71)
         i = 9: EXIT SUB
     CASE Null$ + CHR$(79)
         i = 10: EXIT SUB
     CASE Null$ + CHR$(73)
         i = 11: EXIT SUB
     CASE Null$ + CHR$(81)
         i = 12: EXIT SUB
   END SELECT
   LOCATE 7, 1: PRINT "ACROSS"; across; " DOWN"; down; "     "
 
   IF flag = 1 THEN LET flag = 0: GOTO main.input
i = 6
IF ASC(a$) < 48 THEN LET cell = 1: EXIT SUB
IF ASC(a$) < 58 THEN LET cell = 53 + (ASC(a$) - 48): EXIT SUB
IF ASC(a$) >= 65 AND ASC(a$) <= 90 THEN
  LET cell = 1 + (ASC(a$) - 65): EXIT SUB
END IF
IF ASC(a$) >= 97 AND ASC(a$) <= 122 THEN
   LET cell = 27 + (ASC(a$) - 97): EXIT SUB
END IF
LET cell = 1: EXIT SUB
blanker:
   nerf = 0: SCREEN , , 1, 1: COLOR 0, 0: LINE (0, 0)-(639, 349), 0, BF
   a$ = INPUT$(1): SCREEN , , 0, 0: a$ = "": COLOR 14, 8: RETURN
END SUB

SUB Insert
PALETTE 12, 13
  FOR i = 61 TO cell STEP -1
    FOR glom = 1 TO box(1)
      FOR glim = 1 TO box(2)
        LET font(i + 1, glom, glim) = font(i, glom, glim)
      NEXT
    NEXT
  NEXT
    FOR glom = 1 TO box(1)
      FOR glim = 1 TO box(2)
        LET font(cell, glom, glim) = 0
      NEXT
    NEXT: Out.alphabet: i = 0
END SUB

SUB Load.font
   gonk = 1
   SCREEN , , 1, 1
   LOCATE 1, 1: CLS
   FILES "*.f": PRINT : PRINT
   INPUT "Load what font "; a$
   IF LEN(a$) > 8 OR LEN(a$) < 1 THEN BEEP: GOTO endall2
   OPEN a$ + ".f" FOR INPUT AS #1
   INPUT #1, box(1), box(2)
   ERASE font
   FOR i = 1 TO 62
     FOR ii = 1 TO box(1)
     FOR iii = 1 TO box(2)
       INPUT #1, font(i, ii, iii)
     NEXT iii
     NEXT ii
   NEXT i
   LET name$ = a$
   CLOSE
endall2:
SCREEN , , 0, 0
     across = 1: down = 1
     COLOR 14, 8
     FOR i = 1 TO 12
     LOCATE i + 3, 42: PRINT STRING$(38, " ")
     NEXT
     LOCATE 1, 1: PRINT "Editing "; CHR$(34); name$;
     PRINT CHR$(34); "  "; box(1); "across"; box(2); "down";
     LINE (0, 13)-(639, 15), 12, BF: LINE (320, 0)-(323, 300), 12, BF
     COLOR 14, 8
     Out.alphabet
 
END SUB

SUB Out.alphabet
   IF flag = 0 THEN X = 330: Y = 50 ELSE X = 2: Y = 2
   IF flag = 1 THEN SCREEN 7
   PALETTE 12, 13
   FOR i = 1 TO 13
     FOR across = 1 TO box(1)
     FOR down = 1 TO box(2)
     IF font(i, across, down) = 1 THEN col = 15 ELSE col = 0
     PSET (X + (i * box(1)) + across, Y + down), col
     IF font(i + 13, across, down) = 1 THEN col = 15 ELSE col = 0
     PSET (X + (i * box(1)) + across, Y + down + 30), col
     IF font(i + 26, across, down) = 1 THEN col = 15 ELSE col = 0
     PSET (X + (i * box(1)) + across, Y + down + 60), col
     IF font(i + 39, across, down) = 1 THEN col = 15 ELSE col = 0
     PSET (X + (i * box(1)) + across, Y + down + 90), col
     IF i < 11 THEN
       IF font(i + 52, across, down) = 1 THEN col = 15 ELSE col = 0
       PSET (X + (i * box(1)) + across, Y + down + 120), col
     END IF
     NEXT down
     NEXT across
   NEXT i
   IF flag = 0 THEN GOTO past.it.all
   COLOR 15: LOCATE 21, 3: FOR i = 1 TO 26: PRINT CHR$(64 + i); : NEXT
   LOCATE 23, 3: FOR i = 1 TO 26: PRINT CHR$(96 + i); : NEXT
   a$ = INPUT$(1): a$ = "": down = 1: across = 1
   SCREEN 9: COLOR 13, 8: EXIT SUB
past.it.all:
down = 1: across = 1: PALETTE: COLOR 14, 8
END SUB

SUB Put.pixel
  dx = 0: i = cell
  IF cell > 13 THEN LET dx = dx + 30: i = cell - 13
  IF cell > 26 THEN LET dx = dx + 30: i = cell - 26
  IF cell > 39 THEN LET dx = dx + 30: i = cell - 39
  IF cell > 52 THEN LET dx = dx + 30: i = cell - 52
  IF font(cell, across, down) = 1 THEN LET col = 15 ELSE LET col = 0
  PSET (330 + (i * box(1)) + across, dx + 50 + down), col
END SUB

SUB Save.font
   SCREEN , , 1, 1: LOCATE 1, 1: CLS
   FILES "*.*": PRINT : PRINT
   PRINT TAB(10); "Save "; name$; " to disk?"; : a$ = INPUT$(1)
   IF a$ <> "Y" AND a$ <> "y" THEN GOTO endall
   OPEN name$ + ".F" FOR OUTPUT AS #1
   WRITE #1, box(1), box(2)
   FOR i = 1 TO 62
     FOR ii = 1 TO box(1)
     FOR iii = 1 TO box(2)
        IF ii = box(1) AND iii = box(2) THEN
          IF font(i, ii, iii) = 1 THEN PRINT #1, "1" ELSE PRINT #1, "0"
        ELSE
          IF font(i, ii, iii) = 1 THEN PRINT #1, "1,";  ELSE PRINT #1, "0,";
        END IF
     NEXT iii
     NEXT ii
   NEXT i
   CLOSE
endall:
 SCREEN , , 0, 0: COLOR 14, 8
END SUB