+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: Lunar Lander Bloatware v0-64 (now with sound! stars!) (/showthread.php?tid=731)
Lunar Lander Bloatware v0-64 (now with sound! stars!) - madscijr - 08-04-2022
With sound and alerts, this version is finally starting to look like a real game... By 1981 standards, at least! :-D
The program requires some sound files - the attached 7z file has everything.
I would welcome any feedback on this. The code is not necessarily concise or efficient, but it mostly works.
(I had added these nifty stars which are supposed to twinkle, only they don't twinkle, not sure why!
I'm out of time and brain cells. If anyone ever finds out why, let me know.)
Enjoy
![[Image: lunar-lander-bloatware-v0-64.png]](https://i.ibb.co/y6zmrZL/lunar-lander-bloatware-v0-64.png)
Code: (Select All)
' Lunar Lander Bloatware, mostly by madscijr
' based on b+ Lander 30 LOC (double parking cheat) 2020-11-13
' BPlus proggies > Lander
' https://qb64phoenix.com/forum/showthread.php?tid=162&page=3&highlight=Lander
' https://qb64phoenix.com/forum/showthread.php?tid=443
' bplus Wrote:
' I got a little 30 LOC starter kit setup in Proggies for Lander.
' You will feel the need to jazz it up, resistance is futile.
' DATE WHO-DONE-IT DID-WHAT
' 2020-11-15 bplus fix off-sides x,
' add alternate keys: a=left d=right w=up
' so now arrow keys or WAD system works
' 2022-07-15 madscijr changed variables to double to move lander a fraction of a pixel at a time
' display velocity, fule, etc. on screen
' 2022-07-31 madscijr arrow keys alone apply a minimum amount of thrust
' tweaked text display and end-of-round messages
' 2022-08-04 madscijr added sound effects! stars! (they're supposed to twinkle, need to fix)
' DONE:
' Change input to use _BUTTON instead of KeyHit
' Track velocity + lateral momentum + fuel
' Display altitude, velocity, fuel, etc.
' Pressing arrow up/down/left/right and 1-7 simultaneously selects which direction to thrust in, and power level.
' Pressing arrow keys without 1-7 applies the minimum thrust (same as pressing 1)
' Added some detail to text display and messages at end of round.
' Sound effects: engines, crash, warning beeps (low fuel, moving too fast, etc.)
' Stars "cheap planetarium"
' If speed too fast, display in a different color or graphically warn player.
' TODO:
' Draw slopes of moon instead of blocky (right triangles, like Unicode Character "â—¢" (U+25E2) and "â—£" U+25E3, using _MapTriangle)
' Keep score / stats
' Better (graphic) display for fuel gauge, air speed, etc.
' Animated explosions when the lander crashes!
' Draw rocket flames for left/right/up (maybe use simple straight lines)
' Fix stars (not twinkling!)
' Auto-generate sound file resources from code (maybe need to use OGG instead of WAV for smaller files)
' TODO AFTER:
' Catch up to the classic (Atari Lunar Lander)
' - Change surface of moon to vector lines.
' - Rotate lander Asteroids-style like the arcade game (Atari Lunar Lander).
' - Map entire moon and scroll horizontally as lander drifts towards edges of screen.
' - Zoom in as lander gets close to surface.
' Add title screen + menu with options + skill level
' Multiplayer options (cooperative, competitive, split screen, different roles for players, etc.)
' Lander can sustain damage to parts (later add ability to repair)
' Support game controllers? (analog stick to control thrust direction+power)
' Track + display oxygen (food, water)
' Retrieve extra oxygen/fuel from moon bases, crashed landers, satellites + orbiting spacecraft
' Meteorites (can damage lander), UFOs + other phenomena
' Get out and walk on the moon, collect rocks, ride in lunar rover, meet moonmen, blast back off, rendevous, go home, splashdown, etc.
' Persist junk on the moon (crashed landers, stranded astronauts, flags, equipment, etc.)
' Fly missions related to past missions (rescue stranded astronauts, recover items, etc.)
' Retrieve astronaut poop and study it under a microscope to learn about microorganisms (which may mutate and grow into a monster, interact with moonlife, conway's game of life, etc.)
' Various missions - land, explore, take readings, rescue, salvage, mining, combat, set up moonbase, etc.
' Tunnel under the surface, mine stuff, explore, find caverns, subterranean water, discover life forms, communicate and deal with them, etc.
' Send programmable drones out on missions
' Train astronauts (AI? program them using simple commands?) and see how they perform in various roles
' Etc.
_Title "Lunar Lander Bloatware v0.64 mostly by madscijr" ' display in the Window's title bar
' BOOLEAN CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
' FOR THRUST DIRECTION
Const cNone = 0
Const cUp = 1
Const cDown = 2
Const cLeft = 3
Const cRight = 4
' FOR TRACKING ALTITUDE
Const cHighAltitude = 0
Const cMiddleAltitude = 1
Const cLowAltitude = 2
' FOR ALERTS
Const cNoAlert = 0
Const cSurfaceAlert = 1
Const cSpeedAlert = 2
Const cDangerAlert = 3
Const cOrbitAlert = 4
' HOLDS INFO ABOUT ROCKET THRUSTERS
Type ThrustType
FuelUsed As Integer
Power As Double
Radius As Single
OffsetX As Single
OffsetY As Single
Color As _Unsigned Long
FlickerIndex As Integer
End Type ' ThrustType
' HOLDS LOCATION + COLOR OF EACH STAR
Type StarType
x As Integer
y As Integer
width As Integer
ColorIndex As _Unsigned Long ' the star's current color
TwinkleCounter As Integer ' counter for twinkles
MaxCount As Integer ' controls how fast the star twinkles
End Type ' StarType
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = FALSE
' BASIC PROGRAM METADATA
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)
' ****************************************************************************************************************************************************************
' ACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
$Console
_Delay 4
_Console On
_Echo "Started " + m_ProgramName$
_Echo "Debugging on..."
End If
' ****************************************************************************************************************************************************************
' =============================================================================
' START THE MAIN ROUTINE
main
' =============================================================================
' FINISH
Screen 0
Print m_ProgramName$ + " finished."
Input "Press <ENTER> to continue", in$
' ****************************************************************************************************************************************************************
' DEACTIVATE DEBUGGING WINDOW
If m_bDebug = TRUE Then
_Console Off
End If
' ****************************************************************************************************************************************************************
System ' return control to the operating system
End
' /////////////////////////////////////////////////////////////////////////////
Sub main
' LOCAL VARIABLES
Dim dblGravity As Double: dblGravity = 0.05
Dim iStartFuel As Integer: iStartFuel = 1000
Dim dblMinSpeedY As Double: dblMinSpeedY = 1 ' 0.75
Dim dblMinSpeedX As Double: dblMinSpeedX = .5 ' 0.20
' -----------------------------------------------------------------------------
Dim iFPS As Integer: iFPS = 30
Dim bHorizontalMomentum As Integer: bHorizontalMomentum = FALSE
Dim iLoop As Integer
Dim imgStars&
Dim imgMoon&
ReDim arrMoon(-100 To 200) As Integer ' contains Y positions of moon's surface along x-axis (where 0 = top of screen, 39 = bottom of screen)
'ReDim arrAltitude(-100 To 200) As Integer ' contains altitude of moon's surface along x-axis (where 0 = bottom of screen, 39 = top of screen)
ReDim arrStars(1 To 100) As StarType
ReDim arrColor(-1) As _Unsigned Long
Dim iNumStars As Integer
Dim iHeight As Integer
Dim dblDX As Double
Dim dblDY As Double
Dim dblDangerDX As Double: dblDangerDX = 3
Dim dblDangerDY As Double: dblDangerDY = 3
Dim dblX As Double
Dim dblY As Double
Dim iX As Integer
Dim iY As Integer
Dim sKey As String
Dim iMinX As Integer
Dim iMaxX As Integer
Dim iMinY As Integer
Dim iMaxY As Integer
Dim iStartY As Integer
Dim dblMinX As Double
Dim dblMaxX As Double
Dim dblMinY As Double
Dim dblMaxY As Double
Dim iFuel As Integer
Dim iLowFuelLevel As Integer: iLowFuelLevel = 100
Dim iEscapeFuel As Integer: iEscapeFuel = 75 ' how much fuel they need to leave
Dim iPowerLevel As Integer
Dim iOldPowerLevel As Integer
Dim iAvailablePower As Integer
Dim iLowAltitude As Integer: iLowAltitude = 1 ' when we are this many tiles away from the surface, sound the proximity alert
Dim bFlicker As Integer
Dim iThrustDirection As Integer
Dim iOldThrustDirection As Integer
Dim iDrawThrust As Integer
Dim arrThrust(0 To 7) As ThrustType
Dim arrHeight(0 To 2) As Integer
Dim bCrash As Integer
Dim bLost As Integer
Dim iAltitudeStatus As Integer
Dim iAlertStatus As Integer
Dim bExit As Integer
' -----------------------------------------------------------------------------
'RIGHT FLAME:
Dim sngStartRadian1 As Single: sngStartRadian1 = 5.2 ' 0 to 2, -6.1 to 6.1
Dim sngStopRadian1 As Single: sngStopRadian1 = 0.6 ' 0 to 2, -6.1 to 6.1
Dim sngAspect1 As Single: sngAspect1 = -1 ' 0 to 1, -6.1 to 6.1
'LEFT FLAME:
Dim sngStartRadian2 As Single: sngStartRadian2 = 2.5 ' 0 to 2, -6.1 to 6.1
Dim sngStopRadian2 As Single: sngStopRadian2 = 4.1 ' 0 to 2, -6.1 to 6.1
Dim sngAspect2 As Single: sngAspect2 = -1 ' 0 to 1, -6.1 to 6.1
' -----------------------------------------------------------------------------
Dim iLandingSite As Integer
Dim bQuit As Integer: bQuit = FALSE
Dim in$
Dim sError As String: sError = ""
' -----------------------------------------------------------------------------
' SOUNDS:
Dim lngThrustSound As Long
Dim lngFuelSound As Long
Dim lngSpeedSound As Long
Dim lngDangerSound As Long
Dim lngSurfaceSound As Long
Dim lngExplode1Sound As Long
Dim lngOrbitSound As Long
Dim sNextFile As String
' ARE ALL FILES FOUND?
sNextFile = m_ProgramPath$ + "lunar_alarm1.wav": If _FileExists(sNextFile) = FALSE Then sError = sError + sNextFile + Chr$(13)
sNextFile = m_ProgramPath$ + "lunar_alarm2.wav": If _FileExists(sNextFile) = FALSE Then sError = sError + sNextFile + Chr$(13)
sNextFile = m_ProgramPath$ + "lunar_beep1.wav": If _FileExists(sNextFile) = FALSE Then sError = sError + sNextFile + Chr$(13)
sNextFile = m_ProgramPath$ + "lunar_beep2.wav": If _FileExists(sNextFile) = FALSE Then sError = sError + sNextFile + Chr$(13)
sNextFile = m_ProgramPath$ + "lunar_explode1.wav": If _FileExists(sNextFile) = FALSE Then sError = sError + sNextFile + Chr$(13)
sNextFile = m_ProgramPath$ + "lunar_thrust1.wav": If _FileExists(sNextFile) = FALSE Then sError = sError + sNextFile + Chr$(13)
If Len(sError) > 0 Then
Cls
Print "One or more sound file was not found:" + Chr$(13) + sError
Input "PRESS ENTER TO EXIT"; in$
Exit Sub
End If
' LOAD SOUNDS
lngThrustSound = _SndOpen(m_ProgramPath$ + "lunar_thrust1.wav")
lngFuelSound = _SndOpen(m_ProgramPath$ + "lunar_alarm2.wav")
lngSpeedSound = _SndOpen(m_ProgramPath$ + "lunar_beep2.wav")
lngDangerSound = _SndOpen(m_ProgramPath$ + "lunar_alarm1.wav")
lngSurfaceSound = _SndOpen(m_ProgramPath$ + "lunar_beep1.wav")
lngExplode1Sound = _SndOpen(m_ProgramPath$ + "lunar_explode1.wav")
lngOrbitSound = _SndOpen(m_ProgramPath$ + "lunar_beep2.wav")
' ARE SOUNDS LOADED?
If lngThrustSound = 0 Then sError = sError + "lngThrustSound=0" + Chr$(13)
If lngFuelSound = 0 Then sError = sError + "lngFuelSound=0" + Chr$(13)
If lngSpeedSound = 0 Then sError = sError + "lngSpeedSound=0" + Chr$(13)
If lngDangerSound = 0 Then sError = sError + "lngDangerSound=0" + Chr$(13)
If lngSurfaceSound = 0 Then sError = sError + "lngSurfaceSound=0" + Chr$(13)
If lngExplode1Sound = 0 Then sError = sError + "lngExplode1Sound=0" + Chr$(13)
If lngOrbitSound = 0 Then sError = sError + "lngOrbitSound=0" + Chr$(13)
If Len(sError) > 0 Then
Cls
Print "Sound(s) could not be loaded:" + Chr$(13) + sError
Input "PRESS ENTER TO EXIT"; in$
Exit Sub
End If
' INIT THRUSTERS
arrThrust(0).FuelUsed = 0
arrThrust(0).Power = 0
arrThrust(0).Radius = 0
arrThrust(0).OffsetX = 0
arrThrust(0).OffsetY = 0
arrThrust(0).Color = cBlack
arrThrust(0).FlickerIndex = 0
arrThrust(1).FuelUsed = 1
arrThrust(1).Power = .05
arrThrust(1).Radius = 6
arrThrust(1).OffsetX = 0
arrThrust(1).OffsetY = 0
arrThrust(1).Color = cRed
arrThrust(1).FlickerIndex = 2
arrThrust(2).FuelUsed = 2
arrThrust(2).Power = .10
arrThrust(2).Radius = 8
arrThrust(2).OffsetX = -1
arrThrust(2).OffsetY = 1
arrThrust(2).Color = cYellow
arrThrust(2).FlickerIndex = 3
arrThrust(3).FuelUsed = 3
arrThrust(3).Power = .15
arrThrust(3).Radius = 10
arrThrust(3).OffsetX = -2
arrThrust(3).OffsetY = 2
arrThrust(3).Color = cOrange
arrThrust(3).FlickerIndex = 4
arrThrust(4).FuelUsed = 4
arrThrust(4).Power = .20
arrThrust(4).Radius = 12
arrThrust(4).OffsetX = -3
arrThrust(4).OffsetY = 3
arrThrust(4).Color = cRed
arrThrust(4).FlickerIndex = 5
arrThrust(5).FuelUsed = 6
arrThrust(5).Power = .3
arrThrust(5).Radius = 14
arrThrust(5).OffsetX = -4
arrThrust(5).OffsetY = 4
arrThrust(5).Color = cYellow
arrThrust(5).FlickerIndex = 6
arrThrust(6).FuelUsed = 9
arrThrust(6).Power = .4
arrThrust(6).Radius = 18
arrThrust(6).OffsetX = -6
arrThrust(6).OffsetY = 5
arrThrust(6).Color = cOrange
arrThrust(6).FlickerIndex = 7
arrThrust(7).FuelUsed = 12
arrThrust(7).Power = .5
arrThrust(7).Radius = 26
arrThrust(7).OffsetX = -10
arrThrust(7).OffsetY = 9
arrThrust(7).Color = cRed
arrThrust(7).FlickerIndex = 6
' INIT COLORS
AddGrayscaleColors arrColor()
' =============================================================================
' INITIALIZE SCREEN
Screen _NewImage(800, 640, 32) ' 40 text rows x 100 text columns
imgStars& = _NewImage(800, 640, 32) ' background
imgMoon& = _NewImage(800, 640, 32) ' landscape
' =============================================================================
' START NEW GAME
Do
_Dest 0: Cls , cBlack ' set graphics destination back to game screen
_KeyClear
' -----------------------------------------------------------------------------
' STOP ALL SOUNDS
If lngSurfaceSound <> 0 Then
If _SndPlaying(lngSurfaceSound) = TRUE Then _SndStop lngSurfaceSound
End If
If lngSpeedSound <> 0 Then
If _SndPlaying(lngSpeedSound) = TRUE Then _SndStop lngSpeedSound
End If
If lngDangerSound <> 0 Then
If _SndPlaying(lngDangerSound) = TRUE Then _SndStop lngDangerSound
End If
If lngFuelSound <> 0 Then
If _SndPlaying(lngFuelSound) = TRUE Then _SndStop lngFuelSound
End If
If lngThrustSound <> 0 Then
If _SndPlaying(lngThrustSound) = TRUE Then _SndStop lngThrustSound
End If
If lngExplode1Sound <> 0 Then
If _SndPlaying(lngExplode1Sound) = TRUE Then _SndStop lngExplode1Sound
End If
If lngOrbitSound <> 0 Then
If _SndPlaying(lngOrbitSound) = TRUE Then _SndStop lngOrbitSound
End If
' -----------------------------------------------------------------------------
' DRAW RANDOM LUNAR SURFACE
_Dest imgMoon&: Cls , cEmpty
Randomize Timer
iHeight = 30
iLandingSite = RandomNumber%(-9, 108)
For iLoop = -10 To 110
If iLoop = iLandingSite And iLoop <= (iLandingSite + 1) Then
iHeight = arrMoon(iLoop - 1)
Else
' The RND function returns a random number with a value between 0 (inclusive) and 1 (exclusive).
If Rnd < .5 Then iHeight = iHeight + Int(Rnd * 3) - 1
If iHeight > 39 Then iHeight = 39
If iHeight < 25 Then iHeight = 25
End If
'Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), _RGB32(128), BF
Line (iLoop * 8, iHeight * 16)-(iLoop * 8 + 8, _Height), cGray, BF
arrMoon(iLoop) = iHeight
'arrAltitude(iLoop) = 39 - iHeight
'DebugPrint "arrMoon(" + _Trim$(Str$(iLoop)) + " = " + _Trim$(Str$(arrMoon(iLoop)))
' _PUTIMAGE [STEP] [(dx1, dy1)-[STEP][(dx2, dy2)]][, sourceHandle&][, destHandle&][, ][STEP][(sx1, sy1)[-STEP][(sx2, sy2)]][_SMOOTH]
'_PutImage , 0, imgMoon&
Next iLoop
_Dest 0 ' set graphics destination back to game screen
'DebugPrint "--------------------------------------------------------------------------------"
' -----------------------------------------------------------------------------
' PLACE STARS RANDOMLY
' TODO: maybe add planets, earth, other objects, actual constellations (player can navigate by)
' TODO: as lander circles the moon, move the stars? etc.
iNumStars = RandomNumber%(20, 100)
ReDim arrStars(1 To iNumStars) As StarType
For iLoop = 1 To iNumStars
arrStars(iLoop).x = RandomNumber%(0, 800)
arrStars(iLoop).y = RandomNumber%(0, 584)
arrStars(iLoop).ColorIndex = RandomNumber%(LBound(arrColor), UBound(arrColor))
arrStars(iLoop).width = RandomNumber%(1, 10)
If arrStars(iLoop).width = 10 Then
arrStars(iLoop).width = 3
ElseIf arrStars(iLoop).width > 8 Then
arrStars(iLoop).width = 2
ElseIf arrStars(iLoop).width > 2 Then
arrStars(iLoop).width = 1
Else
arrStars(iLoop).width = 0
End If
arrStars(iLoop).MaxCount = RandomNumber%(50, 300)
arrStars(iLoop).TwinkleCounter = arrStars(iLoop).MaxCount ' (set to max so they are drawn the first time)
Next iLoop
' -----------------------------------------------------------------------------
' SCREEN BOUNDARIES
iMinX = -2
iMaxX = 101
iMinY = 0 - 10
iMaxY = 39
dblMinX = iMinX * 8
dblMaxX = iMaxX * 8
dblMinY = iMinY * 8
dblMaxY = iMaxY * 8 ' 622
' -----------------------------------------------------------------------------
' PUT LANDER IN ORBIT
iStartY = 0
dblX = RandomNumber%(iMinX, iMaxX) * 8
dblY = iStartY * 16
dblDX = 0.0
dblDY = 0.5
iFuel = iStartFuel
bFlicker = FALSE
iThrustDirection = cNone
iOldThrustDirection = cNone
iDrawThrust = 0
iPowerLevel = 1
iOldPowerLevel = 1
bCrash = FALSE
bLost = FALSE
iAltitudeStatus = cMiddleAltitude
iAlertStatus = cNoAlert
' -----------------------------------------------------------------------------
' CONFIGURE PRINTING FOR _PrintString
_PrintMode _FillBackground
'_PrintMode _KEEPBACKGROUND
' -----------------------------------------------------------------------------
' MAIN LOOP
While TRUE = TRUE
' REDRAW MOON + STARS
DrawMoonAndStars imgMoon&, imgStars&, arrStars(), arrColor()
' APPLY GRAVITY
dblDY = dblDY + dblGravity
' WRAP AROUND SCREEN WHY NOT
If dblX < dblMinX Then
dblX = dblMaxX
ElseIf dblX > dblMaxX Then
dblX = dblMinX
End If
' GET AN INTEGER
iX = DblToInt%(dblX) \ 8
iY = DblToInt%(dblY) \ 16
' SHOW INSTRUMENTS + INSTRUCTIONS
DrawText arrMoon(), dblX, dblY, iX, iY, dblDX, dblDY, dblMinSpeedX, dblMinSpeedY, iFuel, iAlertStatus, sKey
' DRAW LANDER
DrawLander dblX, dblY
' THRUST (CURRENTLY ONLY BOTTOM ENGINE)
If iAvailablePower > 0 Then
If iThrustDirection = cUp Then
' 2 ways we could draw rocket flame LINE and CIRCLE
'
' CIRCLE Parameters
' Can use STEP for relative coordinate moves from the previous graphic coordinates.
' Coordinates designate the center position of the circle. Can be partially drawn offscreen.
' radius% is an INTEGER value for half of the total circle diameter.
' drawColor% is any available color attribute in the SCREEN mode used.
' startRadian! and stopRadian! can be any SINGLE value from 0 to 2 * π to create partial circles or ellipses.
' aspect! SINGLE values of 0 to 1 affect the vertical height and values over 1 affect the horizontal width of an ellipse. Aspect = 1 is a normal circle.
'''LINE (dblX + 04, dblY + 16)-(dblX + 02, dblY + 20), cOrange
'''LINE (dblX + 04, dblY + 16)-(dblX + 06, dblY + 20), cYellow
'''Circle (dblX + 04, dblY + 16), 4, cRed, 0, 2
''Circle (dblX + 04, dblY + 16), 8, cRed, sngStartRadian, sngStopRadian
''Circle (dblX + 32, dblY + 32), 8, cOrange, sngAspect
''Circle (dblX + 64, dblY + 48), 8, cYellow, sngStartRadian, sngStopRadian, sngAspect
'Circle (dblX + 64, dblY + 48), iRadius, cYellow, sngStartRadian, sngStopRadian, sngAspect
If bFlicker = FALSE Then
iDrawThrust = iAvailablePower
Else
iDrawThrust = arrThrust(iAvailablePower).FlickerIndex
End If
Circle _
(dblX + 00 + arrThrust(iDrawThrust).OffsetX, dblY + 20 + arrThrust(iDrawThrust).OffsetY), _
arrThrust(iDrawThrust).Radius, _
arrThrust(iDrawThrust).Color, _
sngStartRadian1, _
sngStopRadian1, _
sngAspect1
Circle _
(dblX + 08 - arrThrust(iDrawThrust).OffsetX, dblY + 20 + arrThrust(iDrawThrust).OffsetY), _
arrThrust(iDrawThrust).Radius, _
arrThrust(iDrawThrust).Color, _
sngStartRadian2, _
sngStopRadian2, _
sngAspect2
End If
End If ' THRUST
' UPDATE THE SCREEN
_Display
' -----------------------------------------------------------------------------
' HAS LANDER TOUCHED THE SURFACE OR WENT BACK INTO SPACE?
' IS IT GETTING NEAR?
' GET HEIGHT OF SURFACE AROUND LANDER
arrHeight(0) = arrMoon(iX - 1) - 1
arrHeight(1) = arrMoon(iX) - 1
arrHeight(2) = arrMoon(iX + 1) - 1
' DID WE LAND ON EVEN SURFACE?
If iY = arrHeight(0) And iY = arrHeight(1) And iY = arrHeight(2) Then
' DID WE TOUCH DOWN GENTLY ENOUGH?
If dblDY <= dblMinSpeedY Then
' ARE WE MOVING TOO FAST HORIZONTALLY?
If Abs(dblDX) <= dblMinSpeedX Then
' ADJUST LANDER'S VERTICAL POSITION + REDRAW
dblY = (arrHeight(0) * 16) - 5
' REDRAW EVERYTHING
DrawMoonAndStars imgMoon&, imgStars&, arrStars(), arrColor()
DrawText arrMoon(), dblX, dblY, iX, iY, dblDX, dblDY, dblMinSpeedX, dblMinSpeedY, iFuel, iAlertStatus, sKey ' REDRAW TEXT
DrawLander dblX, dblY
' TOUCH DOWN!
Color cWhite, cDimGray
PrintAt 16, 30, "The Eagle has landed. "
PrintAt 17, 30, "That's one small step for (wo)man,"
PrintAt 18, 30, "one giant leap for Earthlings. "
If iFuel < iEscapeFuel Then
PrintAt 20, 30, "One small problem: "
PrintAt 21, 30, "Not enough fuel left to leave. "
End If
PrintAt 23, 30, "Press any key to try again. "
Exit While
Else
' TOO FAST HORIZONTALLY
Color cWhite, cDimGray
PrintAt 20, 30, "Moving too fast sideways. "
PrintAt 21, 30, "Landing gear failure. "
PrintAt 23, 30, "Press any key to try again. "
bCrash = TRUE
Exit While
End If
Else
' TOO FAST VERTICALLY
Color cWhite, cDimGray
PrintAt 20, 30, "Falling too fast. "
PrintAt 21, 30, "Ship destroyed on imact. "
PrintAt 23, 30, "Press any key to try again. "
bCrash = TRUE
Exit While
End If
' DID WE LAND ON UNEVEN SURFACE?
ElseIf iY >= arrHeight(0) Or iY >= arrHeight(1) Or iY >= arrHeight(2) Or iY > iMaxY Then
' CRASHED DUE TO SPEED OR UNEVEN SURFACE?
If dblDY <= dblMinSpeedY Then
' CRASHED ON UNEVEN SURFACE
Color cWhite, cDimGray
PrintAt 20, 30, "Terrain is too uneven. "
PrintAt 21, 30, "Crash landed on surface. "
PrintAt 23, 30, "Press any key to try again. "
bCrash = TRUE
Exit While
Else
' TOO FAST VERTICALLY
Color cWhite, cDimGray
PrintAt 20, 30, "Out of control. "
PrintAt 21, 30, "Ship destroyed on imact. "
PrintAt 23, 30, "Press any key to try again. "
bCrash = TRUE
Exit While
End If
ElseIf iY < iMinY Then
' LEFT THE MOON'S ORBIT & FLEW OFF INTO SPACE!
Color cWhite, cDimGray
PrintAt 20, 30, "Leaving so soon? "
PrintAt 21, 30, "Lost in space. "
PrintAt 23, 30, "Press any key to try again. "
bLost = TRUE
Exit While
ElseIf iY < 0 Then
' DANGEROUSLY NEAR LEAVING ORBIT!
iAltitudeStatus = cHighAltitude
ElseIf arrHeight(0) - iY <= iLowAltitude Then
' CLOSE TO THE SURFACE!
iAltitudeStatus = cLowAltitude
'DebugPrint "CLOSE! arrHeight(0)-iY <= iLowAltitude, " + cstr$(arrHeight(0)) + "-" + cstr$(iY) + " <= " + cstr$(iLowAltitude)
ElseIf arrHeight(1) - iY <= iLowAltitude Then
' CLOSE TO THE SURFACE!
iAltitudeStatus = cLowAltitude
'DebugPrint "CLOSE! arrHeight(1)-iY <= iLowAltitude, " + cstr$(arrHeight(1)) + "-" + cstr$(iY) + " <= " + cstr$(iLowAltitude)
ElseIf arrHeight(2) - iY <= iLowAltitude Then
' CLOSE TO THE SURFACE!
iAltitudeStatus = cLowAltitude
'DebugPrint "CLOSE! arrHeight(2)-iY <= iLowAltitude, " + cstr$(arrHeight(2)) + "-" + cstr$(iY) + " <= " + cstr$(iLowAltitude)
Else
' NEITHER TOO CLOSE NOR TOO FAR
iAltitudeStatus = cMiddleAltitude
End If
' SET ALERT STATUS
If iAltitudeStatus = cLowAltitude Then
' NEARING THE SURFACE...
If dblDY <= dblMinSpeedY And Abs(dblDX) <= dblMinSpeedX Then
iAlertStatus = cSurfaceAlert
ElseIf dblDY < dblDangerDY And Abs(dblDX) < dblDangerDX Then
iAlertStatus = cSpeedAlert
Else
iAlertStatus = cDangerAlert
End If
ElseIf iAltitudeStatus = cHighAltitude Then
' NEARING OUTER SPACE...
If Abs(dblDY) < dblDangerDY And Abs(dblDX) < dblDangerDX Then
iAlertStatus = cOrbitAlert
Else
iAlertStatus = cDangerAlert
End If
Else
' SOMEWHERE IN THE MIDDLE...
If Abs(dblDY) < dblDangerDY And Abs(dblDX) < dblDangerDX Then
iAlertStatus = cNoAlert
Else
iAlertStatus = cDangerAlert
End If
End If
' STOP ANY UNNECESSARY ALARMS
If iAlertStatus <> cOrbitAlert Or iFuel <= 0 Then
If lngOrbitSound <> 0 Then
If _SndPlaying(lngOrbitSound) = TRUE Then _SndStop lngOrbitSound
End If
End If
If iAlertStatus <> cSpeedAlert Or iFuel <= 0 Then
If lngSpeedSound <> 0 Then
If _SndPlaying(lngSpeedSound) = TRUE Then _SndStop lngSpeedSound
End If
End If
If iAlertStatus <> cDangerAlert Or iFuel <= 0 Then
If lngDangerSound <> 0 Then
If _SndPlaying(lngDangerSound) = TRUE Then _SndStop lngDangerSound
End If
End If
If iAlertStatus <> cSurfaceAlert Or iFuel <= 0 Then
If lngSurfaceSound <> 0 Then
If _SndPlaying(lngSurfaceSound) = TRUE Then _SndStop lngSurfaceSound
End If
End If
If iFuel <= 0 Then
If lngFuelSound <> 0 Then
If _SndPlaying(lngFuelSound) = TRUE Then _SndStop lngFuelSound
End If
End If
' SOUND ALARMS / ALERTS
If iFuel > 0 Then
' LOW FUEL ALARM?
If iFuel <= iLowFuelLevel Then
If lngFuelSound <> 0 Then
If _SndPlaying(lngFuelSound) = FALSE Then _SndLoop lngFuelSound '_SNDPLAY lngFuelSound
End If
End If
' ALL OTHER ALERTS
If iAlertStatus = cOrbitAlert Then
If lngOrbitSound <> 0 Then
If _SndPlaying(lngOrbitSound) = FALSE Then _SndLoop lngOrbitSound '_SNDPLAY lngThrustSound
End If
ElseIf iAlertStatus = cSurfaceAlert Then
If lngSurfaceSound <> 0 Then
If _SndPlaying(lngSurfaceSound) = FALSE Then _SndLoop lngSurfaceSound '_SNDPLAY lngThrustSound
End If
ElseIf iAlertStatus = cSpeedAlert Then
If lngSpeedSound <> 0 Then
If _SndPlaying(lngSpeedSound) = FALSE Then _SndLoop lngSpeedSound '_SNDPLAY lngThrustSound
End If
ElseIf iAlertStatus = cDangerAlert Then
If lngDangerSound <> 0 Then
If _SndPlaying(lngDangerSound) = FALSE Then _SndLoop lngDangerSound '_SNDPLAY lngThrustSound
End If
End If
Else
' NO FUEL = NO POWER FOR ALARMS!
End If
' =============================================================================
' PROCESS INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
sKey = ""
' -----------------------------------------------------------------------------
' QUIT?
If _Button(KeyCode_Escape%) Then
bQuit = TRUE
Exit While
End If
' -----------------------------------------------------------------------------
' Get power level (1=weakest, 7=strongest)
If _Button(KeyCode_1%) Then
iPowerLevel = 1: sKey = sKey + "1,"
ElseIf _Button(KeyCode_2%) Then
iPowerLevel = 2: sKey = sKey + "2,"
ElseIf _Button(KeyCode_3%) Then
iPowerLevel = 3: sKey = sKey + "3,"
ElseIf _Button(KeyCode_4%) Then
iPowerLevel = 4: sKey = sKey + "4,"
ElseIf _Button(KeyCode_5%) Then
iPowerLevel = 5: sKey = sKey + "5,"
ElseIf _Button(KeyCode_6%) Then
iPowerLevel = 6: sKey = sKey + "6,"
ElseIf _Button(KeyCode_7%) Then
iPowerLevel = 7: sKey = sKey + "7,"
End If
' -----------------------------------------------------------------------------
' Get direction
If _Button(KeyCode_Left%) Then
sKey = sKey + "LEFT,"
iThrustDirection = cLeft
ElseIf _Button(KeyCode_A%) Then
sKey = sKey + "A,"
iThrustDirection = cLeft
ElseIf _Button(KeyCode_Right%) Then
sKey = sKey + "RIGHT,"
iThrustDirection = cRight
ElseIf _Button(KeyCode_D%) Then
sKey = sKey + "D,"
iThrustDirection = cRight
ElseIf _Button(KeyCode_Up%) Then
sKey = sKey + "UP,"
iThrustDirection = cUp
ElseIf _Button(KeyCode_W%) Then
sKey = sKey + "W,"
iThrustDirection = cUp
ElseIf _Button(KeyCode_Down%) Then
sKey = sKey + "DOWN,"
iThrustDirection = cDown
ElseIf _Button(KeyCode_S%) Then
sKey = sKey + "S,"
iThrustDirection = cDown
Else
iThrustDirection = cNone
End If
' -----------------------------------------------------------------------------
' Fire the engines
iAvailablePower = 0
If iThrustDirection <> cNone Then
' Remember previous
iOldThrustDirection = iThrustDirection
' Make sure we have enough fuel for thrust level.
' (Else adjust based on available fuel.)
For iLoop = iPowerLevel To 0 Step -1
If iFuel >= arrThrust(iLoop).FuelUsed Then
iAvailablePower = iLoop
Exit For
End If
Next iLoop
' If we had enough fuel that engines are firing
If iAvailablePower > 0 Then
' Consume fuel
iFuel = iFuel - arrThrust(iAvailablePower).FuelUsed
' Apply force
If iThrustDirection = cLeft Then
dblDX = dblDX - arrThrust(iAvailablePower).Power
'TODO: need a better way to do sound, these sounds don't stop playing when the player releases the controls
'SLIME_BAS_SOUND_11
ElseIf iThrustDirection = cRight Then
dblDX = dblDX + arrThrust(iAvailablePower).Power
'SLIME_BAS_SOUND_11
ElseIf iThrustDirection = cUp Then
dblDY = dblDY - arrThrust(iAvailablePower).Power
'SLIME_BAS_SOUND_11
ElseIf iThrustDirection = cDown Then
dblDY = dblDY + arrThrust(iAvailablePower).Power
'snatch_bas_sound_6
''SLIME_BAS_SOUND_11
End If
' Animate the rocket flames
If iThrustDirection = iOldThrustDirection Then bFlicker = Not (bFlicker)
' Sound on
If lngThrustSound <> 0 Then
' CHANGE THRUSTER VOLUME IF POWER LEVEL CHANGES
If (iAvailablePower <> iOldPowerLevel) Then
iOldPowerLevel = iAvailablePower
_SndVol lngThrustSound, iAvailablePower / 7
End If
If _SndPlaying(lngThrustSound) = FALSE Then
_SndLoop lngThrustSound '_SNDPLAY lngThrustSound
End If
End If
Else
' Engines off
iOldThrustDirection = cNone: bFlicker = FALSE
' Sound off
If lngThrustSound <> 0 Then
If _SndPlaying(lngThrustSound) = TRUE Then _SndStop lngThrustSound
End If
End If
Else
' Engines off
iOldThrustDirection = cNone: bFlicker = FALSE
' Sound off
If lngThrustSound <> 0 Then
If _SndPlaying(lngThrustSound) = TRUE Then _SndStop lngThrustSound
End If
End If
' -----------------------------------------------------------------------------
' MOVE LANDER
dblX = dblX + dblDX
dblY = dblY + dblDY
' -----------------------------------------------------------------------------
' CONTROL GAME SPEED
_Limit iFPS
'_Limit 2
'_Limit 30
Wend
' UPDATE THE SCREEN
_Display
' STOP ALL SOUNDS
If lngSurfaceSound <> 0 Then
If _SndPlaying(lngSurfaceSound) = TRUE Then _SndStop lngSurfaceSound
End If
If lngSpeedSound <> 0 Then
If _SndPlaying(lngSpeedSound) = TRUE Then _SndStop lngSpeedSound
End If
If lngDangerSound <> 0 Then
If _SndPlaying(lngDangerSound) = TRUE Then _SndStop lngDangerSound
End If
If lngFuelSound <> 0 Then
If _SndPlaying(lngFuelSound) = TRUE Then _SndStop lngFuelSound
End If
If lngThrustSound <> 0 Then
If _SndPlaying(lngThrustSound) = TRUE Then _SndStop lngThrustSound
End If
If lngOrbitSound <> 0 Then
If _SndPlaying(lngOrbitSound) = TRUE Then _SndStop lngOrbitSound
End If
' PLAY FINAL SOUNDS
bExit = FALSE
If bCrash = TRUE Then
' BOOM!
If lngExplode1Sound <> 0 Then
If _SndPlaying(lngExplode1Sound) = TRUE Then _SndStop lngExplode1Sound
_SndPlay lngExplode1Sound
End If
ElseIf bLost = TRUE Then
' LOST IN SPACE!
' NOTE: HOW DO WE STOP SOUND FROM PLAYING EARLY?
' TODO: REPLACE WITH A WAV FILE FOR NOW...
'_KeyClear : While InKey$ <> "": Wend ' Clear the keyboard buffer
'For iLoop = 1 To 2000
' Sound 25000 - (iLoop * 10), .1
' if len(InKey$) > 0 then bExit = TRUE: Exit For
'Next iLoop
'DOESN'T WORK: If bExit = TRUE Then Sound 0, 0
End If
' CLEAR KEYBOARD BUFFER
_KeyClear: _Delay 2
' PLAY ANOTHER ROUND OR QUIT?
If bQuit = FALSE Then
If bExit = FALSE Then Sleep
Color cWhite, cBlack
Else
Exit Do
End If
Loop
' CLOSE SOUNDS
_SndClose lngThrustSound
_SndClose lngFuelSound
_SndClose lngSpeedSound
_SndClose lngDangerSound
_SndClose lngSurfaceSound
_SndClose lngExplode1Sound
_SndClose lngOrbitSound
' RETURN TO AUTODISPLAY
_AutoDisplay
End Sub ' main
' /////////////////////////////////////////////////////////////////////////////
' (RE)DRAW MOON AND STARS
Sub DrawMoonAndStars (imgMoon&, imgStars&, arrStars() As StarType, arrColor() As _Unsigned Long)
Dim iLoop As Integer
Dim x1%
Dim x2%
Dim y1%
Dim y2%
' Twinkle twinkle little stars
_Dest imgStars&
For iLoop = LBound(arrStars) To UBound(arrStars)
' increment twinkle counter
arrStars(iLoop).TwinkleCounter = arrStars(iLoop).TwinkleCounter + 1
' is it time to twinkle the color?
If arrStars(iLoop).TwinkleCounter > arrStars(iLoop).MaxCount Then
arrStars(iLoop).TwinkleCounter = 0 ' reset counter
arrStars(iLoop).ColorIndex = arrStars(iLoop).ColorIndex + 1 ' increment color
If arrStars(iLoop).ColorIndex > UBound(arrColor) Then
arrStars(iLoop).ColorIndex = LBound(arrColor) ' reset color
End If
' get size
x1% = arrStars(iLoop).x: x2% = x1% + arrStars(iLoop).width
y1% = arrStars(iLoop).y: y2% = y1% + arrStars(iLoop).width
' (re)draw it
Line (x1%, y1%)-(x2%, y2%), arrColor(arrStars(iLoop).ColorIndex), BF
End If
Next iLoop
' Start with space
_Dest 0
Cls , cBlack ' set graphics destination back to game screen
' Add the stars
_PutImage , imgStars&, 0
' Add the lunar surface
_PutImage , imgMoon&, 0
End Sub ' DrawMoonAndStars
' /////////////////////////////////////////////////////////////////////////////
' SHOW INSTRUMENTS + INSTRUCTIONS
' 800x600 = 40 rows x 100 columns
sub DrawText( _
arrMoon() As Integer, _
dblX as double, dblY as double, _
iX as integer, iY as integer, _
dblDX as double, dblDY as double, _
dblMinSpeedX as double, dblMinSpeedY as double, _
iFuel as integer, iAlertStatus as integer, _
sKey as string _
)
Dim sValue$
' SHOW POSITION + SPEED
Color cWhite
PrintAt 1, 1, "Velocity X: " + Left$(DblRoundedToStr$(dblDX, 3), 5) + " "
Color cGray
PrintAt 2, 1, "Max +/- X: " + Left$(DblRoundedToStr$(dblMinSpeedX, 3), 5) + " "
Color cWhite
PrintAt 1, 21, "Latitude : " + _
LeftPadString$(cstr$(iX), 4, " ") + _
" " + _
LeftPadString$(Left$(DblRoundedToStr$(dblX, 3), 5), 5, " ") + _
" "
Color cWhite
PrintAt 3, 1, "Velocity Y: " + Left$(DblRoundedToStr$(dblDY, 3), 5) + " "
Color cGray
PrintAt 4, 1, "Max Y: " + Left$(DblRoundedToStr$(dblMinSpeedY, 3), 5) + " "
Color cWhite
PrintAt 3, 21, "Altitude : " + _
LeftPadString$(cstr$(iY), 4, " ") + _
" " + _
LeftPadString$(Left$(DblRoundedToStr$(dblY, 3), 5), 5, " ") + _
" "
Color cGray
sValue$ = cstr$(arrMoon(iX - 1))
PrintAt 5, 21, "Surface : " + LeftPadString$(sValue$, 4, " ") + " "
sValue$ = cstr$(arrMoon(iX))
PrintAt 6, 21, " " + LeftPadString$(sValue$, 4, " ") + " "
sValue$ = cstr$(arrMoon(iX + 1))
PrintAt 7, 21, " " + LeftPadString$(sValue$, 4, " ") + " "
Color cYellow
If iFuel > 0 Then
PrintAt 8, 1, "Fuel : " + _Trim$(Str$(iFuel)) + " "
Else
PrintAt 8, 1, "Fuel : EMPTY"
End If
Color cLime
PrintAt 10, 1, "Controls : " + RightPadString$(sKey, 10, " ") + " "
Color cDodgerBlue
PrintAt 1, 48, Chr$(34) + "One Small Step" + Chr$(34)
Color cCyan
PrintAt 3, 48, "Land on an even surface."
Color cMagenta
PrintAt 5, 48, "Arrow keys: direction of thrust"
PrintAt 6, 48, " (up slows descent)"
PrintAt 8, 48, "1-7 keys: burn engine"
PrintAt 9, 48, " (1 = weakest)"
Color cOrange
PrintAt 11, 48, "Good Luck!"
If iAlertStatus = cDangerAlert Then
Color cRed
PrintAt 20, 30, "DANGER! SLOW DOWN!"
End If
End Sub ' DrawText
Sub DrawLander (dblX, dblY)
' DRAW LANDER
'CIRCLE [[[STEP]]](column, row), radius%, [drawColor%][, startRadian!, stopRadian!] [, aspect!]
Circle (dblX + 4, dblY + 8), 4, cGray
'Circle (dblX - 2, dblY + 16), 4, cGray, 0, _Pi
'Circle (dblX + 10, dblY + 16), 4, cGray, 0, _Pi
Circle (dblX + 0, dblY + 16), 4, cGray, 0, _Pi
Circle (dblX + 8, dblY + 16), 4, cGray, 0, _Pi
''Circle (dblX + 4, dblY + 8), 4, &HFF00FFFF
''Circle (dblX + 0, dblY + 16), 4, &HFFFFFF00, 0, _Pi
''Circle (dblX + 8, dblY + 16), 4, &HFFFFFF00, 0, _Pi
'LINE [STEP] [(column1, row1)]-[STEP] (column2, row2), color[, [{B|BF}], style%]
''LINE (100, 100)-(200, 200), 10
'LINE (dblX + 4, dblY + 16)-(dblX + 0, dblY + 24), cGray
'LINE (dblX + 4, dblY + 16)-(dblX + 8, dblY + 24), cGray
' LEGS:
Line (dblX - 4, dblY + 16)-(dblX - 4, dblY + 20), cGray
Line (dblX + 12, dblY + 16)-(dblX + 12, dblY + 20), cGray
' FEET
Line (dblX - 5, dblY + 20)-(dblX - 3, dblY + 20), cGray
Line (dblX + 11, dblY + 20)-(dblX + 13, dblY + 20), cGray
End Sub ' DrawLander
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Function cstr$ (myValue)
'cstr$ = LTRIM$(RTRIM$(STR$(myValue)))
cstr$ = _Trim$(Str$(myValue))
End Function ' cstr$
' /////////////////////////////////////////////////////////////////////////////
' Hack function, to be replaced with something better
Function DblToInt% (dblOld As Double)
Dim dblNew As Double
Dim sValue As String
Dim iPos As Integer
dblNew = RoundDouble#(dblOld, 0)
'sValue = _Trim$(Str$(dblNew))
sValue = DblToStr$(dblNew)
'iPos = InStr(1, sValue, ".")
'If iPos > 0 Then
' DblToInt% = Val(Left$(sValue, iPos - 1))
'Else
' DblToInt% = Val(sValue)
'End If
DblToInt% = Val(sValue)
End Function ' DblToInt%
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function DblToStr$ (n#)
Dim result$: result$ = ""
Dim value$
Dim Xpos%
Dim expo%
Dim sign$
Dim valu$
Dim dot%
Dim L%
Dim add$
Dim min$
Dim DP$
Dim n%
value$ = UCase$(LTrim$(Str$(n#)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") ' only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n% = 1 To L%
If Mid$(valu$, n%, 1) <> "." Then
num$ = num$ + Mid$(valu$, n%, 1)
End If
Next n%
result$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
Else
result$ = value$
End If
DblToStr$ = result$
End Function ' DblToStr$
' /////////////////////////////////////////////////////////////////////////////
Function DblRoundedToStr$ (dblValue As Double, intNumPlaces As Integer)
Dim dblNew As Double
dblNew = RoundDouble#(dblValue, intNumPlaces)
DblRoundedToStr$ = DblToStr$(dblNew)
End Function ' DblRoundedToStr$
' /////////////////////////////////////////////////////////////////////////////
' Scientific notation - QB64 Wiki
' https://www.qb64.org/wiki/Scientific_notation
' Example: A string function that displays extremely small or large exponential decimal values.
Function FloatToStr$ (n##)
value$ = UCase$(LTrim$(Str$(n##)))
Xpos% = InStr(value$, "D") + InStr(value$, "E") 'only D or E can be present
If Xpos% Then
expo% = Val(Mid$(value$, Xpos% + 1))
If Val(value$) < 0 Then
sign$ = "-"
valu$ = Mid$(value$, 2, Xpos% - 2)
Else
valu$ = Mid$(value$, 1, Xpos% - 1)
End If
dot% = InStr(valu$, ".")
L% = Len(valu$)
If expo% > 0 Then
add$ = String$(expo% - (L% - dot%), "0")
End If
If expo% < 0 Then
min$ = String$(Abs(expo%) - (dot% - 1), "0")
DP$ = "."
End If
For n = 1 To L%
If Mid$(valu$, n, 1) <> "." Then
num$ = num$ + Mid$(valu$, n, 1)
End If
Next n
Else
FloatToStr$ = value$
Exit Function
End If
FloatToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)
End Function ' FloatToStr$
' /////////////////////////////////////////////////////////////////////////////
' 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$)
Dim result$
Dim i As Long
result$ = in$(LBound(in$))
For i = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(i)
Next i
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
Function LeftPadString$ (myString$, toWidth%, padChar$)
LeftPadString$ = Right$(String$(toWidth%, padChar$) + myString$, toWidth%)
End Function ' LeftPadString$
' /////////////////////////////////////////////////////////////////////////////
' iRow% and iCol% are 0-based in this version
Sub PrintAt (iRow%, iCol%, sText$)
'_PrintString (iCol% * 8, iRow% * 16), sText$
_PrintString (iCol% * 8, iRow% * 16), sText$
'_PrintString (iCol%, iRow%), sText$
End Sub ' PrintAt
' /////////////////////////////////////////////////////////////////////////////
' 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%
' /////////////////////////////////////////////////////////////////////////////
Function RightPadString$ (myString$, toWidth%, padChar$)
RightPadString$ = Left$(myString$ + String$(toWidth%, padChar$), toWidth%)
End Function ' RightPadString$
' /////////////////////////////////////////////////////////////////////////////
' https://www.qb64.org/forum/index.php?topic=3605.0
' Quote from: SMcNeill on Today at 03:53:48 PM
'
' Sometimes, you guys make things entirely too complicated.
' There ya go! Three functions to either round naturally,
' always round down, or always round up, to whatever number of digits you desire.
' EDIT: Modified to add another option to round scientific,
' since you had it's description included in your example.
' Receives + returns _FLOAT myVar## (-1.18E-4932 to +1.18E+4932)
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE _FLOAT
Function Round## (num##, digits%)
Round## = Int(num## * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUp## (num##, digits%)
RoundUp## = _Ceil(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDown## (num##, digits%)
RoundDown## = Int(num## * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientific## (num##, digits%)
RoundScientific## = _Round(num## * 10 ^ digits%) / 10 ^ digits%
End Function
' =============================================================================
' ROUNDING FUNCTIONS FOR TYPE DOUBLE
Function RoundDouble# (num#, digits%)
RoundDouble# = Int(num# * 10 ^ digits% + .5) / 10 ^ digits%
End Function
Function RoundUpDouble# (num#, digits%)
RoundUpDouble# = _Ceil(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundDownDouble# (num#, digits%)
RoundDownDouble# = Int(num# * 10 ^ digits%) / 10 ^ digits%
End Function
Function RoundScientificDouble# (num#, digits%)
RoundScientificDouble# = _Round(num# * 10 ^ digits%) / 10 ^ digits%
End Function
' /////////////////////////////////////////////////////////////////////////////
' 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.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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~&
' LONG-HAIRED FRIENDS OF JESUS OR NOT,
' THIS IS NOT YELLOW ENOUGH (TOO CLOSE TO LIME)
' TO USE FOR OUR COMPLEX RAINBOW SEQUENCE:
Function cChartreuse~& ()
cChartreuse = _RGB32(127, 255, 0)
End Function ' cChartreuse~&
' WE SUBSTITUTE THIS CSS3 COLOR FOR INBETWEEN LIME AND YELLOW:
Function cOliveDrab1~& ()
cOliveDrab1 = _RGB32(192, 255, 62)
End Function ' cOliveDrab1~&
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)
'cWhite = _RGB32(254, 254, 254)
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
cEmpty = _RGB32(0, 0, 0, 0)
End Function ' cEmpty~&
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN COLOR ARRAY FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
Sub AddColor (ColorValue As _Unsigned Long, arrColor() As _Unsigned Long)
ReDim _Preserve arrColor(0 To UBound(arrColor) + 1) As _Unsigned Long
arrColor(UBound(arrColor)) = ColorValue
End Sub ' AddColor
' /////////////////////////////////////////////////////////////////////////////
Sub AddGrayscaleColors (arrColor() As _Unsigned Long)
AddColor cDimGray, arrColor()
AddColor cGray, arrColor()
AddColor cDarkGray, arrColor()
AddColor cSilver, arrColor()
AddColor cLightGray, arrColor()
AddColor cGainsboro, arrColor()
AddColor cWhiteSmoke, arrColor()
AddColor cWhite, arrColor()
AddColor cWhiteSmoke, arrColor()
AddColor cGainsboro, arrColor()
AddColor cLightGray, arrColor()
AddColor cSilver, arrColor()
AddColor cDarkGray, arrColor()
AddColor cGray, arrColor()
End Sub ' AddGrayscaleColors
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END COLOR ARRAY FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' BEGIN KEYBOARD CODE FUNCTIONS
' NOTE: ALL CODES ARE FOR _BUTTON, EXCEPT:
' cF10 (_KEYDOWN)
' cAltLeft (_KEYHIT)
' cAltRight (_KEYHIT)
' cPrintScreen (_KEYHIT) <- may slow down pc?
' cPauseBreak (_KEYHIT) <- may not work?
' ################################################################################################################################################################
Function KeyCode_Escape% ()
KeyCode_Escape% = 2
End Function
Function KeyCode_F1% ()
KeyCode_F1% = 60
End Function
Function KeyCode_F2% ()
KeyCode_F2% = 61
End Function
Function KeyCode_F3% ()
KeyCode_F3% = 62
End Function
Function KeyCode_F4% ()
KeyCode_F4% = 63
End Function
Function KeyCode_F5% ()
KeyCode_F5% = 64
End Function
Function KeyCode_F6% ()
KeyCode_F6% = 65
End Function
Function KeyCode_F7% ()
KeyCode_F7% = 66
End Function
Function KeyCode_F8% ()
KeyCode_F8% = 67
End Function
Function KeyCode_F9% ()
KeyCode_F9% = 68
End Function
'_KEYDOWN CODE, NOT _BUTTON CODE
Function KeyCode_F10% ()
KeyCode_F10% = 17408
End Function
Function KeyCode_F11% ()
KeyCode_F11% = 88
End Function
Function KeyCode_F12% ()
KeyCode_F12% = 89
End Function
'_KEYHIT CODE, NOT _BUTTON CODE
Function KeyCode_PrintScreen% ()
KeyCode_PrintScreen% = -44
End Function
Function KeyCode_ScrollLock% ()
KeyCode_ScrollLock% = 71
End Function
'_KEYHIT CODE, NOT _BUTTON CODE
Function KeyCode_PauseBreak% ()
KeyCode_PauseBreak% = 31053
End Function
Function KeyCode_Tilde% ()
KeyCode_Tilde% = 42
End Function
Function KeyCode_1% ()
KeyCode_1% = 3
End Function
Function KeyCode_2% ()
KeyCode_2% = 4
End Function
Function KeyCode_3% ()
KeyCode_3% = 5
End Function
Function KeyCode_4% ()
KeyCode_4% = 6
End Function
Function KeyCode_5% ()
KeyCode_5% = 7
End Function
Function KeyCode_6% ()
KeyCode_6% = 8
End Function
Function KeyCode_7% ()
KeyCode_7% = 9
End Function
Function KeyCode_8% ()
KeyCode_8% = 10
End Function
Function KeyCode_9% ()
KeyCode_9% = 11
End Function
Function KeyCode_0% ()
KeyCode_0% = 12
End Function
Function KeyCode_Minus% ()
KeyCode_Minus% = 13
End Function
Function KeyCode_Equal% ()
KeyCode_Equal% = 14
End Function
Function KeyCode_BkSp% ()
KeyCode_BkSp% = 15
End Function
Function KeyCode_Ins% ()
KeyCode_Ins% = 339
End Function
Function KeyCode_Home% ()
KeyCode_Home% = 328
End Function
Function KeyCode_PgUp% ()
KeyCode_PgUp% = 330
End Function
Function KeyCode_Del% ()
KeyCode_Del% = 340
End Function
Function KeyCode_End% ()
KeyCode_End% = 336
End Function
Function KeyCode_PgDn% ()
KeyCode_PgDn% = 338
End Function
Function KeyCode_NumLock% ()
KeyCode_NumLock% = 326
End Function
Function KeyCode_KeypadSlash% ()
KeyCode_KeypadSlash% = 310
End Function
Function KeyCode_KeypadMultiply% ()
KeyCode_KeypadMultiply% = 56
End Function
Function KeyCode_KeypadMinus% ()
KeyCode_KeypadMinus% = 75
End Function
Function KeyCode_Keypad7Home% ()
KeyCode_Keypad7Home% = 72
End Function
Function KeyCode_Keypad8Up% ()
KeyCode_Keypad8Up% = 73
End Function
Function KeyCode_Keypad9PgUp% ()
KeyCode_Keypad9PgUp% = 74
End Function
Function KeyCode_KeypadPlus% ()
KeyCode_KeypadPlus% = 79
End Function
Function KeyCode_Keypad4Left% ()
KeyCode_Keypad4Left% = 76
End Function
Function KeyCode_Keypad5% ()
KeyCode_Keypad5% = 77
End Function
Function KeyCode_Keypad6Right% ()
KeyCode_Keypad6Right% = 78
End Function
Function KeyCode_Keypad1End% ()
KeyCode_Keypad1End% = 80
End Function
Function KeyCode_Keypad2Down% ()
KeyCode_Keypad2Down% = 81
End Function
Function KeyCode_Keypad3PgDn% ()
KeyCode_Keypad3PgDn% = 82
End Function
Function KeyCode_KeypadEnter% ()
KeyCode_KeypadEnter% = 285
End Function
Function KeyCode_Keypad0Ins% ()
KeyCode_Keypad0Ins% = 83
End Function
Function KeyCode_KeypadPeriodDel% ()
KeyCode_KeypadPeriodDel% = 84
End Function
Function KeyCode_Tab% ()
KeyCode_Tab% = 16
End Function
Function KeyCode_Q% ()
KeyCode_Q% = 17
End Function
Function KeyCode_W% ()
KeyCode_W% = 18
End Function
Function KeyCode_E% ()
KeyCode_E% = 19
End Function
Function KeyCode_R% ()
KeyCode_R% = 20
End Function
Function KeyCode_T% ()
KeyCode_T% = 21
End Function
Function KeyCode_Y% ()
KeyCode_Y% = 22
End Function
Function KeyCode_U% ()
KeyCode_U% = 23
End Function
Function KeyCode_I% ()
KeyCode_I% = 24
End Function
Function KeyCode_O% ()
KeyCode_O% = 25
End Function
Function KeyCode_P% ()
KeyCode_P% = 26
End Function
Function KeyCode_BracketLeft% ()
KeyCode_BracketLeft% = 27
End Function
Function KeyCode_BracketRight% ()
KeyCode_BracketRight% = 28
End Function
Function KeyCode_Backslash% ()
KeyCode_Backslash% = 44
End Function
Function KeyCode_CapsLock% ()
KeyCode_CapsLock% = 59
End Function
Function KeyCode_A% ()
KeyCode_A% = 31
End Function
Function KeyCode_S% ()
KeyCode_S% = 32
End Function
Function KeyCode_D% ()
KeyCode_D% = 33
End Function
Function KeyCode_F% ()
KeyCode_F% = 34
End Function
Function KeyCode_G% ()
KeyCode_G% = 35
End Function
Function KeyCode_H% ()
KeyCode_H% = 36
End Function
Function KeyCode_J% ()
KeyCode_J% = 37
End Function
Function KeyCode_K% ()
KeyCode_K% = 38
End Function
Function KeyCode_L% ()
KeyCode_L% = 39
End Function
Function KeyCode_Semicolon% ()
KeyCode_Semicolon% = 40
End Function
Function KeyCode_Apostrophe% ()
KeyCode_Apostrophe% = 41
End Function
Function KeyCode_Enter% ()
KeyCode_Enter% = 29
End Function
Function KeyCode_ShiftLeft% ()
KeyCode_ShiftLeft% = 43
End Function
Function KeyCode_Z% ()
KeyCode_Z% = 45
End Function
Function KeyCode_X% ()
KeyCode_X% = 46
End Function
Function KeyCode_C% ()
KeyCode_C% = 47
End Function
Function KeyCode_V% ()
KeyCode_V% = 48
End Function
Function KeyCode_B% ()
KeyCode_B% = 49
End Function
Function KeyCode_N% ()
KeyCode_N% = 50
End Function
Function KeyCode_M% ()
KeyCode_M% = 51
End Function
Function KeyCode_Comma% ()
KeyCode_Comma% = 52
End Function
Function KeyCode_Period% ()
KeyCode_Period% = 53
End Function
Function KeyCode_Slash% ()
KeyCode_Slash% = 54
End Function
Function KeyCode_ShiftRight% ()
KeyCode_ShiftRight% = 55
End Function
Function KeyCode_Up% ()
KeyCode_Up% = 329
End Function
Function KeyCode_Left% ()
KeyCode_Left% = 332
End Function
Function KeyCode_Down% ()
KeyCode_Down% = 337
End Function
Function KeyCode_Right% ()
KeyCode_Right% = 334
End Function
Function KeyCode_CtrlLeft% ()
KeyCode_CtrlLeft% = 30
End Function
Function KeyCode_WinLeft% ()
KeyCode_WinLeft% = 348
End Function
' _KEYHIT CODE NOT _BUTTON CODE
Function KeyCode_AltLeft% ()
KeyCode_AltLeft% = -30764
End Function
Function KeyCode_Spacebar% ()
KeyCode_Spacebar% = 58
End Function
' _KEYHIT CODE NOT _BUTTON CODE
Function KeyCode_AltRight% ()
KeyCode_AltRight% = -30765
End Function
Function KeyCode_WinRight% ()
KeyCode_WinRight% = 349
End Function
Function KeyCode_Menu% ()
KeyCode_Menu% = 350
End Function
Function KeyCode_CtrlRight% ()
KeyCode_CtrlRight% = 286
End Function
' ################################################################################################################################################################
' END KEYBOARD CODE FUNCTIONS
' ################################################################################################################################################################
' ################################################################################################################################################################
' BEGIN SOUND ROUTINES
' ################################################################################################################################################################
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RUMBLE SOUNDS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' low warbling rumbly sound (very short version)
Sub SLIME_BAS_SOUND_11
Dim z%
Dim zz%
For z% = 220 To 200 Step -1
Sound Int(100 * Rnd) + 50, .3
For zz% = 1 To 1000: Next zz%
Next z%
End Sub ' SLIME_BAS_SOUND_11
' /////////////////////////////////////////////////////////////////////////////
' medium rumbling type sound
Sub snatch_bas_sound_6
Dim Z As Integer
For Z = 40 To 1 Step -1
'For Z = 10 To 1 Step -1
'Z = 20
Sound Int(60 * Rnd) + 60 + Z, .2
Next Z
End Sub ' snatch_bas_sound_6
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RUMBLE SOUNDS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' END SOUND ROUTINES
' ################################################################################################################################################################
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DEBUGGING ROUTINES #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub DebugPrint (MyString As String)
If m_bDebug = TRUE Then
'_Echo MyString
ReDim arrLines(-1) As String
Dim iLoop As Integer
split MyString, Chr$(13), arrLines()
For iLoop = LBound(arrLines) To UBound(arrLines)
_Echo arrLines(iLoop)
Next iLoop
End If
End Sub ' DebugPrint
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #REFERENCE
' =============================================================================
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%