Well, it's not exactly like the original Asteroids. The rocks don't break into smaller ones. I did try to make it that way, but it's a bit too advanced for my learning. Plus I don't want to make it look almost exactly like the arcade version because of copyright infringement. I know there's been a million other versions already made, but ya never know. lol
The rocks change their looks randomly for each level.
Tell me what you think, I've been working on this for maybe 3 or 4 days. It might still have some flukes, like possibly more than 1 asteroids being gone after shooting one for a different angle. I'm not exactly sure why that happened but I might have fixed it, or at least almost all of it.
Disclaimer: This game is not intended to replace any other game in existence. It is a labor of love and given out for free like usual.
Thank you guys for your inspiration. My Mouse Tank game really helped a lot on this code. Plus I got more math code from ChatGPT. Feel free to take as much as you want, as usual.
Here is a picture, the code is below it.
@bplus
@Pete
Code: (Select All)
'Asteroids Clone by, SierraKen
'February 1, 2025
'Thank you QB64pe Forum for your inspiration!
'Thank you also ChatGPT for a lot of the math.
'This game is not intended to replace any other game already in existence.
'It is a labor of love and given out for free.
_Title "Asteroids Clone - by SierraKen"
Screen _NewImage(800, 600, 32)
Randomize Timer
Dim oldx(100), oldy(100)
Dim llx(300), lly(300)
Dim lx(300), ly(300), ldir(300)
Dim x1 As Single, y1 As Single
Const numPoints = 30
Dim x2(100, 35), y2(100, 35)
Dim xRot(100, 35), yRot(100, 35)
Dim cx2(200), cy2(200), angle2(200)
Dim dx(100), dy(100)
Dim nox(200)
Locate 3, 25: Print "A s t e r o i d s C l o n e"
Locate 5, 25: Print "By SierraKen"
Locate 10, 25: Print "Move your ship around with the arrow keys."
Locate 11, 25: Print "Turn your ship with the left and right arrow keys."
Locate 12, 25: Print "Go forward with the up arrow key."
Locate 12, 25: Print "Press Space Bar to fire at asteroids."
Locate 13, 25: Print "To pause and un-pause, press Esc."
Locate 14, 25: Print "Press Q anytime to quit."
Locate 16, 25: Print "This game is not intended to replace any other game."
Locate 17, 25: Print "It is a labor of love and given out for free."
Locate 20, 25: Input "Press Enter to Begin.", a$
numAsteroids = numAsteroids + 2
If numAsteroids > 40 Then numAsteroids = 40
num = numAsteroids
rock = 0
hits = 0
speed2 = 0
laser = 0
ll = 0
numpoints2 = Int(Rnd * numPoints) + 5
For ll3 = 1 To 200
lx(ll3) = 0
ly(ll3) = 0
ldir(ll3) = 0
Next ll3
sx = 400
sy = 300
oldx = 400
oldy = 300
det = 0
r1 = 3 'bullets
r3 = 25 'Your ship
loops = 0
Play "MB"
' Initialize asteroids
For a = 0 To num - 1
more:
cx2(a) = Int(Rnd * 680) + 55 ' Random start X
cy2(a) = Int(Rnd * 480) + 55 ' Random start Y
If cx2(a) > 250 And cx2(a) < 550 And cy2(a) > 150 And cy2(a) < 450 Then GoTo more:
angle2(a) = Rnd * 360 ' Random starting rotation
dx(a) = (Rnd - 0.5) * 2 ' Random speed X (-1 to 1)
dy(a) = (Rnd - 0.5) * 2 ' Random speed Y (-1 to 1)
' Generate random asteroid shape
For i = 0 To numpoints2
ang = i * (360 / numpoints2)
rOffset = radius2 + Int(Rnd * 15 - 7) ' Vary radius randomly
x2(a, i) = Cos(ang * _Pi / 180) * rOffset
y2(a, i) = Sin(ang * _Pi / 180) * rOffset
Next
rock = rock + 1
Next
Do
_Limit 100
k = _KeyHit
If k = 32 Then
laser = 1
ll = ll + 1
If ll > 100 Then ll = 1
lx(ll) = x1
ly(ll) = y1
ldir(ll) = angle
End If
If k = 19200 Then dir = 1 ' Left Arrow (rotate counterclockwise)
If k = 19712 Then dir = 2 ' Right Arrow (rotate clockwise)
If k = 18432 Then dir = 3 ' Up Arrow (thrust forward)
If k = 20480 Then dir = 4 ' Down Arrow (thrust backward)
If dir = 1 Then
angle = angle - 1
If right = 1 Then
right = 0
dir = 0
GoTo nex2
End If
left = 1
right = 0
End If
If dir = 2 Then
angle = angle + 1
If left = 1 Then
left = 0
dir = 0
GoTo nex2
End If
right = 1
left = 0
End If
If dir = 3 Then
forward = 1
backward = 0
speed2 = speed2 + .5
If speed2 > 3 Then speed2 = 3
' Move in the direction of the angle
sx = sx + speed2 * Cos(angle * _Pi / 180)
sy = sy + speed2 * Sin(angle * _Pi / 180)
End If
If dir = 4 Then
If forward = 1 Then
dir = 0
speed2 = 0
GoTo nex2:
End If
End If
nex2:
If sx > 800 Then sx = 0
If sx < 0 Then sx = 800
If sy > 600 Then sy = 0
If sy < 0 Then sy = 600
If k = 27 Then
Do: c = _KeyHit
Loop Until c = 27
End If
If k = 81 Or k = 113 Then End
' Update and draw each asteroid
For a = 0 To num - 1
If nox(a) = 1 Then GoTo skip
angle2(a) = angle2(a) + 1 ' Rotate
If angle2(a) >= 360 Then angle2(a) = 0
' Rotate asteroid points
rad = angle2(a) * _Pi / 180
For i = 0 To numpoints2
xRot(a, i) = cx2(a) + (x2(a, i) * Cos(rad) - y2(a, i) * Sin(rad))
yRot(a, i) = cy2(a) + (x2(a, i) * Sin(rad) + y2(a, i) * Cos(rad))
Next
' Draw asteroid
For i = 0 To numpoints2 - 1
j = (i + 1) Mod numpoints2
Line (xRot(a, i), yRot(a, i))-(xRot(a, j), yRot(a, j)), _RGB32(255, 255, 255)
Next
' Wrap around screen edges
If cx2(a) < 0 Then cx2(a) = 800
If cx2(a) > 800 Then cx2(a) = 0
If cy2(a) < 0 Then cy2(a) = 600
If cy2(a) > 600 Then cy2(a) = 0
Next
skip:
If laser = 1 Then
For lz = 0 To ll - 1 Step 10
lx2 = Cos(ldir(lz) * _Pi / 180) * 10
ly2 = Sin(ldir(lz) * _Pi / 180) * 10
lx(lz) = lx2 + lx(lz)
ly(lz) = ly2 + ly(lz)
If lx(lz) > 850 Then lx(lz) = 850
If lx(lz) < -50 Then lx(lz) = -50
If ly(lz) > 650 Then ly(lz) = 650
If ly(lz) < -50 Then ly(lz) = -50
fillCircle lx(lz), ly(lz), r1, _RGB32(255, 0, 5)
For chk = 0 To num - 1
distance = Sqr((lx(lz) - cx2(chk)) ^ 2 + (ly(lz) - cy2(chk)) ^ 2)
If distance <= r1 + radius2 Then
DetectCollision = -1 ' True (collision detected)
Else
DetectCollision = 0 ' False (no collision)
End If
If DetectCollision = -1 Then
For explosion = 1 To 50
Circle (lx(lz), ly(lz)), explosion, _RGB32(255, 0, 0)
llx(explosion) = lx(lz)
lly(explosion) = ly(lz)
Next explosion
'SOUND frequency!, duration![, volume!][, panPosition!][, waveform&][, waveformParameters!][, voice&]]
Sound 800, .4, , , 5
Sound 200, .75, , , 6
Sound 100, .75, , , 7
nox(rock) = 1
rock = rock - 1
num = num - 1
cx2(chk) = -500: cy2(chk) = 1200
lx(lz) = -150: ly(lz) = -150: ldir(lz) = 0
score = score + 10
_Title "Score: " + Str$(score) + " Health: " + Str$(healthp) + "% Level: " + Str$(level)
hits = hits + 1
laser = 0
End If
Next chk
'Detect Level Change
If hits > numAsteroids - 1 Then
Cls
level = level + 1
For n = 1 To 200
nox(n) = 0
Next n
For n = 0 To 100
cx2(n) = -400: cy2(n) = -400
dx(n) = 0: dy(n) = 0
angle2(n) = 0
Next n
GoTo start2
End If
Next lz
End If
For chk = 0 To numAsteroids - 1
distance = Sqr((sx - cx2(chk)) ^ 2 + (sy - cy2(chk)) ^ 2)
If distance <= r3 + radius2 Then
DetectCollision = -1 ' True (collision detected)
Else
DetectCollision = 0 ' False (no collision)
End If
If DetectCollision = -1 And nox(chk) <> 1 Then
det = 1
health = health - .2
healthp = Int((health / 50) * 100)
_Title "Score: " + Str$(score) + " Health: " + Str$(healthp) + "% Level: " + Str$(level)
If health < .01 Then
health = 0
For explosion = 1 To 200
Circle (sx, sy + 25), explosion, _RGB32(255, 0, 0)
Next explosion
For nn = 1 To 200
nox(nn) = 0
Next nn
Sound 500, 4, , , 8
Sound 500, 8, , , 5
Sound 100, 4, , , 7
Locate 20, 30: Print "G A M E O V E R"
Locate 25, 30: Input "Again (Y/N)"; ag$
ag2$ = LTrim$(RTrim$(ag$))
If Left$(ag2$, 1) = "y" Or Left$(ag2$, 1) = "Y" Then GoTo start
End
End If
End If
Next chk
skip3:
If det > 0 Then
det = det + 1
Paint (sx, sy), _RGB32(255, 0, 0), _RGB32(255, 255, 255)
If det > 200 Then det = 0
End If
If loops < 1000 Then
loops = loops + 1
End If
_Display
Cls
Loop
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, 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), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub DrawTriangle (cx As Integer, cy As Integer, size As Integer, angle As Single, x1, y1)
Dim x2 As Single, y2 As Single
Dim x3 As Single, y3 As Single
Dim a1 As Single, a2 As Single, a3 As Single
Here is my first stab at yet another _Mem function set program:
This is my first lame attempt of using _Mem functions..
Let me know if anything needs to be added or is incorrect..
-ejo
Code: (Select All)
Rem example using _mem functions. v1.0a 01/30/2025 QB64 PD 2025.
Rem written by Erik Jon Oredson at eoredson@gmail.com
Rem new version 2.0a adds display function.
$Checking:Off
_ScreenMove _Middle
Width 80, 25
Dim m As _MEM
Dim n As _MEM
Dim p As _Offset
Color 15
Print "Mem sample program v2.0a"
Print "Mem value(10-32767)";
Input t
If t >= 10 And t <= 32767 Then
Else
End
End If
l$ = LTrim$(Str$(t))
l = Len(l$) ' length of mem value
' define length of memory buffer
m = _MemNew(t * l + l)
n = _MemNew(t * l + l)
p = m.TYPE
' take apart the memory buffer
Color 14
Print "Display memory buffer."
Print " Memtype:"; p ' ; "("; _Bin$(p); ")"
For q = 1 To t
z = Int(Val(Mid$(b$, (q - 1) * l + 1, l)))
Print z;
Next
Print
x = More
Color 7
End
' store the memory buffer
PutMem:
Color 14
For q = 1 To t
x$ = String$(l, "0")
s$ = s$ + Right$(x$ + LTrim$(Str$(q)), l)
Next
Print "Store memory buffer."
x = Display(s$)
_MemPut m, m.OFFSET, s$
Return
' copy the memory buffer
CopyMem:
Color 14
s$ = Space$(t * l)
_MemGet m, m.OFFSET, s$
Print "Copy memory buffer."
x = Display(s$)
_MemCopy m, m.OFFSET, m.SIZE To n, n.OFFSET
Return
' read the memory buffer
GetMem:
Color 14
b$ = Space$(t * l)
_MemGet n, n.OFFSET, b$
Print "Read memory buffer."
x = Display(b$)
Return
' always clear the memory when done
FreeMem:
Color 14
Print "Free memory buffer."
_MemFree m: _MemFree n
x = More
Return
' prompt for next display
Function More
Color 15
Print "-more-";
Do
_Limit 50
x$ = InKey$
If Len(x$) Then
Print
Exit Do
End If
Loop
More = -1
End Function
' prompt for next display
Function MoreX
Color 15
Print "-next-";
Do
_Limit 50
x$ = InKey$
If Len(x$) Then
Print
Exit Do
End If
Loop
MoreX = -1
End Function
Function Display (o$)
c = -1
For d = 1 To Len(o$)
c = c + 1
If c >= 22 * 80 Then
c = 0
Print
x = MoreX
End If
Color 14
Print Mid$(o$, d, 1);
Next
Print
x = More
Display = -1
End Function
I need to test whether a number's square root is an integer (nothing after the decimal, test code below).
My first try was to use MOD and see if 1 divides into it evenly, but MOD is integer only.
I thought maybe I could cast the square root to an integer, and subtracting that from the square root value yields 0, we know there is a fractional portion left over, so it's not just an integer.
Did I hear something about a "cast" command being added at some point?
Even if that's not the best way to test the square root, that would be good to know about.
Any guidance would be appreciated...
Code: (Select All)
Dim iLoop%
For iLoop% = 1 To 16
TestSquareRoot iLoop%
Next iLoop%
Sub TestSquareRoot (MyNumber%)
Dim MySquareRoot!
MySquareRoot! = Sqr(MyNumber%)
Print "For value " + _Trim$(Str$(MyNumber%)) + ", " + _
"square root is " + _trim$(str$(MySquareRoot!)) + ", " + _
_IIf((MySquareRoot! Mod 1 = 0), "even", "different")
End Sub
first of all many thanks for this great forum. This forum is the reason why i'm learning QB64 .
I read the tutorial from here https://www.qb64tutorial.com
which was really excellent. Some smaller tutorials followd and i learned a lot.
For learning purposes i'm now trying to translate an older QBasic code to modern QB64 Code. It is an old Demo from Phatcode called "digital reality" by plasma. For me the most interesting part ist the Vector_Balls part.
My problem is I can't figure out how to do the page flipping in a correct way in modern QB64.
I also sent the DIGIREAL.BIN fily, simply rename .bmp to .BIN.
This is the reduced working code:
Code: (Select All)
'digital reality by plasma
'.........................
'
'[11-01-2004] updated final release
'[07-16-2002] final release
'[11-01-2001] contest release
'
'created for Toshi's Fall 2001 "Pure QB" demo competition
'placed 3rd out of 6 entries
'
'www.phatcode.net
'Dim ScreenImage& ' the main graphics screen
'Dim ActivePage% ' page being written to
'Dim ViewPage% ' page being viewed
'ScreenImage& = _NewImage(640, 640, 32) ' create main graphics screen'Screen ScreenImage&, , 1, 0 ' page 1 active and viewing page 0
'Screen ScreenImage&, , 0, 0 ' active and view page set to 0
Const Compiled = TRUE 'change this to FALSE to run in the QB IDE
'change this to TRUE when compiling for extra speed
DECLARE SUB Do.End ()
DECLARE SUB Do.VectorBalls ()
DECLARE SUB Gfx.Pal.GetAttr (pal.seg, pal.off, Reg, r, g, b)
DECLARE SUB Gfx.Pal.Load (Filename$, pal.seg, pal.off)
DECLARE SUB Gfx.Pal.Set (pal.seg, pal.off)
DECLARE SUB Gfx.Put (x.pos, y.pos, src.seg, src.off, dest.seg, dest.off)
DECLARE SUB Gfx.Put.Mask (x.pos, y.pos, src.seg, src.off, dest.seg, dest.off, clip.color)
DECLARE SUB Lookup.GenTables ()
DECLARE SUB Pack.BLoad (PakFile, Filename$, segment, offset)
DECLARE FUNCTION Pack.Offset& (PakFile, Filename$)
Dim Shared Pack
Dim Shared PackFile$
PackFile$ = "DIGIREAL.BIN"
Pack = FreeFile
Open "DIGIREAL.BIN" For Binary As #Pack
If LOF(Pack) = 0 Then
Close #Pack
Kill PackFile$
Print "Cannot find " + PackFile$
End
End If
Dim Shared Gfx.OldSkool
Dim Shared Gfx.WaitSync
Dim Shared Pal.FadeBuffer(767)
'$Dynamic
'$Static
Dim Shared Lookup.Cosine(360) As Single
Dim Shared Lookup.Sine(360) As Single
Dim Shared Lookup.Sine160(0 To 360) As Single
Dim Shared Lookup.Cosine160(0 To 360) As Single
Dim Vector(NumShapes, NumBalls - 1, 2)
Dim Temp(NumBalls - 1, 2)
Distance = 256
Dim Morph(NumShapes, NumBalls - 1, 2)
For i = 1 To NumShapes
For j = 0 To NumBalls - 1
Get #Pack, , x
Get #Pack, , y
Get #Pack, , z
Vector(i, j, 0) = x
Vector(i, j, 1) = y
Vector(i, j, 2) = z
Next
Next
steps = 0
shape = 1
Do
'PCopy 1, 0 ' clear screen with page 3 image
If steps < 128 Then
For i = 0 To NumBalls - 1
Vector(0, i, 0) = Vector(shape, i, 0) + (Morph(shape, i, 0) / 128) * steps
Vector(0, i, 1) = Vector(shape, i, 1) + (Morph(shape, i, 1) / 128) * steps
Vector(0, i, 2) = Vector(shape, i, 2) + (Morph(shape, i, 2) / 128) * steps
Next
steps = steps + 1
ElseIf steps < 512 Then
steps = steps + 1
ElseIf steps = 512 And shape < NumShapes - 1 Then
steps = 0
shape = shape + 1
End If
If shape = NumShapes - 1 And steps > 128 And AngleX >= 0 And AngleX <= 5 And AngleY >= 0 And AngleY <= 0 And AngleZ >= 0 And AngleZ <= 5 Then
AngleX = 0
AngleY = 0
AngleZ = 0
Distance = Distance - 1
If Distance = 0 Then Exit Do
Else
AngleX = AngleX + 1
If AngleX >= 360 Then AngleX = 0
AngleY = AngleY + 1
If AngleY >= 360 Then AngleY = 0
AngleZ = AngleZ - 1
If AngleZ < 0 Then AngleZ = 359
End If
For i = 0 To NumBalls - 1
TempX = Vector(0, i, 0)
TempY = Vector(0, i, 1)
TempZ = Vector(0, i, 2)
For j = 0 To NumBalls - 2
For k = j + 1 To NumBalls - 1
a = Temp(j, 2)
b = Temp(k, 2)
If a >= b Then
Swap Temp(j, 0), Temp(k, 0)
Swap Temp(j, 1), Temp(k, 1)
Swap Temp(j, 2), Temp(k, 2)
End If
Next
Next
For i = 0 To NumBalls - 1
Gfx.Put Temp(i, 0) - 10, Temp(i, 1) - 8, VarSeg(Ball(0)), VarPtr(Ball(0)), VarSeg(Screen.Buffer(0)), 4
Next
If Gfx.WaitSync > 1 Then
Wait &H3DA, 8, 8
Wait &H3DA, 8
End If
Def Seg = pal.seg
For x = 0 To 767
Get #Pack, , Byte$
Poke pal.off + x, Asc(Byte$)
Next
End Sub
Sub Gfx.Pal.Set (pal.seg, pal.off)
Def Seg = pal.seg
Out &H3C8, 0
For x = 0 To 255
red = Peek(pal.off + x * 3)
green = Peek(pal.off + x * 3 + 1)
blue = Peek(pal.off + x * 3 + 2)
If Gfx.OldSkool Then
gray = (red * 30 + green * 59 + blue * 11) \ 100
Out &H3C9, gray
Out &H3C9, gray
Out &H3C9, gray
Else
Out &H3C9, red
Out &H3C9, green
Out &H3C9, blue
End If
Next
End Sub
Sub Gfx.Pal.SetAttr (pal.seg, pal.off, Reg, r, g, b)
Def Seg = pal.seg
Poke pal.off + Reg * 3, r
Poke pal.off + Reg * 3 + 1, g
Poke pal.off + Reg * 3 + 2, b
End Sub
Sub Gfx.Pal.sFade (steps, frame, pal.seg, pal.off, topal.seg, topal.off)
For x = 0 To 767
Def Seg = topal.seg
target = Peek(topal.off + x)
Def Seg = pal.seg
current = Peek(pal.off + x)
If frame = 0 Then
Pal.FadeBuffer(x) = current
original = current
Else
original = Pal.FadeBuffer(x)
End If
If current < target Then
current = original + ((target - original) / steps) * frame
ElseIf current > target Then
current = target + ((original - target) / steps) * (steps - frame)
End If
Poke pal.off + x, current
Next
End Sub
Sub Gfx.Put (x.pos, y.pos, src.seg, src.off, dest.seg, dest.off)
For y = 0 To ysize - 1
For x = 0 To xsize - 1
Def Seg = src.seg
Byte = Peek(src.off + 4 + y * xsize + x)
If Byte <> 0 Then
If y.pos + y > 0 And y.pos + y < 200 And x.pos + x > 0 And x.pos + x < 320 Then
Def Seg = dest.seg
Poke dest.off + (y.pos + y) * 320 + x.pos + x, Byte
End If
End If
Next
Next
Else
For y = 0 To ysize - 1
For x = 0 To xsize - 1
Def Seg = src.seg
Byte = Peek(src.off + 4 + y * xsize + x)
If Byte <> 0 Then
If y.pos + y > 0 And y.pos + y < 200 And x.pos + x > 0 And x.pos + x < 320 Then
Def Seg = dest.seg
Poke dest.off + (y.pos + y) * 320& + x.pos + x, Byte
End If
End If
Next
Next
End If
End Sub
Sub Gfx.Put.Mask (x.pos, y.pos, src.seg, src.off, dest.seg, dest.off, clip.color)
For y = 0 To ysize - 1
For x = 0 To xsize - 1
Def Seg = src.seg
Byte = Peek(src.off + 4 + y * xsize + x)
Def Seg = dest.seg
If y.pos + y > 0 And y.pos + y < 320 And x.pos + x > 0 And x.pos + x < 320 Then
If Peek(dest.off + (y.pos + y) * 320 + x.pos + x) <> clip.color Then
Poke dest.off + (y.pos + y) * 320 + x.pos + x, Byte
End If
End If
Next
Next
Else
For y = 0 To ysize - 1
For x = 0 To xsize - 1
Def Seg = src.seg
Byte = Peek(src.off + 4 + y * xsize + x)
Def Seg = dest.seg
If y.pos + y > 0 And y.pos + y < 320 And x.pos + x > 0 And x.pos + x < 320 Then
If Peek(dest.off + (y.pos + y) * 320& + x.pos + x) <> clip.color Then
Poke dest.off + (y.pos + y) * 320& + x.pos + x, Byte
End If
End If
Next
Next
End If
End Sub
Sub Lookup.GenTables
For x = 0 To 359
Lookup.Cosine(x) = Cos(x * 3.14159265# / 180)
Lookup.Sine(x) = Sin(x * 3.14159265# / 180)
Lookup.Sine160(x) = Lookup.Sine(x) / 160
Lookup.Cosine160(x) = Lookup.Cosine(x) / 160
Next
End Sub
Sub Pack.BLoad (PakFile, Filename$, segment, offset)
buffer = 8000
Seek #PakFile, 6
Get #PakFile, , NumFiles
For x = 1 To NumFiles
Name$ = Space$(8)
Get #PakFile, , Name$
Ext$ = Space$(3)
Get #PakFile, , Ext$
If Filename$ = LTrim$(RTrim$(Name$)) + "." + LTrim$(RTrim$(Ext$)) Then
FileNum = x
Exit For
End If
offset& = offset - 1
Block = buffer
Do
If Loc(PakFile) = FileLoc& + FileLen& + 1 Then Exit Do
If Loc(PakFile) + Block > FileLoc& + FileLen& + 1 Then
Block = (FileLoc& + FileLen& + 1) - Loc(PakFile)
End If
buffer$ = Input$(Block, # PakFile)
Def Seg = segment
For x = 1 To Len(buffer$)
Poke offset& + x, Asc(Mid$(buffer$, x, 1))
Next
offset& = offset& + Len(buffer$)
Loop Until EOF(PakFile)
buffer$ = ""
End Sub
Function Pack.Offset& (PakFile, Filename$)
Seek #PakFile, 6
Get #PakFile, , NumFiles
For x = 1 To NumFiles
Name$ = Space$(8)
Get #PakFile, , Name$
Ext$ = Space$(3)
Get #PakFile, , Ext$
If Filename$ = LTrim$(RTrim$(Name$)) + "." + LTrim$(RTrim$(Ext$)) Then
FileNum = x
Exit For
End If
I'm also a little bit confused about the waitsync part.
Im trying it now for 1 week but I'm totally stuck .
Thank you fot your help and work in advance.
Best regards,
Huggy
Admin Edit:
Removed the DIGIREAL.BMP as it was wanting to try and load as an image and couldn't (as it's a BIN file instead), so it just errored out and was inaccessible. You can now grab the file in the 7z archive and extract it without issue for testing and experimentation with the code above.
Do Cls ReadJoyStick'Use this command to read your joystick
'The code here is what we use to check the results of our joystick input For i = 1ToUBound(JoyStick) 'this checks for each axis of our joystick 'joystick(1) should be the left paddle 'joystick(2) should be the right paddle 'joystick(3) should be the d-pad If JoyStick(i).Active Then'check to see if any of the joysticks are active Print Using"STICK # ACTIVE:"; i Print"Hort:", JoyStick(i).Hort, "Vert:", JoyStick(i).Vert 'if one is, you can get the direction it's pressed in Print"X:", JoyStick(i).X, "Y:", JoyStick(i).Y 'simply by referencing these global variables Print"Angle:", JoyStick(i).Angle 'and this gives you the angle of the joystick End If Next For b = 1ToUBound(Button) 'button(1) is the A button 'button(2) is the B button 'button(3) is the X button 'button(4) is the Y button 'button(5) is the top-left button on the front of the game pad 'button(6) is the top-right button on the front of the game pad 'button(7) is the select button (top of game pad, beside the d-pad 'button(8) is the start button (top of game pad, right of button(7) 'button(9) is the left paddle being pushed in as a button 'button(10) is the right paddle being pushed in as a button 'button(11) is the bottom-left button on the front of the game pad (Z-Axis) 'button(12) is the bottom-right button on the front of the game pad (Z-Axis) If Button(b) ThenPrint Using"Button ## down (of ##)"; b, UBound(Button) 'if the button is down, process it Next _Limit30 _Display Loop
'This sub needs to go at the end of your code, or in a BM file SubReadJoyStick StaticAsLong d, LA, LB 'Last Axis, Last Button If d = 0Then d = _Devices If d < 3ThenExit Sub'3 is joystick. Without one, then there's no reason to waste effort doing anything else. If LA = 0Then LA = _LastAxis(3): ReDim JoyStick(1To3) As Axis_Type If LA = 0ThenExit Sub'if there's no axis on your joystick, I don't know how to read it! If LB = 0Then LB = _LastButton(3): ReDim Button(1To LB + 2) AsLong If LB = 0ThenExit Sub'if there's no buttons on your joystick, then it's not a proper controller. Go buy one!
Dim axis(LA) AsSingle Do
di = _DeviceInput Select Case di Case3'We have joystick input For a = 1To LA: axis(a) = Int(100 * _Axis(a)) / 100: Next'read the input on each axis
JoyStick(1).Hort = axis(1): JoyStick(1).Vert = axis(2) 'left pad is axis 1 and 2 'axis 3 is the botton left/right buttons on the front of my joystick
JoyStick(2).Hort = axis(5): JoyStick(2).Vert = axis(4) 'right pad is axis 5 and 4
JoyStick(3).Hort = axis(6): JoyStick(3).Vert = axis(7) 'd-pad is axis 6 and 7 'right-pad seems to be mapped backwards to the other axis??!! For i = 1To LB
Button(i) = _Button(i) Next
Button(LB + 1) = _FALSE: Button(LB + 2) = _FALSE Select Case_Axis(3) 'this is an odd axis which reads off the left/right buttons on the front of the gamepad Case Is > 0.4: Button(LB + 1) = _TRUE Case Is < -0.4: Button(LB + 2) = _TRUE End Select End Select Loop Until di = 0 For j = 1To3 IfAbs(JoyStick(j).Vert) <= .01Then JoyStick(j).Vert = 0'remove some natural drift from the keypad IfAbs(JoyStick(j).Hort) <= .01Then JoyStick(j).Hort = 0'my joystick seldom resets back to perfect 0 ' the code below here gives me a simple X/Y value for left/right, up/down of _TRUE/_FALSE 'I personally find it easier for my 2-d style games to process than having to use frational results. 'Feel free to change the threshold as necessary for your own uses. 0.4 works fine for cardinal directions and diagionals for my use. IfAbs(JoyStick(j).Vert) > 0.4Then JoyStick(j).Y = Sgn(JoyStick(j).Vert) Else JoyStick(j).Y = 0 IfAbs(JoyStick(j).Hort) > 0.4Then JoyStick(j).X = Sgn(JoyStick(j).Hort) Else JoyStick(j).X = 0 'the angle here is just like the one we learned in school with 0/360 to the right, 90 up, 180 left, and 270 down 'Tweak this as needed so it fits the coordinate system of your own stuff as desired.
JoyStick(j).Angle = _Atan2(JoyStick(j).Hort, JoyStick(j).Vert)
JoyStick(j).Angle = (_R2D(JoyStick(j).Angle) + 270) Mod360 'And below here is what determines if a joystick was active or not If JoyStick(j).Vert = 0And JoyStick(j).Hort = 0Then JoyStick(j).Active = _FALSE Else JoyStick(j).Active = _TRUE Next End Sub
All the mappings here work for my gamepad, though some buttons just fail to report. Even checking the Windows controller test routine, they fail to read, so this appears to be a Windows issue and not a QB64PE issue.
As it is, 16 of my 21 buttons are now mapped and reading properly, with 5 of them just lost.
Keep in mind though, that 4 of the buttons that work are double-mapped to the same input.
My left-paddle can be pressed down to generate a button event. On the bottom of my controller is another button that generates that exact same event. The controller was made like this, just for ease of producing that event.
Same with the right-paddle and pressing it down to generate a button event. On the bottom of the controller is another button that mimics that same press. It's just the way it's designed.
My Z-Axis (the left and right bottom buttons on the front) for some reason are separated into two distinct buttons. Perhaps an ergonomics thing? Either way, both of them generate the same button response as the button beside them.
I don't know if other's controllers are configured the same, but I would hope so. Hopefully several folks will test this out and report back for us, and let us know if everything maps to the same buttons for them.
I commented the crapola out of this code, so it should be easy to read, understand, and maintain in the future. There's a few parts which people might want to tweak for their own personal preferences, so be certain to take a moment to look at those. (The angle we return is one which I'd think various programs might need to tweak for their own usage.)
Try it out. Report back. I hope it works just as well for everyone else as it does on my personal game pad.
SubReadJoyStick Static d, LA If d = 0Then d = _Devices If d < 3ThenExit Sub'3 is joystick. Without one, then there's no reason to waste effort doing anything else. If LA = 0Then LA = _LastAxis(3): ReDim JoyStick(1To LA \ 2) As Axis_Type If LA = 0ThenExit Sub'if there's no axis on your joystick, I don't know how to read it! Dim axis(LA) AsSingle Do
di = _DeviceInput Select Case di Case3 For a = 1To LA: axis(a) = _Axis(a): Next For j = 1To LA \ 2 If j = 1Then 'left pad is axis 1 and 2
JoyStick(j).Hort = axis(j * 2 - 1): JoyStick(j).Vert = axis(j * 2) Else 'axis 3 is the botton left/right buttons on the front of my joystick 'so the right pad is axis 4 and 5 'and the d-pad is axis 6 and 7
JoyStick(j).Hort = axis(j * 2 + 1): JoyStick(j).Vert = axis(j * 2) 'd-pad seems to be mapped backwards to the other axis??!! If j = 3ThenSwap JoyStick(j).hort, JoyStick(j).vert End If Next End Select Loop Until di = 0 For j = 1To LA \ 2 IfAbs(JoyStick(j).Vert) <= .01Then JoyStick(j).Vert = 0 IfAbs(JoyStick(j).Hort) <= .01Then JoyStick(j).Hort = 0
JoyStick(j).Angle = _Atan2(JoyStick(j).Hort, JoyStick(j).Vert)
JoyStick(j).Angle = (_R2D(JoyStick(j).Angle) + 270) Mod360 If JoyStick(j).Vert = 0And JoyStick(j).Hort = 0Then JoyStick(j).Active = _FALSE Else JoyStick(j).Active = _TRUE Next End Sub
I've tested this on my Xbox-style joystick and... these mappings seem odd as BLEEP to me!
Left paddle is axis 1 and 2
Right paddle is axis 4 and 5
D-pad is axis 7 and 6
Axis 3 is the button left/right buttons on the front of the joystick
Note that the D-pad is REVERSED in order compared to the paddles.
Who the crap configures these things? Who thought this type of set up would be nice and normal and easy to configure for??
/sigh
Anywho... Test this out with your own joysticks and see if it responds as expected for you. So far, this just tests for the stick movement (it doesn't even try and tell you about those button-sticks!), but it *should* have x and y both mapped for all 3 axis.
Let me know if it works for you, or if it gives some odd readings, or whatnot. I have no idea how the heck this might work on various controllers. It's just... weird the mapping on this thing.
As for the angle, I've fixed it so it should map to the same coordinates as what we learned in school. 0 is to right, 90 is to the top, 180 is left and 270 is bottom. It should be the quickest way to tell if something is completely off with the left/right paddles.
I worked over 8 hours on this game so far, but I can't figure out how to make the oval flippers collide with the ball efficiently. So far, they work around 50% of the time. Much of this code is from when B+ helped me with hocky puck colliders awhile back and another big part of this code is math from ChatGPT, such as making the ovals turn on the axis at the end of the oval, for the flippers.
You can still play this game if you keep pressing the 2 CTRL keys to move the flippers many times to hit the ball. But it would be nice if I could fix this, thanks. You can probably tell a lot of it has been made experimenting with numbers, etc. I'm just zomped out. lol
Code: (Select All)
'Pinball by SierraKen
'1-25-25
'Much of this code is from help by B+ with collisions awhile back.
'Thank you B+ and QB64pe Forum!
'Another large chunk of this math is from ChatGPT.
'The paddles only work about 50 percent of the time and I'm not sure how to fix that.
'OItherwise if you keep pressing the paddles they will work.
'The Left Paddle is the Left CTRL key and the Right Paddle is the Right CTRL key.
_Title "Pinball - by SierraKen - Press the Left and Right CTRL keys to move Paddles."
Randomize Timer
Screen _NewImage(800, 800, 32)
num = 12
ball = 10
Dim circx(num), circy(num), size(num), red(num), green(num), blue(num)
Dim X As Single, Y As Single
Dim Xc As Single, Yc As Single
Dim a As Single, b As Single
Dim theta As Single, t As Single
Dim thickness As Integer
Dim X2 As Single, Y2 As Single
Dim Xc2 As Single, Yc2 As Single
Dim a2 As Single, b2 As Single
Dim theta2 As Single, t2 As Single
Dim thickness2 As Integer
Xc = 500 ' Center of the screen
Yc = 700
a = 75 ' Semi-major axis
b = 25 ' Semi-minor axis
theta = 45 * _Pi / 180 ' Rotate 45 degrees in radians
thickness = 10 ' Thickness of the ellipse
Xc2 = 300 ' Center of the screen
Yc2 = 700
a2 = 75 ' Semi-major axis
b2 = 25 ' Semi-minor axis
theta2 = 45 * _Pi / -180 ' Rotate 45 degrees in radians
thickness2 = 10 ' Thickness of the ellipse
begin:
slotx = 280
sloty = 690
dir = 1
For cir = 1 To num
If cir = 1 Then
circx(cir) = 775
circy(cir) = 25
size(cir) = 50
End If
If cir = 2 Then
circx(cir) = 25
circy(cir) = 25
size(cir) = 50
End If
If cir = 4 Then
circx(cir) = 635
circy(cir) = 200
size(cir) = 40
End If
If cir = 5 Then
circx(cir) = 175
circy(cir) = 200
size(cir) = 40
End If
If cir = 6 Then
circx(cir) = 535
circy(cir) = 350
size(cir) = 30
End If
If cir = 7 Then
circx(cir) = 275
circy(cir) = 350
size(cir) = 30
End If
If cir = 8 Then
circx(cir) = 460
circy(cir) = 500
size(cir) = 20
End If
If cir = 9 Then
circx(cir) = 355
circy(cir) = 500
size(cir) = 20
End If
If cir = 10 Then
circx(cir) = 400
circy(cir) = 550
size(cir) = 15
End If
If cir = 11 Then
circx(cir) = 800
circy(cir) = 680
size(cir) = 50
End If
If cir = 12 Then
circx(cir) = 0
circy(cir) = 680
size(cir) = 165
End If
red(cir) = Rnd * 255
green(cir) = Rnd * 255
blue(cir) = Rnd * 255
Next cir
pr = 7 'Radius of ball
pc = _RGB32(0, 255, 0) 'Color of ball
'
speedx = 30 '
speedy = 30
gravity = 0.5 ' Gravitational acceleration (adjust this to simulate stronger/weaker gravity)
floorHeight = 680 ' Floor height, where the ball will stop when it hits
_Limit 800
Line (10, 10)-(790, 690), _RGB32(255, 255, 255), B
For cir = 1 To num
_Limit 800
'Bumpers
fillCircle circx(cir), circy(cir), size(cir), _RGB32(red(cir), green(cir), blue(cir))
fillCircle circx(cir), circy(cir), size(cir) / 2, _RGB32(255, 255, 127)
a$ = InKey$
If a$ = " " Then GoTo start:
If a$ = Chr$(27) Then End
'Flippers
If _KeyDown(100305) Then 'Right Side
If theta > .85 Then GoTo skip1
theta = theta + .05
Else
If theta < -.25 Then GoTo skip1
theta = theta - .05
End If
skip1:
If _KeyDown(100306) Then 'Left Side
If theta2 < -.85 Then GoTo skip2
theta2 = theta2 - .05
Else
If theta2 > .25 Then GoTo skip2
theta2 = theta2 + .05
End If
skip2:
For offset = 0 To thickness - 1 Step 0.5 ' Add layers for thickness
For t2 = 0 To 2 * _Pi Step 0.01
' Calculate initial x and y for the oval before rotation
X_initial = (a + offset) * Cos(t2)
Y_initial = (b + offset) * Sin(t2)
' Translate so the end of the oval becomes the origin
X_translated = X_initial - (a + offset)
Y_translated = Y_initial
' Rotate around the new origin using theta
X_rotated = X_translated * Cos(theta) - Y_translated * Sin(theta)
Y_rotated = X_translated * Sin(theta) + Y_translated * Cos(theta)
' Translate back to the original position
X2 = Xc + X_rotated + (a + offset)
Y2 = Yc + Y_rotated
' Draw the point
PSet (X2, Y2), _RGB32(255, 255, 255)
Next
Next
For offset = 0 To thickness - 1 Step 0.5 ' Add layers for thickness
For t = 0 To 2 * _Pi Step 0.01
' Calculate initial x and y for the second flipper
X_initial = (a + offset) * Cos(t)
Y_initial = (b + offset) * Sin(t)
' Translate so the opposite end of the oval becomes the origin
X_translated = X_initial + (a + offset) ' Notice the + instead of -
Y_translated = Y_initial
' Rotate around the new origin using theta for Flipper 2
X_rotated = X_translated * Cos(theta2) - Y_translated * Sin(theta2)
Y_rotated = X_translated * Sin(theta2) + Y_translated * Cos(theta2)
' Translate back to the original position for Flipper 2
X = Xc2 + X_rotated - (a + offset) ' Translate back from the opposite end
Y = Yc2 + Y_rotated
' Draw Flipper 2
PSet (X, Y), _RGB32(255, 255, 255) ' Use a different color for Flipper 2
Next
Next
'Check flippers
For chk = -10 To 10 Step 1
If Sqr((X + chk - px) ^ 2 + (Y + chk - py) ^ 2) < (pr + 35) Then
pa = _Atan2(py - Y, px - X)
collision px, py, pa, speedx, speedy
px = px + speedx * Cos(pa)
py = py + speedy * Sin(pa)
End If
If Sqr((X2 + chk - px) ^ 2 + (Y2 + chk - py) ^ 2) < (pr + 35) Then
pa = _Atan2(py - Y2, px - Y2)
collision px, py, pa, speedx, speedy
px = px + speedx * Cos(pa)
py = py + speedy * Sin(pa)
End If
Next chk
'Check bumpers
If Sqr((circx(cir) - px) ^ 2 + (circy(cir) - py) ^ 2) < (pr + size(cir)) Then
pa = _Atan2(py - circy(cir), px - circx(cir))
pa = pa + Rnd
px = px + speedx * Cos(pa)
py = py + speedy * Sin(pa)
fillCircle circx(cir), circy(cir), size(cir), _RGB32(255, 0, 0)
fillCircle circx(cir), circy(cir), size(cir) / 1.33, _RGB32(255, 255, 127)
score = Int(score + 10000 / size(cir))
Sound 350, .5, , , 2
Sound 400, .5, , , 3
Sound 350, .5, , , 4
Sound 300, .5, , , 5
_Title "Score: " + Str$(score) + " Ball: " + Str$(ball) + " Level: " + Str$(level)
oldlevel = level
level = Int(score \ 50000 + 1)
If oldlevel <> level And level <> 1 Then GoTo begin:
End If
If speedx < 5 Then speedx = 5
If speedy < 5 Then speedy = 5
If speedx > 30 Then speedx = 30
If speedy > 30 Then speedy = 30
Next cir
'Border reflection.
If px > 790 - pr Then pa = _Pi - pa * Rnd + 1: px = 790 - pr
If px < 10 + pr Then pa = _Pi - pa * Rnd + 1: px = 10 + pr
If py > 790 - pr And floorHeight = 680 Then pa = -pa * Rnd + 1: py = 790 - pr
If py < 10 + pr Then pa = -pa * Rnd + 1: py = 10 + pr
If px > slotx + 30 And px < slotx + 170 And py > sloty - 70 Then
floorHeight = floorHeight + 8
If px > slotx + 60 And px < slotx + 200 And floorHeight > 760 Then
ball = ball - 1
_Title "Score: " + Str$(score) + " Ball: " + Str$(ball) + " Level: " + Str$(level)
px = (Rnd * 550) + 60: py = 60
down = 0
floorHeight = 680
_Delay 1
If ball = 0 Then End
End If
Else
floorHeight = 680
End If
' Simulate ball bouncing off the floor
If py + pr >= floorHeight And hit <> 1 Then
py = floorHeight - pr ' Position ball on the floor
speedy = -speedy * 0.9 ' Reverse direction and apply damping
End If
' Simulate ball moving with some friction
If Abs(speedx) > 0.1 Then
speedx = speedx * 0.99 ' Friction effect on horizontal velocity
Else
speedx = 0 ' Stop ball when velocity is too low
End If
If speedx < 5 Then speedx = 5
If speedy < 5 Then speedy = 5
If speedx > 30 Then speedx = 30
If speedy > 30 Then speedy = 30
Line (slotx, sloty)-(slotx + 300, sloty), _RGB32(0, 0, 0)
_Display
Cls
Loop Until InKey$ = Chr$(27)
End
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, 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), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
I don't know if TSR is the proper term for this type of program nowadays, but back in the yesteryears of the past these type of tools were called Terminate and Stay Resident programs.
Not that without a title bar and without any easy exit commands, this little program doesn't terminate and quit very easily on you now. You'll probably need to go into task manager to manually stop it, so keep that in mind. If you're not comfortable with manual program stopping then... why the heck are you into programming?
This works just like before except I've made some important changes here.
1)To start with, this loads and runs and behaves exactly as the other version...
2)..until you hit CTRL-ALT-K (for Kolor Picker), where it will then hide itself and disappear completely off your computer...
3)..until you hit CTRL-ALT-K once again, where the tool will instantly reappear at command and be usable once more.
Configure this to run in your windows startup and from now on, you'll always have a handle little CTRL-ALT-K color picker available for use on your machine!
So why is this here instead of in the other topic?
Basically so folks will take the time to read the fact that this doesn't ever terminate on its own. Start it up and it'll stay in your task list and do its thing forever more unless you manually close it yourself.
For me, this is a system tool which I can make use of to always be able to grab the color code from whatever I see on my monitor. My personal plan is just to pop this into windows startup and then it'll just always be an extended system tool for me. I thought others might like the same (or at least to see how to do the same so they could write similar little programs for themselves.)
![[Image: Asteroids-Clone-by-Sierra-Ken.jpg]](https://i.ibb.co/rRDGvCx9/Asteroids-Clone-by-Sierra-Ken.jpg)
![[Image: memory.png]](https://i.ibb.co/WNn0D8KD/memory.png)
![[Image: smile.png]](https://qb64phoenix.com/forum/images/icons/smile.png){kind=icon}
.![[Image: sad.png]](https://qb64phoenix.com/forum/images/icons/sad.png){kind=icon}
.
