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