Author Topic: Isometric Mapping Demo re-visited (Read 778 times)

madscijr · « **on:** November 29, 2021, 06:38:21 pm »

I was playing with the code for the Isometric Mapping Demo
by SMcNeill, bplus, and others, at
https://www.qb64.org/forum/index.php?topic=1903.30
and got it to draw and render some objects in different colors.
I modified the rendering routine to draw a single block at the Z coordinate, instead of drawing UP TO the Z coordinate.
The code is crude but it works - enjoy.

Code: QB64: [Select]

' Isomatric mapping demo re-revisited
' Version 2.18 by madscijr
 
' Based on Isometric Mapping Demo
' by SMcNeill, bplus, and others at
' https://www.qb64.org/forum/index.php?topic=1903.30
 
' This crude version uses a 3-dimensional array (32x32x32)
' to store blocks of different colors,
' and draws them to the screen in 2.5D "isometric".
 
Screen _NewImage(1024, 720, 32)
'_ScreenMove _Middle
 
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
'$CONSOLE
'_DELAY 4
'_CONSOLE ON
'_ECHO "Debugging on..."
' ****************************************************************************************************************************************************************
 
' =============================================================================
' GLOBAL DECLARATIONS a$=string, i%=integer, L&=long, s!=single, d#=double
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
 
' boolean constants
Const FALSE = 0
Const TRUE = Not FALSE
 
' constants for map
Const cMapEmpty = 0
Const cMapTileFloor = 32
Const cMapRedWall = 1
Const cMapPurpleWall = 2
Const cMapBlueWall = 3
Const cMapGreenWall = 4
Const cMapYellowWall = 5
Const cMapOrangeWall = 6
Const cMapWater = 48
 
' constants for drawing on the screen
Const cGridOffsetX = 50
Const cGridOffsetY = 50
Const cGridOffsetZ = 0
Const cScreenOffsetX = 450 ' 500
Const cScreenOffsetY = 50 ' 300
Const cScreenOffsetZ = 0
 
' =============================================================================
' GLOBAL VARIABLES
Dim ProgramPath$
Dim ProgramName$
 
Dim Shared iGridSize As Integer
Dim iColor As _Unsigned Long
Dim arrGrid(32, 32, 32) As _Byte ' x,y,z
Dim iX%
Dim iY%
Dim iZ%
Dim iNextX%
Dim iNextY%
Dim iNextZ%
Dim iMaxSize%
Dim iSize%
Dim iLoopX%
Dim iLoopY%
Dim iPosX1%
Dim iPosX2%
Dim iPosY1%
Dim iPosY2%
Dim iPosZ1%
Dim iPosZ2%
Dim bTile As Integer
Dim iNextWall%
Dim bContinue As Integer
Dim i2$
Dim iMinX%
Dim iMaxX%
Dim iMinY%
Dim iMaxY%
Dim iMinZ%
Dim iMaxZ%
Dim sLine As String
Dim iNext%
Dim iLoop%
Dim iNum%
Dim bFinished As Integer
Dim iCount%
Dim iOpen%
Dim iMove%
Dim bFirst As Integer
 
' =============================================================================
' INITIALIZE
ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
iGridSize = 10 ' < 10 is causing problems with PAINT
 
' -----------------------------------------------------------------------------
' INITIALIZE MAP TO EMPTY
For iLoopZ% = 0 To 32
    For iLoopX% = 0 To 32
        For iLoopY% = 0 To 32
            arrGrid(iLoopX%, iLoopY%, iLoopZ%) = cMapEmpty
        Next iLoopY%
    Next iLoopX%
Next iLoopZ%
 
' -----------------------------------------------------------------------------
' DRAW FLOOR
iZ% = 0
For iLoopX% = 0 To 32
    For iLoopY% = 0 To 32
        arrGrid(iLoopX%, iLoopY%, iZ%) = cMapTileFloor
    Next iLoopY%
Next iLoopX%
 
' -----------------------------------------------------------------------------
' DRAW BLOCKS TO CHECK ORIENTATION
arrGrid(0, 0, 1) = cMapRedWall
arrGrid(32, 0, 1) = cMapBlueWall
arrGrid(0, 32, 1) = cMapGreenWall
arrGrid(32, 32, 1) = cMapYellowWall
arrGrid(0, 16, 1) = cMapOrangeWall
arrGrid(32, 16, 1) = cMapPurpleWall
 
' -----------------------------------------------------------------------------
' DRAW SOME OBJECTS
 
If TRUE = TRUE Then
    iX% = 5
    iY% = 2
 
    iNextWall% = cMapRedWall
    iLoopZ% = 1
    iLoopY% = iY%
    For iLoopX% = iX% To (iX% + 10)
        arrGrid(iLoopX%, iLoopY%, iLoopZ%) = iNextWall%
    Next iLoopX%
 
    iNextWall% = cMapBlueWall
    iLoopZ% = 1
    iLoopY% = iY% + 8
    For iLoopX% = iX% To (iX% + 10)
        arrGrid(iLoopX%, iLoopY%, iLoopZ%) = iNextWall%
    Next iLoopX%
 
    iNextWall% = cMapGreenWall
    iLoopZ% = 1
    iLoopX% = iX% + 1
    For iLoopY% = (iY% + 1) To (iY% + 7)
        arrGrid(iLoopX%, iLoopY%, iLoopZ%) = iNextWall%
    Next iLoopY%
 
    iNextWall% = cMapYellowWall
    iLoopZ% = 1
    iLoopX% = iX% + 9
    For iLoopY% = (iY% + 1) To (iY% + 7)
        arrGrid(iLoopX%, iLoopY%, iLoopZ%) = iNextWall%
    Next iLoopY%
End If
 
' -----------------------------------------------------------------------------
' DRAW A PYRAMID
 
If TRUE = TRUE Then
    iX% = 15
    iY% = 15
    iZ% = 1
    iPosX1% = iX%
    iPosX2% = iX% + 10
    iPosY1% = iY%
    iPosY2% = iY% + 10
 
    bContinue = TRUE
    Do
        ' PLOT NEXT LEVEL
        For iLoopX% = iPosX1% To iPosX2%
            For iLoopY% = iPosY1% To iPosY2%
                Select Case iZ% Mod 6
                    Case 1:
                        iNextWall% = cMapRedWall
                    Case 2:
                        iNextWall% = cMapPurpleWall
                    Case 3:
                        iNextWall% = cMapBlueWall
                    Case 4:
                        iNextWall% = cMapGreenWall
                    Case 5:
                        iNextWall% = cMapYellowWall
                    Case Else:
                        iNextWall% = cMapOrangeWall
                End Select
                arrGrid(iLoopX%, iLoopY%, iZ%) = iNextWall%
            Next iLoopY%
        Next iLoopX%
 
        ' MOVE UP A LEVEL
        iPosX1% = iPosX1% + 1
        iPosX2% = iPosX2% - 1
        iPosY1% = iPosY1% + 1
        iPosY2% = iPosY2% - 1
 
        ' QUIT AFTER WE REACH THE TOP
        If (iPosX1% <= iPosX2%) And (iPosY1% <= iPosY2%) Then
            iZ% = iZ% + 1
        Else
            bContinue = FALSE
        End If
 
    Loop Until bContinue = FALSE
End If
 
' -----------------------------------------------------------------------------
' DRAW PIPES
 
IF TRUE=TRUE THEN
        iX% = 5 ' RandomNumber(0, 32)
        iY% = 28 ' RandomNumber(0, 32)
        iZ% = 1 ' 32
        
        bFirst = TRUE
        iMove% = 4
        iCount% = 0
        bFinished = FALSE
        Do
                iNextX% = iX%
                iNextY% = iY%
                iNextZ% = iZ%
 
                iMove% = iMove% + 1
                If iMove% > 4 Then
                        iMove% = 0
 
                        If bFirst = TRUE Then
                                ' MOVE UP FOR FIRST MOVE
                                iNum% = 2
                                bFirst = FALSE
                        Else
                                iNum% = RandomNumber(1, 6)
                        End If
                End If
 
                Select Case iNum%
                        Case 1:
                                If iNextZ% > 0 Then
                                        iNextZ% = iNextZ% - 1
                                End If
                        Case 2:
                                If iNextZ% < 32 Then
                                        iNextZ% = iNextZ% + 1
                                End If
                        Case 3:
                                If iNextX% > 0 Then
                                        iNextX% = iNextX% - 1
                                End If
                        Case 4:
                                If iNextX% < 32 Then
                                        iNextX% = iNextX% + 1
                                End If
                        Case 5:
                                If iNextY% > 0 Then
                                        iNextY% = iNextY% - 1
                                End If
                        Case Else:
                                If iNextY% < 32 Then
                                        iNextY% = iNextY% + 1
                                End If
                End Select
 
                If arrGrid(iNextX%, iNextY%, iNextZ%) = cMapEmpty Then
                        iCount% = iCount% + 1
                        iX% = iNextX%
                        iY% = iNextY%
                        iZ% = iNextZ%
 
                        Select Case iCount% Mod 6
                                Case 1:
                                        iNextWall% = cMapRedWall
                                Case 2:
                                        iNextWall% = cMapPurpleWall
                                Case 3:
                                        iNextWall% = cMapBlueWall
                                Case 4:
                                        iNextWall% = cMapGreenWall
                                Case 5:
                                        iNextWall% = cMapYellowWall
                                Case Else:
                                        iNextWall% = cMapOrangeWall
                        End Select
                        arrGrid(iX%, iY%, iZ%) = iNextWall%
 
                        ' HAVE WE PLACED MAX # OF BLOCKS?
                        If iCount% > 64 Then
                                bFinished = TRUE
                        End If
                Else
                        ' SEE IF WE HAVE ANY OPEN SPACES TO MOVE TO
                        iOpen% = 0
                        If iZ% > 0 Then
                                If arrGrid(iX%, iY%, iZ% - 1) <> cMapEmpty Then
                                        iOpen% = iOpen% + 1
                                End If
                        End If
                        If iZ% < 32 Then
                                If arrGrid(iX%, iY%, iZ% + 1) <> cMapEmpty Then
                                        iOpen% = iOpen% + 1
                                End If
                        End If
                        If iX% > 0 Then
                                If arrGrid(iX% - 1, iY%, iZ%) <> cMapEmpty Then
                                        iOpen% = iOpen% + 1
                                End If
                        End If
                        If iX% < 32 Then
                                If arrGrid(iX% + 1, iY%, iZ%) <> cMapEmpty Then
                                        iOpen% = iOpen% + 1
                                End If
                        End If
                        If iY% > 0 Then
                                If arrGrid(iX%, iY% - 1, iZ%) <> cMapEmpty Then
                                        iOpen% = iOpen% + 1
                                End If
                        End If
                        If iY% < 32 Then
                                If arrGrid(iX%, iY% + 1, iZ%) <> cMapEmpty Then
                                        iOpen% = iOpen% + 1
                                End If
                        End If
 
                        ' QUIT IF NO OPEN SPACES AVAILABLE
                        If iOpen% = 0 Then
                                ' NOWHERE TO GO, EXIT
                                bFinished = TRUE
                        End If
                End If
 
        Loop Until bFinished = TRUE
END IF
 
' -----------------------------------------------------------------------------
' Draw the map in 3D Isometic Perspective
 
bTile = FALSE
For iLoopZ% = 0 To 32
    For iLoopX% = 0 To 32 'STEP -1
        For iLoopY% = 0 To 32 'STEP -1
            ' DETERMINE COLOR
            If arrGrid(iLoopX%, iLoopY%, iLoopZ%) = cMapTileFloor Then
                If bTile = TRUE Then
                    iColor = cGray&
                    bTile = FALSE
                Else
                    iColor = cLightGray&
                    bTile = TRUE
                End If
            ElseIf arrGrid(iLoopX%, iLoopY%, iLoopZ%) = cMapRedWall Then
                iColor = cRed&
            ElseIf arrGrid(iLoopX%, iLoopY%, iLoopZ%) = cMapBlueWall Then
                iColor = cBlue&
            ElseIf arrGrid(iLoopX%, iLoopY%, iLoopZ%) = cMapGreenWall Then
                iColor = cGreen&
            ElseIf arrGrid(iLoopX%, iLoopY%, iLoopZ%) = cMapYellowWall Then
                iColor = cYellow&
            ElseIf arrGrid(iLoopX%, iLoopY%, iLoopZ%) = cMapOrangeWall Then
                iColor = cOrange&
            ElseIf arrGrid(iLoopX%, iLoopY%, iLoopZ%) = cMapPurpleWall Then
                iColor = cPurple&
            Else
                iColor = cEmpty&
            End If
                        
            ' CALCULATE POSITION
            iZ% = iLoopZ% * iGridSize + cGridOffsetZ
            iPosX1% = iLoopX% * iGridSize + cGridOffsetX
            iPosY1% = iLoopY% * iGridSize + cGridOffsetY
            iPosX2% = iPosX1% + iGridSize
            iPosY2% = iPosY1% + iGridSize
            If iColor <> cEmpty& Then
                IsoLine3D iPosX1%, iPosY1%, iPosX2%, iPosY2%, iZ%, iGridSize, cScreenOffsetX, cScreenOffsetY, iColor
            End If
 
        Next iLoopY%
    Next iLoopX%
Next iLoopZ%
 
' -----------------------------------------------------------------------------
' GIVE OPTION TO VIEW MAP AS TEXT
 
If TRUE = TRUE Then
    Input "See a text dump (y/n)? ", i2$
 
    If LCase$(i2$) = LCase$("y") Then
        iMinX% = -1
        iMaxX% = -1
        iMinY% = -1
        iMaxY% = -1
        iMinZ% = -1
        iMaxZ% = -1
        For iLoopZ% = 0 To 32
            For iLoopX% = 0 To 32
                For iLoopY% = 0 To 32
                    iNext% = arrGrid(iLoopX%, iLoopY%, iLoopZ%)
                    If iNext% <> cMapEmpty And iNext% <> cMapTileFloor Then
                        If iMinX% = -1 Then
                            iMinX% = iLoopX%
                        End If
                        If iMinY% = -1 Then
                            iMinY% = iLoopY%
                        End If
                        If iMinZ% = -1 Then
                            iMinZ% = iLoopZ%
                        End If
                        If iLoopX% > iMaxX% Then
                            iMaxX% = iLoopX%
                        End If
                        If iLoopY% > iMaxY% Then
                            iMaxY% = iLoopY%
                        End If
                        If iLoopZ% > iMaxZ% Then
                            iMaxZ% = iLoopZ%
                        End If
                    End If
                Next iLoopY%
            Next iLoopX%
        Next iLoopZ%
 
        For iLoopZ% = iMinZ% To iMaxZ%
            Cls
            Print "Map Z=" + cstr$(iLoopZ%) + ":"
 
            For iLoopY% = iMinY% To iMaxY%
                sLine = ""
                For iLoopX% = iMinX% To iMaxX%
                    iNext% = arrGrid(iLoopX%, iLoopY%, iLoopZ%)
                    If iNext% > cMapEmpty Then
                        If iNext% <= cMapOrangeWall Then
                            sLine = sLine + cstr$(iNext%)
                        Else
                            sLine = sLine + " "
                        End If
                    Else
                        sLine = sLine + " "
                    End If
                Next iLoopX%
                Print sLine
            Next iLoopY%
 
            If iLoopZ% < iMaxZ% Then
                Input "Press <ENTER> to continue", i2$
            End If
        Next iLoopZ%
    End If
End If
 
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
'_CONSOLE OFF
' ****************************************************************************************************************************************************************
 
' -----------------------------------------------------------------------------
' FINISHED
Input "Press <ENTER> to continue", i2$
 
System ' return control to the operating system
Print ProgramName$ + " finished."
End
 
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GRAPHICS FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
' /////////////////////////////////////////////////////////////////////////////
 
Function CX2I (x As Long, y As Long) 'Convert Cartesian X To Isometic coordinates
    CX2I = x - y
End Function ' CX2I
 
' /////////////////////////////////////////////////////////////////////////////
 
Function CY2I (x As Long, y As Long) 'Convert Cartesian Y To Isometic coordinates
    CY2I = (x + y) / 2
End Function ' CY2I
 
' /////////////////////////////////////////////////////////////////////////////
' since we're drawing a diamond and not a square box, we can't use Line BF.
' We have to manually down the 4 points of the line.
 
Sub IsoLine (x, y, x2, y2, xoffset, yoffset, iColor As _Unsigned Long)
    Line (CX2I(x, y) + xoffset, CY2I(x, y) + yoffset)-(CX2I(x2, y) + xoffset, CY2I(x2, y) + yoffset), iColor
    Line -(CX2I(x2, y2) + xoffset, CY2I(x2, y2) + yoffset), iColor
    Line -(CX2I(x, y2) + xoffset, CY2I(x, y2) + yoffset), iColor
    Line -(CX2I(x, y) + xoffset, CY2I(x, y) + yoffset), iColor
    Paint (CX2I(x, y) + xoffset, CY2I(x, y) + 4), iColor 'and fill the diamond solid
    Line (CX2I(x, y) + xoffset, CY2I(x, y) + yoffset)-(CX2I(x2, y) + xoffset, CY2I(x2, y) + yoffset), &HFFFFFFFF
    Line -(CX2I(x2, y2) + xoffset, CY2I(x2, y2) + yoffset), &HFFFFFFFF
    Line -(CX2I(x, y2) + xoffset, CY2I(x, y2) + yoffset), &HFFFFFFFF
    Line -(CX2I(x, y) + xoffset, CY2I(x, y) + yoffset), &HFFFFFFFF
End Sub ' IsoLine
 
' /////////////////////////////////////////////////////////////////////////////
' Like IsoLine, we're going to have to draw our lines manually.
' only in this case, we also need a Z coordinate to tell us how
' THICK/TALL/HIGH to make our tile
 
' MODIFIED by madscijr to draw a single block of height iHeight at Z axis
 
'Sub IsoLine3D (x, y, x2, y2, z, xoffset, yoffset, iColor As _Unsigned Long)
Sub IsoLine3D (x, y, x2, y2, z, iHeight, xoffset, yoffset, iColor As _Unsigned Long)
    r = _Red32(iColor): g = _Green32(iColor): b = _Blue32(iColor)
 
    ' Let's just do all the math first this time.
    ' We need to turn those 4 normal points into 4 isometric points (x, y, x1, y1)
    TempX1 = CX2I(x, y) + xoffset
    TempY1 = CY2I(x, y) + yoffset
    TempX2 = CX2I(x2, y) + xoffset
    TempY2 = CY2I(x2, y) + yoffset
    TempX3 = CX2I(x2, y2) + xoffset
    TempY3 = CY2I(x2, y2) + yoffset
    TempX4 = CX2I(x, y2) + xoffset
    TempY4 = CY2I(x, y2) + yoffset
 
    ' The top
    fquad TempX1, TempY1 - z, TempX2, TempY2 - z, TempX3, TempY3 - z, TempX4, TempY4 - z, iColor
 
    If z <> 0 Then
        ' the left side
        'fquad TempX4, TempY4 - z, TempX4, TempY4, TempX3, TempY3, TempX3, TempY3 - z, _RGB32(.25 * r, .5 * g, .75 * b)
        fquad TempX4, TempY4 - z, TempX4, TempY4 - z + iHeight, TempX3, TempY3 - z + iHeight, TempX3, TempY3 - z, _RGB32(.25 * r, .5 * g, .75 * b)
 
        ' and then for the right side
        'fquad TempX3, TempY3 - z, TempX3, TempY3, TempX2, TempY2, TempX2, TempY2 - z, _RGB32(.75 * r, .3 * g, .3 * b)
        fquad TempX3, TempY3 - z, TempX3, TempY3 - z + iHeight, TempX2, TempY2 - z + iHeight, TempX2, TempY2 - z, _RGB32(.75 * r, .3 * g, .3 * b)
    Else
        ' no need to draw any height, if there isn't any.
    End If
End Sub ' IsoLine3D
 
' /////////////////////////////////////////////////////////////////////////////
' found at abandoned, outdated and now likely malicious qb64 dot net website
' don’t go there: http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=14425.0
 
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    Dim D As Long
    Dim a&
 
    D = _Dest
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest D
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& ' <<< this is important!
End Sub ' ftri
 
' /////////////////////////////////////////////////////////////////////////////
' 2019-11-20 Steve saves some time with STATIC
' and saves and restores last dest
 
Sub ftri1 (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    Dim D As Long
    Static a&
 
    D = _Dest
    If a& = 0 Then
        a& = _NewImage(1, 1, 32)
    End If
    _Dest a&
    _DontBlend a&
    PSet (0, 0), K
    _Blend a&
    _Dest D
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub ' ftri1
 
' /////////////////////////////////////////////////////////////////////////////
' original fill quad that may be at fault using Steve's fTri version
' need 4 non linear points (not all on 1 line) list them clockwise
' so x2, y2 is opposite of x4, y4
 
Sub fquad1 (x1, y1, x2, y2, x3, y3, x4, y4, K As _Unsigned Long)
    ftri1 x1, y1, x2, y2, x4, y4, K
    ftri1 x3, y3, x2, y2, x4, y4, K
End Sub ' fquad1
 
' /////////////////////////////////////////////////////////////////////////////
' update 2019-12-16 needs orig fTri
' need 4 non linear points (not all on 1 line)
' list them clockwise so x2, y2 is opposite of x4, y4
 
Sub fquad (x1, y1, x2, y2, x3, y3, x4, y4, K As _Unsigned Long)
    ftri x1, y1, x2, y2, x3, y3, K
    ftri x3, y3, x4, y4, x1, y1, K
End Sub ' fquad
 
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GRAPHICS FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
' /////////////////////////////////////////////////////////////////////////////
 
Function cstr$ (myValue)
    'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
    cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
 
' /////////////////////////////////////////////////////////////////////////////
 
Function cstrl$ (myValue As Long)
    cstrl$ = _Trim$(Str$(myValue))
End Function ' cstrl$
 
' /////////////////////////////////////////////////////////////////////////////
 
Function cstrs$ (myValue As Single)
    ''cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
    cstrs$ = _Trim$(Str$(myValue))
End Function ' cstrs$
 
' /////////////////////////////////////////////////////////////////////////////
 
Function IIF (Condition, IfTrue, IfFalse)
    If Condition Then IIF = IfTrue Else IIF = IfFalse
End Function
 
' /////////////////////////////////////////////////////////////////////////////
 
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
    If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
 
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
 
' Returns the 8-bit binary representation
' of an integer iInput where 0 <= iInput <= 255
 
Function GetBinary$ (iInput1 As Integer)
    Dim sResult As String
    Dim iLoop As Integer
    Dim iInput As Integer: iInput = iInput1
 
    sResult = ""
 
    If iInput >= 0 And iInput <= 255 Then
        For iLoop = 1 To 8
            sResult = LTrim$(RTrim$(Str$(iInput Mod 2))) + sResult
            iInput = iInput \ 2
            'If iLoop = 4 Then sResult = " " + sResult
        Next iLoop
    End If
 
    GetBinary$ = sResult
End Function ' GetBinary$
 
' /////////////////////////////////////////////////////////////////////////////
' wonderfully inefficient way to read if a bit is set
' ival = GetBit256%(int we are comparing, int containing the bits we want to read)
 
' See also: GetBit256%, SetBit256%
 
Function GetBit256% (iNum1 As Integer, iBit1 As Integer)
    Dim iResult As Integer
    Dim sNum As String
    Dim sBit As String
    Dim iLoop As Integer
    Dim bContinue As Integer
    'DIM iTemp AS INTEGER
    Dim iNum As Integer: iNum = iNum1
    Dim iBit As Integer: iBit = iBit1
 
    iResult = FALSE
    bContinue = TRUE
 
    If iNum < 256 And iBit <= 128 Then
        sNum = GetBinary$(iNum)
        sBit = GetBinary$(iBit)
        For iLoop = 1 To 8
            If Mid$(sBit, iLoop, 1) = "1" Then
                'if any of the bits in iBit are false, return false
                If Mid$(sNum, iLoop, 1) = "0" Then
                    iResult = FALSE
                    bContinue = FALSE
                    Exit For
                End If
            End If
        Next iLoop
        If bContinue = TRUE Then
            iResult = TRUE
        End If
    End If
 
    GetBit256% = iResult
End Function ' GetBit256%
 
' /////////////////////////////////////////////////////////////////////////////
' From: Bitwise Manipulations By Steven Roman
' http://www.romanpress.com/Articles/Bitwise_R/Bitwise.htm
 
' Returns the integer that corresponds to a binary string of length 8
 
Function GetIntegerFromBinary% (sBinary1 As String)
    Dim iResult As Integer
    Dim iLoop As Integer
    Dim strBinary As String
    Dim sBinary As String: sBinary = sBinary1
 
    iResult = 0
    strBinary = Replace$(sBinary, " ", "") ' Remove any spaces
    For iLoop = 0 To Len(strBinary) - 1
        iResult = iResult + 2 ^ iLoop * Val(Mid$(strBinary, Len(strBinary) - iLoop, 1))
    Next iLoop
 
    GetIntegerFromBinary% = iResult
End Function ' GetIntegerFromBinary%
 
' /////////////////////////////////////////////////////////////////////////////
' By sMcNeill from https://www.qb64.org/forum/index.php?topic=896.0
 
Function IsNum% (text$)
    Dim a$
    Dim b$
    a$ = _Trim$(text$)
    b$ = _Trim$(Str$(Val(text$)))
    If a$ = b$ Then
        IsNum% = TRUE
    Else
        IsNum% = FALSE
    End If
End Function ' IsNum%
 
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
 
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
 
Function join$ (in$(), delimiter$)
    result$ = in$(LBound(in$))
    For i = LBound(in$) + 1 To UBound(in$)
        result$ = result$ + delimiter$ + in$(i)
    Next i
    join$ = result$
End Function ' join$
 
' /////////////////////////////////////////////////////////////////////////////
' ABS was returning strange values with type LONG
' so I created this which does not.
 
Function LongABS& (lngValue As Long)
    If Sgn(lngValue) = -1 Then
        LongABS& = 0 - lngValue
    Else
        LongABS& = lngValue
    End If
End Function ' LongABS&
 
' /////////////////////////////////////////////////////////////////////////////
' Returns blank if successful else returns error message.
 
Function PrintFile$ (sFileName As String, sText As String, bAppend As Integer)
    'x = 1: y = 2: z$ = "Three"
 
    Dim sError As String: sError = ""
 
    If Len(sError) = 0 Then
        If (bAppend = TRUE) Then
            If _FileExists(sFileName) Then
                Open sFileName For Append As #1 ' opens an existing file for appending
            Else
                sError = "Error in PrintFile$ : File not found. Cannot append."
            End If
        Else
            Open sFileName For Output As #1 ' opens and clears an existing file or creates new empty file
        End If
    End If
    If Len(sError) = 0 Then
        ' WRITE places text in quotes in the file
        'WRITE #1, x, y, z$
        'WRITE #1, sText
 
        ' PRINT does not put text inside quotes
        Print #1, sText
 
        Close #1
 
        'PRINT "File created with data. Press a key!"
        'K$ = INPUT$(1) 'press a key
 
        'OPEN sFileName FOR INPUT AS #2 ' opens a file to read it
        'INPUT #2, a, b, c$
        'CLOSE #2
 
        'PRINT a, b, c$
        'WRITE a, b, c$
    End If
 
    PrintFile$ = sError
End Function ' PrintFile$
 
' /////////////////////////////////////////////////////////////////////////////
' Generate random value between Min and Max.
Function RandomNumber% (Min%, Max%)
    Dim NumSpread%
 
    ' SET RANDOM SEED
    'Randomize ' Initialize random-number generator.
    Randomize Timer
 
    ' GET RANDOM # Min%-Max%
    'RandomNumber = Int((Max * Rnd) + Min) ' generate number
 
    NumSpread% = (Max% - Min%) + 1
 
    RandomNumber% = Int(Rnd * NumSpread%) + Min% ' GET RANDOM # BETWEEN Max% AND Min%
 
End Function ' RandomNumber%
 
' /////////////////////////////////////////////////////////////////////////////
 
Sub RandomNumberTest
    Dim iCols As Integer: iCols = 10
    Dim iRows As Integer: iRows = 20
    Dim iLoop As Integer
    Dim iX As Integer
    Dim iY As Integer
    Dim sError As String
    Dim sFileName As String
    Dim sText As String
    Dim bAppend As Integer
    Dim iMin As Integer
    Dim iMax As Integer
    Dim iNum As Integer
    Dim iErrorCount As Integer
    Dim sInput$
 
    sFileName = "c:\temp\maze_test_1.txt"
    sText = "Count" + Chr$(9) + "Min" + Chr$(9) + "Max" + Chr$(9) + "Random"
    bAppend = FALSE
    sError = PrintFile$(sFileName, sText, bAppend)
    If Len(sError) = 0 Then
        bAppend = TRUE
        iErrorCount = 0
 
        iMin = 0
        iMax = iCols - 1
        For iLoop = 1 To 100
            iNum = RandomNumber(iMin, iMax)
            sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
            sError = PrintFile$(sFileName, sText, bAppend)
            If Len(sError) > 0 Then
                iErrorCount = iErrorCount + 1
                Print Str$(iLoop) + ". ERROR"
                Print "    " + "iMin=" + Str$(iMin)
                Print "    " + "iMax=" + Str$(iMax)
                Print "    " + "iNum=" + Str$(iNum)
                Print "    " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
                Print "    " + sError
            End If
        Next iLoop
 
        iMin = 0
        iMax = iRows - 1
        For iLoop = 1 To 100
            iNum = RandomNumber(iMin, iMax)
            sText = Str$(iLoop) + Chr$(9) + Str$(iMin) + Chr$(9) + Str$(iMax) + Chr$(9) + Str$(iNum)
            sError = PrintFile$(sFileName, sText, bAppend)
            If Len(sError) > 0 Then
                iErrorCount = iErrorCount + 1
                Print Str$(iLoop) + ". ERROR"
                Print "    " + "iMin=" + Str$(iMin)
                Print "    " + "iMax=" + Str$(iMax)
                Print "    " + "iNum=" + Str$(iNum)
                Print "    " + "Could not write to file " + Chr$(34) + sFileName + Chr$(34) + "."
                Print "    " + sError
            End If
        Next iLoop
 
        Print "Finished generating numbers. Errors: " + Str$(iErrorCount)
    Else
        Print "Error creating file " + Chr$(34) + sFileName + Chr$(34) + "."
        Print sError
    End If
 
    Input "Press <ENTER> to continue", sInput$
End Sub ' RandomNumberTest
 
' /////////////////////////////////////////////////////////////////////////////
' FROM: String Manipulation
' http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index_topic_5964-0/
'
'SUMMARY:
'   Purpose:  A library of custom functions that transform strings.
'   Author:   Dustinian Camburides (dustinian@gmail.com)
'   Platform: QB64 (www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there])
'   Revision: 1.6
'   Updated:  5/28/2012
 
'SUMMARY:
'[Replace$] replaces all instances of the [Find] sub-string with the [Add] sub-string within the [Text] string.
'INPUT:
'Text: The input string; the text that's being manipulated.
'Find: The specified sub-string; the string sought within the [Text] string.
'Add: The sub-string that's being added to the [Text] string.
 
Function Replace$ (Text1 As String, Find1 As String, Add1 As String)
    ' VARIABLES:
    Dim Text2 As String
    Dim Find2 As String
    Dim Add2 As String
    Dim lngLocation As Long ' The address of the [Find] substring within the [Text] string.
    Dim strBefore As String ' The characters before the string to be replaced.
    Dim strAfter As String ' The characters after the string to be replaced.
 
    ' INITIALIZE:
    ' MAKE COPIESSO THE ORIGINAL IS NOT MODIFIED (LIKE ByVal IN VBA)
    Text2 = Text1
    Find2 = Find1
    Add2 = Add1
 
    lngLocation = InStr(1, Text2, Find2)
 
    ' PROCESSING:
    ' While [Find2] appears in [Text2]...
    While lngLocation
        ' Extract all Text2 before the [Find2] substring:
        strBefore = Left$(Text2, lngLocation - 1)
 
        ' Extract all text after the [Find2] substring:
        strAfter = Right$(Text2, ((Len(Text2) - (lngLocation + Len(Find2) - 1))))
 
        ' Return the substring:
        Text2 = strBefore + Add2 + strAfter
 
        ' Locate the next instance of [Find2]:
        lngLocation = InStr(1, Text2, Find2)
 
        ' Next instance of [Find2]...
    Wend
 
    ' OUTPUT:
    Replace$ = Text2
End Function ' Replace$
 
' /////////////////////////////////////////////////////////////////////////////
' fantastically inefficient way to set a bit
 
' example use: arrMaze(iX, iY) = SetBit256%(arrMaze(iX, iY), cS, FALSE)
 
' See also: GetBit256%, SetBit256%
 
' newint=SetBit256%(oldint, int containing the bits we want to set, value to set them to)
Function SetBit256% (iNum1 As Integer, iBit1 As Integer, bVal1 As Integer)
    Dim sNum As String
    Dim sBit As String
    Dim sVal As String
    Dim iLoop As Integer
    Dim strResult As String
    Dim iResult As Integer
    Dim iNum As Integer: iNum = iNum1
    Dim iBit As Integer: iBit = iBit1
    Dim bVal As Integer: bVal = bVal1
 
    If iNum < 256 And iBit <= 128 Then
        sNum = GetBinary$(iNum)
        sBit = GetBinary$(iBit)
        If bVal = TRUE Then
            sVal = "1"
        Else
            sVal = "0"
        End If
        strResult = ""
        For iLoop = 1 To 8
            If Mid$(sBit, iLoop, 1) = "1" Then
                strResult = strResult + sVal
            Else
                strResult = strResult + Mid$(sNum, iLoop, 1)
            End If
        Next iLoop
        iResult = GetIntegerFromBinary%(strResult)
    Else
        iResult = iNum
    End If
 
    SetBit256% = iResult
End Function ' SetBit256%
 
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM Â»
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
 
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
 
Sub split (in$, delimiter$, result$())
    ReDim result$(-1)
    start = 1
    Do
        While Mid$(in$, start, 1) = delimiter$
            start = start + 1
            If start > Len(in$) Then Exit Sub
        Wend
        finish = InStr(start, in$, delimiter$)
        If finish = 0 Then finish = Len(in$) + 1
        ReDim _Preserve result$(0 To UBound(result$) + 1)
        result$(UBound(result$)) = Mid$(in$, start, finish - start)
        start = finish + 1
    Loop While start <= Len(in$)
End Sub ' split
 
' /////////////////////////////////////////////////////////////////////////////
 
Sub SplitTest
 
    Dim in$
    Dim delim$
    ReDim arrTest$(0)
    Dim iLoop%
 
    delim$ = Chr$(10)
    in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
    Print "in$ = " + Chr$(34) + in$ + Chr$(34)
    Print "delim$ = " + Chr$(34) + delimeter$ + Chr$(34)
    split in$, delim$, arrTest$()
 
    For iLoop% = LBound(arrTest$) To UBound(arrTest$)
        Print "arrTest$(" + LTrim$(RTrim$(Str$(iLoop%))) + ") = " + Chr$(34) + arrTest$(iLoop%) + Chr$(34)
    Next iLoop%
    Print
    Print "Split test finished."
End Sub ' SplitTest
 
' /////////////////////////////////////////////////////////////////////////////
 
Sub WaitForEnter
    Dim in$
    Input "Press <ENTER> to continue", in$
End Sub ' WaitForEnter
 
' /////////////////////////////////////////////////////////////////////////////
' WaitForKey "Press <ESC> to continue", 27, 0
' WaitForKey "Press <ENTER> to begin;", 13, 0
' waitforkey "", 65, 5
 
Sub WaitForKey (prompt$, KeyCode&, DelaySeconds%)
    ' SHOW PROMPT (IF SPECIFIED)
    If Len(prompt$) > 0 Then
        If Right$(prompt$, 1) <> ";" Then
            Print prompt$
        Else
            Print Right$(prompt$, Len(prompt$) - 1);
        End If
    End If
 
    ' WAIT FOR KEY
    Do: Loop Until _KeyDown(KeyCode&) ' leave loop when specified key pressed
 
    ' PAUSE AFTER (IF SPECIFIED)
    If DelaySeconds% < 1 Then
        _KeyClear: '_DELAY 1
    Else
        _KeyClear: _Delay DelaySeconds%
    End If
End Sub ' WaitForKey
 
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
' NOTE: these are mostly negative numbers
'       and have to be forced to positive
'       when stored in the dictionary
'       (only cEmpty& should be negative)
 
Function cRed& ()
    cRed& = _RGB32(255, 0, 0)
End Function
 
Function cOrangeRed& ()
    cOrangeRed& = _RGB32(255, 69, 0)
End Function ' cOrangeRed&
 
Function cDarkOrange& ()
    cDarkOrange& = _RGB32(255, 140, 0)
End Function ' cDarkOrange&
 
Function cOrange& ()
    cOrange& = _RGB32(255, 165, 0)
End Function ' cOrange&
 
Function cGold& ()
    cGold& = _RGB32(255, 215, 0)
End Function ' cGold&
 
Function cYellow& ()
    cYellow& = _RGB32(255, 255, 0)
End Function ' cYellow&
 
Function cChartreuse& ()
    cChartreuse& = _RGB32(127, 255, 0)
End Function ' cChartreuse&
 
Function cLime& ()
    cLime& = _RGB32(0, 255, 0)
End Function ' cLime&
 
Function cMediumSpringGreen& ()
    cMediumSpringGreen& = _RGB32(0, 250, 154)
End Function ' cMediumSpringGreen&
 
Function cCyan& ()
    cCyan& = _RGB32(0, 255, 255)
End Function ' cCyan&
 
Function cDeepSkyBlue& ()
    cDeepSkyBlue& = _RGB32(0, 191, 255)
End Function ' cDeepSkyBlue&
 
Function cDodgerBlue& ()
    cDodgerBlue& = _RGB32(30, 144, 255)
End Function ' cDodgerBlue&
 
Function cSeaBlue& ()
    cSeaBlue& = _RGB32(0, 64, 255)
End Function ' cSeaBlue&
 
Function cBlue& ()
    cBlue& = _RGB32(0, 0, 255)
End Function ' cBlue&
 
Function cBluePurple& ()
    cBluePurple& = _RGB32(64, 0, 255)
End Function ' cBluePurple&
 
Function cDeepPurple& ()
    cDeepPurple& = _RGB32(96, 0, 255)
End Function ' cDeepPurple&
 
Function cPurple& ()
    cPurple& = _RGB32(128, 0, 255)
End Function ' cPurple&
 
Function cPurpleRed& ()
    cPurpleRed& = _RGB32(128, 0, 192)
End Function ' cPurpleRed&
 
Function cDarkRed& ()
    cDarkRed& = _RGB32(160, 0, 64)
End Function ' cDarkRed&
 
Function cBrickRed& ()
    cBrickRed& = _RGB32(192, 0, 32)
End Function ' cBrickRed&
 
Function cDarkGreen& ()
    cDarkGreen& = _RGB32(0, 100, 0)
End Function ' cDarkGreen&
 
Function cGreen& ()
    cGreen& = _RGB32(0, 128, 0)
End Function ' cGreen&
 
Function cOliveDrab& ()
    cOliveDrab& = _RGB32(107, 142, 35)
End Function ' cOliveDrab&
 
Function cLightPink& ()
    cLightPink& = _RGB32(255, 182, 193)
End Function ' cLightPink&
 
Function cHotPink& ()
    cHotPink& = _RGB32(255, 105, 180)
End Function ' cHotPink&
 
Function cDeepPink& ()
    cDeepPink& = _RGB32(255, 20, 147)
End Function ' cDeepPink&
 
Function cMagenta& ()
    cMagenta& = _RGB32(255, 0, 255)
End Function ' cMagenta&
 
Function cBlack& ()
    cBlack& = _RGB32(0, 0, 0)
End Function ' cBlack&
 
Function cDimGray& ()
    cDimGray& = _RGB32(105, 105, 105)
End Function ' cDimGray&
 
Function cGray& ()
    cGray& = _RGB32(128, 128, 128)
End Function ' cGray&
 
Function cDarkGray& ()
    cDarkGray& = _RGB32(169, 169, 169)
End Function ' cDarkGray&
 
Function cSilver& ()
    cSilver& = _RGB32(192, 192, 192)
End Function ' cSilver&
 
Function cLightGray& ()
    cLightGray& = _RGB32(211, 211, 211)
End Function ' cLightGray&
 
Function cGainsboro& ()
    cGainsboro& = _RGB32(220, 220, 220)
End Function ' cGainsboro&
 
Function cWhiteSmoke& ()
    cWhiteSmoke& = _RGB32(245, 245, 245)
End Function ' cWhiteSmoke&
 
Function cWhite& ()
    cWhite& = _RGB32(255, 255, 255)
End Function ' cWhite&
 
Function cDarkBrown& ()
    cDarkBrown& = _RGB32(128, 64, 0)
End Function ' cDarkBrown&
 
Function cLightBrown& ()
    cLightBrown& = _RGB32(196, 96, 0)
End Function ' cLightBrown&
 
Function cKhaki& ()
    cKhaki& = _RGB32(240, 230, 140)
End Function ' cKhaki&
 
Function cEmpty& ()
    cEmpty& = -1
End Function ' cEmpty&
 
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 

News:

Author Topic: Isometric Mapping Demo re-visited (Read 778 times)

madscijr

Isometric Mapping Demo re-visited