Author Topic: Worley Noise Demo (Read 2887 times)

bplus · « **Reply #15 on:** February 02, 2022, 12:36:56 pm »

Here is one less Picasso and more moving:

Code: QB64: [Select]

Screen _NewImage(800, 600, 32)
DefLng A-Z
_Delay .5
'seed
fcirc 0, 0, 2, _RGB32(128, 128, 128, 200)
fcirc _Width - 1, 0, 2, _RGB32(164, 164, 164, 200)
fcirc _Width - 1, _Height - 1, 2, _RGB32(184, 184, 184, 200)
fcirc 0, _Height - 1, 2, _RGB32(200, 200, 200, 200)
cloud 0, 0, _Width - 1, _Height - 1, -1
Do
    cloud 0, 0, _Width - 1, _Height - 1, 0
    _Display
    _Limit 30
Loop Until _KeyDown(27)
 
Sub cloud (x1, y1, x2, y2, initTF) ' corners of square or rect
    Dim As Long c, ave, al
    al = 255
    mx = (x1 + x2) / 2
    my = (y1 + y2) / 2
    If (mx <= x1 + 1) Or (my <= y + 1) Then Exit Sub
    c = (_Red32(Point(x1, y1)) + _Red32(Point(x2, y1)) + _Red32(Point(x1, y2)) + _Red32(Point(x2, y2))) / 4
    ave = (5 * c + Rnd * 64 - 32) / 5
    fcirc mx, my, 3, _RGB32(ave, ave, ave, al)
    If init Then
        'AHA! need to color corners of future squares  NOT just the middle!
        fcirc mx, y1, 3, _RGB32(c + 32 * Rnd - 16, c + 32 * Rnd - 16, c + 32 * Rnd - 16, al)
        fcirc x1, my, 3, _RGB32(c + 32 * Rnd - 16, c + 32 * Rnd - 16, c + 32 * Rnd - 16, al)
        fcirc x2, my, 3, _RGB32(c + 32 * Rnd - 16, c + 32 * Rnd - 16, c + 32 * Rnd - 16, al)
        fcirc mx, y2, 3, _RGB32(c + 32 * Rnd - 16, c + 32 * Rnd - 16, c + 32 * Rnd - 16, al)
    End If
    cloud x1, y1, mx, my, 0
    cloud mx, y1, x2, my, 0
    cloud x1, my, mx, y2, 0
    cloud mx, my, x2, y2, 0
End Sub
 
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
    Dim Radius As Long, RadiusError As Long
    Dim X As Long, Y As Long
    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub
 

Phlashlite · « **Reply #16 on:** February 02, 2022, 12:55:02 pm »

Ooooh... That is close! :)

bplus · « **Reply #17 on:** February 02, 2022, 01:02:33 pm »

Yeah close, but not IT yet!

Phlashlite · « **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 · « **Reply #19 on:** February 02, 2022, 01:26:11 pm »

Quote from: bplus on February 02, 2022, 11:32:49 am

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.

bplus · « **Reply #20 on:** February 02, 2022, 02:04:58 pm »

Quote from: FellippeHeitor on February 02, 2022, 01:26:11 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.

bplus · « **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]

Option _Explicit
_Title "Noise Texture Generator" ' trans Yabasic Port by Galileo to QB64 b+ 2022-02-02
'//Noise texure generator
'//Taken from
'//http://www.student.kuleuven.be/~m0216922/CG/randomnoise.html/CG/randomnoise.html
'//=======================================================================
'// Ported from FreeBASIC to Yabasic by Galileo, 1/2018
'// Original code: https://www.freebasic.net/forum/viewtopic.php?f=7&t=13842
 
Const twidth = 800, theight = 600, zoom = 128
Dim Shared noise(twidth * theight) '//the noise array
Dim Shared texture(twidth * theight) '//texture array
Dim Shared pal(256) As _Unsigned Long '//color palette
 
Screen _NewImage(twidth, theight, 32)
_ScreenMove 100, 100
Dim x, y
 
MakePalette 255, 255, 255, 100, 100, 180
GenerateNoise
Do
    For y = 0 To theight - 1
        For x = 0 To twidth - 1
            If x <> twidth - 1 Then
                noise(x + y * theight) = noise((x + 1) + y * theight)
            Else
                If Rnd < .5 Then noise(x + y * theight) = Rnd Else noise(x + y * theight) = noise((x - 1) + y * theight)
            End If
        Next
    Next
    buildtexture
    drawtexture
    _Display
Loop Until _KeyDown(27)
 
'//interpolation code by rattrapmax6
Sub MakePalette (sr, sg, sb, er, eg, eb) ' (b+) start and end RGB's ? yes
    Dim i, istart(3), iend(3), ishow(3), rend(3), interpol(3)
 
    interpol(0) = 255
    istart(1) = sr
    istart(2) = sg
    istart(3) = sb
    iend(1) = er
    iend(2) = eg
    iend(3) = eb
    interpol(1) = (istart(1) - iend(1)) / interpol(0)
    interpol(2) = (istart(2) - iend(2)) / interpol(0)
    interpol(3) = (istart(3) - iend(3)) / interpol(0)
    rend(1) = istart(1)
    rend(2) = istart(2)
    rend(3) = istart(3)
 
    For i = 0 To 255
        ishow(1) = rend(1)
        ishow(2) = rend(2)
        ishow(3) = rend(3)
 
        pal(i) = _RGB32(ishow(1), ishow(2), ishow(3))
 
        rend(1) = rend(1) - interpol(1)
        rend(2) = rend(2) - interpol(2)
        rend(3) = rend(3) - interpol(3)
    Next i
End Sub
 
'//generates random noise.
Sub GenerateNoise ()
    Dim As Long x, y
 
    For x = 0 To twidth - 1
        For y = 0 To theight - 1
            noise(x + y * twidth) = Rnd
        Next y
    Next x
End Sub
 
Function SmoothNoise (x, y)
    '//get fractional part of x and y
    Dim fractx, fracty, x1, y1, x2, y2, value
    fractx = x - Int(x)
    fracty = y - Int(y)
 
    '//wrap around
    x1 = (Int(x) + twidth) Mod twidth
    y1 = (Int(y) + theight) Mod theight
 
    '//neighbor values
    x2 = (x1 + twidth - 1) Mod twidth
    y2 = (y1 + theight - 1) Mod theight
 
    '//smooth the noise with bilinear interpolation
    value = 0.0
    value = value + fractx * fracty * noise(x1 + y1 * twidth)
    value = value + fractx * (1 - fracty) * noise(x1 + y2 * twidth)
    value = value + (1 - fractx) * fracty * noise(x2 + y1 * twidth)
    value = value + (1 - fractx) * (1 - fracty) * noise(x2 + y2 * twidth)
 
    SmoothNoise = value
End Function
 
Function Turbulence (x, y, size)
    Dim value, initialsize
 
    initialsize = size
    While (size >= 1)
        value = value + SmoothNoise(x / size, y / size) * size
        size = size / 2.0
    Wend
    Turbulence = (128.0 * value / initialsize)
End Function
 
'//builds the texture.
Sub buildtexture
    Dim x, y
 
    For x = 0 To twidth - 1
        For y = 0 To theight - 1
            texture(x + y * twidth) = Turbulence(x, y, zoom)
        Next y
    Next x
End Sub
 
'//draws texture to screen.
Sub drawtexture ()
    Dim x, y
 
    For x = 0 To twidth - 1
        For y = 0 To theight - 1
            PSet (x, y), pal(texture((x + y * twidth)))
        Next y
    Next x
End Sub
 
 

_vince · « **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

bplus · « **Reply #23 on:** February 05, 2022, 09:06:43 am »

Quote from: _vince 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

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!).

_vince · « **Reply #24 on:** February 06, 2022, 08:27:52 am »

mod of a B+ mod!

Code: QB64: [Select]

Option _Explicit
_Title "Noise Texture Generator" ' trans Yabasic Port by Galileo to QB64 b+ 2022-02-02
'//Noise texure generator
'//Taken from
'//http://www.student.kuleuven.be/~m0216922/CG/randomnoise.html/CG/randomnoise.html
'//=======================================================================
'// Ported from FreeBASIC to Yabasic by Galileo, 1/2018
'// Original code: https://www.freebasic.net/forum/viewtopic.php?f=7&t=13842
 
Const twidth = 800, theight = 600, zoom = 128
Dim Shared noise(10*twidth * theight) '//the noise array
Dim Shared texture(10*twidth * theight) '//texture array
Dim Shared pal(256) As _Unsigned Long '//color palette
 
Screen _NewImage(twidth, theight, 32)
_ScreenMove 100, 100
Dim x, y
 
locate 1,1
? "please give us a few seconds"
_display
 
MakePalette 255, 255, 255, 100, 100, 180
 
GenerateNoise
buildtexture
 
 
dim i as integer
do
for i=0 to 9*(twidth )
        drawtexture i
        _limit 30
        _display
next
loop
 
'Do
'    For y = 0 To theight - 1
'        For x = 0 To twidth - 1
'            If x <> twidth - 1 Then
'                noise(x + y * theight) = noise((x + 1) + y * theight)
'            Else
'                If Rnd < .5 Then noise(x + y * theight) = Rnd Else noise(x + y * theight) = noise((x - 1) + y * theight)
'            End If
'        Next
'    Next
'    buildtexture
'    drawtexture
'    _Display
'Loop Until _KeyDown(27)
sleep
system
 
'//interpolation code by rattrapmax6
Sub MakePalette (sr, sg, sb, er, eg, eb) ' (b+) start and end RGB's ? yes
    Dim i, istart(3), iend(3), ishow(3), rend(3), interpol(3)
 
    interpol(0) = 255
    istart(1) = sr
    istart(2) = sg
    istart(3) = sb
    iend(1) = er
    iend(2) = eg
    iend(3) = eb
    interpol(1) = (istart(1) - iend(1)) / interpol(0)
    interpol(2) = (istart(2) - iend(2)) / interpol(0)
    interpol(3) = (istart(3) - iend(3)) / interpol(0)
    rend(1) = istart(1)
    rend(2) = istart(2)
    rend(3) = istart(3)
 
    For i = 0 To 255
        ishow(1) = rend(1)
        ishow(2) = rend(2)
        ishow(3) = rend(3)
 
        pal(i) = _RGB32(ishow(1), ishow(2), ishow(3))
 
        rend(1) = rend(1) - interpol(1)
        rend(2) = rend(2) - interpol(2)
        rend(3) = rend(3) - interpol(3)
    Next i
End Sub
 
'//generates random noise.
Sub GenerateNoise ()
    Dim As Long x, y
 
    For x = 0 To 10*twidth - 1
        For y = 0 To theight - 1
            noise(x + y * twidth) = Rnd
        Next y
    Next x
End Sub
 
Function SmoothNoise (x, y)
    '//get fractional part of x and y
    Dim fractx, fracty, x1, y1, x2, y2, value
    fractx = x - Int(x)
    fracty = y - Int(y)
 
    '//wrap around
    x1 = (Int(x) + 10*twidth) Mod twidth
    y1 = (Int(y) + theight) Mod theight
 
    '//neighbor values
    x2 = (x1 + 10*twidth - 1) Mod twidth
    y2 = (y1 + theight - 1) Mod theight
 
    '//smooth the noise with bilinear interpolation
    value = 0.0
    value = value + fractx * fracty * noise(x1 + y1 * twidth)
    value = value + fractx * (1 - fracty) * noise(x1 + y2 * twidth)
    value = value + (1 - fractx) * fracty * noise(x2 + y1 * twidth)
    value = value + (1 - fractx) * (1 - fracty) * noise(x2 + y2 * twidth)
 
    SmoothNoise = value
End Function
 
Function Turbulence (x, y, size)
    Dim value, initialsize
 
    initialsize = size
    While (size >= 1)
        value = value + SmoothNoise(x / size, y / size) * size
        size = size / 2.0
    Wend
    Turbulence = (128.0 * value / initialsize)
End Function
 
'//builds the texture.
Sub buildtexture
    Dim x, y
 
    For x = 0 To 10*twidth - 1
        For y = 0 To theight - 1
            texture(x + y * 10*twidth) = Turbulence(x, y, zoom)
        Next y
    Next x
End Sub
 
'//draws texture to screen.
Sub drawtexture (dx )
    Dim x, y
 
    For x = 0 To twidth - 1
        For y = 0 To theight - 1
            PSet (x, y), pal(texture(((x + dx) + y * 10*twidth)))
        Next y
    Next x
End Sub
 
 

bplus · « **Reply #25 on:** February 06, 2022, 10:04:43 am »

@_vince yeah! nice mod much better!

Phlashlite · « **Reply #26 on:** February 06, 2022, 11:57:23 am »

Those are nice! Thank you both! Lots to process... :)

SierraKen · « **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.

bplus · « **Reply #28 on:** February 06, 2022, 09:39:20 pm »

Quote from: SierraKen 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.

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.

News:

Author Topic: Worley Noise Demo (Read 2887 times)

bplus

Re: Worley Noise Demo

Phlashlite

Re: Worley Noise Demo

bplus

Re: Worley Noise Demo

Phlashlite

Re: Worley Noise Demo

FellippeHeitor

Re: Worley Noise Demo

bplus

Re: Worley Noise Demo

bplus

Re: Worley Noise Demo

_vince

Re: Worley Noise Demo

bplus

Re: Worley Noise Demo

_vince

Re: Worley Noise Demo

bplus

Re: Worley Noise Demo

Phlashlite

Re: Worley Noise Demo

SierraKen

Re: Worley Noise Demo

bplus

Re: Worley Noise Demo