Author Topic: Worley Noise Demo  (Read 9595 times)

0 Members and 1 Guest are viewing this topic.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Worley Noise Demo
« Reply #15 on: February 02, 2022, 12:36:56 pm »
Here is one less Picasso and more moving:
Code: QB64: [Select]
  1. Screen _NewImage(800, 600, 32)
  2. DefLng A-Z
  3. 'seed
  4. fcirc 0, 0, 2, _RGB32(128, 128, 128, 200)
  5. fcirc _Width - 1, 0, 2, _RGB32(164, 164, 164, 200)
  6. fcirc _Width - 1, _Height - 1, 2, _RGB32(184, 184, 184, 200)
  7. fcirc 0, _Height - 1, 2, _RGB32(200, 200, 200, 200)
  8. cloud 0, 0, _Width - 1, _Height - 1, -1
  9.     cloud 0, 0, _Width - 1, _Height - 1, 0
  10.     _Display
  11.     _Limit 30
  12.  
  13. Sub cloud (x1, y1, x2, y2, initTF) ' corners of square or rect
  14.     Dim As Long c, ave, al
  15.     al = 255
  16.     mx = (x1 + x2) / 2
  17.     my = (y1 + y2) / 2
  18.     If (mx <= x1 + 1) Or (my <= y + 1) Then Exit Sub
  19.     c = (_Red32(Point(x1, y1)) + _Red32(Point(x2, y1)) + _Red32(Point(x1, y2)) + _Red32(Point(x2, y2))) / 4
  20.     ave = (5 * c + Rnd * 64 - 32) / 5
  21.     fcirc mx, my, 3, _RGB32(ave, ave, ave, al)
  22.     If init Then
  23.         'AHA! need to color corners of future squares  NOT just the middle!
  24.         fcirc mx, y1, 3, _RGB32(c + 32 * Rnd - 16, c + 32 * Rnd - 16, c + 32 * Rnd - 16, al)
  25.         fcirc x1, my, 3, _RGB32(c + 32 * Rnd - 16, c + 32 * Rnd - 16, c + 32 * Rnd - 16, al)
  26.         fcirc x2, my, 3, _RGB32(c + 32 * Rnd - 16, c + 32 * Rnd - 16, c + 32 * Rnd - 16, al)
  27.         fcirc mx, y2, 3, _RGB32(c + 32 * Rnd - 16, c + 32 * Rnd - 16, c + 32 * Rnd - 16, al)
  28.     End If
  29.     cloud x1, y1, mx, my, 0
  30.     cloud mx, y1, x2, my, 0
  31.     cloud x1, my, mx, y2, 0
  32.     cloud mx, my, x2, y2, 0
  33.  
  34. Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
  35.     Dim Radius As Long, RadiusError As Long
  36.     Dim X As Long, Y As Long
  37.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
  38.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
  39.     Line (CX - X, CY)-(CX + X, CY), C, BF
  40.     While X > Y
  41.         RadiusError = RadiusError + Y * 2 + 1
  42.         If RadiusError >= 0 Then
  43.             If X <> Y + 1 Then
  44.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  45.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  46.             End If
  47.             X = X - 1
  48.             RadiusError = RadiusError - X * 2
  49.         End If
  50.         Y = Y + 1
  51.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  52.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  53.     Wend
  54.  

Offline Phlashlite

  • Newbie
  • Posts: 50
    • View Profile
Re: Worley Noise Demo
« Reply #16 on: February 02, 2022, 12:55:02 pm »
Ooooh... That is close! :)

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Worley Noise Demo
« Reply #17 on: February 02, 2022, 01:02:33 pm »
Yeah close, but not IT yet!

Offline Phlashlite

  • Newbie
  • Posts: 50
    • View Profile
Re: Worley Noise Demo
« Reply #18 on: February 02, 2022, 01:11:58 pm »
I have to step through these things to figure them out...

I mean, I get the gist of it.. but I need details!

LOL!

FellippeHeitor

  • Guest
Re: Worley Noise Demo
« Reply #19 on: February 02, 2022, 01:26:11 pm »
https://en.wikipedia.org/wiki/Perlin_noise
Mentions Dot Product which I dont know if you are using in p5js?

I have no idea. Whatever p5.js is doing, this is doing.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Worley Noise Demo
« Reply #20 on: February 02, 2022, 02:04:58 pm »
I have no idea. Whatever p5.js is doing, this is doing.

Yeah my version of p5js has several Noise examples 1, 2, 3 could be dimensions? So what you reassembled may have been only the first dimension?

Update: OK I ran p5js through QB64 v1.5 to test the 3 "Perlin Noise" samples, plus I show that my version of p5js for QB64 has errors. It shows the Perlins as variations of 1 dimension.
 
image_2022-02-02_141847.png
« Last Edit: February 02, 2022, 02:19:01 pm by bplus »

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Worley Noise Demo
« Reply #21 on: February 02, 2022, 10:16:20 pm »
OK time to give your CPU's a workout! I found some pretty nice code from RetroBASIC forum by Galileo who found code from FreeBasic some years ago, I modified to get sky moving but a little jerky. Maybe with Mem tricks we can rewrite the noise array faster.

Code: QB64: [Select]
  1. _Title "Noise Texture Generator" ' trans Yabasic Port by Galileo to QB64 b+ 2022-02-02
  2. '//Noise texure generator
  3. '//Taken from
  4. '//http://www.student.kuleuven.be/~m0216922/CG/randomnoise.html/CG/randomnoise.html
  5. '//=======================================================================
  6. '// Ported from FreeBASIC to Yabasic by Galileo, 1/2018
  7. '// Original code: https://www.freebasic.net/forum/viewtopic.php?f=7&t=13842
  8.  
  9. Const twidth = 800, theight = 600, zoom = 128
  10. Dim Shared noise(twidth * theight) '//the noise array
  11. Dim Shared texture(twidth * theight) '//texture array
  12. Dim Shared pal(256) As _Unsigned Long '//color palette
  13.  
  14. Screen _NewImage(twidth, theight, 32)
  15. _ScreenMove 100, 100
  16. Dim x, y
  17.  
  18. MakePalette 255, 255, 255, 100, 100, 180
  19. GenerateNoise
  20.     For y = 0 To theight - 1
  21.         For x = 0 To twidth - 1
  22.             If x <> twidth - 1 Then
  23.                 noise(x + y * theight) = noise((x + 1) + y * theight)
  24.             Else
  25.                 If Rnd < .5 Then noise(x + y * theight) = Rnd Else noise(x + y * theight) = noise((x - 1) + y * theight)
  26.             End If
  27.         Next
  28.     Next
  29.     buildtexture
  30.     drawtexture
  31.     _Display
  32.  
  33. '//interpolation code by rattrapmax6
  34. Sub MakePalette (sr, sg, sb, er, eg, eb) ' (b+) start and end RGB's ? yes
  35.     Dim i, istart(3), iend(3), ishow(3), rend(3), interpol(3)
  36.  
  37.     interpol(0) = 255
  38.     istart(1) = sr
  39.     istart(2) = sg
  40.     istart(3) = sb
  41.     iend(1) = er
  42.     iend(2) = eg
  43.     iend(3) = eb
  44.     interpol(1) = (istart(1) - iend(1)) / interpol(0)
  45.     interpol(2) = (istart(2) - iend(2)) / interpol(0)
  46.     interpol(3) = (istart(3) - iend(3)) / interpol(0)
  47.     rend(1) = istart(1)
  48.     rend(2) = istart(2)
  49.     rend(3) = istart(3)
  50.  
  51.     For i = 0 To 255
  52.         ishow(1) = rend(1)
  53.         ishow(2) = rend(2)
  54.         ishow(3) = rend(3)
  55.  
  56.         pal(i) = _RGB32(ishow(1), ishow(2), ishow(3))
  57.  
  58.         rend(1) = rend(1) - interpol(1)
  59.         rend(2) = rend(2) - interpol(2)
  60.         rend(3) = rend(3) - interpol(3)
  61.     Next i
  62.  
  63. '//generates random noise.
  64. Sub GenerateNoise ()
  65.     Dim As Long x, y
  66.  
  67.     For x = 0 To twidth - 1
  68.         For y = 0 To theight - 1
  69.             noise(x + y * twidth) = Rnd
  70.         Next y
  71.     Next x
  72.  
  73. Function SmoothNoise (x, y)
  74.     '//get fractional part of x and y
  75.     Dim fractx, fracty, x1, y1, x2, y2, value
  76.     fractx = x - Int(x)
  77.     fracty = y - Int(y)
  78.  
  79.     '//wrap around
  80.     x1 = (Int(x) + twidth) Mod twidth
  81.     y1 = (Int(y) + theight) Mod theight
  82.  
  83.     '//neighbor values
  84.     x2 = (x1 + twidth - 1) Mod twidth
  85.     y2 = (y1 + theight - 1) Mod theight
  86.  
  87.     '//smooth the noise with bilinear interpolation
  88.     value = 0.0
  89.     value = value + fractx * fracty * noise(x1 + y1 * twidth)
  90.     value = value + fractx * (1 - fracty) * noise(x1 + y2 * twidth)
  91.     value = value + (1 - fractx) * fracty * noise(x2 + y1 * twidth)
  92.     value = value + (1 - fractx) * (1 - fracty) * noise(x2 + y2 * twidth)
  93.  
  94.     SmoothNoise = value
  95.  
  96. Function Turbulence (x, y, size)
  97.     Dim value, initialsize
  98.  
  99.     initialsize = size
  100.     While (size >= 1)
  101.         value = value + SmoothNoise(x / size, y / size) * size
  102.         size = size / 2.0
  103.     Wend
  104.     Turbulence = (128.0 * value / initialsize)
  105.  
  106. '//builds the texture.
  107. Sub buildtexture
  108.     Dim x, y
  109.  
  110.     For x = 0 To twidth - 1
  111.         For y = 0 To theight - 1
  112.             texture(x + y * twidth) = Turbulence(x, y, zoom)
  113.         Next y
  114.     Next x
  115.  
  116. '//draws texture to screen.
  117. Sub drawtexture ()
  118.     Dim x, y
  119.  
  120.     For x = 0 To twidth - 1
  121.         For y = 0 To theight - 1
  122.             PSet (x, y), pal(texture((x + y * twidth)))
  123.         Next y
  124.     Next x
  125.  
  126.  

 
Noise Texture Generator.PNG


Offline _vince

  • Seasoned Forum Regular
  • Posts: 422
    • View Profile
Re: Worley Noise Demo
« Reply #22 on: February 05, 2022, 06:57:26 am »
nice, that is a lot of mingling of basics.  How would you rank your favourite BASICs?  Justbasic, freebasic, xbasic, qbasic, qb64, libertybasic, VB.NET etc

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Worley Noise Demo
« Reply #23 on: February 05, 2022, 09:06:43 am »
nice, that is a lot of mingling of basics.  How would you rank your favourite BASICs?  Justbasic, freebasic, xbasic, qbasic, qb64, libertybasic, VB.NET etc

Using QB64 all the time now but first Eval function was in JB and 100 line Interpreter (with double parking) built from SmallBASIC Interpreter (no line numbers!).

Offline _vince

  • Seasoned Forum Regular
  • Posts: 422
    • View Profile
Re: Worley Noise Demo
« Reply #24 on: February 06, 2022, 08:27:52 am »
mod of a B+ mod!

Code: QB64: [Select]
  1. _Title "Noise Texture Generator" ' trans Yabasic Port by Galileo to QB64 b+ 2022-02-02
  2. '//Noise texure generator
  3. '//Taken from
  4. '//http://www.student.kuleuven.be/~m0216922/CG/randomnoise.html/CG/randomnoise.html
  5. '//=======================================================================
  6. '// Ported from FreeBASIC to Yabasic by Galileo, 1/2018
  7. '// Original code: https://www.freebasic.net/forum/viewtopic.php?f=7&t=13842
  8.  
  9. Const twidth = 800, theight = 600, zoom = 128
  10. Dim Shared noise(10*twidth * theight) '//the noise array
  11. Dim Shared texture(10*twidth * theight) '//texture array
  12. Dim Shared pal(256) As _Unsigned Long '//color palette
  13.  
  14. Screen _NewImage(twidth, theight, 32)
  15. _ScreenMove 100, 100
  16. Dim x, y
  17.  
  18. locate 1,1
  19. ? "please give us a few seconds"
  20.  
  21. MakePalette 255, 255, 255, 100, 100, 180
  22.  
  23. GenerateNoise
  24. buildtexture
  25.  
  26.  
  27. for i=0 to 9*(twidth )
  28.         drawtexture i
  29.         _limit 30
  30.         _display
  31.  
  32. 'Do
  33. '    For y = 0 To theight - 1
  34. '        For x = 0 To twidth - 1
  35. '            If x <> twidth - 1 Then
  36. '                noise(x + y * theight) = noise((x + 1) + y * theight)
  37. '            Else
  38. '                If Rnd < .5 Then noise(x + y * theight) = Rnd Else noise(x + y * theight) = noise((x - 1) + y * theight)
  39. '            End If
  40. '        Next
  41. '    Next
  42. '    buildtexture
  43. '    drawtexture
  44. '    _Display
  45. 'Loop Until _KeyDown(27)
  46.  
  47. '//interpolation code by rattrapmax6
  48. Sub MakePalette (sr, sg, sb, er, eg, eb) ' (b+) start and end RGB's ? yes
  49.     Dim i, istart(3), iend(3), ishow(3), rend(3), interpol(3)
  50.  
  51.     interpol(0) = 255
  52.     istart(1) = sr
  53.     istart(2) = sg
  54.     istart(3) = sb
  55.     iend(1) = er
  56.     iend(2) = eg
  57.     iend(3) = eb
  58.     interpol(1) = (istart(1) - iend(1)) / interpol(0)
  59.     interpol(2) = (istart(2) - iend(2)) / interpol(0)
  60.     interpol(3) = (istart(3) - iend(3)) / interpol(0)
  61.     rend(1) = istart(1)
  62.     rend(2) = istart(2)
  63.     rend(3) = istart(3)
  64.  
  65.     For i = 0 To 255
  66.         ishow(1) = rend(1)
  67.         ishow(2) = rend(2)
  68.         ishow(3) = rend(3)
  69.  
  70.         pal(i) = _RGB32(ishow(1), ishow(2), ishow(3))
  71.  
  72.         rend(1) = rend(1) - interpol(1)
  73.         rend(2) = rend(2) - interpol(2)
  74.         rend(3) = rend(3) - interpol(3)
  75.     Next i
  76.  
  77. '//generates random noise.
  78. Sub GenerateNoise ()
  79.     Dim As Long x, y
  80.  
  81.     For x = 0 To 10*twidth - 1
  82.         For y = 0 To theight - 1
  83.             noise(x + y * twidth) = Rnd
  84.         Next y
  85.     Next x
  86.  
  87. Function SmoothNoise (x, y)
  88.     '//get fractional part of x and y
  89.     Dim fractx, fracty, x1, y1, x2, y2, value
  90.     fractx = x - Int(x)
  91.     fracty = y - Int(y)
  92.  
  93.     '//wrap around
  94.     x1 = (Int(x) + 10*twidth) Mod twidth
  95.     y1 = (Int(y) + theight) Mod theight
  96.  
  97.     '//neighbor values
  98.     x2 = (x1 + 10*twidth - 1) Mod twidth
  99.     y2 = (y1 + theight - 1) Mod theight
  100.  
  101.     '//smooth the noise with bilinear interpolation
  102.     value = 0.0
  103.     value = value + fractx * fracty * noise(x1 + y1 * twidth)
  104.     value = value + fractx * (1 - fracty) * noise(x1 + y2 * twidth)
  105.     value = value + (1 - fractx) * fracty * noise(x2 + y1 * twidth)
  106.     value = value + (1 - fractx) * (1 - fracty) * noise(x2 + y2 * twidth)
  107.  
  108.     SmoothNoise = value
  109.  
  110. Function Turbulence (x, y, size)
  111.     Dim value, initialsize
  112.  
  113.     initialsize = size
  114.     While (size >= 1)
  115.         value = value + SmoothNoise(x / size, y / size) * size
  116.         size = size / 2.0
  117.     Wend
  118.     Turbulence = (128.0 * value / initialsize)
  119.  
  120. '//builds the texture.
  121. Sub buildtexture
  122.     Dim x, y
  123.  
  124.     For x = 0 To 10*twidth - 1
  125.         For y = 0 To theight - 1
  126.             texture(x + y * 10*twidth) = Turbulence(x, y, zoom)
  127.         Next y
  128.     Next x
  129.  
  130. '//draws texture to screen.
  131. Sub drawtexture (dx )
  132.     Dim x, y
  133.  
  134.     For x = 0 To twidth - 1
  135.         For y = 0 To theight - 1
  136.             PSet (x, y), pal(texture(((x + dx) + y * 10*twidth)))
  137.         Next y
  138.     Next x
  139.  
  140.  
« Last Edit: February 06, 2022, 08:37:59 am by _vince »

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Worley Noise Demo
« Reply #25 on: February 06, 2022, 10:04:43 am »
@_vince  yeah! nice mod much better!

Offline Phlashlite

  • Newbie
  • Posts: 50
    • View Profile
Re: Worley Noise Demo
« Reply #26 on: February 06, 2022, 11:57:23 am »
Those are nice!  Thank you both!  Lots to process... :)

Offline SierraKen

  • Forum Resident
  • Posts: 1454
    • View Profile
Re: Worley Noise Demo
« Reply #27 on: February 06, 2022, 05:37:20 pm »
Really cool clouds! I tried to make my own mod with this but no success. I was trying to make it all different colors at once instead of just white and blue.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Worley Noise Demo
« Reply #28 on: February 06, 2022, 09:39:20 pm »
Really cool clouds! I tried to make my own mod with this but no success. I was trying to make it all different colors at once instead of just white and blue.

You can redefine the pallet making sub, put in your own 255 colors best if colors close to each other in number are also close in hue.