Login

madscijr · (This post was last modified: 07-20-2022, 05:42 AM by madscijr.)

I took the 30 line game by BPlus and force fed it, and now it's 1500+ lines!

It's still not Atari Lunar Lander, but getting there...!

My current challenge is doing sound effects from code without resorting to using separate sound files. The rocket sounds keep playing after the player stops pressing keys. How to make it stop?

Enjoy

Code: (Select All)
' Looney Lander 1562 LOC, v0.33, mostly by madscijr

' based on b+ Lander 30 LOC (double parking cheat) 2020-11-13

' BPlus proggies > Lander

' https://staging.qb64phoenix.com/showthread.php?tid=162&page=3&highlight=Lander

' 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, fuel, etc. on screen

' 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.

' TODO:

' Better (graphic) display for fuel gauge, air speed, etc.

' If speed too fast, display in a different color or graphically warn player.

' Sound effects: engines, crash, warning beeps (low fuel, moving too fast, etc.)

' Simplify flames? Just draw a couple of lines instead of semicircles?

' Change surface of moon to vector lines.

' Map entire moon and scroll horizontally as lander drifts towards edges of screen.

' Zoom in as lander gets close to surface.

' Stars "cheap planetarium"

' Track + display oxygen

' Meteorites, UFOs + other phenomena

' Support game controllers?

' Get out and walk on the moon, collect rocks, meet moonmen, blast back off, rendevous, go home, splashdown, etc.

' Various missions - land, explore, take readings, rescue, salvage, mining, combat, set up moonbase, etc.

' 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

' 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

' ENABLE / DISABLE DEBUG CONSOLE

Dim Shared m_bDebug As Integer: m_bDebug = TRUE

' 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 imgMoon&

    ReDim arrMoon(-100 To 200) As Integer

    'ReDim arrMoon(-100 To 200) As Double

    Dim iHeight As Integer

    Dim dblDX As Double

    Dim dblDY As Double

    'Dim iDX As Integer

    'Dim iDY As Integer

    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 dblMinX As Double

    Dim dblMaxX As Double

    Dim dblMinY As Double

    Dim dblMaxY As Double

    Dim iFuel As Integer

    Dim iThrust As Integer

    Dim iOldThrust As Integer

    Dim bFlicker As Integer

    Dim iThrustDirection As Integer

    Dim iDrawThrust As Integer

    Dim arrThrust(0 To 7) As ThrustType

    Dim arrHeight(0 To 2) 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 bCrash As Integer: bCrash = FALSE

    Dim bQuit As Integer: bQuit = FALSE

    Dim in$

    ' 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

    ' =============================================================================

    ' INITIALIZE SCREEN

    Screen _NewImage(800, 640, 32)

    imgMoon& = _NewImage(800, 640, 32)

    ' =============================================================================

    ' START NEW GAME

    Do

        Cls

        _KeyClear

        ' -----------------------------------------------------------------------------

        ' DRAW RANDOM LUNAR SURFACE

        Randomize Timer

        iHeight = 30

        iLandingSite = RandomNumber%(-9, 108)

        For iLoop = -10 To 110

            If iLoop = iLandingSite Or 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

            arrMoon(iLoop) = iHeight

            'arrMoon(iLoop) = iHeight * 16

            DebugPrint "arrMoon(" + _Trim$(Str$(iLoop)) + " = " + _Trim$(Str$(arrMoon(iLoop)))

            _PutImage , 0, imgMoon&

        Next iLoop

        DebugPrint "--------------------------------------------------------------------------------"

        ' -----------------------------------------------------------------------------

        ' SCREEN BOUNDARIES

        intMinX = -2

        intMaxX = 101

        intMinY = 0

        intMaxY = 39

        dblMinX = intMinX * 8

        dblMaxX = intMaxX * 8

        dblMinY = intMinY * 8

        dblMaxY = intMaxY * 8 ' 622

        ' -----------------------------------------------------------------------------

        ' PUT LANDER IN ORBIT

        dblX = RandomNumber%(intMinX, intMaxX) * 8

        dblY = intMinY * 16

        dblDX = 0.0

        dblDY = 0.5

        iFuel = iStartFuel

        iThrust = 0

        iOldThrust = 0

        bFlicker = FALSE

        iThrustDirection = cNone

        iDrawThrust = 0

        bCrash = FALSE

        ' -----------------------------------------------------------------------------

        ' CONFIGURE PRINTING FOR _PrintString

        _PrintMode _FillBackground

        '_PrintMode _KEEPBACKGROUND

        ' -----------------------------------------------------------------------------

        ' MAIN LOOP

        While TRUE = TRUE

            ' REDRAW MOON

            _PutImage , imgMoon&, 0

            ' 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

            Color cWhite

            PrintAt 1, 1, "Velocity X: " + Left$(DblRoundedToStr$(dblDX, 3), 5) + "     "

            PrintAt 1, 20, "Latitude  : " + cstr$(iX) + "     " '+ Left$(DblRoundedToStr$(dblX, 3), 5) + "     "

            PrintAt 3, 1, "Velocity Y: " + Left$(DblRoundedToStr$(dblDY, 3), 5) + "     "

            PrintAt 3, 20, "Altitude  : " + cstr$(iY) + "     " '+ Left$(DblRoundedToStr$(dblY, 3), 5) + "     "

            Color cGray

            PrintAt 5, 20, "Surface   : " + _Trim$(Str$(arrMoon(iX - 1)))

            PrintAt 6, 20, "            " + _Trim$(Str$(arrMoon(iX)))

            PrintAt 7, 20, "            " + _Trim$(Str$(arrMoon(iX + 1)))

            Color cYellow

            If iFuel > 0 Then

                PrintAt 9, 1, "Fuel      : " + _Trim$(Str$(iFuel))

            Else

                PrintAt 9, 1, "Fuel      : EMPTY"

            End If

            Color cCyan

            PrintAt 11, 1, "Controls  : " + sKey

            Color cDodgerBlue

            PrintAt 1, 40, Chr$(34) + "One Small Step" + Chr$(34)

            Color cMagenta

            PrintAt 4, 40, "Land on an even surface."

            PrintAt 2, 40, "Arrow keys: select which rocket engine, up slows descent."

            PrintAt 3, 40, "1-7   keys: fire thrusters, 1=lightest, 7=heaviest."

            Color cLime

            PrintAt 5, 40, "Maximum x velocity: " + Left$(DblRoundedToStr$(dblMinSpeedX, 3), 5) + "     "

            PrintAt 6, 40, "Maximum y velocity: " + Left$(DblRoundedToStr$(dblMinSpeedY, 3), 5) + "     "

            Color cMagenta

            PrintAt 7, 40, "Good Luck!"

            ' 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

            ' THRUST (CURRENTLY ONLY BOTTOM ENGINE)

            If iThrust > 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 = iThrust

                    Else

                        iDrawThrust = arrThrust(iThrust).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

            ' div: int1% = num1% \ den1%

            ' mod: rem1% = num1% MOD den1%

            ' -----------------------------------------------------------------------------

            ' HAS LANDER TOUCHED THE SURFACE OR WENT BACK INTO SPACE?

            ' 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 cLime

                        PrintAt 20, 50, "That's one small step for (wo)man kind!"

                        Exit While

                    Else

                        ' TOO FAST HORIZONTALLY

                        bCrash = TRUE

                    End If

                Else

                    ' TOO FAST VERTICALLY

                    bCrash = TRUE

                End If

                ' DID WE LAND ON UNEVEN SURFACE?

            ElseIf iY = arrHeight(0) Or iY = arrHeight(1) Or iY = arrHeight(2) Or iY > intMaxY Then

                ' CRASHED ON UNEVEN SURFACE

                bCrash = TRUE

                ' DID WE LEAVE THE MOON'S ORBIT?

            ElseIf iY < intMinY Then

                ' FLEW OFF INTO SPACE

                Color cCyan

                PrintAt 20, 50, "Lost in space!"

                _KeyClear: _Delay 2

                Exit While

            End If

            ' EXIT IF WE CRASHED

            If bCrash = TRUE Then

                Color cRed

                PrintAt 20, 50, "Crash!"

                Exit While

            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 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

            ' -----------------------------------------------------------------------------

            ' Get power level (1=weakest, 7=strongest)

            If iThrustDirection <> cNone Then

                If _Button(KeyCode_1%) Then

                    iOldThrust = iThrust: iThrust = 1: sKey = sKey + "1,"

                ElseIf _Button(KeyCode_2%) Then

                    iOldThrust = iThrust: iThrust = 2: sKey = sKey + "2,"

                ElseIf _Button(KeyCode_3%) Then

                    iOldThrust = iThrust: iThrust = 3: sKey = sKey + "3,"

                ElseIf _Button(KeyCode_4%) Then

                    iOldThrust = iThrust: iThrust = 4: sKey = sKey + "4,"

                ElseIf _Button(KeyCode_5%) Then

                    iOldThrust = iThrust: iThrust = 5: sKey = sKey + "5,"

                ElseIf _Button(KeyCode_6%) Then

                    iOldThrust = iThrust: iThrust = 6: sKey = sKey + "6,"

                ElseIf _Button(KeyCode_7%) Then

                    iOldThrust = iThrust: iThrust = 7: sKey = sKey + "7,"

                Else

                    iOldThrust = 0: iThrust = 0: bFlicker = FALSE

                End If

            Else

                iOldThrust = 0: iThrust = 0: bFlicker = FALSE

            End If

            ' -----------------------------------------------------------------------------

            ' Fire the engines

            If iThrust > 0 Then

                ' Make sure we have enough fuel for thrust level.

                ' (Else adjust based on available fuel.)

                For iLoop = iThrust To 0 Step -1

                    If iFuel >= arrThrust(iLoop).FuelUsed Then

                        iThrust = iLoop

                        Exit For

                    End If

                Next iLoop

                ' If we had enough fuel that engines are firing

                If iThrust > 0 Then

                    ' Consume fuel

                    iFuel = iFuel - arrThrust(iLoop).FuelUsed

                    ' Apply force

                    If iThrustDirection = cLeft Then

                        dblDX = dblDX - arrThrust(iThrust).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(iThrust).Power

                        'SLIME_BAS_SOUND_11

                    ElseIf iThrustDirection = cUp Then

                        dblDY = dblDY - arrThrust(iThrust).Power

                        'SLIME_BAS_SOUND_11

                    ElseIf iThrustDirection = cDown Then

                        dblDY = dblDY + arrThrust(iThrust).Power

                        'snatch_bas_sound_6

                        ''SLIME_BAS_SOUND_11

                    End If

                    ' Animate the rocket flames

                    If iThrust = iOldThrust Then bFlicker = Not (bFlicker)

                Else

                    ' Engines off

                    iOldThrust = 0: bFlicker = FALSE

                End If

            End If

            ' -----------------------------------------------------------------------------

            ' MOVE LANDER

            dblX = dblX + dblDX

            dblY = dblY + dblDY

            ' -----------------------------------------------------------------------------

            ' CONTROL GAME SPEED

            _Limit iFPS

            '_Limit 2

            '_Limit 30

        Wend

        ' PLAY ANOTHER ROUND OR QUIT?

        If bQuit = FALSE Then

            _KeyClear: _Delay 1: Sleep

        Else

            Exit Do

        End If

    Loop

End Sub ' main

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

' 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#)

    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

        DblToStr$ = value$

        Exit Function

    End If

    DblToStr$ = _Trim$(sign$ + DP$ + min$ + num$ + add$)

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$

' /////////////////////////////////////////////////////////////////////////////

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 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%

SierraKen · 07-20-2022, 04:08 PM

LOL that is fun! For the sound, you might want to try short bursts of sound if it's possible. Or use the PLAY command to play an A note at 16 or 32. https://qb64phoenix.com/qb64wiki/index.php/PLAY

There might be other ways to do it too, I know that I use Dav's chimes for my clock that doesn't use either of those, it uses the _SndRawLen, _SndRaw, and _SndRate commands that I still have to figure out myself.

madscijr · 07-20-2022, 06:32 PM

(07-20-2022, 04:08 PM)SierraKen Wrote: LOL that is fun! For the sound, you might want to try short bursts of sound if it's possible. Or use the PLAY command to play an A note at 16 or 32. https://qb64phoenix.com/qb64wiki/index.php/PLAY

There might be other ways to do it too, I know that I use Dav's chimes for my clock that doesn't use either of those, it uses the _SndRawLen, _SndRaw, and _SndRate commands that I still have to figure out myself.

I saw those _SndRaw commands, briefly played with them, and didn't get too far.
It does look like it gives you low-level control, and I will spend more time reading about it.
Sound is one of those areas of QB64 that I need to learn more about. I would like to see the language expanded with higher level commands that let you have more control over audio, but maybe some of that functionality is already present. I need to study some _SndRaw examples and see what it can do...

SierraKen · (This post was last modified: 07-20-2022, 06:48 PM by SierraKen.)

Here is one of my simple clocks using Dav's chimes. The chimes section is towards the bottom. When you run it, press the Space Bar to hear the chimes anytime. They also play at the top of the hour.

Code: (Select All)
_Title "Clock by Ken G."

Screen _NewImage(350, 350, 32)

_Limit 500

Do

    a$ = InKey$

    If a$ = " " Then chimes = 1

    Circle (180, 184), 140, _RGB32(127, 249, 255)

    hours = Timer \ 3600

    minutes = Timer \ 60 - hours * 60

    seconds = (Timer - hours * 3600 - minutes * 60)

    ho$ = Left$(Time$, 2): hou = Val(ho$)

    min$ = Mid$(Time$, 4, 2): minu = Val(min$)

    seco$ = Right$(Time$, 2): secon = Val(seco$)

    'Minutes

    m = 180 - minutes * 6

    xx = Int(Sin(m / 180 * 3.141592) * 120) + 180

    yy = Int(Cos(m / 180 * 3.141592) * 120) + 184

    For b = -5 To 5 Step .1

        Line (180 + b, 184)-(xx, yy), _RGB32(0, 255, 255)

        Line (180, 184 + b)-(xx, yy), _RGB32(0, 255, 255)

    Next b

    'Hours

    h = 360 - hours * 30 + 180

    xxx = Int(Sin(h / 180 * 3.141592) * 100) + 180

    yyy = Int(Cos(h / 180 * 3.141592) * 100) + 184

    For b = -5 To 5 Step .1

        Line (180 + b, 184)-(xxx, yyy), _RGB32(0, 255, 0)

        Line (180, 184 + b)-(xxx, yyy), _RGB32(0, 255, 0)

    Next b

    'Seconds

    s = (60 - seconds) * 6 + 180

    x = Int(Sin(s / 180 * 3.141592) * 125) + 180

    y = Int(Cos(s / 180 * 3.141592) * 125) + 184

    For b = -5 To 5 Step .1

        Line (180 + b, 184)-(x, y), _RGB32(255, 0, 0)

        Line (180, 184 + b)-(x, y), _RGB32(255, 0, 0)

    Next b

    'Dav's Chimes

    If (minu = 0 And secon = 0) Or chimes = 1 Then

        hour2 = hou

        If hour2 > 12 Then hour2 = hour2 - 12

        If hour2 = 0 Then hour2 = 12

        For chimes = 1 To hour2

            ttt = 0

            Do

                'queue some sound

                Do While _SndRawLen < 0.1 'you may wish to adjust this

                    sample = Sin(ttt * 340 * Atn(1) * 8) '340Hz sine wave (ttt * 440 * 2p)

                    sample = sample * Exp(-ttt * 3) 'fade out eliminates clicks after sound

                    _SndRaw sample

                    ttt = ttt + 1 / _SndRate 'sound card sample frequency determines time

                Loop

                'do other stuff, but it may interrupt sound

            Loop While ttt < 2 'play for 2 seconds

            Do While _SndRawLen > 0 'Finish any left over queued sound!

            Loop

        Next chimes

    End If

    chimes = 0

    two:

    _Display

    Cls

Loop

vince · 07-21-2022, 01:50 AM

Does B+ also have a lunar lander or is it a JB original?

madscijr · (This post was last modified: 07-21-2022, 02:10 AM by madscijr.)

(07-21-2022, 01:50 AM)vince Wrote: Does B+ also have a lunar lander or is it a JB original?

I link to BPlus' 30-line original in the comments at the top of my code ^^^

Here's the original:

BPlus proggies > Lander

https://staging.qb64phoenix.com/showthre...ght=Lander

https://staging.qb64phoenix.com/showthread.php?tid=443

bplus Wrote:

Quote: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.

madscijr · 07-21-2022, 06:16 PM

(07-20-2022, 06:47 PM)SierraKen Wrote: Here is one of my simple clocks using Dav's chimes. The chimes section is towards the bottom. When you run it, press the Space Bar to hear the chimes anytime. They also play at the top of the hour.

Thanks! The fade out that eliminates the clicks after the sound is helpful.

I see the comment "do other stuff, but it may interrupt sound" which leads to my next question -
if it's a sound effect for a game, where we're constantly redrawing the screen, reading the keyboard for input, and making calculations,
the sound effects need to be asynchronous. How do we get it to NOT interrupt the sound?
When the player lets go of the "thrust" button, the engine sound should stop immediately, without any clicks.

Here's my test harness where I am playing with your "chimes" code:

Code: (Select All)
' SierraKen

' Here is one of my simple clocks using Dav's chimes.

' The chimes section is towards the bottom.

' When you run it, press the Space Bar to hear the chimes anytime.

' They also play at the top of the hour.

' https://staging.qb64phoenix.com/showthread.php?tid=654&pid=4228#pid4228

_Title "Chimes #1"

' BOOLEAN CONSTANTS

Const FALSE = 0

Const TRUE = Not FALSE

Dim HZ&

Dim iCount%

Dim iIncrement&

Dim iDirection&

Dim iMinHZ&

Dim iMaxHZ&

Dim bQuit%

iCount% = 0

iMinHZ& = 1

iMaxHZ& = 20000

iMinInc& = 1

iMaxInc& = 16384

iIncrement& = 40

iDirection& = 1

HZ& = iMinHZ& ' start at 128 Hz

'HZ& = 340 ' 340Hz

bQuit% = FALSE

_Limit 500

Do

    iCount% = iCount% + 1

    HZ& = HZ& + (iIncrement& * iDirection&)

    ttt = 0

    Cls

    Print "_SndRaw experiment based on Clock by SierraKen"

    Print

    Print "Chime #" + _Trim$(Str$(iCount%))

    Print

    Print "Frequency = " + _Trim$(Str$(HZ&)) + " Hz"

    Print "Increment = " + _Trim$(Str$((iIncrement& * iDirection&))) + " Hz"

    Print "Min freq  = " + _Trim$(Str$(iMinHZ&)) + " Hz"

    Print "Max freq  = " + _Trim$(Str$(iMaxHZ&)) + " Hz"

    Print

    Print "Press 1 to decrease frequency increment by 5."

    Print "Press 2 to increase " + Chr$(34) + " " + Chr$(34)

    Print

    Print "Press Esc to quit."

    Do

        GoSub GetInput

        ' queue some sound

        Do While _SndRawLen < 0.1 ' you may wish to adjust this

            sample = Sin(ttt * HZ& * Atn(1) * 8) ' HZ% HZ sine wave (ttt * 440 * 2p)

            sample = sample * Exp(-ttt * 3) ' fade out eliminates clicks after sound

            _SndRaw sample

            ttt = ttt + 1 / _SndRate ' sound card sample frequency determines time

        Loop

        ' do other stuff, but it may interrupt sound

    Loop While ttt < 2 ' play for 2 seconds

    Do While _SndRawLen > 0 ' Finish any left over queued sound!

        GoSub GetInput

    Loop

    If HZ& < iMinHZ& Or HZ& > iMaxHZ& Then

        iDirection& = iDirection& * -1

    End If

    _KeyClear: '_DELAY 1

    If bQuit% = TRUE Then Exit Do

Loop

End

GetInput:

sKey$ = InKey$

If sKey$ = Chr$(27) Then

    bQuit% = TRUE

ElseIf sKey$ = "1" Then

    iIncrement& = iIncrement& - 5: If iIncrement& < iMinInc& Then iIncrement& = iMinInc&

ElseIf sKey$ = "2" Then

    iIncrement& = iIncrement& + 5: If iIncrement& > iMaxInc& Then iIncrement& = iMaxInc&

End If

Return

' /////////////////////////////////////////////////////////////////////////////

Sub PrintAt (iRow%, iCol%, sText$)

    '_PrintString (iCol% * 8, iRow% * 16), sText$

    _PrintString (iCol% * 8, iRow% * 16), sText$

    '_PrintString (iCol%, iRow%), sText$

End Sub ' PrintAt

SierraKen · 07-21-2022, 08:17 PM

Neat little experiment.

Yeah I think the PLAY command might be the only one that can play while the code keeps going. It uses the MB command inside the PLAY command to tell it to play that way. Here is an example I just made. MB sets it to play while it keeps going and the letters are the sound notes and the numbers are the duration of each note.

You also can see many other commands that PLAY has here. There might be a way to make a ship sound with it, not sure.
https://qb64phoenix.com/qb64wiki/index.php/PLAY

Code: (Select All)
Do

    t = t + 1

    Print t

    Play "MB a16b16c16d16e16f16g16"

Loop

SierraKen · 07-21-2022, 08:23 PM

This might be a good engine sound, you can play around with it. The << sets the octave 2 times lower.

Code: (Select All)
Do

    t = t + 1

    Print t

    Play "MB <<g32"

Loop

mnrvovrfc

(07-21-2022, 08:23 PM)SierraKen Wrote: This might be a good engine sound, you can play around with it. The << sets the octave 2 times lower.

Code: (Select All)
Do t = t + 1 Print t Play "MB <<g32" Loop

I might be mistaken but "PLAY" and "SOUND" are part of the deal for QB64 to emulate M$QB and GW-BASIC as closely as possible. Especially people using the latter product entirely expected sounds playing while doing something else such as keyboard input. It was crucial for those who were able to program impressive text-mode animations while complex music arrangements were being played.

You're better off at least using "_SNDOPEN", "_SNDPLAY", "_SNDSTOP", "_SNDVOL", "_SNDPLAYING" and "_SNDCLOSE", with external audio files. They could be in MP3 or OGG format which could be very small if one-channel and maybe 22050Hz sampling rate. Might want to take advantage of "_INFLATE" and "_MEMSOUND" to even include such a file into your source code. Otherwise "_SNDRAW" is the only way to start and stop sound at will.

I have to check out "_MEMSOUND" myself, but I'm not very comfortable programming for the "_MEM" gang. That statement is a lot like "Catchsound" in Purebasic, made it rather easy to bind media files into an EXE file. Sadly it might be for Windows only unless QB64 could recognize "zlib" on Linux.

EDIT: Uh about the code above, what is done with "t"? Because it's an endless loop.

Login
Username/Email:
Password:	Lost Password?
	Remember me