Hilbert Curve (Rosetta Code task)

[AndyA]

https://rosettacode.org/wiki/Hilbert_curve

'==================================================
Task
Produce a graphical or ASCII-art representation of a Hilbert curve of at least order 3.
'==================================================

Code: QB64: [Select]

1. _Title "Hilbert Curve"
2. Dim Shared As Integer sw, sh, wide, cell
3.  
4. wide = 128: cell = 4
5. sw = wide * cell + cell
6. sh = sw
7.  
8. Screen _NewImage(sw, sh, 8)
9. Cls , 15
10. Color 0
11.  
12. PSet (wide * cell, wide * cell)
13.  
14. Call Hilbert(0, 0, wide, 0, 0)
15.  
16. Sleep
17. System
18.  
19. Sub Hilbert (x As Integer, y As Integer, lg As Integer, p As Integer, q As Integer)
20.     Dim As Integer iL, iX, iY
21.     iL = lg: iX = x: iY = y
22.     If iL = 1 Then
23.         Line -((wide - iX) * cell, (wide - iY) * cell)
24.         Exit Sub
25.     End If
26.     iL = iL \ 2
27.     Call Hilbert(iX + p * iL, iY + p * iL, iL, p, 1 - q)
28.     Call Hilbert(iX + q * iL, iY + (1 - q) * iL, iL, p, q)
29.     Call Hilbert(iX + (1 - p) * iL, iY + (1 - p) * iL, iL, p, q)
30.     Call Hilbert(iX + (1 - q) * iL, iY + q * iL, iL, 1 - p, q)
31. End Sub
32.  

[bplus]

I tried to work this out one time never got it.

I think cell or wide should work with screen assigned and not the other way around, just an opinion.

[AndyA]

I used cell and wide to make it easier to fit the whole curve on the screen. You can work it the other way around, open window at whatever size, then figure out what fits, but that's the hard way to go about it.

[bplus]

OK going for most simple without any coloring because it doesn't matter on RC according to AndyA.

Code: QB64: [Select]

1. _Title "Hilbert Curve" 'AndyA  2021-04-14 B+ some simple mods
2. '  https://www.qb64.org/forum/index.php?topic=3816.msg131682#msg131682
3.  
4. Const wide = 128, cell = 4 ' screen width 512 = height
5. Screen _NewImage(wide * cell + cell, wide * cell + cell, 32)
6. PSet (wide * cell, wide * cell) 'prime pump
7. Hilbert 0, 0, wide, 0, 0
8. Sleep
9. System
10.  
11. Sub Hilbert (x As Integer, y As Integer, lg As Integer, p As Integer, q As Integer)
12.     Dim As Integer iL, iX, iY
13.     iL = lg: iX = x: iY = y
14.     If iL = 1 Then
15.         Line -((wide - iX) * cell, (wide - iY) * cell)
16.         Exit Sub
17.     End If
18.     iL = iL \ 2
19.     Hilbert iX + p * iL, iY + p * iL, iL, p, 1 - q
20.     Hilbert iX + q * iL, iY + (1 - q) * iL, iL, p, q
21.     Hilbert iX + (1 - p) * iL, iY + (1 - p) * iL, iL, p, q
22.     Hilbert iX + (1 - q) * iL, iY + q * iL, iL, 1 - p, q
23. End Sub
24.  

Edit Update: Shared line removed, we have no intention of using wide and cell as variables so make them Const's =automatically shared.

[AndyA]

Well, that's one to go about it.

I chose those colors (black lines on white background) because: 1) It seemed to me to have better contrast for seeing the lines  2) If it was printed on printer, it saves on ink.

Besides it's only to lines for the 'color' which can be shortened to one line.  I would say that it not too excessive.

[bplus]

Oh sure print outs! LOL

And how shall you defend using CALL?

Typing practice? LOL

[bplus]

Gotta say black background works better!

Code: QB64: [Select]

1. Option _Explicit
2. _Title "Hilbert Curve Voronoi Coloring" 'AndyA  2021-04-14 B+ some simple mods
3. '  https://www.qb64.org/forum/index.php?topic=3816.msg131682#msg131682
4.  
5. Randomize Timer
6. Const wide = 128, cell = 4 ' screen width 512 = height
7. Screen _NewImage(wide * cell + cell, wide * cell + cell, 32)
8.  
9. Dim As Integer pnt, px, py, i, x, y, adjct, sy, ly
10. pnt = 100
11. px = wide * cell + cell
12. py = wide * cell + cell
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. Dim Shared As Long V
21.  
22. V = _NewImage(wide * cell + cell, wide * cell + cell, 32)
23. _Dest V
24. For i = 1 To pnt
25.     Pax(i) = Int(Rnd * px)
26.     Pay(i) = Int(Rnd * py)
27.     col(i) = _RGB(Pax(i) / px * 255, Pay(i) / py * 255, (px - Pax(i)) / px * 256)
28. Next
29.  
30. For x = 0 To px - 1
31.     For y = 0 To py - 1
32.         dSqr(x, y) = (Pax(1) - x) * (Pax(1) - x) + (Pay(1) - y) * (Pay(1) - y)
33.         Indx(x, y) = 1
34.     Next
35. Next
36.  
37. For i = 2 To pnt
38.     ly = py - 1
39.     For x = Pax(i) To 0 Step -1
40.         If (scan(i, x, ly)) = 0 Then Exit For
41.     Next x
42.     For x = Pax(i) + 1 To px - 1
43.         If (scan(i, x, ly)) = 0 Then Exit For
44.     Next
45. Next
46.  
47. For x = 0 To px - 1
48.     For y = 0 To py - 1
49.         sy = y
50.         adjct = Indx(x, y)
51.         For y = y + 1 To py
52.             If Indx(x, y) <> adjct Then y = y - 1: Exit For
53.         Next
54.         Line (x, sy)-(x, y + 1), col(adjct)
55.     Next
56. Next
57. _Dest 0
58. Color , 0
59. Cls
60. PSet (wide * cell, wide * cell) 'prime pump
61. Hilbert 0, 0, wide, 0, 0
62. Sleep
63. System
64.  
65. Function scan (site As Integer, x As Integer, ly As Integer)
66.     Dim As Integer ty
67.     Dim As Long delt2, dsq
68.     delt2 = (Pax(site) - x) * (Pax(site) - x)
69.     For ty = 0 To ly
70.         dsq = (Pay(site) - ty) * (Pay(site) - ty) + delt2
71.         If dsq <= dSqr(x, ty) Then
72.             dSqr(x, ty) = dsq
73.             Indx(x, ty) = site
74.             scan = 1
75.         End If
76.     Next
77. End Function
78.  
79. Sub Hilbert (x As Integer, y As Integer, lg As Integer, p As Integer, q As Integer)
80.     Dim As Integer iL, iX, iY
81.     Dim As _Unsigned Long K
82.     iL = lg: iX = x: iY = y
83.     _Source V
84.     If iL = 1 Then
85.         K = Point((wide - iX) * cell, (wide - iY) * cell)
86.         Line -((wide - iX) * cell, (wide - iY) * cell), K
87.         Exit Sub
88.     End If
89.     iL = iL \ 2
90.     Hilbert iX + p * iL, iY + p * iL, iL, p, 1 - q
91.     Hilbert iX + q * iL, iY + (1 - q) * iL, iL, p, q
92.     Hilbert iX + (1 - p) * iL, iY + (1 - p) * iL, iL, p, q
93.     Hilbert iX + (1 - q) * iL, iY + q * iL, iL, 1 - p, q
94. End Sub
95.  
96.  

 

[bplus]

I saw this in Wiki and thought it cool to try and duplicate:

Code: QB64: [Select]

1. _Title "Hilbert in His Curve" '2021-04-14 B+
2. ' using AndyA's code for Hilbert Curve  and Wiki image of Hilbert
3.  
4. Const wide = 128, cell = 4 ' screen width 512 = height
5. Screen _NewImage(wide * cell + cell, wide * cell + cell, 32)
6. ReDim Shared As Long H, I
7. H = _NewImage(wide * cell + cell, wide * cell + cell, 32)
8. I = _LoadImage("Hilbert.PNG")
9. _PutImage , I, H
10. 'Color , &HFFFFFFFF 'nope black still works better!
11. 'Cls
12. PSet (wide * cell, wide * cell) 'prime pump
13. Hilbert 0, 0, wide, 0, 0
14. Sleep
15. System
16.  
17. Sub Hilbert (x As Integer, y As Integer, lg As Integer, p As Integer, q As Integer)
18.     Dim As Integer iL, iX, iY
19.     Dim As _Unsigned Long K
20.     iL = lg: iX = x: iY = y
21.     _Source H
22.     If iL = 1 Then
23.         K = Point((wide - iX) * cell, (wide - iY) * cell)
24.         Line -((wide - iX) * cell, (wide - iY) * cell), K
25.         Exit Sub
26.     End If
27.     iL = iL \ 2
28.     Hilbert iX + p * iL, iY + p * iL, iL, p, 1 - q
29.     Hilbert iX + q * iL, iY + (1 - q) * iL, iL, p, q
30.     Hilbert iX + (1 - p) * iL, iY + (1 - p) * iL, iL, p, q
31.     Hilbert iX + (1 - q) * iL, iY + q * iL, iL, 1 - p, q
32. End Sub
33.  

 

Opps you will need the zip for the image I used.

[AndyA]

I like the last one 'Hilbert in Hilbert Curve', you could use just about any image to color the curve.