Posts: 40
Threads: 2
Joined: May 2022
Dav -
I tried one of your "fog" programs in recent versions of QB64, it looks great. I also tried getting it working with the online BASIC machines out there. Had t he best luck with this one:
https://qbjs.org/?code=U2NyZWVuIF9OZXdJb...VuZCBTdWIK
For some reason the colors do not come out the same i think the new one looks more like a blue sky with clouds and the seams are more visible
Posts: 545
Threads: 116
Joined: Apr 2022
Reputation:
39
This is hysterical....my browser really wanted to translate that code from Welsh into English. Hmmm... got to review my language settings
Posts: 224
Threads: 7
Joined: Apr 2022
Reputation:
14
B+ mod time
Code: (Select All) 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
Posts: 224
Threads: 7
Joined: Apr 2022
Reputation:
14
B+ mod #2
Code: (Select All) _Title "U.S. Flag - Use space bar to change hills background."
const sw = 800
const sh = 600
Screen _NewImage(sw, sh, 32)
Cls
x = 150
y = 100
Dim cf&(113000)
Const nn = 1
Const twidth = sw, theight = sh, zoom = 128
Dim Shared noise(nn * twidth * theight) '//the noise array
Dim Shared texture(nn * twidth * theight) '//texture array
Dim Shared pal(256) As _Unsigned Long '//color palette
MakePalette 255, 155, 255, 10, 100, 180
GenerateNoise
buildtexture
Dim vs As Long
vs = _NewImage(twidth, theight, 32)
_Dest vs
drawtexture 0
_Dest 0
GoSub hills:
dim vvs as long
vvs = _newimage(sw, sh, 32)
vvs2 = _newimage(sw, sh, 32)
_dest vvs
'Stars
Line (x, y)-(x + 185, y + 130), _RGB32(0, 0, 255), BF
For xx = 155 To 345 Step 32
For yy = 105 To 220 Step 28
Line (xx + 2, yy + 12)-(xx + 7, yy), _RGB32(255, 255, 255)
Line (xx + 7, yy)-(xx + 13, yy + 12), _RGB32(255, 255, 255)
Line (xx + 13, yy + 12)-(xx, yy + 5), _RGB32(255, 255, 255)
Line (xx, yy + 5)-(xx + 15, yy + 5), _RGB32(255, 255, 255)
Line (xx + 15, yy + 5)-(xx + 2, yy + 12), _RGB32(255, 255, 255)
Paint (xx + 7, yy + 2), _RGB32(255, 255, 255)
Paint (xx + 7, yy + 6), _RGB32(255, 255, 255)
Paint (xx + 11, yy + 10), _RGB32(255, 255, 255)
Paint (xx + 4, yy + 10), _RGB32(255, 255, 255)
Paint (xx + 3, yy + 6), _RGB32(255, 255, 255)
Paint (xx + 12, yy + 6), _RGB32(255, 255, 255)
Next yy
Next xx
For xx = 172 To 329 Step 32
For yy = 118.9 To 213.05 Step 28
Line (xx + 2, yy + 12)-(xx + 7, yy), _RGB32(255, 255, 255)
Line (xx + 7, yy)-(xx + 13, yy + 12), _RGB32(255, 255, 255)
Line (xx + 13, yy + 12)-(xx, yy + 5), _RGB32(255, 255, 255)
Line (xx, yy + 5)-(xx + 15, yy + 5), _RGB32(255, 255, 255)
Line (xx + 15, yy + 5)-(xx + 2, yy + 12), _RGB32(255, 255, 255)
Paint (xx + 7, yy + 2), _RGB32(255, 255, 255)
Paint (xx + 7, yy + 6), _RGB32(255, 255, 255)
Paint (xx + 11, yy + 10), _RGB32(255, 255, 255)
Paint (xx + 4, yy + 10), _RGB32(255, 255, 255)
Paint (xx + 3, yy + 6), _RGB32(255, 255, 255)
Paint (xx + 12, yy + 6), _RGB32(255, 255, 255)
Next yy
Next xx
'Stripes
For rs = 100 To 230 Step 37.2
w = w + 1
Line (335, rs)-(612.5, rs + 18.6), _RGB32(255, 0, 0), BF
If w > 3 Then GoTo nex:
Line (335, rs + 18.6)-(612.5, rs + 37.2), _RGB32(255, 255, 255), BF
Next rs
nex:
w = 0
dim z(98) as _unsigned _integer64 'Marshawn polynomial coefficients of the nth order
z(0)=&h3000000~&&:z(1)=&hFFF8~&&:z(2)=&h0~&&:z(3)=&h830E000000000000~&&
z(4)=&h47FF080000000~&&:z(5)=&h1BFFFE6000~&&:z(6)=&h37FFFE~&&
z(7)=&h900000000000006E~&&:z(8)=&hFFFFC80000000000~&&:z(9)=&h5FFFFFE8000000~&&
z(10)=&hBFFFFFF400~&&:z(11)=&h17FFFFE~&&:z(12)=&hF80000000000017A~&&
z(13)=&hFFFFFA0000000000~&&:z(14)=&h2F7FFFFFA000000~&&:z(15)=&h2EDFFFFFF00~&&
z(16)=&h2DBFFFE~&&:z(17)=&hFD000000000002D6~&&:z(18)=&hFFFFED0000000000~&&
z(19)=&h2B7FFFFAD000000~&&:z(20)=&h6B41FC7AD00~&&:z(21)=&h6E3EFB8~&&
z(22)=&hAD0000000000066C~&&:z(23)=&h17463D0000000000~&&:z(24)=&h2D016C0B5000000~&&
z(25)=&h2B00A805900~&&:z(26)=&h2A00A80~&&:z(27)=&h1B000000000002A0~&&
z(28)=&h9801A0000000000~&&:z(29)=&h3A00A801A000000~&&:z(30)=&hA008805A00~&&
z(31)=&h901660~&&:z(32)=&h580000000000026E~&&:z(33)=&hEC90D00000000000~&&
z(34)=&h2F0096F2F000000~&&:z(35)=&h6FFE9B0F100~&&:z(36)=&h2FFD0BE~&&
z(37)=&hFD000000000002C6~&&:z(38)=&hD2DFFD0000000000~&&:z(39)=&h33BD55F1B000000~&&
z(40)=&h16DEDBDEA00~&&:z(41)=&h54F27A~&&:z(42)=&hF400000000000046~&&
z(43)=&hEEFAA80000000000~&&:z(44)=&h4B5D5EA0000000~&&:z(45)=&h6BD1AFA000~&&
z(46)=&h69FFFA~&&:z(47)=&h64~&&:z(48)=&h57AB400000000000~&&:z(49)=&h25D7AF40000000~&&
z(50)=&h2BF3BF4000~&&:z(51)=&h2B7FEE~&&:z(52)=&h4000000000000024~&&
z(53)=&h6EAEC00000000000~&&:z(54)=&h19FEBC80000000~&&:z(55)=&h4FFBC8000~&&
z(56)=&hE000003C0002AFC8~&&:z(57)=&h1080000420000~&&:z(58)=&h7032000204000040~&&
z(59)=&hBFEC00020400~&&:z(60)=&h8080009FC80004~&&:z(61)=&h400004060004010~&&
z(62)=&h18040000C19C00~&&:z(63)=&h3FE0007604000080~&&:z(64)=&h8700000003860400~&&
z(65)=&h100F0E000000C1E~&&:z(66)=&h2000100E61C0000~&&:z(67)=&hE1CC010001009FC2~&&
z(68)=&hC0078FF601000100~&&:z(69)=&h3B8703837020200~&&:z(70)=&h101803F2FC3B002~&&
z(71)=&h2000101FC07F83E~&&:z(72)=&h80FE0200008207C0~&&:z(73)=&hF01C0F810600005C~&&
z(74)=&h3C00007800E800~&&:z(75)=&h1F00036000~&&:z(76)=&h1DFE01E~&&
z(77)=&hEE00000000001E7E~&&:z(78)=&h8307F9E000000000~&&:z(79)=&hE3FC1CE07F1C0000~&&
z(80)=&h381E3FC1C00E0FF0~&&:z(81)=&hC03047F1FF0F0002~&&:z(82)=&hC3FE3FC8C31E7078~&&
z(83)=&h3839C10C83E2~&&:z(84)=&h8180000006071B04~&&:z(85)=&hC2180C00000000C0~&&
z(86)=&h610442E070000000~&&:z(87)=&h381D085B018000~&&:z(88)=&h60348360C~&&:z(89)=&h181B0~&&
z(90)=&h2430000000000000~&&:z(91)=&h30D0C04000000000~&&:z(92)=&h80D00800000~&&
z(93)=&h4070100~&&:z(94)=&h202~&&:z(95)=&h8200000000000000~&&:z(96)=&h1045C0000000000~&&
z(97)=&hEC60000000~&&
dim as _unsigned _integer64 b, i, n, j,d
redim f(320, 240) as double
redim ff(320, 240) as double
dim p(300) as long
for i=1 to 100
fr = 240*i/100 + 15
p(i) = _rgb(fr,0,0)
p(i + 100) = _rgb(255, fr, 0)
p(i + 200) = _rgb(255, 255, fr)
next
For rs = 230 To 341.6 Step 37.2
r = r + 1
Line (150, rs)-(612.5, rs + 18.6), _RGB32(255, 255, 255), BF
If r > 3 Then GoTo nex2:
Line (150, rs + 18.6)-(612.5, rs + 37.2), _RGB32(255, 0, 0), BF
Next rs
i = 0
n = 0
b = z(n)
xstep = 3
ystep = 2
for y=0 to 79-1
for x=0 to 80-1
if (b and _shl(1~&&, 63)) then
line (280 + x*xstep, 150 + y*ystep)-step(xstep,ystep),_rgb(0,0,0),bf
f (x + 120, y + 80) = 300
ff(x + 120, y + 80) = 300
end if
b = _shl(b, 1~&&)
i=i+1
if i = 64 then
n = n + 1
b = z(n)
i = 0
end if
next
next
paint (370,190),_rgb(0,0,0)
paint (420,190),_rgb(0,0,0)
_dest 0
_source vvs2
nex2:
r = 0
For fy = 100 To 341.6
For fx = 150 To 612.5
t5 = t5 + 1
cf&(t5) = Point(fx, fy)
Next fx
Next fy
t = 20
_source 0
'On Timer(2) GoSub hills:
'Timer On
ii = 0
jj = -1
Do
'Sky
ii = ii + 1
If ii >= sw Then
ii = 0
jj = Not jj
End If
If jj Then
_PutImage (ii, 0)-Step(sw, sh), vs
_PutImage (ii, 0)-Step(-sw, sh), vs
Else
_PutImage (ii + sw, 0)-Step(-sw, sh), vs
_PutImage (ii - sw, 0)-Step(sw, sh), vs
End If
'hour$ = Left$(Time$, 2)
'hour = Val(hour$)
'If hour < 21 And hour >= 6 Then
'Paint (2, 2), _RGB32(0, 205, 255)
'End If
_PutImage , hills&, 0
'Flag Pole
For sz = .25 To 10 Step .25
Circle (145, 80), sz, _RGB32(122, 128, 166)
Next sz
Line (142, 80)-(147, 600), _RGB32(122, 128, 166), BF
_dest vvs2
_putimage ,vvs
for y=1 to 240-1
for x=1 to 320-1
dim r as double
r = rnd
if r > 0.65 then f(x,y) = ff(x,y)
next
next
for y=0 to 240-2
for x=1 to 320-1
f(x,y) = max((f(x-1,y+1) + f(x,y+1) + f(x+1,y+1) + f(x-1,y+2))/4 - 5, 0)
line (x*xstep - 81, y*ystep - 6)-step(xstep, ystep), p(f(x,y)),bf
next
next
_source vvs2
r = 0
t5 = 0
For fy = 100 To 341.6
For fx = 150 To 612.5
t5 = t5 + 1
cf&(t5) = Point(fx, fy)
Next fx
Next fy
t = 20
_source 0
_dest 0
fx2 = fx2 + 1.2
If fx2 > 5 Then fx2 = 1.2
For fy = 100 To 341.6
For fx = 150 To 612.5
t6 = t6 + 1
if cf&(t6) <> _rgb(0,0,0) then
PSet ((Sin(fy * 0.017453 / fx2) * t) + fx, (Sin(fx * 0.017453 / fx2) * t) + fy), cf&(t6)
end if
Next fx
Next fy
t6 = 0
If tt = 0 Then t = t + 1
If t > 10 Then tt = 1
If tt = 1 Then t = t - 1
If t < -10 Then tt = 0
a$ = InKey$
If a$ = Chr$(27) Then End
'If a$ = " " Then
GoSub hills:
_Display
_Limit 50
Loop
hills:
'Random Hills
hills& = _NewImage(_Width, _Height, 32)
_Dest hills&
Randomize Timer
hills = 8'Int(Rnd * 40) + 3
For h = -3 To hills + 1
hx = 800*h/hills + (ii*8 mod 300) 'Int(Rnd * 800) + 1
size = 300'Int(Rnd * 450) + 75
cl = 15'Int(Rnd * 55)
shape = 0.7'Rnd
For sz = .25 To size Step .25
cl = cl + .05
Circle (hx, 599), sz, _RGB32(10, cl, 20), , , shape
Next sz
Next h
hills = 5'Int(Rnd * 40) + 3
For h = -3 To hills + 1
hx = 800*h/hills + (ii*5 mod 300) 'Int(Rnd * 800) + 1
size = 250'Int(Rnd * 450) + 75
cl = 35'Int(Rnd * 55)
shape = 0.7'Rnd
For sz = .25 To size Step .25
cl = cl + .05
Circle (hx, 599), sz, _RGB32(10, cl, 20), , , shape
Next sz
Next h
hills = 3'Int(Rnd * 40) + 3
For h = -3 To hills + 1
hx = 800*h/hills + (ii mod 300) 'Int(Rnd * 800) + 1
size = 180'Int(Rnd * 450) + 75
cl = 55'Int(Rnd * 55)
shape = 0.7'Rnd
For sz = .25 To size Step .25
cl = cl + .05
Circle (hx, 599), sz, _RGB32(10, cl, 20), , , shape
Next sz
Next h
_Dest 0
Return
function max(a, b)
if a > b then max = a else max = b'+
end function
'//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 nn * twidth - 1
For y = 0 To theight - 1
zz = Rnd
noise(x + y * twidth) = zz
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) + nn * twidth) Mod twidth
y1 = (Int(y) + theight) Mod theight
'//neighbor values
x2 = (x1 + nn * 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 nn * twidth - 1
For y = 0 To theight - 1
texture(x + y * nn * twidth) = Turbulence(x, y, zoom)
Next y
Next x
End Sub
'//draws texture to screen.
Sub drawtexture (dx)
Dim x, y
Dim As Long c, r, g, b
For x = 0 To twidth - 1
For y = 0 To theight - 1
c = pal(texture(((x + dx) + y * nn * twidth)))
r = _Red(c)
g = _Green(c)
b = _Blue(c)
c = _RGB(r - 0.2 * y, g - 0.2 * y, b - 0.2 * b)
PSet (x, y), c 'pal(texture(((x + dx) + y * nn*twidth)))
Next y
Next x
End Sub
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
Reply to vince last to posts:
I think Dav's method is better, no waiting like for Perlin noise and layered so images can be put amidst the mist.
And #13 is better than my post and #14 looks like a mash of stuff, not a post of mine. Ken's hills should move slower not faster in background and who is this Marshawn dude with a bad copy of my Jolly Roger burning? ;-))
b = b + ...
Posts: 300
Threads: 57
Joined: Apr 2022
Reputation:
56
@triggered: Very interesting. I get different colors too depending on what computer I'm on. On my ipad I get cloud like colors like your did. But on my laptop I get darker colors. I guess it depends on what javascript version the compuer is using? I dunno...
@vince: That first one you posted looks so good to me. Great cloud generator!
- Dav
|
