//DJXTimer v1.1
unit DJXTimer;

interface

uses
  Windows,
  Messages,
  Classes,
  Forms;

type
  TDJXTimer = class(TComponent)
  private
    m_WindowHandle: HWND;
    m_OldIdleEvent: TIdleEvent;
    m_QPCAvailable: boolean;
    m_Frequency: int64;
    m_TargetFPS: integer;
    m_OldTime, m_NewTime: int64;
    m_ProcNewTime, m_ProcOldTime: int64;
    m_Lag: single;
    m_SpeedFactor: single;
    m_IntervalPos: integer;
    m_Interval: integer;
    m_FramesPas: integer;
    m_FPSOldTime: int64;
    m_FPS, m_FPSCurrent: integer;
    m_Enabled: boolean;
    m_MaxFPS: integer;
    m_MaxFPSLag: integer;
    m_ProcessCounter: single;
    m_OnTimer: TNotifyEvent;
    m_OnProcess: TNotifyEvent;
  protected
    procedure SetEnabled(const Value: Boolean);
    procedure AppIdle(Sender: TObject; var Done: Boolean);
    procedure WndProc(var Msg: TMessage);
    procedure UpdateTimer;
    procedure SetMaxFPS(const Value: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Lag: single read m_Lag;
    property SpeedFactor: single read m_SpeedFactor;
    property FPS: integer read m_FPS;
    function GetTime: int64;
  published
    property Enabled: boolean read m_Enabled write SetEnabled;
    property MaxFPS: integer read m_MaxFPS write SetMaxFPS;
    property TargetFPS: integer read m_TargetFPS write m_TargetFPS;
    property ProcInterval: integer read m_Interval write m_Interval;
    property OnTimer: TNotifyEvent read m_OnTimer write m_OnTimer;
    property OnProcess: TNotifyEvent read m_OnProcess write m_OnProcess;
  end;

implementation

uses
  MMSystem;

//TDJXTimer BEGIN
constructor TDJXTimer.Create(AOwner: TComponent);
begin
  inherited;
  m_MaxFPS := 120;
  m_TargetFPS := 100;
  if csDesigning in ComponentState then Exit;
  m_QPCAvailable := QueryPerformanceFrequency(m_Frequency);
  if not m_QPCAvailable then
  begin
    timeBeginPeriod(1);
    m_Frequency := 1000;
  end;
  m_IntervalPos := 0;
  m_FramesPas := 1;
  MaxFPS := m_MaxFPS;
  m_Interval := 10;
  m_ProcOldTime := GetTime;
  m_WindowHandle := AllocateHWnd(WndProc);
  m_OldIdleEvent := Application.OnIdle;
end;
destructor TDJXTimer.Destroy;
begin
  if not (csDesigning in ComponentState) then
  begin
    if not m_QPCAvailable then
    TimeEndPeriod(1);
    DeallocateHWnd(m_WindowHandle);
  end;
  Application.OnIdle := nil;
  inherited;
end;

procedure TDJXTimer.SetEnabled(const Value: Boolean);
begin
  if Value = m_Enabled then Exit;
  m_Enabled := Value;
  if csDesigning in ComponentState then Exit;
  if Value then
  begin
    m_OldTime := GetTime;
    m_FPSOldTime := m_OldTime;
    m_FPSCurrent := 0;
    m_FPS := 0;
    m_IntervalPos := 0;
    m_FramesPas := 1;
    m_ProcOldTime := GetTime;
    m_ProcessCounter := 0;
  end;
  UpdateTimer;
end;
procedure TDJXTimer.AppIdle(Sender: TObject; var Done: Boolean);
var
  AbsLag: int64;
  i: integer;
begin
  if not m_Enabled then exit;
  Done := False;
  m_NewTime := GetTime;
  if m_NewTime - m_FPSOldTime >= m_Frequency then
  begin
    m_FPS := m_FPSCurrent;
    m_FPSCurrent := 0;
    m_FPSOldTime := m_NewTime;
  end;
  AbsLag := m_NewTime - m_OldTime;
  if (m_MaxFPS = 0) or (AbsLag >= m_MaxFPSLag)then
  begin
    inc(m_IntervalPos);
    if m_IntervalPos >= m_Interval then
    begin
      m_ProcNewTime := GetTime;
      m_SpeedFactor := (m_TargetFPS * (m_ProcNewTime - m_ProcOldTime) / m_Frequency) / m_FramesPas;
      m_IntervalPos := 0;
      m_FramesPas := 1;
      m_ProcOldTime := m_ProcNewTime;
    end
    else
    inc(m_FramesPas);
    m_Lag := AbsLag / m_Frequency;
    if Assigned(m_OnProcess) then
    begin
      m_ProcessCounter := m_ProcessCounter + m_SpeedFactor;
      for i := 0 to Trunc(m_ProcessCounter) - 1 do
      m_OnProcess(self);
      m_ProcessCounter := m_ProcessCounter - trunc(m_ProcessCounter);
    end;
    if Assigned(m_OnTimer) then m_OnTimer(Self);
    m_OldTime := m_NewTime;
    Inc(m_FPSCurrent);
  end
  else
  if m_MaxFPS > 0 then
  Sleep(1);
  if Assigned(m_OldIdleEvent) then m_OldIdleEvent(Sender, Done);
end;
procedure TDJXTimer.WndProc(var Msg: TMessage);
var
  bDummy: boolean;
begin
  with Msg do
  if Msg = WM_TIMER then
  try
    AppIdle(Self, bDummy);
  except
    Application.HandleException(Self);
  end
  else
  Result := DefWindowProc(m_WindowHandle, Msg, wParam, lParam);
end;
procedure TDJXTimer.UpdateTimer;
begin
  KillTimer(m_WindowHandle, 1);
  if m_Enabled and Assigned(m_OnTimer) then
  Application.OnIdle := AppIdle
  else
  Application.OnIdle := nil;
end;
procedure TDJXTimer.SetMaxFPS(const Value: Integer);
begin
  m_MaxFPS := Value;
  if csDesigning in ComponentState then Exit;
  if m_MaxFPS > 0 then
  m_MaxFPSLag := m_Frequency div m_MaxFPS;
end;
function TDJXTimer.GetTime: int64;
begin
  if m_QPCAvailable then
  QueryPerformanceCounter(Result)
  else
  Result := TimeGetTime;
end;

//TDJXTimer END

end.
