Best compile options:
-gen gcc -O 3
-gen gcc -Wc -O2
-gen gcc -Wc -Ofast
x64 is horrible slow except -gen gcc -Wc -Ofast !?!?
Windows only version:
Code: Select all
'Coded by UEZ version v0.60 - original idea by Hugo Elias
'Thanks to: Joshy, duke4e
'
'Best compile settings for fastest fps: -gen gcc -Wc -Ofast -fpmode FAST -fpu SSE
'
#Include "fbgfx.bi"
#Include "file.bi"
'remove these following two lines if you don't need it
#Include "windows.bi"
FreeConsole 'windows.bi Is needed
Using FB
Dim Shared As Ushort iW = 512, iH = 384 'original background image size
Declare Function Shade(iColor As Long, iGain As Long) As Ulong
Declare Function ImageScale(s as fb.Image ptr, w as integer, h as integer) as fb.Image ptr
Declare Sub ExtractFishAnim()
Declare Function Base91Decode(sString As String, Byref iBase91Len As Ulong) As Ubyte Ptr
Declare Function _WinAPI_LZNTDecompress(aBinary As Ubyte Ptr, iFileSize As Ulong, iCompressedSize As Ulong) As Ubyte Ptr
#Define Floor(x) (((x) * 2.0 - 0.5) Shr 1) ' http://www.freebasic.net/forum/viewtopic.php?p=118633
#Define Ceiling(x) (-((-(x) * 2.0 - 0.5) Shr 1))
#Define Round(x) ((x * 100 + 0.5) / 100 Shr 0) '2 decimal places 10^2 = 100
#Define PixelSet(_x, _y, colour) *Cptr(Ulong Ptr, imgData + (_y) * pitch + (_x) Shl 2) = (colour)
#Define PixelGet(_x, _y) *Cptr(Ulong Ptr, imgData2 + (_y) * pitch + (_x) Shl 2)
#Define PixelSet2(_x, _y, colour) *Cptr(Ulong Ptr, imgData3 + (_y) * pitch + (_x) Shl 2) = (colour)
#Define Translate2Dto1D(_x, _y) ((_x) + (_y) * (iUBW + 1))
#Define _Red(colors) ((colors Shr 16) And 255)
#Define _Green(colors) ((colors Shr 8) And 255)
#Define _Blue(colors) (colors And 255)
#Define _Min(a, b) (Iif(a < b, a, b))
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Perlin -> https://www.freebasic.net/forum/viewtopic.php?t=10454#p91198
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Shared As Integer perm(512) = { _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180, _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180}
#Define FADE(_t) (_t * _t * _t * (_t * (_t * 6 - 15) + 10))
#Define NLERP(_t, _a, _b) ((_a) + (_t)*((_b)-(_a)))
Dim Shared As Single ms_grad4(512)
Dim As Single kkf(256)
For i As Integer = 0 To 255
kkf(i) = -1.0f + 2.0f * (i / 255.0f)
Next
For i As Integer = 0 To 255
ms_grad4(i) = kkf(perm(i)) * 0.507f
Next
Function Noise(x As Single, y As Single, px As Integer, py As Integer) As Single
Dim As Integer ix0, iy0, ix1, iy1
Dim As Single fx0, fy0
Dim As Single s, t, nx0, nx1, n0, n1
ix0 = Cint(x - 0.5f)
iy0 = Cint(y - 0.5f)
fx0 = x - ix0
fy0 = y - iy0
If px < 1 Then px = 1
If py < 1 Then py = 1
ix1 = ((ix0 + 1) Mod px) And &hff
iy1 = ((iy0 + 1) Mod py) And &hff
ix0 = (ix0 Mod px) And &hff
iy0 = (iy0 Mod py) And &hff
t = FADE(fy0)
s = FADE(fx0)
nx0 = ms_grad4(perm(ix0 + perm(iy0)))
nx1 = ms_grad4(perm(ix0 + perm(iy1)))
n0 = NLERP( t, nx0, nx1 )
nx0 = ms_grad4(perm(ix1 + perm(iy0)))
nx1 = ms_grad4(perm(ix1 + perm(iy1)))
n1 = NLERP(t, nx0, nx1)
Return NLERP(s, n0, n1)
End Function
Function Turbulence(x As Single, y As Single, size As Single) As Ubyte ' size must be 2 ^ n
Dim As Single value = 0.0, initialSize = size
While(size >= 1)
value += Noise(x / size, y / size, iW / size, iH / size) * size
size /= 2.0f
Wend
Return (128.0f * value / initialSize) + 127
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Randomize , 2
Dim As Single aCurrent(iH, iW), aPrevious(iH, iW)
Dim As Long iUBW = Ubound(aCurrent, 2), iX, iY
Dim As Single xOff, yOff, ripRadPower, ripRad = 5, depth = 2048
Dim Shared As Ulong aImage(iH, iW)
Dim As Single v, l, q
Dim As Single Ptr pACurrent, pAPrevious, pATmp
pACurrent = @aCurrent(0, 0)
pAPrevious = @aPrevious(0, 0)
Dim as Single fScale = 2.0 'scale factor for screen
Screenres iW * fScale, iH * fScale, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_ALWAYS_ON_TOP Or GFX_NO_SWITCH
Screenset 1, 0
Windowtitle("Water Effect v0.60 with a lonely fish coded by UEZ")
Dim As Any Ptr pImage = Imagecreate(iW, iH, 0, 32), pImage2 = Imagecreate(iW, iH, 0, 32), pImage2_Clone = Imagecreate(iW, iH, 0, 32), _
pImage_Fish1 = Imagecreate(96, 128, , 32), pImage_Sky = Imagecreate(iW, iH, 0, 32), pImage_resized = Imagecreate(iW * fScale, iH * fScale, 0, 32)
Bload(Curdir & "\Pebbles under Water_512x384.bmp", pImage2) 'Download: https://ibb.co/dGT1wyX and convert to BMP format
Bload(Curdir & "\Pebbles under Water_512x384.bmp", pImage2_Clone)
If Fileexists(Curdir & "\Fish3.bmp") = 0 Then ExtractFishAnim()
Bload(Curdir & "\Fish3.bmp", pImage_Fish1)
Dim As Integer w, h, pitch
Dim As Any Pointer imgData, imgData2, imgData3
Imageinfo(pImage, w, h, , pitch, imgData)
Imageinfo(pImage2, , , , , imgData2)
Imageinfo(pImage_Sky, , , , , imgData3)
Dim As SIngle T
'Add sky With clouds To the background image
Dim As Long x, y, z
For y = 0 To iH - 1
For x = 0 To iW - 1
T = Turbulence(-x, y, 64)
PixelSet2(x, y, Rgba(T, T, &hF0, _Min(&h08 + T, 255)))
Next
Next
Put pImage2_Clone, (0, 0), pImage_Sky, Alpha 'Add sky with clouds
Dim As Ulong i, iFPS = 0, iFPS_current = 0, iColor
Dim As Double fTimer, fTimer_drops = Timer
Dim As Integer mx, my, mb, iFrame
Dim As Single wave, light
Type tFishAnim
As Single x, y, vy, movespeed, animspeed, frame
As Ubyte Dir 'Dir -> 0 = top To botton, 1 = Right To Left, 2 = Left To Right, 3 = bottom To top
As Byte d
End Type
Dim As tFishAnim Fish
'one lonely fish
Fish.Dir = 2
Fish.x = -64
Fish.y = 32 + Rnd() * (iH - 32)
Fish.frame = 0
Fish.movespeed = 0.2 + Rnd() * 0.3
Fish.animspeed = Fish.movespeed / 2
Fish.d = 1
Do
'rebuild color array from original background image
For iY = 0 To iH - 1
For iX = 0 To iW - 1
aImage(iY, iX) = PixelGet(iX, iY) 'color values of bg image (pImage2)
Next
Next
'mouse interaction to disturb water surface
Getmouse (mx, my, , mb)
If mb = 1 Then
ripRadPower = Cushort(0.5 + Rnd() * 2.75)
For iY = my / fScale - (ripRad + ripRadPower) To my / fScale + (ripRad + ripRadPower)
For iX = mx / fScale - (ripRad + ripRadPower) To mx / fScale + (ripRad + ripRadPower)
pACurrent[Translate2Dto1D(Iif(iX < 0, 0, Iif(iX > iW - 1, iW - 1, iX)), _
Iif(iY < 0, 0, Iif(iY > iH - 1, iH - 1, iY)))] += 20
Next
Next
End If
'calculate the wave
For iY = 1 To iH - 1
For iX = 1 To iW - 1
wave = _
(pAPrevious[Translate2Dto1D((iX - 1), iY) ] + _
pAPrevious[Translate2Dto1D((iX + 1), iY) ] + _
pAPrevious[Translate2Dto1D( iX, (iY - 1))] + _
pAPrevious[Translate2Dto1D( iX, (iY + 1))] + _
pAPrevious[Translate2Dto1D((iX - 1), (iY - 1))] + _
pAPrevious[Translate2Dto1D((iX - 1), (iY + 1))] + _
pAPrevious[Translate2Dto1D((iX + 1), (iY - 1))] + _
pAPrevious[Translate2Dto1D((iX + 1), (iY + 1))] ) / 4
wave -= pACurrent[Translate2Dto1D(iX, iY)]
wave -= wave / 256
pACurrent[Translate2Dto1D(iX, iY)] = wave
light = wave * 3 - pACurrent[Translate2Dto1D(iX, iY)] * 2
wave = (depth - wave)
xOff = (((iX - iW) * wave) / depth) + iW
yOff = (((iY - iH) * wave) / depth) + iH
xOff = Iif(xOff >= iW, iW - 1, Iif(xOff < 0, 0, xOff))
yOff = Iif(yOff >= iH, iH - 1, Iif(yOff < 0, 0, yOff))
iColor = aImage(yOff, xOff)
light = Iif(light < -8, -8, Iif(light > 64, 64, light))
PixelSet(iX, iY, Shade(iColor, light))
Next
Next
For iX = 1 to 20
aPrevious((Rnd() * (iH - 1)) Shr 0, (Rnd() * (iW - 1)) Shr 0) += -10 * Rnd() + 20 ' some turbulances on water surface
next
'draw generated image to screen incl. FPS
If fScale <> 1 then
pImage_Resized = ImageScale(pImage, iW * fScale, iH * fScale)
Put (0,0), pImage_Resized, Pset
Imagedestroy pImage_resized
Else
Put (0,0), pImage, Pset
end if
Draw String(2, 2), iFPS_current & " fps", Rgb(&hFF, &hFF, &h00)
Flip
'do some random drops
If (Timer - fTimer_drops) > (1 + Rnd() * 10.0) Then
x = 15 + Cushort(Rnd() * (iW - 30))
y = 15 + Cushort(Rnd() * (iH - 30))
ripRadPower = Cushort(0.5 + Rnd() * 2.75)
Dim as Single fWPower = 32 + Rnd() * 224
For iY = y - (ripRad + ripRadPower) To y + (ripRad + ripRadPower)
For iX = x - (ripRad + ripRadPower) To x + (ripRad + ripRadPower)
pACurrent[Translate2Dto1D(Iif(iX < 0, 0, Iif(iX >= iW, iW - 1, iX)), _
Iif(iY < 0, 0, Iif(iY >= iH, iH - 1, iY)))] += fWPower
Next
Next
fTimer_drops = Timer
Endif
Swap pACurrent, pAPrevious
Put pImage2, (0, 0), pImage2_Clone, Pset 'restore background image
'do some very simple fish animation
Select Case Fish.Dir
Case 1
iFrame = Cubyte(Fish.frame)
Put pImage2, (Fish.x, Fish.y), pImage_Fish1, (iFrame * 32, Fish.Dir * 32) - (iFrame * 32 + 31, Fish.Dir * 32 + 31), Alpha
Fish.x -= Fish.movespeed
Fish.vy = Sin(Fish.x / 100 - Turbulence(Fish.x, Fish.y, 2048)) / 2
Fish.y += Fish.vy
If Fish.y > iH - 32 Then Fish.y = iH - 32
If Fish.y < 32 Then Fish.y = 32
Fish.frame += Fish.animspeed * Fish.d
If Fish.frame < 0 Or Fish.frame > 2 Then
Fish.d *= -1
End If
If Fish.x < -48 - Rnd() * 32 Then
Fish.y = 32 + Rnd() * (iH - 32)
Fish.movespeed = 0.2 + Rnd() * 0.3
Fish.animspeed = Fish.movespeed / 2
Fish.Dir = 2
End If
Case 2
iFrame = Cubyte(Fish.frame)
Put pImage2, (Fish.x, Fish.y), pImage_Fish1, (iFrame * 32, Fish.Dir * 32) - (iFrame * 32 + 31, Fish.Dir * 32 + 31), Alpha
Fish.x += Fish.movespeed
Fish.vy = Sin(Fish.x / 100 - Turbulence(Fish.x, Fish.y, 2048)) / 2
Fish.y += Fish.vy
If Fish.y > iH - 32 Then Fish.y = iH - 32
If Fish.y < 32 Then Fish.y = 32
Fish.frame += Fish.animspeed * Fish.d
If Fish.frame < 0 Or Fish.frame > 2 Then
Fish.d *= -1
End If
If Fish.x > iW + 16 + Rnd() * 32 Then
Fish.y = 32 + Rnd() * (iH - 32)
Fish.movespeed = 0.2 + Rnd() * 0.3
Fish.animspeed = Fish.movespeed / 2
Fish.Dir = 1
End If
End Select
If Timer - fTimer > 0.99 Then
iFPS_current = iFPS
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
Sleep(1, 1)
Loop Until Inkey = Chr(27)
Imagedestroy pImage
Imagedestroy pImage2
Imagedestroy pImage2_Clone
Imagedestroy pImage_Sky
Imagedestroy pImage_Fish1
Function Shade(iColor As Long, iGain As Long) As Ulong
Dim As Long a, r, g, b
r = _Red(iColor) + iGain
r = Iif(r < 0, 0, Iif(r > 255, 255, r))
g = _Green(iColor) + iGain
g = Iif(g < 0, 0, Iif(g > 255, 255, g))
b = _Blue(iColor) + iGain
b = Iif(b < 0, 0, Iif(b > 255, 255, b))
Return r Shl 16 Or g Shl 8 Or b
End Function
function ImageScale(s as fb.Image ptr, w as integer, h as integer) as fb.Image ptr 'by D.J. Peters aka Joshy (https://www.freebasic.net/forum/viewtopic.php?t=10533#p91780)
if s =0 then return 0
if s->width <1 then return 0
if s->height<1 then return 0
if w<4 then w=4
if h<4 then h=4
dim as fb.Image ptr t=ImageCreate(w,h)
dim as Long xs=(s->width /t->Width ) * &h10000 '(1024*64)
dim as Long ys=(s->height/t->height) * &h10000 '(1024*64)
dim as integer x,y,sy
select case as const s->bpp
case 1
dim as ubyte ptr ps=cptr(ubyte ptr,s)+32
dim as uinteger sp=s->pitch
dim as ubyte ptr pt=cptr(ubyte ptr,t)+32
dim as uinteger tp=t->pitch-t->width
for ty as integer = 0 to t->height-1
dim as ubyte ptr src=ps+(sy shr 16)*sp
for tx as integer = 0 to t->width-1
*pt=src[x shr 16]:pt+=1:x+=xs
next
pt+=tp:sy+=ys:x=0
next
case 2
dim as ushort ptr ps=cptr(ushort ptr,s)+16
dim as uinteger sp=(s->pitch shr 1)
dim as ushort ptr pt=cptr(ushort ptr,t)+16
dim as uinteger tp=(t->pitch shr 1)-t->width
for ty as integer = 0 to t->height-1
dim as ushort ptr src=ps+(sy shr 16)*sp
for tx as integer = 0 to t->width-1
*pt=src[x shr 16]:pt+=1:x+=xs
next
pt+=tp:sy+=ys:x=0
next
case 4
dim as ULong ptr ps=cptr(Ulong ptr,s)+8
dim as ULong sp=(s->pitch shr 2)
dim as ULong ptr pt=cptr(ULong ptr,t)+8
dim as ULong tp=(t->pitch shr 2)-t->width
for ty as Long = 0 to t->height-1
dim as ULong ptr src=ps+(sy shr 16)*sp
for tx as Long = 0 to t->width-1
*pt=src[x shr 16]:pt+=1:x+=xs
next
pt+=tp:sy+=ys:x=0
next
end select
return t
end function
Sub ExtractFishAnim()
Dim As Ulong iLines, bCompressed, iFileSize, iCompressedSize
Dim As String sBaseType, sBase91, aB91(1)
Restore __Fish3bmp:
Read iLines
Read bCompressed
Read iFileSize
Read iCompressedSize
Read sBaseType
For i As Ushort = 0 To iLines - 1
Read aB91(0)
sBase91 &= aB91(0)
Next
Dim As Ulong l
Dim As Ubyte Ptr aBinary = Base91Decode(sBase91, l)
Dim As Boolean bError = False
If bCompressed Then
If iCompressedSize <> l Then bError = TRUE
Else
If iFileSize <> l Then bError = TRUE
Endif
If bError <> False Then
? "Something went wrong"
Sleep
End
End If
Dim As Long hFile = Freefile()
Open Curdir & "\Fish3.bmp" For Binary Access Write As #hFile
If bCompressed Then
Dim As Ubyte Ptr aBinaryC = _WinAPI_LZNTDecompress(aBinary, iFileSize, iCompressedSize)
Put #hFile, 0, aBinaryC[0], iFileSize
Close #hFile
Deallocate (aBinaryC)
Else
Put #hFile, 0, aBinary[0], iFileSize
Close #hFile
Endif
aBinary = 0
End Sub
Function Base91Decode(sString As String, Byref iBase91Len As Ulong) As Ubyte Ptr
Dim As String sB91, sDecoded
sB91 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!#$%&()*+,./:;<=>?@[]^_`{|}~´" '´ instead of "
Dim As Long i, n = 0, c, b = 0, v = -1
Dim aChr(0 To Len(sString) - 1) As String
For i = 0 To Ubound(aChr)
aChr(i) = Mid(sString, i + 1, 1)
Next
For i = 0 To Ubound(aChr)
c = Instr(sB91, aChr(i)) - 1
If v < 0 Then
v = c
Else
v += c * 91
b = b Or (v Shl n)
n += 13 + (((v And 8191) <= 88) * -1)
Do Until (n > 7)=0
sDecoded &= Chr(b And 255)
b = b Shr 8
n -= 8
Loop
v = -1
Endif
Next
If (v + 1) Then
sDecoded &= Chr((b Or (v Shl n)) And 255)
End If
iBase91Len = Len(sDecoded)
Static As Ubyte aReturn(0 To Len(sDecoded))
For i = 0 To Len(sDecoded) - 1 'convert result String To ascii code values
aReturn(i) = Asc(sDecoded, i + 1)
Next
Return @aReturn(0) 'Return Pointer To the array
End Function
Function _WinAPI_LZNTDecompress(aBinary As Ubyte Ptr, iFileSize As Ulong, iCompressedSize As Ulong) As Ubyte Ptr
'#Define COMPRESSION_FORMAT_LZNT1 2
Dim As Any Ptr hLib = Dylibload("Ntdll.dll")
Dim pRtlDecompressBuffer As Function _
(Byval CompressionFormat As Ushort, _
Byval UncompressedBuffer As Ubyte Ptr, _
Byval UncompressedBufferSize As Ulong, _
Byval CompressedBuffer As Ubyte Ptr, _
Byval CompressedBufferSize As Ulong, _
Byval FinalUncompressedSize As Ulong Ptr) As Ulong
pRtlDecompressBuffer = Dylibsymbol(hLib, "RtlDecompressBuffer") 'https://docs.microsoft.com/en-us/windows-hardware/drivers/ddi/content/ntifs/nf-ntifs-rtldecompressbuffer
Dim As Ubyte Ptr pDecompress = Allocate(iFileSize)
Dim As Ulong iUSize
Dim As Ulong iReturn = pRtlDecompressBuffer(COMPRESSION_FORMAT_LZNT1, _
pDecompress, _
iFileSize, _
aBinary, _
iCompressedSize, _
@iUSize)
Dylibfree(hLib)
Return pDecompress
End Function
'Generated by FB File2Bas Code Generator v0.80 build 2019-01-05 beta by UEZ
__Fish3bmp:
Data 7,1,49274,4765,"Base91"
Data "iyM7e2!CO´AAfBVx~;C´pI@QT|B´luFA5FUEEAMA$NH#wA|Ek_EB>CFB&mIcRe:o*BS´4GT/rFwVP/[d!}^),~C%[2QcJNoW´~2n!F6C.]7M@_k.^F_W)ER|pyty(T´(9GVDwAzK=´[KEPi<PAB´yF}4UX%xTEJ´tt3}iBPD:C%aQL}ElqPZl5J#lu&Cd~I`5yAt+>DAKX=~^KT|v(HAeF6F*,4y23~wD´*hl3)h<PuH´;QFA´CtAt~~`KT|uWzL´@+R4}j_~KT|v(]LI>´o&yQ|}FB´v(tWA´qF3r+>D´WLP|9~PA8A6CJV+>D´)h~~bFT|kByKk_BtHAA´=~QV+>D´tW+>D´HA´s=~MV+>D´HAA´BtHA´sZK})=?~CPA8A=~HAeA`~g~(_BtHAeAdBd~fAhFHpR´Y;4FeAdByKk_/CJVY4IqVsH>0~0_BtHAA´BtHAA´=~QV+>D´HAeA`~DA[q}~zKk_BtHAeAdBd~z}}ee|:?8hPA8A6CJV+>B´i|^)YFeAdByKk_BtWL~~/CtWdByKk_BtHAeA!>0~?s7CJV+>D´HAeA`~g~(_/CJV+>D´HAeAc_w~z_BtKVBtBA<*KA4I4}(4R8d+GBx68(S´lG$4?~K,,zcr/$6(AA}Q6(6~D$*+OD@CrW1Fp(k~I`5y>?mP+27{H´(z/C{~s~jB=~,}!^F´PA=~0_tLBth[!Ts0!~&(py%xbGe´SXhB9~i|d+fWk_Ct,Vj´$lrY~~!~fA@.`k;v^)O(!A&Cd~I`4F3rXL4FVkF~g~)_BAOKqyp*Ix,>4F&s1J/Vk_/CJV+>/CtWn(zKk_BtHAA´´ztW~~9~Uqv(DAPA`~#~tW`~b]bc(E@E8A6CJV+>u(f|T)4FA´6CJV+>D´]3TL%CWB`~$^n4jw"
Data "HAeAdBd~At>~7}h´lu)h8A6C4}J?B´a|T)4FA´6CJV+>/C.V`s1.´siK<}J?D´HAku=~7}B´9~a|4*DAPA~~!~i|T)B´z_huHAeA`~ds0RRu8gA´QttWdByKk_BtEh´~9~a|B´7Kk_BtHAA´=~7}K?4FAtv(DAPAP|tVU~[@n4Pd=~HAeAPLf~z_EtWL~~ZFT|kBd~(_lufA´s=~MV*hAAy*qAkE4}N´mBQ~uvoVq;zXVx/h]´Ty5Fi(WLR_At!}e[o4S|5yfAA´>~Atw}<~y|d+tWA´=~#}q?WLY44F}AAt`~<Vk_:vtW~~F´PAA´=~!r+>DAMlTF#~NI`~<Vk_:vtWhB]KT|^)B´(_CtPA?~Q$5}q?F´HAA´luWL~~ZFSqv(DAPA~~9~tW`~zKk_BtHAeA@}_|F`B´7}J?D´HAeAdBd~z_luB´K?D´HAeAdBd~z_luWL~~D´HAeAdB]q0_lu!N6m9~PA8A6CJV+>/CtW`~zKk_/CJV+>D´WL~~9~Zqv(DAAtv(DA9´+C]qyqv(DAPA~~D´WLg_9~Zqv(DAPA8A=~HAQq=~7}K?D´HAeAdBd~3}[~MV+>D´HAeAdBd~z_B´7}K?D´HAeAdBd~z_luB´K?D´HAeAdBd~!{EtWL~~D´HAeAdBd~z_EtWL8AxtHAIA!ea{7yDt,ob?%´fAjBHL4}/COWT|w(PAfAhB]KT|v(tWk_CtPA!A&C/Vk_CtPAA´CtPA!A&C/Vk_CtPA!A`~HAfAhB]KT|v(HAfAhB9~fAhBZFSqv(DAPA8A6C4}#A6CJV+>D´HAeAdByKk_/CJV+>D´HAeAdByKk_BttW+>D´HAeAdByKk_BtHAA´BtHAeAdByKk_BtHAeA`~DAPA8A6CJV+>D´O)!A=~HAeAdByKk_"
Data "Bt*>z[vFT|kByKk_BtHAeA!>zKk_BttW+>D´HA2}2>QV+>D´HA+}BtHA_smu43lCOWb|kByKk_BtHAeAc_fsz_BttW+>D´HAeAc_g~z_BtHAA´izHAeAy&J`z_puHAoWBtWq!]sJ(2rW]KO}B´Qc4@cBAtv(WL1r6CJV+>D´4FJ/RW#A~~cFSqv(TEeWe{DPa4D´:vFB[w3Qj,>O*hM8QcgYKC!kk|?BF1aycw<EJBxAjLQWqg`Ex64FlB12]R{!lU=N:8^}B+2s}QBt,E:m,bqIlBl3Mhf(N7d?B´X^MiDRT@4*GO5v2a´&CiiHxWjV[~]&kk!RU?oBaPb´BZsI$$Kf~s>sA´O~fAH3=s%V.ENp/7=WTF%^R$|}q?|}R´d6~PWBtJh~(_5yAt~~VL&s:=s~k_J´QL+{u#!}B´>p:C`e.C^V3_2u{L[h4Fy(WL.CeW4}P@R´(cr(#~At!>e~}FHtl[!.Q?`x(_&,4}6vWL~~Q(V|w(WL{s[~fAjBdJq@+>[´fA´s@~(}/COWT|#AGAP;d_]QF)2*At?{rwfAjB2>7}q?J´tW~~nI#A+C#TG}6(<5´s^~Y~AtOWT|D)3FKg6>dVY43IB´D)PAtW`~g~(_1utW~~.~Ux!>5}6{&v=WE_%~n}T)B´z_luWLx[bFT|4*4F´s=~WL~~OWT|^)LckBGW1~G@u(Zq%)DA´#>9g~z_luWL~~[CPA8A=~7}K?/CtWc_e~fA`~fs?}+,xKg_P(Zqv(At0_luWL~~9~a|T)DAPA~~GDtW`~e~z_luHAeAe>(,O8NtEAhnoIt1?´2BAyuD+O]X(?,2K<u(<HV4xAM_W~c*T|t+AtjB^n/}u(VWY4z/PA,o`~@Vk_CtB´L@[KfAhB]KT|v(HAfA~~WLfAhB]K"
Data "T|v(HAfAhB9~fAhB]KT|v(HAfAhB]KT|/C/Vk_BtHAeAdByKk_BttW+>D´HAeAdByKk_BtHAA´BtHAeAdByKk_BtHAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA<)DAPA8AlB1[Yeh´*P~~J´HAeAdByKk_/CJVuW~CPA8A6CJV+>D´tW+>4FAtdByKk_BtHAeARV3FG!$obAku6CJV+>4FSqv(DA$txF2Kk_BtHAR|BtHAA´=~QV+>D´BAeAy]B´%cz<FO2>efWLdBd~z_puHAeA`~*eeAdByKk_luiH8A$A+>%Wl0B´q?D´HA1rI4tW8A6Cv(gAduRF$49}I~YVsik_uzHA+s=~FK+C8si+KvLjaF<sAAG´dEvD:KIudZXLzKR}b):.l_`u&8sWEH9|#(TX<G*xh=p[ZC:RNt}Y!W#`P@kkoWWE`hT´[OaG)zgqlBlK?Rht{(5/dGkkP:Ah]!|$q?WL%t.`H;tWX<%+9ZHtsM9RU?KYD@z)1W)WxA.^j#uu@XO´ukB´5y9s~~6|}F_eYA/s`Jd~>H0nB*|4Q´iWXb?j5l|)~][yx6tWjb9~y|d+WL;~>~N~H^>hlZ]bdA!~!h`@(_5SP7Kv%h%aPLd~&nntMs~~WLB´`~&^dGn.6CkQN?C~i39~@W@9u(GW$~?$WX=RA´5ytWP|9~a|w(4FNZs>T~bQ]9^[WX>:F#FK4}D?J´"
Data "B´K?cZ#A+C9~a|<(PAtW`~q?A´=~#}q?/C#A~~P(a|kBcs1;=yNW,COWv(W;j_i_.%4F~~OWT|w(4FeA`~g~B´=~7}C?J´WL+CaFT|Z)RqS|tuMJZZf}n}Z)GL´s=~WL~~9~a|4*DAPA~~!~a|B´e~z_:vEJ8AHL8}o`!LB´3<oFjB!C4}L?/CtW`~e~At,;LV+>%CtW`~e~z_luB´L?D´HA/veW8}F?.94M`~DAPA~~9~a|T)4F+o6C4}8A=~7}K?/CtW=~E,NPJtYA4yp*@~It2|;h%t6N+yd5nA}{0~c~v_=u+h>a#opK[~,}0[WLtWk[ZSVLp[}}+>WLB´&Cd~#A&C/Vk_CtPA3F>s,r+>WLT|v(HAfAhB]KT|v(HAB´v(HAfAhB]KT|v(HAfA~~F´PA!AdByKk_BtHAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA`~DAPA8A6CJV+>D´HAeA<)DAPA8A*B6ybeJ´_AL/ytB´{%+TF`6#0AB´`~js`_5yfAL~>~hrz|$~z|^)WL!A&Cd~(_B´!r+>DAkWmK|[U|^)HAB´^)WL!A&Cd~(_:vPA!A_s3s#~eWss+>4FAt`~<Vk_B´#}q?F´PA2}%J4}K?[CAtv(DAPA8A=~7}K?J´HAA´BtHAeA`~e~z_luwF8A=~HAeA`~e~c/[yWL8A6C4}#A=~"
Data "7}K?/CtWdByKk_BtB´K?/CtW`~zKk_BtHAzrcst1Q|UW6y&(4FeAdBd~fA`~e~z_luWL8A6CJV+>B´a|T)PAtWdByKk_BtWL}s.C#A~~9~Zqv(DAPA~~9~!T`~e~z_BtHAeA`~e~x_WL4}K?D´HAeA`~2[I`tuB´K?/CPA8A6C4}K?/CtW`~4FeAdByKk_luWL~~9~a|kByKk_Bt,Vh_P(]vR)2Fy_puHAIA0k[BN/CtkB?(/~j??.>S[FcMpIz(IZoIq:)hmII),0G!x8*OIi~sA´lq´sKim[r~Qo/t^>+yFOi?HA(sO~2|z|M/u(2C7r:>`<1Fe}{~<Vk_O7B´#A/vSXg_!~y|d+HA|s_set%~2!&}Z]F´RX]~9sz|*>g~I`5yJSg_<nD,^)[KA´CtRXy~wj5|&,[KA´=~7}B´!~hqv(DAPATL!~a|T)*>q_BtHAeAxFn~z_luGb~~:BPA8A6C4}K?/C!TdBd~fAdByKk_=aWLP|ZFSqv(KLk_YB34`~8M;}T)DAAtv(DAPA~~!~a|^)DAPA~~D´HAkuz3c~K?D´HAeAM)DAPAx~vDofrWCA.Uu(.7f|)B1rmag´4Aku6CJV+>D´tW+>4FAtc_zKk_BtHAeA_s.FA´1f{&@>D´HAeAdBd~luz=|):?|QPA8A6CJV+>tWb|^)WLeAdByKk_BtHAA´luWL8A6CJV+>D´HAku?~2L8A6CJV+>D´HAA´2>@J8A6C8MXLr!&A~B9~j?0#qIBtoBQ~2(VQc&w(&HU<IeZE<>QDgcF<9~}~{(^}S|)hB´{~s~I`5yW+#MzKKduIh(VL?~,}B´`KT|uWULiC_~!r+>F´?QXL|P:sq1p~*_CtAt~~$~fAhB8sYY|)WL!A&CX;u{ERz#K`}FfAhB9~y|"
Data "v(HAB´^)WL!A&CyKk_}9aAjB^~HAeAdByKk_:vtW8A6C4}#A6CJV+>/CtWxF0Kk_BttW+>D´HA´s~}(}M?D´HAA´BtHAA´=~QV+>D´HAeA,(DA7VU):.5yJVfgIF$$T|T)DAPA8A6CUE!A1hfbWLQj?.´;WLk_BtHAeA`~g~(_:vHAA´BtHAeAc_2~F!lu2L8AqyHAeAdBcskkluz8sW<{V//=.s0_BtHAeA`~WLA´=~QV+>D´HAeAc_e~}lz38}K?D´HAeAdBd~1_r|p+ZMVDwAw4VvOs`s<AXIdByKk_BttW~~!~i|kByKk_BtHA´sHL,}=>%´tW+>D´HAeAH(s?AX´DvKH?ZqPAcA*By]Y4G´ZS.48rOAA"
Code: Select all
'Coded by UEZ version v0.60 - original idea by Hugo Elias
'Thanks to: Joshy, duke4e
'
'Best compile settings for fastest fps: -gen gcc -Wc -Ofast -fpmode FAST -fpu SSE
'
#Include "fbgfx.bi"
#Include "file.bi"
Using FB
Dim Shared As Ushort iW = 512, iH = 384 'original background image size
Declare Function ImageScale(s as fb.Image ptr, w as integer, h as integer) as fb.Image ptr
Declare Function Shade(iColor As Long, iGain As Long) As Ulong
#Define PixelSet(_x, _y, colour) *Cptr(Ulong Ptr, imgData + (_y) * pitch + (_x) Shl 2) = (colour)
#Define PixelGet(_x, _y) *Cptr(Ulong Ptr, imgData2 + (_y) * pitch + (_x) Shl 2)
#Define PixelSet2(_x, _y, colour) *Cptr(Ulong Ptr, imgData3 + (_y) * pitch + (_x) Shl 2) = (colour)
#Define Translate2Dto1D(_x, _y) ((_x) + (_y) * (iUBW + 1))
#Define _Red(colors) ((colors Shr 16) And 255)
#Define _Green(colors) ((colors Shr 8) And 255)
#Define _Blue(colors) (colors And 255)
#Define _Min(a, b) (Iif(a < b, a, b))
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Perlin -> https://www.freebasic.net/forum/viewtopic.php?t=10454#p91198
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Shared As Integer perm(512) = { _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180, _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180}
#Define FADE(_t) (_t * _t * _t * (_t * (_t * 6 - 15) + 10))
#Define NLERP(_t, _a, _b) ((_a) + (_t)*((_b)-(_a)))
Dim Shared As Single ms_grad4(512)
Dim As Single kkf(256)
For i As Integer = 0 To 255
kkf(i) = -1.0f + 2.0f * (i / 255.0f)
Next
For i As Integer = 0 To 255
ms_grad4(i) = kkf(perm(i)) * 0.507f
Next
Function Noise(x As Single, y As Single, px As Integer, py As Integer) As Single
Dim As Integer ix0, iy0, ix1, iy1
Dim As Single fx0, fy0
Dim As Single s, t, nx0, nx1, n0, n1
ix0 = Cint(x - 0.5f)
iy0 = Cint(y - 0.5f)
fx0 = x - ix0
fy0 = y - iy0
If px < 1 Then px = 1
If py < 1 Then py = 1
ix1 = ((ix0 + 1) Mod px) And &hff
iy1 = ((iy0 + 1) Mod py) And &hff
ix0 = (ix0 Mod px) And &hff
iy0 = (iy0 Mod py) And &hff
t = FADE(fy0)
s = FADE(fx0)
nx0 = ms_grad4(perm(ix0 + perm(iy0)))
nx1 = ms_grad4(perm(ix0 + perm(iy1)))
n0 = NLERP( t, nx0, nx1 )
nx0 = ms_grad4(perm(ix1 + perm(iy0)))
nx1 = ms_grad4(perm(ix1 + perm(iy1)))
n1 = NLERP(t, nx0, nx1)
Return NLERP(s, n0, n1)
End Function
Function Turbulence(x As Single, y As Single, size As Single) As Ubyte
' size must be 2 ^ n
Dim As Single value = 0.0, initialSize = size
While(size >= 1)
value += Noise(x / size, y / size, iW / size, iH / size) * size
size /= 2.0f
Wend
Return (128.0f * value / initialSize) + 127
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Randomize , 2
Dim As Single aCurrent(iH, iW), aPrevious(iH, iW)
Dim As Long iUBW = Ubound(aCurrent, 2), iX, iY
Dim As Single xOff, yOff, ripRadPower, ripRad = 3
Dim Shared As Ulong aImage(iH, iW)
Dim As Single v, l, q
Dim As Single Ptr pACurrent, pAPrevious, pATmp
pACurrent = @aCurrent(0, 0)
pAPrevious = @aPrevious(0, 0)
Dim as Single fScale = 2.0 'scale factor for screen
Screenres iW * fScale, iH * fScale, 32, 2, GFX_ALPHA_PRIMITIVES Or GFX_ALWAYS_ON_TOP Or GFX_NO_SWITCH
Screenset 1, 0
Windowtitle("Water Effect v0.60 coded by UEZ")
Dim As Any Ptr pImage = Imagecreate(iW, iH, 0, 32), pImage2 = Imagecreate(iW, iH, 0, 32), pImage2_Clone = Imagecreate(iW, iH, 0, 32), _
pImage_Sky = Imagecreate(iW, iH, 0, 32), pImage_resized = Imagecreate(iW * fScale, iH * fScale, 0, 32)
Bload(Curdir & "\Pebbles under Water_512x384.bmp", pImage2) 'Download: https://ibb.co/dGT1wyX and convert to BMP format
Bload(Curdir & "\Pebbles under Water_512x384.bmp", pImage2_Clone)
Dim As Integer w, h, pitch
Dim As Any Pointer imgData, imgData2, imgData3
Imageinfo(pImage, w, h, , pitch, imgData)
Imageinfo(pImage2, , , , , imgData2)
Imageinfo(pImage_Sky, , , , , imgData3)
Dim As SIngle T
'Add sky With clouds To the background image
Dim As Long x, y, z
For y = 0 To iH - 1
For x = 0 To iW - 1
T = Turbulence(-x, y, 64)
PixelSet2(x, y, Rgba(T, T, &hF0, _Min(&h08 + T, 255)))
Next
Next
Put pImage2, (0, 0), pImage_Sky, Alpha 'Add sky with clouds
Dim As Ulong i, iFPS = 0, iFPS_current = 0, iColor
Dim As Double fTimer, fTimer_drops = Timer
Dim As Integer mx, my, mb, iFrame
Dim As Single wave, light
'rebuild color array from original background image
For iY = 0 To iH - 1
For iX = 0 To iW - 1
aImage(iY, iX) = PixelGet(iX, iY) 'color values of bg image (pImage2)
Next
Next
Do
'mouse interaction to disturb water surface
Getmouse (mx, my, , mb)
If mb = 1 Then
ripRadPower = Cushort(0.5 + Rnd() * 2.75)
For iY = my / fScale - (ripRad + ripRadPower) To my / fScale + (ripRad + ripRadPower)
For iX = mx / fScale - (ripRad + ripRadPower) To mx / fScale + (ripRad + ripRadPower)
pACurrent[Translate2Dto1D(Iif(iX < 0, 0, Iif(iX > iW - 1, iW - 1, iX)), _
Iif(iY < 0, 0, Iif(iY > iH - 1, iH - 1, iY)))] += 16
Next
Next
End If
'calculate the wave
For iY = 1 To iH - 1
For iX = 1 To iW - 1
wave = _
(pAPrevious[Translate2Dto1D((iX - 1), iY) ] + _
pAPrevious[Translate2Dto1D((iX + 1), iY) ] + _
pAPrevious[Translate2Dto1D( iX, (iY - 1))] + _
pAPrevious[Translate2Dto1D( iX, (iY + 1))] + _
pAPrevious[Translate2Dto1D((iX - 1), (iY - 1))] + _
pAPrevious[Translate2Dto1D((iX - 1), (iY + 1))] + _
pAPrevious[Translate2Dto1D((iX + 1), (iY - 1))] + _
pAPrevious[Translate2Dto1D((iX + 1), (iY + 1))] ) / 4
wave -= pACurrent[Translate2Dto1D(iX, iY)]
wave -= wave / 160
pACurrent[Translate2Dto1D(iX, iY)] = wave
light = wave * 3 - pACurrent[Translate2Dto1D(iX - 1, iY)] * 2
wave = (1024 - wave)
xOff = (((iX - iW) * wave) / 1024) + iW
yOff = (((iY - iH) * wave) / 1024) + iH
xOff = Iif(xOff >= iW, iW - 1, Iif(xOff < 0, 0, xOff))
yOff = Iif(yOff >= iH, iH - 1, Iif(yOff < 0, 0, yOff))
iColor = aImage(yOff, xOff)
light = Iif(light < -16, -16, Iif(light > 64, 64, light))
PixelSet(iX, iY, Shade(iColor, light))
Next
Next
For iX = 1 to 20
aPrevious((Rnd() * (iH - 1)) Shr 0, (Rnd() * (iW - 1)) Shr 0) += -8 * Rnd() + 16 ' some turbulances on water surface
next
'draw generated image to screen incl. FPS
If fScale <> 1 then
pImage_Resized = ImageScale(pImage, iW * fScale, iH * fScale)
Put (0,0), pImage_Resized, Pset
Imagedestroy pImage_resized
Else
Put (0,0), pImage, Pset
end if
Draw String(2, 2), iFPS_current & " fps", Rgb(&hFF, &h00, &h00)
Flip
'do some random drops
If (Timer - fTimer_drops) > (1 + Rnd() * 10.0) Then
x = 15 + Cushort(Rnd() * (iW - 30))
y = 15 + Cushort(Rnd() * (iH - 30))
ripRadPower = Cushort(0.5 + Rnd() * 2.75)
Dim as Single fWPower = 32 + Rnd() * 224
For iY = y - (ripRad + ripRadPower) To y + (ripRad + ripRadPower)
For iX = x - (ripRad + ripRadPower) To x + (ripRad + ripRadPower)
pACurrent[Translate2Dto1D(Iif(iX < 0, 0, Iif(iX >= iW, iW - 1, iX)), _
Iif(iY < 0, 0, Iif(iY >= iH, iH - 1, iY)))] += fWPower
Next
Next
fTimer_drops = Timer
Endif
Swap pACurrent, pAPrevious
Put (0, 0), pImage, Pset 'restore background image
If Timer - fTimer > 0.99 Then
iFPS_current = iFPS
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
Sleep(1, 1)
Loop Until Inkey = Chr(27)
Imagedestroy pImage
Imagedestroy pImage2
Imagedestroy pImage_Sky
Function Shade(iColor As Long, iGain As Long) As Ulong
Dim As Long a, r, g, b
r = _Red(iColor) + iGain
r = Iif(r < 0, 0, Iif(r > 255, 255, r))
g = _Green(iColor) + iGain
g = Iif(g < 0, 0, Iif(g > 255, 255, g))
b = _Blue(iColor) + iGain
b = Iif(b < 0, 0, Iif(b > 255, 255, b))
Return r Shl 16 Or g Shl 8 Or b
End Function
function ImageScale(s as fb.Image ptr, w as integer, h as integer) as fb.Image ptr 'by D.J. Peters aka Joshy (https://www.freebasic.net/forum/viewtopic.php?t=10533#p91780)
if s =0 then return 0
if s->width <1 then return 0
if s->height<1 then return 0
if w<4 then w=4
if h<4 then h=4
dim as fb.Image ptr t=ImageCreate(w,h)
dim as Long xs=(s->width /t->Width ) * &h10000 '(1024*64)
dim as Long ys=(s->height/t->height) * &h10000 '(1024*64)
dim as integer x,y,sy
select case as const s->bpp
case 1
dim as ubyte ptr ps=cptr(ubyte ptr,s)+32
dim as uinteger sp=s->pitch
dim as ubyte ptr pt=cptr(ubyte ptr,t)+32
dim as uinteger tp=t->pitch-t->width
for ty as integer = 0 to t->height-1
dim as ubyte ptr src=ps+(sy shr 16)*sp
for tx as integer = 0 to t->width-1
*pt=src[x shr 16]:pt+=1:x+=xs
next
pt+=tp:sy+=ys:x=0
next
case 2
dim as ushort ptr ps=cptr(ushort ptr,s)+16
dim as uinteger sp=(s->pitch shr 1)
dim as ushort ptr pt=cptr(ushort ptr,t)+16
dim as uinteger tp=(t->pitch shr 1)-t->width
for ty as integer = 0 to t->height-1
dim as ushort ptr src=ps+(sy shr 16)*sp
for tx as integer = 0 to t->width-1
*pt=src[x shr 16]:pt+=1:x+=xs
next
pt+=tp:sy+=ys:x=0
next
case 4
dim as ULong ptr ps=cptr(Ulong ptr,s)+8
dim as ULong sp=(s->pitch shr 2)
dim as ULong ptr pt=cptr(ULong ptr,t)+8
dim as ULong tp=(t->pitch shr 2)-t->width
for ty as Long = 0 to t->height-1
dim as ULong ptr src=ps+(sy shr 16)*sp
for tx as Long = 0 to t->width-1
*pt=src[x shr 16]:pt+=1:x+=xs
next
pt+=tp:sy+=ys:x=0
next
end select
return t
end function
I used this background image (probably you have to convert it to BMP format first):
Pebbles under Water_512x384.bmp
I'm not using Linux and thus not tested!
v0.50: added one lonely fish
v0.55: try to add sky reflection to water surface
v0.60: added scale function + some small modifications