FastConsole.bas

#include once "CRT.bi"
#include once "Windows.bi"

#define ConColor(_Back,_Fore) ((_Fore) OR ((_Back) shl 4))
#define ConBlock(_Char, _Color) ((_Char) OR ((_Color) SHR 8)

#define BlockPtr(X, Y) ((X) + ((Y) * pCon.iWidth))
#define CharPtr(X, Y) (((X) + ((Y) * pCon.iWidth)) SHL 1)
#define AttrPtr(X, Y) (((X) + ((Y) * pCon.iWidth)) SHL 1) + 1

Type TxtGFX
    ImgWidth as uShort
    ImgHeight as uShort
    Image as uByte Ptr
End Type

namespace pCon
    Dim as Integer iWidth, iHeight

    Dim Shared as HANDLE hOldScreen
    Dim Shared as uShort Ptr pNewScreen

    Function Create(iWid as Integer = 80, iHei as Integer = 25) as uShort Ptr
        If iWid <= 8 or iHei <= 4 Then
            MessageBox(0, "ConsoleCreate: Bad console size selected", null, MB_ICONERROR)
            return 0
        End If

        iWidth = iWid: iHeight = iHei
        width iWidth, iHeight

        hOldScreen = GetStdHandle(STD_OUTPUT_HANDLE)
        pNewScreen = malloc(iWidth*iHeight*2)

        ' Hide the cursor in the console
        Dim as CONSOLE_CURSOR_INFO BlankCursor
        BlankCursor.dwSize = 100
        BlankCursor.bVisible = FALSE
        SetConsoleCursorInfo(hOldScreen, @BlankCursor)

        return pNewScreen
    End Function

    Sub Update
        Dim as COORD ConSize, BuffStart
        BuffStart.X = 0: BuffStart.Y = 0
        ConSize.X = iWidth: ConSize.Y = iHeight

        Dim as SMALL_RECT WriteRegion
        WriteRegion.Left = 0: WriteRegion.Top = 0
        WriteRegion.Right = iWidth-1: WriteRegion.Bottom = iHeight-1

        ' Convert from DOS format to Windows console format
        Dim as CHAR_INFO tNative(iWidth * iHeight)
        For X as Integer = 0 to (iWidth * iHeight)
            tNative(X).Char.AsciiChar = pNewScreen[X] AND &HFF
            tNative(X).Attributes = pNewScreen[X] SHR 8
        Next X

        WriteConsoleOutput(hOldScreen, @tNative(0), ConSize, BuffStart, @WriteRegion)
    End Sub

    Sub ClearCon(ConColor as uByte = &H0F, ConChar as uByte = 32)
        Dim as uShort CharBlock = (ConColor SHL 8) OR ConChar
        For x as Integer = 0 To (iHeight * iWidth)-1
            pNewScreen[X] = CharBlock
        Next X
    End Sub

    Sub DrawRect(X as Short, Y as Short, iWid as Short, iHei as Short, ConColor as uByte, ConChar as uByte)
        Dim as uShort CharBlock = (ConColor SHL 8) OR ConChar

        var RectPart = (X + (Y * iWidth))
        var RectY = 0
        Do
            For RectX as Integer = 0 to iWid-1
                pNewScreen[RectPart+RectX] = CharBlock
            Next RectX
            RectPart += iWidth: RectY += 1
        Loop until (RectY = iHei)
    End Sub

    Sub PrintCon(X as short, Y as short, TextInput as String)
        var ScreenPos = ((X + (Y * iWidth)) SHR 1)
        Dim as uByte Ptr pScreenPtr = Cast(uByte Ptr, pNewScreen)

        For TextPos as Integer = 0 to Len(TextInput)-1
            If TextInput[TextPos] = 10 Then
                ScreenPos += iWidth SHL 1
            ElseIf TextInput[TextPos] <> 13 Then
                pScreenPtr[ScreenPos] = TextInput[TextPos]
                ScreenPos += 2
            End If
        Next TextPos
    End Sub

    Sub Destroy()
        Free(pNewScreen)
        iWidth = 0: iHeight = 0
    End Sub

    ' Graphics routines
    Function CreateImage(ImgWidth as Short, ImgHeight as Short) as TxtGFX
        Dim as TxtGFX NewImg
        With NewImg
            .ImgWidth = ImgWidth
            .ImgHeight = ImgHeight
            .Image = malloc(ImgWidth*ImgHeight)
        End With
        Return NewImg
    End Function

    Sub DestroyImage(OldImage as TxtGFX)
        With OldImage
            .ImgWidth = 0
            .ImgHeight = 0
            .Image = 0
        End With
    End Sub

    Sub GetGfx(X as Short, Y as Short, Byref ImageBuff as TxtGFX)
        Dim as Short ImagePos = 0
        var ScreenStart = BlockPtr(X, Y)
        With ImageBuff
            For OffSetY as Integer = X to X+.ImgWidth-1
                For OffSetX as Integer = Y to Y+.ImgHeight-1
                    .Image[ImagePos] = pNewScreen[BlockPtr(OffSetX, OffSetY)]
                    ImagePos += 1
                Next OffSetX
            Next OffsetY
        End With
    End Sub

    Sub PutGfx(X as Short, Y as Short, Byref ImageBuff as TxtGFX)
        Dim as Short ImagePos = 0
        var ScreenStart = BlockPtr(X, Y)
        With ImageBuff
            For OffSetY as Integer = X to X+.ImgWidth-1
                For OffSetX as Integer = Y to Y+.ImgHeight-1
                    pNewScreen[BlockPtr(OffSetX, OffSetY)] = .Image[ImagePos]
                    ImagePos += 1
                Next OffsetX
            Next OffSetY
        End With
    End Sub
end namespace