Power-Programmierung/CD1.mdf/basic/library/qb_pds/ansi/pansi.bas

BASIC Source File | 1992-07-24 | 20.6 KB | 670 lines

'PANSI.BAS v1.50
'ANSI emulator for QuickBASIC 4.5 and PDS
'By Richard Geldreich July 24, 1992
'Don't forget that "CALL INTERRUPT" is used- load QB with "QB/l"

'I have fixed up & improved the ANSI escape sequence state machine. It
'now works faster. I still don't know why I'm releasing this driver,
'because I'm going to release my all-assembly version very soon...
'(the assembly version of this driver is light years ahead of this program!)
'See the PrintANSI procedure for a list of bug fixes.

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'! Don't forget to modify the "SendStatus" procedure for your !
'!                       comm package!                        !
'!    You also should modify PrintString for QB4.5 or PDS     !
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'I welcome any suggestions or ideas about this program... It _should_
'emulate DOS's ANSI.SYS device driver... This program is in the public
'domain; do what you want with it! Have a ball!! Just try and give
'me some credit. Thanks. I have tested this driver out with many BBS's
'and door programs and it works fine. Please test this driver out before
'you release it in a program!!!

'NOTE: This program assumes that the current segment is always
'pointing twards the video buffer!! If you change the current
'segment don't forget to change it back or sparks will fly when you
'write to the screen! (see GetVSeg)

'Info:
'ClearScreen- used internally by the PrintAnsi procedure- you may
'use it to clear the current window(the current background color
'is used in the clear). The cursor is set to the upper left hand corner
'of the window after the window is cleared.

'CursorControl A- if A is non-zero then the SetCursor routine(which
'is called by PrintAnsi) will update the cursor whenever it is moved.
'If it is zero then SetCursor won't touch the cursor's position.

'GetVSeg- Returns the current video segment.

'Init- Initializes the driver. This should be called before any other
'procedure. Completly resets the entire driver, sets the window to the
'current screen page & size and moves the cursor to the upper left hand
'corner of the screen.

'Music A- if A is not zero, then ANSI music is enabled.

'PrintAnsi Char- where Char is an ASCII code from 0-255. Recognizes
'ANSI escape sequences(of course!). Processes the character and
'updates the display, if needed

'PrintString A$- prints a string to the display. Calls PrintAnsi for
'each character. Don't forget to modify this for PDS/QuickBASIC.

'ScrollUpScreen- scrolls up the current window. Uses a BIOS call.
'Normally used internally by PrintAnsi.

'SendStatus- sends a CPR sequence to the receiver.
'In other words, SendStatus will output the current X and Y coordinates
'of the cursor to the remote terminal. Used by some BBS's and doors
'to see if the user's terminal has ANSI capibilities. You must modify
'this procedure to output the status string to your comm package!
'(this is used internally by PrintAnsi)

'SetCursor- moves the cursor to its correct position(it doesn't turn
'it on however- use the LOCATE , , 1 command to do that). This procedure
'should work on all adapters, but I haven't tested it out on many
'cards yet... Use this to restore the cursor to where it should be
'after you move it. If you want, change this procedure to use QB's
'LOCATE command instead of the OUT's.

'SetWindow WorkPage, Lx,Ly,Hx,Hy- defines a window where all text
'is printed. if WorkPage is -1, then the BIOS data area is examined for
'the current screen page, otherwise WorkPage must indicate which page to
'write to. If Lx is -1, the the window will take up the entire screen
'otherwise Lx and Ly are the upper-left lines of the window(where
'1,1 is the upper corner of the screen) and Hx and Hy are the lower-right
'coordinates of the window.
'   The current cursor position is moved to the upper left corner of the
'new window. If the coordinates passed are invalid, the window is not
'modified.

'   That's all! You can add more functions if you need them; I've
'documented the PrintAnsi procedure enough for you to get
'a good idea of how it works.

'   The assembly version of this driver very close to completion and I will
'be posting it very soon...

DEFINT A-Z

DECLARE SUB ClearScreen ()
DECLARE SUB CursorControl (A%)
DECLARE FUNCTION GetVSeg% ()
DECLARE SUB Init ()
DECLARE SUB Music (A%)
DECLARE SUB PrintANSI (Char%)
DECLARE SUB PrintString (B$)
DECLARE SUB ScrollUpScreen ()
DECLARE SUB SendStatus (X%, Y%)
DECLARE SUB SetCursor ()
DECLARE SUB SetWindow (WorkPage%, Lx%, Ly%, Hx%, Hy%)

DECLARE SUB playme (A$)

TYPE RegType
     Ax    AS INTEGER
     Bx    AS INTEGER
     Cx    AS INTEGER
     Dx    AS INTEGER
     bp    AS INTEGER
     si    AS INTEGER
     di    AS INTEGER
     flags AS INTEGER
END TYPE

DIM SHARED Xpos, Ypos               'cursor's position
DIM SHARED MinX, MinY, MaxX, MaxY   'current window
DIM SHARED SaveX, SaveY             'used by SCR and RCP
DIM SHARED Colors(7), Attribute
DIM SHARED CursorOn, VideoSegment, VideoOffset, CursorAddress, BytesPerLine
DIM SHARED Monochrome, CRT          'monochrome adapter flag
DIM SHARED ANSIMusic, MusicLevel
DIM SHARED Level

CONST True = -1, False = NOT True   'usefull stuff

'The color translation table is used to translate an ANSI color
'to a screen color.
ColorTable:
    DATA 0,4,2,6,1,5,3,7

'******START OF TEST PROGRAM
'The following code is not needed... It's only for testing!

SCREEN 0
WIDTH 80, 25
CLS
LOCATE , , 1            'turn cursor on

Init
ClearScreen             'clear the window
SetWindow -1, 1, 1, 80, 25 'set window at (1,2)-(80,25)

'DO
'    A$ = INKEY$: IF A$ <> "" THEN PrintString A$
'LOOP

'test ANSI music
PrintString CHR$(27) + "[MFO1CDEFGABC" + CHR$(14)

'A! = TIMER
'PrintString STRING$(5000, 65)
'B! = TIMER
'PRINT 5000 / (B! - A!)
'END

'a lame test
Esc$ = CHR$(27)
Up$ = CHR$(27) + "[A"
Down$ = CHR$(27) + "[B"
Lft$ = CHR$(27) + "[D"
Rgt$ = CHR$(27) + "[C"
Foreground = 31: Background = 40: Bold = 0
X = 1: Y = 1
DO
    A$ = CHR$(27) + "["
    IF NOT Bold THEN A$ = A$ + "0;" ELSE A$ = A$ + "1;"
    PrintString A$ + MID$(STR$(Foreground), 2) + ";" + MID$(STR$(Background), 2) + "m"

    Bold = NOT Bold
    Foreground = Foreground + 1
    IF Foreground > 37 THEN
        Foreground = 31
        Background = Background + 1
        IF Background > 47 THEN Background = 40
    END IF
    PrintString CHR$(27) + "[s" + CHR$(219) + CHR$(27) + "[u"
    IF Xdirect THEN
        X = X - 1
        PrintString Lft$
        IF X = 1 THEN Xdirect = 0
    ELSE
        X = X + 1
        PrintString Rgt$
        IF X = 80 THEN Xdirect = 1
    END IF
    IF Ydirect THEN
        Y = Y - 1
        PrintString Up$
        IF Y = 1 THEN Ydirect = 0
    ELSE
        Y = Y + 1
        PrintString Down$
        IF Y = 24 THEN Ydirect = 1
    END IF

LOOP UNTIL INKEY$ <> ""

END
'******END OF TEST PROGRAM

'Clears the current window. The cursor is also set to the upper-left hand
'corner of the window.
SUB ClearScreen
    DIM Regs AS RegType
    Regs.Ax = &H600
    A& = Attribute * 256&
    IF A& > 32767 THEN A = A& - 65536 ELSE A = A&
    Regs.Bx = A
    Regs.Cx = (MinY * 256&) + MinX - 257
    Regs.Dx = (MaxY * 256&) + MaxX - 257
    CALL interrupt(&H10, Regs, Regs)

    Xpos = MinX: Ypos = MinY
    SetCursor


END SUB

'Enables or disables cursor updating.
SUB CursorControl (A)
    IF A THEN
        CursorOn = True
    ELSE
        CursorOn = False
    END IF
END SUB

'Returns the current video segment.
FUNCTION GetVSeg
    GetVSeg = VideoSegment
END FUNCTION

'Initializes everything.
SUB Init
    DIM Regs AS RegType

    'default color, white on black (or black on white??)
    Attribute = 7

    Level = 0: MusicLevel = 0   'reset levels
    ANSIMusic = True            'ANSI music enabled
    CursorOn = True             'cursor movement enabled

    'read in color translation table
    RESTORE ColorTable
    FOR A = 0 TO 7: READ Colors(A): NEXT

    Regs.Ax = 15 * 256
    CALL interrupt(&H10, Regs, Regs)
    'if AL=7 then card is monochrome.
    IF (Regs.Ax AND 255) = 7 THEN
        VideoSegment = &HB000
        Monochrome = True
    ELSE
        VideoSegment = &HB800
        Monochrome = False
    END IF
    DEF SEG = &H40
    CRT = PEEK(&H63) + PEEK(&H64) * 256&

    'Set segment to the screen.
    DEF SEG = VideoSegment

    'window defaults to screen's page & size
    'Xpos, Ypos, SaveX, SaveY, MinX, MinY, MaxX, MaxY, VideoOffset and the
    'cursor are set up within this procedure
    SetWindow -1, -1, 0, 0, 0

END SUB

'Enables/Disables ANSI music...
SUB Music (A)
    ANSIMusic = A
END SUB

'Prints an ASCII character on the screen; filters out
'ANSI escape sequences and parses them.
'Fixups from last version(howcome nobody told me about these errors?!):
' A chr$(27) would not be processed correctly if received from within
'   another escape sequence. This has been fixed.
' SetCursor now uses a BIOS variable to get the correct OUT address... It
'   should now work on monochrome and color monitors.
' The cursor set, up & down commands are now not ignored if the cursor is
'  set to a position that is invalid.
' The entire parameter table is set to 1 so special case tests do not
'  have to be performed. Parameters will now be interpeted as 1 if they
'  are zero in the cursor set commands(these two aren't bugs, just
'  improvements!)
' ESC[m now resets the attribute to 7. The new page command, CHR$(12), now
'  resets the screen to attribute 7 before clearing(not really a bug, but...)
' OOPS!! The cursor position command, ESC[H, was processed as an absolute
'  coordinate relative to the upper-left hand of the screen... It should of
'  been processed relative to the upper-left hand corner of the window! DUMB!
'  So if the window was set to (1,2)-(80,25), and an ESC[H was received, the
'  cursor would not move anywhere.... This of course has been fixed.
'
' I discovered almost all of these little bugs while coding the assembly
' version of the driver...
SUB PrintANSI (Char) STATIC
    DIM Parameters(10)

    SELECT CASE Level
    CASE 0
        'normal mode
        GOSUB ProcessChar
    CASE 1
        'Level=1 after a chr$(27) is received.
        'valid escape sequence?

        IF Char <> 91 THEN
            Level = 0
            GOSUB ProcessChar
        ELSE
            'a valid escape sequence has been received
            Level = 2
            CurrentParameter = 0
            NumParameters = 0
            ValidParameter = False
            FOR A = 0 TO 10: Parameters(A) = 1: NEXT
        END IF
    CASE 2

        'inside an escape sequence
        GOSUB ProcessCode
    END SELECT
EXIT SUB

ProcessChar:
    'processes a non-ANSI code
    SELECT CASE Char
    'process new page code
    CASE 12
        Attribute = 7
        ClearScreen
    'process escape character
    CASE 27
        Level = 1
    'process enter
    CASE 13
        Xpos = MinX
        SetCursor
    'process line feed
    CASE 10
        Ypos = Ypos + 1
        IF Ypos > MaxY THEN Ypos = MaxY: ScrollUpScreen
        SetCursor
    'process backspace(non-destructive)
    CASE 8
        IF Xpos > MinX THEN
            Xpos = Xpos - 1
            SetCursor
        END IF
    'process tab key(tab stops=8)
    CASE 9
        Xpos = ((Xpos \ 8) + 1) * 8
        IF Xpos > MaxX THEN Xpos = MaxX
        SetCursor
    'process bell
    CASE 7
        'don't substitute a "BEEP" statement here!
        'BEEP resets the cursor to where QB thinks it is!
        SOUND 3140, 1.25
    'any other character is sent to the screen
    CASE ELSE

        'prints a character to the screen
        POKE CursorAddress, Char: POKE CursorAddress + 1, Attribute
        CursorAddress = CursorAddress + 2
        Xpos = Xpos + 1

        IF Xpos > MaxX THEN

            Xpos = MinX
            Ypos = Ypos + 1
            IF Ypos > MaxY THEN
                Ypos = MaxY
                ScrollUpScreen
            END IF
            SetCursor
        ELSE
            IF CursorOn THEN
                Address = CursorAddress \ 2
                OUT CRT, &HE
                OUT CRT + 1, Address \ 256
                OUT CRT, &HF
                OUT CRT + 1, Address AND 255
            END IF
        END IF
    END SELECT
RETURN
'processes a character within an ansi escape sequence
'non-valid characters are sent to the screen
ProcessCode:
'handles ANSI music...
IF MusicLevel > 0 THEN
    SELECT CASE MusicLevel
    'see if the "F" in "ESC[MF" is received...
    CASE 1
        IF Char <> 70 THEN          '"F"
            MusicLevel = 0
            Level = 0
            GOSUB ProcessChar
        ELSE
            MusicLevel = 2
            MusicString$ = ""
        END IF
        'Either add a char to the music string or play it...
    CASE 2
        IF Char <> 14 THEN
            'fall out if an escape character is received...
            IF Char = 27 THEN
                MusicString$ = ""
                MusicLevel = 0
                Level = 0
                GOSUB ProcessChar
            'assume the character received to be part of the
            'PLAY string
            ELSE
                MusicString$ = MusicString$ + CHR$(Char)
            END IF
        ELSE
            IF ANSIMusic THEN
                'play the string- the PLAY command is in a seperate
                'module to keep error checking out of this module
                playme MusicString$
            END IF
            MusicString$ = ""
            MusicLevel = 0
            Level = 0
        END IF
    END SELECT
ELSE
    SELECT CASE Char
    CASE 77                             '"M"
        MusicLevel = 1
    CASE 48 TO 57                       '0-9
        'all parameters should be lower than 199...
        IF CurrentParameter < 199 THEN
            CurrentParameter = CurrentParameter * 10 + (Char - 48)
            ValidParameter = True
        ELSE
            Level = 0
            GOSUB ProcessChar
        END IF
    CASE 59
        GOSUB MakeParameter             '";"
    'CUP-set cursor's position
    CASE 72, 102                        'H or f
        GOSUB MakeParameter
        Ypos = MinY + A - 1
        A = Parameters(1): IF A = 0 THEN A = 1
        Xpos = MinX + A - 1
        IF Xpos > MaxX THEN Xpos = MaxX
        IF Ypos > MaxY THEN Ypos = MaxY
        SetCursor
        Level = 0
    'CUU- cursor up
    CASE 65                             'A
        GOSUB MakeParameter
        Ypos = Ypos - A
        IF Ypos < MinY THEN Ypos = MinY
        SetCursor
        Level = 0
    'CUD-cursor down
    CASE 66                             'B
        GOSUB MakeParameter
        Ypos = Ypos + A
        IF Ypos > MaxY THEN Ypos = MaxY
        SetCursor
        Level = 0
    'CUF-cursor forward
    CASE 67                             'C
        GOSUB MakeParameter
        Xpos = Xpos + A
        IF Xpos > MaxX THEN Xpos = MaxX
        SetCursor
        Level = 0
    'CUB-cursor backward
    CASE 68                              'D
        GOSUB MakeParameter
        Xpos = Xpos - A

        IF Xpos < MinX THEN Xpos = MinX
        SetCursor
        Level = 0
    'SCR-save cursor position
    CASE 115                            's
        SaveX = Xpos: SaveY = Ypos
        Level = 0
    'RCP-restore cursor position
    CASE 117                            'u
        Xpos = SaveX: Ypos = SaveY
        Level = 0
        SetCursor
    'ED-erase display(ESC[2J and ESC[J work
    'both work)
    CASE 74                             'J
        ClearScreen
        Level = 0
    'EL-erase in line
    CASE 75                             'K
        A = CursorAddress
        FOR X = Xpos TO MaxX
            POKE A, 32: POKE A + 1, Attribute: A = A + 2
        NEXT
        Level = 0
    'SGR-sets new color
    CASE 109                            'm
        GOSUB MakeParameter
        'if no color codes then stuff 0 into the table
        IF NumParameters = 0 THEN Parameters(0) = 0: NumParameters = 1
        FOR A = 0 TO NumParameters - 1
            P = Parameters(A)
            SELECT CASE P
            CASE IS <= 8
                SELECT CASE P
                'all attributes off
                CASE 0
                    Attribute = 7
                'high-intensity
                CASE 1
                    Attribute = Attribute OR 8
                'blinking
                CASE 5
                    Attribute = Attribute OR 128
                'inverse
                CASE 7
                    Attribute = (Attribute AND 136) OR (Attribute AND 7) * 16 OR (Attribute AND 112) \ 16
                END SELECT
                'set foreground
            CASE 30 TO 37
                IF NOT Monochrome THEN
                    Attribute = (Attribute AND 248) OR Colors(P - 30)
                END IF
                'set background
            CASE 40 TO 47
                IF NOT Monochrome THEN
                    Attribute = (Attribute AND 143)
                    Attribute = Attribute OR Colors(P - 40) * 16
                END IF
            END SELECT
        NEXT
        Level = 0
    'DSR-outputs a CPR sequence
    'This function outputs the string "ESC[#;#R" where
    '#;# is the current Y and current X coordinate
    'to the receiver.
    'Calls SendStatus to do its dirty work...
    CASE 110
        SendStatus Xpos, Ypos
        Level = 0
    'any other code is assumed to be invalid;it's just sent to the
    'screen
    CASE ELSE
        Level = 0
        GOSUB ProcessChar
    END SELECT
END IF
RETURN
'stores a numeric parameter into the parameter table
MakeParameter:
    'check to see if a least one digit has been received
    'for this parameter and there's room left in the table
    IF ValidParameter AND NumParameters < 10 THEN
        'add parameter to table
        Parameters(NumParameters) = CurrentParameter
        NumParameters = NumParameters + 1
        CurrentParameter = 0
        ValidParameter = False
    END IF

    'Set A equal to the first parameter and make it 1 if it's 0
    A = Parameters(0)
    IF A = 0 THEN A = 1

RETURN
END SUB

'Prints a string to the display.
SUB PrintString (B$)
    A& = SADD(B$)
    IF A& < 0 THEN A& = A& + 65536

    STOP' You must change the next line if you're using QB4.5!
    'It is currently coded for PDS.

    'Segment = VARSEG(B$) + A& \ 16

    Segment = SSEG(B$) + A& \ 16    'change to VARSEG(B$) for QB4.5 & QBASIC

    Address = A& MOD 16
    FOR B = Address TO Address + LEN(B$) - 1
        DEF SEG = Segment
        A1 = PEEK(B)
        DEF SEG = VideoSegment
        PrintANSI A1
    NEXT
END SUB

SUB ScrollUpScreen
    DIM Regs AS RegType
    Regs.Ax = &H601

    A& = Attribute * 256&
    IF A& > 32767 THEN A = A& - 65536 ELSE A = A&
    Regs.Bx = A

    Regs.Cx = (MinY * 256&) + MinX - 257
    Regs.Dx = (MaxY * 256&) + MaxX - 257
    CALL interrupt(&H10, Regs, Regs)
END SUB

'Sends the screen's status to the receiver. You must modify the
'"PRINT #1, A$;" command to print to your comm package.
'Sends "ESC[##;##R" where ##;## is Y;X.
SUB SendStatus (X, Y)
    A$ = CHR$(27) + "[" + RIGHT$("0" + MID$(STR$(Y), 2), 2)
    A$ = A$ + ";" + RIGHT$("0" + MID$(STR$(X), 2), 2) + "R"

'*****Change the next line to print this string out to your comm package!!****
    PRINT A$;           'DON'T insert a line feed!!

END SUB

'Sets the cursor- uses OUT's for speed
SUB SetCursor
    'Must do this...

    CursorAddress = (Xpos - 1) * 2 + (Ypos - 1) * BytesPerLine + VideoOffset
    IF CursorOn THEN
        Address = CursorAddress \ 2
        OUT CRT, &HE
        OUT CRT + 1, Address \ 256
        OUT CRT, &HF
        OUT CRT + 1, Address AND 255
    END IF
END SUB

'Sets a new printing window.
SUB SetWindow (WorkPage, Lx, Ly, Hx, Hy)
    DEF SEG = &H40
    IF WorkPage = -1 THEN
        VideoOffset = PEEK(&H4E) + PEEK(&H4F) * 256&
    ELSE
        VideoOffset = (PEEK(&H4C) + PEEK(&H4D) * 256&) * WorkPage
    END IF

    ScreenX = PEEK(&H4A)
    ScreenY = PEEK(&H84) + 1

    IF Lx = -1 THEN
        MinX = 1: MinY = 1
        MaxX = ScreenX: MaxY = ScreenY
        BytesPerLine = MaxX * 2
    ELSE
        'change window size if coordinates are valid
        IF Lx <= Hx AND Ly <= Hy AND Hx <= ScreenX AND Hy <= ScreenY THEN
            MinX = Lx: MaxX = Hx: MinY = Ly: MaxY = Hy
        END IF
    END IF
    DEF SEG = VideoSegment
    Xpos = MinX: Ypos = MinY
    SaveX = MinX: SaveY = MinY
    SetCursor
END SUB