Voronoi Diagram (Rosetta Code Task)

[AndyA]

https://rosettacode.org/wiki/Voronoi_diagram

'======================================
Rosetta Code Task:
Task
Demonstrate how to generate and display a Voronoi diagram.
'======================================

[begin edit] This is a very fast way to draw a Voronoi Diagram. For small diagrams
100 points on 400x400 pixel canvas take about 400 milliseconds. I scales well, for 2000 points on a 1024x1024 canvas its take about 1000 milliseconds. [end of edit]

Code: QB64: [Select]

1. _Title "Voronoi Diagram"
2.  
3. Dim As Integer pnt, px, py, i, x, y, adjct, sy, ly
4. Dim As Double st
5.  
6. '=====================================================================
7. ' Changes number of points and screen size here
8. '=====================================================================
9. pnt = 100
10. px = 512
11. py = 512
12. '=====================================================================
13. Screen _NewImage(px, py, 32)
14. Randomize Timer
15.  
16. Dim Shared As Integer pax(pnt), pay(pnt), indx(px, py)
17. Dim Shared As Long dSqr(px, py)
18. Dim As Long col(pnt)
19.  
20. For i = 1 To pnt
21.     pax(i) = Int(Rnd * px)
22.     pay(i) = Int(Rnd * py)
23.     col(i) = _RGB(Rnd * 256, Rnd * 256, Rnd * 256)
24. Next
25. st = Timer
26. For x = 0 To px - 1
27.     For y = 0 To py - 1
28.         dSqr(x, y) = (pax(1) - x) * (pax(1) - x) + (pay(1) - y) * (pay(1) - y)
29.         indx(x, y) = 1
30.     Next
31. Next
32.  
33. For i = 2 To pnt
34.     ly = py - 1
35.     For x = pax(i) To 0 Step -1
36.         If (scan(i, x, ly)) = 0 Then Exit For
37.     Next x
38.     For x = pax(i) + 1 To px - 1
39.         If (scan(i, x, ly)) = 0 Then Exit For
40.     Next
41. Next
42.  
43. For x = 0 To px - 1
44.     For y = 0 To py - 1
45.         sy = y
46.         adjct = indx(x, y)
47.         For y = y + 1 To py
48.             If indx(x, y) <> adjct Then y = y - 1: Exit For
49.         Next
50.         Line (x, sy)-(x, y + 1), col(adjct)
51.     Next
52. Next
53.  
54. Sleep
55. System
56.  
57. Function scan (site As Integer, x As Integer, ly As Integer)
58.     Dim As Integer ty
59.     Dim As Long delt2, dsq
60.     delt2 = (pax(site) - x) * (pax(site) - x)
61.     For ty = 0 To ly
62.         dsq = (pay(site) - ty) * (pay(site) - ty) + delt2
63.         If dsq <= dSqr(x, ty) Then
64.             dSqr(x, ty) = dsq
65.             indx(x, ty) = site
66.             scan = 1
67.         End If
68.     Next
69. End Function

[bplus]

Well this one could be jazzed up a little nicer:

Code: QB64: [Select]

1. _Title "Golden Angle Spiral Voronoi"
2. 'Golden angle Vorornoi.bas for SmallBASIC 2015-10-16 MGA/B+
3.  
4. Const xmx = 640
5. Const ymx = 640
6.  
7. Screen _NewImage(xmx, ymx, 32)
8. sq = ymx: s2 = sq / 2: points = 1200: ga = 137.5: mx = Sqr((xmx - s2) ^ 2 + (mxy - s2) ^ 2) - 100
9. Dim x(1 To points), y(1 To points), kl(1 To points) As _Unsigned Long
10. scale = sq * 10 / 640
11. For n = 1 To points
12.     x(n) = s2 + scale * Sqr(n) * Cos(_D2R(n * ga))
13.     y(n) = s2 + scale * Sqr(n) * Sin(_D2R(n * ga))
14.     kl(n) = _RGB32(255 - 255 * Sqr((s2 - x(n)) ^ 2 + (s2 - y(n)) ^ 2) / mx, 255 - 255 * Sqr((s2 - x(n)) ^ 2 + (s2 - y(n)) ^ 2) / mx, 0)
15. Next
16.  
17. For xx = 0 To sq
18.     For yy = 0 To sq
19.         d = xmx * ymx + 1
20.         For i = 1 To points
21.             a = x(i) - xx: b = y(i) - yy
22.             q = a * a + b * b
23.             If q < d Then d = q: kkl = i
24.         Next
25.         PSet (xx, yy), kl(kkl)
26.     Next
27.     _Display
28. Next
29.  
30.  
31.  

Might try a couple of tricks to speed up too, I could use Longs and Line, When comparing distances I know dont have to do SQR, if one > than another then SQR will be also.

[bplus]

Yeah switching to default Long made huge difference, Line? Not as much:

Code: QB64: [Select]

1. _Title "Golden Angle Spiral Voronoi 2 Faster" 'b+ mod 2021-04-14    
2. 'Golden angle Vorornoi.bas for SmallBASIC 2015-10-16 MGA/B+
3. DefLng A-Z
4. Const xmx = 640, ymx = 640, sq = ymx, s2 = 320, points = 1200, ga = 137.5
5.  
6. Screen _NewImage(xmx, ymx, 32)
7. mx = Sqr((xmx - s2) ^ 2 + (mxy - s2) ^ 2) - 50
8.  
9. ' setup spiral points for Voronoi app
10. Dim x(1 To points), y(1 To points), kl(1 To points) As _Unsigned Long
11. scale = sq * 10 / 640
12. For n = 1 To points
13.     x(n) = s2 + scale * Sqr(n) * Cos(_D2R(n * ga))
14.     y(n) = s2 + scale * Sqr(n) * Sin(_D2R(n * ga))
15.     kl(n) = _RGB32(255 - 255 * Sqr((s2 - x(n)) ^ 2 + (s2 - y(n)) ^ 2) / mx, 255 - 255 * Sqr((s2 - x(n)) ^ 2 + (s2 - y(n)) ^ 2) / mx, 0)
16. Next
17. For xx = 0 To sq
18.     For yy = 0 To sq
19.         d = xmx * ymx + 1
20.         For i = 1 To points
21.             a = x(i) - xx: b = y(i) - yy
22.             q = a * a + b * b
23.             If q < d Then d = q: kkl = i
24.         Next
25.         Line (xx, yy)-Step(0, 0), kl(kkl)
26.     Next
27.     _Display
28. Next
29.  
30.  
31.  

@AndyA  OK something you are doing is faster, I made points same as yours and screen same as mine and your ugly thing is still faster LOL! I don't think difference is the setup but might be.

[bplus]

Well this at least fixes the ugliness of color choices:

Code: QB64: [Select]

1. _Title "Voronoi Diagram" ' Andy's is faster than mine 2021-04-14 but I color better :)
2. '  https://www.qb64.org/forum/index.php?topic=3813.msg131679#msg131679
3.  
4. Dim As Integer pnt, px, py, i, x, y, adjct, sy, ly
5. Dim As Double st
6.  
7. '=====================================================================
8. ' Changes number of points and screen size here
9. '=====================================================================
10. pnt = 100
11. px = 512
12. py = 512
13. '=====================================================================
14. Screen _NewImage(px, py, 32)
15. Randomize Timer
16.  
17. Dim Shared As Integer pax(pnt), pay(pnt), indx(px, py)
18. Dim Shared As Long dSqr(px, py)
19. Dim As Long col(pnt)
20.  
21. For i = 1 To pnt
22.     pax(i) = Int(Rnd * px)
23.     pay(i) = Int(Rnd * py)
24.     col(i) = _RGB(pax(i) / px * 255, pay(i) / py * 255, (px - pax(i)) / px * 256)
25. Next
26. st = Timer
27. For x = 0 To px - 1
28.     For y = 0 To py - 1
29.         dSqr(x, y) = (pax(1) - x) * (pax(1) - x) + (pay(1) - y) * (pay(1) - y)
30.         indx(x, y) = 1
31.     Next
32. Next
33.  
34. For i = 2 To pnt
35.     ly = py - 1
36.     For x = pax(i) To 0 Step -1
37.         If (scan(i, x, ly)) = 0 Then Exit For
38.     Next x
39.     For x = pax(i) + 1 To px - 1
40.         If (scan(i, x, ly)) = 0 Then Exit For
41.     Next
42. Next
43.  
44. For x = 0 To px - 1
45.     For y = 0 To py - 1
46.         sy = y
47.         adjct = indx(x, y)
48.         For y = y + 1 To py
49.             If indx(x, y) <> adjct Then y = y - 1: Exit For
50.         Next
51.         Line (x, sy)-(x, y + 1), col(adjct)
52.     Next
53. Next
54.  
55. Sleep
56. System
57.  
58. Function scan (site As Integer, x As Integer, ly As Integer)
59.     Dim As Integer ty
60.     Dim As Long delt2, dsq
61.     delt2 = (pax(site) - x) * (pax(site) - x)
62.     For ty = 0 To ly
63.         dsq = (pay(site) - ty) * (pay(site) - ty) + delt2
64.         If dsq <= dSqr(x, ty) Then
65.             dSqr(x, ty) = dsq
66.             indx(x, ty) = site
67.             scan = 1
68.         End If
69.     Next
70. End Function
71.  
72.  

 

[AndyA]

Nice colors, but I'm trying to keep the code as simple as possibe, yet finish the task as stated. Besides, there's no way to post a screen output. It seems that Rosetta has removed that option.

[_vince]

Nice, I bet this is much harder to do if you were to draw the polygons with just LINEs, not filling in

[bplus]

Nice, I bet this is much harder to do if you were to draw the polygons with just LINEs, not filling in

Is nice and fast, still trying to figure out why?

You know this might be fun to figure out the polys after drawing the Voronoi as that is what creates them.

[Aurel]

Yes Mark your have little bit more smooth colors..!!
I finally update to 1.5v yeah it work fine 32bit version on my win7 machine !!
Huh..i become lazy to change syntax with old 1.3v ...
I am wondering is there a way to build it without array ?

PS..I never asked is anyone maybe interested to use editor ,work solid with multiple tabs?

[bplus]

These Voronoi patterns remind me of the ancient stone blocks of walls or buildings that use no mortar and have no spaces in between that you could slip paper between one block and another, these constructions that puzzle engineers of today.

Yes Mark your have little bit more smooth colors..!!
I finally update to 1.5v yeah it work fine 32bit version on my win7 machine !!
Huh..i become lazy to change syntax with old 1.3v ...
I am wondering is there a way to build it without array ?

PS..I never asked is anyone maybe interested to use editor ,work solid with multiple tabs?

Without array for the points? Yeah you could list points individually but I am far too lazy for that! LOL

Tabs for IDE, yeah that would be great! Steve (SMcNeill) gave us a link for an app to do that but if you have something I am sure there will be interest.

RhoSigma working with Notepad++ for that feature and plenty of others (Spellchecker, folding...) Alas, I miss syntax checking that QB64 IDE offers.