## Smoky Zoom Effect

UEZ
Posts: 614
Joined: May 05, 2017 19:59
Location: Germany

### Smoky Zoom Effect

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 tEnd 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_BlurredEnd FunctionFunction 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 sleeptimeEnd FunctionConst w = 800, h = 500, w2 = w \ 2, h2 = h \ 2Dim 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 = 0Dim As Ushort ws = w * scale1, hs = h * scale1Dim As String sTxt = "Coded by UEZ"Screenres w, h, 32, , GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVESWindowtitle("Smoky Zoom Effect by UEZ")Dim As Any Ptr pImage1, pImage2, pImage3Dim As Ubyte cpImage1 = Imagecreate(w, h, &h00000000, 32)Dim As Ulong iFPS_current = 0Do   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: For the lyric version see 5 posts below.
Last edited by UEZ on Jul 04, 2020 11:54, edited 3 times in total.
deltarho
Posts: 2583
Joined: Jan 02, 2017 0:34
Location: UK

### Re: Smoky Zoom Effect

More awesome graphics from the UEZ stable. gcc32 -O2 29fps
gcc64 -O2 58fps
gas64 29fps

Visuallly, for me, I prefer 29fps.

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

### Re: Smoky Zoom Effect

deltarho wrote:More awesome graphics from the UEZ stable. 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.
Posts: 2129
Joined: May 24, 2007 22:10
Location: The Netherlands

### Re: Smoky Zoom Effect

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: 6648
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Smoky Zoom Effect

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: 614
Joined: May 05, 2017 19:59
Location: Germany

### Re: Smoky Zoom Effect

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!

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_PRESCANType HSTREAM As DWORDtype HPLUGIN as DWORDtype HSAMPLE as DWORDtype HMUSIC as DWORDType QWORD As LongintType BASS_DEVICEINFO   As Zstring Ptr name, driver   As DWORD flagsEnd TypeType BASS_CHANNELINFO   as DWORD freq, chans, flags, ctype, origres   as HPLUGIN plugin   as HSAMPLE sample   as Zstring Ptr filenameend typeDim Shared BASS_Init As Function stdcall(Byval As Long, Byval As DWORD, Byval As DWORD, Byval As HWND, Byval As GUID Ptr) As BOOLDim Shared BASS_GetDeviceInfo As Function stdcall(As DWORD, As BASS_DEVICEINFO Ptr) As IntegerDim Shared BASS_GetDevice As Function stdcall() As DWORDDim Shared BASS_Free As Function stdcall() As BOOLDim Shared BASS_Stop As Function stdcall() As BOOLDim Shared BASS_SetVolume As Function stdcall(Byval As Single) As BOOLDim Shared BASS_ErrorGetCode As Function stdcall() As IntegerDim Shared BASS_StreamGetFilePosition As Function stdcall(Byval As HSTREAM, As DWORD) As QWORDDim Shared BASS_StreamCreateFile As Function stdcall(Byval As BOOL, Byval As Any Ptr, Byval As QWORD, Byval As QWORD, Byval As DWORD) As HSTREAMDim Shared BASS_StreamFree As Function stdcall(Byval As HSTREAM) As BOOLDim Shared BASS_ChannelPlay As Function stdcall(Byval As DWORD, Byval As BOOL) As BOOLDim Shared BASS_ChannelStop As Function stdcall(Byval As DWORD) As BOOLDim Shared BASS_ChannelPause As Function stdcall(Byval As DWORD) As BOOLDim Shared BASS_ChannelGetInfo As Function stdcall(Byval As DWORD, As BASS_CHANNELINFO) As BOOLDim Shared BASS_ChannelGetData As Function stdcall(Byval As DWORD, As any Ptr, As DWORD) As DWORDDim Shared BASS_ChannelGetLevel As Function stdcall(Byval As DWORD) As DWORDDim Shared BASS_ChannelGetPosition As Function stdcall(Byval As DWORD, Byval As DWORD) As DWORDDim Shared BASS_ChannelGetLength As Function stdcall(Byval As DWORD, Byval As DWORD) As QWORDDim Shared BASS_ChannelBytes2Seconds As Function stdcall(Byval As DWORD, Byval As QWORD) As DoubleDim Shared BASS_ChannelSetAttribute As Function stdcall(Byval As DWORD, Byval As DWORD, Byval as single) As BOOLDim 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 HMUSICDim Shared BASS_MusicFree As Function stdcall(Byval As HMUSIC) As BOOLDim Shared As Any Ptr _g__hLib_Bass = 0Dim Shared As Boolean _g__bSound = TrueFunction _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 TrueEnd FunctionFunction _Bass_Shutdown() As Boolean   If _g__hLib_Bass > 0 Then       Dylibfree(_g__hLib_Bass)      Return True   End If   Return False End FunctionFunction _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 FunctionFunction _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 FunctionFunction _Bass_Free() As Boolean   Return BASS_Free()End FunctionFunction _Bass_Stop() As Boolean   Return BASS_Stop()End Function'Device-----------------------------------------------------------------------------------------------------------------------------------------Function _BASS_GetDevice() As DWORD   Return BASS_GetDevice()End FunctionFunction _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 FunctionFunction _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 FunctionFunction _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 FunctionFunction _BASS_SetVolume(Volume As Single) As Boolean   Return BASS_SetVolume(Iif(Volume < 0, 0, Iif(Volume > 1.0, 1.0, Volume)))End FunctionFunction _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 FunctionFunction _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 FunctionFunction _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 FunctionFunction _BASS_ChannelStop(Handle As DWORD) As Boolean   Return BASS_ChannelStop(Handle)End FunctionFunction _BASS_ChannelPause(Handle As DWORD) As Boolean   Return BASS_ChannelPause(Handle)End FunctionFunction _BASS_ChannelGetInfo(Handle as DWORD, ChanInfo as BASS_CHANNELINFO) as Boolean   Return BASS_ChannelGetInfo(Handle, ChanInfo)end functionFunction _BASS_ChannelGetData(Handle as DWORD, Buffer as Any Ptr, Length as DWORD) as DWORD   Return BASS_ChannelGetData(Handle, Buffer, Length)end functionFunction _BASS_ChannelGetLevel(Handle as DWORD) as DWORD   Return BASS_ChannelGetLevel(Handle) end functionFunction _BASS_ChannelGetPosition(Handle as DWORD, Mode as DWORD) as QWORD   Return BASS_ChannelGetPosition(Handle, Mode) end functionFunction _BASS_ChannelGetLength(Handle as DWORD, Mode as DWORD = BASS_POS_BYTE) as QWORD   Return BASS_ChannelGetLength(Handle, Mode) end functionFunction _BASS_ChannelBytes2Seconds(Handle as DWORD, Position as QWORD) as Double   Return BASS_ChannelBytes2Seconds(Handle, Position) end functionFunction _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 FBFunction 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 tEnd 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_BlurredEnd FunctionFunction 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 sleeptimeEnd FunctionDim As HSTREAM hStreamDim As BOOL bBass = _Bass_Startup(), q = FalseDim pMem As Ubyte PtrDim as QWORD iByteLen, iCurrentPos = 0Dim 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, 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 IfEnd IfConst w = 1000, h = 600, w2 = w \ 2, h2 = h \ 2Dim 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 = 0Dim As Ushort ws = w * scale1, hs = h * scale1Dim As String sTxt = "Coded by UEZ"Screenres w, h, 32, , GFX_WINDOWED Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVESWindowtitle("Smoky Zoom Effect (lyric version) by UEZ")Dim As Any Ptr pImage1, pImage2, pImage3Dim As Ubyte cpImage1 = Imagecreate(w, h, &h00000000, 32)RandomizeDim As Ulong iFPS_current = 0, cl = 0Dim 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      WendImagedestroy(pImage1)If bBass Then   _BASS_ChannelStop(hStream)   _BASS_StreamFree(hStream)   _Bass_Free()   _Bass_Shutdown()   Deallocate(pMem)End If`