Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/ARQS_ZIP/VBTERM.ZIP/VT100.BAS

BASIC Source File | 1991-10-04 | 17.6 KB | 660 lines

Declare Sub ScrollWindow Lib "USER" (ByVal hWnd As Integer, ByVal XAmount As Integer, ByVal YAmount As Integer, ByVal lpRect As Long, ByVal lpClipRect As Long)
Declare Function GetMapMode Lib "GDI" (ByVal hDC As Integer) As Integer
Declare Function SetMapMode Lib "GDI" (ByVal hDC As Integer, ByVal nMapMode As Integer) As Integer
Declare Function SetWindowExt Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Long
Declare Function SetViewportExt Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Long

'======================= Mapping Modes ====================
Const MM_TEXT = 1
Const MM_LOMETRIC = 2
Const MM_HIMETRIC = 3
Const MM_LOENGLISH = 4
Const MM_HIENGLISH = 5
Const MM_TWIPS = 6
Const MM_ISOTROPIC = 7
Const MM_ANISOTROPIC = 8


Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nwidth As Integer, ByVal nheight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
Declare Function PatBlt Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nwidth As Integer, ByVal nheight As Integer, ByVal dwRop As Long) As Integer

'=================== Ternary raster operations ============
Const SRCCOPY = &HCC0020         ' (DWORD) dest = source
Const SRCPAINT = &HEE0086        ' (DWORD) dest = source OR dest
Const SRCAND = &H8800C6          ' (DWORD) dest = source AND dest
Const SRCINVERT = &H660046       ' (DWORD) dest = source XOR dest
Const SRCERASE = &H440328        ' (DWORD) dest = source AND (NOT dest )
Const NOTSRCCOPY = &H330008      ' (DWORD) dest = (NOT source)
Const NOTSRCERASE = &H1100A6     ' (DWORD) dest = (NOT src) AND (NOT dest)
Const MERGECOPY = &HC000CA       ' (DWORD) dest = (source AND pattern)
Const MERGEPAINT = &HBB0226      ' (DWORD) dest = (NOT source) OR dest
Const PATCOPY = &HF00021         ' (DWORD) dest = pattern
Const PATPAINT = &HFB0A09        ' (DWORD) dest = DPSnoo
Const PATINVERT = &H5A0049       ' (DWORD) dest = pattern XOR dest
Const DSTINVERT = &H550009       ' (DWORD) dest = (NOT dest)
Const BLACKNESS = &H42&          ' (DWORD) dest = BLACK
Const WHITENESS = &HFF0062       ' (DWORD) dest = WHITE

'
'   Calls to output text
'
Declare Function TextOut Lib "GDI" (ByVal hDC%, ByVal X%, ByVal Y%, ByVal lpString$, ByVal nCount%) As Integer

'
'   Set text to transparent or opaque
'
Declare Function SetBkMode Lib "GDI" (ByVal hDC%, ByVal nmode%) As Integer

Const TRANSPARENT = 1
Const OPAQUE = 2

'
'   Color management
'
Declare Function GetTextColor Lib "GDI" (ByVal hDC%) As Long
Declare Function SetTextColor Lib "GDI" (ByVal hDC%, ByVal newcolor As Long) As Long

Declare Function GetBkColor Lib "GDI" (ByVal hDC%) As Long
Declare Function SetBkColor Lib "GDI" (ByVal hDC%, ByVal newcolor As Long) As Long

Dim TermTextColor As Long
Dim TermBkColor As Long

Dim ScrImage(24) As String
Dim ScrAttr(24) As String
Dim Normal80 As String
Dim curAttr As String


'
'   Current Buffered Text
'

Dim outstr As String
Dim outx As Integer
Dim outlen As Integer

'
'   Flag to indicate that we're ready to run
'
Dim FlagInit As Integer

Dim curx As Integer
Dim cury As Integer

Dim InEscape As Integer     ' Processing an escape seq?
Dim EscString As String     ' String so far

Dim charHeight As Integer
Dim charWidth As Integer

Dim CurState As Integer

Sub term_init ()

    curx = 0
    cury = 0

    TTY.ScaleMode = 3
    charHeight = TTY.TextHeight("M")
    charWidth = TTY.TextWidth("M")

    TTY.ScaleMode = 0
    TTY.Scale (0, 0)-(79, 24)
    'nMapMode% = SetMapMode(TTY.hDC, MM_ANISOTROPIC)
    'lExt& = SetWindowExt(TTY.hDC, 1, 1)
    'lExt& = SetViewportExt(TTY.hDC, charWidth, charHeight)

    InEscape = 0
    CurState = 0


    r% = SetBkMode(TTY.hDC, OPAQUE)
    TTY.forecolor = QBColor(0)
    TTY.backcolor = QBColor(15)
    TermTextColor = GetTextColor(TTY.hDC)
    TermBkColor = GetBkColor(TTY.hDC)
    disp_cursor

    Normal80 = String$(80, "0")

    For i% = 1 To 24
        ScrImage(i%) = Space$(80)
        ScrAttr(i%) = Normal80
    Next i%

    curAttr = "0"

    FlagInit = -1
End Sub

Sub disp_cursor ()

    '------------------------------------------------------------------------
    '   disp_cursor
    '
    '   display the inverted block cursor on the screen.  currently uses
    '   BitBlt, but seems like it could use PatBlt instead.
    '------------------------------------------------------------------------

    If CurState Then
        Exit Sub
    End If

    sx% = curx * charWidth
    sy% = cury * charHeight
    If TTY.WindowState <> MINIMIZED Then
       r% = PatBlt(TTY.hDC, sx%, sy%, charWidth, charHeight, DSTINVERT)
    End If

    CurState = TRUE

End Sub

Sub hide_cursor ()

    If CurState = 0 Then Exit Sub

    sx% = curx * charWidth
    sy% = cury * charHeight
    If TTY.WindowState <> 1 Then
        r% = PatBlt(TTY.hDC, sx%, sy%, charWidth, charHeight, DSTINVERT)
    End If

    CurState = FALSE

End Sub

Sub scroll_up ()
    Dim wid As Integer
    Dim High As Integer
    Dim cHigh As Integer

'    wid = TTY.ScaleWidth
'    cHigh = 1
'    High = 23 * cHigh

'    If (High > TTY.ScaleHeight) Then
'        High = TTY.ScaleHeight
'    End If

'    If TTY.WindowState <> 1 Then
'        ScrollWindow TTY.hWnd, 0, -cHigh, 0, 0
'        ' r% = BitBlt(TTY.hDC, 0, 0, wid, High, TTY.hDC, 0, cHigh, SRCCOPY)
'        r% = PatBlt(TTY.hDC, 0, High, wid, cHigh, WHITENESS)
'    End If

    For i% = 1 To 23
        ScrImage(i%) = ScrImage(i% + 1)
        ScrAttr(i%) = ScrAttr(i% + 1)
    Next i%

    ScrImage(24) = Space$(80)
    ScrAttr(24) = Normal80

    RedrawScreen

End Sub

Sub term_put (buf As String, cnt As Integer)

    Dim i As Integer
    Dim ch As Integer

    hide_cursor

    outstr = ""
    outlen = 0
    outx = curx

    For i = 1 To cnt

        ch = &H7F And Asc(Mid$(buf, i, 1))

        If (InEscape) Then
            Call AddEscape(ch)
            outx = curx
        Else
            Select Case ch

            Case 13
                curx = 0
                If (outlen <> 0) Then WriteText
                outx = 0

            Case 10
                If (outlen <> 0) Then WriteText     '   flush output buffer

                cury = cury + 1                     '   goto next line
                If (cury > 23) Then                 '   if line left on scrn
                    Call scroll_up                  '   ..  scroll upwards
                    cury = 23                       '   ..  use blank line
                End If

            Case 8
                If (outlen <> 0) Then WriteText     '   flush output buffer

                If curx > 0 Then                    '   if not at line begin
                    curx = curx - 1                 '   ..  adjust back 1 spc
                    outx = curx
                End If

            Case 7
                Beep

            Case 27
                If (outlen <> 0) Then WriteText
                Call StartEscape

            Case Else
                If (ch > 31) Then
                    outstr = outstr + Chr$(ch)
                    outlen = outlen + 1
                    Mid$(ScrImage(cury + 1), curx + 1, 1) = Chr$(ch)
                    Mid$(ScrAttr(cury + 1), curx + 1, 1) = curAttr
                    curx = curx + 1
                    If (curx >= 80) Then
                        Call WriteText
                        curx = 79
                    End If
                End If
            End Select
        End If
    Next i

    If (outlen <> 0) Then WriteText

End Sub

Sub StartEscape ()
    InEscape = -1
    EscString = ""
End Sub

Sub AddEscape (ch As Integer)

    Dim c As String
    Dim l As Long

    c = Chr$(ch)
    If EscString = "" And c <> "[" Then
        InEscape = 0
        Exit Sub
    End If

    EscString = EscString + c
    If (LCase$(c) = UCase$(c)) Then
        ' Not a letter ...
        If Len(EscString) > 16 Then InEscape = 0
        Exit Sub
    End If

    Select Case c
    Case "H", "f"
        EscString = Mid$(EscString, 2)
        cury = Val(PopArg(EscString)) - 1
        If (cury < 0) Then cury = 0
        curx = Val(EscString) - 1
        If (curx < 0) Then curx = 0

    Case "K"
        Select Case Val(Mid$(EscString, 2))
        Case 0
            Call erase_eol
        Case 1
            Call erase_bol
        Case 2
            Call erase_line
        End Select

    Case "J"
        Select Case Val(Mid$(EscString, 2))
        Case 0
            Call erase_eos
        Case 1
            Call erase_bos
        Case 2
            Call erase_screen
        End Select

    Case "m"
        EscString = Mid$(EscString, 2)
        Do
            Call SetAttr(PopArg(EscString))
        Loop While EscString <> ""

    Case "A", "B"
        EscString = Mid$(EscString, 2)
        yDiff% = Val(PopArg(EscString))
        If yDiff% = 0 Then yDiff% = 1
        If c = "A" Then yDiff% = 0 - yDiff%
        cury = cury + yDiff%
        If (cury < 0) Then cury = 0

    Case "C", "D"
        EscString = Mid$(EscString, 2)
        xDiff% = Val(PopArg(EscString))
        If xDiff% = 0 Then xDiff% = 1
        If c = "D" Then xDiff% = 0 - xDiff%
        curx = curx + xDiff%
        If (curx < 0) Then curx = 0
        If (curx > 79) Then curx = 79

    End Select

    InEscape = 0
    EscString = ""

End Sub

Function PopArg (s As String) As String
'
'   PopArg takes the next argument (digits up to a ;) and
'   returns it.  It also removes the arg and the ; from
'   the "s"

    i% = InStr(s, ";")
    If i% = 0 Then
        PopArg = s
        s = ""
        Exit Function
    End If

    PopArg = Left$(s, i% - 1)
    s = Mid$(s$, i% + 1)

End Function

Sub erase_bos ()

    '------------------------------------------------------------------------
    '   erase_bos
    '
    '   erase all lines from beginning of screen to and including current
    '------------------------------------------------------------------------
    Dim wid As Integer
    Dim High As Integer
    Dim cHigh As Integer

    '------------------------------------------------------------------------
    '   erase from the beginning of the line. if current line is 0, then exit
    '------------------------------------------------------------------------
    Call erase_bol
    If (cury = 0) Then
        Exit Sub
    End If

    '------------------------------------------------------------------------
    '   calculate height of block to erase
    '------------------------------------------------------------------------
    wid = TTY.Width
    cHigh = TTY.TextHeight("M")
    High = (cury - 1) * cHigh

    If TTY.WindowState <> 1 Then
        r% = PatBlt(TTY.hDC, 0, 0, wid, High, WHITENESS)
    End If

    '------------------------------------------------------------------------
    '   reset screen buffer contents
    '------------------------------------------------------------------------
    For Y% = 1 To cury
        ScrImage(Y%) = Space$(80)
        ScrAttr(Y%) = Normal80
    Next Y%

End Sub

Sub erase_line ()

'   Erase Line

    Dim wid As Integer
    Dim High As Integer
    Dim cHigh As Integer
    Dim StartX As Integer

    wid = TTY.Width
    cHigh = TTY.TextHeight("M")
    High = cury * cHigh

    If TTY.WindowState <> 1 Then
        r% = PatBlt(TTY.hDC, 0, High, wid, cHigh, WHITENESS)
    End If

    ScrImage(cury + 1) = Space$(80)
    ScrAttr(cury + 1) = Normal80

End Sub

Sub erase_eos ()
'
'   Erase to end of screen
'
    Dim wid As Integer
    Dim High As Integer
    Dim cHigh As Integer
    Dim StartY As Integer

    Call erase_eol

    If (cury = 23) Then Exit Sub

    wid = TTY.ScaleWidth
    cHigh = TTY.TextHeight("M")
    StartY = (cury + 1) * cHigh
    High = 24 * cHigh - StartY


    If TTY.WindowState <> 1 Then
        r% = PatBlt(TTY.hDC, 0, StartY, wid, High, WHITENESS)
    End If

    For Y% = cury + 2 To 24
        ScrImage(Y%) = Space$(80)
        ScrAttr(Y%) = Normal80
    Next Y%

End Sub

Sub erase_eol ()
'
'   Erase to End of Line
'
    Dim wid As Integer
    Dim High As Integer
    Dim cHigh As Integer
    Dim StartX As Integer

    wid = TTY.ScaleWidth
    cHigh = charHeight
    High = cury * charHeight
    StartX = curx * charWidth

    If TTY.WindowState <> 1 Then
        r% = PatBlt(TTY.hDC, StartX, High, wid - StartX, cHigh, WHITENESS)
    End If

    Mid$(ScrImage(cury + 1), curx + 1, 80 - curx) = Space$(80 - curx)
    Mid$(ScrAttr(cury + 1), curx + 1, 80 - curx) = String$(80 - curx, "0")

End Sub

Sub erase_bol ()

    '------------------------------------------------------------------------
    '   erase_bol
    '
    '   erase from beginning of current line
    '------------------------------------------------------------------------
    Dim wid As Integer
    Dim High As Integer
    Dim cHigh As Integer


    cHigh = charHeight
    High = cury * charHeight
    wid = curx * charWidth

    If TTY.WindowState <> 1 Then
        r% = PatBlt(TTY.hDC, 0, High, wid, cHigh, WHITENESS)
    End If

    Mid$(ScrImage(cury + 1), 1, curx + 1) = Space$(curx + 1)
    Mid$(ScrAttr(cury + 1), 1, curx + 1) = String$(curx + 1, "0")

End Sub

Sub erase_screen ()

    TTY.Cls
    For Y% = 1 To 24
        ScrImage(Y%) = Space$(80)
        ScrAttr(Y%) = Normal80
    Next Y%

End Sub

Sub WriteText ()

    If TTY.WindowState <> MINIMIZED Then
        r% = TextOut(TTY.hDC, outx * charWidth, cury * charHeight, outstr, outlen)
    End If

    outstr = ""
    outlen = 0
    outx = outx + outlen

End Sub

Sub RedrawScreen ()

    Dim oldcur As Integer
    Dim oldattr As String

    If FlagInit <> -1 Then Exit Sub
    If TTY.WindowState = 1 Then Exit Sub

    oldcur = CurState
    oldattr = curAttr

    Call hide_cursor
    Call SetAttr("0")

    For Y% = 1 To 24

        If (ScrAttr(Y%) = Normal80) Then
            r% = TextOut(TTY.hDC, 0, (Y% - 1) * charHeight, ScrImage(Y%), 80)
        Else

            For X% = 1 To 80
                If (Mid$(ScrAttr(Y%), X%, 1) <> curAttr) Then
                    Call SetAttr(Mid$(ScrAttr(Y%), X%, 1))
                End If
                r% = TextOut(TTY.hDC, (X% - 1) * charWidth, (Y% - 1) * charHeight, Mid$(ScrImage(Y%), X%, 1), 1)

            Next X%
        End If

        r% = DoEvents()

    Next Y%

    Call SetAttr(oldattr)
    If oldcur <> 0 Then Call disp_cursor

End Sub

Sub SetAttr (ch As String)

    Select Case Val(ch)

            '===============================================================

            Case 0  '   Normal
                'TTY.fontbold = FALSE
                TTY.fontunderline = FALSE
                'TTY.fontitalic = FALSE
                oldColor = SetTextColor(TTY.hDC, TermTextColor)
                oldColor = SetBkColor(TTY.hDC, TermBkColor)

            Case 1  '   Bold
                'TTY.fontbold = TRUE
                oldColor = SetTextColor(TTY.hDC, QBColor(9))

            Case 5  '   Blinking
                'TTY.fontitalic = TRUE
                oldColor = SetTextColor(TTY.hDC, QBColor(3))

            Case 4  '   Underscore
                TTY.fontunderline = TRUE

            Case 7  '   Reverse Video
                oldColor = SetTextColor(TTY.hDC, TermBkColor)
                oldColor = SetBkColor(TTY.hDC, TermTextColor)

            Case 8  '   Cancel (Invisible)
                oldColor = SetTextColor(TTY.hDC, TermBkColor)
                oldColor = SetBkColor(TTY.hDC, TermBkColor)

            '===============================================================

            Case 30 '   Black Foreground
                oldColor = SetTextColor(TTY.hDC, QBColor(0))

            Case 31 '   Red Foreground
                oldColor = SetTextColor(TTY.hDC, QBColor(4))

            Case 32 '   Green Foreground
                oldColor = SetTextColor(TTY.hDC, QBColor(2))

            Case 33 '   Yellow Foreground
                oldColor = SetTextColor(TTY.hDC, QBColor(14))

            Case 34 '   Blue Foreground
                oldColor = SetTextColor(TTY.hDC, QBColor(1))

            Case 35 '   Magenta Foreground
                oldColor = SetTextColor(TTY.hDC, QBColor(5))

            Case 36 '   Cyan Foreground
                oldColor = SetTextColor(TTY.hDC, QBColor(3))

            Case 37 '   White Foreground
                oldColor = SetTextColor(TTY.hDC, QBColor(15))

            '===============================================================

            Case 40 '   Black Background
                oldColor = SetBkColor(TTY.hDC, QBColor(0))

            Case 41 '   Red Background
                oldColor = SetBkColor(TTY.hDC, QBColor(4))

            Case 42 '   Green Background
                oldColor = SetBkColor(TTY.hDC, QBColor(2))

            Case 43 '   Yellow Background
                oldColor = SetBkColor(TTY.hDC, QBColor(14))

            Case 44 '   Blue Background
                oldColor = SetBkColor(TTY.hDC, QBColor(1))

            Case 45 '   Magenta Background
                oldColor = SetBkColor(TTY.hDC, QBColor(5))

            Case 46 '   Cyan Background
                oldColor = SetBkColor(TTY.hDC, QBColor(3))

            Case 47 '   White Background
                oldColor = SetBkColor(TTY.hDC, QBColor(15))

            Case Else
                Exit Sub
    End Select

    curAttr = ch

End Sub