QB64.org Forum

Active Forums => Programs => Topic started by: SMcNeill on February 06, 2019, 02:13:34 pm

Title: CircleFiller
Post by: SMcNeill on February 06, 2019, 02:13:34 pm

Since Bplus likes balls so much, I thought I'd give him a new, never before seen, SUPER CircleFiller!!

Code: QB64: [Select]

1. SCREEN _NEWIMAGE(640, 480, 32)
2.  
3. CONST Red = &HFFFF0000
4.  
5. LINE (200, 200)-(400, 400), Red, B
6. CircleFiller 300, 300, 10, Red
7.  
8. SLEEP
9. CLS , 0
10. CIRCLE (320, 240), 100, Red
11. CircleFiller 320, 240, 10, Red
12.  
13.  
14. SUB CircleFiller (x, y, r, k AS _UNSIGNED LONG)
15.     IF CircleFillValid(x, y, r, k) THEN
16.         CircleFill x, y, r, k
17.         CircleFiller x - r - r - 1, y, r, k
18.         CircleFiller x + r + r + 1, y, r, k
19.         CircleFiller x, y - r - r - 1, r, k
20.         CircleFiller x, y + r + r + 1, r, k
21.     END IF
22. END SUB
23.  
24.  
25.  
26.  
27.  
28.  
29. SUB CircleFill (cx AS INTEGER, cy AS INTEGER, r AS INTEGER, c AS _UNSIGNED LONG)
30.     DIM a AS LONG, b AS LONG
31.     DIM x AS LONG, y AS LONG
32.     DIM xx AS LONG, yy AS LONG
33.     DIM sx AS LONG, sy AS LONG
34.     DIM e AS LONG
35.     DIM rx AS INTEGER, ry AS INTEGER
36.     rx = r: ry = r
37.  
38.     a = 2 * rx * rx
39.     b = 2 * ry * ry
40.     x = rx
41.     xx = ry * ry * (1 - rx - rx)
42.     yy = rx * rx
43.     sx = b * rx
44.  
45.     DO WHILE sx >= sy
46.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
47.         IF y <> 0 THEN LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
48.  
49.         y = y + 1
50.         sy = sy + a
51.         e = e + yy
52.         yy = yy + a
53.  
54.         IF (e + e + xx) > 0 THEN
55.             x = x - 1
56.             sx = sx - b
57.             e = e + xx
58.             xx = xx + b
59.         END IF
60.     LOOP
61.  
62.     x = 0
63.     y = ry
64.     xx = rx * ry
65.     yy = rx * rx * (1 - ry - ry)
66.     e = 0
67.     sx = 0
68.     sy = a * ry
69.  
70.     DO WHILE sx <= sy
71.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
72.         LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
73.  
74.         DO
75.             x = x + 1
76.             sx = sx + b
77.             e = e + xx
78.             xx = xx + b
79.         LOOP UNTIL (e + e + yy) > 0
80.  
81.         y = y - 1
82.         sy = sy - a
83.         e = e + yy
84.         yy = yy + a
85.  
86.     LOOP
87.  
88. END SUB
89.  
90.  
91. FUNCTION CircleFillValid (cx AS INTEGER, cy AS INTEGER, r AS INTEGER, c AS _UNSIGNED LONG)
92.     DIM a AS LONG, b AS LONG
93.     DIM x AS LONG, y AS LONG
94.     DIM xx AS LONG, yy AS LONG
95.     DIM sx AS LONG, sy AS LONG
96.     DIM e AS LONG
97.     DIM rx AS INTEGER, ry AS INTEGER
98.     rx = r: ry = r
99.  
100.     a = 2 * rx * rx
101.     b = 2 * ry * ry
102.     x = rx
103.     xx = ry * ry * (1 - rx - rx)
104.     yy = rx * rx
105.     sx = b * rx
106.  
107.     DO WHILE sx >= sy
108.         FOR i = cx - x TO cx + x
109.             IF POINT(i, cy - y) = c THEN EXIT FUNCTION
110.         NEXT
111.         'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
112.         IF y <> 0 THEN
113.             'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
114.             FOR i = cx - x TO cx + x
115.                 IF POINT(i, cy + y) = c THEN EXIT FUNCTION
116.             NEXT
117.         END IF
118.  
119.         y = y + 1
120.         sy = sy + a
121.         e = e + yy
122.         yy = yy + a
123.  
124.         IF (e + e + xx) > 0 THEN
125.             x = x - 1
126.             sx = sx - b
127.             e = e + xx
128.             xx = xx + b
129.         END IF
130.     LOOP
131.  
132.     x = 0
133.     y = ry
134.     xx = rx * ry
135.     yy = rx * rx * (1 - ry - ry)
136.     e = 0
137.     sx = 0
138.     sy = a * ry
139.  
140.     DO WHILE sx <= sy
141.         'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
142.         'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
143.         FOR i = cx - x TO cx + x
144.             IF POINT(i, cy - y) = c THEN EXIT FUNCTION
145.             IF POINT(i, cy + y) = c THEN EXIT FUNCTION
146.         NEXT
147.  
148.         DO
149.             x = x + 1
150.             sx = sx + b
151.             e = e + xx
152.             xx = xx + b
153.         LOOP UNTIL (e + e + yy) > 0
154.  
155.         y = y - 1
156.         sy = sy - a
157.         e = e + yy
158.         yy = yy + a
159.  
160.     LOOP
161.     CircleFillValid = -1
162. END SUB
163.  

This can also be easily modified to become an EllipseFiller (as I'm actually using the EllipseFill routines for this and modified them so rx/ry are both passed by r instead...), if case anyone wants a nice EllipseFiller utility.

And what's the purpose of this, you ask?

I was thinking of plugging it into my little hourglass program so it'd drop balls instead of sand, but then I figured, "Nah... I'm too lazy.  This is good enough.  Somebody else can go back and insert the routines into the program if they want to now.  I'm going to dinner and a movie with the wife..."

:P

Title: Re: CircleFiller
Post by: bplus on February 06, 2019, 05:33:39 pm

Oh balls! ;-))

I have check on 1 to show that no more balls can be placed inside the random rectangle, but for a fun show change check to 0.

Code: QB64: [Select]

1. _TITLE "Circle Filled by Steve mod B+" '2019-02-06
2. CONST xmax = 800
3. CONST ymax = 600
4. SCREEN _NEWIMAGE(xmax, ymax, 32)
5. _SCREENMOVE _MIDDLE
6.  
7. CONST Red = &HFF880000
8. DIM SHARED check
9. check = 1 ' 0 or 1 to check the rack
10.  
11. PRINT "Test rack: (200, 200)-(400, 400), radius =10, color =Red"
12. LINE (200, 200)-(400, 400), &HFFFFFFFF, B
13. fillWithBalls 200, 200, 200, 200, 10, Red
14. INPUT "To see a show, press enter,  and other + enter ends program... "; wate$
15. CLS
16. WHILE _KEYDOWN(27) = 0
17.     IF check = 1 THEN CLS
18.     w = rand(50, 300): h = rand(50, 300)
19.     fillWithBalls rand(0, xmax - w - 1), rand(0, ymax - h - 1), w, h, rand(4, 20), _RGB32(RND * 255, RND * 255, RND * 255)
20.     _DISPLAY
21.     IF check THEN _LIMIT .3 ELSE _LIMIT 1
22. WEND
23.  
24. SUB fillWithBalls (topX, topY, wide, height, ballRadius, ballColr AS _UNSIGNED LONG)
25.     xLeft = topX + wide
26.     yBelow = topY + height
27.     'check the rack
28.     IF check = 1 THEN LINE (topX, topY)-(xLeft, yBelow), &HFFFFFFFF, B
29.     FOR y = yBelow - ballRadius TO topY + ballRadius STEP -SQR(3) * ballRadius
30.         layer = layer + 1
31.         IF layer MOD 2 = 0 THEN spacer = ballRadius ELSE spacer = 0
32.         IF y + SQR(3) * ballRadius <= yBelow + ballRadius THEN
33.             FOR x = topX + ballRadius TO xLeft STEP 2 * ballRadius
34.                 IF spacer + x - ballRadius >= topX AND spacer + x + ballRadius <= xLeft + 2 THEN
35.                     ball spacer + x, y, ballRadius, ballColr
36.                     'check ball fill = tangent white circles
37.                     IF check = 1 THEN CIRCLE (spacer + x, y), ballRadius, &HFFFFFFFF ' be honest with edges
38.                 ELSE
39.                     'check ball fill = tangent white circles
40.                     IF check = 1 THEN CIRCLE (spacer + x, y), ballRadius, &HFFFFFFFF ' be honest with edges
41.                 END IF
42.             NEXT
43.         END IF
44.     NEXT
45. END SUB
46.  
47.  
48. 'here it is! The ball sub !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
49. SUB ball (x AS INTEGER, y AS INTEGER, r AS INTEGER, K AS _UNSIGNED LONG)
50.     DIM rd AS _UNSIGNED LONG, g AS _UNSIGNED LONG, b AS LONG, kr AS _UNSIGNED LONG
51.     rd = _RED32(K): g = _GREEN32(K): b = _BLUE32(K)
52.     FOR rad = r TO 1 STEP -1
53.         kr = _RGB32((r - rad) / r * rd, (r - rad) / r * g, (r - rad) / r * b)
54.         fel x, y, rad, rad, kr
55.     NEXT
56. END SUB
57.  
58. 'FillEllipse is too much typing so using fel
59. ' with Steve's EllipseFill, who needs CircleFill? fix for 0 radii 2019-02-05
60. ' Is this fast enough for general circle fill (June 2018):  https://www.qb64.org/forum/index.php?topic=298.msg1942#msg1942
61. '  EllipseFill SMcNeill (Nov 3, 2018) https://www.qb64.org/forum/index.php?topic=755.msg6506#msg6506
62. SUB fel (cx AS INTEGER, cy AS INTEGER, rx AS INTEGER, ry AS INTEGER, c AS _UNSIGNED LONG)
63.     DIM a AS LONG, b AS LONG
64.     DIM x AS LONG, y AS LONG
65.     DIM xx AS LONG, yy AS LONG
66.     DIM sx AS LONG, sy AS LONG
67.     DIM e AS LONG
68.  
69.     IF rx = 0 OR ry = 0 THEN EXIT SUB 'nothing to draw
70.  
71.     a = 2 * rx * rx
72.     b = 2 * ry * ry
73.     x = rx
74.     xx = ry * ry * (1 - rx - rx)
75.     yy = rx * rx
76.     sx = b * rx
77.  
78.     DO WHILE sx >= sy
79.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
80.         IF y <> 0 THEN LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
81.  
82.         y = y + 1
83.         sy = sy + a
84.         e = e + yy
85.         yy = yy + a
86.  
87.         IF (e + e + xx) > 0 THEN
88.             x = x - 1
89.             sx = sx - b
90.             e = e + xx
91.             xx = xx + b
92.         END IF
93.     LOOP
94.  
95.     x = 0
96.     y = ry
97.     xx = rx * ry
98.     yy = rx * rx * (1 - ry - ry)
99.     e = 0
100.     sx = 0
101.     sy = a * ry
102.  
103.     DO WHILE sx <= sy
104.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
105.         LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
106.  
107.         DO
108.             x = x + 1
109.             sx = sx + b
110.             e = e + xx
111.             xx = xx + b
112.         LOOP UNTIL (e + e + yy) > 0
113.  
114.         y = y - 1
115.         sy = sy - a
116.         e = e + yy
117.         yy = yy + a
118.  
119.     LOOP
120.  
121. END SUB
122.  
123. FUNCTION rand% (lo%, hi%)
124.     rand% = INT(RND * (hi% - lo% + 1)) + lo%
125. END FUNCTION
126.  

Title: Re: CircleFiller
Post by: STxAxTIC on February 06, 2019, 05:40:49 pm

Ah cool, your screenshot shows you got the right packing density for circles.

Title: Re: CircleFiller
Post by: SMcNeill on February 06, 2019, 05:50:47 pm

Only one thing, Bp:  Mine fills any area, like a paint fill would.  Yours is just working on creating balls in a rectangular area, unless I’m mistaken?

Title: Re: CircleFiller
Post by: STxAxTIC on February 06, 2019, 05:53:54 pm

While we're on this, someone tell me why everyone's ellipse fill functions are getting so huge. This is all you need at most for regular ellipses (yeah, it works in the code above, but I plead Steve's argument - I'm to lazy to fix his code and show you!):

Code: QB64: [Select]

1. SCREEN 12
2.  
3. CALL efill(50, 150, 80, 40, 4)
4.  
5. SUB efill (x0, y0, a, b, c)
6.     FOR i = -a TO a
7.         y1 = b * SQR(1 - i ^ 2 / a ^ 2)
8.         y2 = -b * SQR(1 - i ^ 2 / a ^ 2)
9.         LINE (i + 320 + x0, -y1 + 240 - y0)-(i + 320 + x0, -y2 + 240 - y0), c, B
10.     NEXT
11. END SUB

Title: Re: CircleFiller
Post by: bplus on February 06, 2019, 05:56:28 pm

Quote from: SMcNeill on February 06, 2019, 05:50:47 pm

Only one thing, Bp:  Mine fills any area, like a paint fill would.  Yours is just working on creating balls in a rectangular area, unless I’m mistaken?

Steve, you are not mistaken. I missed the "fill any area" from your demo. So you could fill a circle or triangle without going outside the lines?

Title: Re: CircleFiller
Post by: bplus on February 06, 2019, 05:57:01 pm

Quote from: STxAxTIC on February 06, 2019, 05:53:54 pm

While we're on this, someone tell me why everyone's ellipse fill functions are getting so huge. This is all you need at most for regular ellipses (yeah, it works in the code above, but I plead Steve's argument - I'm to lazy to fix his code and show you!):

Code: QB64: [Select]

1. SCREEN 12
2.  
3. CALL efill(50, 150, 80, 40, 4)
4.  
5. SUB efill (x0, y0, a, b, c)
6.     FOR i = -a TO a
7.         y1 = b * SQR(1 - i ^ 2 / a ^ 2)
8.         y2 = -b * SQR(1 - i ^ 2 / a ^ 2)
9.         LINE (i + 320 + x0, -y1 + 240 - y0)-(i + 320 + x0, -y2 + 240 - y0), c, B
10.     NEXT
11. END SUB

You want to race? ;-))

Title: Re: CircleFiller
Post by: STxAxTIC on February 06, 2019, 06:05:22 pm

Sure, run the speed test. I'm curious to see if my two uses of SQR are slower than the fluffy version yall are using.

EDIT

Lol, you can remove the ,B at the end of my LINE statement though... Oh and for that matter, I can see how this can be made 4 times as fast. Let me know if you actually want to run a test and I'll cook up a different function. Or hell, use the one as-is, I'm still curious.

Title: Re: CircleFiller
Post by: SMcNeill on February 06, 2019, 06:10:28 pm

Quote from: bplus on February 06, 2019, 05:56:28 pm

Quote from: SMcNeill on February 06, 2019, 05:50:47 pm

Only one thing, Bp:  Mine fills any area, like a paint fill would.  Yours is just working on creating balls in a rectangular area, unless I’m mistaken?

Steve, you are not mistaken. I missed the "fill any area" from your demo. So you could fill a circle or triangle without going outside the lines?

Hit any key..  The demo itself already has a circle filled with circles.  ;)

Code: QB64: [Select]

1. SLEEP
2. CLS , 0
3. CIRCLE (320, 240), 100, Red
4. CircleFiller 320, 240, 10, Red

It’s more or less ready to plug directly into the hourglass demo.  (Just widen the gap to the size of your circle so it looks “natural”.)

Title: Re: CircleFiller
Post by: STxAxTIC on February 06, 2019, 06:42:42 pm

Throw this into the test bucket too. Test case involves transparency!

Code: QB64: [Select]

1. SCREEN _NEWIMAGE(800, 600, 32)
2.  
3. CALL efill(50, 150, 80, 40, _RGBA(100, 200, 0, 100))
4. CALL efill(70, 130, 80, 40, _RGBA(200, 100, 0, 100))
5.  
6. SUB efill (x0, y0, a, b, c AS LONG)
7.     a2 = a / SQR(2)
8.     b2 = b / SQR(2)
9.     LINE (-a2 + _WIDTH / 2 + x0, -b2 + _HEIGHT / 2 - y0)-(a2 + _WIDTH / 2 + x0, b2 + _HEIGHT / 2 - y0), c, BF
10.     LINE (0 + _WIDTH / 2 + x0, -b + _HEIGHT / 2 - y0)-(0 + _WIDTH / 2 + x0, -b2 - 1 + _HEIGHT / 2 - y0), c
11.     LINE (0 + _WIDTH / 2 + x0, b + _HEIGHT / 2 - y0)-(0 + _WIDTH / 2 + x0, b2 + 1 + _HEIGHT / 2 - y0), c
12.     LINE (-a + _WIDTH / 2 + x0, 0 + _HEIGHT / 2 - y0)-(-a2 - 1 + _WIDTH / 2 + x0, 0 + _HEIGHT / 2 - y0), c
13.     LINE (a + _WIDTH / 2 + x0, 0 + _HEIGHT / 2 - y0)-(a2 + 1 + _WIDTH / 2 + x0, 0 + _HEIGHT / 2 - y0), c
14.     FOR i = 1 TO a2
15.         y1 = b * SQR(1 - i ^ 2 / a ^ 2)
16.         LINE (i + _WIDTH / 2 + x0, -y1 + _HEIGHT / 2 - y0)-(i + _WIDTH / 2 + x0, -b2 - 1 + _HEIGHT / 2 - y0), c
17.         LINE (-i + _WIDTH / 2 + x0, -y1 + _HEIGHT / 2 - y0)-(-i + _WIDTH / 2 + x0, -b2 - 1 + _HEIGHT / 2 - y0), c
18.         LINE (i + _WIDTH / 2 + x0, b2 + 1 + _HEIGHT / 2 - y0)-(i + _WIDTH / 2 + x0, y1 + _HEIGHT / 2 - y0), c
19.         LINE (-i + _WIDTH / 2 + x0, b2 + 1 + _HEIGHT / 2 - y0)-(-i + _WIDTH / 2 + x0, y1 + _HEIGHT / 2 - y0), c
20.     NEXT
21.     FOR j = 1 TO b2
22.         x1 = a * SQR(1 - j ^ 2 / b ^ 2)
23.         LINE (-x1 + _WIDTH / 2 + x0, j + _HEIGHT / 2 - y0)-(-a2 - 1 + _WIDTH / 2 + x0, j + _HEIGHT / 2 - y0), c
24.         LINE (-x1 + _WIDTH / 2 + x0, -j + _HEIGHT / 2 - y0)-(-a2 - 1 + _WIDTH / 2 + x0, -j + _HEIGHT / 2 - y0), c
25.         LINE (x1 + _WIDTH / 2 + x0, j + _HEIGHT / 2 - y0)-(a2 + 1 + _WIDTH / 2 + x0, j + _HEIGHT / 2 - y0), c
26.         LINE (x1 + _WIDTH / 2 + x0, -j + _HEIGHT / 2 - y0)-(a2 + 1 + _WIDTH / 2 + x0, -j + _HEIGHT / 2 - y0), c
27.     NEXT
28. END SUB
29.  

Title: Re: CircleFiller
Post by: bplus on February 06, 2019, 07:30:17 pm

Quote from: SMcNeill on February 06, 2019, 06:10:28 pm

Quote from: bplus on February 06, 2019, 05:56:28 pm

Quote from: SMcNeill on February 06, 2019, 05:50:47 pm

Only one thing, Bp:  Mine fills any area, like a paint fill would.  Yours is just working on creating balls in a rectangular area, unless I’m mistaken?

Steve, you are not mistaken. I missed the "fill any area" from your demo. So you could fill a circle or triangle without going outside the lines?

Hit any key..  The demo itself already has a circle filled with circles.  ;)

Code: QB64: [Select]

1. SLEEP
2. CLS , 0
3. CIRCLE (320, 240), 100, Red
4. CircleFiller 320, 240, 10, Red

It’s more or less ready to plug directly into the hourglass demo.  (Just widen the gap to the size of your circle so it looks “natural”.)

OK now I see it, POINT in the verification code. Yes, just draw a boundary, good!

My Minute Timer did need a fix for filling the top bowl. It was taking longer to fill the bowl than to run the timer, :P

Title: Re: CircleFiller
Post by: bplus on February 06, 2019, 07:30:59 pm

Quote from: STxAxTIC on February 06, 2019, 06:42:42 pm

Throw this into the test bucket too. Test case involves transparency!

Code: QB64: [Select]

1. SCREEN _NEWIMAGE(800, 600, 32)
2.  
3. CALL efill(50, 150, 80, 40, _RGBA(100, 200, 0, 100))
4. CALL efill(70, 130, 80, 40, _RGBA(200, 100, 0, 100))
5.  
6. SUB efill (x0, y0, a, b, c AS LONG)
7.     a2 = a / SQR(2)
8.     b2 = b / SQR(2)
9.     LINE (-a2 + _WIDTH / 2 + x0, -b2 + _HEIGHT / 2 - y0)-(a2 + _WIDTH / 2 + x0, b2 + _HEIGHT / 2 - y0), c, BF
10.     LINE (0 + _WIDTH / 2 + x0, -b + _HEIGHT / 2 - y0)-(0 + _WIDTH / 2 + x0, -b2 - 1 + _HEIGHT / 2 - y0), c
11.     LINE (0 + _WIDTH / 2 + x0, b + _HEIGHT / 2 - y0)-(0 + _WIDTH / 2 + x0, b2 + 1 + _HEIGHT / 2 - y0), c
12.     LINE (-a + _WIDTH / 2 + x0, 0 + _HEIGHT / 2 - y0)-(-a2 - 1 + _WIDTH / 2 + x0, 0 + _HEIGHT / 2 - y0), c
13.     LINE (a + _WIDTH / 2 + x0, 0 + _HEIGHT / 2 - y0)-(a2 + 1 + _WIDTH / 2 + x0, 0 + _HEIGHT / 2 - y0), c
14.     FOR i = 1 TO a2
15.         y1 = b * SQR(1 - i ^ 2 / a ^ 2)
16.         LINE (i + _WIDTH / 2 + x0, -y1 + _HEIGHT / 2 - y0)-(i + _WIDTH / 2 + x0, -b2 - 1 + _HEIGHT / 2 - y0), c
17.         LINE (-i + _WIDTH / 2 + x0, -y1 + _HEIGHT / 2 - y0)-(-i + _WIDTH / 2 + x0, -b2 - 1 + _HEIGHT / 2 - y0), c
18.         LINE (i + _WIDTH / 2 + x0, b2 + 1 + _HEIGHT / 2 - y0)-(i + _WIDTH / 2 + x0, y1 + _HEIGHT / 2 - y0), c
19.         LINE (-i + _WIDTH / 2 + x0, b2 + 1 + _HEIGHT / 2 - y0)-(-i + _WIDTH / 2 + x0, y1 + _HEIGHT / 2 - y0), c
20.     NEXT
21.     FOR j = 1 TO b2
22.         x1 = a * SQR(1 - j ^ 2 / b ^ 2)
23.         LINE (-x1 + _WIDTH / 2 + x0, j + _HEIGHT / 2 - y0)-(-a2 - 1 + _WIDTH / 2 + x0, j + _HEIGHT / 2 - y0), c
24.         LINE (-x1 + _WIDTH / 2 + x0, -j + _HEIGHT / 2 - y0)-(-a2 - 1 + _WIDTH / 2 + x0, -j + _HEIGHT / 2 - y0), c
25.         LINE (x1 + _WIDTH / 2 + x0, j + _HEIGHT / 2 - y0)-(a2 + 1 + _WIDTH / 2 + x0, j + _HEIGHT / 2 - y0), c
26.         LINE (x1 + _WIDTH / 2 + x0, -j + _HEIGHT / 2 - y0)-(a2 + 1 + _WIDTH / 2 + x0, -j + _HEIGHT / 2 - y0), c
27.     NEXT
28. END SUB
29.  

OK but Jeopardy is on now, so a little later...

Title: Re: CircleFiller
Post by: bplus on February 07, 2019, 12:54:50 am

OK here is a little mod of Steve's original post (now that I know how it works):

Code: QB64: [Select]

1. _TITLE "Circle Paint by Steve mod B+" '2019-02-06
2. SCREEN _NEWIMAGE(640, 480, 32)
3.  
4. CONST Red = &HFFFF0000
5.  
6. LINE (200, 200)-(400, 400), Red, B
7. CircleFiller 300, 300, 10, Red
8. PRINT "Hit any key for real fun!"
9. SLEEP
10. CLS , 0
11. WHILE _KEYDOWN(27) = 0
12.     CLS
13.     LINE (1, 1)-(639, 479), Red, B
14.     LINE (0, 0)-(640, 480), Red, B
15.     FOR i = 1 TO 5
16.         CIRCLE (RND * 640, RND * 480), RND * 30 + 20, Red
17.     NEXT
18.     CircleFiller 320, 240, 10, Red
19.     _DISPLAY
20.     _LIMIT .5
21. WEND
22.  
23. SUB CircleFiller (x, y, r, k AS _UNSIGNED LONG)
24.     IF CircleFillValid(x, y, r, k) THEN
25.         CircleFill x, y, r, k
26.         CircleFiller x - r - r - 1, y, r, k
27.         CircleFiller x + r + r + 1, y, r, k
28.         CircleFiller x, y - r - r - 1, r, k
29.         CircleFiller x, y + r + r + 1, r, k
30.     END IF
31. END SUB
32.  
33.  
34. SUB CircleFill (cx AS INTEGER, cy AS INTEGER, r AS INTEGER, c AS _UNSIGNED LONG)
35.     DIM a AS LONG, b AS LONG
36.     DIM x AS LONG, y AS LONG
37.     DIM xx AS LONG, yy AS LONG
38.     DIM sx AS LONG, sy AS LONG
39.     DIM e AS LONG
40.     DIM rx AS INTEGER, ry AS INTEGER
41.     rx = r: ry = r
42.  
43.     a = 2 * rx * rx
44.     b = 2 * ry * ry
45.     x = rx
46.     xx = ry * ry * (1 - rx - rx)
47.     yy = rx * rx
48.     sx = b * rx
49.  
50.     DO WHILE sx >= sy
51.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
52.         IF y <> 0 THEN LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
53.  
54.         y = y + 1
55.         sy = sy + a
56.         e = e + yy
57.         yy = yy + a
58.  
59.         IF (e + e + xx) > 0 THEN
60.             x = x - 1
61.             sx = sx - b
62.             e = e + xx
63.             xx = xx + b
64.         END IF
65.     LOOP
66.  
67.     x = 0
68.     y = ry
69.     xx = rx * ry
70.     yy = rx * rx * (1 - ry - ry)
71.     e = 0
72.     sx = 0
73.     sy = a * ry
74.  
75.     DO WHILE sx <= sy
76.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
77.         LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
78.  
79.         DO
80.             x = x + 1
81.             sx = sx + b
82.             e = e + xx
83.             xx = xx + b
84.         LOOP UNTIL (e + e + yy) > 0
85.  
86.         y = y - 1
87.         sy = sy - a
88.         e = e + yy
89.         yy = yy + a
90.  
91.     LOOP
92.  
93. END SUB
94.  
95.  
96. FUNCTION CircleFillValid (cx AS INTEGER, cy AS INTEGER, r AS INTEGER, c AS _UNSIGNED LONG)
97.     DIM a AS LONG, b AS LONG
98.     DIM x AS LONG, y AS LONG
99.     DIM xx AS LONG, yy AS LONG
100.     DIM sx AS LONG, sy AS LONG
101.     DIM e AS LONG
102.     DIM rx AS INTEGER, ry AS INTEGER
103.     rx = r: ry = r
104.  
105.     a = 2 * rx * rx
106.     b = 2 * ry * ry
107.     x = rx
108.     xx = ry * ry * (1 - rx - rx)
109.     yy = rx * rx
110.     sx = b * rx
111.  
112.     DO WHILE sx >= sy
113.         FOR i = cx - x TO cx + x
114.             IF POINT(i, cy - y) = c THEN EXIT FUNCTION
115.         NEXT
116.         'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
117.         IF y <> 0 THEN
118.             'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
119.             FOR i = cx - x TO cx + x
120.                 IF POINT(i, cy + y) = c THEN EXIT FUNCTION
121.             NEXT
122.         END IF
123.  
124.         y = y + 1
125.         sy = sy + a
126.         e = e + yy
127.         yy = yy + a
128.  
129.         IF (e + e + xx) > 0 THEN
130.             x = x - 1
131.             sx = sx - b
132.             e = e + xx
133.             xx = xx + b
134.         END IF
135.     LOOP
136.  
137.     x = 0
138.     y = ry
139.     xx = rx * ry
140.     yy = rx * rx * (1 - ry - ry)
141.     e = 0
142.     sx = 0
143.     sy = a * ry
144.  
145.     DO WHILE sx <= sy
146.         'LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
147.         'LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
148.         FOR i = cx - x TO cx + x
149.             IF POINT(i, cy - y) = c THEN EXIT FUNCTION
150.             IF POINT(i, cy + y) = c THEN EXIT FUNCTION
151.         NEXT
152.  
153.         DO
154.             x = x + 1
155.             sx = sx + b
156.             e = e + xx
157.             xx = xx + b
158.         LOOP UNTIL (e + e + yy) > 0
159.  
160.         y = y - 1
161.         sy = sy - a
162.         e = e + yy
163.         yy = yy + a
164.  
165.     LOOP
166.     CircleFillValid = -1
167. END SUB
168.  
169.  

Title: Re: CircleFiller
Post by: bplus on February 07, 2019, 03:23:04 am

And so likewise, Paint with Balls:

Code: QB64: [Select]

1. _TITLE "Circle Filled by Steve mod B+" '2019-02-06
2. CONST xmax = 800
3. CONST ymax = 600
4.  
5. SCREEN _NEWIMAGE(xmax, ymax, 32)
6. _SCREENMOVE _MIDDLE
7. DIM SHARED black AS _UNSIGNED LONG
8. black = _RGB32(0, 0, 0)
9.  
10. LINE (0, 0)-(800, 600), black, BF
11. LINE (200, 200)-(400, 400), &HFFFFFFFF, B
12. PaintWithBalls 300, 300, 10, _RGB32(255, 128, 0)
13. INPUT "To see a show, press enter,  and other + enter ends program... "; wate$
14.  
15. WHILE _KEYDOWN(27) = 0
16.     LINE (0, 0)-(800, 600), &HFF000000, BF
17.     LINE (0, 0)-(800, 600), _RGB32(255, 255, 255), B
18.     LINE (1, 1)-(799, 599), _RGB32(255, 255, 255), B
19.     FOR i = 1 TO 5
20.         LINE (RND * 800, RND * 600)-STEP(RND * 50 + 50, RND * 50 + 50), _RGB32(RND * 255, RND * 255, RND * 255), B
21.     NEXT
22.     PaintWithBalls 200, 200, INT(RND * 45 + 5), _RGB32(255, 100, 0)
23.     _LIMIT 1
24. WEND
25.  
26. SUB PaintWithBalls (X, Y, ballRadius, ballColr AS _UNSIGNED LONG)
27.     ra = _PI(2 / 6)
28.     br = 2 * ballRadius + 1
29.     IF circClear(X, Y, ballRadius) THEN
30.         ball X, Y, ballRadius, ballColr
31.         PaintWithBalls X + br * COS(0), Y + br * SIN(0), ballRadius, ballColr
32.         PaintWithBalls X + br * COS(ra), Y + br * SIN(ra), ballRadius, ballColr
33.         PaintWithBalls X + br * COS(ra * 2), Y + br * SIN(ra * 2), ballRadius, ballColr
34.         PaintWithBalls X + br * COS(ra * 3), Y + br * SIN(ra * 3), ballRadius, ballColr
35.         PaintWithBalls X + br * COS(ra * 4), Y + br * SIN(ra * 4), ballRadius, ballColr
36.         PaintWithBalls X + br * COS(ra * 5), Y + br * SIN(ra * 5), ballRadius, ballColr
37.     END IF
38. END SUB
39.  
40. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
41. FUNCTION circClear (CX AS LONG, CY AS LONG, R AS LONG)
42.     DIM subRadius AS LONG, RadiusError AS LONG
43.     DIM X AS LONG, Y AS LONG
44.  
45.     subRadius = ABS(R)
46.     RadiusError = -subRadius
47.     X = subRadius
48.     Y = 0
49.  
50.     'IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
51.  
52.     ' Draw the middle span here so we don't draw it twice in the main loop,
53.     ' which would be a problem with blending turned on.
54.     FOR i = CX - X TO CX + X
55.         IF POINT(i, CY) <> black THEN EXIT FUNCTION
56.     NEXT
57.     WHILE X > Y
58.         RadiusError = RadiusError + Y * 2 + 1
59.         IF RadiusError >= 0 THEN
60.             IF X <> Y + 1 THEN
61.                 FOR i = CX - Y TO CX + Y
62.                     IF POINT(i, CY - X) <> black THEN EXIT FUNCTION
63.                 NEXT
64.                 'LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
65.                 FOR i = CX - Y TO CX + Y
66.                     IF POINT(i, CY + X) <> black THEN EXIT FUNCTION
67.                 NEXT
68.                 'LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
69.             END IF
70.             X = X - 1
71.             RadiusError = RadiusError - X * 2
72.         END IF
73.         Y = Y + 1
74.         FOR i = CX - X TO CX + X
75.             IF POINT(i, CY - Y) <> black THEN EXIT FUNCTION
76.         NEXT
77.         'LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
78.  
79.         FOR i = CX - X TO CX + X
80.             IF POINT(i, CY + Y) <> black THEN EXIT FUNCTION
81.         NEXT
82.         'LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
83.  
84.     WEND
85.     circClear = -1
86. END FUNCTION
87.  
88. SUB ball (x AS INTEGER, y AS INTEGER, r AS INTEGER, K AS _UNSIGNED LONG)
89.     DIM rd AS _UNSIGNED LONG, g AS _UNSIGNED LONG, b AS LONG, kr AS _UNSIGNED LONG
90.     rd = _RED32(K): g = _GREEN32(K): b = _BLUE32(K)
91.     FOR rad = r TO 1 STEP -1
92.         kr = _RGB32((r - rad) / r * rd, (r - rad) / r * g, (r - rad) / r * b)
93.         fel x, y, rad, rad, kr
94.     NEXT
95. END SUB
96.  
97. 'FillEllipse is too much typing so aballRadiuseviated to fel
98. ' with Steve's EllipseFill, who needs CircleFill? fix for 0 radii 2019-02-05
99. ' Is this fast enough for general circle fill (June 2018):  https://www.qb64.org/forum/index.php?topic=298.msg1942#msg1942
100. '  EllipseFill SMcNeill (Nov 3, 2018) https://www.qb64.org/forum/index.php?topic=755.msg6506#msg6506
101. SUB fel (cx AS INTEGER, cy AS INTEGER, rx AS INTEGER, ry AS INTEGER, c AS _UNSIGNED LONG)
102.     DIM a AS LONG, b AS LONG
103.     DIM x AS LONG, y AS LONG
104.     DIM xx AS LONG, yy AS LONG
105.     DIM sx AS LONG, sy AS LONG
106.     DIM e AS LONG
107.  
108.     IF rx = 0 OR ry = 0 THEN EXIT SUB 'nothing to draw
109.  
110.     a = 2 * rx * rx
111.     b = 2 * ry * ry
112.     x = rx
113.     xx = ry * ry * (1 - rx - rx)
114.     yy = rx * rx
115.     sx = b * rx
116.  
117.     DO WHILE sx >= sy
118.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
119.         IF y <> 0 THEN LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
120.  
121.         y = y + 1
122.         sy = sy + a
123.         e = e + yy
124.         yy = yy + a
125.  
126.         IF (e + e + xx) > 0 THEN
127.             x = x - 1
128.             sx = sx - b
129.             e = e + xx
130.             xx = xx + b
131.         END IF
132.     LOOP
133.  
134.     x = 0
135.     y = ry
136.     xx = rx * ry
137.     yy = rx * rx * (1 - ry - ry)
138.     e = 0
139.     sx = 0
140.     sy = a * ry
141.  
142.     DO WHILE sx <= sy
143.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
144.         LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
145.  
146.         DO
147.             x = x + 1
148.             sx = sx + b
149.             e = e + xx
150.             xx = xx + b
151.         LOOP UNTIL (e + e + yy) > 0
152.  
153.         y = y - 1
154.         sy = sy - a
155.         e = e + yy
156.         yy = yy + a
157.  
158.     LOOP
159.  
160. END SUB
161.  
162. FUNCTION rand% (lo%, hi%)
163.     rand% = INT(RND * (hi% - lo% + 1)) + lo%
164. END FUNCTION
165.  
166.  

  [ This attachment cannot be displayed inline in 'Print Page' view ]  

Text Only | Text with Attachments