Smoky Zoom Effect

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

Smoky Zoom Effect

Postby UEZ » Jul 01, 2020 13:29

A long time ago I wrote a function using GDIPlus to create a smoky zooming effect.

I tried to use FB code only which should also run on Linux and here the result:

Smoky Zoom Effect.bas

Code: Select all

'Coded by UEZ build 2020-07-02
'Thanks to Joshy, Mario Klingemann and dodicat (see below)

#Include "fbgfx.bi"

Using FB

#Define Min(a, b) Iif(a < b, a, b)
#Define Max(a, b) Iif(a > b, a, b)

Function ImageScale(s As Image Ptr, w As Integer, h As Integer) As 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 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

'Super Fast Blur v1.1 by Mario Klingemann <http://incubator.quasimondo.com>
Function SuperFastBlur(pImage As Any Pointer, iRadius As Ubyte, iW As Ushort, iH As Ushort) As Any Pointer '24-bit only
   Dim pImage_Blurred As Any Ptr = Imagecreate(iW, iH, 0, 32)

   Dim As Ulong Ptr pix_in = Cast(Ulong Ptr, pImage) + Sizeof(pImage) + Sizeof(Ulong)
   Dim As Ulong Ptr pix_out = Cast(Ulong Ptr, pImage_Blurred) + Sizeof(pImage_Blurred) + Sizeof(Ulong)
   /'
   pix = Cast(Ulong Ptr, Cast(Ubyte Ptr, imgData) + Sizeof(imgData) * Sizeof(Ulong) + Sizeof(Ulong) * Sizeof(Ulong))
   '/
   Dim As Long wm, hm, wh, divv, rsum, gsum, bsum, x, y, i, p, p1, p2, yp, yi, yw, iPitch = iW
   If (iW Mod 4) <> 0 Then iPitch = (iW \ 4) * 4 + 4

   wm = iW - 1
   hm = iH - 1
   wh = iW * iH
   divv = 2 * iRadius + 1

   Dim As Long vmin(0 To Max(iW, iH)), vmax(0 To Max(iW, iH)), dv(0 To 256 * divv), r(0 To wh), g(0 To wh), b(0 To wh)

   For i = 0 To 256 * divv - 1
      dv(i) = i \ divv
   Next

   yw = 0
   yi = 0
   
   For y = 0 To hm
      rsum = 0
      gsum = 0
      bsum = 0
      For i = -iRadius To iRadius
         p = pix_in[yw + Min(wm, Max(i, 0))]
         rsum += (p And &hFF0000) Shr 16
         gsum += (p And &h00FF00) Shr 8
         bsum += (p And &h0000FF)
      Next
      For x = 0 To wm
         r(yi) = dv(rsum)
         g(yi) = dv(gsum)
         b(yi) = dv(bsum)
         If y = 0 Then
            vmin(x) = Min(x + iRadius + 1, wm)
            vmax(x) = Max(x - iRadius,       0)
         End If
         p1 = pix_in[yw + vmin(x)]
         p2 = pix_in[yw + vmax(x)]
         rsum += ((p1 And &hFF0000) - (p2 And &hFF0000)) Shr 16
         gsum += ((p1 And &h00FF00) - (p2 And &h00FF00)) Shr 8
         bsum +=  (p1 And &h0000FF) - (p2 And &h0000FF)
         yi += 1
      Next
      yw += iPitch
   Next
   
   For x = 0 To wm
      rsum = 0
      gsum = 0
      bsum = 0
      yp = -iRadius * iW
      For i = -iRadius To iRadius
         yi = Max(0, yp) + x
         rsum += r(yi)
         gsum += g(yi)
         bsum += b(yi)
         yp += iW
      Next
      yi = x
      For y = 0 To hm
         pix_out[yi] = &hFF000000 Or dv(rsum) Shl 16 Or dv(gsum) Shl 8 Or dv(bsum)
         If x = 0 Then
            vmin(y) = Min(y + iRadius + 1, hm) * iW
            vmax(y) = Max(y - iRadius, 0) * iW
         End If
         p1 = x + vmin(y)
         p2 = x + vmax(y)

         rsum += r(p1) - r(p2)
         gsum += g(p1) - g(p2)
         bsum += b(p1) - b(p2)

         yi += iPitch
      Next
   Next
   Return pImage_Blurred
End Function

Function Regulate(TargetFPS 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 / TargetFPS) - t + timervalue) * 1000
   If sleeptime < 1 Then sleeptime = 1
   _lastsleeptime = sleeptime
   timervalue = t
   Return sleeptime
End Function

Const w = 800, h = 500, w2 = w \ 2, h2 = h \ 2

Dim As Single s = 0.025, scale1 = 1 + s, scale2 = 1 - s, px1, px2, py1, py2, r = 200, pi = Acos(-1), rad = pi / 180, angle = Rnd() * 100, x, y, f1, f2, k = 0
Dim As Ushort ws = w * scale1, hs = h * scale1
Dim As String sTxt = "Coded by UEZ"

Screenres w, h, 32, , GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES
Windowtitle("Smoky Zoom Effect by UEZ")

Dim As Any Ptr pImage1, pImage2, pImage3

Dim As Ubyte c

pImage1 = Imagecreate(w, h, &h00000000, 32)

Dim As Ulong iFPS_current = 0

Do
   Screenlock
   
   f1 = angle * rad
   f2 = (180 + angle) * rad
   px1 = w2 + Sin(f1) * r
   py1 = h2 + Cos(f1) * r
   px2 = w2 + Sin(f2) * r
   py2 = h2 + Cos(f2) * r
   c = k Mod 255
   
   Line pImage1, (px1, py1)-(px2, py2), Rgba(c, c, c, &hA0)
   
   x = w2 + Cos((px2 - angle) / 50) * 150 - 50
   y = h2 + Sin((py2 + angle) / 30) * 50
   Draw String pImage1, (x, y), sTxt, Rgba(255, (255 - angle) Mod 256, c, &hC0)
   
   pImage2 = ImageScale(pImage1, ws, hs)
   pImage3 = SuperFastBlur(pImage2, 3, ws, hs)
   
   Put pImage1, ((w - ws) / 2, (h - hs) / 2), pImage3, (0, 0)-(ws, hs), Trans
   
   Draw String pImage1, (x, y), sTxt, Rgba(255, 255, 255, &h80)
   
   Imagedestroy(pImage2)
   Imagedestroy(pImage3)
   
   Put (0, 0), pImage1, PSet
   
   Draw String(2, 2), iFPS_current & " fps", Rgba(&hFF, &hFF, &hFF, &hB0)
   
   angle += 1.0
   k += 0.5
   
   Screenunlock
      
   Sleep(Regulate(30, iFPS_current))
Loop Until Len(Inkey())

Imagedestroy(pImage1)


Sneak preview:
Image


For the lyric version see 5 posts below.
Last edited by UEZ on Jul 04, 2020 11:54, edited 3 times in total.
deltarho[1859]
Posts: 2530
Joined: Jan 02, 2017 0:34
Location: UK

Re: Smoky Zoom Effect

Postby deltarho[1859] » Jul 01, 2020 23:15

More awesome graphics from the UEZ stable. Image

gcc32 -O2 29fps
gcc64 -O2 58fps
gas64 29fps

Visuallly, for me, I prefer 29fps.

Great imagination!
UEZ
Posts: 586
Joined: May 05, 2017 19:59
Location: Germany

Re: Smoky Zoom Effect

Postby UEZ » Jul 02, 2020 12:38

deltarho[1859] wrote:More awesome graphics from the UEZ stable. Image

gcc32 -O2 29fps
gcc64 -O2 58fps
gas64 29fps

Visuallly, for me, I prefer 29fps.

Great imagination!

Thanks deltarho for your feedback. I modified the code and added dodicat's regulate function to run at ~30 fps which is visually nicer to watch.
badidea
Posts: 2079
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Smoky Zoom Effect

Postby badidea » Jul 02, 2020 17:10

Here the demo crashes (or freezes with -exx) on 64-bit fbc 1.07.1 on Ubuntu. I don't see the reason yet. 32-bit compile works fine.
dodicat
Posts: 6557
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Smoky Zoom Effect

Postby dodicat » Jul 02, 2020 19:00

I like your thing that much that I made it into a movie.
https://www.mediafire.com/file/pl93s3xctak56en/ground_control.zip/file
(Windows only)
UEZ
Posts: 586
Joined: May 05, 2017 19:59
Location: Germany

Re: Smoky Zoom Effect

Postby UEZ » Jul 03, 2020 8:54

dodicat wrote:I like your thing that much that I made it into a movie.
https://www.mediafire.com/file/pl93s3xctak56en/ground_control.zip/file
(Windows only)


Declaration of love... :-) Indeed, with sound it's much better.

Windows only:

I tried to make it in real time playing the sound. You need dodicat's zip from above. Put Bass.dll / Bass64.dll in the same source code folder and create both files from source code below!

Or download everything from here: Major Tom Lyric Version

Bass2.bi

Code: Select all

'Coded by UEZ build 2020-06-17
#Include Once "windows.bi"
#Include Once "file.bi"

Const BASS_UNICODE = &h80000000, BASS_DEVICE_ENABLED = 1, BASS_FILEDATA_END = 0, BASS_FILEPOS_START = 3, BASS_SAMPLE_8BITS = 1, _
     BASS_SAMPLE_FLOAT = 256, BASS_SAMPLE_MONO = 2, BASS_SAMPLE_LOOP = 4, BASS_SAMPLE_3D = 8, BASS_SAMPLE_SOFTWARE = 16, _
     BASS_SAMPLE_MUTEMAX = 32, BASS_SAMPLE_VAM = 64, BASS_SAMPLE_FX = 128, BASS_STREAM_PRESCAN = &h20000, BASS_STREAM_AUTOFREE = &h400001, _
     BASS_STREAM_RESTRATE = &h800001, BASS_STREAM_BLOCK = &h100000, BASS_STREAM_DECODE = &h200000, BASS_MUSIC_RAMP = &h200, _
     BASS_MUSIC_RAMPS = &h400, BASS_MUSIC_SURROUND = &h800, BASS_MUSIC_SURROUND2 = &h1000, BASS_MUSIC_FT2PAN = &h2000, _
     BASS_MUSIC_FT2MOD = &h2000, BASS_MUSIC_PT1MOD = &h4000, BASS_MUSIC_NONINTER = &h10000, BASS_MUSIC_STOPBACK = &h80000, _
     BASS_ASYNCFILE = &h40000000, BASS_CTYPE_SAMPLE = 1, BASS_CTYPE_RECORD = 2, BASS_CTYPE_STREAM = &h10000, BASS_CTYPE_STREAM_OGG = &h10002, _
     BASS_CTYPE_STREAM_MP1 = &h10003, BASS_CTYPE_STREAM_MP2 = &h10004, BASS_CTYPE_STREAM_MP3 = &h10005, BASS_CTYPE_STREAM_AIFF = &h10006, _
     BASS_CTYPE_STREAM_CA = &h10007, BASS_CTYPE_STREAM_MF = &h10008, BASS_CTYPE_STREAM_AM = &h10009, BASS_CTYPE_STREAM_DUMMY = &h18000, _
     BASS_CTYPE_STREAM_DEVICE = &h18001, BASS_CTYPE_STREAM_WAV = &h40000, BASS_CTYPE_STREAM_WAV_PCM = &h50001, BASS_CTYPE_STREAM_WAV_FLOAT = &h50003, _
     BASS_CTYPE_MUSIC_MOD = &h20000, BASS_CTYPE_MUSIC_MTM = &h20001, BASS_CTYPE_MUSIC_S3M = &h20002, BASS_CTYPE_MUSIC_XM = &h20003, _
     BASS_CTYPE_MUSIC_IT = &h20004, BASS_CTYPE_MUSIC_MO3 = &h00100, BASS_DATA_AVAILABLE = 0, BASS_DATA_FIXED = &h20000000, _
     BASS_DATA_FLOAT = &h40000000, BASS_DATA_FFT256 = &h80000000, BASS_DATA_FFT512 = &h80000001, BASS_DATA_FFT1024 = &h80000002, _
     BASS_DATA_FFT2048 = &h80000003, BASS_DATA_FFT4096 = &h80000004, BASS_DATA_FFT8192 = &h80000005, BASS_DATA_FFT16384 = &h80000006, _
     BASS_DATA_FFT32768 = &h80000007, BASS_DATA_FFT_INDIVIDUAL = &h10, BASS_DATA_FFT_NOWINDOW = &h20, BASS_DATA_FFT_REMOVEDC = &h40, _
     BASS_DATA_FFT_COMPLEX = &h80, BASS_DATA_FFT_NYQUIST = &h100, BASS_POS_BYTE = 0, BASS_POS_MUSIC_ORDER = 1, BASS_POS_OGG = 3, _
     BASS_ATTRIB_FREQ = 1, BASS_ATTRIB_VOL = 2, BASS_ATTRIB_PAN = 3, BASS_ATTRIB_EAXMIX = 4, BASS_ATTRIB_NOBUFFER = 5, BASS_ATTRIB_VBR = 6, _
     BASS_ATTRIB_CPU = 7, BASS_ATTRIB_SRC = 8, BASS_ATTRIB_NET_RESUME = 9, BASS_ATTRIB_SCANINFO = 10, BASS_ATTRIB_NORAMP = 11, _
     BASS_ATTRIB_BITRATE = 12, BASS_ATTRIB_BUFFER = 13, BASS_ATTRIB_MUSIC_AMPLIFY = &h100, BASS_ATTRIB_MUSIC_PANSEP = &h101, _
     BASS_ATTRIB_MUSIC_PSCALER = &h102, BASS_ATTRIB_MUSIC_BPM = &h103, BASS_ATTRIB_MUSIC_SPEED = &h104, BASS_ATTRIB_MUSIC_VOL_GLOBAL = &h105, _
     BASS_ATTRIB_MUSIC_ACTIVE = &h106, BASS_ATTRIB_MUSIC_VOL_CHAN = &h200, BASS_ATTRIB_MUSIC_VOL_INST = &h300, BASS_MUSIC_PRESCAN = BASS_STREAM_PRESCAN


Type HSTREAM As DWORD
type HPLUGIN as DWORD
type HSAMPLE as DWORD
type HMUSIC as DWORD
Type QWORD As Longint

Type BASS_DEVICEINFO
   As Zstring Ptr name, driver
   As DWORD flags
End Type

Type BASS_CHANNELINFO
   as DWORD freq, chans, flags, ctype, origres
   as HPLUGIN plugin
   as HSAMPLE sample
   as Zstring Ptr filename
end type


Dim Shared BASS_Init As Function stdcall(Byval As Long, Byval As DWORD, Byval As DWORD, Byval As HWND, Byval As GUID Ptr) As BOOL
Dim Shared BASS_GetDeviceInfo As Function stdcall(As DWORD, As BASS_DEVICEINFO Ptr) As Integer
Dim Shared BASS_GetDevice As Function stdcall() As DWORD
Dim Shared BASS_Free As Function stdcall() As BOOL
Dim Shared BASS_Stop As Function stdcall() As BOOL
Dim Shared BASS_SetVolume As Function stdcall(Byval As Single) As BOOL
Dim Shared BASS_ErrorGetCode As Function stdcall() As Integer
Dim Shared BASS_StreamGetFilePosition As Function stdcall(Byval As HSTREAM, As DWORD) As QWORD
Dim Shared BASS_StreamCreateFile As Function stdcall(Byval As BOOL, Byval As Any Ptr, Byval As QWORD, Byval As QWORD, Byval As DWORD) As HSTREAM
Dim Shared BASS_StreamFree As Function stdcall(Byval As HSTREAM) As BOOL
Dim Shared BASS_ChannelPlay As Function stdcall(Byval As DWORD, Byval As BOOL) As BOOL
Dim Shared BASS_ChannelStop As Function stdcall(Byval As DWORD) As BOOL
Dim Shared BASS_ChannelPause As Function stdcall(Byval As DWORD) As BOOL
Dim Shared BASS_ChannelGetInfo As Function stdcall(Byval As DWORD, As BASS_CHANNELINFO) As BOOL
Dim Shared BASS_ChannelGetData As Function stdcall(Byval As DWORD, As any Ptr, As DWORD) As DWORD
Dim Shared BASS_ChannelGetLevel As Function stdcall(Byval As DWORD) As DWORD
Dim Shared BASS_ChannelGetPosition As Function stdcall(Byval As DWORD, Byval As DWORD) As DWORD
Dim Shared BASS_ChannelGetLength As Function stdcall(Byval As DWORD, Byval As DWORD) As QWORD
Dim Shared BASS_ChannelBytes2Seconds As Function stdcall(Byval As DWORD, Byval As QWORD) As Double
Dim Shared BASS_ChannelSetAttribute As Function stdcall(Byval As DWORD, Byval As DWORD, Byval as single) As BOOL
Dim Shared BASS_MusicLoad As Function stdcall(Byval As BOOL, Byval As Any Ptr, Byval As QWORD, Byval As DWORD, Byval As DWORD, Byval As DWORD) As HMUSIC
Dim Shared BASS_MusicFree As Function stdcall(Byval As HMUSIC) As BOOL

Dim Shared As Any Ptr _g__hLib_Bass = 0
Dim Shared As Boolean _g__bSound = True

Function _Bass_Startup(sFolderDLL as string = CurDir) As Boolean
   #Ifdef __Fb_64bit__
      ? "Loading Bass64.dll"
      If Fileexists(sFolderDLL & "\Bass64.dll") = 0 Then
         _g__bSound = False
         Return False
      Else
         _g__hLib_Bass = Dylibload(sFolderDLL & "\Bass64.dll")
      Endif
   #Else
      ? "Loading Bass.dll"
      If Fileexists(sFolderDLL & "\Bass.dll") = 0 Then
         _g__bSound = False
         Return False
      Else
         _g__hLib_Bass = Dylibload(sFolderDLL & "\Bass.dll")
      Endif
   #Endif
   BASS_Init = Dylibsymbol(_g__hLib_Bass, "BASS_Init")
   If BASS_Init = 0 Then Return False
   BASS_Free = Dylibsymbol(_g__hLib_Bass, "BASS_Free")
   If BASS_Free = 0 Then Return False
   BASS_StreamCreateFile = Dylibsymbol(_g__hLib_Bass, "BASS_StreamCreateFile")
   If BASS_StreamCreateFile = 0 Then Return False
   BASS_StreamFree = Dylibsymbol(_g__hLib_Bass, "BASS_StreamFree")
   If BASS_StreamFree = 0 Then Return False
   BASS_ChannelPlay = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelPlay")
   If BASS_ChannelPlay = 0 Then Return False
   BASS_ChannelStop = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelStop")
   If BASS_ChannelStop = 0 Then Return False
   BASS_Stop = Dylibsymbol(_g__hLib_Bass, "BASS_Stop")
   If BASS_Stop = 0 Then Return False
   BASS_SetVolume = Dylibsymbol(_g__hLib_Bass, "BASS_SetVolume")
   If BASS_SetVolume = 0 Then Return False
   BASS_ErrorGetCode = Dylibsymbol(_g__hLib_Bass, "BASS_ErrorGetCode")
   If BASS_ErrorGetCode = 0 Then Return False
   BASS_GetDeviceInfo = Dylibsymbol(_g__hLib_Bass, "BASS_GetDeviceInfo")
   If BASS_GetDeviceInfo = 0 Then Return False
   BASS_GetDevice = Dylibsymbol(_g__hLib_Bass, "BASS_GetDevice")
   If BASS_GetDevice = 0 Then Return False   
   BASS_StreamGetFilePosition = Dylibsymbol(_g__hLib_Bass, "BASS_StreamGetFilePosition")
   If BASS_StreamGetFilePosition = 0 Then Return False
   BASS_ChannelGetInfo = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelGetInfo")
   If BASS_ChannelGetInfo = 0 Then Return False
   BASS_ChannelGetData = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelGetData")
   If BASS_ChannelGetData = 0 Then Return False
   BASS_ChannelGetLevel = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelGetLevel")
   If BASS_ChannelGetLevel = 0 Then Return False
   BASS_ChannelGetPosition = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelGetPosition")
   If BASS_ChannelGetPosition = 0 Then Return False
   BASS_ChannelPause = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelPause")
   If BASS_ChannelPause = 0 Then Return False
   BASS_ChannelGetLength = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelGetLength")
   If BASS_ChannelGetLength = 0 Then Return False            
   BASS_ChannelBytes2Seconds = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelBytes2Seconds")
   If BASS_ChannelBytes2Seconds = 0 Then Return False
   BASS_ChannelSetAttribute = Dylibsymbol(_g__hLib_Bass, "BASS_ChannelSetAttribute")
   If BASS_ChannelSetAttribute = 0 Then Return False   
   BASS_MusicLoad = Dylibsymbol(_g__hLib_Bass, "BASS_MusicLoad")
   If BASS_MusicLoad = 0 Then Return False
   BASS_MusicFree = Dylibsymbol(_g__hLib_Bass, "BASS_MusicFree")
   If BASS_MusicFree = 0 Then Return False   
   Return True
End Function

Function _Bass_Shutdown() As Boolean
   If _g__hLib_Bass > 0 Then
      Dylibfree(_g__hLib_Bass)
      Return True
   End If
   Return False
 End Function


Function _BASS_ErrorGetCode() As String
   Select Case BASS_ErrorGetCode()
      Case 0 : Return "No Error."
      Case 1 : Return "There is insufficient memory."
      Case 2 : Return "The file could not be opened."
      Case 3 : Return "Cannot find a free sound driver."
      Case 4 : Return "The sample buffer was lost."
      Case 5 : Return "Invalid handle."
      Case 6 : Return "Unsupported sample format."
      Case 7 : Return "Invalid position."
      Case 8 : Return "BASS_Init has not been successfully called."
      Case 9 : Return "BASS_Start has not been successfully called."
      Case 10 : Return "SSL/HTTPS support is not available."
      Case 14 : Return "Already initialized/paused/whatever."
      Case 17 : Return "The file does not contain audio, or it also contains video and videos are disabled."
      Case 18 : Return "Cannot get a free channel."
      Case 19 : Return "An illegal type was specified."
      Case 20 : Return "An illegal parameter was specified."
      Case 21 : Return "Could not initialize 3D support."
      Case 22 : Return "No EAX support."
      Case 23 : Return "Illegal device number."
      Case 24 : Return "Not playing."
      Case 25 : Return "Illegal sample rate."
      Case 27 : Return "The stream is not a file stream."
      Case 29 : Return "No hardware voices available."
      Case 31 : Return "The Mod music has no sequence Data."
      Case 32 : Return "No internet connection could be opened."
      Case 33 : Return "Could not create the file."
      Case 34 : Return "Effects are not available."
      Case 37 : Return "Requested data is not available."
      Case 38 : Return "The channel is a decoding channel"
      Case 39 : Return "A sufficient DirectX version is not installed."
      Case 40 : Return "Connection timed out."
      Case 41 : Return "The file's format is not recognised/supported."
      Case 42 : Return "The specified SPEAKER flags are invalid."
      Case 43 : Return "The plugin requires a different BASS version."
      Case 44 : Return "Codec is not available/supported."
      Case 45 : Return "The channel/file has ended."
      Case 46 : Return "Something else has exclusive use of the device."
      Case 47 : Return "The file cannot be streamed using the buffered file system."
      Case -1 : Return "Some other mystery problem!"
   End Select
   Return "Hmmmm."
End Function

Function _Bass_Init(Device As DWORD = -1, Freq As Dword = 44100, Flags As Dword = 0, Win As HWND = Null, clsid As GUID Ptr = Null) As Boolean
   Return BASS_Init(Device, Freq, Flags, Win, clsid)
End Function

Function _Bass_Free() As Boolean
   Return BASS_Free()
End Function

Function _Bass_Stop() As Boolean
   Return BASS_Stop()
End Function
'Device-----------------------------------------------------------------------------------------------------------------------------------------
Function _BASS_GetDevice() As DWORD
   Return BASS_GetDevice()
End Function

Function _BASS_GetDeviceInfo(Device As DWORD, Info As BASS_DEVICEINFO Ptr) As Boolean
   Return BASS_GetDeviceInfo(Device, Info)
End Function
'Stream-----------------------------------------------------------------------------------------------------------------------------------------
Function _BASS_StreamFree(hStream As HSTREAM) As Boolean
   Return BASS_StreamFree(hStream)
End Function

Function _BASS_StreamCreateFile(File As String, Flags As Dword = 0, offset As QWORD = 0, Length As QWORD = 0, Mem As Boolean = False) As HSTREAM
   Return BASS_StreamCreateFile(Mem, StrPtr(File), offset, Length, Flags)
End Function

Function _BASS_StreamCreateMem(pMem As Any Ptr, Length As QWORD = 0, Flags As Dword = 0, offset As QWORD = 0, Mem As Boolean = True) As HSTREAM
   Return BASS_StreamCreateFile(Mem, pMem, offset, Length, Flags or BASS_UNICODE)
End Function

Function _BASS_SetVolume(Volume As Single) As Boolean
   Return BASS_SetVolume(Iif(Volume < 0, 0, Iif(Volume > 1.0, 1.0, Volume)))
End Function

Function _BASS_StreamGetFilePosition(hStream As HSTREAM, Mode As Dword) As QWORD
   Return BASS_StreamGetFilePosition(hStream, Mode)
End Function
'Music------------------------------------------------------------------------------------------------------------------------------------------
Function _BASS_MusicLoad(File As String, Flags As DWORD = 0, Freq as DWORD = 0, offset As QWORD = 0, Length As DWORD = 0, Mem As Boolean = False) As HMUSIC
   Return BASS_MusicLoad(Mem, StrPtr(File), offset, Length, Flags, Freq)
End Function

Function _BASS_MusicLoadMem(pMem As Any Ptr, Flags As DWORD = 0, Freq as DWORD = 0, offset As QWORD = 0, Length As DWORD = 0, Mem As Boolean = True) As HMUSIC
   Return BASS_MusicLoad(Mem, pMem, offset, Length, Flags, Freq)
End Function

Function _BASS_MusicFree(Handle as HMUSIC) as Boolean
   Return BASS_MusicFree(Handle)
end function
'Channel----------------------------------------------------------------------------------------------------------------------------------------
Function _BASS_ChannelPlay(Handle As DWORD, Restart As BOOL = False) As Boolean
   Return BASS_ChannelPlay(Handle, Restart)
End Function

Function _BASS_ChannelStop(Handle As DWORD) As Boolean
   Return BASS_ChannelStop(Handle)
End Function

Function _BASS_ChannelPause(Handle As DWORD) As Boolean
   Return BASS_ChannelPause(Handle)
End Function

Function _BASS_ChannelGetInfo(Handle as DWORD, ChanInfo as BASS_CHANNELINFO) as Boolean
   Return BASS_ChannelGetInfo(Handle, ChanInfo)
end function

Function _BASS_ChannelGetData(Handle as DWORD, Buffer as Any Ptr, Length as DWORD) as DWORD
   Return BASS_ChannelGetData(Handle, Buffer, Length)
end function

Function _BASS_ChannelGetLevel(Handle as DWORD) as DWORD
   Return BASS_ChannelGetLevel(Handle)
end function

Function _BASS_ChannelGetPosition(Handle as DWORD, Mode as DWORD) as QWORD
   Return BASS_ChannelGetPosition(Handle, Mode)
end function

Function _BASS_ChannelGetLength(Handle as DWORD, Mode as DWORD = BASS_POS_BYTE) as QWORD
   Return BASS_ChannelGetLength(Handle, Mode)
end function

Function _BASS_ChannelBytes2Seconds(Handle as DWORD, Position as QWORD) as Double
   Return BASS_ChannelBytes2Seconds(Handle, Position)
end function

Function _BASS_ChannelSetAttribute(Handle as DWORD, Attrib as DWORD, Value as Single) as BOOL
   Return BASS_ChannelSetAttribute(Handle, Attrib, Value)
end function

'-----------------------------------------------------------------------------------------------------------------------------------------------


Major Tom (lyric version).bas ;-)

Code: Select all

'Coded by UEZ build 2020-07-04
'Thanks to Joshy, Mario Klingemann and dodicat (see below)

#Include "fbgfx.bi"
#Include "Bass2.bi"

Using FB

Function ImageScale(s As Image Ptr, w As Integer, h As Integer) As 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 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

'Super Fast Blur v1.1 by Mario Klingemann <http://incubator.quasimondo.com>
Function SuperFastBlur(pImage As Any Pointer, iRadius As Ubyte, iW As Ushort, iH As Ushort) As Any Pointer '24-bit only
   Dim pImage_Blurred As Any Ptr = Imagecreate(iW, iH, 0, 32)

   Dim As Ulong Ptr pix_in = Cast(Ulong Ptr, pImage) + Sizeof(pImage) + Sizeof(Ulong)
   Dim As Ulong Ptr pix_out = Cast(Ulong Ptr, pImage_Blurred) + Sizeof(pImage_Blurred) + Sizeof(Ulong)
   /'
   pix = Cast(Ulong Ptr, Cast(Ubyte Ptr, imgData) + Sizeof(imgData) * Sizeof(Ulong) + Sizeof(Ulong) * Sizeof(Ulong))
   '/
   Dim As Long wm, hm, wh, divv, rsum, gsum, bsum, x, y, i, p, p1, p2, yp, yi, yw, iPitch = iW
   If (iW Mod 4) <> 0 Then iPitch = (iW \ 4) * 4 + 4

   wm = iW - 1
   hm = iH - 1
   wh = iW * iH
   divv = 2 * iRadius + 1

   Dim As Long vmin(0 To Max(iW, iH)), vmax(0 To Max(iW, iH)), dv(0 To 256 * divv), r(0 To wh), g(0 To wh), b(0 To wh)

   For i = 0 To 256 * divv - 1
      dv(i) = i \ divv
   Next

   yw = 0
   yi = 0
   
   For y = 0 To hm
      rsum = 0
      gsum = 0
      bsum = 0
      For i = -iRadius To iRadius
         p = pix_in[yw + Min(wm, Max(i, 0))]
         rsum += (p And &hFF0000) Shr 16
         gsum += (p And &h00FF00) Shr 8
         bsum += (p And &h0000FF)
      Next
      For x = 0 To wm
         r(yi) = dv(rsum)
         g(yi) = dv(gsum)
         b(yi) = dv(bsum)
         If y = 0 Then
            vmin(x) = Min(x + iRadius + 1, wm)
            vmax(x) = Max(x - iRadius,       0)
         End If
         p1 = pix_in[yw + vmin(x)]
         p2 = pix_in[yw + vmax(x)]
         rsum += ((p1 And &hFF0000) - (p2 And &hFF0000)) Shr 16
         gsum += ((p1 And &h00FF00) - (p2 And &h00FF00)) Shr 8
         bsum +=  (p1 And &h0000FF) - (p2 And &h0000FF)
         yi += 1
      Next
      yw += iPitch
   Next
   
   For x = 0 To wm
      rsum = 0
      gsum = 0
      bsum = 0
      yp = -iRadius * iW
      For i = -iRadius To iRadius
         yi = Max(0, yp) + x
         rsum += r(yi)
         gsum += g(yi)
         bsum += b(yi)
         yp += iW
      Next
      yi = x
      For y = 0 To hm
         pix_out[yi] = &hFF000000 Or dv(rsum) Shl 16 Or dv(gsum) Shl 8 Or dv(bsum)
         If x = 0 Then
            vmin(y) = Min(y + iRadius + 1, hm) * iW
            vmax(y) = Max(y - iRadius, 0) * iW
         End If
         p1 = x + vmin(y)
         p2 = x + vmax(y)

         rsum += r(p1) - r(p2)
         gsum += g(p1) - g(p2)
         bsum += b(p1) - b(p2)

         yi += iPitch
      Next
   Next
   Return pImage_Blurred
End Function

Function Regulate(TargetFPS 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 / TargetFPS) - t + timervalue) * 1000
   If sleeptime < 1 Then sleeptime = 1
   _lastsleeptime = sleeptime
   timervalue = t
   Return sleeptime
End Function


Dim As HSTREAM hStream
Dim As BOOL bBass = _Bass_Startup(), q = False
Dim pMem As Ubyte Ptr
Dim as QWORD iByteLen, iCurrentPos = 0

Dim As String aLyric(0 To ...) = {  "Ground Control to Major Tom", _
                           "Ground Control to Major Tom", _
                           "Take your protein pills and put your helmet on", _
                           "Ground Control to Major Tom (ten, nine, eight, seven, six)", _
                           "Commencing countdown, engines on (five, four, three)", _
                           "Check ignition and may God's love be with you (two, one, liftoff)", _
                           "This is Ground Control to Major Tom", _
                           "You've really made the grade", _
                           "And the papers want to know whose shirts you wear", _
                           "Now it's time to leave the capsule if you dare", _
                           "This is Major Tom to Ground Control", _
                           "I'm stepping through the door", _
                           "And I'm floating in a most peculiar way", _
                           "And the stars look very different today", _
                           "For here", _
                           "Am I sitting in a tin can", _
                           "Far above the world", _
                           "Planet Earth is blue", _
                           "And there's nothing I can do", _
                           "Though I'm past one hundred thousand miles", _
                           "I'm feeling very still", _
                           "And I think my spaceship knows which way to go", _
                           "Tell my wife I love her very much she knows", _
                           "Ground Control to Major Tom", _
                           "Your circuit's dead, there's something wrong", _
                           "Can you hear me, Major Tom?", _
                           "Can you hear me, Major Tom?", _
                           "Can you hear me, Major Tom?", _
                           "Can you Here am I floating 'round my tin can", _
                           "Far above the moon", _
                           "Planet Earth is blue", _
                           "And there's nothing I can do"}
                           
Dim As Single aLyricTimes(0 To ..., 0 To 1) = {{26, 29.5}, {33, 36.5}, {40, 45.5}, {47.5, 51}, {55, 58}, {61.5, 69}, {79, 83}, {84, 88}, {89, 94}, {96, 101}, {104, 108}, {109, 112}, {114, 119}, {121, 127}, {128, 130}, _
                                    {131, 134}, {136, 141}, {143, 145}, {145, 149}, {179, 183}, {184, 187}, {189, 194}, {196, 201}, {203, 206}, {206, 210}, {210, 213}, {213, 216}, {217, 219}, {220.5, 227}, _
                                    {228, 232}, {235, 237}, {237, 242}}
If bBass = True Then
   Dim As String SOUNDFILE = "ground control to major tom.mp3"

   Dim As QWORD iSize = Filelen(SOUNDFILE)
   If iSize > 0 Then
      pMem = Allocate(iSize)

      Dim As Integer hFile = Freefile()
      Open SOUNDFILE For Binary Access Read As #hFile
      Get #hFile, 0, pMem[0], iSize
      Close #hFile
      _Bass_Init(-1, 44100)
      hStream = _BASS_StreamCreateMem(pMem, iSize, BASS_STREAM_PRESCAN)
      '_BASS_ChannelSetAttribute(hStream, BASS_ATTRIB_VOL, 0.33)
      _BASS_ChannelPlay(hStream)
      iByteLen = _BASS_ChannelGetLength(hStream)
   Else
      _Bass_Shutdown()
      bBass = False
   End If
End If

Const w = 1000, h = 600, w2 = w \ 2, h2 = h \ 2

Dim As Single s = 0.025, scale1 = 1 + s, scale2 = 1 - s, px1, px2, py1, py2, r = 250, pi = Acos(-1), rad = pi / 180, angle = Rnd() * 100, x, y, xx, yy, f1, f2, k = 0
Dim As Ushort ws = w * scale1, hs = h * scale1
Dim As String sTxt = "Coded by UEZ"

Screenres w, h, 32, , GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES
Windowtitle("Smoky Zoom Effect (lyric version) by UEZ")

Dim As Any Ptr pImage1, pImage2, pImage3

Dim As Ubyte c

pImage1 = Imagecreate(w, h, &h00000000, 32)

Randomize

Dim As Ulong iFPS_current = 0, cl = 0
Dim As Single fTimer = Timer, t = aLyricTimes(0, 0)

While Len(Inkey()) = 0
   Screenlock
   
   f1 = angle * rad
   f2 = (180 + angle) * rad
   px1 = w2 + Sin(f1) * r
   py1 = h2 + Cos(f1) * r
   px2 = w2 + Sin(f2) * r
   py2 = h2 + Cos(f2) * r
   c = k Mod 256
   
   Line pImage1, (px1, py1)-(px2, py2), Rgba(c, c, c, &hA0)
   
   x = w2 + Cos((px2 - angle) / 50) * 150 - 50
   y = h2 + Sin((py2 + angle) / 30) * 50
   Draw String pImage1, (x, y), sTxt, Rgba(255, (255 - angle) Mod 256, c, &hC0)
   
   pImage2 = ImageScale(pImage1, ws, hs)
   pImage3 = SuperFastBlur(pImage2, 2, ws, hs)
   
   Put pImage1, ((w - ws) / 2, (h - hs) / 2), pImage3, (0, 0)-(ws, hs), Trans
   
   Draw String pImage1, (x, y), sTxt, Rgba(255, 255, 255, &h80)
   
   If q = False Then
      xx = Rnd * (w - Len(aLyric(cl)) * 10)
      yy = h * 0.2 + Rnd * (h * 0.6)
   End If
   If Timer - fTimer > t Then
      q = True
      Draw String pImage1, (xx, yy), aLyric(cl), Rgba(255, 255, 255, &h30)
      If Timer - fTimer > aLyricTimes(cl, 1) Then
         cl += 1
         t = aLyricTimes(cl, 0)
         If cl > Ubound(aLyric) Then cl = 0
         q = False
      End If
   End If
   
   Imagedestroy(pImage2)
   Imagedestroy(pImage3)
   
   Put (0, 0), pImage1, PSet
   
   Draw String(2, 2), iFPS_current & " fps", Rgba(&hFF, &hFF, &hFF, &hB0)
   
   angle += 0.9
   k += 0.5
   
   Screenunlock
      
   Sleep(Regulate(30, iFPS_current))
   
   If bBass Then
      iCurrentPos = _BASS_ChannelGetPosition(hStream, BASS_POS_BYTE)
      If iCurrentPos > iByteLen * 0.975 Then Exit While
   end if
      
Wend

Imagedestroy(pImage1)

If bBass Then
   _BASS_ChannelStop(hStream)
   _BASS_StreamFree(hStream)
   _Bass_Free()
   _Bass_Shutdown()
   Deallocate(pMem)
End If


Edit: added lyric version

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 6 guests