' UNDRLINE.BAS    - modifies VGA-font, including underlined characters
' Author          : Egbert Zijlema
' (up)Date        : October 31, 1996
' Language        : Power Basic 3.2
' Copyright status: Public Domain

DEFINT A - Z      ' all variables integer, unless specified

' equate for toggle key
  %F1   = 59 * 256                    ' toggle underline

' equates for arrow keys etc.
  %HOME = 71 * 256 : %LEFT = 75 * 256 : %RIGHT = 77 * 256
  %END  = 79 * 256 : %DEL  = 83 * 256

' equates for often used ASCII keys
  %BACKSPACE =  8 : %TAB   =  9
  %ESCAPE    = 27 : %ENTER = 13
  %CTRLY     = 25

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

TYPE FLAGS
  vga AS INTEGER
  uline AS INTEGER
END TYPE
DIM flg AS SHARED FLAGS

FUNCTION GetKey                       ' keyboard watcher
  DO
  LOOP UNTIL INSTAT
  FUNCTION = CVI( INKEY$ + CHR$(0) )
END FUNCTION

' ------------ routines for the line editor ------------------------

FUNCTION Modify$(cursor, temp$, KeyIn, length)
  txt$ = LEFT$(temp$, cursor - 1) + CHR$(KeyIn) + _
                                       MID$(temp$, cursor + IsIns + 1)
  IF LEN(txt$) > length THEN txt$ = LEFT$(txt$, length)
  IF cursor < LEN(txt$) + 1 THEN INCR cursor
  FUNCTION = txt$
END FUNCTION

SUB InsertOn
  DEF SEG = 64
  POKE 23, PEEK(23) OR 128
  DEF SEG
END SUB

SUB InsertOff
  DEF SEG = 64
  POKE 23, PEEK(23) AND 127
  DEF SEG
END SUB

FUNCTION IsIns
  DEF SEG = 64
  FUNCTION = (PEEK(23) AND 128) = 128
  DEF SEG
END FUNCTION

SUB Editor(row, col, text$, length)
  STATIC cursor
  OldInsert = IsIns                                    ' save insert status
  InsertOn                                             ' insert modus
  temp$ = LTRIM$(RTRIM$(text$))
  COLOR 15, 0
  LOCATE row, col, 0 : PRINT temp$
  IF cursor = 0 THEN cursor = LEN(temp$) + 1
  DO WHILE (cursor > LEN(temp$) + 1)
    DECR cursor
  LOOP

  DO
    LOCATE row, col + cursor - 1, 1                    ' visible cursor
    KeyIn = GetKey
    SELECT CASE KeyIn
      CASE %F1
        IF flg.vga = 0 THEN EXIT SELECT                ' vga-card only
        IF flg.uline THEN flg.uline = 0 ELSE flg.uline = -1
      CASE %HOME  : cursor = 1
      CASE %END   : cursor = LEN(temp$) + 1
      CASE %LEFT  : IF cursor > 1 THEN DECR cursor
      CASE %RIGHT : IF cursor < LEN(temp$) + 1 THEN INCR cursor
      CASE %DEL
        temp$ = LEFT$(temp$, cursor - 1) + _
                MID$(temp$, cursor + 1)
      CASE %BACKSPACE
        IF cursor > 1 THEN
          temp$ = LEFT$(temp$, cursor - 2) + MID$(temp$, cursor)
          DECR cursor
        END IF
      CASE %CTRLY, %ESCAPE
        cursor = 1 : temp$ = ""                        ' erase line
        IF KeyIn = %ESCAPE THEN
          LOCATE row, col : PRINT SPACE$(length)
          EXIT LOOP
        END IF
      CASE %TAB
        ScrollAscii128Plus choice
        IF choice = 0 THEN EXIT SELECT
        temp$ = Modify$(cursor, temp$, choice, length)
      CASE %ENTER
        EXIT LOOP
      CASE 32 TO 122
        SELECT CASE KeyIn
          CASE 65 TO 90 : IF flg.uline THEN DECR KeyIn, 64
          CASE > 96     : IF flg.uline THEN INCR KeyIn, 122
          CASE 48 TO 57 : IF flg.uline THEN INCR KeyIn, 197
        END SELECT
        temp$ = Modify$(cursor, temp$, KeyIn, length)
    END SELECT
    LOCATE row, col : PRINT SPACE$(length)
    LOCATE row, col : PRINT temp$;
  LOOP

  IF OldInsert THEN InsertOn ELSE InsertOff            ' restore insert
  text$ = temp$
  COLOR 7                                              ' unbold text
  LOCATE row, col : PRINT text$
END SUB

SUB ScrollAscii128Plus(choice)
  IF flg.vga THEN
    FOR count = 128 TO 147
      accent$ = accent$ + CHR$(count)
    NEXT
  ELSE
    accent$ = CHR$(128, 129, 130, 131, 132) + _
              CHR$(133, 135, 136, 137, 138) + _
              CHR$(139, 142, 144, 147, 148) + _
              CHR$(149, 153, 154, 160, 162)
  END IF

  COLOR 7, 0
  LOCATE 24, 22 : PRINT accent$;
  COLOR 0, 7
  LOCATE 24, 22 : PRINT LEFT$(accent$, 1);
  LocalCur = 1
  DO
    LOCATE , , 0
    KeyIn = GetKey
    SELECT CASE KeyIn
      CASE %F1
      IF flg.uline THEN flg.uline = 0 ELSE flg.uline = -1
      CASE %LEFT
        DECR LocalCur
        IF LocalCur < 1 THEN LocalCur = LEN(accent$)
      CASE %END
        LocalCur = LEN(accent$)
      CASE %HOME
        LocalCur = 1
      CASE %RIGHT
        INCR LocalCur
        IF LocalCur > LEN(accent$) THEN LocalCur = 1
      CASE %ENTER
        choice = LocalCur + 127
        IF flg.uline THEN INCR choice, 20
        EXIT LOOP
      CASE %ESCAPE
        choice = 0
        EXIT LOOP
    END SELECT
    COLOR 7, 0
    LOCATE 24, 22 : PRINT accent$
    COLOR 0, 7
    LOCATE 24, 21 + LocalCur : PRINT MID$(accent$, LocalCur, 1)
  LOOP
  COLOR 7, 0
  LOCATE 24, 22 : PRINT SPACE$(LEN(accent$))
  COLOR 15
  LOCATE , , 1
END SUB

' -------------- end of editor routines --------------------

SUB ModifyPattern(font$)
  change$ = MID$(font$, 65 * 16 + 1, 26 * 16)      ' grab A - Z
  count = 1 : pattern$ = ""                        ' (re)set
  DO
    pattern$ = pattern$ + MID$(change$, count, 15) ' first 15 bytes
    pattern$ = pattern$ + CHR$(254)
    INCR count, 16                                 ' next character pattern
  LOOP UNTIL count = 26 * 16 + 1                   ' until 26 chars modified
  LoadFont pattern$, 26, 1                         ' 26 chars (ASCII 1)

  change$ = MID$(font$, 97 * 16 + 1, 26 * 16)      ' grab a - z
  count = 1 : pattern$ = ""
  DO
    pattern$ = pattern$ + MID$(change$, count, 15)
    pattern$ = pattern$ + CHR$(254)
    INCR count, 16
  LOOP UNTIL count = 26 * 16 + 1
  LoadFont pattern$, 26, 219

  change$ = MID$(font$, 48 * 16 + 1, 10 * 16)      ' grab 0 - 9
  count = 1 : pattern$ = ""
  DO
    pattern$ = pattern$ + MID$(change$, count, 15)
    pattern$ = pattern$ + CHR$(254)
    INCR count, 16
  LOOP UNTIL count = 10 * 16 + 1
  LoadFont pattern$, 10, 245

  change$ = MID$(font$, 128 * 16 + 1, 6 * 16) + _  ' grab 20 overstrikes
            MID$(font$, 135 * 16 + 1, 5 * 16) + _
            MID$(font$, 142 * 16 + 1, 1 * 16) + _
            MID$(font$, 144 * 16 + 1, 1 * 16) + _
            MID$(font$, 147 * 16 + 1, 3 * 16) + _
            MID$(font$, 153 * 16 + 1, 2 * 16) + _
            MID$(font$, 160 * 16 + 1, 1 * 16) + _
            MID$(font$, 162 * 16 + 1, 1 * 16)
  count = 1
  pattern$ = change$
  DO
    pattern$ = pattern$ + MID$(change$, count, 15)
    pattern$ = pattern$ + CHR$(254)
    INCR count, 16
  LOOP UNTIL count = 20 * 16 + 1
  LoadFont pattern$, 40, 128

  count = 0 : pattern$ = ""
  TestBtmLine$ = MID$(font$, 17, 16)                 ' grab chr$(1)
  WHILE RIGHT$(TestBtmLine$, 1) = CHR$(0)
    TestBtmLine$ = LEFT$(TestBtmLine$, LEN(TestBtmLine$) - 1)
    INCR count
  WEND
  CopRite$ = CHR$(126, 129, 189, 165, 161, 165, 189, 129, 126) + _
             STRING$(count, 0)
  pattern$ = RIGHT$(STRING$(16, 0) + CopRite$, 16)
  LoadFont pattern$, 1, 124
  pattern$ = ""
  phone$   = CHR$(126, 255, 153,  60, 126, 126) + _
             STRING$(count, 0)
  pattern$ = RIGHT$(STRING$(16, 0) + phone$, 16)
  LoadFont pattern$, 1, 127
END SUB

SUB LoadFont(pattern$, HowMany, Where)
  REG %AX, &H1100                 ' service for AX
  REG %BX, &H1000                 ' 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 RetrieveDefaultFont
  IF BIT(pbvScrnCard, 4) THEN         ' vga-card only!
    flg.vga = -1                      ' yes
    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
    pattern$ = PEEK$(pointer, 4096)   ' grab 4096 bytes (= 256 chars)
    DEF SEG                           ' restore default segment
    ModifyPattern pattern$            ' modify it
    REG %AX, &H1103                   ' service
    REG %BX, 0                        ' use block 0
    CALL INTERRUPT &H10
  END IF
END SUB

' demo calling module
CLS
  RetrieveDefaultFont
  IF flg.vga THEN
    Copyright$ = CHR$(124)
    PhoneSymb$ = CHR$(127)
  ELSE
    Copyright$ = "(C)"
    PhoneSymb$ = "Phone: "
  END IF
  LOCATE 2, 2
    PRINT "UNDRLINE.BAS - source code for font modifications"
  LOCATE 3, 2
    PRINT Copyright$; " 1996: Public Domain"
  LOCATE 4, 2
    PRINT "Author: Egbert Zijlema, "; PhoneSymb$; " +31 50 5348997"

  LOCATE 8, 10
  PRINT "This is normal text"
  LOCATE 9, 10
  TextToDisplay$ = "And this is underlined"
  FOR count = 1 TO LEN(TextToDisplay$)
    character = ASC( MID$(TextToDisplay$, count, 1) )
    SELECT CASE character
      CASE 65 TO 90  : DECR character, 64
      CASE 97 TO 122 : INCR character, 122
      CASE 48 TO 57  : INCR character, 197
    END SELECT
    PRINT CHR$(character);
  NEXT

  LOCATE 11, 10 : PRINT "Now it's your turn to type a couple of lines"
  LOCATE 12, 10 : PRINT "Press F1 to (un)select underlining, ";
                  PRINT "Tab to scan 128+ characters"
  LOCATE 13, 10 : PRINT "   or Esc to quit editor"

  Editor 15, 10, FirstLine$, 30
  Editor 16, 10, SecndLine$, 20
  SLEEP
  SCREEN , 0                    ' restore defaults
END