johnno56
Junior Member
Logic is the beginning of wisdom.
Posts: 85
|
Post by johnno56 on May 7, 2021 16:44:58 GMT -5
This is a site dedicated to multiple forms of Basic. Here is a function I found on the QB64 forum. It draws a filled disc without the use of Trig or circle commands ... Using only filled boxes (rectangles).
Although it was written with QB64 in mind, my challenge is for it to be converted to all the other Basic's on this site, just to compare performance and to see if it can be done...
'from Steve Gold standard 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
fcirc 320, 240, 100, _RGB32(255, 0, 0)
If you are using a screen of 640x480 then this will draw a 200 pixel wide red disc in the center of the screen.
I have already converted this routine to run on RCBasic and it runs very well...
Who's next?
|
|
|
Post by bplus on May 7, 2021 16:56:42 GMT -5
Hey johnno56 Doesn't RCBasic have a built-in Circle Fill? That would likely be faster than from a subroutine though Steve's is really nice of course. I don't know maybe after compiled it doesn't matter built-in or add-on sub, then it's all binary? Also main code goes before subs in QB64 and you need to start in a graphics screen: Screen _NewImage(640, 480, 32) ' or any screen dimensions you like > 32 is for _RGB graphics colors
fcirc 320, 240, 100, _RGB32(255, 0, 0)
'from Steve Gold standard 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
|
|
|
Post by The Joyful Programmer on May 7, 2021 19:01:40 GMT -5
Now this is a funny thing to post!
What Johnno56 doesn't realize is that Steve's function actually stems from when I spent two weeks trying to learn how to add commands/statements to QB64. Once I figured it out, I posted a large post detailing everything and every file you must change to add your own commands.
Do you know what command I added to QB64, well, my copy of it? A filled circle!
I had created five different tests trying to figure out the fastest way of rendering them, and Steve decided to copy me and try his hand at it. Next thing you know, everybody was trying the same thing!
That was in April 2014 when I showed the community how to add commands to QB64. Here's the source code to my BAS demo using my new made command:
DIM ScreenWidth AS _UNSIGNED INTEGER DIM ScreenHeight AS _UNSIGNED INTEGER DIM MainScreen AS LONG DIM SHARED Count AS _UNSIGNED LONG
ScreenWidth = 800 ScreenHeight = 600 MainScreen = _NEWIMAGE(ScreenWidth, ScreenHeight, 32)
SCREEN _NEWIMAGE(800, 600, 32)
TestSeconds = 1
DO
Count = 1 BeginTimer# = TIMER
DO
_LIMIT 60
FOR iteration = 1 TO 100
Count = Count + 1 Colr& = _RGB(RND * 256, RND * 256, RND * 256)
EDI_CIRCLE (RND * 800, RND * 500 + 100), RND * 50 + 10, _RGBA(RND * 256, RND * 256, RND * 256, RND * 256)
IF TIMER - BeginTimer# >= TestSeconds THEN EXIT DO
NEXT
_DISPLAY
LOOP UNTIL _KEYHIT
LOCATE 1, 1: PRINT "Count: "; Count; " various size circles with random colors drawn per second."
LOOP WHILE INKEY$ = "" While Steve and I where trying to figure out who could draw the fastest circles, here's my source code to the five functions I was test (that I wrote by myself):
DIM SHARED ScreenWidth AS INTEGER DIM SHARED ScreenHeight AS INTEGER DIM SHARED CurrentTestScreen AS LONG DIM Radius AS INTEGER DIM CenterX AS INTEGER DIM CenterY AS INTEGER DIM Colr AS LONG DIM NumOfTests AS LONG DIM TimesToTest AS INTEGER
REDIM TestTotal(-1, -1) REDIM TestAverage(-1)
ScreenWidth = 800 ScreenHeight = 600 CenterX = ScreenWidth - (ScreenWidth / 4) - 10 CenterY = ScreenHeight / 2 Radius = 200 TestSeconds = 1 NumOfTests = 5 TimesToTest = 10
REDIM TestTotal(NumOfTests, TimesToTest) REDIM TestAverage(NumOfTests)
ScreenMain = _NEWIMAGE(ScreenWidth, ScreenHeight, 32) ScreenBackBuffer = _NEWIMAGE(ScreenWidth, ScreenHeight, 32)
SCREEN ScreenMain _TITLE "Circle speed test using the Pythagorean Theorm - LINE vs _MEMFILL vs _MEMPUT"
CurrentTestScreen = ScreenMain
' ********** START THE TESTS ********** COLOR _RGB(255, 255, 0) PRINT "Each test runs for"; TestSeconds; "seconds." PRINT "Each test speed number represents how many circles are drawn in"; TestSeconds; "seconds." PRINT PRINT COLOR _RGB(64, 255, 64) PRINT "QB64 LINE ", "_MEMFILL ", "_MEMPUT ", "QB LINE #2", "_MEMPUT #2" COLOR _RGB(218, 0, 215) PRINT "----------", "----------", "----------", "----------", "----------"
FOR OtherIteration = TimesToTest TO 1 STEP -1
' ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ' : : ' : TIGHTER TESTING PROCEDURES : ' : : ' :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
FOR currenttest = 0 TO NumOfTests - 1
COLOR _RGB(128, 128, 128) PRINT "T:"; LTRIM$(RTRIM$(STR$(OtherIteration))); ")"; IF OtherIteration < 10 THEN PRINT " ";
BeginTimer# = TIMER DO '_LIMIT 60
FOR i = 1 TO 100 ' ### An abitary number
Count = Count + 1 Colr = _RGBA32(RND * 255, RND * 255, RND * 255, 255)
SELECT CASE currenttest CASE 0 DrawFilledCircle CenterX, CenterY, Radius, Colr CASE 1 MemCircle CurrentTestScreen, CenterX, CenterY, Radius, Colr CASE 2 DrawFilledCircle2 CurrentTestScreen, CenterX, CenterY, Radius, Colr CASE 3 OctantCircle CurrentTestScreen, CenterX, CenterY, Radius, Colr CASE 4 OctantCircleMEMPUT CurrentTestScreen, CenterX, CenterY, Radius, Colr END SELECT
IF TIMER - BeginTimer# >= TestSeconds THEN EXIT DO NEXT
_DISPLAY
LOOP UNTIL _KEYHIT
TestTotal(currenttest, TimesToTest - OtherIteration) = Count
COLOR _RGB(255, 255, 255)
IF currenttest < NumOfTests - 1 THEN PRINT Count, ELSE PRINT Count END IF
Count = 0
_DISPLAY
NEXT NEXT
_DISPLAY
COLOR _RGB(218, 0, 215) PRINT "==========", "==========", "==========", "==========", "==========" COLOR _RGB(64, 255, 64) PRINT "TEST TOTAL ", "TEST TOTAL", "TEST TOTAL", "TEST TOTAL", "TEST TOTAL" COLOR _RGB(218, 0, 215) PRINT "----------", "----------", "----------", "----------", "----------" COLOR _RGB(255, 255, 255)
FOR i = 0 TO NumOfTests - 1
CurrentTestTotal = 0 FOR i2 = 0 TO TimesToTest - 1
CurrentTestTotal = CurrentTestTotal + TestTotal(i, i2)
NEXT
PRINT CurrentTestTotal, TestAverage(i) = CurrentTestTotal / TimesToTest
NEXT
PRINT
COLOR _RGB(218, 0, 215) PRINT "==========", "==========", "==========", "==========", "==========" COLOR _RGB(64, 255, 64) PRINT "AVERAGE ", "AVERAGE ", "AVERAGE ", "AVERAGE ", "AVERAGE " COLOR _RGB(218, 0, 215) PRINT "----------", "----------", "----------", "----------", "----------" COLOR _RGB(255, 255, 255)
FOR i = 0 TO NumOfTests - 1 PRINT TestAverage(i), NEXT
PRINT COLOR _RGB(218, 0, 215) PRINT "----------", "----------", "----------", "----------", "----------"
_DISPLAY
'DO: LOOP WHILE INKEY$ = ""
' ################################################################################################# ' # # ' ################################################################################################# SUB DrawFilledCircle (CenterX AS INTEGER, CenterY AS INTEGER, Radius AS INTEGER, Colr AS LONG)
DIM y AS INTEGER DIM x AS INTEGER DIM RadiusSquared AS LONG
RadiusSquared = Radius * Radius
FOR y = 0 TO Radius x = SQR(RadiusSquared - y * y) LINE (CenterX - x, CenterY - y)-(CenterX + x, CenterY - y), Colr&, BF LINE (CenterX - x, CenterY + y)-(CenterX + x, CenterY + y), Colr&, BF NEXT
END SUB
' ################################################################################################# ' # # ' ################################################################################################# SUB DrawFilledCircle2 (ScreenHandle AS LONG, CenterX AS INTEGER, CenterY AS INTEGER, Radius AS _UNSIGNED LONG, Colr AS _UNSIGNED LONG)
DIM ImageMemory AS _MEM DIM ImageXOffset AS _OFFSET DIM ImageOffset AS _OFFSET DIM ImageEndOffset AS _OFFSET DIM ImageByteWidth AS _UNSIGNED INTEGER DIM XCoordinate AS INTEGER DIM YCoordinate AS INTEGER DIM RadiusSquared AS _UNSIGNED LONG DIM LineWidth AS _UNSIGNED INTEGER
ImageMemory = _MEMIMAGE(ScreenHandle)
$CHECKING:OFF
YCoordinate = 0 ImageByteWidth = _WIDTH(ScreenHandle) * 4 ImageXOffset = ImageMemory.OFFSET + CenterX * 4 RadiusSquared = Radius ^ 2
DO XCoordinate = SQR(RadiusSquared - YCoordinate ^ 2) LineWidth = XCoordinate * 8
' *** Draw Top-Left and Top-Right quadrants of the circle ImageOffset = ImageXOffset + ImageByteWidth * (CenterY - YCoordinate) ImageEndOffset = ImageOffset + LineWidth
DO _MEMPUT ImageMemory, ImageOffset - XCoordinate * 4, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4
LOOP WHILE ImageOffset <= ImageEndOffset
' *** Draw Bottom-Left and Botton-Right quandrants of the circle ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + YCoordinate) ImageEndOffset = ImageOffset + LineWidth
DO _MEMPUT ImageMemory, ImageOffset - XCoordinate * 4, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4
LOOP WHILE ImageOffset <= ImageEndOffset YCoordinate = YCoordinate + 1
LOOP UNTIL YCoordinate >= Radius
$CHECKING:ON _MEMFREE ImageMemory
END SUB
' ################################################################################################# ' # # ' ################################################################################################# SUB MemCircle (ScreenHandle AS LONG, XC AS INTEGER, YC AS INTEGER, R AS INTEGER, Kolor AS _UNSIGNED LONG) 'To use this AS a filled circle routine, this MUST be used with 32 bit color screens. 'ScreenHandle is the screen we want to draw the circle on. 0 for the default screen 'XC is the X Center of our Circle. 'YC is the Y Center of our Circle. 'R is the Radius of our Circle. 'Kolor is the color we want to make our circle.
DIM m AS _MEM m = _MEMIMAGE(ScreenHandle) DIM O AS _OFFSET, O1 AS _OFFSET DIM W AS INTEGER DIM x AS INTEGER, y AS INTEGER
$CHECKING:OFF
y = 0 W = _WIDTH(ScreenHandle) * 4 O1 = m.OFFSET + XC * 4 R2 = R ^ 2 DO x = SQR(R2 - y ^ 2) O = O1 + W * (YC - y) _MEMFILL m, O - x * 4, x * 8, Kolor O = O1 + W * (YC + y) _MEMFILL m, O - x * 4, x * 8, Kolor y = y + 1 LOOP UNTIL y >= R $CHECKING:ON _MEMFREE m END SUB
' ################################################################################################# ' # # ' ################################################################################################# SUB OctantCircle (ScreenHandle AS LONG, CenterX AS INTEGER, CenterY AS INTEGER, Radius AS INTEGER, Colr AS _UNSIGNED LONG)
DIM x AS INTEGER DIM y AS INTEGER DIM r2 AS LONG
y = 0 r2 = Radius * Radius
DO x = SQR(r2 - y * y) LINE (CenterX - x, CenterY - y)-(CenterX + x, CenterY - y), Colr, BF LINE (CenterX - x, CenterY + y)-(CenterX + x, CenterY + y), Colr, BF y = y + 1
LOOP UNTIL y >= Radius
'DIM X AS INTEGER 'DIM y AS INTEGER 'DIM RadiusError AS LONG
'X = Radius 'y = 0 'RadiusError = 1 - X
'DO
' LINE (CenterX + -y, CenterY + -X)-(CenterX + y, CenterY + -X), Colr, BF ' LINE (CenterX + -X, CenterY + -y)-(CenterX + X, CenterY + -y), Colr, BF ' LINE (CenterX + X, CenterY + y)-(CenterX + -X, CenterY + y), Colr, BF ' LINE (CenterX + y, CenterY + X)-(CenterX + -y, CenterY + X), Colr, BF
' y = y + 1
' IF RadiusError < 0 THEN ' RadiusError = RadiusError + y + y + 1 ' ELSE ' X = X - 1 ' RadiusError = RadiusError + 2 * (y - X + 1) ' END IF
' IF INKEY$ <> "" THEN SYSTEM
'LOOP WHILE X >= y
END SUB
' ################################################################################################# ' # # ' ################################################################################################# SUB OctantCircleMEMPUT (ScreenHandle AS LONG, CenterX AS INTEGER, CenterY AS INTEGER, Radius AS INTEGER, Colr AS _UNSIGNED LONG)
DIM ImageMemory AS _MEM DIM ImageXOffset AS _OFFSET DIM ImageOffset AS _OFFSET DIM ImageEndOffset AS _OFFSET DIM ImageByteWidth AS _UNSIGNED INTEGER DIM XCoordinate AS INTEGER DIM YCoordinate AS INTEGER DIM RadiusSquared AS _UNSIGNED LONG DIM LineWidth AS _UNSIGNED INTEGER DIM X AS INTEGER DIM y AS INTEGER DIM RadiusError AS LONG
X = Radius y = 0 RadiusError = 1 - X
ImageMemory = _MEMIMAGE(ScreenHandle) ImageByteWidth = _WIDTH(ScreenHandle) * 4 'ImageXOffset = ImageMemory.OFFSET + CenterX * 4
DO
' ### FIRST SECTION ' LINE (CenterX + -y, CenterY + -X)-(CenterX + y, CenterY + -X), Colr, BF ImageXOffset = ImageMemory.OFFSET + (CenterX + -y) * 4 ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + -X) ImageEndOffset = ImageOffset + ((CenterX + y) - (CenterX + -y)) * 4
DO _MEMPUT ImageMemory, ImageOffset, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4 LOOP WHILE ImageOffset <= ImageEndOffset
' ### SECOND SECTION ' LINE (CenterX + -X, CenterY + -y)-(CenterX + X, CenterY + -y), Colr, BF ImageXOffset = ImageMemory.OFFSET + (CenterX + -X) * 4 ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + -y) ImageEndOffset = ImageOffset + ((CenterX + X) - (CenterX + -X)) * 4
DO _MEMPUT ImageMemory, ImageOffset, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4 LOOP WHILE ImageOffset <= ImageEndOffset
' ### THIRD SECTION ' LINE (CenterX + X, CenterY + y)-(CenterX + -X, CenterY + y), Colr, BF ImageXOffset = ImageMemory.OFFSET + (CenterX + -X) * 4 ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + y) ImageEndOffset = ImageOffset + ((CenterX + X) - (CenterX + -X)) * 4
DO _MEMPUT ImageMemory, ImageOffset, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4 LOOP WHILE ImageOffset <= ImageEndOffset
' ### FOURTH SECTION ' LINE (CenterX + y, CenterY + X)-(CenterX + -y, CenterY + X), Colr, BF ImageXOffset = ImageMemory.OFFSET + (CenterX + -y) * 4 ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + X) ImageEndOffset = ImageOffset + ((CenterX + y) - (CenterX + -y)) * 4
DO _MEMPUT ImageMemory, ImageOffset, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4 LOOP WHILE ImageOffset <= ImageEndOffset
y = y + 1
IF RadiusError < 0 THEN RadiusError = RadiusError + y + y + 1 ELSE X = X - 1 RadiusError = RadiusError + 2 * (y - X + 1) END IF
LOOP WHILE X >= y
END SUB
Here's the latest version of that demo I could find:
DIM SHARED ScreenWidth AS INTEGER DIM SHARED ScreenHeight AS INTEGER DIM SHARED CurrentTestScreen AS LONG DIM Radius AS INTEGER DIM CenterX AS INTEGER DIM CenterY AS INTEGER DIM Colr AS LONG DIM NumOfTests AS LONG DIM TimesToTest AS INTEGER
REDIM TestTotal(-1, -1) REDIM TestAverage(-1)
ScreenWidth = 800 ScreenHeight = 600 CenterX = ScreenWidth - (ScreenWidth / 4) - 10 CenterY = ScreenHeight / 2 Radius = 200 TestSeconds = 2 NumOfTests = 5 TimesToTest = 10
REDIM TestTotal(NumOfTests, TimesToTest) REDIM TestAverage(NumOfTests)
ScreenMain = _NEWIMAGE(ScreenWidth, ScreenHeight, 32) ScreenBackBuffer = _NEWIMAGE(ScreenWidth, ScreenHeight, 32)
SCREEN ScreenMain _TITLE "Circle speed test using the Pythagorean Theorm - LINE vs _MEMFILL vs _MEMPUT"
CurrentTestScreen = ScreenMain
' ********** START THE TESTS ********** COLOR _RGB(255, 255, 0) PRINT "Each test runs for"; TestSeconds; "seconds." PRINT "Each test speed number represents how many circles are drawn in"; TestSeconds; "seconds." PRINT PRINT COLOR _RGB(64, 255, 64) PRINT "QB64 LINE ", "_MEMFILL ", "_MEMPUT ", "QB LINE #2", "_MEMPUT #2" COLOR _RGB(218, 0, 215) PRINT "----------", "----------", "----------", "----------", "----------"
FOR OtherIteration = TimesToTest TO 1 STEP -1
' ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ' : : ' : TIGHTER TESTING PROCEDURES : ' : : ' :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
FOR currenttest = 0 TO NumOfTests - 1
COLOR _RGB(128, 128, 128) PRINT "T:"; LTRIM$(RTRIM$(STR$(OtherIteration))); ")"; IF OtherIteration < 10 THEN PRINT " ";
BeginTimer# = TIMER DO '_LIMIT 60
FOR i = 1 TO 100 ' ### An abitary number
Count = Count + 1 Colr = _RGBA32(RND * 255, RND * 255, RND * 255, 255)
SELECT CASE currenttest CASE 0 DrawFilledCircle CenterX, CenterY, Radius, Colr CASE 1 MemCircle CurrentTestScreen, CenterX, CenterY, Radius, Colr CASE 2 DrawFilledCircle2 CurrentTestScreen, CenterX, CenterY, Radius, Colr CASE 3 OctantCircle CurrentTestScreen, CenterX, CenterY, Radius, Colr CASE 4 OctantCircleMEMPUT CurrentTestScreen, CenterX, CenterY, Radius, Colr END SELECT
IF TIMER - BeginTimer# >= TestSeconds THEN EXIT DO NEXT
_DISPLAY
LOOP UNTIL _KEYHIT
TestTotal(currenttest, TimesToTest - OtherIteration) = Count
COLOR _RGB(255, 255, 255)
IF currenttest < NumOfTests - 1 THEN PRINT Count, ELSE PRINT Count END IF
Count = 0
_DISPLAY
NEXT NEXT
_DISPLAY
COLOR _RGB(218, 0, 215) PRINT "==========", "==========", "==========", "==========", "==========" COLOR _RGB(64, 255, 64) PRINT "TEST TOTAL ", "TEST TOTAL", "TEST TOTAL", "TEST TOTAL", "TEST TOTAL" COLOR _RGB(218, 0, 215) PRINT "----------", "----------", "----------", "----------", "----------" COLOR _RGB(255, 255, 255)
FOR i = 0 TO NumOfTests - 1
CurrentTestTotal = 0 FOR i2 = 0 TO TimesToTest - 1
CurrentTestTotal = CurrentTestTotal + TestTotal(i, i2)
NEXT
PRINT CurrentTestTotal, TestAverage(i) = CurrentTestTotal / TimesToTest
NEXT
PRINT
COLOR _RGB(218, 0, 215) PRINT "==========", "==========", "==========", "==========", "==========" COLOR _RGB(64, 255, 64) PRINT "AVERAGE ", "AVERAGE ", "AVERAGE ", "AVERAGE ", "AVERAGE " COLOR _RGB(218, 0, 215) PRINT "----------", "----------", "----------", "----------", "----------" COLOR _RGB(255, 255, 255)
FOR i = 0 TO NumOfTests - 1 PRINT TestAverage(i), NEXT
PRINT COLOR _RGB(218, 0, 215) PRINT "----------", "----------", "----------", "----------", "----------"
_DISPLAY
'DO: LOOP WHILE INKEY$ = ""
' ################################################################################################# ' # # ' ################################################################################################# SUB DrawFilledCircle (CenterX AS INTEGER, CenterY AS INTEGER, Radius AS INTEGER, Colr AS LONG)
RadiusSquared = Radius ^ 2
FOR y = 0 TO Radius x = SQR(RadiusSquared - y ^ 2) LINE (CenterX - x, CenterY - y)-(CenterX + x, CenterY - y), Colr& LINE (CenterX - x, CenterY + y)-(CenterX + x, CenterY + y), Colr& NEXT
END SUB
' ################################################################################################# ' # # ' ################################################################################################# SUB DrawFilledCircle2 (ScreenHandle AS LONG, CenterX AS INTEGER, CenterY AS INTEGER, Radius AS _UNSIGNED LONG, Colr AS _UNSIGNED LONG)
DIM ImageMemory AS _MEM DIM ImageXOffset AS _OFFSET DIM ImageOffset AS _OFFSET DIM ImageEndOffset AS _OFFSET DIM ImageByteWidth AS _UNSIGNED INTEGER DIM XCoordinate AS INTEGER DIM YCoordinate AS INTEGER DIM RadiusSquared AS _UNSIGNED LONG DIM LineWidth AS _UNSIGNED INTEGER
ImageMemory = _MEMIMAGE(ScreenHandle)
$CHECKING:OFF
YCoordinate = 0 ImageByteWidth = _WIDTH(ScreenHandle) * 4 ImageXOffset = ImageMemory.OFFSET + CenterX * 4 RadiusSquared = Radius ^ 2
DO XCoordinate = SQR(RadiusSquared - YCoordinate ^ 2) LineWidth = XCoordinate * 8
' *** Draw Top-Left and Top-Right quadrants of the circle ImageOffset = ImageXOffset + ImageByteWidth * (CenterY - YCoordinate) ImageEndOffset = ImageOffset + LineWidth
DO _MEMPUT ImageMemory, ImageOffset - XCoordinate * 4, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4
LOOP WHILE ImageOffset <= ImageEndOffset
' *** Draw Bottom-Left and Botton-Right quandrants of the circle ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + YCoordinate) ImageEndOffset = ImageOffset + LineWidth
DO _MEMPUT ImageMemory, ImageOffset - XCoordinate * 4, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4
LOOP WHILE ImageOffset <= ImageEndOffset YCoordinate = YCoordinate + 1
LOOP UNTIL YCoordinate >= Radius
$CHECKING:ON _MEMFREE ImageMemory
END SUB
' ################################################################################################# ' # # ' ################################################################################################# SUB MemCircle (ScreenHandle AS LONG, XC AS INTEGER, YC AS INTEGER, R AS INTEGER, Kolor AS _UNSIGNED LONG) 'To use this AS a filled circle routine, this MUST be used with 32 bit color screens. 'ScreenHandle is the screen we want to draw the circle on. 0 for the default screen 'XC is the X Center of our Circle. 'YC is the Y Center of our Circle. 'R is the Radius of our Circle. 'Kolor is the color we want to make our circle.
DIM m AS _MEM m = _MEMIMAGE(ScreenHandle) DIM O AS _OFFSET, O1 AS _OFFSET DIM W AS INTEGER DIM x AS INTEGER, y AS INTEGER
$CHECKING:OFF
y = 0 W = _WIDTH(ScreenHandle) * 4 O1 = m.OFFSET + XC * 4 R2 = R ^ 2 DO x = SQR(R2 - y ^ 2) O = O1 + W * (YC - y) _MEMFILL m, O - x * 4, x * 8, Kolor O = O1 + W * (YC + y) _MEMFILL m, O - x * 4, x * 8, Kolor y = y + 1 LOOP UNTIL y >= R $CHECKING:ON _MEMFREE m END SUB
' ################################################################################################# ' # # ' ################################################################################################# SUB OctantCircle (ScreenHandle AS LONG, CenterX AS INTEGER, CenterY AS INTEGER, Radius AS INTEGER, Colr AS _UNSIGNED LONG)
DIM X AS INTEGER DIM y AS INTEGER DIM RadiusError AS LONG
X = Radius y = 0 RadiusError = 1 - X
DO
LINE (CenterX + -y, CenterY + -X)-(CenterX + y, CenterY + -X), Colr, BF LINE (CenterX + -X, CenterY + -y)-(CenterX + X, CenterY + -y), Colr, BF LINE (CenterX + X, CenterY + y)-(CenterX + -X, CenterY + y), Colr, BF LINE (CenterX + y, CenterY + X)-(CenterX + -y, CenterY + X), Colr, BF
y = y + 1
IF RadiusError < 0 THEN RadiusError = RadiusError + y + y + 1 ELSE X = X - 1 RadiusError = RadiusError + 2 * (y - X + 1) END IF
'IF INKEY$ <> "" THEN SYSTEM
LOOP WHILE X >= y
END SUB
' ################################################################################################# ' # # ' ################################################################################################# SUB OctantCircleMEMPUT (ScreenHandle AS LONG, CenterX AS INTEGER, CenterY AS INTEGER, Radius AS INTEGER, Colr AS _UNSIGNED LONG)
DIM ImageMemory AS _MEM DIM ImageXOffset AS _OFFSET DIM ImageOffset AS _OFFSET DIM ImageEndOffset AS _OFFSET DIM ImageByteWidth AS _UNSIGNED INTEGER DIM XCoordinate AS INTEGER DIM YCoordinate AS INTEGER DIM RadiusSquared AS _UNSIGNED LONG DIM LineWidth AS _UNSIGNED INTEGER DIM X AS INTEGER DIM y AS INTEGER DIM RadiusError AS LONG
X = Radius y = 0 RadiusError = 1 - X
ImageMemory = _MEMIMAGE(ScreenHandle) ImageByteWidth = _WIDTH(ScreenHandle) * 4 'ImageXOffset = ImageMemory.OFFSET + CenterX * 4
DO
' ### FIRST SECTION ' LINE (CenterX + -y, CenterY + -X)-(CenterX + y, CenterY + -X), Colr, BF ImageXOffset = ImageMemory.OFFSET + (CenterX + -y) * 4 ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + -X) ImageEndOffset = ImageOffset + ((CenterX + y) - (CenterX + -y)) * 4
DO _MEMPUT ImageMemory, ImageOffset, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4 LOOP WHILE ImageOffset <= ImageEndOffset
' ### SECOND SECTION ' LINE (CenterX + -X, CenterY + -y)-(CenterX + X, CenterY + -y), Colr, BF ImageXOffset = ImageMemory.OFFSET + (CenterX + -X) * 4 ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + -y) ImageEndOffset = ImageOffset + ((CenterX + X) - (CenterX + -X)) * 4
DO _MEMPUT ImageMemory, ImageOffset, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4 LOOP WHILE ImageOffset <= ImageEndOffset
' ### THIRD SECTION ' LINE (CenterX + X, CenterY + y)-(CenterX + -X, CenterY + y), Colr, BF ImageXOffset = ImageMemory.OFFSET + (CenterX + -X) * 4 ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + y) ImageEndOffset = ImageOffset + ((CenterX + X) - (CenterX + -X)) * 4
DO _MEMPUT ImageMemory, ImageOffset, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4 LOOP WHILE ImageOffset <= ImageEndOffset
' ### FOURTH SECTION ' LINE (CenterX + y, CenterY + X)-(CenterX + -y, CenterY + X), Colr, BF ImageXOffset = ImageMemory.OFFSET + (CenterX + -y) * 4 ImageOffset = ImageXOffset + ImageByteWidth * (CenterY + X) ImageEndOffset = ImageOffset + ((CenterX + y) - (CenterX + -y)) * 4
DO _MEMPUT ImageMemory, ImageOffset, Colr AS _UNSIGNED LONG ImageOffset = ImageOffset + 4 LOOP WHILE ImageOffset <= ImageEndOffset
y = y + 1
IF RadiusError < 0 THEN RadiusError = RadiusError + y + y + 1 ELSE X = X - 1 RadiusError = RadiusError + 2 * (y - X + 1) END IF
LOOP WHILE X >= y
END SUB So... Enjoy!
Walter Whitman The Joyful Programmer
|
|
|
Post by paul doe on May 8, 2021 2:42:51 GMT -5
Be it as it may, it can be ported to FreeBasic almost verbatim: 'from Steve Gold standard 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
screenRes( 640, 480, 32 ) '' 640x480 window, 32-bit color
fcirc( 320, 240, 100, rgb( 255, 0, 0 ) )
sleep() So, that's one less dialect to port
|
|
|
Post by bplus on May 8, 2021 12:57:23 GMT -5
For sb, as Paul Doe says, almost verbatim just fix the line statement by removing ()'s and used the easier QB color 12 for red
'sb fcirc 2021-05-08 b+ 2021-05-08 fcirc 320, 240, 100, 12
Sub fcirc (CX, CY, R, C) 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 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 Line CX - Y, CY + X, CX + Y, CY + X, C End If X = X - 1 RadiusError = RadiusError - X * 2 End If Y = Y + 1 Line CX - X, CY - Y, CX + X, CY - Y, C Line CX - X, CY + Y, CX + X, CY + Y, C Wend End Sub
Oh yeah, no need for Variable Types! You can, if you really need to, control the screen size but it is a PITA.
|
|
|
Post by bplus on May 8, 2021 14:31:57 GMT -5
Here is a special treat for everybody (well for me at least) I have the Bresenham Style Circle Fill translated to my oh (one handed) Interpreter. Here is what code looks like (edited in Notepad++): ' oh Interpreter - Fill Circle Bresenham Style b+ 2021-05-08
' center our origin on fixed screen 1024 X 672 and setup colors cx = d[xmax,2] cy = d[ymax,2] r = 100 ink 255;0;0 paper 0;0;0 cls ' call the circle fill sub gs fcirc\ end
fcirc\ radius = abs[r] radiusError = x[radius,-1] x = radius y = 0 if eq[radius,0] pix cx;cy rtn fi line s[cx,x];cy;a[cx,x];cy [ jmp lte[x,y] radiusError = a[radiusError,x[y,2],1] if gte[RadiusError,0] if noteq[x,a[y,1]] line s[cx,y];s[cy,x];a[cx,y];s[cy,x] line s[cx,y];a[cy,x];a[cx,y];a[cy,x] fi x = s[x,1] radiusError = s[radiusError,x[x,2]] fi y = a[y,1] line s[cx,x];s[cy,y];a[cx,x];s[cy,y] line s[cx,x];a[cy,y];a[cx,x];a[cy,y] ] rtn
And here is screen shot from successful Run: johnno56 you didn't ask for blue? ;-)) EDIT: Funny thing I had to paste Notepad++ code into QB64 IDE to get the indents right from Notepad++ to this forum editor.
|
|