editor/bass-sys/win/bass24/delphi/spectrum/Unit1.pas
2021-01-07 21:37:50 -06:00

555 lines
15 KiB
ObjectPascal

// BASS spectrum analyser example, copyright (c) 2002-2006 Ian Luck.
//
// C++ to Delphi adapted by Evgeny Melnikov
//
// http://dsoft1961.narod.ru
// mail angvelem@gmail.com
unit Unit1;
{$I Common.inc}
{$IFDEF D7}
{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}
interface
uses
Windows, Messages, CommDlg, MMSystem, Bass;
const
SPECWIDTH = 368; // display width
SPECHEIGHT = 127; // height (changing requires palette adjustments too)
BANDS = 28;
szAppName = 'BASS-Spectrum';
BASSErCodes : array[-1..44] of String = (
'Some other mystery error',
'All is OK',
'Memory error',
'Can''t open the file',
'Can''t find a free sound driver',
'The sample buffer was lost',
'Invalid handle',
'Unsupported sample format',
'Invalid playback position',
'BASS_Init has not been successfully called',
'BASS_Start has not been successfully called',
'Unknown error',
'Unknown error',
'Unknown error',
'Unknown error',
'Already initialized/paused/whatever',
'Unknown error',
'Not paused',
'Unknown error',
'Can''t get a free channel',
'An illegal type was specified',
'An illegal parameter was specified',
'No 3D support',
'No EAX support',
'Illegal device number',
'Not playing',
'Illegal sample rate',
'Unknown error',
'The stream is not a file stream',
'Unknown error',
'No hardware voices available',
'Unknown error',
'The MOD music has no sequence data',
'No internet connection could be opened',
'Couldn''t create the file',
'Effects are not enabled',
'The channel is playing',
'Unknown error',
'Requested data is not available',
'The channel is a "decoding channel"',
'A sufficient DirectX version is not installed',
'Connection timedout',
'Unsupported file format',
'Unavailable speaker',
'Invalid BASS version (used by add-ons)',
'Codec is not available/supported');
var
Window : HWND = 0;
Msg : TMsg;
WndClass : TWndClassEX;
PosX, PosY : Integer;
SizeX, SizeY : Integer;
Timer : DWORD = 0;
Chan : DWORD;
SpecDC : HDC = 0;
SpecBmp : HBITMAP = 0;
SpecBuf : Pointer;
SpecMode : Integer = 0;
SpecPos : Integer = 0; // spectrum mode (and marker pos for 2nd mode)
BI : TBITMAPINFO;
pal : array[Byte] of TRGBQUAD;
procedure WinMain;
implementation
var
Win32Platform : Integer = 0;
Win32MajorVersion : Integer = 0;
Win32MinorVersion : Integer = 0;
Win32BuildNumber : Integer = 0;
Win32CSDVersion : string = '';
//---------------------------------------------------------
function IntPower(const Base: Extended; const Exponent: Integer): Extended;
asm
mov ecx, eax
cdq
fld1 { Result := 1 }
xor eax, edx
sub eax, edx { eax := Abs(Exponent) }
jz @@3
fld Base
jmp @@2
@@1: fmul ST, ST { X := Base * Base }
@@2: shr eax,1
jnc @@1
fmul ST(1),ST { Result := Result * X }
jnz @@1
fstp st { pop X from FPU stack }
cmp ecx, 0
jge @@3
fld1
fdivrp { Result := 1 / Result }
@@3:
fwait
end;
//---------------------------------------------------------
function Power(const Base, Exponent: Extended): Extended;
begin
if Exponent = 0.0 then
Result := 1.0 { n**0 = 1 }
else if (Base = 0.0) and (Exponent > 0.0) then
Result := 0.0 { 0**n = 0, n > 0 }
else if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then
Result := IntPower(Base, Integer(Trunc(Exponent)))
else
Result := Exp(Exponent * Ln(Base))
end;
//---------------------------------------------------------
// Log.10(X) := Log.2(X) * Log.10(2)
function Log10(const X : Extended) : Extended;
asm
FLDLG2 { Log base ten of 2 }
FLD X
FYL2X
FWAIT
end;
//---------------------------------------------------------
function IntToStr(I : Integer) : String;
begin
Str(I, Result);
end;
//---------------------------------------------------------
procedure GetOSInfo;
var
OSVersionInfo : TOSVersionInfo;
begin
OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);
if GetVersionEx(OSVersionInfo) then
with OSVersionInfo do
begin
Win32Platform := dwPlatformId;
Win32MajorVersion := dwMajorVersion;
Win32MinorVersion := dwMinorVersion;
Win32BuildNumber := dwBuildNumber;
Win32CSDVersion := szCSDVersion;
end;
end;
//---------------------------------------------------------
// display error messages
procedure Error(St : String);
var
ErrCode : Integer;
Mes : String;
begin
ErrCode := BASS_ErrorGetCode;
if ErrCode > 44 then
ErrCode := 10;
Mes := St + #13#10 + BASSErCodes[ErrCode] + #13#10 + '(Error code: ' + IntToStr(ErrCode) + ')';
MessageBox(0, PChar(Mes), '', MB_ICONERROR or MB_OK);
end;
//---------------------------------------------------------
// select a file to play, and play it
function PlayFile(Wnd : HWND) : Boolean;
var
FileName : array[0..MAX_PATH - 1] of Char;
ofn : TOPENFILENAME;
TempFileName : String;
begin
Result := False;
FillChar(ofn, SizeOf(ofn), 0);
FillChar(FileName, SizeOf(FileName), 0);
{$IFDEF D7}
if (Win32MajorVersion >= 5) and (Win32Platform = VER_PLATFORM_WIN32_NT) or { Win2k }
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and (Win32MajorVersion >= 4) and (Win32MinorVersion >= 90)) then { WinME }
ofn.lStructSize := SizeOf(TOpenFilename)
else
ofn.lStructSize := SizeOf(TOpenFilename) - (SizeOf(DWORD) shl 1) - SizeOf(Pointer); { subtract size of added fields }
{$ELSE}
ofn.lStructSize := SizeOf(TOpenFilename);
{$ENDIF}
ofn.hwndOwner := Window;
ofn.hInstance := hInstance;
ofn.lpstrTitle := 'Select a file to play';
ofn.lpstrFile := FileName;
ofn.lpstrFilter := 'playable files'#0'*.mo3;*.xm;*.mod;*.s3m;*.it;*.mtm;*.umx;*.mp3;*.mp2;*.mp1;*.ogg;*.wav;*.aif'#0'All files'#0'*.*'#0#0;
ofn.nMaxFile := MAX_PATH;
ofn.Flags := OFN_FILEMUSTEXIST or OFN_HIDEREADONLY or OFN_EXPLORER;
if not GetOpenFileName(ofn) then
Exit;
TempFileName := FileName;
chan := BASS_StreamCreateFile(False, PChar(TempFileName), 0, 0, BASS_SAMPLE_LOOP {$IFDEF UNICODE} or BASS_UNICODE {$ENDIF});
if (chan = 0) then
begin
chan := BASS_MusicLoad(False, PChar(TempFileName), 0, 0, BASS_MUSIC_RAMP or BASS_SAMPLE_LOOP {$IFDEF UNICODE} or BASS_UNICODE {$ENDIF}, 1);
if (chan = 0) then
begin
Error('Can''t play file'); // Can't load the file
Exit;
end;
end;
BASS_ChannelPlay(chan, False);
Result := True;
end;
//---------------------------------------------------------
// update the spectrum display - the interesting bit :)
procedure UpdateSpectrum(uTimerID, uMsg, dwUser, dw1, dw2 : Integer); stdcall;
type
TSingleArray = array of Single;
var
DC : HDC;
X, Y, Z,
I, J, sc : Integer;
Sum : Single;
fft : array[0..1023] of Single; // get the FFT data
ci : BASS_CHANNELINFO;
Buf : TSingleArray;
begin
if SpecMode = 3 then // waveform
begin
FillChar(SpecBuf^, SPECWIDTH * SPECHEIGHT, 0);
BASS_ChannelGetInfo(chan, ci); // get number of channels
SetLength(Buf, ci.chans * SPECWIDTH);
Y := 0;
BASS_ChannelGetData(chan, buf, (ci.chans * SPECWIDTH * SizeOf(Single)) or BASS_DATA_FLOAT); // get the sample data (floating-point to avoid 8 & 16 bit processing)
for I := 0 to ci.chans - 1 do
begin
for X := 0 to SPECWIDTH - 1 do
begin
Z := Trunc((1 - Buf[X * Integer(ci.chans) + I]) * SPECHEIGHT / 2); // invert and scale to fit display
if Z < 0 then
Z := 0
else if Z >= SPECHEIGHT then
Z := SPECHEIGHT - 1;
if X = 0 then
Y := Z;
repeat // draw line from previous sample...
if Y < Z then
inc(Y)
else if Y > Z then
dec(Y);
if (I and 1) = 1 then
Byte(Pointer(Longint(SpecBuf) + Y * SPECWIDTH + X)^) := 127
else
Byte(Pointer(Longint(SpecBuf) + Y * SPECWIDTH + X)^) := 1;
until Y = Z;
end;
end;
end
else
begin
BASS_ChannelGetData(chan, @fft, BASS_DATA_FFT2048);
case SpecMode of
0 : // "normal" FFT
begin
FillChar(SpecBuf^, SPECWIDTH * SPECHEIGHT, 0);
Z := 0;
for X := 0 to pred(SPECWIDTH) div 2 do
begin
Y := Trunc(sqrt(fft[X + 1]) * 3 * SPECHEIGHT - 4); // scale it (sqrt to make low values more visible)
// Y := Trunc(fft[X + 1] * 10 * SPECHEIGHT); // scale it (linearly)
if Y > SPECHEIGHT then
Y := SPECHEIGHT; // cap it
if (X > 0) and (Z = (Y + Z) div 2) then // interpolate from previous to make the display smoother
while (Z >= 0) do
begin
Byte(Pointer(Longint(SpecBuf) + Z * SPECWIDTH + X * 2 - 1)^) := Z + 1;
dec(Z);
end;
Z := Y;
while (Y >= 0) do
begin
Byte(Pointer(Longint(SpecBuf) + Y * SPECWIDTH + X * 2)^) := Y + 1; // draw level
dec(Y);
end;
end;
end;
1 : // logarithmic, acumulate & average bins
begin
I := 0;
FillChar(SpecBuf^, SPECWIDTH * SPECHEIGHT, 0);
for X := 0 to BANDS - 1 do
begin
Sum := 0;
J := Trunc(Power(2, X * 10.0 / (BANDS - 1)));
if J > 1023 then
J := 1023;
if J <= I then
J := I + 1; // make sure it uses at least 1 FFT bin
sc := 10 + J - I;
while I < J do
begin
Sum := Sum + fft[1 + I];
inc(I);
end;
Y := Trunc((sqrt(Sum / log10(sc)) * 1.7 * SPECHEIGHT) - 4); // scale it
if Y > SPECHEIGHT then
Y := SPECHEIGHT; // cap it
while (Y >= 0) do
begin
FillChar(Pointer(Longint(SpecBuf) + Y * SPECWIDTH + X * (SPECWIDTH div BANDS))^, SPECWIDTH div BANDS - 2, Y + 1); // draw bar
dec(Y);
end;
end;
end;
2 : // "3D"
begin
for X := 0 to SPECHEIGHT - 1 do
begin
Y := Trunc(sqrt(fft[x + 1]) * 3 * 127); // scale it (sqrt to make low values more visible)
if Y > 127 then
Y := 127; // cap it
Byte(Pointer(Longint(SpecBuf) + X * SPECWIDTH + SpecPos)^) := 128 + Y; // plot it
end;
// move marker onto next position
SpecPos := (SpecPos + 1) mod SPECWIDTH;
for X := 0 to SPECHEIGHT do
Byte(Pointer(Longint(SpecBuf) + X * SPECWIDTH + SpecPos)^) := 255;
end;
end;
end;
// update the display
DC := GetDC(Window);
try
BitBlt(DC, 0, 0, SPECWIDTH, SPECHEIGHT, SpecDC, 0, 0, SRCCOPY);
finally
ReleaseDC(Window, DC);
end;
end;
//---------------------------------------------------------
// window procedure
function SpectrumWindowProc(Wnd : HWND; Msg : Integer; wParam, lParam : Longint): Integer; stdcall;
var
Ps : TPAINTSTRUCT;
DC : HDC;
I : Integer;
begin
Result := 0;
case Msg of
WM_CREATE :
begin
GetOSInfo;
// initialize BASS
if not BASS_Init(-1, 44100, 0, Wnd, NIL) then
begin
Error('Can''t initialize device');
Result := -1;
Exit;
end;
if not PlayFile(Wnd) then // start a file playing
begin
BASS_Free;
Result := -1;
Exit;
end;
// create bitmap to draw spectrum in - 8 bit for easy updating :)
FillChar(BI, SizeOf(BI), 0);
with BI.bmiHeader do // fill structure with parameter bitmap
begin
biSize := SizeOf(BI.bmiHeader);
biWidth := SPECWIDTH;
biHeight := SPECHEIGHT; // upside down (line 0=bottom)
biPlanes := 1;
biBitCount := 8;
biClrImportant := 256;
biClrUsed := 256;
end;
// setup palette
for I := 0 to 127 do
begin
pal[I].rgbGreen := 255 - 2 * I;
pal[I].rgbRed := 2 * I;
end;
for I := 0 to 31 do
begin
pal[128 + I].rgbBlue := 8 * I;
pal[128 + 32 + I].rgbBlue := 255;
pal[128 + 32 + I].rgbRed := 8 * I;
pal[128 + 64 + I].rgbRed := 255;
pal[128 + 64 + I].rgbBlue := 8 * (31 - I);
pal[128 + 64 + I].rgbGreen := 8 * I;
pal[128 + 96 + I].rgbRed := 255;
pal[128 + 96 + I].rgbGreen := 255;
pal[128 + 96 + I].rgbBlue := 8 * I;
end;
// create the bitmap
SpecBmp := CreateDIBSection(0, BI, DIB_RGB_COLORS, SpecBuf, 0, 0);
SpecDC := CreateCompatibleDC(0);
SelectObject(SpecDC, SpecBmp);
// setup update timer (40hz)
timer := timeSetEvent(25, 25, @UpdateSpectrum, 0, TIME_PERIODIC);
end;
WM_PAINT :
if GetUpdateRect(Wnd, PRect(NIL)^, False) then
begin
DC := BeginPaint(Wnd, Ps);
if DC = 0 then
begin
Result := 0;
Exit;
end;
BitBlt(DC, 0, 0, SPECWIDTH, SPECHEIGHT, SpecDC, 0, 0, SRCCOPY);
EndPaint(Wnd, Ps);
Result := 0;
Exit;
end;
WM_LBUTTONUP :
begin
SpecMode := (SpecMode + 1) mod 4; // swap spectrum mode
if SpecMode = 2 then
SpecPos := 0;
FillChar(SpecBuf^, SPECWIDTH * SPECHEIGHT, 0); // clear display
Result := 0;
Exit;
end;
WM_CLOSE :
begin
DestroyWindow(Wnd);
end;
WM_DESTROY :
begin
if timer <> 0 then
timeKillEvent(timer);
BASS_Free;
if SpecDC <> 0 then
DeleteDC(SpecDC);
if SpecBmp <> 0 then
DeleteObject(specbmp);
PostQuitMessage(0);
Exit;
end;
end;
Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
//---------------------------------------------------------
procedure WinMain;
begin
Window := FindWindow(szAppName, NIL);
if Window <> 0 then
begin
if IsIconic(Window) then
ShowWindow(Window, SW_RESTORE);
SetForegroundWindow(Window);
Halt(254);
end;
// check the correct BASS was loaded
if HIWORD(BASS_GetVersion) <> BASSVERSION then
begin
MessageBox(0, 'An incorrect version of BASS.DLL was loaded', '', MB_ICONERROR);
Exit;
end;
// register window class and create the window
FillChar(WndClass, SizeOf(TWndClassEx), 0);
WndClass.cbSize := SizeOf(TWndClassEx);
WndClass.style := CS_HREDRAW or CS_VREDRAW;
WndClass.lpfnWndProc := @SpectrumWindowProc;
WndClass.cbClsExtra := 0;
WndClass.cbWndExtra := 0;
WndClass.hInstance := hInstance;
WndClass.hCursor := LoadCursor(0, IDC_ARROW);
WndClass.hbrBackGround := GetSysColorBrush(COLOR_BTNFACE);
WndClass.lpszClassName := szAppName;
if RegisterClassEx(WndClass) = 0 then
Halt(255);
SizeX := SPECWIDTH + 2 * GetSystemMetrics(SM_CXDLGFRAME);
SizeY := SPECHEIGHT + 2 * GetSystemMetrics(SM_CYDLGFRAME) + GetSystemMetrics(SM_CYCAPTION);
PosX := (GetSystemMetrics(SM_CXSCREEN) - SizeX) div 2;
PosY := (GetSystemMetrics(SM_CYSCREEN) - SizeY) div 2;
Window := CreateWindowEx(0, szAppName, 'BASS spectrum example (click to toggle mode)',
WS_POPUPWINDOW or WS_CAPTION,
PosX, PosY, SizeX, SizeY, 0, 0, hInstance, NIL);
ShowWindow(Window, SW_SHOWNORMAL);
while (GetMessage(Msg, 0, 0, 0)) do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
Halt(Msg.wParam);
end;
begin
WinMain;
end.