QB64.org Forum

Active Forums => Programs => Topic started by: bplus on April 07, 2019, 08:50:55 pm

Title: Circle Packing
Post by: bplus on April 07, 2019, 08:50:55 pm

Another idea from Shiffman, Circle Packing.

Basic random fill:

Code: QB64: [Select]

1. _TITLE "Circle Packing 1 fill" 'B+ started 2019-04-07  just basic random fill space
2. CONST xmax = 800
3. CONST ymax = 600
4. SCREEN _NEWIMAGE(xmax, ymax, 32)
5. _SCREENMOVE _MIDDLE
6.  
7. TYPE CircleType
8.     x AS SINGLE
9.     y AS SINGLE
10.     r AS SINGLE
11.     c AS _UNSIGNED LONG
12.     growing AS INTEGER
13. END TYPE
14. REDIM SHARED circles(1 TO 1) AS CircleType
15. DIM SHARED flagDone AS INTEGER
16.  
17. WHILE _KEYDOWN(27) = 0 AND flagDone = 0
18.     CLS
19.     newCircle 1
20.     drawCircles
21.     _DISPLAY
22.     _LIMIT 60
23. WEND
24. PRINT "done"
25.  
26. SUB drawCircles
27.     FOR i = 1 TO UBOUND(circles)
28.         IF circles(i).growing THEN 'check new r
29.             testr = circles(i).r + 2
30.             IF circles(i).x - testr < 0 OR circles(i).x + testr > xmax OR circles(i).y - testr < 0 OR circles(i).y + testr > ymax THEN
31.                 circles(i).growing = 0
32.             ELSE
33.                 'check if run into another circle
34.                 FOR j = 1 TO UBOUND(circles)
35.                     IF j <> i THEN
36.                         IF SQR((circles(j).x - circles(i).x) ^ 2 + (circles(j).y - circles(i).y) ^ 2) <= testr + circles(j).r THEN
37.                             circles(i).growing = 0: circles(j).growing = 0
38.                             EXIT FOR
39.                         END IF
40.                     END IF
41.                 NEXT
42.             END IF
43.         END IF
44.         IF circles(i).growing THEN circles(i).r = testr
45.         fcirc circles(i).x, circles(i).y, circles(i).r, circles(i).c
46.     NEXT
47.     PRINT UBOUND(circles)
48. END SUB
49.  
50. SUB newCircle (n)
51.     FOR i = 1 TO n
52.         attempts = 0
53.         retry:
54.         testX = RND * xmax: testY = RND * ymax
55.         OK = -1
56.         FOR j = 1 TO UBOUND(circles)
57.             IF SQR((testX - circles(j).x) ^ 2 + (testY - circles(j).y) ^ 2) < circles(j).r + 2 THEN OK = 0: EXIT FOR
58.         NEXT
59.         IF OK THEN
60.             new = UBOUND(circles) + 1
61.             REDIM _PRESERVE circles(1 TO new) AS CircleType
62.             circles(new).x = testX
63.             circles(new).y = testY
64.             circles(new).r = 1
65.             circles(new).growing = -1
66.             circles(new).c = _RGB32(RND * 155 + 100, RND * 155 + 100, RND * 155 + 100)
67.         ELSE
68.             attempts = attempts + 1
69.             IF attempts > 3000 THEN flagDone = -1: EXIT SUB
70.             GOTO retry
71.         END IF
72.     NEXT
73. END SUB
74.  
75. 'from Steve Gold standard
76. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
77.     DIM Radius AS INTEGER, RadiusError AS INTEGER
78.     DIM X AS INTEGER, Y AS INTEGER
79.  
80.     Radius = ABS(R)
81.     RadiusError = -Radius
82.     X = Radius
83.     Y = 0
84.  
85.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
86.  
87.     ' Draw the middle span here so we don't draw it twice in the main loop,
88.     ' which would be a problem with blending turned on.
89.     LINE (CX - X, CY)-(CX + X, CY), C, BF
90.  
91.     WHILE X > Y
92.         RadiusError = RadiusError + Y * 2 + 1
93.         IF RadiusError >= 0 THEN
94.             IF X <> Y + 1 THEN
95.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
96.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
97.             END IF
98.             X = X - 1
99.             RadiusError = RadiusError - X * 2
100.         END IF
101.         Y = Y + 1
102.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
103.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
104.     WEND
105. END SUB
106.  
107.  

It's more fun with images:

Title: Re: Circle Packing
Post by: Ashish on April 08, 2019, 03:50:34 am

Awesome bplus! I like the circle packing of QB64.

Title: Re: Circle Packing
Post by: qb4ever on April 08, 2019, 07:44:32 am

Very hypnotic, I am in loop with your program... :o
Well done, great job !

Title: Re: Circle Packing
Post by: bplus on April 08, 2019, 10:04:14 am

Thanks, I am "in loop" with your feedback! :)

Title: Re: Circle Packing
Post by: TempodiBasic on April 08, 2019, 03:54:04 pm

Hi Bplus

cool!
Are you sure that you have not made it for WaltDisney cartoon?
I have seen it watching TV!

Title: Re: Circle Packing
Post by: bplus on April 08, 2019, 08:09:17 pm

Of course, we don't have to pack just circles:

Code: QB64: [Select]

1. _TITLE "Circle Packing 4 nonCircles" 'B+ started 2019-04-08
2. CONST xmax = 1200
3. CONST ymax = 600
4. SCREEN _NEWIMAGE(xmax - 1, ymax - 1, 32)
5. _SCREENMOVE _MIDDLE
6. spbg& = _NEWIMAGE(xmax - 1, ymax - 1, 32)
7. _DEST spbg&
8. LINE (0, 0)-(xmax - 1, ymax - 1), _RGB32(0, 0, 0), BF
9. cText xmax / 2, ymax / 2, 500, _RGB32(255, 255, 255), "QB64"
10. _SOURCE spbg&
11. TYPE CircleType
12.     x AS INTEGER
13.     y AS INTEGER
14.     r AS INTEGER
15.     n AS INTEGER
16.     a AS SINGLE
17.     c AS _UNSIGNED LONG
18.     growing AS INTEGER
19. END TYPE
20. REDIM SHARED circles(0) AS CircleType
21. DIM SHARED flagDone AS INTEGER
22.  
23. WHILE _KEYDOWN(27) = 0 AND flagDone = 0
24.     CLS
25.     count = count + 1
26.     newCircle 20
27.     drawCircles
28.     _DISPLAY
29.     _LIMIT 60
30. WEND
31. PRINT "done"
32.  
33. SUB drawCircles
34.     FOR i = 1 TO UBOUND(circles)
35.         IF circles(i).growing THEN 'check new r
36.             testr = circles(i).r + 1
37.             IF circles(i).x - testr < 0 OR circles(i).x + testr > xmax - 1 OR circles(i).y - testr < 0 OR circles(i).y + testr > ymax - 2 THEN
38.                 circles(i).growing = 0
39.             ELSE
40.                 'check if run into another circle
41.                 FOR j = 1 TO UBOUND(circles)
42.                     IF j <> i THEN
43.                         IF SQR((circles(j).x - circles(i).x) ^ 2 + (circles(j).y - circles(i).y) ^ 2) <= testr + circles(j).r THEN
44.                             circles(i).growing = 0: circles(j).growing = 0
45.                             EXIT FOR
46.                         END IF
47.                     END IF
48.                 NEXT
49.             END IF
50.         END IF
51.         IF circles(i).growing THEN circles(i).r = testr
52.         star circles(i).x, circles(i).y, .3 * circles(i).r, circles(i).r, circles(i).n, circles(i).a, circles(i).c
53.     NEXT
54.     PRINT UBOUND(circles)
55. END SUB
56.  
57. SUB newCircle (n)
58.     FOR i = 1 TO n
59.         attempts = 0
60.         retry:
61.         testX = INT(RND * xmax): testY = INT(RND * ymax)
62.         OK = -1
63.         IF POINT(testX, testY) = _RGB32(255, 255, 255) THEN
64.             FOR j = 1 TO UBOUND(circles)
65.                 IF SQR((testX - circles(j).x) ^ 2 + (testY - circles(j).y) ^ 2) < circles(j).r + 3 THEN OK = 0: EXIT FOR
66.             NEXT
67.             IF OK THEN
68.                 new = UBOUND(circles) + 1
69.                 REDIM _PRESERVE circles(1 TO new) AS CircleType
70.                 circles(new).x = testX
71.                 circles(new).y = testY
72.                 circles(new).r = 3
73.                 circles(new).a = RND * _PI(2)
74.                 circles(new).n = 5 + INT(RND * 5)
75.                 circles(new).growing = -1
76.                 circles(new).c = _RGB32(RND * 255 + 55, RND * 200 + 55, RND * 200 + 55)
77.             ELSE
78.                 attempts = attempts + 1
79.                 IF attempts > 3000 THEN flagDone = -1: EXIT SUB
80.                 GOTO retry
81.             END IF
82.         ELSE
83.             GOTO retry
84.         END IF
85.     NEXT
86. END SUB
87.  
88. SUB cText (x, y, textHeight, K AS _UNSIGNED LONG, txt$)
89.     fg = _DEFAULTCOLOR
90.     'screen snapshot
91.     cur& = _DEST
92.     I& = _NEWIMAGE(8 * LEN(txt$), 16, 32)
93.     _DEST I&
94.     COLOR K, _RGBA32(0, 0, 0, 0)
95.     _PRINTSTRING (0, 0), txt$
96.     mult = textHeight / 16
97.     xlen = LEN(txt$) * 8 * mult
98.     _PUTIMAGE (x - .5 * xlen, y - .5 * textHeight)-STEP(xlen, textHeight), I&, cur&
99.     COLOR fg
100.     _FREEIMAGE I&
101. END SUB
102.  
103. SUB fIrrPoly (arr(), K AS _UNSIGNED LONG)
104.     'this just draws a bunch of triangles according to x, y points in arr()
105.     ox = arr(0): oy = arr(1) 'the first 2 items in arr() need to be center
106.     FOR i = 2 TO UBOUND(arr) - 3 STEP 2
107.         ftri ox, oy, arr(i), arr(i + 1), arr(i + 2), arr(i + 3), K
108.     NEXT
109. END SUB
110.  
111. SUB star (x, y, rInner, rOuter, nPoints, angleOffset, K AS _UNSIGNED LONG)
112.     ' x, y are same as for circle,
113.     ' rInner is center circle radius
114.     ' rOuter is the outer most point of star
115.     ' nPoints is the number of points,
116.     ' angleOffset = angle offset in radians
117.     ' this is to allow us to spin the star
118.  
119.     DIM ar(INT(nPoints) * 4 + 3) 'add two for origin
120.     pAngle = _PI(2) / nPoints: radAngleOffset = angleOffset - _PI(1 / 2)
121.     ar(0) = x: ar(1) = y
122.     ar(2) = x + rOuter * COS(radAngleOffset)
123.     ar(3) = y + rOuter * SIN(radAngleOffset)
124.     idx = 4
125.     FOR i = 0 TO nPoints - 1
126.         ar(idx) = x + rInner * COS(i * pAngle + radAngleOffset + .5 * pAngle)
127.         idx = idx + 1
128.         ar(idx) = y + rInner * SIN(i * pAngle + radAngleOffset + .5 * pAngle)
129.         idx = idx + 1
130.         ar(idx) = x + rOuter * COS((i + 1) * pAngle + radAngleOffset)
131.         idx = idx + 1
132.         ar(idx) = y + rOuter * SIN((i + 1) * pAngle + radAngleOffset)
133.         idx = idx + 1
134.     NEXT
135.     fIrrPoly ar(), K
136. END SUB
137.  
138. SUB ftri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
139.     a& = _NEWIMAGE(1, 1, 32)
140.     _DEST a&
141.     PSET (0, 0), K
142.     _DEST 0
143.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
144.     _FREEIMAGE a& '<<< this is important!
145. END SUB
146.  
147.  

Title: Re: Circle Packing
Post by: bplus on April 09, 2019, 12:17:22 am

Packing images:

Code: QB64: [Select]

1. _TITLE "Circle Packing 5 image packing" 'B+ started 2019-04-09
2. CONST xmax = 1200
3. CONST ymax = 600
4. SCREEN _NEWIMAGE(xmax - 1, ymax - 1, 32)
5. _SCREENMOVE _MIDDLE
6. spbg& = _NEWIMAGE(xmax - 1, ymax - 1, 32)
7. _DEST spbg&
8. LINE (0, 0)-(xmax - 1, ymax - 1), _RGB32(0, 0, 0), BF
9. cText xmax / 2, ymax / 2, 500, _RGB32(255, 255, 255), "QB64"
10. _SOURCE spbg&
11. TYPE CircleType
12.     x AS INTEGER
13.     y AS INTEGER
14.     r AS INTEGER
15.     s AS STRING * 1
16.     c AS _UNSIGNED LONG
17.     growing AS INTEGER
18. END TYPE
19. REDIM SHARED circles(0) AS CircleType
20. DIM SHARED flagDone AS INTEGER
21.  
22. WHILE _KEYDOWN(27) = 0 AND flagDone = 0
23.     CLS
24.     count = count + 1
25.     newCircle 20
26.     drawCircles
27.     _DISPLAY
28.     _LIMIT 60
29. WEND
30. PRINT "done"
31.  
32. SUB drawCircles
33.     FOR i = 1 TO UBOUND(circles)
34.         IF circles(i).growing THEN 'check new r
35.             testr = circles(i).r + 1
36.             IF circles(i).x - testr < 0 OR circles(i).x + testr > xmax - 1 OR circles(i).y - testr < 0 OR circles(i).y + testr > ymax - 2 THEN
37.                 circles(i).growing = 0
38.             ELSE
39.                 'check if run into another circle
40.                 FOR j = 1 TO UBOUND(circles)
41.                     IF j <> i THEN
42.                         IF SQR((circles(j).x - circles(i).x) ^ 2 + (circles(j).y - circles(i).y) ^ 2) <= testr + circles(j).r THEN
43.                             circles(i).growing = 0: circles(j).growing = 0
44.                             EXIT FOR
45.                         END IF
46.                     END IF
47.                 NEXT
48.             END IF
49.         END IF
50.         IF circles(i).growing THEN circles(i).r = testr
51.         cText circles(i).x, circles(i).y, 2 * circles(i).r, circles(i).c, circles(i).s
52.     NEXT
53.     PRINT UBOUND(circles)
54. END SUB
55.  
56. SUB newCircle (n)
57.     FOR i = 1 TO n
58.         attempts = 0
59.         retry:
60.         testX = INT(RND * xmax): testY = INT(RND * ymax)
61.         OK = -1
62.         IF POINT(testX, testY) = _RGB32(255, 255, 255) THEN
63.             FOR j = 1 TO UBOUND(circles)
64.                 IF SQR((testX - circles(j).x) ^ 2 + (testY - circles(j).y) ^ 2) < circles(j).r + 3 THEN OK = 0: EXIT FOR
65.             NEXT
66.             IF OK THEN
67.                 new = UBOUND(circles) + 1
68.                 REDIM _PRESERVE circles(1 TO new) AS CircleType
69.                 circles(new).x = testX
70.                 circles(new).y = testY
71.                 circles(new).r = 3
72.                 circles(new).s = CHR$(RND * 96 + 32)
73.                 circles(new).growing = -1
74.                 circles(new).c = _RGB32(RND * 255 + 55, RND * 200 + 55, RND * 200 + 55)
75.             ELSE
76.                 attempts = attempts + 1
77.                 IF attempts > 3000 THEN flagDone = -1: EXIT SUB
78.                 GOTO retry
79.             END IF
80.         ELSE
81.             GOTO retry
82.         END IF
83.     NEXT
84. END SUB
85.  
86. SUB cText (x, y, textHeight, K AS _UNSIGNED LONG, txt$)
87.     fg = _DEFAULTCOLOR
88.     'screen snapshot
89.     cur& = _DEST
90.     I& = _NEWIMAGE(8 * LEN(txt$), 16, 32)
91.     _DEST I&
92.     COLOR K, _RGBA32(0, 0, 0, 0)
93.     _PRINTSTRING (0, 0), txt$
94.     mult = textHeight / 16
95.     xlen = LEN(txt$) * 8 * mult
96.     _PUTIMAGE (x - .5 * xlen, y - .5 * textHeight)-STEP(xlen, textHeight), I&, cur&
97.     COLOR fg
98.     _FREEIMAGE I&
99. END SUB
100.  
101.  

Title: Re: Circle Packing
Post by: TempodiBasic on April 09, 2019, 06:02:13 am

Thanks Bplus
very cool !

Title: Re: Circle Packing
Post by: bplus on April 09, 2019, 08:19:59 am

Thanks TempodiBasic, I am considering packing with cartoon images. ;-))

Title: Re: Circle Packing
Post by: TempodiBasic on April 09, 2019, 08:43:55 am

try with my avatar at first :-))

Title: Re: Circle Packing
Post by: codeguy on April 09, 2019, 07:43:55 pm

impressive B+. I took the liberty of making MINOR modifications that do not affect output EXCEPT to make it a bit faster. Please enjoy this faster but otherwise EXACTLY the same output:

Code: QB64: [Select]

1. _TITLE "Circle Packing 4 nonCircles" 'B+ started 2019-04-08
2. CONST xmax = 1200
3. CONST ymax = 600
4. SCREEN _NEWIMAGE(xmax - 1, ymax - 1, 32)
5. DO
6. LOOP UNTIL _SCREENEXISTS
7. '_SCREENMOVE _MIDDLE
8. _FULLSCREEN
9. spbg& = _NEWIMAGE(xmax - 1, ymax - 1, 32)
10. _DEST spbg&
11. LINE (0, 0)-(xmax - 1, ymax - 1), _RGB32(0, 0, 0), BF
12. cText xmax / 2, ymax / 2, 500, _RGB32(255, 255, 255), "QB64"
13. _SOURCE spbg&
14. TYPE CircleType
15.     x AS INTEGER
16.     y AS INTEGER
17.     r AS INTEGER
18.     n AS INTEGER
19.     a AS SINGLE
20.     c AS _UNSIGNED LONG
21.     growing AS INTEGER
22. END TYPE
23. REDIM SHARED circles(0) AS CircleType
24. DIM SHARED flagDone AS INTEGER
25.  
26. WHILE _KEYDOWN(27) = 0 AND flagDone = 0
27.     CLS
28.     count = count + 1
29.     newCircle 20
30.     drawCircles
31.     _DISPLAY
32.     _LIMIT 30 '* originally 60
33. WEND
34. PRINT "done"
35.  
36. SUB drawCircles
37.     FOR i = 1 TO UBOUND(circles)
38.         IF circles(i).growing THEN 'check new r
39.             testr = circles(i).r + 1
40.             IF circles(i).x - testr < 0 OR circles(i).x + testr > xmax - 1 OR circles(i).y - testr < 0 OR circles(i).y + testr > ymax - 2 THEN
41.                 circles(i).growing = 0
42.             ELSE
43.                 'check if run into another circle
44.                 FOR j = 1 TO UBOUND(circles)
45.                     IF j <> i THEN
46.                         IF ABS(circles(j).x - circles(i).x) <= testr + circles(j).r THEN
47.                             IF ABS(circles(j).y - circles(i).y) <= testr + circles(j).r THEN
48.                                 circles(i).growing = 0: circles(j).growing = 0
49.                                 EXIT FOR
50.                             END IF
51.                         END IF
52.                     END IF
53.                 NEXT
54.             END IF
55.         END IF
56.         IF circles(i).growing THEN circles(i).r = testr
57.         star circles(i).x, circles(i).y, .3 * circles(i).r, circles(i).r, circles(i).n, circles(i).a, circles(i).c
58.     NEXT
59.     'PRINT UBOUND(circles);
60. END SUB
61.  
62. SUB newCircle (n)
63.     FOR i = 1 TO n
64.         attempts = 0
65.         retry:
66.         testX = INT(RND * xmax): testY = INT(RND * ymax)
67.         OK = -1
68.         IF POINT(testX, testY) = _RGB32(255, 255, 255) THEN
69.             FOR j = 1 TO UBOUND(circles)
70.                 IF ABS(testX - circles(j).x) < circles(j).r + 3 THEN
71.                     IF ABS(testY - circles(j).y) < circles(j).r + 3 THEN
72.                         OK = 0: EXIT FOR
73.                     END IF
74.                 END IF
75.             NEXT
76.             IF OK THEN
77.                 new = UBOUND(circles) + 1
78.                 REDIM _PRESERVE circles(1 TO new) AS CircleType
79.                 circles(new).x = testX
80.                 circles(new).y = testY
81.                 circles(new).r = 3
82.                 circles(new).a = RND * _PI(2)
83.                 circles(new).n = 5 + INT(RND * 5)
84.                 circles(new).growing = -1
85.                 circles(new).c = _RGB32(RND * 255 + 55, RND * 200 + 55, RND * 200 + 55)
86.             ELSE
87.                 attempts = attempts + 1
88.                 IF attempts > 3000 THEN flagDone = -1: EXIT SUB
89.                 GOTO retry
90.             END IF
91.         ELSE
92.             GOTO retry
93.         END IF
94.     NEXT
95. END SUB
96.  
97. SUB cText (x, y, textHeight, K AS _UNSIGNED LONG, txt$)
98.     fg = _DEFAULTCOLOR
99.     'screen snapshot
100.     cur& = _DEST
101.     I& = _NEWIMAGE(8 * LEN(txt$), 16, 32)
102.     _DEST I&
103.     COLOR K, _RGBA32(0, 0, 0, 0)
104.     _PRINTSTRING (0, 0), txt$
105.     mult = textHeight / 16
106.     xlen = LEN(txt$) * 8 * mult
107.     _PUTIMAGE (x - .5 * xlen, y - .5 * textHeight)-STEP(xlen, textHeight), I&, cur&
108.     COLOR fg
109.     _FREEIMAGE I&
110. END SUB
111.  
112. SUB fIrrPoly (arr(), K AS _UNSIGNED LONG)
113.     'this just draws a bunch of triangles according to x, y points in arr()
114.     ox = arr(0): oy = arr(1) 'the first 2 items in arr() need to be center
115.     FOR i = 2 TO UBOUND(arr) - 3 STEP 2
116.         ftri ox, oy, arr(i), arr(i + 1), arr(i + 2), arr(i + 3), K
117.     NEXT
118. END SUB
119.  
120. SUB star (x, y, rInner, rOuter, nPoints, angleOffset, K AS _UNSIGNED LONG)
121.     ' x, y are same as for circle,
122.     ' rInner is center circle radius
123.     ' rOuter is the outer most point of star
124.     ' nPoints is the number of points,
125.     ' angleOffset = angle offset in radians
126.     ' this is to allow us to spin the star
127.  
128.     DIM ar(INT(nPoints) * 4 + 3) 'add two for origin
129.     pAngle = _PI(2) / nPoints: radAngleOffset = angleOffset - _PI(1 / 2)
130.     ar(0) = x: ar(1) = y
131.     ar(2) = x + rOuter * COS(radAngleOffset)
132.     ar(3) = y + rOuter * SIN(radAngleOffset)
133.     idx = 4
134.     FOR i = 0 TO nPoints - 1
135.         ar(idx) = x + rInner * COS(i * pAngle + radAngleOffset + .5 * pAngle)
136.         idx = idx + 1
137.         ar(idx) = y + rInner * SIN(i * pAngle + radAngleOffset + .5 * pAngle)
138.         idx = idx + 1
139.         ar(idx) = x + rOuter * COS((i + 1) * pAngle + radAngleOffset)
140.         idx = idx + 1
141.         ar(idx) = y + rOuter * SIN((i + 1) * pAngle + radAngleOffset)
142.         idx = idx + 1
143.     NEXT
144.     fIrrPoly ar(), K
145. END SUB
146.  
147. SUB ftri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
148.     a& = _NEWIMAGE(1, 1, 32)
149.     _DEST a&
150.     PSET (0, 0), K
151.     _DEST 0
152.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
153.     _FREEIMAGE a& '<<< this is important!
154. END SUB
155.  

all that squaring and square root stuff REALLY penalizes the performance. Excellent work. A+ for B+ :). You can change the _LIMIT to 30 and still get a cool effect. It then runs about the same speed as your original code, but the star placement and rendering is MUCH faster without the squaring and square roots. at _LIMIT 30, the placement and rendering are approximately the same as your original code at _LIMIT 60. Very cool program though Corrected as you pointed out.

Title: Re: Circle Packing
Post by: bplus on April 09, 2019, 08:39:11 pm

Code: QB64: [Select]

1.                         IF ABS(circles(j).x - circles(i).x) <= testr THEN
2.                             IF ABS(circles(j).y - circles(i).y) <= testr + circles(j).r THEN
3.                                 circles(i).growing = 0: circles(j).growing = 0
4.                                 EXIT FOR
5.                             END IF
6.                         END IF
7.  

replaces:

Code: QB64: [Select]

1.                        IF SQR((circles(j).x - circles(i).x) ^ 2 + (circles(j).y - circles(i).y) ^ 2) <= testr THEN
2.                             circles(i).growing = 0: circles(j).growing = 0
3.                             EXIT FOR
4.                         END IF
5.  

I see it, I like it! I will use this lesson in the future. Thank you!

oops! I see something missing in first line
IF ABS(circles(j).x - circles(i).x) <= testr THEN

should be
IF ABS(circles(j).x - circles(i).x) <= testr + circles(j).r

Update: on second thought, since the hypotenuse is considerably shorter than sum of two legs (unless 1 leg is really short)...
I am going to try to work up an alternative that even avoids ABS.

Title: Re: Circle Packing
Post by: bplus on April 09, 2019, 09:32:05 pm

No SQR, no ^2, no ABS and remains accurate to hypotenuse distances compared to leg sums.

Code: QB64: [Select]

1. FUNCTION distLessCheck (x1, x2, y1, y2, checkThis)
2.     dx = x1 - x2: dy = y1 - y2
3.     IF dx * dx + dy * dy < checkThis * checkThis THEN distLessCheck = -1 ELSE distLessCheck = 0
4. END FUNCTION
5.  

Code: QB64: [Select]

1. _TITLE "Circle Packing 4-B nonCircles" 'B+ started 2019-04-09 update with distLessCheck function
2. CONST xmax = 1200
3. CONST ymax = 600
4. SCREEN _NEWIMAGE(xmax - 1, ymax - 1, 32)
5. _SCREENMOVE _MIDDLE
6. spbg& = _NEWIMAGE(xmax - 1, ymax - 1, 32)
7. _DEST spbg&
8. LINE (0, 0)-(xmax - 1, ymax - 1), _RGB32(0, 0, 0), BF
9. cText xmax / 2, ymax / 2, 500, _RGB32(255, 255, 255), "QB64"
10. _SOURCE spbg&
11. TYPE CircleType
12.     x AS INTEGER
13.     y AS INTEGER
14.     r AS INTEGER
15.     n AS INTEGER
16.     a AS SINGLE
17.     c AS _UNSIGNED LONG
18.     growing AS INTEGER
19. END TYPE
20. REDIM SHARED circles(0) AS CircleType
21. DIM SHARED flagDone AS INTEGER
22.  
23. WHILE _KEYDOWN(27) = 0 AND flagDone = 0
24.     CLS
25.     count = count + 1
26.     newCircle 20
27.     drawCircles
28.     _DISPLAY
29.     _LIMIT 60
30. WEND
31. PRINT "done"
32.  
33. SUB drawCircles
34.     FOR i = 1 TO UBOUND(circles)
35.         IF circles(i).growing THEN 'check new r
36.             testr = circles(i).r + 1
37.             IF circles(i).x - testr < 0 OR circles(i).x + testr > xmax - 1 OR circles(i).y - testr < 0 OR circles(i).y + testr > ymax - 2 THEN
38.                 circles(i).growing = 0
39.             ELSE
40.                 'check if run into another circle
41.                 FOR j = 1 TO UBOUND(circles)
42.                     IF j <> i THEN
43.                         IF distLessCheck(circles(j).x, circles(i).x, circles(j).y, circles(i).y, testr + circles(j).r) THEN
44.                             'IF SQR((circles(j).x - circles(i).x) ^ 2 + (circles(j).y - circles(i).y) ^ 2) <= testr + circles(j).r THEN
45.                             circles(i).growing = 0: circles(j).growing = 0
46.                             EXIT FOR
47.                         END IF
48.                     END IF
49.                 NEXT
50.             END IF
51.         END IF
52.         IF circles(i).growing THEN circles(i).r = testr
53.         star circles(i).x, circles(i).y, .3 * circles(i).r, circles(i).r, circles(i).n, circles(i).a, circles(i).c
54.     NEXT
55.     PRINT UBOUND(circles)
56. END SUB
57.  
58. SUB newCircle (n)
59.     FOR i = 1 TO n
60.         attempts = 0
61.         retry:
62.         testX = INT(RND * xmax): testY = INT(RND * ymax)
63.         OK = -1
64.         IF POINT(testX, testY) = _RGB32(255, 255, 255) THEN
65.             FOR j = 1 TO UBOUND(circles)
66.                 IF distLessCheck(testX, circles(j).x, testY, circles(j).y, circles(j).r + 3) THEN OK = 0: EXIT FOR
67.                 'IF SQR((testX - circles(j).x) ^ 2 + (testY - circles(j).y) ^ 2) < circles(j).r + 3 THEN OK = 0: EXIT FOR
68.             NEXT
69.             IF OK THEN
70.                 new = UBOUND(circles) + 1
71.                 REDIM _PRESERVE circles(1 TO new) AS CircleType
72.                 circles(new).x = testX
73.                 circles(new).y = testY
74.                 circles(new).r = 3
75.                 circles(new).a = RND * _PI(2)
76.                 circles(new).n = 5 + INT(RND * 5)
77.                 circles(new).growing = -1
78.                 circles(new).c = _RGB32(RND * 255 + 55, RND * 200 + 55, RND * 200 + 55)
79.             ELSE
80.                 attempts = attempts + 1
81.                 IF attempts > 3000 THEN flagDone = -1: EXIT SUB
82.                 GOTO retry
83.             END IF
84.         ELSE
85.             GOTO retry
86.         END IF
87.     NEXT
88. END SUB
89.  
90. SUB cText (x, y, textHeight, K AS _UNSIGNED LONG, txt$)
91.     fg = _DEFAULTCOLOR
92.     'screen snapshot
93.     cur& = _DEST
94.     I& = _NEWIMAGE(8 * LEN(txt$), 16, 32)
95.     _DEST I&
96.     COLOR K, _RGBA32(0, 0, 0, 0)
97.     _PRINTSTRING (0, 0), txt$
98.     mult = textHeight / 16
99.     xlen = LEN(txt$) * 8 * mult
100.     _PUTIMAGE (x - .5 * xlen, y - .5 * textHeight)-STEP(xlen, textHeight), I&, cur&
101.     COLOR fg
102.     _FREEIMAGE I&
103. END SUB
104.  
105. SUB fIrrPoly (arr(), K AS _UNSIGNED LONG)
106.     'this just draws a bunch of triangles according to x, y points in arr()
107.     ox = arr(0): oy = arr(1) 'the first 2 items in arr() need to be center
108.     FOR i = 2 TO UBOUND(arr) - 3 STEP 2
109.         ftri ox, oy, arr(i), arr(i + 1), arr(i + 2), arr(i + 3), K
110.     NEXT
111. END SUB
112.  
113. SUB star (x, y, rInner, rOuter, nPoints, angleOffset, K AS _UNSIGNED LONG)
114.     ' x, y are same as for circle,
115.     ' rInner is center circle radius
116.     ' rOuter is the outer most point of star
117.     ' nPoints is the number of points,
118.     ' angleOffset = angle offset in radians
119.     ' this is to allow us to spin the star
120.  
121.     DIM ar(INT(nPoints) * 4 + 3) 'add two for origin
122.     pAngle = _PI(2) / nPoints: radAngleOffset = angleOffset - _PI(1 / 2)
123.     ar(0) = x: ar(1) = y
124.     ar(2) = x + rOuter * COS(radAngleOffset)
125.     ar(3) = y + rOuter * SIN(radAngleOffset)
126.     idx = 4
127.     FOR i = 0 TO nPoints - 1
128.         ar(idx) = x + rInner * COS(i * pAngle + radAngleOffset + .5 * pAngle)
129.         idx = idx + 1
130.         ar(idx) = y + rInner * SIN(i * pAngle + radAngleOffset + .5 * pAngle)
131.         idx = idx + 1
132.         ar(idx) = x + rOuter * COS((i + 1) * pAngle + radAngleOffset)
133.         idx = idx + 1
134.         ar(idx) = y + rOuter * SIN((i + 1) * pAngle + radAngleOffset)
135.         idx = idx + 1
136.     NEXT
137.     fIrrPoly ar(), K
138. END SUB
139.  
140. SUB ftri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
141.     a& = _NEWIMAGE(1, 1, 32)
142.     _DEST a&
143.     PSET (0, 0), K
144.     _DEST 0
145.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
146.     _FREEIMAGE a& '<<< this is important!
147. END SUB
148.  
149. FUNCTION distLessCheck (x1, x2, y1, y2, checkThis)
150.     dx = x1 - x2: dy = y1 - y2
151.     IF dx * dx + dy * dy < checkThis * checkThis THEN distLessCheck = -1 ELSE distLessCheck = 0
152. END FUNCTION
153.  
154.  

Next try with Image fun because THAT needed help with speed.

Update: yes, Mr Spock updates much faster.

Title: Re: Circle Packing
Post by: codeguy on April 09, 2019, 09:58:04 pm

My method eliminates the need for multiplication altogether. It is the same method used for my NSpace demo, which unfortunately became lost. Ugh. But the change should afford you enough time to place and scale small images.

Title: Re: Circle Packing
Post by: bplus on April 09, 2019, 11:06:42 pm

I have coded a test to compare collision detections of the two white circle, one stationary in center of screen the other moved by mouse.

codeguy, I called your method ABScollision, I called the one I created MultCollides and I called the normal distance method distCollides and here is a model test site. Move mouse around and you will see ABS detecting collisions with the white circle all the way out to the yellow circle if you move mouse down a diagonal line.

Code: QB64: [Select]

1. _TITLE "Collision Test - move mouse down lines to see ABScollides too often (inside yellow circle)" 'B+ 2019-04-09
2.  
3. SCREEN _NEWIMAGE(800, 600, 32)
4. r1 = 10
5. r2 = 50
6. x1 = 400
7. y1 = 300
8. y2 = 150
9. WHILE _KEYDOWN(27) = 0
10.     CLS
11.     WHILE _MOUSEINPUT: WEND
12.     mx = _MOUSEX: my = _MOUSEY
13.     LINE (600, 100)-(200, 500)
14.     LINE (200, 100)-(600, 500)
15.     CIRCLE (x1, y1), r1
16.     CIRCLE (mx, my), r2
17.     CIRCLE (x1, y1), 28, _RGB32(255, 255, 0)
18.     LOCATE 2, 10: PRINT "ABScollides ="; ABScollides(x1, mx, y1, my, r1, r2)
19.     LOCATE 2, 30: PRINT "MultCollides ="; MultCollides(x1, mx, y1, my, r1, r2)
20.     LOCATE 2, 50: PRINT "distCollides ="; distCollides(x1, mx, y1, my, r1, r2)
21.     _DISPLAY
22.     _LIMIT 60
23. WEND
24.  
25. FUNCTION ABScollides (x1, x2, y1, y2, r1, r2)
26.     IF ABS(x1 - x2) < r1 + r2 THEN
27.         IF ABS(y1 - y2) < r1 + r2 THEN
28.             ABScollides = -1
29.         END IF
30.     END IF
31. END FUNCTION
32.  
33. FUNCTION MultCollides (x1, x2, y1, y2, r1, r2)
34.     dx = x1 - x2: dy = y1 - y2
35.     IF dx * dx + dy * dy < (r1 + r2) * (r1 + r2) THEN MultCollides = -1
36. END FUNCTION
37.  
38. FUNCTION distCollides (x1, x2, y1, y2, r1, r2)
39.     IF SQR((x1 - x2) ^ 2 + (y1 - y2) ^ 2) < r1 + r2 THEN distCollides = -1
40. END FUNCTION
41.  
42.  

This demonstrates that the ABScollides method is inaccurate. The yellow circle shows the error found running down the lines with the mouse.

Title: Re: Circle Packing
Post by: Prithak on April 10, 2019, 12:00:07 am

Quote from: bplus on April 07, 2019, 08:50:55 pm

Another idea from Shiffman, Circle Packing.

Basic random fill:

Code: QB64: [Select]

1. _TITLE "Circle Packing 1 fill" 'B+ started 2019-04-07  just basic random fill space
2. CONST xmax = 800
3. CONST ymax = 600
4. SCREEN _NEWIMAGE(xmax, ymax, 32)
5. _SCREENMOVE _MIDDLE
6.  
7. TYPE CircleType
8.     x AS SINGLE
9.     y AS SINGLE
10.     r AS SINGLE
11.     c AS _UNSIGNED LONG
12.     growing AS INTEGER
13. END TYPE
14. REDIM SHARED circles(1 TO 1) AS CircleType
15. DIM SHARED flagDone AS INTEGER
16.  
17. WHILE _KEYDOWN(27) = 0 AND flagDone = 0
18.     CLS
19.     newCircle 1
20.     drawCircles
21.     _DISPLAY
22.     _LIMIT 60
23. WEND
24. PRINT "done"
25.  
26. SUB drawCircles
27.     FOR i = 1 TO UBOUND(circles)
28.         IF circles(i).growing THEN 'check new r
29.             testr = circles(i).r + 2
30.             IF circles(i).x - testr < 0 OR circles(i).x + testr > xmax OR circles(i).y - testr < 0 OR circles(i).y + testr > ymax THEN
31.                 circles(i).growing = 0
32.             ELSE
33.                 'check if run into another circle
34.                 FOR j = 1 TO UBOUND(circles)
35.                     IF j <> i THEN
36.                         IF SQR((circles(j).x - circles(i).x) ^ 2 + (circles(j).y - circles(i).y) ^ 2) <= testr + circles(j).r THEN
37.                             circles(i).growing = 0: circles(j).growing = 0
38.                             EXIT FOR
39.                         END IF
40.                     END IF
41.                 NEXT
42.             END IF
43.         END IF
44.         IF circles(i).growing THEN circles(i).r = testr
45.         fcirc circles(i).x, circles(i).y, circles(i).r, circles(i).c
46.     NEXT
47.     PRINT UBOUND(circles)
48. END SUB
49.  
50. SUB newCircle (n)
51.     FOR i = 1 TO n
52.         attempts = 0
53.         retry:
54.         testX = RND * xmax: testY = RND * ymax
55.         OK = -1
56.         FOR j = 1 TO UBOUND(circles)
57.             IF SQR((testX - circles(j).x) ^ 2 + (testY - circles(j).y) ^ 2) < circles(j).r + 2 THEN OK = 0: EXIT FOR
58.         NEXT
59.         IF OK THEN
60.             new = UBOUND(circles) + 1
61.             REDIM _PRESERVE circles(1 TO new) AS CircleType
62.             circles(new).x = testX
63.             circles(new).y = testY
64.             circles(new).r = 1
65.             circles(new).growing = -1
66.             circles(new).c = _RGB32(RND * 155 + 100, RND * 155 + 100, RND * 155 + 100)
67.         ELSE
68.             attempts = attempts + 1
69.             IF attempts > 3000 THEN flagDone = -1: EXIT SUB
70.             GOTO retry
71.         END IF
72.     NEXT
73. END SUB
74.  
75. 'from Steve Gold standard
76. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
77.     DIM Radius AS INTEGER, RadiusError AS INTEGER
78.     DIM X AS INTEGER, Y AS INTEGER
79.  
80.     Radius = ABS(R)
81.     RadiusError = -Radius
82.     X = Radius
83.     Y = 0
84.  
85.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
86.  
87.     ' Draw the middle span here so we don't draw it twice in the main loop,
88.     ' which would be a problem with blending turned on.
89.     LINE (CX - X, CY)-(CX + X, CY), C, BF
90.  
91.     WHILE X > Y
92.         RadiusError = RadiusError + Y * 2 + 1
93.         IF RadiusError >= 0 THEN
94.             IF X <> Y + 1 THEN
95.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
96.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
97.             END IF
98.             X = X - 1
99.             RadiusError = RadiusError - X * 2
100.         END IF
101.         Y = Y + 1
102.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
103.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
104.     WEND
105. END SUB
106.  
107.  

It's more fun with images:

I've seen that video!

Text Only | Text with Attachments