Gallery
Software
Music
Programming
Archive
Wednesday, Jan 16 Week 3

Simple and reliable timers

The TBpmTimer has one single event for timer impulse, and the TTempoTimer has two events, also one for impulse off. Both timers has a bpm-parameter for built in conversion between milli-seconds and beats per minute.
The TBpmTimer thread sleeps a given amount of time "mSecs" while the TTempoTimer thread sleeps one millisecond, and then counts when to synchronize the on and off events... Each kind of timer has its own thread descendant.

Supported Delphi-versions

Borland Delphi 5
Borland Delphi 6
Borland Delphi 7
Codegear Delphi 2007
Embarcadero Delphi 2010
Embarcadero Delphi XE
Embarcadero Delphi XE2

Download

tbpmtimer.zip
(3.04 Kb)
, Downloads: 505

{ *********************************************************************** }
{ BpmTimers v1.2, mortenbs.com }
{ 2012-2013 http://www.mortenbs.com/it/delphi/?component=tbpmtimer }
{ *********************************************************************** }
//[D5] [D6] [D7] [D2007] [D2010] [XE] [XE2]

//Simple and reliable thread-based timers for Delphi

//2013 Nov, v1.2: Delphi-versions compatibility.
//2012 Oct, v1.1: D7 only

unit bpmTimers;

interface

uses
windows,classes;

type
float=double;
TSimpleEvent=procedure of object;//Simple event without any arguments..
TTimerThread=class(TThread);
//--------------------------|---------------------|-----------------------|-------------------------<
TCustomBpmTimer=class(TComponent)//for descendants
procedure tapTempo;
private
fOnTempoChange :TSimpleEvent; //Notify tempo changes by user and tap tempo
function getBpm:float; //Convert milli-seconds to beats per minute
protected
thrd :TTimerThread; //Thread descendant of inherited timer
started,fEnabled :boolean; //Timer state parameters
fOnImpulse :TSimpleEvent; //Notify timer impulse (Also known as onTimer)
fTapTempo :int64; //Internally used, for the tap tempo procedure
fMSecs :float; //Timer milli-seconds (Also known as interval)
procedure setEnabled(bl:boolean);virtual;
procedure setMSecs(ms:float);virtual;
procedure setBpm(f:float);virtual;
public
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
procedure enable; //Enable the timer
procedure disable; //Disable the timer
published
property bpm :float read getBpm write setBpm;
property mSecs :float read fMSecs write setMSecs;
property enabled :boolean read fEnabled write setEnabled;
property onImpulse :TSimpleEvent read fOnImpulse write fOnImpulse;
property onTempoChange :TSimpleEvent read fOnTempoChange write fOnTempoChange;
end;
//--------------------------|---------------------|-----------------------|-------------------------<
TBpmTimer=class(TCustomBpmTimer)//Has one single event for impulse
public
constructor Create(AOwner:TComponent);override;
end;
//--------------------------|---------------------|-----------------------|-------------------------<
TTempoTimer=class(TCustomBpmTimer)//Has two events, also one for impulse-off
procedure resetPos;
protected
fImpulseLength :float; //Time between impulse on and off (milli-seconds)
fOnImpulseOff :TSimpleEvent; //Notify timer impulse off
procedure setImpulseLength(f:float);
public
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
published
property impulseLength :float read fImpulseLength write setImpulseLength;
property onImpulseOff :TSimpleEvent read fOnImpulseOff write fOnImpulseOff;
end;
//--------------------------|---------------------|-----------------------|-------------------------<

var
fTimers:word=0;

function tick64:int64;stdcall;//Get Tick 64-Bit -even on Delphi 32-Bit

//--
procedure Register;

implementation

//MSDN: TIMEBEGINPERIOD
//Minimum timer resolution, in milliseconds, for the application or device driver.
//A lower value specifies a higher (more accurate) resolution.

function timeBeginPeriod(uPeriod:longInt):longInt;stdcall;
external 'winmm.dll' name 'timeBeginPeriod';

function timeEndPeriod(uPeriod:longInt):longInt;stdcall;
external 'winmm.dll' name 'timeEndPeriod';

function tick64:int64;
external 'winmm.dll' name 'timeGetTime';

//--------------------------------------------------------------------------------------------------
//TBpmThrd:

type
TBpmThrd=class(TTimerThread)
protected
fTimer :TBpmTimer;
procedure Execute;override;
end;

procedure TBpmThrd.Execute;
var ms:longInt;
begin
while not terminated do try
with fTimer do begin
if assigned(fOnImpulse) then synchronize(fOnImpulse);
ms:=round(fMsecs);if ms<1 then ms:=1;
end;sleep(ms)
except break end
end;

//--------------------------------------------------------------------------------------------------
//TBpmTimer:

constructor TBpmTimer.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
thrd:=TBpmThrd.Create(true);
TBpmThrd(thrd).fTimer:=self;

{$IFDEF VER130} //D5
thrd.resume;
{$ELSE}
{$IF CompilerVersion<21} thrd.resume; {$IFEND} //below D2010
{$IF CompilerVersion>=21} thrd.start; {$IFEND} //D2010 and above
{$ENDIF}

started:=true;
end;

//--------------------------------------------------------------------------------------------------
//TTempoThrd:

type
TTempoThrd=class(TTimerThread)
protected
bl :boolean;
fTimer :TTempoTimer;
procedure Execute;override;
public
tick :int64;
lTick :int64;
end;

procedure TTempoThrd.Execute;
var i1,i2:longInt;
begin
bl:=false;lTick:=0;
while not terminated do try tick:=tick64;
with fTimer do begin
if not fEnabled then begin lTick:=0;sleep(500);continue end;
i1:=round(fMsecs);if i1<1 then i1:=1;
i2:=round(fImpulseLength);if i2<1 then i2:=1;

if tick-lTick>=i1 then begin bl:=true;lTick:=tick;
if assigned(fOnImpulse) then synchronize(fOnImpulse);
end else
if bl and (tick-lTick>=i2) then begin bl:=false;
if assigned(fOnImpulseOff) then synchronize(fOnImpulseOff);
end;

end;sleep(1)
except break end
end;

//--------------------------------------------------------------------------------------------------
//TTempoTimer:

constructor TTempoTimer.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
fImpulseLength:=fMSecs/2;
thrd:=TTempoThrd.Create(true);
TTempoThrd(thrd).fTimer:=self;
{$IFDEF VER130} //D5
thrd.resume;
{$ELSE}
{$IF CompilerVersion<21} thrd.resume; {$IFEND} //below D2010
{$IF CompilerVersion>=21} thrd.start; {$IFEND} //D2010 and above
{$ENDIF}
started:=true;
end;

destructor TTempoTimer.Destroy;
begin
fOnImpulseOff:=nil;
inherited Destroy;
end;

procedure TTempoTimer.setImpulseLength(f:float);
begin
if f<1 then f:=1 else if f>fMSecs then f:=fMSecs;
fImpulseLength:=f;
end;

procedure TTempoTimer.resetPos;
begin
TTempoThrd(thrd).lTick:=0;
end;

//--------------------------------------------------------------------------------------------------
//TCustomBpmTimer:

constructor TCustomBpmTimer.Create(AOwner:TComponent);
begin
started:=false;
inherited Create(AOwner);
fMSecs:=500;fTapTempo:=0;
if fTimers=0 then timeBeginPeriod(1);
inc(fTimers);
end;

destructor TCustomBpmTimer.Destroy;
begin started:=false;
fOnImpulse:=nil;
if thrd<>nil then begin
try if not thrd.terminated then thrd.terminate except end;
thrd:=nil;
end;

dec(fTimers);
if fTimers=0 then timeEndPeriod(1);

inherited Destroy;
end;

procedure TCustomBpmTimer.enable;
begin
fEnabled:=true;
end;

procedure TCustomBpmTimer.disable;
begin
fEnabled:=false;
end;

procedure TCustomBpmTimer.setEnabled(bl:boolean);
begin
if bl then enable else disable;
end;

function TCustomBpmTimer.getBpm:float;
begin
if fMSecs<>0 then result:=(1000/fMSecs)*60 else result:=0;
end;

procedure TCustomBpmTimer.setBpm(f:float);
begin
if f<>0 then f:=(1000/f)*60 else f:=1;
setMSecs(f);
end;

procedure TCustomBpmTimer.setMSecs(ms:float);
begin
if ms<1 then ms:=1 else if ms>60000 then ms:=60000;
if ms=fMSecs then exit;
fMSecs:=ms;
if assigned(fOnTempoChange) then fOnTempoChange;
end;

procedure TCustomBpmTimer.tapTempo;
var t:int64;
begin
t:=tick64;
if t-fTapTempo<2000 then begin
setMSecs(t-fTapTempo);
fTapTempo:=t;
end else fTapTempo:=t;
end;

//..

const
COMPONENT_PAGE = 'mortenbs.com';

procedure Register;
begin
registerComponents(COMPONENT_PAGE, [TBpmTimer]);
registerComponents(COMPONENT_PAGE, [TTempoTimer]);
end;

end.

Related pages of TBpmTimer component

Delphi programming
Programming