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
