Circle Packing

[Prithak]

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!