' =============================================================================
'                   Source code: PowerBASIC for DOS

'           Author: Egbert Zijlema (e.zylema@castel.nl)
' Copyright status: Public Domain
'
' Color & font routines for VGA
' Enables 2 fonts at a time in text mode
' Enables intense background colors

' Related article at: http://www.basicguru.com/zijlema/fonts.htm
' =============================================================================

DEFINT A - Z

DIM underlined AS SHARED BYTE, BrightWhite AS SHARED BYTE
underlined = 15

' equates for registers
%AX = 1 : %BX = 2 : %CX = 3
%DX = 4 : %BP = 7 : %ES = 9

' equates for keys
%ESC   = 27
%UP    = 72 * 256
%LEFT  = 75 * 256
%RIGHT = 77 * 256
%DOWN  = 80 * 256

CLS
  IF BIT(pbvScrnCard, 4) THEN         ' ega/vga only!

    ' precautions for colors
    GetPalette 15, red, green, blue   ' RGB for intense white
    ChangeColor 6, red, green, blue   ' make brown intense white
    BrightWhite = 6
    DisableIntensByPlainBasic         ' intensity bit off for dual fonts

    GetDefaultFont ft$
    Loadfont ft$, 256, 0, 4           ' copy original font to block 4

    ' modify and load underlined chars
    UnderlineFont

    ' enable both fonts
    REG %AX, &H1103
    REG %BX, &H0020
    CALL INTERRUPT &H10
    vga = -1
  ELSE
    BrightWhite = 15
  END IF

  COLOR 7, 0
  LOCATE 2, 2 : PRINT "This is normal white (COLOR 7)"

  COLOR underlined
  LOCATE 3, 2 : PRINT "This is COLOR 15. When your PC has a VGA-card, ";
                PRINT "text should be underlined."

  COLOR BrightWhite
  LOCATE 4, 2 : PRINT "This is either COLOR 6 (modified for VGA) ";
                PRINT "or COLOR 15."

  IF vga THEN
    COLOR 7
    LOCATE 6, 6 : PRINT "Down arrow: turn this font upside down"
    LOCATE 7, 6 : PRINT "Up arrow  : restore default font"
    COLOR underlined
    LOCATE 8, 6 : PRINT "Left arrow: reverse this one left/right"
    LOCATE 9, 6 : PRINT "Right     : restore underlined"
  END IF
  COLOR BrightWhite
  LOCATE 25, 2 : PRINT "Press ESC to quit";

  DO
    arrow = GetKey
    SELECT CASE arrow
      CASE %DOWN
        IF vga THEN UpsideDown
      CASE %LEFT
        IF vga THEN ReverseFont
      CASE %RIGHT
        IF vga THEN UnderlineFont
      CASE %UP
        GetDefaultFont font$
        LoadFont font$, 256, 0, 0
    END SELECT
  LOOP UNTIL arrow = %ESC
  IF LEN(DIR$("UNDRLINE.FNT")) THEN KILL "UNDRLINE.FNT"
  IF LEN(DIR$("UPSIDE.FNT")) THEN KILL "UPSIDE.FNT"
  IF LEN(DIR$("REVERS.FNT")) THEN KILL "REVERS.FNT"
  SCREEN , 0                            ' restore DOS defaults
END

SUB GetDefaultFont(font$)
  REG %AX, &H1130                         ' service
  REG %BX, &H0600                         ' get vga-pattern
  CALL INTERRUPT &H10
  segment = REG(%ES)                      ' segment in ES
  pointer = REG(%BP)                      ' offset in BP
  DEF SEG = segment                       ' load segment
  font$   = PEEK$(pointer, 4096)          ' grab 4096 bytes (= 256 chars)
  DEF SEG
END SUB

SUB UnderlineFont
  IF LEN(DIR$("UNDRLINE.FNT")) THEN
    OPEN "UNDRLINE.FNT" FOR BINARY AS #1
    GET$ #1, LOF(1), font$
    CLOSE #1
    pattern$ = font$
  ELSE
    GetDefaultFont font$

    ' search non-zero line of underscore
    match =  0
    DO
      INCR match
      undersc$ = MID$(font$, 96 * 16 - match, 1)
    LOOP UNTIL undersc$ <> CHR$(0)

    MID$(font$, 95 * 16 + 1, 16) = STRING$(16, 0) ' empty underscore

    modify$ = MID$(font$, 32 * 16 + 1, 134 * 16)  ' chars 32 - 165
    count = -15
    DO
      INCR count, 16                              ' first/next char
      pattern$ = pattern$ + _
                 MID$(modify$, count, 15) + _     ' 15 lines of char
                 undersc$                         ' add underscore
    LOOP UNTIL count = 134 * 16 + 1               ' until 32-165 modified
    OPEN "UNDRLINE.FNT" FOR BINARY AS #1
    PUT$ #1, pattern$
    CLOSE #1
  END IF
  LoadFont pattern$, 134, 32, 4                   ' load 134 chars in block 4
END SUB

SUB UpsideDown
  IF LEN(DIR$("UPSIDE.FNT")) THEN
    OPEN "UPSIDE.FNT" FOR BINARY AS #1
    GET$ #1, LOF(1), font$
    CLOSE #1
    pattern$ = font$
  ELSE
    GetDefaultFont font$
    modify$ = MID$(font$, 33 * 16 + 1, 133 * 16)  ' chars 33 - 165
    count = -15
    DO
      INCR count, 16
      char$ = MID$(modify$, count, 16)
      FOR subcount = 16 TO 1 STEP -1
        pattern$ = pattern$ + MID$(char$, subcount, 1)
      NEXT
    LOOP UNTIL count = 133 * 16 + 1
    OPEN "UPSIDE.FNT" FOR BINARY AS #1
    PUT$ #1, pattern$
    CLOSE #1
  END IF
  LoadFont pattern$, 133, 33, 0
END SUB

SUB ReverseFont
  IF LEN(DIR$("REVERS.FNT")) THEN
    OPEN "REVERS.FNT" FOR BINARY AS #1
    GET$ #1, LOF(1), font$
    CLOSE #1
    pattern$ = font$
  ELSE
    GetDefaultFont font$
    modify$ = MID$(font$, 32 * 16 + 1, 134 * 16)
    count = -15
    DO
      INCR count, 16
      char$ = MID$(modify$, count, 16)
      FOR subcount = 1 TO LEN(char$) - 1        ' 15 lines
        temp$ = RIGHT$("00000000" + BIN$(CVBYT(MID$(char$, subcount, 1))), 8)
        reverse$ = ""
        FOR inverse = 8 TO 1 STEP -1
          reverse$ = reverse$ + MID$(temp$, inverse, 1)
        NEXT
        pattern$ = pattern$ + MKBYT$(VAL("&B" + reverse$))
      NEXT
    pattern$ = pattern$ + MKBYT$(255)           ' re-add underscore
    LOOP UNTIL count = 134 * 16 + 1
    OPEN "REVERS.FNT" FOR BINARY AS #1
    PUT$ #1, pattern$
    CLOSE #1
  END IF
  LoadFont pattern$, 134, 32, 4
END SUB

SUB LoadFont(pattern$, HowMany, Where, blok)
  REG %AX, &H1100                 ' service for AX
  REG %BX, &H1000 + blok          ' 16 bytes per char in BH
  REG %CX, HowMany                ' nbr of characters in CX
  REG %DX, Where                  ' first char in ASCII-set to modify
  REG %ES, STRSEG(pattern$)       ' varseg in ES
  REG %BP, STRPTR(pattern$)       ' varptr in BP
  CALL INTERRUPT &H10
END SUB

SUB DisableIntensByPlainBasic
  FOR kolor = 8 TO 15
    GetPalette kolor - 8, red, green, blue
    ChangeColor kolor, red, green, blue
  NEXT
END SUB

SUB DisableIntensByAssembler
  ASM mov bl, 0       ; Initialise
label:
  ASM mov ax, &H1007  ; Read palette register in BL
  ASM int &H10        ; Value is returned in BH
  ASM add bl, 8       ; Address palette register n+8
  ASM mov ax, &H1000  ; Write value in BH to palette register in BL
  ASM int &H10
  ASM sub bl, 7       ; Palette register n+1
  ASM cmp bl, 8       ; Done eight?
  ASM jb label        ; If not, loop back
END SUB

SUB ChangeColor(BYVAL kolor, red, green, blue)
  SELECT CASE kolor
    CASE 6   : kolor = 20
    CASE > 7 : INCR kolor, 48
  END SELECT
  REG %AX, &H1010
  REG %BX, kolor
  REG %CX, green * 256 + blue
  REG %DX, red * 256
  CALL INTERRUPT &H10
END SUB

SUB GetPalette(BYVAL kolor, red, green, blue)
 SELECT CASE kolor
    CASE 6   : kolor = 20
    CASE > 7 : INCR kolor, 48
  END SELECT
  REG %AX, &H1015
  REG %BX, kolor
  CALL INTERRUPT &H10
  red   = REG(%DX) \ 256
  green = REG(%CX) \ 256
  blue  = REG(%CX) MOD 256
END SUB

FUNCTION GetKey AS INTEGER
  DO
  LOOP UNTIL INSTAT
  FUNCTION = CVI(INKEY$ + CHR$(0))
END FUNCTION