Twister Effect build 2020-04-15

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
UEZ
Posts: 635
Joined: May 05, 2017 19:59
Location: Germany

Twister Effect build 2020-04-15

Postby UEZ » Apr 15, 2020 11:45

I ported the very nice twister effect from here to FB.

Screenshot:
Image

TwisterFX.bas

Code: Select all

'Ported to FreeBasic by UEZ build 2020-04-15
'Original code by neur0sys -> 'https://codepen.io/neuro_sys/pen/QpxMvp

#Include "fbgfx.bi"
#include "file.bi"

Using FB

#Define PixelSet(_x, _y, colour)      *Cptr(Ulong Ptr, imgData + (_y) * pitch + (_x) Shl 2) = (colour)
#Define PixelGet(_x, _y)               *Cptr(Ulong Ptr, imgData2 + (_y) * pitch2 + (_x) Shl 2)
#Define LinearInterpolate(a1, a2, m)   ((a1 * (1 - m) + a2 * m))
#Define Alpha(colors)                  ((colors Shr 24) And 255)
#Define Red(colors)                    ((colors Shr 16) And 255)
#Define Green(colors)                  ((colors Shr 8) And 255)
#Define Blue(colors)                   (colors And 255)

'https://en.wikipedia.org/wiki/BMP_file_format
Type tBitmap_Header Field = 1 '54 bytes
   As UShort bfType   'for windows bitmap it must be 19778 (&h4D42) aka "BM" in little-endian format
   As Long bfSize
   As ULong bfReserved
   As ULong bfOffBits
   As ULong biSize
   As Long biWidth = 0
   As Long biHeight = 0
   As Ushort biPlanes
   As Ushort biBitCount
   As ULong biCompression
   As ULong biSizeImage
   As Long biXPelsPerMeter
   As Long biYPelsPerMeter
   As ULong biClrUsed
   As ULong biClrImportant
End Type

Declare Sub drawTextureLine(x As Ushort, y As Ushort, _width As Ushort, bf as Single = 0.90)
Declare Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Declare Function GetBitmapHeaderInfo(filename As String) As tBitmap_Header

Dim As String sFile = CurDir & "\Image.bmp" '<---- file must exist!

Dim As tBitmap_Header BmpInfo = GetBitmapHeaderInfo(sFile)

Dim Shared As Ushort iW, iH, iW2, iH2, amp
iW = BmpInfo.biWidth : iH = BmpInfo.biHeight * 2
iW2 = iW \ 2 : iH2 = iH \ 2 : amp = iH \ 4
If iW = 0 or iH = 0 Then ? "ERROR: unable to load image" : End

Const fPI = Acos(-1), fRAD = fPI / 180, surfaces = 4, angle = 360 / surfaces

Dim As Ushort i, s, j, aSurfaces(surfaces)
Dim As Single t, freq, c, d

Screenres iW, iH, 32, , GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP
Windowtitle("Twister Effect v0.70")

Dim Shared As Any Ptr pImage, pImage2, pImage_blur
pImage = Imagecreate(iW, iH, , 32)
pImage2 = Imagecreate(BmpInfo.biWidth, BmpInfo.biHeight)
Bload(sFile, pImage2)

Dim Shared As Integer w, h, pitch, w2, h2, pitch2
Dim Shared As Any Pointer imgData, imgData2
Imageinfo(pImage, w, h, , pitch, imgData)
Imageinfo(pImage2, w2, h2, , pitch2, imgData2)

Dim As Ulong iFPS = 0

Do
   Screenlock
   Line pImage, (0, 0) - (iW, iH), &hA0404040, BF
   
   t = Cos(d / 50) * iW
   d += 1.5
   freq = Sin(d / 125) / 4
   
   For j = 0 To iW - 1
       
      c = (j + t) * freq
      
      For i = 0 To surfaces - 1
         aSurfaces(i) = iH2 + Sin((c + angle * i) * fRAD) * amp
      Next
      
      For i = 0 To surfaces - 2
         If aSurfaces(i) < aSurfaces(i + 1) Then drawTextureLine(j, aSurfaces(i), aSurfaces(i + 1) - aSurfaces(i))
      Next
      aSurfaces(i) = iH2 + Sin((c + angle * i) * fRAD) * amp
      If aSurfaces(i) < aSurfaces(0) Then drawTextureLine(j, aSurfaces(i), aSurfaces(0) - aSurfaces(i))
      
   Next
   
   Put (0, 0), pImage, Alpha
   
   Draw String(1, 1), iFPS & " fps", Rgba(&hFF, &h00, &h00, &hFF)
   Screenunlock   
      
   Sleep (Regulate(30, iFPS), 1)
   
Loop Until Len(Inkey())

Imagedestroy(pImage)
Imagedestroy(pImage2)


End

Sub drawTextureLine(x As Ushort, y As Ushort, k As Ushort, bf as Single = 0.90)
   Dim As Ushort u, v
   Dim As Ulong texel
   Dim As Single f, r, g, b
   For i As Ushort = 0 To k - 1
      u = LinearInterpolate(0, w2, x / iW)
      v = LinearInterpolate(0, h2, i / k)
      texel = PixelGet(u, v)
      f = k / amp * bf
      r = Red(texel) * f
      r = Iif(r > 255, 255, r)
      g = Green(texel) * f
      g = Iif(g > 255, 255, g)
      b = Blue(texel) * f
      b = Iif(b > 255, 255, b)
      PixelSet(x, y + i, Rgba(r, g, b, &hFF))
   Next
End Sub

Function Regulate(MyFps As Long, Byref fps As Long) As Long 'by dodicat
   Static As Double timervalue, _lastsleeptime, t3, frames
   Var t = Timer
   frames += 1
   If (t - t3) >= 1 Then t3 = t : fps = frames : frames = 0
   Var sleeptime =_lastsleeptime + ((1 / myfps) - t + timervalue) * 1000
   If sleeptime < 1 Then sleeptime = 1
   _lastsleeptime = sleeptime
   timervalue = t
   Return sleeptime
End Function

Function GetBitmapHeaderInfo(filename As String) As tBitmap_Header
   Dim As tBitmap_Header BmpInfo
   If FileExists(filename) = 0 Then Return BmpInfo
   Dim As Integer f
   f = FreeFile
   Open filename For Binary As #f
   Get #f, , BmpInfo
   Close #f
   Return BmpInfo
End Function



To run this code you need a bitmap file. I used this one here: https://pastebin.com/qdVJXJ1a (too large to post it here). Just compile and execute it in the same directory (save source code in UTF8 format!). A bitmap file named "Image.bmp" should be created. This will be used in TwisterFX.bas

Of course you can use any other supported bitmap file.



Here the version with different texture per surface.

Image



Download source code (inc. the code above), bitmaps and compiled executable here: FB_Twister_Effect.zip


Theoretically this should run also on Linux...
Last edited by UEZ on Apr 17, 2020 9:06, edited 2 times in total.
badidea
Posts: 2150
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Twister Effect build 2020-04-15

Postby badidea » Apr 15, 2020 15:10

UEZ wrote:Theoretically this should run also on Linux...

Yes, it does, when changing/using the following:
Encoding: ISO-8859-1
String.bi -> string.bi
\Image.bmp -> /Image.bmp
UEZ
Posts: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Twister Effect build 2020-04-15

Postby UEZ » Apr 15, 2020 20:08

badidea wrote:
UEZ wrote:Theoretically this should run also on Linux...

Yes, it does, when changing/using the following:
Encoding: ISO-8859-1
String.bi -> string.bi
\Image.bmp -> /Image.bmp


Thanks for your feedback. :-)
dodicat
Posts: 6720
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Twister Effect build 2020-04-15

Postby dodicat » Apr 16, 2020 18:40

Thanks UEZ.
Really nice.
I converted to .bmp with xnconvert.
https://www.xnview.com/en/xnconvert/
I have been using it for a few years.
UEZ
Posts: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Twister Effect build 2020-04-15

Postby UEZ » Apr 16, 2020 19:55

dodicat wrote:Thanks UEZ.
Really nice.
I converted to .bmp with xnconvert.
https://www.xnview.com/en/xnconvert/
I have been using it for a few years.

Thanks dodicat but what do you mean with
I converted to .bmp with xnconvert.
? The Pastebin code generates the .bmp file. I'm using XNView, too. Very nice tool.
dodicat
Posts: 6720
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Twister Effect build 2020-04-15

Postby dodicat » Apr 16, 2020 21:42

UEZ
I didn't notice the pastebin thing.
I got the image from the forum picture.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 3 guests