The method I came up with for Pac-Man I thought was quite clever. Turns out not so much. Not only is it ugly (string manipulation) but it only worked for one global frame rate. If another global rate was needed the entire set of strings need to be recreated. Ugly, yes, but functional for the game.
I have a project I'm working on that needs the ability to have the global FPS change at any time but still have the ability to know when lower frame rates change within that global frame rate, in real time. So, while investigating (and pulling my hair out for an hour) my son walks up and asks, "What ya doing?"
I explain to him what I'm trying to accomplish. He listens, says "huh?", then wanders off. Ten minutes later he came back with a super simple solution! (He's autistic on the Asperger's scale and his mind amazes me)
The code below contains a function called FrameChange that can report lower frame rates within a global frame in real time, even if the global frame rate changes. Now I have to go back to my Pac-Man code and put this in place of my ugly solution. His solution is so freaking simple.
Code: (Select All)
' A better frame counter
' By Brandon Ritchie
' 01/31/23
' The function FrameChange determines lower frame rates within a global frame rate.
' The function will return -1 when a lower frame rate increases to the next frame number.
DIM GlobalFPS AS INTEGER
DIM Frame AS INTEGER
DIM FPS(23) AS INTEGER
DIM Count(23) AS INTEGER
DIM i AS INTEGER
GlobalFPS = 60 ' change to any value above 45 - the individual frame rates will remain constant
' (above 45 simply because example rates below are from 2 to 46)
DO ' begin proof of concept demo
_LIMIT 10 ' or use GlobalFPS (10 used to slow things down)
CLS
Frame = Frame + 1
IF Frame = GlobalFPS THEN Frame = 0 ' reset global frame counter when last frame reached
LOCATE 1, 2: PRINT "Global "; _TRIM$(STR$(GlobalFPS)); " FPS >"; Frame
FOR i = 1 TO 23
IF Frame = 0 THEN Count(i) = 0 ' reset count when frame resets
IF FrameChange(GlobalFPS, i * 2, Frame) THEN Count(i) = Count(i) + 1
LOCATE i + 1, 2
PRINT _TRIM$(STR$(i * 2)); " FPS >"; Count(i);
NEXT i
LOOP UNTIL _KEYDOWN(27) ' press ESC to exit
FUNCTION FrameChange (Global AS INTEGER, Target AS INTEGER, Frame AS INTEGER)
' Global = global frame rate
' Target = target frame rate
' Frame = the current global frame (0 to Global-1)
' Returns -1 (true) if target frame changes within the global frame rate
DIM Fraction AS SINGLE
DIM x AS SINGLE '
FrameChange = 0
Fraction = Target / Global
x = Frame * Fraction
IF INT(x) <> INT(x - Fraction) THEN FrameChange = -1
I was working collisions of spiders and 2 spiders going in same direction or nearly so needed collision code different from spiders coming head on or perpendicular to each other.
So how do I tell if spiders are going in same direction or nearly so, say their headings are within 30 degrees of each other or not?
Just subtract the angles right? Or take the ABS of the difference right?
Well what if one has a heading of 0 degrees and the other a heading of 350 degrees the difference is 350, I am wanting 10 degrees so make 0 360 instead, easy right?
So now what if one was x and the other y when do I know to add 360? like with 0.
I came up with a function AngleDifference to handle this because this issue has come up before but it seems kind of clunky. I think the time before I used Major and Minor arc differences, two answers to angle difference. This time one answer but again seems cluncky.
I won't show my code because I don't want to bias someone coming up with maybe a more elegant solution which I suspect exists.
So if you can do it in a line or 2 I'd be interested.
Recently, I added a level editor to my game project. In this level editor, I included a "playhead" tool, similar to what you would see in a video or audio editing program - so when you hit "play level" from the editor, with the playhead set, it would invisibly simulate the level up to that point as fast as possible, then you'd start playing from the playhead. This is a very useful thing in my level design process, since it means I don't have to watch minutes of level go by while I'm tweaking a later part.
However, I noticed the simulation was taking almost as long as actually playing the level up to where the playhead was. I ran a visible frame counter during the simulation and discovered it was only about 30% faster.
At the time I chalked this up to poor design on my part, maybe some inefficiencies in my code, and looked into it a little bit, but didn't find anything conclusive. To boost the simulation speed a bit, I copied the main gameplay loop and stripped it down to bare essentials, only what the simulation would need. To my surprise, it was now running EVEN SLOWER than before.
So I started commenting out pieces of the simulation loop, to see how it affected the time. Nothing made a difference - the position updates, the level script check, collision detection, background scrolling, very mysterious. So I took the loop, with everything but the actual frame counter commented out, and still, no difference, it was running just as slowly. Good news - those chunks of code are actually super fast! But how could the frame counter be causing so much slowdown that it was running under 60 loops per second? It's just a PRINT statement with a variable plugged in.
Well, when you've eliminated every other possibility, whatever remains, however unlikely, must be true. Below the PRINT statement was a SUB call: display_screen. Here it is:
Code: (Select All)
sub display_screen
putimage(0, 0)-((screenw * option_window_size) - 1, (screenh * option_window_size) - 1), full_screen, scaled_screen(option_window_size), (0, 0)-(screenw - 1, screenh - 1)
display
end sub
I had recently added a screen scaling option to the option menu. Players can choose to run the game at x1, x2, or x3; since it's a pixelart game, the window size options are doubling or tripling the pixels. The x1 resolution is 640x360 (16:9 ratio), so x2 is 1280x720 and x3 is 1920x1080.
So it's that PUTIMAGE statement; more specifically, the scaling. Apparently using PUTIMAGE, in any situation where the output size and input size are different, is a massive resource hog. I was running the playhead 1643 frames into the level in each case... at x2 scaling, this took 37.14 seconds, which is about 44 frames per second. Running x1 scaling took 4.56 seconds, or 360 fps. Removing the multiplier from the PUTIMAGE statement, curiously, took 7.8 seconds, or 210 fps. And finally, commenting out the display_screen call entirely (including the DISPLAY statement) caused it to take 1.42 seconds, which is 1157 fps.
I have some workarounds in mind, such as pre-processing all source images into three size versions, and toggling between them based on the player's chosen size option. But that's a lot of work, so first I have to know, is there a way to speed this up without such a huge overhaul to the code? I've seen games do this exact kind of window size option before, although they weren't made in QB64.
Here is my FreeBASIC port of Pipecom! Right now, I've only converted the Windows portion. The Linux portion will be a bit tougher to do. I am a newbie with FreeBASIC as I just got started so the code might be not that great. However, it works just the same as the QB64 code.
Code: (Select All)
#define UNICODE
#include once "windows.bi"
type PIPE_STRUCT
as DWORD exitCode
as string _stdout, _stderr
end type
declare function pipecom overload (cmd as string) as PIPE_STRUCT
declare function pipecom (cmd as string, byref _stdout as string, byref _stderr as string) as DWORD
declare function StrRemove (byref s as string, ch as ubyte) as string
with pipecom(cmd)
print .exitCode
print ._stdout
end with
sleep
function pipecom (cmd as string, byref _stdout as string, byref _stderr as string) as DWORD
dim as PIPE_STRUCT piped = pipecom(cmd)
_stdout = piped._stdout
_stderr = piped._stderr
return piped.exitCode
end function
function pipecom (cmd as string) as PIPE_STRUCT
dim as PIPE_STRUCT piped
dim as SECURITY_ATTRIBUTES sa
with sa
.nLength = sizeof(SECURITY_ATTRIBUTES)
.lpSecurityDescriptor = null
.bInheritHandle = true
end with
dim as HANDLE hStdOutPipeRead, hStdOutPipeWrite, hStdReadPipeError, hStdOutPipeError
if CreatePipe(@hStdOutPipeRead, @hStdOutPipeWrite, @sa, null) = false then
piped.exitCode = -1
end if
if createpipe(@hStdReadPipeError, @hStdOutPipeError, @sa, null) = false then
piped.exitCode = -1
end if
dim as STARTUPINFO si
with si
.cb = sizeof(STARTUPINFO)
.dwFlags = STARTF_USESTDHANDLES
.hstdError = hStdOutPipeError
.hStdOutput = hStdOutPipeWrite
.hStdInput = null
end with
dim as PROCESS_INFORMATION procinfo
dim as string lpCommandLine = "cmd /c " + cmd
if CreateProcess(null, lpCommandLine, null, null, true, CREATE_NO_WINDOW, null, null, @si, @procinfo) = false then
piped.exitCode = -1
end if
if instr(_stdout, chr(13)) then
_stdout = StrRemove(_stdout, 13)
end if
if instr(_stderr, chr(13)) then
_stderr = StrRemove(_stderr, 13)
end if
dim as DWORD exit_code, ex_stat
piped._stderr = _stderr
piped._stdout = _stdout
if WaitForSingleObject(procinfo.hProcess, INFINITE) <> WAIT_FAILED then
if GetExitCodeProcess(procinfo.hProcess, @exit_code) then
ex_stat = 1
end if
end if
if ex_stat = 1 then
piped.exitCode = exit_code
else
piped.exitCode = -1
end if
return piped
end function
function StrRemove (byref s as string, ch as ubyte) as string
if (0 = strptr(s)) then return ""
'' Get the trimmed string length
''
dim new_length as integer = len(s)
for i as integer = 0 to len(s) - 1
if (ch = s[i]) then
new_length -= 1
exit for
end if
next
'' Allocate an appropriately sized string
''
dim result as string = string(new_length, 0)
'' Copy the non-matching ubytes to the new string
''
dim it as ubyte ptr = @result[0]
for i as integer = 0 to len(s) - 1
if (ch <> s[i]) then
*it = s[i]
it += 1
end if
next
So following recent updates of Windows, the inpubox$ command still functions but it got ugly:
The system doesn't draw the input box neatly and it hides the values in the input box.
Is there a way to fix this from inside a QB64 program or at a higher level in windows? I'm not using the latest released build of QB64 has this already been addressed?
I'm working on a remake of my Worm game, that allows a player to play against the computer. So far, it's just the algorithm for a basic unintelligent response from the computer.
It recognizes a "word" that's being constructed, finds a word that contains that group of letters, and adds a letter to either the beginning or end of that group.
More later.
I used Terry's method of pixel collision detection and added it to my Box Collision detection code because I saw Terry's method as an extension of Box Collision. So in same amount of code as Terry's self contained PixelCollide routine, I have 5 routines that give me more than just Pixel collision detection, mainly BoxCollsion TF and Intersect2Boxes plus minor Max and Min Functions which is commonly needed.
Anyway after getting that going I revised my spider code with an Experiment of turning one spider when it collides instead of reversing both spiders when there is collision. It turned out to be nice effect so I leave the code here but the whole collision code zip package has:
Quote:Box and Pixel Collision pkg Manifest Jan 28, 2023 b+
3 Pairs of Image Files all png:
1. Red and Green Ovals from Terry's original post at forum.
2. starRed and starBlue
3. Rock1 and rock2
3 Pixel Collision Demo Files:
1. Pixel Intersect from Box Intersect.bas - code I used to combine Terry's pixel
collision detection method with my own BoxCollision Code to factor Terry's
Pixel Collide single self contained routine into 5 Routines that do more than
just pixel collision detection with about same amount of Lines-Of-Code.
This one took a whole day of frustration to track down a bug holding up my test
of it with Spiders. But now it's pretty good so not only do you have Pixel
Collision detection, you have Max, Min Functions, BoxCollision TF function
Intersect2Boxes that returns the intersect box which was used in Pixel Collision
Detection, PixelCollision& that returns first pixel detected as well as return
TF collsion.
This is pure Pixel Collison detection code though needing the other routines
to reduce PixelCollision code itself. But also used Intersect2Boxes code to
display the ovelap of the 2 images when they did along with the yellow circle
for the actual pixel collsion, first detected when that happened.
2. Pixel Intersect from Box Intersect full demo.bas - has updated Box Collision
demo code before PixelCollision showing off BoxCollison TF and Intersect2Boxes
that returns the box of Intersect.
3. Terry Update Pixel Collision.bas - demo that I modified a tiny bit for testing
pairs of images to see how good it was. Nice approach Terry Richie!
3 Spiders files:
1. Spiders with Terrys Pixel Collisions.bas - this one I posted at forum already
in Programs Board.
2. Spiders with b+ factored Collisions.bas - Same Spiders Code as above testing
the 5 factored routines to make sure they worked the sameas 1. Spiders file.
3. Spiders refactored Collison Experiment.bas - My feature app! I experimented
with another approach to spider collisons turning only the first one of the two
that collided. Nice effect! Now I can use 100% collision for spider reactions.
Got's to check this one out!
Code: (Select All)
Option _Explicit
_Title "Spiders refactored Collision Experiment" 'b+ 2023-01-28 !!! Speaker volume around 20 maybe! !!!
' Experiment is to only change direction of spider that bumps into another (first) not both spiders
' I want to see I can avoid pile ups that way instead of changing directions 30% of time.
' Yes! I luv the spinning spiders and 100% reactions to collisions by 1 spider at least
' !!!!!!!!!!!!!!!!!!! Escape to Quit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Randomize Timer
Dim Shared xmax As Integer, ymax As Integer
xmax = _DesktopWidth
ymax = _DesktopHeight
Const nSpinners = 30
Type SpinnerType
x As Single
y As Single
dx As Single
dy As Single
a As Single
sz As Single
c As _Unsigned Long
End Type
Dim Shared s(1 To nSpinners) As SpinnerType
Type boxType ' for PixelCollison&
As Single dx, dy
As Long img, x, y, w, h
c As _Unsigned Long
End Type
Dim power1
Dim As Long i, j, iImg, jImg, lc, i2, sc, intx, inty
Dim As boxType sIo, sJo
sc = _ScreenImage
Screen _NewImage(xmax, ymax, 32)
_FullScreen
For i = 1 To nSpinners
newSpinner i
Next
i2 = 1
While InKey$ <> Chr$(27)
_PutImage , sc, 0
lc = lc + 1
If lc Mod 100 = 99 Then
lc = 0
If i2 < nSpinners Then i2 = i2 + 1
End If
For i = 1 To i2
If PixelCollision&(sIo, sJo, intx, inty) Then '+++++++++++++++++++++++++++++++++++++++
Sound Rnd * 5000 + 1000, .1 * Rnd
s(i).a = s(i).a + _Pi(.33) ' turn 30 degrees
s(i).dx = power1 * Cos(s(i).a) 'update dx, dy
s(i).dy = power1 * Sin(s(i).a)
s(i).x = s(i).x + 3 * s(i).dx 'now boost spider out
s(i).y = s(i).y + 3 * s(i).dy
Exit For
End If
_FreeImage jImg
Next
s(i).x = s(i).x + s(i).dx
s(i).y = s(i).y + s(i).dy
If s(i).x < -100 Or s(i).x > xmax + 100 Or s(i).y < -100 Or s(i).y > ymax + 100 Then newSpinner i
_PutImage (s(i).x - 70, s(i).y - 70), iImg, 0
_FreeImage iImg
Next
_Display
_Limit 15
Wend
Sub newSpinner (i As Integer) 'set Spinners dimensions start angles, color?
Dim r
s(i).sz = Rnd * .25 + .5
If Rnd < .5 Then r = -1 Else r = 1
s(i).dx = (s(i).sz * Rnd * 8) * r * 2 + 2: s(i).dy = (s(i).sz * Rnd * 8) * r * 2 + 2
r = Int(Rnd * 4)
Select Case r
Case 0: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = 0: If s(i).dy < 0 Then s(i).dy = -s(i).dy
Case 1: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = ymax: If s(i).dy > 0 Then s(i).dy = -s(i).dy
Case 2: s(i).x = 0: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx < 0 Then s(i).dx = -s(i).dx
Case 3: s(i).x = xmax: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx > 0 Then s(i).dx = -s(i).dx
End Select
r = Rnd * 100 + 40
s(i).c = _RGB32(r, .5 * Rnd * r, Rnd * .25 * r)
End Sub
Sub drawSpinner (idest&, x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green
Static switch As Integer
switch = switch + 2
switch = switch Mod 16 + 1
red = _Red32(c): green = _Green32(c): blue = _Blue32(c)
r = 10 * scale
x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
r = 2 * r 'lg lengths
For lg = 1 To 8
If lg < 5 Then
a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
Else
a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
End If
x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
drawLink idest&, x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5)
If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
a1 = a + d * _Pi(1 / 12)
x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
drawLink idest&, x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8)
rd = Int(Rnd * 8) + 1
a2 = a1 + d * _Pi(1 / 8) * rd / 8
x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
drawLink idest&, x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12)
Next
r = r * .5
fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5)
x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
fcirc x2, y2, r * .2, &HFF000000
x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
fcirc x2, y2, r * .2, &HFF000000
r = r * 2
x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
TiltedEllipseFill idest&, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue)
End Sub
Sub drawLink (idest&, x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
a = _Atan2(y2 - y1, x2 - x1)
a1 = a + _Pi(1 / 2)
a2 = a - _Pi(1 / 2)
x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
fquad idest&, x3, y3, x4, y4, x5, y5, x6, y6, c
fcirc x1, y1, r1, c
fcirc x2, y2, r2, c
End Sub
'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (idest&, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
ftri idest&, x1, y1, x2, y2, x4, y4, c
ftri idest&, x3, y3, x4, y4, x1, y1, c
End Sub
Sub ftri (idest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim a&
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest idest&
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
Sub fcirc (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 TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
Dim TEmax As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
Dim prc As _Unsigned Long, tef As Long
prc = _RGB32(255, 255, 255, 255)
If a > b Then TEmax = a + 1 Else TEmax = b + 1
mx2 = TEmax + TEmax
tef = _NewImage(mx2, mx2)
_Dest tef
_Source tef 'point wont read without this!
For k = 0 To 6.2832 + .05 Step .1
i = TEmax + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = TEmax + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
If k <> 0 Then
Line (lasti, lastj)-(i, j), prc
Else
PSet (i, j), prc
End If
lasti = i: lastj = j
Next
Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
For y = 0 To mx2
x = 0
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
xleft(y) = x
While Point(x, y) = prc And x < mx2
x = x + 1
Wend
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
Next
_Dest destHandle&
For y = 0 To mx2
If xleft(y) <> mx2 Then Line (xleft(y) + x0 - TEmax, y + y0 - TEmax)-(xright(y) + x0 - TEmax, y + y0 - TEmax), c, BF
Next
_FreeImage tef
End Sub
'Function PixelCollide (Obj1 As TypeSPRITE, Obj2 As TypeSPRITE, Intersect As TypePOINT)
' '--------------------------------------------------------------------------------------------------------
' '- Checks for pixel perfect collision between two rectangular areas. -
' '- Returns -1 if in collision -
' '- Returns 0 if no collision -
' '- -
' '- obj1 - rectangle 1 coordinates -
' '- obj2 - rectangle 2 coordinates -
' '---------------------------------------------------------------------
' Dim x%, y%
' Dim x1%, y1% ' upper left x,y coordinate of rectangular collision area
' Dim x2%, y2% ' lower right x,y coordinate of rectangular collision area
' Dim Test1& ' overlap image 1 to test for collision
' Dim Test2& ' overlap image 2 to test for collision
' Dim Hit% ' -1 (TRUE) if a collision occurs, 0 (FALSE) otherwise
' Dim Osource& ' original source image handle
' Dim p1~& ' alpha value of pixel on image 1
' Dim p2~& ' alpha value of pixel on image 2
' If Obj1.x2 >= Obj2.x1 Then ' rect 1 lower right X >= rect 2 upper left X ?
' If Obj1.x1 <= Obj2.x2 Then ' rect 1 upper left X <= rect 2 lower right X ?
' If Obj1.y2 >= Obj2.y1 Then ' rect 1 lower right Y >= rect 2 upper left Y ?
' If Obj1.y1 <= Obj2.y2 Then ' rect 1 upper left Y <= rect 2 lower right Y ?
' If Obj2.x1 <= Obj1.x1 Then x1% = Obj1.x1 Else x1% = Obj2.x1 ' calculate overlapping coordinates
' If Obj2.y1 <= Obj1.y1 Then y1% = Obj1.y1 Else y1% = Obj2.y1
' If Obj2.x2 <= Obj1.x2 Then x2% = Obj2.x2 Else x2% = Obj1.x2
' If Obj2.y2 <= Obj1.y2 Then y2% = Obj2.y2 Else y2% = Obj1.y2
' Test1& = _NewImage(x2% - x1% + 1, y2% - y1% + 1, 32) ' make overlap image of object 1
' Test2& = _NewImage(x2% - x1% + 1, y2% - y1% + 1, 32) ' make overlap image of object 2
' _PutImage (-(x1% - Obj1.x1), -(y1% - Obj1.y1)), Obj1.image, Test1& ' place overlap area of object 1
' _PutImage (-(x1% - Obj2.x1), -(y1% - Obj2.y1)), Obj2.image, Test2& ' place overlap area of object 2
' x% = 0 ' reset overlap area coordinate counters
' y% = 0
' Osource& = _Source ' remember calling source
' Do ' begin pixel collide loop
' _Source Test1& ' read from image 1
' p1~& = _Alpha32(Point(x%, y%)) ' get alpha level of pixel
' _Source Test2& ' read from image 2
' p2~& = _Alpha32(Point(x%, y%)) ' get alpha level of pixel
' If (p1~& <> 0) And (p2~& <> 0) Then ' are both pixels transparent?
' Hit% = -1 ' no, there must be a collision
' Intersect.x = x1% + x% ' return collision coordinates
' Intersect.y = y1% + y% '
' End If
' x% = x% + 1 ' increment column counter
' If x% > _Width(Test1&) - 1 Then ' beyond last column?
' x% = 0 ' yes, reset x
' y% = y% + 1 ' increment row counter
' End If
' Loop Until y% > _Height(Test1&) - 1 Or Hit% ' leave when last row or collision detected
' _Source Osource& ' restore calling source
' _FreeImage Test1& ' remove temporary image from RAM
' _FreeImage Test2&
' End If
' End If
' End If
' End If
' PixelCollide = Hit% ' return result of collision check
'End Function
Function BoxCollision% (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h)
' x, y represent the box left most x and top most y
' w, h represent the box width and height which is the usual way sprites / tiles / images are described
' such that boxbottom = by + bh
' and boxright = bx + bw
If (b1y + b1h < b2y) Or (b1y > b2y + b2h) Or (b1x > b2x + b2w) Or (b1x + b1w < b2x) Then
BoxCollision% = 0
Else
BoxCollision% = -1
End If
End Function
' this needs max, min functions as well as BoxCollision%
Sub Intersect2Boxes (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h, bix As Long, biy As Long, biw As Long, bih As Long)
If b2x >= b1x And b2x <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'top left corner in 2nd box
bix = b2x: biy = b2y
If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x
If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y
ElseIf b2x >= b1x And b2x <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'bottom left corner of 2nd box in first
bix = b2x
If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x
If b2y <= b1y Then biy = b1y: bih = b2y + b2h - b1y Else biy = b2y: bih = b2h
ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'right top corner 2nd box in first
If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x
biy = b2y
If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y
ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'left bottom corners in first box
If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x
If b2y >= b1y Then biy = b2y: bih = b2h Else biy = b1y: bih = b2y + b2h - b1y
ElseIf BoxCollision%(b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h) Then
bix = max(b1x, b2x): biy = max(b1y, b2y)
biw = min(b1x + b1w, b2x + b2w) - bix: bih = min(b1y + b1h, b2y + b2h) - biy
Else 'no intersect
bix = -1: biy = -1: biw = 0: bih = 0
End If
End Sub
Function max (a, b)
If a > b Then max = a Else max = b
End Function
Function min (a, b)
If a < b Then min = a Else min = b
End Function
' this sub needs Intersect2Boxes which uses max, min, and BoxCollision Functions
Function PixelCollision& (img1 As boxType, img2 As boxType, intx As Long, inty As Long)
' boxType here needs at least an x, y, w, h and img
Dim As Long x, y, ix, iy, iw, ih
Dim As _Unsigned Long p1, p2
intx = -1: inty = -1 ' no collision set
Intersect2Boxes img1.x, img1.y, img1.w, img1.h, img2.x, img2.y, img2.w, img2.h, ix, iy, iw, ih
If ix <> -1 Then ' the boxes intersect
y = iy: x = ix
Do
_Source img1.img
p1 = Point(x - img1.x, y - img1.y) ' point minus img x, y location = location in image I hope
_Source img2.img
p2 = Point(x - img2.x, y - img2.y)
If (p1 <> 0) And (p2 <> 0) Then
PixelCollision& = -1: intx = x: inty = y: Exit Function
End If
If (x + 1) > (ix + iw - 1) Then ' get rid of 2 slow For Loops
x = ix: y = y + 1
If y >= (iy + ih - 1) Then
_Source 0: Exit Function
Else
y = y + 1
End If
Else
x = x + 1
End If
Loop
End If
End Function
For Dimster request, sorry couldn't find what I was recalling so we can go with this simple demo:
The sum of intergers 1 to 100, 3 ways:
Code: (Select All)
_Title "Recursive replacement for Loop" ' b+ 2023-01-28
For i = 1 To 100 ' normal loop
tot = tot + i
Next
Print tot
i = 1: fini = 100 ' GoSub method
GoSub counting
Print totGOSUB
Dim Shared sum ' global sum for saving subtotals in for recCount Function
Print recCount(1, 100)
End
counting: ' recursive because it calls until i hits 100
totGOSUB = totGOSUB + i
If i < 100 Then i = i + 1: GoSub counting
Return
Function recCount (i, fini) ' recursive because it calls itself until i hits 100
sum = sum + i
If i < fini Then recCount = recCount(i + 1, fini) Else recCount = sum
End Function
Can someone help me?
How to make. I will draw several different pictures in QB64.
I want to save these pictures to the computer's memory. Then I want to develop these images using _MapTriangle.
For example: Picture(1-100)
I don't want to record them from a file..
Dim As Long Pismeno(5)
Pismo& = _LoadFont("SANFW.ttf", 300, "monospace")
_Font Pismo&
Cx = 450: CY = 110
x = 100: y = 100
For t = 1 To 5
Pismeno(t) = _NewImage(x * 2, y * 2, 32)
_Dest Pismeno(t)
Locate 1, 1: Print t
Line (Cx - x, CY - y)-(Cx + x, CY + y), , B
'Get (Cx - x, CY - y)-(Cx + x, CY + y), Pismeno(t) - I keep getting this error
Cls
Next t
For t = 1 To 5
_Source Pismeno(t)
_Dest 0
_PutImage (Cx - x + c, CY - y), Pismeno(t)
c = c + 200
Next t
_Display
Something QB64 does just like QB45, and I like it.
I've got somebody in another forum wondering why anybody would ever want that.
I'm thinking why wouldn't you want the ability to cycle through colour attributes in either direction and be able to loop around to the other side when you reach an end?
I can't think off the top of my head how I would use it, but it instantly struck me as "that can be really frigging useful," especially when setting up custom palettes that have nice colour transitions through the circle of colours, regardless of direction.
Just bringing that up here in case folk were unaware of that, or in case anybody has a ready example in their back pocket, or in case anybody has thoughts one way of the other.
![[Image: image.png]](https://i.ibb.co/5Fcyb7Z/image.png)
