'===========================================================================
' Subject: GENERIC FONT DESIGNER             Date: Year of 1993 (00:00)   
' Author:  Calvin French                     Code: QB, PDS                
' Keys:    GENERIC,FONT,DESIGNER           Packet: GRAPHICS.ABC
'===========================================================================
DEFINT A-Z
'
' GFONT - Gerneric font designer for QBABBS. Calvin French 1993.
' version 0.0 - pre-release
'
' Press "c" to see a palette of colors. It can be configured
' via bpp to show anywhere from 2 to 256 different colors (bpp is
' bits per pixel).
'
' SUB GFontDraw (bpp, w, h, wc, hc, xg, yg, xc, yc, GfxArr())
' bpp - bits per pixel
' w   - width in pixels
' h   - height in pixels
' wc  - width of one cell (for color selection, as well)
' hc  - hieght of one cell (for color selection, as well)
' xg  - grid x starting
' yg  - grid y starting
' xc  - color selection grid x starting
' yc  - color selection grid y starting
' GfxArr - Integer array (w,h) containing the color of each
'          pixel.
'
' It's very integrateable and you should have no problems changing
' stuff. Have fun and I HOPE that this helps (at least a little)
'
DECLARE SUB GFontDraw (bpp, w, h, wc, hc, xg, yg, xc, yc, GfxArr())
DECLARE SUB GFontDrawScreen ()
DECLARE FUNCTION GFontColor (bpp%, wc%, hc%, xc%, yc%)
DECLARE FUNCTION GFontMenu (MenuArr$())

CONST true = -1, false = NOT true

SCREEN 13

DIM GfxArr%(1 TO 30, 1 TO 30)
CALL GFontDrawScreen
CALL GFontDraw(8, 30, 30, 5, 5, 30, 30, 32, 32, GfxArr%())

FUNCTION GFontColor (bpp, wc, hc, xc, yc)

SELECT CASE bpp
  CASE 1                ' 2 colors   [MCGA]
    h = 1
    w = 2
    MaxColor = 1
  CASE 2                ' 4 colors   [CGA]
    h = 1
    w = 4
    MaxColor = 3
  CASE 4                ' 16 colors  [EGA]
    h = 2
    w = 8
    MaxColor = 15
  CASE 8                ' 256 colors [VGA]
    h = 11
    w = 24
    MaxColor = 255
END SELECT

'
' save the background
'
DIM BackArr((w * wc + 2) * (h * hc + 2) + 2)
GET (xc - 1, yc - 1)-(xc + (w * wc) + 1, yc + (h * hc) + 1), BackArr

'
' draw the box
'
LINE (xc, yc)-(xc + (w * wc), yc + (h * hc)), 0, BF
LINE (xc - 1, yc - 1)-(xc + (w * wc) + 1, yc + (h * hc) + 1), 15, B

'
' Draw the color palette
'
FOR y = 0 TO h - 1
  FOR x = 0 TO w - 1
    LINE (xc + (x * wc) + 1, yc + (y * hc) + 1)-(xc + (x * wc) + (wc - 1), yc + (y * hc) + (hc - 1)), NextColor, BF
    NextColor = NextColor + 1
    IF NextColor > MaxColor THEN NextColor = MaxColor
  NEXT x
NEXT y

oldx = 1
oldy = 1
x = 1
y = 1

'
' main color choosing loop
'
DO
  '
  ' update cursor position, et cetera
  '
  LINE (xc + ((oldx - 1) * wc), yc + ((oldy - 1) * hc))-(xc + ((oldx - 1) * wc) + wc, yc + ((oldy - 1) * hc) + hc), 0, B
  LINE (xc + ((x - 1) * wc), yc + ((y - 1) * hc))-(xc + ((x - 1) * wc) + wc, yc + ((y - 1) * hc) + hc), 15, B
  oldx = x
  oldy = y

  '
  ' inkey loop
  '
  DO
    key$ = INKEY$
  LOOP UNTIL LEN(key$)

  '
  ' take action
  '
  SELECT CASE key$
    CASE CHR$(&H0) + CHR$(&H48)   ' [up]
      y = y - 1
      IF y < 1 THEN y = 1
    CASE CHR$(&H0) + CHR$(&H50)   ' [down]
      y = y + 1
      IF y > h THEN y = h
    CASE CHR$(&H0) + CHR$(&H4B)   ' [left]
      x = x - 1
      IF x < 1 THEN x = 1
    CASE CHR$(&H0) + CHR$(&H4D)   ' [right]
      x = x + 1
      IF x > w THEN x = w
    CASE CHR$(&HD)                ' [enter]
      GFontColor = POINT(xc + ((x - 1) * wc + 1), yc + ((y - 1) * hc) + 1)
      PUT (xc - 1, yc - 1), BackArr, PSET
      EXIT FUNCTION
  END SELECT
LOOP


END FUNCTION

SUB GFontDraw (bpp, w, h, wc, hc, xg, yg, xc, yc, GfxArr())

'
' save the background
'
DIM BackArr((w * wc + 2) * (h * hc + 2) + 2)
GET (xg - 1, yg - 1)-(xg + (w * wc) + 1, yg + (h * hc) + 1), BackArr

'
' draw the box
'
LINE (xg, yg)-(xg + (w * wc), yg + (h * hc)), 0, BF
LINE (xg - 1, yg - 1)-(xg + (w * wc) + 1, yg + (h * hc) + 1), 15, B

'
' draw the image (if any)
'
FOR x = 0 TO w - 1
  FOR y = 0 TO h - 1
    LINE (xg + (x * wc) + 1, yg + (y * hc) + 1)-(xg + (x * wc) + (wc - 1), yg + (y * hc) + (hc - 1)), GfxArr(x + 1, y + 1), BF
  NEXT y
NEXT x

x = 1
y = 1
c = 15
oldx = 1
oldy = 1

'
' main drawing loop
'
DO
  '
  ' update cursor position, et cetera
  '
  LINE (xg + ((oldx - 1) * wc), yg + ((oldy - 1) * hc))-(xg + ((oldx - 1) * wc) + wc, yg + ((oldy - 1) * hc) + hc), 0, B
  LINE (xg + ((x - 1) * wc), yg + ((y - 1) * hc))-(xg + ((x - 1) * wc) + wc, yg + ((y - 1) * hc) + hc), 15, B
  oldx = x
  oldy = y

  '
  ' inkey loop
  '
  DO
    key$ = INKEY$
  LOOP UNTIL LEN(key$)

  '
  ' take action
  '
  SELECT CASE key$
    CASE CHR$(&H20)               ' [spacebar]
      LINE (xg + ((x - 1) * wc) + 1, yg + ((y - 1) * hc) + 1)-(xg + ((x - 1) * wc) + (wc - 1), yg + ((y - 1) * hc) + (hc - 1)), c, BF
      GfxArr(x, y) = c
    CASE CHR$(&H0) + CHR$(&H48)   ' [up]
      y = y - 1
      IF y < 1 THEN y = 1
    CASE CHR$(&H0) + CHR$(&H50)   ' [down]
      y = y + 1
      IF y > h THEN y = h
    CASE CHR$(&H0) + CHR$(&H4B)   ' [left]
      x = x - 1
      IF x < 1 THEN x = 1
    CASE CHR$(&H0) + CHR$(&H4D)   ' [right]
      x = x + 1
      IF x > w THEN x = w
    CASE "c", "C"                 ' [c] or [C]
      c = GFontColor(bpp, wc, hc, xc, yc)
    CASE CHR$(&H9)                ' [tab]
      REDIM MenuArr$(4)
      MenuArr$(0) = " GFont Grid Menu:"
      MenuArr$(1) = " Save image to font"
      MenuArr$(2) = " Load image from font"
      MenuArr$(3) = " Return to editor"
      MenuArr$(4) = " Quit GFont"
      SELECT CASE GFontMenu(MenuArr$())
        CASE 1: 'GFontPutChar    ' [Save image to font]
        CASE 2: 'GFontGetChar    ' [Load image from font]
        CASE 3:                 ' [Return to editor]
        CASE 4                  ' [Quit GFont]
          PUT (xg - 1, yg - 1), BackArr, PSET
          EXIT SUB
      END SELECT
  END SELECT
LOOP

END SUB

DEFSNG A-Z
SUB GFontDrawScreen

LINE (1, 1)-(319, 199), 32, BF

END SUB

DEFINT A-Z
SUB GFontMakeFontFile (FileName$)

DIM GFontBuff AS STRING * 80

PRINT
PRINT "Creating font file: "; FileName$
PRINT
DO
  INPUT "Width?", w$

LOOP UNTIL VAL(w$) <> 0
DO
  INPUT "Hieght?", h$
LOOP UNTIL VAL(h$) <> 0

OPEN FileName$ FOR BINARY AS #1

GFontBuff$ = " GFont font file for QBABBS. GFont [PD] by Calvin French August 1993. " + CHR$(26)

PUT #1, , GFontBuff$

wid = VAL(w$)
PUT #1, , wid
hie = VAL(h$)
PUT #1, , hie



END SUB

FUNCTION GFontMenu (MenuArr$())

LastOpt = UBOUND(MenuArr$)

FOR n = 0 TO LastOpt
  IF LEN(MenuArr$(n)) > LongestLen THEN LongestLen = LEN(MenuArr$(n))
NEXT n

x1 = 32
y1 = 32
x2 = x1 + LongestLen * 8 + 32
y2 = y1 + (LastOpt + 1) * 8

DIM BackArr((x2 - x1 + 2) * (y2 - y1 + 2) + 4)
GET (x1 - 1, y1 - 1)-(x2 + 1, y2 + 1), BackArr
LINE (x1 - 1, y1 - 1)-(x2 + 1, y2 + 1), 0, BF
LINE (x1 - 1, y1 - 1)-(x2 + 1, y2 + 1), 15, B

LOCATE y1 \ 8 + 1, x1 \ 8 + 1
COLOR 13
PRINT MenuArr$(0);

CurrOpt = 1

DO
  '
  ' Update menu
  '
  FOR n = 1 TO LastOpt
    IF n = CurrOpt THEN
      COLOR 15
    ELSE
      COLOR 7
    END IF
    LOCATE y1 \ 8 + n + 1, x1 \ 8 + 1
    PRINT MenuArr$(n);
  NEXT n

  DO
    key$ = INKEY$
  LOOP UNTIL LEN(key$)

  SELECT CASE key$
    CASE CHR$(&H0) + CHR$(&H48)   ' [up]
      CurrOpt = CurrOpt - 1
      IF CurrOpt < 1 THEN CurrOpt = 1
    CASE CHR$(&H0) + CHR$(&H50)   ' [down]
      CurrOpt = CurrOpt + 1
      IF CurrOpt > LastOpt THEN CurrOpt = LastOpt
    CASE CHR$(&HD)                ' [enter]
      GFontMenu = CurrOpt
      PUT (x1 - 1, y1 - 1), BackArr, PSET
      EXIT FUNCTION
  END SELECT

LOOP

END FUNCTION