Text Only | Text with Attachments

QB64.org Forum

Active Forums => Programs => Topic started by: AndyA on April 13, 2021, 11:36:36 pm

Title: Hilbert Curve (Rosetta Code task)
Post by: AndyA on April 13, 2021, 11:36:36 pm
https://rosettacode.org/wiki/Hilbert_curve (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
  11.  
  12. PSet (wide * cell, wide * cell)
  13.  
  14. Call Hilbert(0, 0, wide, 0, 0)
  15.  
  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)
  32.  
Title: Re: Hilbert Curve (Rosetta Code task)
Post by: bplus 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.
Title: Re: Hilbert Curve (Rosetta Code task)
Post by: AndyA 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.
Title: Re: Hilbert Curve (Rosetta Code task)
Post by: bplus 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
  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
  24.  

Edit Update: Shared line removed, we have no intention of using wide and cell as variables so make them Const's =automatically shared.
Title: Re: Hilbert Curve (Rosetta Code task)
Post by: AndyA 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.
Title: Re: Hilbert Curve (Rosetta Code task)
Post by: bplus on April 14, 2021, 09:58:12 pm
Oh sure print outs! LOL

And how shall you defend using CALL?

Typing practice? LOL
Title: Re: Hilbert Curve (Rosetta Code task)
Post by: bplus on April 14, 2021, 11:41:08 pm
Gotta say black background works better!
Code: QB64: [Select]
  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.  
  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)
  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)
  21.  
  22. V = _NewImage(wide * cell + cell, wide * cell + cell, 32)
  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)
  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
  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
  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
  58. Color , 0
  60. PSet (wide * cell, wide * cell) 'prime pump
  61. Hilbert 0, 0, wide, 0, 0
  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
  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
  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
  95.  
  96.  

  [ This attachment cannot be displayed inline in 'Print Page' view ]  
Title: Re: Hilbert Curve (Rosetta Code task)
Post by: bplus 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)
  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
  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
  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
  33.  

 


Opps you will need the zip for the image I used.
Title: Re: Hilbert Curve (Rosetta Code task)
Post by: AndyA 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.
Text Only | Text with Attachments