One of the reasons its not very fast is because its employs realtime bi-linear filtering, resampling, smoothing and dynamic interpolation.

Code: Select all

`Option Explicit`

CONST FinalSZ AS INTEGER = 128

CONST IndSZ AS INTEGER = 16

Const IndSZM As INTEGER = IndSZ-1

Dim shared as integer Tile(1 To IndSZ, 1 To IndSZ), FinalIMG(1 to FinalSZ, 1 To FinalSZ)

Dim shared as integer PT(1 To 4, 1 To 3, 1 To FinalSZ, 1 To FinalSZ)

Dim shared as integer QuickSelect(1 to 4)

QuickSelect(1) = 1

QuickSelect(2) = 2

QuickSelect(3) = 4

QuickSelect(4) = 8

Sub SmoothNoise()

Dim as integer x,y

For y = 1 to IndSZ

For x = 1 To IndSZ

Tile(x,y) = int(rnd * 256) - 128

Next x

Next y

dim as integer x1, x2, y1, y2, c, s, m, Temp(1 To IndSZ, 1 To IndSZ)

For y = 1 to IndSZ

If y=1 Then

y1 = IndSZ

y2 = 2

Elseif y=IndSZ then

y1 = IndSZM

y2 = 1

else

y1 = y-1

y2 = y+1

Endif

For x = 1 To IndSZ

If x=1 Then

x1 = IndSZ

x2 = 2

Elseif x=IndSZ then

x1 = IndSZM

x2 = 1

else

x1 = x-1

x2 = x+1

Endif

c = (Tile(x1,y1)+Tile(x2,y1)+Tile(x1,y2)+Tile(x2,y2)) SHR 4

s = (Tile(x ,y1)+Tile(x2,y )+Tile(x ,y2)+Tile(x1,y )) SHR 3

m = Tile(x,y) SHR 2

Temp(x,y) = c+s+m

Next x

Next y

For y=1 To IndSZ:For x=1 To IndSZ:Tile(x,y)=Temp(x,y):Next x:Next y

End Sub

Sub Resample(byval tle as integer, byval wne as integer, byval amt as double)

dim as double fz, fzm, xm, ym, xd, yd, v1,v2,v3,v4,l1,l2

dim as integer Temp(1 To FinalSZ, 1 To FinalSZ),x,y,xs,ys,f1

fz = FinalSZ / amt

fzm = IndSZ/fz

ym = 1

For y = 1 to FinalSZ

ym += fzm

If int(ym) = IndSZ+1 Then ym = 1

ys = Int(ym)

yd = ym-ys

xm = 1

For x = 1 To FinalSZ

xm += fzm

If int(xm) = IndSZ+1 Then xm = 1

xs = Int(xm)

xd = xm-xs

v1 = Tile(xs,ys)

If xs >= IndSZ and ys <> IndSZ Then

v2 = Tile(1 ,ys )

v3 = Tile(1 ,ys+1)

v4 = Tile(xs ,ys+1)

Elseif xs >= IndSZ and ys >= IndSZ then

v2 = Tile(1 ,ys )

v3 = Tile(1 ,1 )

v4 = Tile(xs ,1 )

Elseif xs <> IndSZ and ys >= IndSZ Then

v2 = Tile(xs+1,ys )

v3 = Tile(xs+1,1 )

v4 = Tile(xs ,1 )

else

v2 = Tile(xs+1,ys )

v3 = Tile(xs+1,ys+1)

v4 = Tile(xs ,ys+1)

Endif

l1 = (v2-v1) * xd + v1

l2 = (v3-v4) * xd + v4

f1 = (l2-l1) * yd + l1

PT(tle,wne,x,y) = f1

Next x

Next y

End Sub

Sub AddToFinal(byval tle2 as integer)

Dim as integer x,y

For y=1 To FinalSZ:For x=1 To FinalSZ

FinalIMG(x,y)+=(PT(tle2,3,x,y) / QuickSelect(tle2))

If FinalIMG(x,y)<-128 Then FinalIMG(x,y)=-128

If FinalIMG(x,y)> 127 Then FinalIMG(x,y)= 127

Next x:Next y

End Sub

Sub ResetFinal()

Dim as integer x,y

For y=1 To FinalSZ:For x=1 To FinalSZ:FinalIMG(x,y)=0:Next x:Next y

End Sub

Dim shared as integer EX(0 To 255)

Sub Exponential()

Dim as integer c,d,cv

For cv = 0 To 255

c = cv-128

If c<0 Then c=0

d = 255-((0.95^c)*255)

EX(cv)=d

Next cv

End Sub

Sub CreateFinal()

Dim as integer x,y

For y=1 To FinalSZ

For x=1 To FinalSZ

FinalIMG(x,y)=EX(FinalIMG(x,y)+128)

Next x

Next y

End Sub

Sub DrawFinal(byval ox as integer, byval oy as integer)

Dim as integer x,y,c,xx,yy

screenlock

For y=1 To FinalSZ

For x=1 To FinalSZ

c=FinalIMG(x,y)

xx=ox+x:yy=oy+y

PSET (xx,yy), RGB(c,c,c)

Next x

Next y

screenunlock

End Sub

Sub SwapChannels(byval tle as integer)

Dim as integer x,y

For y=1 To FinalSZ

For x=1 To FinalSZ

PT(tle,1,x,y) = PT(tle,2,x,y)

Next x

Next y

End Sub

Sub InterpolateChannels(byval tle as integer, byval amt as double)

Dim as integer x,y, itf

For y=1 To FinalSZ

For x=1 To FinalSZ

PT(tle,3,x,y) = (PT(tle,2,x,y)-PT(tle,1,x,y)) * amt + PT(tle,1,x,y)

Next x

Next y

End Sub

'-------------------------------------------MAIN--------------------------------

screenres 320,200,32,2,1

screenset 1,0

Randomize Timer

Dim as double iT(1 to 4), iTs(1 to 4)

Dim as integer i, b

Exponential

iT(1) = 100: iTs(1)=.001: SmoothNoise: Resample 1,2,1

iT(2) = 100: iTs(2)=.002: SmoothNoise: Resample 2,2,2

iT(3) = 100: iTs(3)=.005: SmoothNoise: Resample 3,2,4

iT(4) = 100: iTs(4)=.010: SmoothNoise: Resample 4,2,8

Do

ResetFinal

b = 0

If multikey(&H39) Then b = 1

For i = 1 To 4

If iT(i) >= 1 Then

iT(i) = 0

SwapChannels i

SmoothNoise

Resample i,2,QuickSelect(i)

Else

If b = 1 Then

iT(i) += iTs(i)*10

Else

iT(i) += iTs(i)

Endif

InterpolateChannels i, iT(i)

Endif

AddToFinal i

Next i

CreateFinal

Locate 13,3: Print "FAUX ClOUDS -->"

Line (155,32)-(284,161),&HFFFF00,B

Line (156,33)-(283,160),rgb(100,120,255),B

DrawFinal 155,32

Flip

Loop until multikey(&h01)

end