I have a tutorial user that has reported my pixel perfect collision routines are not working in v3.5.0 but work fine in v3.4.1 but I can't replicate this.
The code below I've tested in the following and it works fine:
- Windows 7 SP2 and QB64PE v3.4.1 and v3.5.0
- The latest version of Linux Mint and QB64PE v3.5.0
For those of you with different versions of Windows, Linux, and MacOS would you kindly run the code below and let me know what you find out? The ZIP file attached contains the code and the two image files needed to run it.
Code: (Select All)
'** Pixel Perfect Collision Demo #5
Type TypeSPRITE ' sprite definition
image As Long ' sprite image
mask As Long ' sprite mask image
x1 As Integer ' upper left X
y1 As Integer ' upper left Y
x2 As Integer ' lower right X
y2 As Integer ' lower right Y
End Type
Type TypePOINT
x As Integer
y As Integer
End Type
Dim RedOval As TypeSPRITE ' red oval images
Dim GreenOval As TypeSPRITE ' green oval images
Dim Intersect As TypePOINT
RedOval.image = _LoadImage("redoval.png", 32) ' load red oval image image
GreenOval.image = _LoadImage("greenoval.png", 32) ' load green oval image
MakeMask RedOval ' create mask for red oval image
MakeMask GreenOval ' create mask for green oval image
Screen _NewImage(640, 480, 32) ' enter graphics screen
_MouseHide ' hide the mouse pointer
GreenOval.x1 = 294 ' green oval upper left X
GreenOval.y1 = 165 ' green oval upper left Y
Do ' begin main program loop
_Limit 30 ' 30 frames per second
Cls ' clear screen
While _MouseInput: Wend ' get latest mouse information
_PutImage (GreenOval.x1, GreenOval.y1), GreenOval.image ' display green oval
_PutImage (RedOval.x1, RedOval.y1), RedOval.image ' display red oval
RedOval.x1 = _MouseX ' record mouse X location
RedOval.y1 = _MouseY ' record mouse Y location
If PixelCollide(GreenOval, RedOval, Intersect) Then ' pixel collision?
Locate 2, 36 ' yes, position text cursor
Print "COLLISION!" ' report collision happening
Circle (Intersect.x, Intersect.y), 4, _RGB32(255, 255, 0)
Paint (Intersect.x, Intersect.y), _RGB32(255, 255, 0), _RGB32(255, 255, 0)
End If
_Display ' update screen with changes
Loop Until _KeyDown(27) ' leave when ESC key pressed
System ' return to operating system
'------------------------------------------------------------------------------------------------------------
Sub MakeMask (Obj As TypeSPRITE)
'--------------------------------------------------------------------------------------------------------
'- Creates a negative mask of image for pixel collision detection. -
'- -
'- Obj - object containing an image and mask image holder -
'-------------------------------------------------------------------
Dim x%, y% ' image column and row counters
Dim cc~& ' clear transparent color
Dim Osource& ' original source image
Dim Odest& ' original destination image
Obj.mask = _NewImage(_Width(Obj.image), _Height(Obj.image), 32) ' create mask image
Osource& = _Source ' save source image
Odest& = _Dest ' save destination image
_Source Obj.image ' make object image the source
_Dest Obj.mask ' make object mask image the destination
cc~& = _RGB32(255, 0, 255) ' set the color to be used as transparent
For y% = 0 To _Height(Obj.image) - 1 ' cycle through image rows
For x% = 0 To _Width(Obj.image) - 1 ' cycle through image columns
If Point(x%, y%) = cc~& Then ' is image pixel the transparent color?
PSet (x%, y%), _RGB32(0, 0, 0, 255) ' yes, set corresponding mask image to solid black
Else ' no, pixel is part of actual image
PSet (x%, y%), cc~& ' set corresponding mask image to transparent color
End If
Next x%
Next y%
_Dest Odest& ' restore original destination image
_Source Osource& ' restore original source image
_SetAlpha 0, cc~&, Obj.image ' set image transparent color
_SetAlpha 0, cc~&, Obj.mask ' set mask transparent color
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 x1%, y1% ' upper left x,y coordinate of rectangular collision area
Dim x2%, y2% ' lower right x,y coordinate of rectangular collision area
Dim Test& ' overlap image to test for collision
Dim Hit% ' -1 (TRUE) if a collision occurs, 0 (FALSE) otherwise
Dim Osource& ' original source image handle
Dim p~& ' pixel color being tested in overlap image
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
If Obj2.y1 <= Obj1.y1 Then y1% = Obj1.y1 Else y1% = Obj2.y1 ' square coordinates
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
Test& = _NewImage(x2% - x1% + 1, y2% - y1% + 1, 32) ' make overlap image
_PutImage (-(x1% - Obj1.x1), -(y1% - Obj1.y1)), Obj1.image, Test& ' place image 1
_PutImage (-(x1% - Obj2.x1), -(y1% - Obj2.y1)), Obj2.mask, Test& ' place image mask 2
'** enable the line below to see a visual represenation of mask on image
'_PUTIMAGE (x1%, y1%), Test&
x2% = x1%
y2% = y1%
y1% = 0 ' reset row counter
Osource& = _Source ' record current source image
_Source Test& ' make test image the source
Do ' begin row (y) loop
x1% = 0 ' reset column counter
Do ' begin column (x) loop
p~& = Point(x1%, y1%) ' get color at current coordinate
'** if color from object 1 then a collision has occurred
If p~& <> _RGB32(0, 0, 0, 255) And p~& <> _RGB32(0, 0, 0, 0) Then
Hit% = -1
Intersect.x = x1% + x2% ' return collision coordinates
Intersect.y = y1% + y2%
End If
x1% = x1% + 1 ' increment to next column
Loop Until x1% = _Width(Test&) Or Hit% ' leave when column checked or collision
y1% = y1% + 1 ' increment to next row
Loop Until y1% = _Height(Test&) Or Hit% ' leave when all rows checked or collision
_Source Osource& ' restore original destination
_FreeImage Test& ' test image no longer needed (free RAM)
End If
End If
End If
End If
PixelCollide = Hit% ' return result of collision check
This is from James D Jarvis, a handy way to make random numbers centered and dense around a center point andtapering off within a range. Here my test code I made for this, one for Integers and one for floats, single is assumed Type.
CW stands for Center Weight:
Code: (Select All)
_Title "rndCWI function" 'b+ 2023-01-20
Dim As Long low, high
high = 5
low = -high
Dim As Long a(low - 1 To high + 1)
For i = 1 To 100000
r = rndCWI(0, high)
a(r) = a(r) + 1
Next
For i = low - 1 To high + 1
Print String$(Int(a(i) / 1000 + .5), "*"), a(i) / 1000, i
Next
' 2023-01-20
Function rndCWI (center, range) 'center +/-range weights to center
Dim As Long halfRange, c
halfRange = Int(range) + 1 'for INT(Rnd) round range in case not integer
c = Int(center + .5)
rndCWI = c + Int(Rnd * (halfRange)) - Int(Rnd * (halfRange))
End Function
' 2023-01-20
Function rndCW (C As Single, range As Single) 'center +/-range weights to center
rndCW = C + Rnd * range - Rnd * range
End Function
Just drop the I from rndCWI to test the float version.
This is a simple program that works like "Cowsay" Flatpak app. It associates a quotation with a silly ASCII picture of an animal or person or something else. It draws a balloon around the quotation. Maybe I should have added the option for "thought" which is fluffier cloud...
This requires at least two files:
personaje.txt - contains the ASCII art. Each "personality" should be separated by a single line which has only three dashes, no whitespace around it, only newline should follow it.
personajq.txt - contains the quotations, one per line.
A file could be asked for in interactive mode:
personaj1.txt - has the quotation that you prefer to give the personality which is not found in "personajq.txt". I wrote this program originally in Freebasic, and I'm not sure if "_CLIPBOARD$" function works on Linux. Otherwise for Windows the change to that function could be certainly done.
Also in interactive mode it's possible to load a text file of your choice to display the personality on the terminal.
This program does no special formatting for the personality, only for the balloon and caption inside. Its output is into the terminal to make it easier to copy and paste into a text editor to foul it up...
Run this program without parameters and it comes up with a random quotation and a random personality from the two files required for it. Otherwise type "help" after the program name to see what's in it for interactive mode.
I'm only including the source code. I leave it to your imagination to go looking for ASCII art and things to say...
Code: (Select All)
$CONSOLE:ONLY
OPTION _EXPLICIT
DIM AS INTEGER p, q, pl, ql, ff, m, n, i, rm, m1, m2
DIM AS STRING pfile, qfile, a, b, bl, ca, crlf
DIM ch AS _UNSIGNED _BYTE
REDIM qline(1 TO 1) AS STRING
REDIM pline(1 TO 1) AS STRING
$IF WIN THEN
crlf = CHR$(13) + CHR$(10)
$ELSEIF LINUX THEN
crlf = CHR$(10)
$ELSE
crlf = CHR$(13)
$END IF
RANDOMIZE TIMER
q = 1
p = 1
ca = COMMAND$(1)
IF ca = "" THEN
qfile = "personajq.txt"
pfile = "personaje.txt"
IF NOT _FILEEXISTS(pfile) THEN
PRINT "File NOT found: "; pfile
SYSTEM
END IF
IF NOT _FILEEXISTS(qfile) THEN
PRINT "File NOT found: "; qfile
SYSTEM
END IF
ql = 10
pl = 10
REDIM qline(1 TO ql) AS STRING
REDIM pline(1 TO pl) AS STRING
b = ""
ff = FREEFILE
OPEN pfile FOR INPUT AS ff
DO UNTIL EOF(ff)
LINE INPUT #ff, a
IF a = "---" THEN
pline(p) = b
b = ""
p = p + 1
IF p > pl THEN
pl = pl + 10
REDIM _PRESERVE pline(1 TO pl) AS STRING
END IF
ELSE
'for Windows concatenate "chr(13) + chr(10)" instead of just the latter
b = b + delundersinside$(a) + crlf
END IF
LOOP
CLOSE ff
IF b = "" THEN
p = p - 1
ELSE
b = b + delundersinside$(a) + crlf
END IF
ff = FREEFILE
OPEN qfile FOR INPUT AS ff
DO UNTIL EOF(ff)
LINE INPUT #ff, a
IF a <> "" THEN
qline(q) = a
q = q + 1
IF q > ql THEN
ql = ql + 10
REDIM _PRESERVE qline(1 TO ql) AS STRING
END IF
END IF
LOOP
CLOSE ff
ELSE
ca = LCASE$(ca)
IF ca = "help" THEN
PRINT quotesquiggle$("Accepted parameters are: ~say~, ~pers~, ~both~ (without double-quotes)")
SYSTEM
END IF
IF ca = "say" OR ca = "both" THEN
PRINT "Write what the personality has to say"
PRINT quotesquiggle$("or ~c~ (without double-quote) to get it from")
PRINT "(current-dir)/personaj1.txt:"
LINE INPUT b
IF b = "" THEN SYSTEM
IF b = "c" THEN
qfile = "personaj1.txt"
b = ""
ff = FREEFILE
OPEN qfile FOR INPUT AS ff
IF NOT EOF(ff) THEN LINE INPUT #ff, b
CLOSE ff
END IF
qline(1) = b
END IF
IF ca = "pers" OR ca = "both" THEN
PRINT "Enter the filename (in current dir) which contains the personality:"
LINE INPUT pfile
IF pfile = "" THEN END
IF NOT _FILEEXISTS(pfile) THEN
PRINT "Without a personality I cannot work!"
SYSTEM
END IF
b = ""
ff = FREEFILE
OPEN pfile FOR INPUT AS ff
DO UNTIL EOF(ff)
LINE INPUT #ff, a
b = b + a + crlf
LOOP
CLOSE ff
pline(1) = b
END IF
END IF
IF q = 1 THEN n = 1 ELSE n = INT(RND * q + 1)
a = qline(n)
b = ""
bl = ""
rm = -1
m = 1
FOR i = 1 TO LEN(a)
m = m + 1
ch = ASC(a, i)
IF ch = 32 AND m > 50 THEN
IF m > rm THEN rm = m
bl = ""
m = 1
ELSE
bl = bl + CHR$(ch)
END IF
NEXT
IF rm = -1 THEN
rm = m
ELSEIF m > rm THEN
rm = m
END IF
bl = ""
m = 1
FOR i = 1 TO LEN(a)
m = m + 1
ch = ASC(a, i)
IF ch = 32 AND m > 50 THEN
b = b + "|" + bl + SPACE$(rm - LEN(bl)) + "|" + crlf
bl = ""
m = 1
ELSE
bl = bl + CHR$(ch)
END IF
NEXT
IF bl <> "" THEN
b = b + "|" + bl + SPACE$(rm - LEN(bl)) + "|" + crlf
END IF
m1 = rm - (rm \ 2) - 1
m2 = rm - m1 - 2
b = " " + STRING$(rm, 45) + crlf + b + " " + STRING$(m1, 45) + "||" + STRING$(m2, 45) + crlf + SPACE$(m1 + 1) + "||"
PRINT b
IF p = 1 THEN n = 1 ELSE n = INT(RND * p + 1)
PRINT pline(n)
SYSTEM
FUNCTION quotesquiggle$ (sa AS STRING)
STATIC st AS STRING
st = sa
ReplaceString2 st, "~", CHR$(34), 0
quotesquiggle$ = st
END FUNCTION
SUB ReplaceString2 (tx AS STRING, sfind AS STRING, repl AS STRING, numtimes AS _UNSIGNED LONG)
DIM AS STRING s, t
DIM AS _UNSIGNED LONG ls, count, u
DIM goahead AS _BYTE
IF (tx = "") OR (sfind = "") OR (sfind = repl) OR (LEN(sfind) > LEN(tx)) THEN EXIT SUB
s = UCASE$(sfind): t = UCASE$(tx)
ls = LEN(s)
count = 0
goahead = 1
DO
u = INSTR(t, s)
IF u > 0 THEN
tx = LEFT$(tx, u - 1) + repl + MID$(tx, u + ls)
t = UCASE$(tx)
IF numtimes > 0 THEN count = count + 1: IF count >= numtimes THEN goahead = 0
ELSE
goahead = 0
END IF
LOOP WHILE goahead
END SUB
FUNCTION delundersinside$ (sa AS STRING)
STATIC st AS STRING, i AS LONG, ch AS _UNSIGNED _BYTE, fl AS _UNSIGNED _BYTE
st = SPACE$(LEN(sa))
fl = 0
FOR i = 1 TO LEN(st)
ch = asc(sa, i)
IF ch = 95 AND fl = 1 THEN
'mid$(st, i, 1) = " "
_CONTINUE
ELSEIF ch <> 95 AND fl = 0 THEN
fl = 1
END IF
MID$(st, i, 1) = CHR$(ch)
NEXT
delundersinside$ = RTRIM$(st)
END FUNCTION
EDIT: Made sure it could work on "any" OS. Didn't process properly the "---" as last line of "personaje.txt", fixed. Didn't format the last line of balloon properly, fixed.
EDIT #2: Added a function, for display of the "personality" that turns the underscores into spaces, the annoying ones that interfere with image view.
Input "0 to end else I will run again"; q
If q = 0 Then System
GoTo top
In electronics to find a value of a Resistor in parallel or a Capacitor in series. The following formula is used (X1 x X2) / (X1 + X2).
To find an unknown value to use would be hard, except when using reciprocals (shortcut for the formula). Must know two values to find the third.
I was using rotozoom2 when I noticed it was skewing the image it was rotating when xscale and yscale were not identical values. (I also adjusted it to used degrees as opposed to radians, but that has nothing to do with the skew).
The change was in multiplying px(0) to px(3) and py(0) to py(3) by the scale factors prior to rotation.
'smokemotes
'playing with circlefill
'
'key presses to stimulate chnages
'R,r, G,g , B,b change colore channels
'w,a,s,d directs the flow of particles
'M,m change the magnifcation on the motes
'<,> change the count of motes displayed
'V,v change the velocity chnages will be applied
'
Screen _NewImage(600, 500, 32)
Type motetype
x As Integer
y As Integer
gx As Integer
gy As Integer
r As Single
tr As Integer
kr As Integer
kg As Integer
kb As Integer
v As Integer
End Type
Randomize Timer
Dim smoke(60000) As motetype
For m = 1 To 60000
smoke(m).x = Int(1 + Rnd * _Width)
smoke(m).y = Int(1 + Rnd * _Height)
smoke(m).gx = Int(Rnd * 3) - Int(Rnd * 3)
smoke(m).gy = Int(Rnd * 3) - Int(Rnd * 3)
smoke(m).r = Int(.5 + Rnd * 3)
smoke(m).tr = Int(6 + Rnd * 10 + Rnd * 10)
smoke(m).kr = 100 + Int(Rnd * 12) - Int(Rnd * 12)
smoke(m).kg = 100 + Int(Rnd * 12) - Int(Rnd * 12)
smoke(m).kb = 200 + Int(Rnd * 20) - Int(Rnd * 20)
smoke(m).v = Int(30 + Rnd * 12 - Rnd * 12)
Next m
mm = 30000
_FullScreen
Do
_Limit 30
Cls
For m = 1 To mm
_Limit 1000000
CircleFill smoke(m).x, smoke(m).y, smoke(m).r, _RGB32(smoke(m).kr, smoke(m).kg, smoke(m).kb, smoke(m).tr)
If Rnd * 100 < 3 Then smoke(m).gx = smoke(m).gx + Int(Rnd * 2) - Int(Rnd * 2)
If Rnd * 100 < 3 Then smoke(m).gy = smoke(m).gy + Int(Rnd * 2) - Int(Rnd * 2)
If Rnd * 100 < smoke(m).v Then smoke(m).x = smoke(m).x + smoke(m).gx
If Rnd * 100 < smoke(m).v Then smoke(m).y = smoke(m).y + smoke(m).gy
If smoke(m).x > _Width Or smoke(m).x < 0 Then smoke(m).x = Int(1 + Rnd * _Width)
If smoke(m).y > _Height Or smoke(m).y < 0 Then smoke(m).y = Int(1 + Rnd * _Width)
Select Case kk$
Case "w"
smoke(m).gy = smoke(m).gy - Int(Rnd * 4)
Case "a"
smoke(m).gx = smoke(m).gx - Int(Rnd * 4)
Case "s"
smoke(m).gy = smoke(m).gy + Int(Rnd * 4)
Case "d"
smoke(m).gx = smoke(m).gx + Int(Rnd * 4)
Case "R"
If Rnd * 100 < 66 Then
smoke(m).kr = smoke(m).kr + Int(Rnd * 3)
If smoke(m).kr > 255 Then smoke(m).kr = 0
End If
Case "G"
If Rnd * 100 < 66 Then
smoke(m).kg = smoke(m).kg + Int(Rnd * 3)
If smoke(m).kg > 255 Then smoke(m).kg = 0
End If
Case "B"
If Rnd * 100 < 66 Then
smoke(m).kb = smoke(m).kb + Int(Rnd * 3)
If smoke(m).kb > 255 Then smoke(m).kb = 0
End If
Case "r"
If Rnd * 100 < 66 Then
smoke(m).kr = smoke(m).kr - Int(Rnd * 3)
If smoke(m).kr < 0 Then smoke(m).kr = 255
End If
Case "g"
If Rnd * 100 < 66 Then
smoke(m).kg = smoke(m).kg - Int(Rnd * 3)
If smoke(m).kg < 0 Then smoke(m).kg = 255
End If
Case "b"
If Rnd * 100 < 66 Then
smoke(m).kb = smoke(m).kb - Int(Rnd * 3)
If smoke(m).kb < 0 Then smoke(m).kb = 255
End If
Case "v"
If Rnd * 100 < 66 Then
smoke(m).v = smoke(m).v - Int(Rnd * 3)
If smoke(m).v < 1 Then smoke(m).v = 1
End If
Case "V"
If Rnd * 100 < 66 Then
smoke(m).v = smoke(m).v + Int(Rnd * 3)
If smoke(m).v > 98 Then smoke(m).v = 98
End If
Case "m"
If Rnd * 100 < 66 Then
smoke(m).r = smoke(m).r * .95
End If
Case "M"
If Rnd * 100 < 66 Then
smoke(m).r = smoke(m).r * 1.1
End If
Case "t"
If Rnd * 100 < 66 Then
smoke(m).tr = smoke(m).tr * .95
End If
Case "T"
If Rnd * 100 < 66 Then
smoke(m).tr = smoke(m).tr * 1.1
End If
End Select
Next m
Select Case kk$
Case "<"
mm = mm - Int(1 + Rnd * 100)
If mm < 10 Then mm = 10
Case ">"
mm = mm + Int(1 + Rnd * 100)
If mm > 60000 Then mm = 60000
End Select
_Display
kk$ = InKey$
Loop Until kk$ = Chr$(27)
Sub CircleFill (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: 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), 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
Something that I've needed for one of my projects for a long time. A modification of the circle fill algorithm that restricts the draw to the limits of a bounding box. I'm not sure why it took me so long to get around to this, but here it is, in case someone can make use of it or are inspired to wow us with a better solution.
Left button click to place the center of the box, mousewheel to change the box size.
Code: (Select All)
'OldMoses' mod of Steve's circle fill
'drawing only those portions that fit the bounding box
'e% = 128
sz% = 50
ls% = 300
rs% = 400
t% = 100
b% = 200
SCREEN _NEWIMAGE(1024, 512, 32)
DO
WHILE _MOUSEINPUT
osz% = wsz%
wsz% = SGN(_MOUSEWHEEL) * 3
IF osz% <> sz% THEN
ls% = ls% - wsz%: rs% = rs% + wsz%
t% = t% - wsz%: b% = b% + wsz%
sz% = sz% + wsz%
END IF
WEND
IF _MOUSEBUTTON(1) THEN
ls% = _MOUSEX - sz%: rs% = _MOUSEX + sz%
t% = _MOUSEY - sz%: b% = _MOUSEY + sz%
END IF
'CIRCLE (512, 256), 128, &H7FFF0000
FCirc 512, 256, 128, &H7FFF0000 ' Steve's unmodified circle fill
FCircPart 512, 256, 128, &H7F00FF00, ls%, rs%, t%, b% ' modified partial circle fill
_LIMIT 30
_DISPLAY
LOOP UNTIL _KEYDOWN(27)
END
SUB FCircPart (CX AS LONG, CY AS LONG, RR AS LONG, C AS _UNSIGNED LONG, lt AS LONG, rt AS LONG, t AS LONG, b AS LONG) 'modified circle fill
IF rt < CX - RR OR lt > CX + RR OR t > CY + RR OR b < CY - RR THEN EXIT SUB 'leave if box not intersecting circle
DIM AS LONG R, RError, X, Y
R = ABS(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB ' zero radius is point, not circle
IF CY >= t AND CY <= b THEN LINE (MinOf&(CX - X, lt), CY)-(MaxOf&(CX + X, rt), CY), C, BF 'draw equatorial line if applicable
WHILE X > Y
RError = RError + Y * 2 + 1 '
IF RError >= 0 THEN
IF X <> Y + 1 THEN
IF CY - X >= t AND CY - X <= b AND CX - Y <= rt AND CX + Y >= lt THEN
LINE (MinOf&(CX - Y, lt), CY - X)-(MaxOf&(CX + Y, rt), CY - X), C, BF ' draw lines for south polar latitudes
END IF
IF CY + X <= b AND CY + X >= t AND CX - Y <= rt AND CX + Y >= lt THEN
LINE (MinOf&(CX - Y, lt), CY + X)-(MaxOf&(CX + Y, rt), CY + X), C, BF ' draw lines for north polar latitudes
END IF
END IF
X = X - 1
RError = RError - X * 2
END IF
Y = Y + 1
IF CY - Y >= t AND CY - Y <= b AND CX - X <= rt AND CX + X >= lt THEN
LINE (MinOf&(CX - X, lt), CY - Y)-(MaxOf&(CX + X, rt), CY - Y), C, BF ' draw lines north equatorial latitudes
END IF
IF CY + Y <= b AND CY + Y >= t AND CX - X <= rt AND CX + X >= lt THEN
LINE (MinOf&(CX - X, lt), CY + Y)-(MaxOf&(CX + X, rt), CY + Y), C, BF ' draw lines south equatorial latitudes
END IF
WEND
END SUB 'FCircPart
SUB FCirc (CX AS LONG, CY AS LONG, RR AS LONG, C AS _UNSIGNED LONG) 'Steve's circle fill unmodified
DIM AS LONG R, RError, X, Y
R = ABS(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB ' zero radius is point, not circle
LINE (CX - X, CY)-(CX + X, CY), C, BF ' draw equatorial line
WHILE X > Y
RError = RError + Y * 2 + 1 '
IF RError >= 0 THEN
IF X <> Y + 1 THEN
LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF ' draw lines for south polar latitudes
LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF ' draw lines for north polar latitudes
END IF
X = X - 1
RError = RError - X * 2
END IF
Y = Y + 1
LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF ' draw lines north equatorial latitudes
LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF ' draw lines south equatorial latitudes
WEND
END SUB 'FCirc
FUNCTION MaxOf& (value AS LONG, max AS LONG)
MaxOf& = -value * (value <= max) - max * (value > max)
END FUNCTION 'MaxOf%
FUNCTION MinOf& (value AS INTEGER, minimum AS INTEGER)
MinOf& = -value * (value >= minimum) - minimum * (value < minimum)
END FUNCTION 'MinOf%
First, I would like to say how much I am enjoying using QB64PE - This is my first post.
I have installed QB64PE it on a Linux VM but I have noticed that it takes my CPU up beyond 90% even when only the IDE is open and no code is running (the fan screaming lets me know!)
I have included two graphs below. The first with the larger area is QB64PE running a small program and then sitting in the IDE only.
The second with the smaller area, is the same small program in QB64.
![[Image: msedge-gy-Pqk3lokl.png]](https://i.ibb.co/N72DSTq/msedge-gy-Pqk3lokl.png)
![[Image: bmsedge-gy-Pqk3lokl.png]](https://i.ibb.co/t8gGTVV/bmsedge-gy-Pqk3lokl.png)
