Print Page - Isometric Demo re-revisited (getting better!)

' ################################################################################################################################################################
' Isomatric mapping demo re-revisited
' Version 2.69 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 cubes of different colors,
' and draws them to the screen in 2.5D "isometric".
' Added code to render cubes that block the view of
' the player as transparent. Added a 2-D top down "map"
' view of the player's current Z slice.
' TO DO:
' * allow player to rotate their view
' * option to hide objects out of player's line-of-sight
' * add objects (water, ladders, ropes, windows, doors, ramps, etc.)
' * shrink grid size to 8x8 (may need to use some other rendering method)
' * expand world to bigger than screen (2.5d scrolling view)
' * show player as a stick figure (like "Realm of Impossibility")
' * add ability to walk up ramps / climb ladders / etc.
' * simultaneously show additional 1st person view
' * add ability for tilting head up/down in first person
' * split screen (x2 or x4) local multi-player version
' * make simple open world (players can add/remove blocks, build in real time, save screens)
' * make simple games (maze craze, capture the flag, snake, surround, 2.5d pong)
' * make more complex games (berzerk, lode runner, atari combat / tank)
' * make awesome complex games (2.5d lunar lander, atari adventure, asteroids, gravitar, etc.)
' ################################################################################################################################################################
' =============================================================================
' 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
' -----------------------------------------------------------------------------
' KeyDownConstants
' -----------------------------------------------------------------------------
Const c_iKeyDown_Esc = 27
Const c_iKeyDown_F1 = 15104
Const c_iKeyDown_F2 = 15360
Const c_iKeyDown_F3 = 15616
Const c_iKeyDown_F4 = 15872
Const c_iKeyDown_F5 = 16128
Const c_iKeyDown_F6 = 16384
Const c_iKeyDown_F7 = 16640
Const c_iKeyDown_F8 = 16896
Const c_iKeyDown_F9 = 17152
Const c_iKeyDown_F10 = 17408
Const c_iKeyDown_Tilde = 96
Const c_iKeyDown_1 = 49
Const c_iKeyDown_2 = 50
Const c_iKeyDown_3 = 51
Const c_iKeyDown_4 = 52
Const c_iKeyDown_5 = 53
Const c_iKeyDown_6 = 54
Const c_iKeyDown_7 = 55
Const c_iKeyDown_8 = 56
Const c_iKeyDown_9 = 57
Const c_iKeyDown_0 = 48
Const c_iKeyDown_Minus = 45
Const c_iKeyDown_EqualPlus = 61
Const c_iKeyDown_BkSp = 8
Const c_iKeyDown_Ins = 20992
Const c_iKeyDown_Home = 18176
Const c_iKeyDown_PgUp = 18688
Const c_iKeyDown_Del = 21248
Const c_iKeyDown_End = 20224
Const c_iKeyDown_PgDn = 20736
Const c_iKeyDown_KEYPAD_7_Home = 18176
Const c_iKeyDown_KEYPAD_8_Up = 18432
Const c_iKeyDown_KEYPAD_9_PgUp = 18688
Const c_iKeyDown_KEYPAD_4_Left = 19200
Const c_iKeyDown_KEYPAD_6_Right = 19712
Const c_iKeyDown_KEYPAD_1_End = 20224
Const c_iKeyDown_KEYPAD_2_Down = 20480
Const c_iKeyDown_KEYPAD_3_PgDn = 20736
Const c_iKeyDown_KEYPAD_0_Ins = 20992
Const c_iKeyDown_KEYPAD_Period_Del = 21248
Const c_iKeyDown_Tab = 9
Const c_iKeyDown_Q = 113
Const c_iKeyDown_W = 119
Const c_iKeyDown_E = 101
Const c_iKeyDown_R = 114
Const c_iKeyDown_T = 116
Const c_iKeyDown_Y = 121
Const c_iKeyDown_U = 117
Const c_iKeyDown_Pipe = 105
Const c_iKeyDown_O = 111
Const c_iKeyDown_P = 112
Const c_iKeyDown_BracketLeft = 91
Const c_iKeyDown_BracketRight = 93
Const c_iKeyDown_Backslash = 92
Const c_iKeyDown_A = 97
Const c_iKeyDown_S = 115
Const c_iKeyDown_D = 100
Const c_iKeyDown_F = 102
Const c_iKeyDown_G = 103
Const c_iKeyDown_H = 104
Const c_iKeyDown_J = 106
Const c_iKeyDown_K = 107
Const c_iKeyDown_L = 108
Const c_iKeyDown_SemiColon = 59
Const c_iKeyDown_Apostrophe = 39
Const c_iKeyDown_Enter = 13
Const c_iKeyDown_Z = 22
Const c_iKeyDown_X = 120
Const c_iKeyDown_C = 99
Const c_iKeyDown_V = 118
Const c_iKeyDown_B = 98
Const c_iKeyDown_N = 110
Const c_iKeyDown_M = 109
Const c_iKeyDown_Comma = 44
Const c_iKeyDown_Period = 46
Const c_iKeyDown_Slash = 47
Const c_iKeyDown_Up = 18432
Const c_iKeyDown_Left = 19200
Const c_iKeyDown_Down = 20480
Const c_iKeyDown_Right = 19712
Const c_iKeyDown_Spacebar = 32
' -----------------------------------------------------------------------------
' constants for map (MapBlockType.Typ)
' -----------------------------------------------------------------------------
Const c_iMapType_Empty = 0
Const c_iMapType_Floor_Tiled = 1
Const c_iMapType_Wall = 2
Const c_iMapType_Water = 3
Const c_iMapType_Window = 4
Const c_iMapType_Player1 = 5
Const c_iMapType_Player2 = 6
' -----------------------------------------------------------------------------
' constants for 2.5D movement
' -----------------------------------------------------------------------------
Const c_iDir_Down = 1
Const c_iDir_Up = 2
Const c_iDir_Left = 3
Const c_iDir_Right = 4
Const c_iDir_Back = 5
Const c_iDir_Forward = 6
Const c_iDir_Min = 1
Const c_iDir_Max = 6
' -----------------------------------------------------------------------------
' constants for drawing the 2.5D screen
' -----------------------------------------------------------------------------
Const cGridOffsetX = 50
Const cGridOffsetY = 50
Const cGridOffsetZ = 0
Const cScreenOffsetX = 500 ' 450
Const cScreenOffsetY = 300 ' 50
Const cScreenOffsetZ = 0
' =============================================================================
' USER DEFINED TYPES
' =============================================================================
Type MapBlockType
Typ As Integer ' c_iMapType_Empty, c_iMap_Floor_Tiled, c_iMap_Wall, etc.
'Vis As Integer ' TRUE = visible, FALSE = don't render
'Lit As Long ' light offset
Color1 As Long ' main color
Color2 As Long ' secondary color if needed
Color3 As Long ' third color if needed
AlphaOverride As Integer ' can be used to override alpha (0 treated as opaque)
End Type ' MapBlockType
' =============================================================================
' GLOBAL VARIABLES
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
Dim Shared m_iGridSize As Integer: m_iGridSize = 10 ' < 10 is causing problems with PAINT
Dim Shared m_iMapMinX As Integer: m_iMapMinX = 0
Dim Shared m_iMapMaxX As Integer: m_iMapMaxX = 32
Dim Shared m_iMapMidX As Integer: m_iMapMidX = (m_iMapMaxX - m_iMapMinX) \ 2
Dim Shared m_iMapMinY As Integer: m_iMapMinY = 0
Dim Shared m_iMapMaxY As Integer: m_iMapMaxY = 32
Dim Shared m_iMapMidY As Integer: m_iMapMidY = (m_iMapMaxY - m_iMapMinY) \ 2
Dim Shared m_iMapMinZ As Integer: m_iMapMinZ = 0
Dim Shared m_iMapMaxZ As Integer: m_iMapMaxZ = 32
Dim Shared m_iMapMidZ As Integer: m_iMapMidZ = (m_iMapMaxZ - m_iMapMinZ) \ 2
' =============================================================================
' LOCAL VARIABLES
Dim in$
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
' ****************************************************************************************************************************************************************
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
System ' return control to the operating system
Print m_ProgramName$ + " finished."
Input "Press <ENTER> to continue", in$
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
_Console Off
' ****************************************************************************************************************************************************************
End
' /////////////////////////////////////////////////////////////////////////////
Sub main
Dim RoutineName As String: RoutineName = "main"
Dim in$
Dim result$
Screen 0
Do
Cls
Print m_ProgramName$
Print
Print "Isomatric Mapping Demo Re-visited"
Print "v2.69, by Softintheheadware (Dec, 2021)"
Print
'PRINT "CONTROLS: PRESS <ESC> TO RETURN TO MENU"
'PRINT "PLAYER LEFT RIGHT UP DOWN "
'PRINT "1 CRSR LEFT CRSR RIGHT CRSR UP CRSR DOWN "
'PRINT "2 KEYPAD 4 KEYPAD 6 KEYPAD 8 KEYPAD 2 "
'PRINT "3 A S W Z "
'PRINT "4 J K I M "
'PRINT
Print "1. IsometricDemo1"
Print "2. IsometricDemo2"
Print "3. Move around in 2.5D"
Print
Print "What to do? ('q' to exit)"
Input in$: in$ = LCase$(Left$(in$, 1))
If in$ = "1" Then
result$ = IsometricDemo1
ElseIf in$ = "2" Then
result$ = IsometricDemo2
ElseIf in$ = "3" Then
result$ = IsometricDemo3
End If
If Len(result$) > 0 Then
Print result$
End If
Loop Until in$ = "q"
End Sub ' main
' /////////////////////////////////////////////////////////////////////////////
Function IsometricDemo1$
Dim RoutineName As String: RoutineName = "IsometricDemo1"
Dim sResult As String: sResult = ""
Dim arrMap(m_iMapMinX To m_iMapMaxX, m_iMapMinY To m_iMapMaxY, m_iMapMinZ To m_iMapMaxZ) As MapBlockType
Dim iX%
Dim iY%
Dim iZ%
Dim iNextX%
Dim iNextY%
Dim iNextZ%
Dim iPosX1%
Dim iPosX2%
Dim iPosY1%
Dim iPosY2%
Dim iLoopX%
Dim iLoopY%
Dim iLoopZ%
Dim iNextColor&
Dim iColorScheme%
Dim bContinue As Integer
Dim iDirection%
Dim bFinished As Integer
Dim iCount%
Dim iOpen%
Dim iMove%
Dim iSegmentLength%
Dim iMaxLength%
Dim bFirst As Integer
Dim bQuit As Integer
Dim in$
' INITIALIZE
'Screen _NewImage(1024, 720, 32) : _ScreenMove _Middle
Screen _NewImage(1280, 1024, 32)
' =============================================================================
' MAIN LOOP
bQuit = FALSE
Do
Cls
' -----------------------------------------------------------------------------
' INITIALIZE MAP TO EMPTY
ClearIsometricMap arrMap()
' -----------------------------------------------------------------------------
' DRAW FLOOR
iZ% = 0
For iLoopX% = 0 To 32
For iLoopY% = 0 To 32
arrMap(iLoopX%, iLoopY%, iZ%).Typ = c_iMapType_Floor_Tiled
arrMap(iLoopX%, iLoopY%, iZ%).Color1 = cGray&
arrMap(iLoopX%, iLoopY%, iZ%).Color2 = cLightGray&
Next iLoopY%
Next iLoopX%
' -----------------------------------------------------------------------------
' DRAW BLOCKS TO CHECK ORIENTATION
For iLoopZ% = m_iMapMinZ + 1 To m_iMapMaxZ
arrMap(m_iMapMinX, m_iMapMinY, iLoopZ%).Typ = c_iMapType_Wall
arrMap(m_iMapMinX, m_iMapMinY, iLoopZ%).Color1 = cRed&
arrMap(m_iMapMaxX, m_iMapMinY, iLoopZ%).Typ = c_iMapType_Wall
arrMap(m_iMapMaxX, m_iMapMinY, iLoopZ%).Color1 = cBlue&
arrMap(m_iMapMinX, m_iMapMaxY, iLoopZ%).Typ = c_iMapType_Wall
arrMap(m_iMapMinX, m_iMapMaxY, iLoopZ%).Color1 = cGreen&
'arrMap(m_iMapMaxX, m_iMapMaxY, iLoopZ%).Typ = c_iMapType_Wall
'arrMap(m_iMapMaxX, m_iMapMaxY, iLoopZ%).Color1 = cYellow&
'arrMap(m_iMapMinX, m_iMapMidY, iLoopZ%).Typ = c_iMapType_Wall
'arrMap(m_iMapMinX, m_iMapMidY, iLoopZ%).Color1 = cOrange&
'
'arrMap(m_iMapMaxX, m_iMapMidY, iLoopZ%).Typ = c_iMapType_Wall
'arrMap(m_iMapMaxX, m_iMapMidY, iLoopZ%).Color1 = cPurple&
'
'arrMap(m_iMapMidX, m_iMapMinY, iLoopZ%).Typ = c_iMapType_Wall
'arrMap(m_iMapMidX, m_iMapMinY, iLoopZ%).Color1 = cLime&
'
'arrMap(m_iMapMidX, m_iMapMaxY, iLoopZ%).Typ = c_iMapType_Wall
'arrMap(m_iMapMidX, m_iMapMaxY, iLoopZ%).Color1 = cCyan&
Next iLoopZ%
' -----------------------------------------------------------------------------
' DRAW SOME OBJECTS
If TRUE = TRUE Then
iX% = 16
iY% = 3
iNextColor& = cRed&
iLoopZ% = 1
iLoopY% = iY%
For iLoopX% = iX% To (iX% + 10)
arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Wall
arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1 = iNextColor&
Next iLoopX%
iNextColor& = cBlue&
iLoopZ% = 1
iLoopY% = iY% + 8
For iLoopX% = iX% To (iX% + 10)
arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Wall
arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1 = iNextColor&
Next iLoopX%
iNextColor& = cGreen&
iLoopZ% = 1
iLoopX% = iX% + 1
For iLoopY% = (iY% + 1) To (iY% + 7)
arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Wall
arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1 = iNextColor&
Next iLoopY%
iNextColor& = cYellow&
iLoopZ% = 1
iLoopX% = iX% + 9
For iLoopY% = (iY% + 1) To (iY% + 7)
arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Wall
arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1 = iNextColor&
Next iLoopY%
End If
' -----------------------------------------------------------------------------
' DRAW A PYRAMID
If TRUE = TRUE Then
iX% = 2
iY% = 18
iZ% = 1
iPosX1% = iX%
iPosX2% = iX% + 10
iPosY1% = iY%
iPosY2% = iY% + 10
iNextColor& = cRed&
iColorScheme% = 1 ' 1 = Rainbow6 #1, 9 = Rainbow6 #2, etc.
bContinue = TRUE
Do
' PLOT NEXT LEVEL
For iLoopX% = iPosX1% To iPosX2%
For iLoopY% = iPosY1% To iPosY2%
arrMap(iLoopX%, iLoopY%, iZ%).Typ = c_iMapType_Wall
arrMap(iLoopX%, iLoopY%, iZ%).Color1 = iNextColor&
Next iLoopY%
Next iLoopX%
' MOVE UP A LEVEL
iPosX1% = iPosX1% + 1
iPosX2% = iPosX2% - 1
iPosY1% = iPosY1% + 1
iPosY2% = iPosY2% - 1
DoCycleColor iColorScheme%, iNextColor&
' 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
' START POSITION
iX% = m_iMapMaxX ' 30 ' RandomNumber(0, 32)
iY% = m_iMapMaxY ' 28 ' RandomNumber(0, 32)
iZ% = 1 ' 32
' LENGTH OF PIPES
iSegmentLength% = 4
iMaxLength% = 64
' START COLOR + DEFINE HOW COLOR CHANGES
iNextColor& = cRed&
iColorScheme% = 2 ' 0 = don't change, 2 = Rainbow18 #1, 10 = Rainbow18 #2, etc.
' INITIALIZE
bFirst = TRUE
iCount% = 0
iMove% = 0
bFinished = FALSE
Do
iNextX% = iX%
iNextY% = iY%
iNextZ% = iZ%
' CHANGE DIRECTION EVERY iSegmentLength% SPACES
iMove% = iMove% + 1
If iMove% > iSegmentLength% Then
iMove% = 0
' PICK A DIRECTION
If bFirst = TRUE Then
' MOVE UP FOR FIRST MOVE
iDirection% = c_iDir_Up
bFirst = FALSE
Else
' PICK A RANDOM DIRECTION
iDirection% = RandomNumber(c_iDir_Min, c_iDir_Max)
End If
End If
Select Case iDirection%
Case c_iDir_Down:
If iNextZ% > 0 Then
iNextZ% = iNextZ% - 1
End If
Case c_iDir_Up:
If iNextZ% < 32 Then
iNextZ% = iNextZ% + 1
End If
Case c_iDir_Left:
If iNextX% > 0 Then
iNextX% = iNextX% - 1
End If
Case c_iDir_Right:
If iNextX% < 32 Then
iNextX% = iNextX% + 1
End If
Case c_iDir_Back:
If iNextY% > 0 Then
iNextY% = iNextY% - 1
End If
Case Else: ' c_iDir_Forward
If iNextY% < 32 Then
iNextY% = iNextY% + 1
End If
End Select
' CHECK IF NEXT SPACE IS EMPTY
If arrMap(iNextX%, iNextY%, iNextZ%).Typ = c_iMapType_Empty Then
' SPACE IS EMPTY
' DRAW HERE
iCount% = iCount% + 1
iX% = iNextX%
iY% = iNextY%
iZ% = iNextZ%
' GET NEXT COLOR AND DRAW BLOCK
DoCycleColor iColorScheme%, iNextColor&
arrMap(iX%, iY%, iZ%).Typ = c_iMapType_Wall
arrMap(iX%, iY%, iZ%).Color1 = iNextColor&
' HAVE WE PLACED MAX # OF BLOCKS?
If iCount% > iMaxLength% Then
bFinished = TRUE
End If
Else
' SPACE IS OCCUPIED
' SEE IF WE HAVE ANY OPEN SPACES TO MOVE TO
iOpen% = 0
If iZ% > 0 Then
If arrMap(iX%, iY%, iZ% - 1).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iZ% < 32 Then
If arrMap(iX%, iY%, iZ% + 1).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iX% > 0 Then
If arrMap(iX% - 1, iY%, iZ%).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iX% < 32 Then
If arrMap(iX% + 1, iY%, iZ%).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iY% > 0 Then
If arrMap(iX%, iY% - 1, iZ%).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iY% < 32 Then
If arrMap(iX%, iY% + 1, iZ%).Typ = c_iMapType_Empty 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
' PLOT GRAPHICS TO SCREEN
DrawIsometricScreen arrMap()
Input "Type q to quit? ", in$
If LCase$(in$) = LCase$("q") Then
bQuit = TRUE
End If
Loop Until bQuit = TRUE
Screen 0
IsometricDemo1 = sResult
End Function ' IsometricDemo1
' /////////////////////////////////////////////////////////////////////////////
Function IsometricDemo2$
Dim RoutineName As String: RoutineName = "IsometricDemo2"
Dim sResult As String: sResult = ""
Dim arrMap(m_iMapMinX To m_iMapMaxX, m_iMapMinY To m_iMapMaxY, m_iMapMinZ To m_iMapMaxZ) As MapBlockType
Dim iX%
Dim iY%
Dim iZ%
Dim iNextX%
Dim iNextY%
Dim iNextZ%
Dim iPosX1%
Dim iPosX2%
Dim iPosY1%
Dim iPosY2%
Dim iLoopX%
Dim iLoopY%
Dim iLoopZ%
Dim iNextColor&
Dim iColorScheme%
Dim bContinue As Integer
Dim iDirection%
Dim bFinished As Integer
Dim iCount%
Dim iOpen%
Dim iMove%
Dim iSegmentLength%
Dim iMaxLength%
Dim bFirst As Integer
Dim bQuit As Integer
Dim in$
' INITIALIZE
'Screen _NewImage(1024, 720, 32) : _ScreenMove _Middle
Screen _NewImage(1280, 1024, 32)
' =============================================================================
' MAIN LOOP
bQuit = FALSE
Do
Cls
' -----------------------------------------------------------------------------
' INITIALIZE MAP TO EMPTY
ClearIsometricMap arrMap()
' -----------------------------------------------------------------------------
' DRAW FLOOR
'For iLoopZ% = m_iMapMinZ To m_iMapMaxZ Step 8
For iLoopZ% = m_iMapMinZ To m_iMapMinZ
For iLoopX% = m_iMapMinX To m_iMapMaxX
For iLoopY% = m_iMapMinY To m_iMapMaxY
arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Floor_Tiled
arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1 = cGray&
arrMap(iLoopX%, iLoopY%, iLoopZ%).Color2 = cLightGray&
Next iLoopY%
Next iLoopX%
Next iLoopZ%
' -----------------------------------------------------------------------------
' DRAW FRAME AROUND ENTIRE SPACE
For iLoopZ% = m_iMapMinZ + 1 To m_iMapMaxZ
arrMap(m_iMapMinX, m_iMapMinY, iLoopZ%).Typ = c_iMapType_Wall
arrMap(m_iMapMinX, m_iMapMinY, iLoopZ%).Color1 = cRed&
arrMap(m_iMapMaxX, m_iMapMinY, iLoopZ%).Typ = c_iMapType_Wall
arrMap(m_iMapMaxX, m_iMapMinY, iLoopZ%).Color1 = cBlue&
arrMap(m_iMapMinX, m_iMapMaxY, iLoopZ%).Typ = c_iMapType_Wall
arrMap(m_iMapMinX, m_iMapMaxY, iLoopZ%).Color1 = cGreen&
arrMap(m_iMapMaxX, m_iMapMaxY, iLoopZ%).Typ = c_iMapType_Wall
arrMap(m_iMapMaxX, m_iMapMaxY, iLoopZ%).Color1 = cYellow&
Next iLoopZ%
For iLoopX% = m_iMapMinX To m_iMapMaxX
arrMap(iLoopX%, m_iMapMinY, m_iMapMinZ + 1).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMinY, m_iMapMinZ + 1).Color1 = cOrange&
arrMap(iLoopX%, m_iMapMaxY, m_iMapMaxZ).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMaxY, m_iMapMaxZ).Color1 = cPurple&
arrMap(iLoopX%, m_iMapMaxY, m_iMapMinZ + 1).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMaxY, m_iMapMinZ + 1).Color1 = cLime&
arrMap(iLoopX%, m_iMapMinY, m_iMapMaxZ).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMinY, m_iMapMaxZ).Color1 = cCyan&
Next iLoopX%
For iLoopY% = m_iMapMinY To m_iMapMaxY
arrMap(m_iMapMinX, iLoopY%, m_iMapMinZ + 1).Typ = c_iMapType_Wall
arrMap(m_iMapMinX, iLoopY%, m_iMapMinZ + 1).Color1 = cDodgerBlue&
arrMap(m_iMapMinX, iLoopY%, m_iMapMaxZ).Typ = c_iMapType_Wall
arrMap(m_iMapMinX, iLoopY%, m_iMapMaxZ).Color1 = cDeepPurple&
arrMap(m_iMapMaxX, iLoopY%, m_iMapMinZ + 1).Typ = c_iMapType_Wall
arrMap(m_iMapMaxX, iLoopY%, m_iMapMinZ + 1).Color1 = cDarkRed&
arrMap(m_iMapMaxX, iLoopY%, m_iMapMaxZ).Typ = c_iMapType_Wall
arrMap(m_iMapMaxX, iLoopY%, m_iMapMaxZ).Color1 = cGold&
Next iLoopY%
' -----------------------------------------------------------------------------
' DRAW PIPES
If TRUE = TRUE Then
' START POSITION
iX% = m_iMapMidX ' 30 ' RandomNumber(0, 32)
iY% = m_iMapMidY ' 28 ' RandomNumber(0, 32)
iZ% = m_iMapMidZ ' 1 ' 32
' LENGTH OF PIPES
iSegmentLength% = 8
iMaxLength% = 512
' START COLOR + DEFINE HOW COLOR CHANGES
iNextColor& = cRed&
iColorScheme% = 3 ' 0 = don't change, 2 = Rainbow18 #1, 10 = Rainbow18 #2, etc.
' INITIALIZE
bFirst = TRUE
iCount% = 0
iMove% = 0
bFinished = FALSE
Do
iNextX% = iX%
iNextY% = iY%
iNextZ% = iZ%
' CHANGE DIRECTION EVERY iSegmentLength% SPACES
iMove% = iMove% + 1
If iMove% > iSegmentLength% Then
iMove% = 0
' PICK A DIRECTION
If bFirst = TRUE Then
' MOVE UP FOR FIRST MOVE
iDirection% = c_iDir_Up
bFirst = FALSE
Else
' PICK A RANDOM DIRECTION
iDirection% = RandomNumber(c_iDir_Min, c_iDir_Max)
End If
End If
Select Case iDirection%
Case c_iDir_Down:
If iNextZ% > 0 Then
iNextZ% = iNextZ% - 1
End If
Case c_iDir_Up:
If iNextZ% < 32 Then
iNextZ% = iNextZ% + 1
End If
Case c_iDir_Left:
If iNextX% > 0 Then
iNextX% = iNextX% - 1
End If
Case c_iDir_Right:
If iNextX% < 32 Then
iNextX% = iNextX% + 1
End If
Case c_iDir_Back:
If iNextY% > 0 Then
iNextY% = iNextY% - 1
End If
Case Else: ' c_iDir_Forward
If iNextY% < 32 Then
iNextY% = iNextY% + 1
End If
End Select
' CHECK IF NEXT SPACE IS EMPTY
If arrMap(iNextX%, iNextY%, iNextZ%).Typ = c_iMapType_Empty Then
' SPACE IS EMPTY
' DRAW HERE
iCount% = iCount% + 1
iX% = iNextX%
iY% = iNextY%
iZ% = iNextZ%
' GET NEXT COLOR AND DRAW BLOCK
DoCycleColor iColorScheme%, iNextColor&
arrMap(iX%, iY%, iZ%).Typ = c_iMapType_Wall
arrMap(iX%, iY%, iZ%).Color1 = iNextColor&
' HAVE WE PLACED MAX # OF BLOCKS?
If iCount% > iMaxLength% Then
bFinished = TRUE
End If
Else
' SPACE IS OCCUPIED
' SEE IF WE HAVE ANY OPEN SPACES TO MOVE TO
iOpen% = 0
If iZ% > 0 Then
If arrMap(iX%, iY%, iZ% - 1).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iZ% < 32 Then
If arrMap(iX%, iY%, iZ% + 1).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iX% > 0 Then
If arrMap(iX% - 1, iY%, iZ%).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iX% < 32 Then
If arrMap(iX% + 1, iY%, iZ%).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iY% > 0 Then
If arrMap(iX%, iY% - 1, iZ%).Typ = c_iMapType_Empty Then
iOpen% = iOpen% + 1
End If
End If
If iY% < 32 Then
If arrMap(iX%, iY% + 1, iZ%).Typ = c_iMapType_Empty 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
' PLOT GRAPHICS TO SCREEN
DrawIsometricScreen arrMap()
Input "Type q to quit? ", in$
If LCase$(in$) = LCase$("q") Then
bQuit = TRUE
End If
Loop Until bQuit = TRUE
Screen 0
IsometricDemo2 = sResult
End Function ' IsometricDemo2
' /////////////////////////////////////////////////////////////////////////////
Function IsometricDemo3$
Dim RoutineName As String: RoutineName = "IsometricDemo3"
Dim sResult As String: sResult = ""
Dim arrMap(m_iMapMinX To m_iMapMaxX, m_iMapMinY To m_iMapMaxY, m_iMapMinZ To m_iMapMaxZ) As MapBlockType
Dim iX%
Dim iY%
Dim iZ%
Dim iNewX%
Dim iNewY%
Dim iNewZ%
Dim iMyColor&
Dim iColorScheme%
Dim iDirection% ' direction player's nose is pointing
Dim bFound As Integer
Dim bDone As Integer
Dim in$
Dim iTotal% ' compute total available spaces
Dim iCount% ' count # of spaces searched
Dim bMoving As Integer
Dim iLastKey As Integer
Dim bMoved As Integer
Dim iPosX1%
Dim iPosX2%
Dim iPosY1%
Dim iPosY2%
Dim iNextColor&
Dim bContinue As Integer
Dim iLoopX%
Dim iLoopY%
Dim iLoopZ%
Dim iLevelCount%
Dim iLevelSize%
Dim iDrawX%
Dim iDrawY%
' =============================================================================
' INITIALIZE
'Screen _NewImage(1024, 720, 32) : _ScreenMove _Middle
Screen _NewImage(1280, 1024, 32)
' -----------------------------------------------------------------------------
' INITIALIZE MAP TO EMPTY
ClearIsometricMap arrMap()
' -----------------------------------------------------------------------------
' DRAW FLOOR
For iLoopZ% = m_iMapMinZ To m_iMapMinZ
For iLoopX% = m_iMapMinX To m_iMapMaxX
For iLoopY% = m_iMapMinY To m_iMapMaxY
arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Floor_Tiled
arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1 = cGray&
arrMap(iLoopX%, iLoopY%, iLoopZ%).Color2 = cLightGray&
Next iLoopY%
Next iLoopX%
Next iLoopZ%
' -----------------------------------------------------------------------------
' DRAW A TALL HOLLOW PYRAMID
If TRUE = TRUE Then
iX% = 5
iY% = 10
iZ% = 1
iLevelSize% = 4
iPosX1% = iX%
iPosX2% = iX% + 7
iPosY1% = iY%
iPosY2% = iY% + 7
iNextColor& = cRed&
iColorScheme% = 1 ' 1 = Rainbow6 #1, 9 = Rainbow6 #2, etc.
iLevelCount% = 0
bContinue = TRUE
Do
' PLOT NEXT LEVEL
'For iLoopX% = iPosX1% To iPosX2%
' For iLoopY% = iPosY1% To iPosY2%
' arrMap(iLoopX%, iLoopY%, iZ%).Typ = c_iMapType_Wall
' arrMap(iLoopX%, iLoopY%, iZ%).Color1 = iNextColor&
' Next iLoopY%
'Next iLoopX%
' Draw front/back walls
For iLoopX% = iPosX1% To iPosX2%
iLoopY% = iPosY1%
arrMap(iLoopX%, iLoopY%, iZ%).Typ = c_iMapType_Wall
arrMap(iLoopX%, iLoopY%, iZ%).Color1 = iNextColor&
arrMap(iLoopX%, iLoopY%, iZ%).AlphaOverride = 255
iLoopY% = iPosY2%
arrMap(iLoopX%, iLoopY%, iZ%).Typ = c_iMapType_Wall
arrMap(iLoopX%, iLoopY%, iZ%).Color1 = iNextColor&
arrMap(iLoopX%, iLoopY%, iZ%).AlphaOverride = 255
Next iLoopX%
' Draw left/right walls
For iLoopY% = iPosY1% To iPosY2%
iLoopX% = iPosX1%
arrMap(iLoopX%, iLoopY%, iZ%).Typ = c_iMapType_Wall
arrMap(iLoopX%, iLoopY%, iZ%).Color1 = iNextColor&
arrMap(iLoopX%, iLoopY%, iZ%).AlphaOverride = 255
iLoopX% = iPosX2%
arrMap(iLoopX%, iLoopY%, iZ%).Typ = c_iMapType_Wall
arrMap(iLoopX%, iLoopY%, iZ%).Color1 = iNextColor&
arrMap(iLoopX%, iLoopY%, iZ%).AlphaOverride = 255
Next iLoopY%
' Add a door to middle of right wall
iX% = iPosX1% + ((iPosX2% - iPosX1%) \ 2)
arrMap(iX%, iPosY2%, iZ%).Typ = c_iMapType_Empty
' Add a door to middle of front wall
iY% = iPosY1% + ((iPosY2% - iPosY1%) \ 2)
arrMap(iPosX2%, iY%, iZ%).Typ = c_iMapType_Empty
' MOVE UP A LEVEL
iLevelCount% = iLevelCount% + 1
If iLevelCount% > iLevelSize% Then
iLevelCount% = 0
iPosX1% = iPosX1% + 1
iPosX2% = iPosX2% - 1
iPosY1% = iPosY1% + 1
iPosY2% = iPosY2% - 1
End If
' QUIT AFTER WE REACH THE TOP
If (iPosX1% <= iPosX2%) And (iPosY1% <= iPosY2%) Then
iZ% = iZ% + 1
DoCycleColor iColorScheme%, iNextColor&
If iZ% > m_iMapMaxZ Then
bContinue = FALSE
End If
Else
bContinue = FALSE
End If
Loop Until bContinue = FALSE
End If
' -----------------------------------------------------------------------------
' DRAW FRAME AROUND ENTIRE SPACE (TOP)
For iLoopX% = m_iMapMinX + 3 To m_iMapMaxX - 3
arrMap(iLoopX%, m_iMapMaxY - 3, m_iMapMaxZ).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMaxY - 3, m_iMapMaxZ).Color1 = cPurple&
arrMap(iLoopX%, m_iMapMinY + 3, m_iMapMaxZ).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMinY + 3, m_iMapMaxZ).Color1 = cCyan&
Next iLoopX%
For iLoopY% = m_iMapMinY + 3 To m_iMapMaxY - 3
arrMap(m_iMapMinX + 3, iLoopY%, m_iMapMaxZ).Typ = c_iMapType_Wall
arrMap(m_iMapMinX + 3, iLoopY%, m_iMapMaxZ).Color1 = cOrange&
arrMap(m_iMapMaxX - 3, iLoopY%, m_iMapMaxZ).Typ = c_iMapType_Wall
arrMap(m_iMapMaxX - 3, iLoopY%, m_iMapMaxZ).Color1 = cLime&
Next iLoopY%
' -----------------------------------------------------------------------------
' DRAW FRAME AROUND ENTIRE SPACE (MIDDLE)
For iLoopX% = m_iMapMinX + 2 To m_iMapMaxX - 2
arrMap(iLoopX%, m_iMapMaxY - 2, m_iMapMidZ).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMaxY - 2, m_iMapMidZ).Color1 = cDodgerBlue&
arrMap(iLoopX%, m_iMapMinY + 2, m_iMapMidZ).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMinY + 2, m_iMapMidZ).Color1 = cDeepPurple&
Next iLoopX%
For iLoopY% = m_iMapMinY + 2 To m_iMapMaxY - 2
arrMap(m_iMapMinX + 2, iLoopY%, m_iMapMidZ).Typ = c_iMapType_Wall
arrMap(m_iMapMinX + 2, iLoopY%, m_iMapMidZ).Color1 = cDarkRed&
arrMap(m_iMapMaxX - 2, iLoopY%, m_iMapMidZ).Typ = c_iMapType_Wall
arrMap(m_iMapMaxX - 2, iLoopY%, m_iMapMidZ).Color1 = cGold&
Next iLoopY%
' -----------------------------------------------------------------------------
' DRAW FRAME AROUND ENTIRE SPACE (BOTTOM)
For iLoopX% = m_iMapMinX + 1 To m_iMapMaxX - 1
arrMap(iLoopX%, m_iMapMaxY - 1, m_iMapMinZ + 1).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMaxY - 1, m_iMapMinZ + 1).Color1 = cSeaBlue&
arrMap(iLoopX%, m_iMapMinY + 1, m_iMapMinZ + 1).Typ = c_iMapType_Wall
arrMap(iLoopX%, m_iMapMinY + 1, m_iMapMinZ + 1).Color1 = cChartreuse&
Next iLoopX%
For iLoopY% = m_iMapMinY + 1 To m_iMapMaxY - 1
arrMap(m_iMapMinX + 1, iLoopY%, m_iMapMinZ + 1).Typ = c_iMapType_Wall
arrMap(m_iMapMinX + 1, iLoopY%, m_iMapMinZ + 1).Color1 = cOrangeRed&
arrMap(m_iMapMaxX - 1, iLoopY%, m_iMapMinZ + 1).Typ = c_iMapType_Wall
arrMap(m_iMapMaxX - 1, iLoopY%, m_iMapMinZ + 1).Color1 = cDeepSkyBlue&
Next iLoopY%
' -----------------------------------------------------------------------------
' FIND START POSITION
iX% = RandomNumber(m_iMapMinX, m_iMapMaxX)
iY% = RandomNumber(m_iMapMinY, m_iMapMaxY)
iZ% = 1 ' RandomNumber(m_iMapMinZ, m_iMapMaxZ)
' MAKE SURE IT'S EMPTY
If arrMap(iX%, iY%, iZ%).Typ = c_iMapType_Empty Then
bFound = TRUE
Else
' IF NOT EMPTY THEN TRY TO FIND AN EMPTY SPOT
iTotal% = ((m_iMapMaxX - m_iMapMinX) + 1) * ((m_iMapMaxY - m_iMapMinY) + 1) * ((m_iMapMaxZ - m_iMapMinZ) + 1)
iCount% = 0
bFound = FALSE
Do
iX% = iX% + 1
If iX% > m_iMapMaxX Then
' reset x and move to next y
iX% = m_iMapMinX
iY% = iY% + 1
If iY% > m_iMapMaxY Then
' reset y and move to next z
iY% = m_iMapMinY
iZ% = iZ% + 1
If iZ% > m_iMapMaxZ Then
' RESET Z AND SEE IF WE HAVE CHECKED EVERYTHING
iZ% = m_iMapMinZ
iCount% = iCount% + 1
If iCount% >= iTotal% Then
' NONE FOUND, EXIT
Exit Do
End If
Else
iCount% = iCount% + 1
End If
Else
iCount% = iCount% + 1
End If
Else
iCount% = iCount% + 1
End If
If arrMap(iX%, iY%, iZ%).Typ = c_iMapType_Empty Then
' FOUND AN EMPTY SPACE, EXIT
bFound = TRUE
Exit Do
End If
Loop
End If
If bFound = TRUE Then
' PLACE PLAYER
iMyColor& = cRed&
iColorScheme% = 2
' PICK A DIRECTION (SIMPLE FOR NOW, LEFT OR RIGHT)
If iX% <= m_iMapMidX Then
iDirection% = c_iDir_Right
Else
iDirection% = c_iDir_Left
End If
' RESET MOVEMENT VARIABLES
bMoving = FALSE
bMoved = FALSE
' RESET INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
iLastKey = c_iKeyDown_Enter
' DRAW PLAYER
arrMap(iX%, iY%, iZ%).Typ = c_iMapType_Player1 ' c_iMapType_Wall
arrMap(iX%, iY%, iZ%).Color1 = iMyColor&
arrMap(iX%, iY%, iZ%).AlphaOverride = 255
' =============================================================================
' MAIN LOOP
bFinished = FALSE
Do
' PLOT GRAPHICS TO SCREEN
Cls ' is cls necessary?
ComputeVisible arrMap(), iX%, iY%, iZ%
DrawIsometricScreen arrMap()
' SHOW INSTRUCTIONS / COORDINATES ON SCREEN
Locate 1, 1: Print "IsometricDemo3"
Locate 3, 1: Print "CRSR RIGHT/LEFT MOVES X=" + cstr$(iX%)
Locate 4, 1: Print "CRSR UP /DOWN MOVES Y=" + cstr$(iY%)
Locate 5, 1: Print "PAGE UP /DOWN MOVES Z=" + cstr$(iZ%)
Locate 7, 1: Print "SPACE TOGGLES CONTINUOUS MOVEMENT"
Locate 9, 1: Print "PRESS <ESC> TO QUIT"
' SHOW 2D MINI MAP ON SCREEN
For iLoopX% = m_iMapMinX To m_iMapMaxX
For iLoopY% = m_iMapMinY To m_iMapMaxY
iDrawX% = (iLoopX% * 4) + 20
iDrawY% = (iLoopY% * 4) + 200
If arrMap(iLoopX%, iLoopY%, iZ%).Typ = c_iMapType_Wall Then
DrawBox iDrawX%, iDrawY%, 4, arrMap(iLoopX%, iLoopY%, iZ%).Color1
ElseIf arrMap(iLoopX%, iLoopY%, iZ%).Typ = c_iMapType_Player1 Then
DrawBox iDrawX%, iDrawY%, 4, arrMap(iLoopX%, iLoopY%, iZ%).Color1
Else
DrawBox iDrawX%, iDrawY%, 4, cBlack&
End If
Next iLoopY%
Next iLoopX%
' GET KEYBOARD INPUT
If _KeyDown(c_iKeyDown_Up) Then
If iLastKey <> c_iKeyDown_Up Then
iLastKey = c_iKeyDown_Up
iDirection% = c_iDir_Back
bMoved = TRUE
End If
ElseIf _KeyDown(c_iKeyDown_Down) Then
If iLastKey <> c_iKeyDown_Down Then
iLastKey = c_iKeyDown_Down
iDirection% = c_iDir_Forward
bMoved = TRUE
End If
ElseIf _KeyDown(c_iKeyDown_Left) Then
If iLastKey <> c_iKeyDown_Left Then
iLastKey = c_iKeyDown_Left
iDirection% = c_iDir_Left
bMoved = TRUE
End If
ElseIf _KeyDown(c_iKeyDown_Right) Then
If iLastKey <> c_iKeyDown_Right Then
iLastKey = c_iKeyDown_Right
iDirection% = c_iDir_Right
bMoved = TRUE
End If
ElseIf _KeyDown(c_iKeyDown_PgUp) Then
If iLastKey <> c_iKeyDown_PgUp Then
iLastKey = c_iKeyDown_PgUp
iDirection% = c_iDir_Up
bMoved = TRUE
End If
ElseIf _KeyDown(c_iKeyDown_PgDn) Then
If iLastKey <> c_iKeyDown_PgDn Then
iLastKey = c_iKeyDown_PgDn
iDirection% = c_iDir_Down
bMoved = TRUE
End If
ElseIf _KeyDown(c_iKeyDown_Spacebar) Then
If iLastKey <> c_iKeyDown_Spacebar Then
iLastKey = c_iKeyDown_Spacebar
'bMoving = IIF(bMoving, False, True)
If bMoving = TRUE Then
bMoving = FALSE
Else
bMoving = TRUE
End If
End If
ElseIf _KeyDown(c_iKeyDown_Esc) Then
Exit Do
Else
iLastKey = -1
End If
' --------------------------------------------------------------------------------
' ERASE OLD POSITION
' --------------------------------------------------------------------------------
arrMap(iX%, iY%, iZ%).Typ = c_iMapType_Empty
arrMap(iX%, iY%, iZ%).Color1 = cEmpty&
arrMap(iX%, iY%, iZ%).AlphaOverride = 255
' --------------------------------------------------------------------------------
' MOVE PLAYER BASED ON DIRECTION
' --------------------------------------------------------------------------------
'IF bMoved=TRUE THEN
If bMoving = TRUE Or bMoved = TRUE Then
bMoved = FALSE
Select Case iDirection%
Case c_iDir_Down:
iNewX% = iX%
iNewY% = iY%
iNewZ% = iZ% - 1
If iNewZ% < m_iMapMinZ Then
iNewZ% = m_iMapMaxZ
End If
If arrMap(iNewX%, iNewY%, iNewZ%).Typ <> c_iMapType_Empty Then
iDirection% = c_iDir_Up
iNewZ% = iZ%
End If
Case c_iDir_Up:
iNewX% = iX%
iNewY% = iY%
iNewZ% = iZ% + 1
If iNewZ% > m_iMapMaxZ Then
iNewZ% = m_iMapMinZ
End If
If arrMap(iNewX%, iNewY%, iNewZ%).Typ <> c_iMapType_Empty Then
iDirection% = c_iDir_Down
iNewZ% = iZ%
End If
Case c_iDir_Left:
iNewX% = iX% - 1
iNewY% = iY%
iNewZ% = iZ%
If iNewX% < m_iMapMinX Then
iNewX% = m_iMapMaxX
End If
If arrMap(iNewX%, iNewY%, iNewZ%).Typ <> c_iMapType_Empty Then
iDirection% = c_iDir_Right
iNewX% = iX%
End If
Case c_iDir_Right:
iNewX% = iX% + 1
iNewY% = iY%
iNewZ% = iZ%
If iNewX% > m_iMapMaxX Then
iNewX% = m_iMapMinX
End If
If arrMap(iNewX%, iNewY%, iNewZ%).Typ <> c_iMapType_Empty Then
iDirection% = c_iDir_Left
iNewX% = iX%
End If
Case c_iDir_Back:
iNewX% = iX%
iNewY% = iY% - 1
iNewZ% = iZ%
If iNewY% < m_iMapMinY Then
iNewY% = m_iMapMaxY
End If
If arrMap(iNewX%, iNewY%, iNewZ%).Typ <> c_iMapType_Empty Then
iDirection% = c_iDir_Forward
iNewY% = iY%
End If
Case c_iDir_Forward:
iNewX% = iX%
iNewY% = iY% + 1
iNewZ% = iZ%
If iNewY% > m_iMapMaxY Then
iNewY% = m_iMapMinY
End If
If arrMap(iNewX%, iNewY%, iNewZ%).Typ <> c_iMapType_Empty Then
iDirection% = c_iDir_Back
iNewY% = iY%
End If
Case Else:
'iNewX% = iX%
'iNewY% = iY%
'iNewZ% = iZ%
End Select
' SAVE NEW POSITION
iX% = iNewX%
iY% = iNewY%
iZ% = iNewZ%
End If
' REDRAW AT CURRENT POSITION
DoCycleColor iColorScheme%, iMyColor&
arrMap(iX%, iY%, iZ%).Typ = c_iMapType_Player1 ' c_iMapType_Wall
arrMap(iX%, iY%, iZ%).Color1 = iMyColor&
arrMap(iX%, iY%, iZ%).AlphaOverride = 255
_Limit 30
_Display
Loop
Else
sResult = "Could not find an empty space to start player."
End If
' FINISH UP AND EXIT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
Screen 0
IsometricDemo3$ = sResult
End Function ' IsometricDemo3
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GRAPHICS FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' =============================================================================
' LET'S GET THE COORDINATES STRAIGHT!
' Coordinates are arrMap(x,y,z)
' ________________
' /|e /|e
' / | / |
' / | / |z-axis
' / | / |
' / /---------/----/
' / / a / b/
' / / / /
' |--------------| /
' |f / g| / y-axis
' | / | /
' | / | /
' |/c d|/
' ----------------
' x-axis
'
' POINT ( X, Y, Z)
' a ( 0, 0, 0)
' b (32, 0, 0)
' c ( 0,32, 0)
' d (32,32, 0)
' e ( 0, 0,32)
' f ( 0,32,32)
' g (32,32,32)
' =============================================================================
' /////////////////////////////////////////////////////////////////////////////
' INITIALIZE MAP TO EMPTY
'ClearIsometricMap arrMap()
Sub ClearIsometricMap (arrMap( m_iMapMinX To m_iMapMaxX , m_iMapMinY To m_iMapMaxY , m_iMapMinZ To m_iMapMaxZ) As MapBlockType)
Dim RoutineName As String: RoutineName = "ClearIsometricMap"
Dim iLoopX%
Dim iLoopY%
Dim iLoopZ%
For iLoopZ% = m_iMapMinZ To m_iMapMaxZ
For iLoopX% = m_iMapMinX To m_iMapMaxX
For iLoopY% = m_iMapMinY To m_iMapMaxY
arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Empty
arrMap(iLoopX%, iLoopY%, iLoopZ%).AlphaOverride = 255
Next iLoopY%
Next iLoopX%
Next iLoopZ%
End Sub ' ClearIsometricMap
' /////////////////////////////////////////////////////////////////////////////
' Determine which squares are visible in isometric map
' arrMap(x,y,z) = 3D array map of world
' iX% = player's X positon
' iY% = player's Y position
' iZ% = player's Z position
Sub ComputeVisible (arrMap( m_iMapMinX To m_iMapMaxX , m_iMapMinY To m_iMapMaxY , m_iMapMinZ To m_iMapMaxZ) As MapBlockType, iX%, iY%, iZ%)
Dim iLoopX%
Dim iLoopY%
Dim iLoopZ%
Dim iPX1%
Dim iPY1%
Dim iPZ1%
Dim iPlayer2Dx As Integer
Dim iPlayer2Dy As Integer
Dim iBrick2Dx As Integer
Dim iBrick2Dy As Integer
' CALCULATE PLAYER'S 2-D POSITION
iPX1% = iX% * m_iGridSize + cGridOffsetX
iPY1% = iY% * m_iGridSize + cGridOffsetY
iPZ1% = iZ% * m_iGridSize + cGridOffsetZ
iPlayer2Dx = CX2I(iPX1%, iPY1%) + cScreenOffsetX
iPlayer2Dy = (CY2I(iPX1%, iPY1%) + cScreenOffsetY) - iPZ1%
'fquad TempX1, TempY1 - z, TempX2, TempY2 - z, TempX3, TempY3 - z, TempX4, TempY4 - z, _RGB32(r, g, b, alpha&)
For iLoopX% = m_iMapMinX To m_iMapMaxX
For iLoopY% = m_iMapMinY To m_iMapMaxY
For iLoopZ% = m_iMapMinZ To m_iMapMaxZ
' If space has a brick
' and its 2D (X,Y) is > Player's 2D (X,Y)
' then make the brick transparent
If arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Wall Then
' CALCULATE BRICK'S 2-D POSITION
iPX1% = iLoopX% * m_iGridSize + cGridOffsetX
iPY1% = iLoopY% * m_iGridSize + cGridOffsetY
iPZ1% = iLoopZ% * m_iGridSize + cGridOffsetZ
iBrick2Dx = CX2I(iPX1%, iPY1%) + cScreenOffsetX
iBrick2Dy = (CY2I(iPX1%, iPY1%) + cScreenOffsetY) - iPZ1%
'fquad TempX1, TempY1 - z, TempX2, TempY2 - z, TempX3, TempY3 - z, TempX4, TempY4 - z, _RGB32(r, g, b, alpha&)
'If iLoopZ% >= iZ% Then
'If iLoopX% >= iX% Then
If iLoopY% > iY% Then
If (iPlayer2Dy >= (iBrick2Dy - m_iGridSize)) And (iPlayer2Dy <= (iBrick2Dy + m_iGridSize)) Then
If (iPlayer2Dx >= (iBrick2Dx - m_iGridSize)) And (iPlayer2Dx <= (iBrick2Dx + m_iGridSize)) Then
arrMap(iLoopX%, iLoopY%, iLoopZ%).AlphaOverride = 86
Else
arrMap(iLoopX%, iLoopY%, iLoopZ%).AlphaOverride = 255
End If
Else
arrMap(iLoopX%, iLoopY%, iLoopZ%).AlphaOverride = 255
End If
End If
'End If
'End If
Else
arrMap(iLoopX%, iLoopY%, iLoopZ%).AlphaOverride = 255
End If
Next iLoopZ%
Next iLoopY%
Next iLoopX%
End Sub ' ComputeVisible
' /////////////////////////////////////////////////////////////////////////////
' Draw the map in 3D Isometic Perspective
' Parameters:
' arrMap(x,y,z) = 3D array map of world
' iX% = player's X positon
' iY% = player's Y position
' iZ% = player's Z position
'DrawIsometricScreen arrMap()
Sub DrawIsometricScreen (arrMap( m_iMapMinX To m_iMapMaxX , m_iMapMinY To m_iMapMaxY , m_iMapMinZ To m_iMapMaxZ) As MapBlockType)
Dim RoutineName As String: RoutineName = "DrawIsometricScreen"
Dim bTile As Integer
Dim iLoopX%
Dim iLoopY%
Dim iLoopZ%
Dim iColor As _Unsigned Long
Dim iPosX1%
Dim iPosX2%
Dim iPosY1%
Dim iPosY2%
Dim iPosZ1%
Dim alpha&
alpha& = 255
bTile = FALSE
For iLoopZ% = m_iMapMinZ To m_iMapMaxZ
For iLoopX% = m_iMapMinX To m_iMapMaxX
For iLoopY% = m_iMapMinY To m_iMapMaxY
' CALCULATE POSITION
iPosZ1% = iLoopZ% * m_iGridSize + cGridOffsetZ
iPosX1% = iLoopX% * m_iGridSize + cGridOffsetX
iPosY1% = iLoopY% * m_iGridSize + cGridOffsetY
iPosX2% = iPosX1% + m_iGridSize
iPosY2% = iPosY1% + m_iGridSize
' DETERMINE COLOR
If arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Floor_Tiled Then
If bTile = TRUE Then
iColor = arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1
bTile = FALSE
Else
iColor = arrMap(iLoopX%, iLoopY%, iLoopZ%).Color2
bTile = TRUE
End If
ElseIf arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Wall Then
iColor = arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1
alpha& = arrMap(iLoopX%, iLoopY%, iLoopZ%).AlphaOverride
ElseIf arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Player1 Then
iColor = arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1
alpha& = 255
ElseIf arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Player2 Then
iColor = arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1
alpha& = 255
ElseIf arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Water Then
'TODO: transparent for water
iColor = cEmpty&
alpha& = 64
ElseIf arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ = c_iMapType_Window Then
'TODO: transparent for windows
iColor = cEmpty&
alpha& = 64
Else
iColor = cEmpty&
End If
' PLOT NEXT BLOCK
If iColor <> cEmpty& Then
'IsoLine3D(x, y, x2, y2, z, iHeight, xoffset, yoffset, iColor As _Unsigned Long, alpha&)
IsoLine3D iPosX1%, iPosY1%, iPosX2%, iPosY2%, iPosZ1%, m_iGridSize, cScreenOffsetX, cScreenOffsetY, iColor, alpha&
End If
Next iLoopY%
Next iLoopX%
Next iLoopZ%
End Sub ' DrawIsometricScreen
' /////////////////////////////////////////////////////////////////////////////
' RETURNS MAP AS TEXT
'Input "See a text dump (y/n)? ", in$
'If LCase$(in$) = LCase$("y") Then
' Print MapToText$( arrMap() )
'End If
Function MapToText$ (arrMap( m_iMapMinX To m_iMapMaxX , m_iMapMinY To m_iMapMaxY , m_iMapMinZ To m_iMapMaxZ) As MapBlockType)
Dim RoutineName As String: RoutineName = "MapToText$"
Dim sResult As String
Dim iLoopX%
Dim iLoopY%
Dim iLoopZ%
Dim iMinX%
Dim iMaxX%
Dim iMinY%
Dim iMaxY%
Dim iMinZ%
Dim iMaxZ%
Dim sLine As String
Dim iType%
Dim iColor1&
Dim iColor2&
Dim iColor3&
Dim in$
sResult = ""
' FIND USED BOUNDARIES OF MAP
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
iType% = arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ
If iType% <> c_iMapType_Empty And iType% <> c_iMapType_Floor_Tiled 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%
' GENERATE OUTPUT
For iLoopZ% = iMinZ% To iMaxZ%
sResult = sResult + "-------------------------------------------------------------------------------" + Chr$(13)
sResult = sResult + "Map Z=" + cstr$(iLoopZ%) + ":" + Chr$(13)
sResult = sResult + "-------------------------------------------------------------------------------" + Chr$(13)
For iLoopY% = iMinY% To iMaxY%
sLine = ""
For iLoopX% = iMinX% To iMaxX%
iType% = arrMap(iLoopX%, iLoopY%, iLoopZ%).Typ
iColor1& = arrMap(iLoopX%, iLoopY%, iLoopZ%).Color1
iColor2& = arrMap(iLoopX%, iLoopY%, iLoopZ%).Color2
iColor3& = arrMap(iLoopX%, iLoopY%, iLoopZ%).Color3
If iType% = c_iMapType_Empty Then
sLine = sLine + " "
Else
If iColor1& = cEmpty& Then
sLine = sLine + " "
Else
sLine = sLine + "#"
End If
End If
Next iLoopX%
sResult = sResult + sLine + Chr$(13)
Next iLoopY%
sResult = sResult + Chr$(13)
Next iLoopZ%
MapToText$ = sResult
End Function ' MapToText$
' /////////////////////////////////////////////////////////////////////////////
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
' MODIFIED by madscijr to accept an alpha& value to control transparency (where 0=fully transparent, 255=opaque)
''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)
Sub IsoLine3D (x, y, x2, y2, z, iHeight, xoffset, yoffset, iColor As _Unsigned Long, alpha&)
Dim r As Integer
Dim g As Integer
Dim b As Integer
'dim iNewColor 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
fquad TempX1, TempY1 - z, TempX2, TempY2 - z, TempX3, TempY3 - z, TempX4, TempY4 - z, _RGB32(r, g, b, alpha&)
If z <> 0 Then
' TODO: maybe change which sides gets shaded depending on the direction of the light source?
' draw the left side, shaded 75%
'fquad TempX4, TempY4 - z, TempX4, TempY4 - z + iHeight, TempX3, TempY3 - z + iHeight, TempX3, TempY3 - z, _RGB32(.75 * r, .75 * g, .75 * b)
fquad TempX4, TempY4 - z, TempX4, TempY4 - z + iHeight, TempX3, TempY3 - z + iHeight, TempX3, TempY3 - z, _RGB32(.75 * r, .75 * g, .75 * b, alpha&)
' draw the right side,s haded 50%
'fquad TempX3, TempY3 - z, TempX3, TempY3 - z + iHeight, TempX2, TempY2 - z + iHeight, TempX2, TempY2 - z, _RGB32(.5 * r, .5 * g, .5 * b)
fquad TempX3, TempY3 - z, TempX3, TempY3 - z + iHeight, TempX2, TempY2 - z + iHeight, TempX2, TempY2 - z, _RGB32(.5 * r, .5 * g, .5 * b, alpha&)
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
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D BOX
'SUB DrawBox (iX%, iY%, iSize%, iColor%)
Sub DrawBox (iX%, iY%, iSize%, iColor&)
Line (iX%, iY%)-(iX% + iSize%, iY% + iSize%), iColor&, BF ' Draw a solid box
'LINE (iX%, iY%)-(iX% + iSize%, iY% + iSize%), iColor%, BF ' Draw a solid box
'LINE (60, 60)-(130, 100), iColor%, B ' Draw a box outline
End Sub ' DrawBox
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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 ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Receives:
' cycleColor = determines how foreColor, backColor are modified
' foreColor = the foreground color
' backColor = the background color (if needed)
' /////////////////////////////////////////////////////////////////////////////
' DoCycleColor colorScheme%, myColor&
' colorScheme = color scheme (value is alternated on subsequent calls)
' myColor = the current color (value is incremented/decremented on subsequent calls)
' colorScheme values:
' 1 Rainbow6 #1
' 9 Rainbow6 #2
' 2 Rainbow18 #1
' 10 Rainbow18 #2
' 3 Grayscale #1
' 11 Grayscale #2
' 4 Grayscale #1
' 12 Grayscale #2
Sub DoCycleColor (colorScheme As Integer, myColor As Long)
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CYCLE FORE COLOR
' 1, 5, 9 = simple rainbow
If colorScheme = 1 Or colorScheme = 9 Then
Select Case myColor
Case cRed&:
myColor = cOrange&
Case cOrange&:
myColor = cYellow&
Case cYellow&:
myColor = cGreen&
Case cGreen&:
myColor = cBlue&
Case cBlue&:
myColor = cPurple&
Case Else:
myColor = cRed&
End Select
' 2, 6, 10 = complex rainbow
ElseIf colorScheme = 2 Or colorScheme = 10 Then
Select Case myColor
Case cRed&:
myColor = cOrangeRed&
Case cOrangeRed&:
myColor = cDarkOrange&
Case cDarkOrange&:
myColor = cOrange&
Case cOrange&:
myColor = cGold&
Case cGold&:
myColor = cYellow&
Case cYellow&:
myColor = cChartreuse&
Case cChartreuse&:
myColor = cLime&
Case cLime&:
myColor = cMediumSpringGreen&
Case cMediumSpringGreen&:
myColor = cCyan&
Case cCyan&:
myColor = cDeepSkyBlue&
Case cDeepSkyBlue&:
myColor = cDodgerBlue&
Case cDodgerBlue&:
myColor = cSeaBlue&
Case cSeaBlue&:
myColor = cBlue&
Case cBlue&:
myColor = cBluePurple&
Case cBluePurple&:
myColor = cDeepPurple&
Case cDeepPurple&:
myColor = cPurple&
Case cPurple&:
myColor = cPurpleRed&
Case Else:
myColor = cRed&
End Select
' 3, 7, 11 = grayscale, ascending
ElseIf colorScheme = 3 Or colorScheme = 11 Then
Select Case myColor
Case cBlack&:
myColor = cDarkGray&
Case cDarkGray&:
myColor = cDimGray&
Case cDimGray&:
myColor = cGray&
Case cGray&:
myColor = cLightGray&
Case cLightGray&:
myColor = cSilver&
Case cSilver&:
myColor = cWhite&
Case Else:
'myColor = cBlack&
myColor = cSilver&
' go in the other direction!
If colorScheme = 3 Then
colorScheme = 4
Else
colorScheme = 12
End If
End Select
' 4, 8, 12 = grayscale, descending
ElseIf colorScheme = 4 Or colorScheme = 12 Then
Select Case myColor
Case cWhite&:
myColor = cSilver&
Case cSilver&:
myColor = cLightGray&
Case cLightGray&:
myColor = cGray&
Case cGray&:
myColor = cDimGray&
Case cDimGray&:
myColor = cDarkGray&
Case cDarkGray&:
myColor = cBlack&
Case Else:
myColor = cDarkGray&
' go in the other direction!
If colorScheme = 4 Then
colorScheme = 3
Else
colorScheme = 11
End If
End Select
End If
End Sub ' DoCycleColor
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR ROUTINES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

QB64.org Forum

Active Forums => QB64 Discussion => Topic started by: madscijr on December 02, 2021, 10:40:31 am