Author Topic: Hilbert Curve (Rosetta Code task)  (Read 3972 times)

0 Members and 1 Guest are viewing this topic.

Offline AndyA

  • Newbie
  • Posts: 73
    • View Profile
Hilbert Curve (Rosetta Code task)
« on: April 13, 2021, 11:36:36 pm »
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.  
  11. PSet (wide * cell, wide * cell)
  12.  
  13. Call Hilbert(0, 0, wide, 0, 0)
  14.  
  15.  
  16. Sub Hilbert (x As Integer, y As Integer, lg As Integer, p As Integer, q As Integer)
  17.     Dim As Integer iL, iX, iY
  18.     iL = lg: iX = x: iY = y
  19.     If iL = 1 Then
  20.         Line -((wide - iX) * cell, (wide - iY) * cell)
  21.         Exit Sub
  22.     End If
  23.     iL = iL \ 2
  24.     Call Hilbert(iX + p * iL, iY + p * iL, iL, p, 1 - q)
  25.     Call Hilbert(iX + q * iL, iY + (1 - q) * iL, iL, p, q)
  26.     Call Hilbert(iX + (1 - p) * iL, iY + (1 - p) * iL, iL, p, q)
  27.     Call Hilbert(iX + (1 - q) * iL, iY + q * iL, iL, 1 - p, q)
  28.  

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Hilbert Curve (Rosetta Code task)
« Reply #1 on: April 14, 2021, 01:48:16 pm »
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.

Offline AndyA

  • Newbie
  • Posts: 73
    • View Profile
Re: Hilbert Curve (Rosetta Code task)
« Reply #2 on: April 14, 2021, 05:39:23 pm »
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.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Hilbert Curve (Rosetta Code task)
« Reply #3 on: April 14, 2021, 05:50:40 pm »
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.  
  9. Sub Hilbert (x As Integer, y As Integer, lg As Integer, p As Integer, q As Integer)
  10.     Dim As Integer iL, iX, iY
  11.     iL = lg: iX = x: iY = y
  12.     If iL = 1 Then
  13.         Line -((wide - iX) * cell, (wide - iY) * cell)
  14.         Exit Sub
  15.     End If
  16.     iL = iL \ 2
  17.     Hilbert iX + p * iL, iY + p * iL, iL, p, 1 - q
  18.     Hilbert iX + q * iL, iY + (1 - q) * iL, iL, p, q
  19.     Hilbert iX + (1 - p) * iL, iY + (1 - p) * iL, iL, p, q
  20.     Hilbert iX + (1 - q) * iL, iY + q * iL, iL, 1 - p, q
  21.  

Edit Update: Shared line removed, we have no intention of using wide and cell as variables so make them Const's =automatically shared.
« Last Edit: April 14, 2021, 10:57:41 pm by bplus »

Offline AndyA

  • Newbie
  • Posts: 73
    • View Profile
Re: Hilbert Curve (Rosetta Code task)
« Reply #4 on: April 14, 2021, 09:45:39 pm »
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.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Hilbert Curve (Rosetta Code task)
« Reply #5 on: April 14, 2021, 09:58:12 pm »
Oh sure print outs! LOL

And how shall you defend using CALL?

Typing practice? LOL

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Hilbert Curve (Rosetta Code task)
« Reply #6 on: April 14, 2021, 11:41:08 pm »
Gotta say black background works better!
Code: QB64: [Select]
  1. _Title "Hilbert Curve Voronoi Coloring" '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.  
  7. Dim As Integer pnt, px, py, i, x, y, adjct, sy, ly
  8. pnt = 100
  9. px = wide * cell + cell
  10. py = wide * cell + cell
  11.  
  12. Screen _NewImage(px, py, 32)
  13.  
  14. Dim Shared As Integer Pax(pnt), Pay(pnt), Indx(px, py)
  15. Dim Shared As Long dSqr(px, py)
  16. Dim As Long col(pnt)
  17.  
  18. V = _NewImage(wide * cell + cell, wide * cell + cell, 32)
  19. For i = 1 To pnt
  20.     Pax(i) = Int(Rnd * px)
  21.     Pay(i) = Int(Rnd * py)
  22.     col(i) = _RGB(Pax(i) / px * 255, Pay(i) / py * 255, (px - Pax(i)) / px * 256)
  23.  
  24. For x = 0 To px - 1
  25.     For y = 0 To py - 1
  26.         dSqr(x, y) = (Pax(1) - x) * (Pax(1) - x) + (Pay(1) - y) * (Pay(1) - y)
  27.         Indx(x, y) = 1
  28.     Next
  29.  
  30. For i = 2 To pnt
  31.     ly = py - 1
  32.     For x = Pax(i) To 0 Step -1
  33.         If (scan(i, x, ly)) = 0 Then Exit For
  34.     Next x
  35.     For x = Pax(i) + 1 To px - 1
  36.         If (scan(i, x, ly)) = 0 Then Exit For
  37.     Next
  38.  
  39. For x = 0 To px - 1
  40.     For y = 0 To py - 1
  41.         sy = y
  42.         adjct = Indx(x, y)
  43.         For y = y + 1 To py
  44.             If Indx(x, y) <> adjct Then y = y - 1: Exit For
  45.         Next
  46.         Line (x, sy)-(x, y + 1), col(adjct)
  47.     Next
  48. Color , 0
  49. PSet (wide * cell, wide * cell) 'prime pump
  50. Hilbert 0, 0, wide, 0, 0
  51.  
  52. Function scan (site As Integer, x As Integer, ly As Integer)
  53.     Dim As Integer ty
  54.     Dim As Long delt2, dsq
  55.     delt2 = (Pax(site) - x) * (Pax(site) - x)
  56.     For ty = 0 To ly
  57.         dsq = (Pay(site) - ty) * (Pay(site) - ty) + delt2
  58.         If dsq <= dSqr(x, ty) Then
  59.             dSqr(x, ty) = dsq
  60.             Indx(x, ty) = site
  61.             scan = 1
  62.         End If
  63.     Next
  64.  
  65. Sub Hilbert (x As Integer, y As Integer, lg As Integer, p As Integer, q As Integer)
  66.     Dim As Integer iL, iX, iY
  67.     iL = lg: iX = x: iY = y
  68.     _Source V
  69.     If iL = 1 Then
  70.         K = Point((wide - iX) * cell, (wide - iY) * cell)
  71.         Line -((wide - iX) * cell, (wide - iY) * cell), K
  72.         Exit Sub
  73.     End If
  74.     iL = iL \ 2
  75.     Hilbert iX + p * iL, iY + p * iL, iL, p, 1 - q
  76.     Hilbert iX + q * iL, iY + (1 - q) * iL, iL, p, q
  77.     Hilbert iX + (1 - p) * iL, iY + (1 - p) * iL, iL, p, q
  78.     Hilbert iX + (1 - q) * iL, iY + q * iL, iL, 1 - p, q
  79.  
  80.  

 
Hibert Curve Voronoi Coloring.PNG

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Hilbert Curve (Rosetta Code task)
« Reply #7 on: April 15, 2021, 12:51:53 am »
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. H = _NewImage(wide * cell + cell, wide * cell + cell, 32)
  7. I = _LoadImage("Hilbert.PNG")
  8. _PutImage , I, H
  9. 'Color , &HFFFFFFFF 'nope black still works better!
  10. 'Cls
  11. PSet (wide * cell, wide * cell) 'prime pump
  12. Hilbert 0, 0, wide, 0, 0
  13.  
  14. Sub Hilbert (x As Integer, y As Integer, lg As Integer, p As Integer, q As Integer)
  15.     Dim As Integer iL, iX, iY
  16.     iL = lg: iX = x: iY = y
  17.     _Source H
  18.     If iL = 1 Then
  19.         K = Point((wide - iX) * cell, (wide - iY) * cell)
  20.         Line -((wide - iX) * cell, (wide - iY) * cell), K
  21.         Exit Sub
  22.     End If
  23.     iL = iL \ 2
  24.     Hilbert iX + p * iL, iY + p * iL, iL, p, 1 - q
  25.     Hilbert iX + q * iL, iY + (1 - q) * iL, iL, p, q
  26.     Hilbert iX + (1 - p) * iL, iY + (1 - p) * iL, iL, p, q
  27.     Hilbert iX + (1 - q) * iL, iY + q * iL, iL, 1 - p, q
  28.  

 
Hilbert in His Curve.PNG


Opps you will need the zip for the image I used.
* Hilbert in His Curve.zip (Filesize: 851.69 KB, Downloads: 170)
« Last Edit: April 15, 2021, 01:26:18 am by bplus »

Offline AndyA

  • Newbie
  • Posts: 73
    • View Profile
Re: Hilbert Curve (Rosetta Code task)
« Reply #8 on: April 15, 2021, 12:49:16 pm »
I like the last one 'Hilbert in Hilbert Curve', you could use just about any image to color the curve.