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

356 lines
9.7 KiB
ObjectPascal

unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Math, StdCtrls, Bass, ExtCtrls;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
Timer1: TTimer;
PB: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure PBPaint(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
function PlayFile: boolean;
procedure ErrorPop(str: string);
procedure SetLoopStart(position: qword);
procedure SetLoopEnd(position: qword);
procedure ScanPeaks2(decoder: HSTREAM);
procedure DrawSpectrum;
procedure DrawTime_Line(position: QWORD; y : integer; cl : TColor);
public
end;
type TScanThread = class(TThread)
private
Fdecoder : HSTREAM;
protected
procedure Execute; override;
public
constructor Create(decoder:HSTREAM);
end;
procedure LoopSyncProc(handle: HSYNC; channel, data: DWORD; user: Pointer); stdcall;
var
Form1: TForm1;
lsync : HSYNC; // looping synchronizer handle
chan : HSTREAM; // sample stream handle
chan2: HSTREAM;
loop : array[0..1] of DWORD;
killscan : boolean;
bpp : dword; // stream bytes per pixel
wavebufL : array of smallint;
wavebufR : array of smallint;
mousedwn : integer;
Buffer: TBitmap;
implementation
{$R *.dfm}
//------------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
// check the correct BASS was loaded
if (HIWORD(BASS_GetVersion) <> BASSVERSION) then
begin
MessageBox(0,'An incorrect version of BASS.DLL was loaded', nil, MB_ICONERROR);
Halt;
end;
//assigning layout properties
ClientHeight := 201;
ClientWidth := 600;
Top := 100;
Left := 100;
Buffer := TBitmap.Create;
Buffer.Width:= PB.Width;
Buffer.Height:= PB.Height;
PB.Parent.DoubleBuffered := true;
//set array size
setlength(wavebufL,ClientWidth);
setlength(wavebufR,ClientWidth);
//init vars
loop[0] := 0;
loop[1] := 0;
//init BASS
if not BASS_Init(-1,44100,0,Application.Handle,nil) then
ErrorPop('Can''t initialize device');
//init timer for updating
Timer1.Interval := 20; //ms
Timer1.Enabled := true;
//main start play function
if not PlayFile then
begin
BASS_Free();
Application.Terminate;
end;
end;
function TForm1.PlayFile : boolean;
var
filename : string;
data : array[0..2000] of SmallInt;
i : integer;
begin
result := false;
if OpenDialog1.Execute then
begin
filename := OpenDialog1.Filename;
BringWindowToTop(Form1.Handle);
SetForegroundWindow(Form1.Handle);
//creating stream
chan := BASS_StreamCreateFile(FALSE,pchar(filename),0,0,0 {$IFDEF UNICODE} or BASS_UNICODE {$ENDIF});
if chan = 0 then
begin
chan := BASS_MusicLoad(False, pchar(filename), 0, 0, BASS_MUSIC_RAMPS or BASS_MUSIC_POSRESET or BASS_MUSIC_PRESCAN {$IFDEF UNICODE} or BASS_UNICODE {$ENDIF}, 1);
if (chan = 0) then
begin
ErrorPop('Can''t play file');
Exit;
end;
end;
//playing stream and setting global vars
for i:=0 to length(data)-1 do data[0] := 0;
bpp := BASS_ChannelGetLength(chan,BASS_POS_BYTE) div ClientWidth; // stream bytes per pixel
if (bpp < BASS_ChannelSeconds2Bytes(chan,0.02)) then // minimum 20ms per pixel (BASS_ChannelGetLevel scans 20ms)
bpp := BASS_ChannelSeconds2Bytes(chan,0.02);
BASS_ChannelSetSync(chan,BASS_SYNC_END or BASS_SYNC_MIXTIME,0,LoopSyncProc, nil); // set sync to loop at end
BASS_ChannelPlay(chan,FALSE); // start playing
//getting peak levels in seperate thread, stream handle as parameter
chan2 := BASS_StreamCreateFile(FALSE,pchar(filename),0,0,BASS_STREAM_DECODE {$IFDEF UNICODE} or BASS_UNICODE {$ENDIF});
if (chan2 = 0) then chan2 := BASS_MusicLoad(FALSE,pchar(filename),0,0,BASS_MUSIC_DECODE {$IFDEF UNICODE} or BASS_UNICODE {$ENDIF},1);
TScanThread.Create(chan2); // start scanning peaks in a new thread
result := true;
end;
end;
procedure TForm1.DrawSpectrum;
var
i,ht : integer;
begin
//clear background
Buffer.Canvas.Brush.Color := clBlack;
Buffer.Canvas.FillRect(Rect(0,0,Buffer.Width,Buffer.Height));
//draw peaks
ht := ClientHeight div 2;
for i:=0 to length(wavebufL)-1 do
begin
Buffer.Canvas.MoveTo(i,ht);
Buffer.Canvas.Pen.Color := clLime;
Buffer.Canvas.LineTo(i,ht-trunc((wavebufL[i]/32768)*ht));
Buffer.Canvas.Pen.Color := clLime;
Buffer.Canvas.MoveTo(i,ht+2);
Buffer.Canvas.LineTo(i,ht+2+trunc((wavebufR[i]/32768)*ht));
end;
end;
procedure TForm1.DrawTime_Line(position : QWORD; y : integer; cl : TColor);
var
sectime : integer;
str : string;
x : integer;
begin
sectime := trunc(BASS_ChannelBytes2Seconds(chan,position));
x := position div bpp;
//format time
str := '';
if (sectime mod 60 < 10) then str := '0';
str := str+inttostr(sectime mod 60);
str := inttostr(sectime div 60)+':'+str;
//drawline
Buffer.Canvas.Pen.Color := cl;
Buffer.Canvas.MoveTo(x,0);
Buffer.Canvas.LineTo(x,ClientHeight);
//drawtext
Buffer.Canvas.Font.Color := cl;
Buffer.Canvas.Font.Style := [fsBold];
if x > ClientWidth-20 then
dec(x,40);
SetBkMode(Buffer.Canvas.Handle,TRANSPARENT);
Buffer.Canvas.TextOut(x+2,y,str);
end;
procedure TForm1.ErrorPop(str:string);
begin
//show last BASS errorcode when no argument is given, else show given text.
if str = '' then
Showmessage('Error code: '+inttostr(BASS_ErrorGetCode()))
else
Showmessage(str);
Application.Terminate;
end;
procedure TForm1.SetLoopStart(position : qword);
begin
loop[0] := position;
end;
procedure TForm1.SetLoopEnd(position : qword);
begin
loop[1] := position;
BASS_ChannelRemoveSync(chan,lsync); // remove old sync
lsync := BASS_ChannelSetSync(chan,BASS_SYNC_POS or BASS_SYNC_MIXTIME,loop[1],LoopSyncProc, nil); // set new sync
end;
procedure LoopSyncProc(handle: HSYNC; channel, data: DWORD; user: Pointer); stdcall;
begin
if not BASS_ChannelSetPosition(channel,loop[0],BASS_POS_BYTE) then // try seeking to loop start
BASS_ChannelSetPosition(channel,0,BASS_POS_BYTE); // failed, go to start of file instead
end;
procedure TForm1.ScanPeaks2(decoder : HSTREAM);
var
cpos,level : DWord;
peak : array[0..1] of DWORD;
position : DWORD;
counter : integer;
begin
cpos := 0;
peak[0] := 0;
peak[1] := 0;
counter := 0;
while not killscan do
begin
level := BASS_ChannelGetLevel(decoder); // scan peaks
if (peak[0]<LOWORD(level)) then
peak[0]:=LOWORD(level); // set left peak
if (peak[1]<HIWORD(level)) then
peak[1]:=HIWORD(level); // set right peak
if BASS_ChannelIsActive(decoder) <> BASS_ACTIVE_PLAYING then
begin
position := cardinal(-1); // reached the end
end else
position := BASS_ChannelGetPosition(decoder,BASS_POS_BYTE) div bpp;
if position > cpos then
begin
inc(counter);
if counter <= length(wavebufL)-1 then
begin
wavebufL[counter] := peak[0];
wavebufR[counter] := peak[1];
end;
if (position >= dword(ClientWidth)) then
break;
cpos := position;
end;
peak[0] := 0;
peak[1] := 0;
end;
BASS_StreamFree(decoder); // free the decoder
end;
//------------------------------------------------------------------------------
{ TScanThread }
constructor TScanThread.Create(decoder: HSTREAM);
begin
inherited create(false);
Priority := tpNormal;
FreeOnTerminate := true;
FDecoder := decoder;
end;
procedure TScanThread.Execute;
begin
inherited;
Form1.ScanPeaks2(FDecoder);
Terminate;
end;
//------------------------------------------------------------------------------
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if bpp = 0 then exit;
DrawSpectrum; // draw peak waveform
DrawTime_Line(loop[0],12,TColor($FFFF00)); // loop start
DrawTime_Line(loop[1],24,TColor($00FFFF)); // loop end
DrawTime_Line(BASS_ChannelGetPosition(chan,BASS_POS_BYTE),0,TColor($FFFFFF)); // current pos
PB.Refresh;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
mousedwn := 1;
SetLoopStart(dword(x)*bpp)
end
else if Button = mbRight then
begin
mousedwn := 2;
SetLoopEnd(dword(x)*bpp);
end;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if mousedwn = 0 then
exit;
if mousedwn = 1 then
SetLoopStart(dword(x)*bpp)
else if mousedwn = 2 then
SetLoopEnd(dword(x)*bpp);
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
mousedwn := 0;
end;
procedure TForm1.PBPaint(Sender: TObject);
begin
if bpp = 0 then exit;
PB.Canvas.Draw(0,0,Buffer);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key = 27 then
Application.Terminate;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
Timer1.Enabled := false;
bpp := 0;
killscan := true;
Buffer.Free;
BASS_Free();
end;
end.