I don't like this "Moved"! There's a better way for threads that get out of hand.
There used to be a forum called Antivegan here. The name speaks for itself. There was no registration and no censorship. It was about ideology, and often the scraps flew.
In the forum there was a subforum Names garbage can. There came in all the threads the came out of controll. It was really rough there, but it was often funny too.
In my personal opinion, this was the best solution without censorship that I have seen to date.
The forum no longer exists since 2020/2021 because the anti-vegans have practically won each other to death. Yes, really! The opponents all went down somehow.
Of course there are still vegans, but not this one anymore.
What I want to say is, couldn't we also create a garbage can here - open, without a password?
This one is kind of neat, looks like it lets you draw a sound waveform and plays it.
Code: (Select All)
' QB64 - A tech demo where one can move the mouse to alter the _SNDRAW waveform (self.QBprograms)
' https://www.reddit.com/r/QBprograms/comments/t9477v/a_tech_demo_where_one_can_move_the_mouse_to_alter/
' submitted 4 months ago by SupremoZanne
' https://www.reddit.com/user/SupremoZanne
_Title "waveform line demo" ' made for QB64
Dim xx(1100)
Screen _NewImage(1100, 300, 13)
Do
If InKey$ <> "" Then
For vv = 1 To 100
PSet (Rnd * 1100, Rnd * 300) 'press any key to splatter pixels
Next
End If
While _MouseInput 'move mouse to form soundwave
x = _MouseX
y = _MouseY
Wend
x2 = x
y2 = y
For xz = x1 To x2
xx(x) = y
Line (xz, 0)-(xz, 300), 0
Next
Line (x1, y1)-(x2, y2)
For z = 1 To 1100
For y3 = 1 To 300
If Point(z, y3) = 15 Then
zzt = y3
GoTo 1
End If
Next
1
_SndRaw y3 / 350
Next
While _SndRawLen
Wend
y1 = y2
x1 = x2
Loop
Screen _NewImage(xmax, ymax, 32)
_Title "Wavy Persian Carpets by bplus, press spacebar to wave another"
xo = (xmax - W) / 2: yo = (ymax - H) / 2
lft = xo: rght = W + xo: top = yo: bot = H + yo
While 1
ReDim carpet&(W, H)
r& = _RGB(Rnd * 200 + 55, Rnd * 200 + 55, Rnd * 200 + 55)
Line (lft, top)-(rght, top), r&
Line (lft, bot)-(rght, bot), r&
Line (lft, top)-(lft, bot), r&
Line (rght, top)-(rght, bot), r&
DetermineColor lft, rght, top, bot
_Display
For y = 0 To H
For x = 0 To W
carpet&(x, y) = Point(xo + x, yo + y)
Next
Next
'check point worked
Cls
Print "Check graphic, press any (except spacebar) to continue..."
For y = 0 To H
For x = 0 To W
PSet (x + 100, y + 100), carpet&(x, y)
Next
Next
_Display
Sleep
da# = _Pi(2) / 30: aInc# = _Pi(2) / 50: a# = 0
bOrbit! = .1: br! = 4: spacer = 5: walk! = 0: dir = 1
While 1
If _KeyHit = 32 Then Exit While
a# = a# + aInc#
bOrbit! = bOrbit! + .1 * dir
If bOrbit! >= 15.1 Then bOrbit! = 15.0: dir = dir * -1
If bOrbit! <= 0 Then bOrbit! = .1: dir = dir * -1
Cls
For y = 0 To H
For x = 0 To W
bAngle# = (x + y) * da# + a#
xBall = (2 * Sin(bAngle#) + Cos(bAngle#)) / 2 * bOrbit! + x * spacer
yBall = (Cos(bAngle#) + Sin(bAngle#)) / 2 * bOrbit! + y * spacer
Color carpet&(x, y)
fcirc (xBall + 10 + walk!) Mod (xmax + 640), (yBall + 10 + .12 * walk!) Mod (ymax + 640), br!
Next
Next
walk! = walk! + .1 * bOrbit!
_Display
_Limit 60
Wend
Wend
Rem Determine the color based on function f, and draw cross in quadrant
Sub DetermineColor (lft, rght, top, bot)
If (lft < rght - 1) Then
middlecol = Int((lft + rght) / 2)
middlerow = Int((top + bot) / 2)
c& = f&(lft, rght, top, bot)
Line (lft + 1, middlerow)-(rght - 1, middlerow), c&
Line (middlecol, top + 1)-(middlecol, bot - 1), c&
DetermineColor lft, middlecol, top, middlerow
DetermineColor middlecol, rght, top, middlerow
DetermineColor lft, middlecol, middlerow, bot
DetermineColor middlecol, rght, middlerow, bot
Else
Exit Sub
End If
End Sub
'create 4x4x4 very bright contrasting colors
Function f& (lft, rght, top, bot)
p& = Point(lft, top) + Point(rght, top) + Point(lft, bot) + Point(rght, bot)
If _Red32(p&) / 255 < .25 Then
r% = 0
ElseIf _Red32(p&) / 255 < .5 Then
r% = 128
ElseIf _Red32(p&) / 255 < .75 Then
r% = 192
Else
r% = 255
End If
If _Green32(p&) / 255 < .25 Then
g% = 0
ElseIf _Green32(p&) / 255 < .5 Then
g% = 128
ElseIf _Green32(p&) / 255 < .75 Then
g% = 192
Else
g% = 255
End If
If _Blue32(p&) / 255 < .5 Then
b% = 0
ElseIf _Blue32(p&) / 255 < .5 Then
b% = 128
ElseIf _Blue32(p&) / 255 < .75 Then
b% = 192
Else
b% = 255
End If
f& = _RGB(r, g, b)
End Function
'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long
subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0
If subRadius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End Sub
In looking for a way to make a cool rumbling sound for my Lunar Lander game
(I want it to sound like the 1979 Atari Lunar Lander & Asteroids games)
I came across some code at a Japanese site (thank the maker for Google translate)
which made a sound, so I just made a loop that changes some parameters
to see what kind of sounds come from different numbers.
Here is the code in case anyone is curious.
Code: (Select All)
' A _SndRaw experiment
' based on code by Senji Niban, 2/4/2016, at senjiniban-hatenablog.com
' Modified by madscijr, 7/21/2022
'
' --------------------------------------------------------------------------------
' "Keep it simple, Stupid!" Again (2016-02-02) (senjiniban-hatenablog.com)
' https://senjiniban-hatenablog-com.translate.goog/?page=1454854659&_x_tr_sl=ja&_x_tr_tl=en&_x_tr_hl=en&_x_tr_pto=sc
'
' From Senji Niban, 2/4/2016
'
' Tags: FORTH QB64 QuickBasic
'
' I'm always saying that I'm just doing it, so I'd like you to listen to it in
' half the story, but I've become quite fond of QB64, and I may make an app with
' this.
' Even if I used to do Baisc programs in earnest, I think that QuickBasic
' compatibility is quite unreasonable to work on programs in earnest nowadays,
' and in fact it is a premise to do Python etc. in parallel, but something this
' source I feel that the condition that comes into my head is very irresistible.
' You may have read this article before.
' postd.cc
' When I looked at the program below, I thought that there was nothing I couldn't
' understand compared to other languages. It's as simple as trying to make a
' sound with a microcomputer , and it feels like you can see the operation of the
' CPU rather than calling a sound-related class in an object language.
' --------------------------------------------------------------------------------
' NOTE: There were no Dim statements so I'm not sure what types these should be.
' I tried dimming the variables based on what docs I could find
' and it stopped working, so for now no variables are explicitly declared.
FREQ = 400 ' any frequency desired from 36 to 10,000 Pi2
Pi2 = 8 * Atn(1) ' 2 * pi
Amplitude = .3 ' amplitude of the signal from --1.0 to 1.0
Amplitude = -1
iSeconds% = 5
iSeconds% = 2
Do
FREQ = FREQ + 200
Amplitude = Amplitude + 0.3 ' amplitude of the signal from --1.0 to 1.0
SampleRate = _SndRate ' sets the sample rate
FRate = FREQ / SampleRate
For Duration = 0 To iSeconds% * SampleRate ' play 5 seconds
_SndRaw Amplitude * Sin(Pi2 * Duration * FRate) ' sine wave
Next Duration
Do: Loop While _SndRawLen
Loop Until InKey$ <> ""
End
' Speaking of seeing the operation of the CPU, with QB64, PEEK and POKE could
' also be used to directly access the memory. Actually, although it is said to be
' simple, if the execution environment is dropped, it is about 100M, and as I
' wrote last time, it is compatible with OpenGL and networks, so it may not be so
' simple, but after all it is Basic in terms of language specifications. I don't
' think it's suitable for writing huge programs. However, the low hurdle due to
' this simplicity is very big. As Chuck Moore, who made Forth, is proud of the
' size of the sauce, it is nonsense, and a compact sauce for a single purpose
' would be good. Moore says "1 mega is enough". However, the exe file that QB64
' spits out is a little larger than one floppy disk. Lately, I wanted to make an
' app with a program, but I couldn't imagine what it would be like, and I was
' sick of it, but the "SHOOTING SIXTEEN" made with QuickBasic (although it
' doesn't move) is quite tiny . Looking at Zebius , I'm wondering if I should
' make a very simple tool for doing what I want to do.
Been working on a new version of my grain harvest database, and while building a support file editing section, I conceived of the need to quickly and easily display a row of button choices, along with the ability to accept hotkeys in lieu of mouse clicks.
It depends upon a few of my other library routines (included in the code), but anything could be easily adapted. I'm particularly indebted to Steve for his MBS function and SierraKen for his beveled calculator button algorithm.
Code: (Select All)
'Button & hotkey choosing routine. FUNCTION Chs_Key_Button% Coding by OldMoses
'supporting subroutines by Steve McNeill & SierraKen
'chose from aligned and identically sized and spaced controls in
'vertical or horizontal orientation, or use hotkeys
'Esc keypress returns -1
SCREEN _NEWIMAGE(1024, 512, 32)
DIM lbl(7) AS STRING '
DIM ani(5) AS STRING
lbl(1) = "One": lbl(2) = "Two": lbl(3) = "Three": lbl(4) = "Four": lbl(5) = "Five": lbl(6) = "Six": lbl(7) = "Seven"
ani(1) = "Dog": ani(2) = "Cat": ani(3) = "Horse": ani(4) = "Frog": ani(5) = "Jerk"
DO
CLS
scene% = scene% + 1
SELECT CASE scene%
CASE 1
x% = _SHR(_WIDTH(0), 1) ' screen centered (512,256), seven horizontal buttons
y% = _SHR(_HEIGHT(0), 1): w% = 60: h% = 32: sp% = 4: it% = 7
cho% = Chs_Key_Button%("1234567", "h", y%, it%, w%, h%, sp%, x%, lbl())
IF cho% > 0 THEN x$ = lbl(cho%)
CASE 2
x% = _SHR(_WIDTH(0), 1) ' screen centered (512,256), four horizontal buttons
y% = _SHR(_HEIGHT(0), 1): w% = 60: h% = 32: sp% = 20: it% = 4
cho% = Chs_Key_Button%("DCHF", "h", y%, it%, w%, h%, sp%, x%, ani())
IF cho% > 0 THEN x$ = ani(cho%)
CASE 3
x% = _SHR(_WIDTH(0), 2) ' screen left quarter (256,256), four vertical buttons
y% = _SHR(_HEIGHT(0), 1): w% = 60: h% = 32: sp% = 16: it% = 4
cho% = Chs_Key_Button%("1234", "v", x%, it%, w%, h%, sp%, y%, lbl())
IF cho% > 0 THEN x$ = lbl(cho%)
CASE 4
x% = _SHR(_WIDTH(0), 2) * 3 ' screen right quarter (768,256), four vertical buttons
y% = _SHR(_HEIGHT(0), 1): w% = 60: h% = 32: sp% = 16: it% = 5
cho% = Chs_Key_Button%("DCHFJ", "v", x%, it%, w%, h%, sp%, y%, ani())
IF cho% > 0 THEN x$ = ani(cho%)
CASE 5
x% = 137 ' upper right corner (137,20), five horizontal buttons
y% = 20: w% = 50: h% = 50: sp% = 6: it% = 5
cho% = Chs_Key_Button%("12345", "h", y%, it%, w%, h%, sp%, x%, lbl())
IF cho% > 0 THEN x$ = lbl(cho%)
END SELECT
LOCATE 1, 1
SELECT CASE cho%
CASE -1: EXIT DO
CASE ELSE: PRINT "You chose "; _TRIM$(x$); ";";
END SELECT
PRINT " press any key to continue"
SLEEP
IF scene% = 5 THEN scene% = 0
LOOP
END
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
'vchr: string of valid hotkey characters
'ori: "v" = vertical buttons "h" = horizontal buttons (anything other than 'v' will work for horizontal)
'ledgr: upper y edge of horizontal buttons, or left x edge of vertical buttons
'bl: number of buttons displayed
'bw: button pixel width
'bh: button pixel height
'space: space in pixels between buttons
'cent: center point of buttons in x for horizontal or y for vertical
FUNCTION Chs_Key_Button% (vchr AS STRING, ori AS STRING, ledgr AS INTEGER, bl AS INTEGER, bw AS INTEGER, bh AS INTEGER, space AS INTEGER, cent AS INTEGER, array() AS STRING)
m% = bw: n% = bh ' duplicate for Con_Blok before possible swap
IF ori = "v" THEN ' flip the axes for vertical orientation
hpos% = ledgr
vpos% = cent - _SHR(bh * bl + space * (bl - 1), 1)
hstp% = 0: vstp% = space + bh
SWAP bw, bh
ELSE
hpos% = cent - _SHR(bw * bl + space * (bl - 1), 1)
vpos% = ledgr
hstp% = space + bw: vstp% = 0
END IF
FOR a% = 0 TO bl - 1 ' Display buttons
Con_Blok hpos% + a% * hstp%, vpos% + a% * vstp%, m%, n%, _TRIM$(array(a% + 1)), 0, &HFF7F7F7F
NEXT a%
DO ' Choosing loop section
k$ = UCASE$(INKEY$)
IF k$ <> "" THEN
IF k$ = CHR$(27) THEN ' esc to abort, returning -1
choice% = -1: in% = -1
ELSE
choice% = INSTR(vchr, k$)
IF choice% <> 0 THEN in% = -1 ' if valid char then return with its index
END IF
END IF
ms = MBS
IF ms AND 1 THEN ' left mouse button clicked
Clear_MB 1 ' clear the mouse click
x% = _MOUSEX: y% = _MOUSEY ' we don't want to use mouse position directly
IF ori = "v" THEN SWAP x%, y% ' flip the axes for vertical orientation
rowrange% = _SHR(bh, 1) + ledgr ' this marks the center of button row
IF ABS(y% - rowrange%) < _SHR(bh, 1) THEN ' are we within the row of buttons
odd% = (bl MOD 2 <> 0) ' is there an odd number of buttons
full% = space + bw ' control width + space between
hfsp% = _SHR(space, 1) ' half space
hfbt% = _SHR(bw, 1) ' half button width
FOR z% = 1 TO bl
IF odd% THEN
md% = z% - _CEIL(bl / 2) ' midpoint multiplier, center button on 0
ps% = -(md% * full%) * (md% <> 0)
ELSE
md% = z% - INT(bl / 2) + (SGN(z% - INT(bl / 2)) < 1)
ps% = SGN(md%) * ((ABS(md%) - 1) * full% + _SHR(full%, 1))
END IF
IF ABS(x% - (cent + ps%)) < hfbt% THEN 'use ps% offset from center to position specific button ranges
choice% = z%: in% = -1
END IF
NEXT z%
'alternate code- replacing FOR z%...NEXT block above; both seem to work equally well
'IF odd% THEN
' start% = cent - full% * ((bl - 1) / 2) - hfbt%
'ELSE
' start% = cent - full% * (bl / 2 - 1) - (bw + hfsp%)
'END IF
'FOR z% = 1 TO bl
' md% = start% + (z% - 1) * full% + hfbt%
' IF ABS(x% - md%) < hfbt% THEN
' choice% = z%: in% = -1
' END IF
'NEXT z%
END IF ' end: if within row
END IF ' end: if left mouse click
_LIMIT 30
LOOP UNTIL in%
Chs_Key_Button% = choice%
END FUNCTION 'Chs_Key_Button%
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²² coding by Steve McNeill
FUNCTION MBS%
STATIC StartTimer AS _FLOAT
STATIC ButtonDown AS INTEGER
'STATIC ClickCount AS INTEGER
CONST ClickLimit## = .4 'Less than 1/2 of a second to down, up a key to count as a CLICK.
' Down longer counts as a HOLD event.
SHARED Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
WHILE _MOUSEINPUT 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
SELECT CASE SGN(_MOUSEWHEEL)
CASE 1: tempMBS = tempMBS OR 512
CASE -1: tempMBS = tempMBS OR 1024
END SELECT
WEND
IF _MOUSEBUTTON(1) THEN tempMBS = tempMBS OR 1
IF _MOUSEBUTTON(2) THEN tempMBS = tempMBS OR 2
IF _MOUSEBUTTON(3) THEN tempMBS = tempMBS OR 4
IF StartTimer = 0 THEN
IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
ButtonDown = 1: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
ELSEIF _MOUSEBUTTON(2) THEN
ButtonDown = 2: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
ELSEIF _MOUSEBUTTON(3) THEN
ButtonDown = 3: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
END IF
ELSE
BD = ButtonDown MOD 3
IF BD = 0 THEN BD = 3
IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit. It's a click
IF _MOUSEBUTTON(BD) = 0 THEN tempMBS = 4 * 2 ^ ButtonDown: ButtonDown = 0: StartTimer = 0
ELSE
IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
tempMBS = 0: ButtonDown = 0: StartTimer = 0
Mouse_EndX = _MOUSEX: Mouse_EndY = _MOUSEY
ELSE 'We've now started the hold event
tempMBS = tempMBS OR 32 * 2 ^ ButtonDown
END IF
END IF
END IF
MBS% = tempMBS
END FUNCTION 'MBS%
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Clear_MB (var AS INTEGER)
DO UNTIL NOT _MOUSEBUTTON(var)
WHILE _MOUSEINPUT: WEND
LOOP
END SUB 'Clear_MB
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²
SUB Con_Blok (xpos AS INTEGER, ypos AS INTEGER, xsiz AS INTEGER, ysiz AS INTEGER, label AS STRING, high AS INTEGER, col AS _UNSIGNED LONG)
'Create control block
CN& = _NEWIMAGE(xsiz, ysiz, 32)
_DEST CN&
COLOR , col
CLS
BevelB xsiz, ysiz, col
_PRINTMODE _KEEPBACKGROUND
x% = LEN(label)
sx = xsiz / 2 - x% * 4: sy = ysiz / 2 - 8
FOR p = 1 TO x% ' iterate through label characters
COLOR -4294901760 * (p = high) - 4278190080 * (p <> high) '&HFFFF0000 &HFF000000
IF col = &HFFC80000 THEN COLOR clr&(15)
_PRINTSTRING (sx + (p - 1) * 8, sy), MID$(label, p, 1)
NEXT p
_PUTIMAGE (xpos, ypos), CN&, A&
_FREEIMAGE CN&
END SUB 'Con_Blok
'²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²² adaptation of code by SierraKen
SUB BevelB (xsiz AS INTEGER, ysiz AS INTEGER, col AS _UNSIGNED LONG)
'Create control button bevels for 3D effect - called from Con_Blok
brdr = ABS(INT(ysiz / 4) * (ysiz <= xsiz) + INT(xsiz / 4) * (ysiz > xsiz)) 'select smaller 1/4 size border axis
FOR bb = 0 TO brdr
c = c + 100 / brdr
LINE (0 + bb, 0 + bb)-(xsiz - 1 - bb, ysiz - 1 - bb), _RGBA32(_RED32(col) - 100 + c, _GREEN32(col) - 100 + c, _BLUE32(col) - 100 + c, _ALPHA(col)), B
NEXT bb
I have a question.
My program starts with the command $RESIZE:SMOOTH in SCREEN 0 (text mode).
Everything works perfectly but if you want to maximize the screen the first row disappears. What can I do about it?
I know there is a command _FULLSCREEN _SQUAREPIXELS , _SMOOTH but I don't want it.
Here's a demo:
Code: (Select All)
$RESIZE:SMOOTH
FOR a = 1 TO 10
LOCATE a, 1: PRINT "This is line"; a;
NEXT
PRINT: PRINT "Now maximize this Window and then return to a regular Window."
PRINT "As you can see, the first two rows disappear. How to solve?"
PRINT "Press any key to quit this program"
x$ = INPUT$(1)
SYSTEM
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
' 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.
' 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
' ****************************************************************************************************************************************************************
' 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$
' =============================================================================
' 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
' 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.
' -----------------------------------------------------------------------------
' 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
' -----------------------------------------------------------------------------
' 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' 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 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
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
I am renewing my older programs. What could be the problem ? I always make programs under QB64 1.2. I tried the refurbished one
"4D maze" program and does not start on newer versions. It doesn't write an error message. windows7 says: "the program stops" ...and that's it. Does anyone know why?
Edit: You can already download Android Nim in the 2nd post below
Programming 2 games: Android Nim and Obstacle.
Android Nim was originally programmed in 1979 by Leo Christopherson on the TRS-80 model 1, 3 and 4.
And in 1981, I bought the book 'TRS-80 Programs' by Tom Rugg and Phill Feldman. There I saw the program Obstacle that I modified by adding sound, keeping scores, etc.
Today, 40 years later, both programs were reprogrammed in QB64, both completely in text-mode (screen 0).
More info when the programs are ready. Here are 2 screenshots of each program.
![[Image: Babsi-Baby.jpg]](https://i.ibb.co/DzzLy7q/Babsi-Baby.jpg)
It doesn't write an error message. windows7 says: "the program stops" ...and that's it. Does anyone know why?