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
Code: (Select All)
' Lunar Lander Bloatware, mostly by madscijr
' based on b+ Lander 30 LOC (double parking cheat) 2020-11-13
' https://staging.qb64phoenix.com/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
' 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
' ****************************************************************************************************************************************************************
' 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
' 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
' =============================================================================
' 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
' _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
' 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.
' -----------------------------------------------------------------------------
' 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
' 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
' -----------------------------------------------------------------------------
' 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
' /////////////////////////////////////////////////////////////////////////////
' (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) + " "
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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
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 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
I had serious problems with passing variables to functions: by reference or by value.
I have now solved it like this - it doesn't seem to work without a dummy.
Code: (Select All)
'https://www.lernhelfer.de/schuelerlexikon/mathematik/artikel/euklidischer-algorithmus
'Groester gemeinsamer Teiler und kleintes gemeinsames Vielfaches
'GGT und kgV nach Euklid - 4. August 2022
Option _Explicit
Declare Function ggt(zahl1, zahl2 as Long) as Long
Declare Function kgV(zahl1, zahl2, ggtErgebnis as Long) as Long
Dim zahl1, zahl2 As Long
Dim d1, d2 As Long
Print
Print "Berechnet den GGT und das kgV nach Euklid"
Print
Input "Geben Sie die erste Zahl ein : ", zahl1
Input "Geben Sie die zweite Zahl ein: ", zahl2
'd1/2 = dummy - Zuweisung als Wert (Value)
'Sonst wird per Referenz auf zahl1/2 zugegriffen,
'und natuerlich ihr veraenderter Wert uebergeben
d1 = (zahl1)
d2 = (zahl2)
Print: Print
Print Using "Der gemeinsame Teiler von ### und ### ist: ###"; zahl1, zahl2, ggt(zahl1, zahl2)
Print: Print
'Nur mit den dummies funktioniert es
Print Using "Das kleinste gemeinsame Vielfache von ### und ### ist: ###,###"; d1, d2, kgV(d1, d2, ggt(zahl1, zahl2))
End 'Hauptprogramm
Function ggt (zahl1, zahl2 As Long)
Dim temp As Long
While (zahl1 > 0)
If (zahl1 < zahl2) Then
temp = zahl1: zahl1 = zahl2: zahl2 = temp
End If
zahl1 = zahl1 - zahl2
Wend
ggt = zahl2
If we create a long sound using SOUND inside a loop, the loop ends quickly but the sound keeps on playing in the background.
So it seems that whenever the SOUND command is called, it just adds the current frequency/duration to a queue, which then keeps playing in the background, without holding up the code.
The problem I'm having is, how do you make it stop early?
If there is no command for this, then maybe it should be added?
The below program demonstrates the issue and the strange behavior I get when trying to stop the sound with different workarounds...
Any help appreciated!
Code: (Select All)
' Q: how do you stop a sound playing with the Sound command?
Const FALSE = 0
Const TRUE = Not FALSE
Dim iLoop As Integer
Dim in$
Dim bQuit As Integer
Do
bQuit = FALSE
Cls
Print "Start playing some sounds..."
' Quick ascending tone signals that we are starting
For iLoop = 400 To 500 Step 5: Sound iLoop, .3: Next iLoop
' Middle sound (goes on a long time, how to turn it off?)
For iLoop = 1 To 2000
Sound 25000 - (iLoop * 10), .1
Next iLoop
' Quick descending tone signals that we're done
For iLoop = 500 To 400 Step -5: Sound iLoop, .3: Next iLoop
Print "Finished generating sound."
Print
Print "Now, how do we stop it playing or clear the SOUND queue?"
Print
Print "WARNING: "
Print "Options 1-3 can cause program to freeze or act strangely!"
Print
_KeyClear: While InKey$ <> "": Wend ' Clear the keyboard buffer
Print "1. Try stopping the sound with SOUND 0,0"
Print "2. Try stopping the sound with SOUND 37,1"
Print "3. Try stopping the sound with BEEP"
Print "4. Play it again"
Print "5. Quit"
Print
Input "Your choice"; in$: in$ = LCase$(_Trim$(in$))
Do
If in$ = "1" Then
Sound 0, 0
ElseIf in$ = "2" Then
Sound 37, 1
ElseIf in$ = "3" Then
Beep
ElseIf in$ = "4" Then
bQuit = FALSE: Exit Do
ElseIf in$ = "5" Or in$ = "q" Then
bQuit = TRUE: Exit Do
End If
Loop
Added logic so it recognizes links like "forum.qb64.org" and not just "www.qb64.org/forum",
and can handle other such weird cases.
Code: (Select All)
' Opens google qb64.rip links in mirror site.
' https://staging.qb64phoenix.com/showthread.php?tid=429
' Version: 7.08
' DATE WHO-DONE-IT DID-WHAT
' 2022-05-18 Pete Created QB64.org URL redirector.
' 2022-07-22 madscijr Added options menu and support for wiki.
' 2022-07-29 madscijr Changed input from Input to Inkey$.
' 2022-08-04 madscijr Added logic to normalize URLs
' like https://forum.qb64.org/index.php?topic=...
' to https://www.qb64.org/forum/index.php?topic=...
Dim in$
Dim iCount%: iCount% = 0
Dim oldURL$
Dim parse$
Dim newURL$
Dim bUpdateClipboard%
Dim sOpenBrowser$
Dim sValue$
Dim sMessage$
Dim iPos%
Dim sKey$
Dim bChrome%
Dim bFirefox%
Dim bDontNavigate%
Dim bScreenUpdate%
bScreenUpdate% = TRUE
bUpdateClipboard% = TRUE
sOpenBrowser$ = "c"
sMessage$ = ""
_Title "QB64.org link updater v7.08" ' display in the Window's title bar
Do
bChrome% = (sOpenBrowser$ = "g")
bFirefox% = (sOpenBrowser$ = "f")
bDontNavigate% = ((bChrome% = FALSE) And (bFirefox% = FALSE))
If (bScreenUpdate% = TRUE) Then
Cls
Print "QB64.org link updater by Pete, modified by madscijr"
Print
Print "1. Copy old link to clipboard first"
Print "2. Select options (see below)"
Print "3. Press ENTER to convert link and do something."
Print
Print "ESC = quit"
Print
Print "---------------------------------------------------"
Print "Clipboard options:"
Print "C = Enable update clipboard.........." + IIFSTR$(bUpdateClipboard%, "<---", " ")
Print "D = Disable update clipboard.........." + IIFSTR$(bUpdateClipboard%, " ", "<---")
Print
Print "Navigation options:"
Print "G = Navigates to new link in Chrome..." + IIFSTR$(bChrome%, "<---", " ")
Print "F = Navigates to new link in Firefox.." + IIFSTR$(bFirefox%, "<---", " ")
Print "N = Don't navigate to new link........" + IIFSTR$(bDontNavigate%, "<---", " ")
Print "---------------------------------------------------"
Print sMessage$: If Len(sMessage$) > 0 Then sMessage$ = ""
bScreenUpdate% = FALSE
End If
sKey$ = InKey$
If UCase$(sKey$) = "C" Then
If bUpdateClipboard% = FALSE Then
bUpdateClipboard% = TRUE
bScreenUpdate% = TRUE
End If
ElseIf UCase$(sKey$) = "D" Then
If bUpdateClipboard% = TRUE Then
bUpdateClipboard% = FALSE
bScreenUpdate% = TRUE
End If
ElseIf UCase$(sKey$) = "G" Then
If sOpenBrowser$ <> "g" Then
sOpenBrowser$ = "g"
bScreenUpdate% = TRUE
End If
ElseIf UCase$(sKey$) = "F" Then
If sOpenBrowser$ <> "f" Then
sOpenBrowser$ = "f"
bScreenUpdate% = TRUE
End If
ElseIf UCase$(sKey$) = "N" Then
If sOpenBrowser$ <> "n" Then
sOpenBrowser$ = "n"
bScreenUpdate% = TRUE
End If
ElseIf sKey$ = Chr$(27) Then
Exit Do
ElseIf sKey$ = Chr$(13) Then
If Len(_Clipboard$) Then
oldURL$ = LCase$(_Clipboard$)
oldURL$ = _Trim$(oldURL$)
' MAKE SURE THERE IS A SLASH AFTER "qb64.org"
' OLD: https://www.qb64.org
' NEW: https://www.qb64.org/
If Right$(oldURL$, 8) = "qb64.org" Then
oldURL$ = Left$(oldURL$, Len(oldURL$) - 8) + "qb64.org/"
End If
' MAKE SURE THERE IS "WWW"
' OLD: https://qb64.org/...
' NEW: https://www.qb64.org/...
oldURL$ = Replace$(oldURL$, "https://qb64.org/", "https://www.qb64.org/")
If InStr(oldURL$, "/www.qb64.org/forum/index.php") > 0 Then
' URL IS FROM FORUMS...
If InStr(oldURL$, "?topic=") > 0 Then
sMessage$ = sMessage$ + "Detected forum link." + Chr$(13)
parse$ = Mid$(oldURL$, InStr(oldURL$, "index"))
newURL$ = "https://qb64forum.alephc.xyz/" + parse$
Else
sMessage$ = sMessage$ + "Detected forum link, no topic." + Chr$(13)
' GOTO THE ROOT FORUMS URL
newURL$ = "https://qb64forum.alephc.xyz/index.php"
End If
iCount% = iCount% + 1
ElseIf InStr(oldURL$, "/www.qb64.org/wiki") > 0 Then
' URL IS FROM WIKI...
If InStr(oldURL$, "/www.qb64.org/wiki/") > 0 Then
sMessage$ = sMessage$ + "Detected wiki link." + Chr$(13)
iPos% = _InStrRev(oldURL$, "/wiki/")
If iPos% > 0 Then
parse$ = Right$(oldURL$, Len(oldURL$) - (iPos% + 5))
End If
newURL$ = "https://qb64phoenix.com/qb64wiki/index.php/" + parse$
Else
sMessage$ = sMessage$ + "Detected wiki link, no topic." + Chr$(13)
' GOTO THE ROOT WIKI URL
newURL$ = "https://qb64phoenix.com/qb64wiki/index.php"
End If
iCount% = iCount% + 1
Else
sMessage$ = sMessage$ + "Link not recognized." + Chr$(13)
newURL$ = ""
End If
If Len(newURL$) > 0 Then
sMessage$ = sMessage$ + "Converted, new URL is:" + Chr$(13) + newURL$ + Chr$(13)
If sOpenBrowser$ = "g" Then
sMessage$ = sMessage$ + "Opening new link in Chrome." + Chr$(13)
Shell _DontWait "chrome " + newURL$
ElseIf sOpenBrowser$ = "f" Then
sMessage$ = sMessage$ + "Opening new link in Firefox." + Chr$(13)
Shell _DontWait "firefox " + newURL$
End If
If bUpdateClipboard% = TRUE Then
sMessage$ = sMessage$ + "Copying new link to clipboard." + Chr$(13)
_Clipboard$ = newURL$
End If
End If
Else
sMessage$ = sMessage$ + "Clipboard is empty!" + Chr$(13)
End If
bScreenUpdate% = TRUE
End If
If bScreenUpdate% = TRUE Then
While InKey$ <> "": Wend ' Clear the keyboard buffer
End If
_Limit 60
Loop
'System
End
' /////////////////////////////////////////////////////////////////////////////
' IIF function for QB for strings
Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
End Function
'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))))
' Locate the next instance of [Find2]:
lngLocation = InStr(1, Text2, Find2)
' Next instance of [Find2]...
Wend
' OUTPUT:
Replace$ = Text2
End Function ' Replace$
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Redirect old-forum and wiki search results to Pheonix as appropriate.
' https://staging.qb64phoenix.com/showthread.php?tid=429
' mpgcan
' 05-18-2022, 10:37 AM
'
' You know how it goes. Searching for a QB64 solution, search engines return
' results to the old-forum or old-wiki. Clicking the link only to be informed the
' server is not found.
'
' With the link returned, you can use part of it to search in either the new-wiki
' or old-backup forum. This has become very tedious. I thought there must be a
' better way.
'
' A simple solution is to use Einar Egilsson's Redirector for this. It is a
' browser add-on for Firefox, Chrome, Edge and Opera. The Redirector allows you
' to search for a specific URL, substitute it for another URL and force the
' browser to redirect to this new URL.
'
' How to install redirector on Firefox:
'
' 1) Use the following link to get the add-on
' https://addons.mozilla.org/en-GB/firefox/addon/redirector/
'
' 2) Note: This add-on is not actively monitored for security by Mozilla.
' Check out the "Learn more" link. After reading your choice
' if you wish to continue.
'
' 3) Click the Add to Firefox button.
'
' 4) Add Redirector? This extension will have permission to:
' Click Add button
'
' 5) Redirector was added.
' Click the check box. Allow this extension to run in Private Windows
' Click Okay button.
'
' 6) A redirector symbol is displayed at the top right of the browser
' confirming it is successfully installed.
'
' Configuring redirector:
' Redirect from the old QB64 forum to Phoenix's old-archived read only
' working forum.
'
' 1) Click on the redirector symbol in the drop down click
' "Edit Redirects" button.
' 2) On the new browser page that opens, click "Create New Redirect"
' 3) Fill in the form with the following information:
' Configuration information:
' Description........: QB64_forum_old_to_archive
' Example URL........: https://forum.qb64.org/
' Include pattern....: https://forum.qb64.org/*
' Redirect to........: https://qb64forum.alephc.xyz/$1
' Pattern type.......: Wildcard click radio buttom
' Pattern Description: Leave blank
' Example result: https://qb64forum.alephc.xyz/
' To complete it, click the "Save" button.
' 4) Click "Create New Redirect"
' 5) Fill in the form with the following information:
' Configuration information:
' Redirect from the old QB64 Wiki to Pheonix's new QB64 Wiki.
' Description : QB64_Wiki_old_to_new
' Example URL : https://wiki.qb64.org/wiki/
' Include pattern : https://wiki.qb64.org/wiki/*
' Redirect to : https://qb64phoenix.com/qb64wiki/index.php/$1
' Pattern type : Wildcard click radio buttom
' Pattern Description: Leave blank
' Example result: https://qb64phoenix.com/qb64wiki/index.php/
' To complete it, click the "Save" button.
' 6) Finally disable the first configuration
' "Example redirect, try going to http://example.com/anywordhere"
' By clicking the "Disable" button.
'
' Test:
' Try the following two links in your browser:
' https://forum.qb64.org/index.php?topic=456.0
' https://wiki.qb64.org/wiki/$IF
'
' All the best
' MPGCAN
'
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' madscijr
' 05-19-2022, 11:39 AM
' (05-18-2022, 10:37 AM) mpgcan Wrote:
' >A simple solution is to use Einar Egilsson's Redirector for this.
' >It is a browser add-on for Firefox, Chrome, Edge and Opera.
' >The Redirector allows you to search for a specific URL,
' >substitute it for another URL and force the browser to redirect
' >to this new URL.
'
' Thanks for sharing this and explaining how to use it.
' This can come in handy for any number of things...
'
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' Pete, Administrator
' 05-19-2022, 01:21 AM
'
' Looks like a useful plugin.
' I made my own in QB64...
'
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' madscijr
' 05-19-2022, 11:38 AM
'
' (05-19-2022, 01:21 AM) Pete Wrote:
' >Looks like a useful plugin.
' >I made my own in QB64...
'
' Very cool!
' Not only does it work and is useful, but I never knew QB64 could do that,
' and learned something knew.
' Thanks Pete
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
This very minimal drawing program alllows a user to draw an image with a mouse and write a string to the clipboard to be used with the draw command in another program.
The image is drawn using relative coordinates so it may be positioned anywhere on the screen when used later.
EDIT: check the latest version in the thread for the corrections (of course)
Code: (Select All)
'Mininmal relative Pen draw
'
'this simple program that allows the user to draw an image using a mouse and write the a string that can be used by the draw command
'in another program to the clipboard to be copy and pasted as the user needs.
'
' each coordinate position in the image is recorded as a relative coordinate, this allows the image to be drawn in a later program with
' a different origin on the display screen
'
'this uses color 15 as the line color and color 12 as the fill color.
' it is possible to cycle through the stroke color by pressing the c key and the fill color by pressing the b key
' there is some odd behavior if the fills I have not completely figure out at this point so...uh, good luck
'
' I whipped this up because I was getting darned sick and tired of plotting out draw images coordinates ahead of time
' this version makes it easier to use the draw command to make a "sprite" of sorts.
'
_Title "pen_draw RELATIVE <esc> to quit"
imgx = 640 'just change these two if you want to draw larger pictures or smaller pictures (without using all the screen space)
imgy = 480
Screen _NewImage(imgx + 200, imgy + 120, 256)
'leaving room for buttons and visual aids outside draw area for future program development
Dim dc$(60000) 'this is a big string array, I haven't drawn anything that fills this yet but i suppose it is indeed very possible
Dim DW$(60000)
' this relatively simple program uses a whole lot of RAM becasue of those two arrays, any modern system will not even notice
p = 0
ox = 0
oy = 0
nx = 0
ny = 0
DD$ = ""
fklr = 12
sklr = 15
Draw "c" + Str$(sklr)
Do
_Limit 60
Do While _MouseInput
'check for the mouse pointer in the image drawing area, if it is start drawing
If _MouseButton(1) Then
If _MouseX <= imgx And _MouseY <= imgy Then
p = p + 1
nx = _MouseX
ny = _MouseY
'deterimine the difference from this coordinate and the last one and save the resultign relative positions as a string
dx = nx - ox
dy = ny - oy
If dx < 0 Then
ddx$ = _Trim$(Str$(dx))
Else
ddx$ = "+" + _Trim$(Str$(dx)) 'have to add a + so the realtive posion is properly drawn with the draw command
End If
If dy < 0 Then
ddy$ = _Trim$(Str$(dy))
Else
ddy$ = "+" + _Trim$(Str$(dy)) 'have to add a + so the realtive posion is properly drawn with the draw command
End If
If ox = 0 And oy = 0 Then ' if the pen is up the line will be plotted by blind move but not drawn
dc$(p) = "bm" + ddx$ + "," + ddy$
Draw "c" + Str$(sklr)
Draw dc$(p)
ox = nx
oy = ny
Else 'elsewise the pen is down and a visible line will be plotted
PSet (ox, oy)
dc$(p) = "m" + ddx$ + "," + ddy$
Draw "c" + Str$(sklr)
Draw dc$(p)
ox = nx
oy = ny
End If
End If
End If
Loop
ask$ = InKey$
Select Case ask$
Case " " 'pen up and pen down
'this clears old X and old Y so the user can create non-contiguos points ...it's a little rough
If ox = 0 And oy = 0 Then
ox = nx
oy = ny
Else
ox = 0
oy = 0
End If
Case "f" 'fill
' it works best if you press the space bar once or twice before and after using this command...
'unless you want to keep drawing lines through the filled area
p = p + 1
fx = _MouseX
fy = _MouseY
dx = fx - nx
dy = fy - ny
If dx < 0 Then
ddx$ = _Trim$(Str$(dx))
Else
ddx$ = "+" + _Trim$(Str$(dx))
End If
If dy < 0 Then
ddy$ = _Trim$(Str$(dy))
Else
ddy$ = "+" + _Trim$(Str$(dy))
End If
dc$(p) = "bm" + ddx$ + "," + ddy$ + " P" + Str$(fklr) + "," + Str$(sklr) + " c" + Str$(sklr)
ox = 0
oy = 0
Draw dc$(p)
ask$ = " "
Case "u"
'undo, it mostly sorta works...
' do not hold the u key down too long or a whole lot of work is getting undone
' if the image yuo are drawing has a lot of redundant points that haven't been cleaned up yet it will take a while
' to notice the results of this command as it steps back through the draw commands
p = p - 1
Cls
PSet (0, 0)
Draw "c" + Str$(sklr)
For d = 1 To p
DD$ = DD$ + dc$(d)
Next d
Draw DD$
DD$ = ""
ask$ = " "
Case "w" 'write to clipboard also clean up duplicate entries
'even with the one pass cleanup to clear out redundant points the string for all but the simplest images can still be very large
DD$ = ""
DW$(1) = dc$(1)
w = 1
For d = 2 To p
If dc$(d) <> DW$(w) Then
w = w + 1
DW$(w) = dc$(d)
End If
Next d
For d = 1 To w
DD$ = DD$ + DW$(d)
dc$(d) = DW$(d)
Next d
p = w
ox = 0
oy = 0
_Clipboard$ = DD$ ''this slaps the string on the clipboard
Case "b" 'cycle fill color b is for background?
fklr = fklr + 1
If fklr > 255 Then fklr = 0
Line (imgx + 30, 20)-(imgx + 36, 40), fklr, BF
ask$ = " "
Case "c" 'cycle stroke color
'results of changing the stroke color is still pretty iffy and odd but here's the code for now
sklr = sklr + 1
If sklr > 255 Then sklr = 0
Line (imgx + 20, 20)-(imgx + 26, 40), sklr, B
Draw "c" + Str$(sklr)
dc$(p) = dc$(p) + "c" + Str$(sklr)
ask$ = " "
End Select
Loop Until ask$ = Chr$(27)
Cls
For d = 1 To p
DD$ = DD$ + dc$(d)
Next d
Input "Enter anyhting to quit", AA$
'an example on how to use the draw command to make a "sprite" for use elsewhere in a program
For x = 0 To 300 Step 10
_Limit 30
Cls
Line (100, 100)-(200, 200), 13, BF 'fancy background you didn't draw before
dt$ = "c15 bm" + Str$(x) + ",100" 'just using the draw command itself to move the image along
Draw dt$
Draw DD$
_Display
Next
_Delay 2
a very minimal program designed to draw an image and directly encode it for use with the DRAW command.
Write what you draw with mouse to the clipboard to copy and past in another program or data file.
Code: (Select All)
'Mininmal absolute Pen draw
'
'this simple program allows the user to draw an image using a mouse and write a string that can be used by the draw command
'in another program.
'
'this uses color 15 as the line color and color 12 as the fill color.
'
' I whipped this up because I was getting darned sick and tired of plotting out draw images coordinates ahead of time
_Title "pen_draw ABSOLUTE <esc> to quit" '
maxx = 640 'just change these two if you want to draw larger pictures
maxy = 480
Screen _NewImage(maxx, maxy, 256)
'$DYNAMIC
Dim dc$(60000) 'this is a big string array, I haven't drawn anything that fills this yet but i suppose it is indeed very possible
Dim DW$(60000)
p = 0
ox = 0
oy = 0
nx = 0
ny = 0
DD$ = ""
Draw "c15"
Do
_Limit 60
Do While _MouseInput
If _MouseButton(1) Then
p = p + 1
Locate 1, 1: Print p
nx = _MouseX
ny = _MouseY
If ox = 0 And oy = 0 Then 'if the pen is up the line will be plotted by blind move but not drawn
dc$(p) = "bm" + Str$(nx) + "," + Str$(ny)
Draw dc$(p)
ox = nx
oy = ny
Else 'elsewise the pen is down and a visible line will be plotted f
PSet (ox, oy)
dc$(p) = "m" + Str$(nx) + "," + Str$(ny)
Draw dc$(p)
ox = nx
oy = ny
End If
End If
Loop
ask$ = InKey$
Select Case ask$
Case " " 'pen up and pen down
'this clears old X and old Y so the user can create non-contiguos points
If ox = 0 And oy = 0 Then
ox = nx
oy = ny
Else
ox = 0
oy = 0
End If
Case "f" 'fill, it works best if you press the space bar before and after using this command
p = p + 1
fx = _MouseX
fy = _MouseY
dc$(p) = "bm" + Str$(fx) + "," + Str$(fy) + " P12,15 c15"
ox = 0
oy = 0
Draw dc$(p)
ask$ = " "
Case "u" 'undo, it mostly sorta works...
' do not hold the u key down too long or a whole lot of work is getting undone
' if the image yuo are drawing has a lot of redundant points that haven't been cleaned up yet it will take a while
' to notice the results of this command as it steps back through the draw commands
p = p - 1 'step back one point
Cls
PSet (0, 0)
Draw "c15"
For D = 1 To p 'redraw the image after stepping back
DD$ = DD$ + dc$(D)
Next D
Draw DD$
DD$ = ""
ask$ = " "
Case "w" 'write to clipboard also clean up duplicate entries
'this writes a single string holding the draw command for the image to the clipbaord
'it does a simple pass to eliminate consecutive redundant points that can be generated while drawing with the mouse
DD$ = ""
DW$(1) = dc$(1)
w = 1
For D = 2 To p
If dc$(D) <> DW$(w) Then
w = w + 1
DW$(w) = dc$(D)
End If
Next D
For D = 1 To w
DD$ = DD$ + DW$(D)
dc$(D) = DW$(D)
Next D
p = w
ox = 0
oy = 0
_Clipboard$ = DD$ 'this slaps the string on the clipboard
End Select
Loop Until ask$ = Chr$(27)
Cls
For D = 1 To p
DD$ = DD$ + dc$(D)
Next D
Draw DD$
Input "Enter anything to quit ", aa$
I believe there's 79 different variations of sentences than can be made with this. Possibly more. Most of it is very bad grammar lol. But try to look over that if you can. I'm just having some fun. I added mouse support to left click for another sentence. If you right click it ends. Tell me what you think, thanks. I'm no English professor lol. It's more of a poetry-type of writing or something like the start of a haiku almost, in one sentence.
Code: (Select All)
Dim a$(22)
start:
Cls
Print " Random Sentence Generator"
Print
Print " By SierraKen"
Randomize Timer
Print: Print
a = Int(Rnd * 22) + 1
For aa = 1 To 22
Read a$(aa)
If aa = a Then Print a$(aa);
Next aa
a = Int(Rnd * 22) + 1
For aa = 1 To 22
Read a$(aa)
If aa = a Then Print " " + a$(aa);
Next aa
a = Int(Rnd * 7) + 1
For aa = 1 To 7
Read a$(aa)
If aa = a Then Print " " + a$(aa);
Next aa
a = Int(Rnd * 12) + 1
For aa = 1 To 12
Read a$(aa)
If aa = a Then Print " " + a$(aa);
Next aa
a = Int(Rnd * 4) + 1
For aa = 1 To 4
Read a$(aa)
If aa = a Then Print " " + a$(aa);
Next aa
a = Int(Rnd * 5) + 1
For aa = 1 To 5
Read a$(aa)
If aa = a Then Print " " + a$(aa);
Next aa
a = Int(Rnd * 7) + 1
For aa = 1 To 7
Read a$(aa)
If aa = a Then Print " " + a$(aa);
Next aa
Locate 22, 1
Print "Click left mouse button for another one."
Print "Click right mouse button to quit."
Do
While _MouseInput: Wend
mouseLeftButton = _MouseButton(1)
mouseRightButton = _MouseButton(2)
Clear_MB 1
If mouseLeftButton Then Restore: GoTo start:
If mouseRightButton Then End
Loop
Data "He","She","I","You","Animals","People","They","Birds","Dogs","A dog","A cat","Cats","A bird","Fish","A fish","Squirrels","A squirrel","Chipmunks","A chipmunk","Crowds","A crowd","A person"
Data "hit","ran","hunted","looked","walked","roamed","journeyed","swam","read","programmed","typed","laughed","listened","flew","ate","drove","bit","smiled","chewed","stared","yawned","slept"
Data "to","until","when","more to","less to","faster to","slower to"
Data "Lucy","Edward","Ralph","Cindy","people","they","a woman","a man","a kid","animals","they","someone"
Data "but","or","as if","and when"
Data "saw","looked","ignored","yelled","talked"
Data "to nothing.","to a star.","to another person.","to themself.","to nobody.","to everyone.","to the world."
Sub Clear_MB (var As Integer)
Do Until Not _MouseButton(var)
While _MouseInput: Wend
Loop
I may have missed something somewhere in notes on rendering order because the behavior of the attached program surprised me.
I'm using the draw command to draw a simple shape as a sprite of sorts and it will overprint an image drawn with the other graphics commands but it will not overprint text. How the fill interacts is interesting as well. It just doesn't seem consistent with other drawing commands.
Hi friends
following the thread of Steve about a logic bug on what a coder was waiting for getting an effect and the transparent quality that masking what the code does....
here an evolution of the explosion code posted by Steve
beyond the added differences for getting fading effects and vertical or horizontal explosion
the main difference is using an incremental speed of movement got by calculating speed at each loop
Code: (Select All)
Const Classic = 0, MoveUpLeft = 1, MoveUpRight = 2, MoveDownLeft = 3, MoveDownRight = 4, Horizontal = 5, Vertical = 6
Screen _NewImage(1280, 720, 32)
$Color:32
Dim Shared f As Long
f = _LoadFont("courbd.ttf", 128, "monospace")
testExplosion Red, Green, White, Classic
testExplosion Blue, Yellow, Cyan, MoveUpLeft
testExplosion Brown, Green, Black, MoveUpRight
testExplosion Red, Brown, Green, MoveDownRight
testExplosion White, Red, Yellow, MoveDownLeft
testExplosion Blue, Brown, Cyan, Horizontal
testExplosion Red, Blue, Violet, Vertical
_Font 8
Print "FINISHED!!"
End
Sub testExplosion (ForeC, BackC, LineC, ModeE)
_Font f
Color ForeC, BackC
Cls , 0
_PrintString (284, 200), "Steve is"
_PrintString (284, 328), "Awesome!"
Color LineC
Line (283, 199)-(645, 457), , B
Sleep
Explode2 284, 200, 644, 456, 16, 16, ModeE
Sleep 2
End Sub
'Sub Explode (x1, y1, x2, y2, pw, ph)
' tempScreen = _NewImage(_Width, _Height, 32)
' _PutImage , 0, tempScreen
' w = x2 - x1 + 1: h = y2 - y1 + 1
' ax = 2 * w \ pw + 1: ay = 2 * h \ ph + 1
' cx = x1 + w \ 2: cy = y1 + h \ 2
' Type box
' x As Single
' y As Single
' handle As Long
' rotation As Single
' changex As Single
' changey As Single
' End Type
' Dim Array(0 To ax, 0 To ay) As box
' For x = 0 To ax
' For y = 0 To ay
' Array(x, y).handle = _NewImage(pw, ph, 32)
' Array(x, y).x = x1 + pw * x
' Array(x, y).y = y1 + ph * y
' _PutImage , 0, Array(x, y).handle, (x1 + pw * x, y1 + ph * y)-Step(pw, ph)
' Array(x, y).changex = -(cx - Array(x, y).x) / 10
' Array(x, y).changey = -(cy - Array(x, y).y) / 10
' Next
' Next
' Do
' Cls , 0
' finished = -1
' For x = 0 To ax
' For y = 0 To ay
' Array(x, y).x = Array(x, y).x + Array(x, y).changex
' Array(x, y).y = Array(x, y).y + Array(x, y).changey
' If Array(x, y).x >= 0 And Array(x, y).y >= 0 And _
' Array(x, y).x <= _Width And Array(x, y).y <= _Height Then finished = 0
' 'If Array(x, y).x >= 0 And Array(x, y).y >= 0 And Array(x, y).x <= _Width / 4 And Array(x, y).y <= _Height / 2 Then finished = 0 ' Pete solution
' _PutImage (Array(x, y).x, Array(x, y).y)-Step(pw, ph), Array(x, y).handle, 0, (0, 0)-(pw, ph)
' Next
' Next
' _Display
' _Limit 60
' Loop Until finished
' _AutoDisplay
'End Sub
Sub Explode2 (x1, y1, x2, y2, pw, ph, mode)
' this copy screen visible
tempScreen = _NewImage(_Width, _Height, 32)
_PutImage , 0, tempScreen
' this calculates width, height, maxbox-X, maxbox-Y, center of area passed for exploding
w = x2 - x1 + 1: h = y2 - y1 + 1 ' width and height of image
ax = 2 * w \ pw + 1: ay = 2 * h \ ph + 1 'mAX horyzontal blocks and mA(X)Y vertical blocks
cx = x1 + w \ 2: cy = y1 + h \ 2 ' center of image
Type box
x As Single
y As Single
handle As Long
rotation As Single
changex As Single
changey As Single
End Type
Dim Array(0 To ax, 0 To ay) As box ' two dimensional array for blocks of image to explode
' this save each box/block of image into array and with the relative images
For x = 0 To ax
For y = 0 To ay
Array(x, y).handle = _NewImage(pw, ph, 32)
Array(x, y).x = x1 + pw * x
Array(x, y).y = y1 + ph * y
_PutImage , 0, Array(x, y).handle, (x1 + pw * x, y1 + ph * y)-Step(pw, ph)
Next
Next
' this moves block/boxes for getting animation of explosion
Do
Cls , 0
finished = -1
For x = 0 To ax
For y = 0 To ay
If mode = 0 Then
Array(x, y).changex = -(cx - Array(x, y).x) / 10
Array(x, y).changey = -(cy - Array(x, y).y) / 10
ElseIf mode = 1 Then
Array(x, y).changex = -cx / 10
Array(x, y).changey = -cy / 10
ElseIf mode = 2 Then
Array(x, y).changex = cx / 10
Array(x, y).changey = -cy / 10
ElseIf mode = 3 Then
Array(x, y).changex = -cx / 10
Array(x, y).changey = cy / 10
ElseIf mode = 4 Then
Array(x, y).changex = cx / 10
Array(x, y).changey = cy / 10
ElseIf mode = 5 Then
Array(x, y).changex = -(cx - Array(x, y).x) / 10
Array(x, y).changey = 0
ElseIf mode = 6 Then
Array(x, y).changex = 0
Array(x, y).changey = -(cy - Array(x, y).y) / 10
End If
Array(x, y).x = Array(x, y).x + Array(x, y).changex
Array(x, y).y = Array(x, y).y + Array(x, y).changey
If Array(x, y).x >= 0 And Array(x, y).y >= 0 And _
Array(x, y).x <= _Width And Array(x, y).y <= _Height Then finished = 0
_PutImage (Array(x, y).x, Array(x, y).y)-Step(pw, ph), Array(x, y).handle, 0, (0, 0)-(pw, ph)
Next
Next
_Display
_Limit 60
As a way of saying hello I thought I'd upload something to display my awful programming habits. I honestly haven't programmed something like a game since the 80s when I would horse around on a Commodore 64. I later took several courses in HS and college but didn't pursue programming as a career.
A few weeks ago I was sort of wishing I could still do some qb45 coding, for amusement, and discovered Dosbox and got set up. Then I thought about making this spinning wheel, and after it was functioning in qb45 I discovered qb64. Then realized I had a mess of a program because I was just piling on new aspects and stretching the project towards something I had no intention of when it started. So anyway, here's a silly project that is full of messy programming. You can just watch it or hit a key to stop the wheel when you want.
Later on I might do this again properly (with neat and organized coding) and make an actual game out of it. We'll see. For now I'll be going through some qb64 tutorials.
Cheers
James
Edit: updated zip file, hopefully the graphics work now in this arrangement
Also I have no idea how these uploads work. The ones I've looked at show the program and a convenient "copy" feature seemingly built in to this forum. I guess I need the 101 on that topic.
![[Image: lunar-lander-bloatware-v0-64.png]](https://i.ibb.co/y6zmrZL/lunar-lander-bloatware-v0-64.png)
