Some old code that I've used in my projects, not sure where it originally came from...
Code:
unit glThread;
interface
uses
Forms, Windows, Classes, MMSystem;
type
TThreadProcedure = procedure of object;
TGLDrawEvent = procedure(Sender: TObject) of object;
TGLRunThread = class(TThread)
private
FIsTerminated: Boolean;
fAverageDrawList : TList;
fAverageDrawTime : single;
fFrameRate : single;
fIdleTime : Single;
fAverageIdleTime : single;
fMaxFrameRate : integer;
fThreadProc : TThreadProcedure;
fGLPriority : TThreadPriority;
fUnlimited : boolean;
FrameCount : integer;
FrameTicks : Single;
procedure SetfGLPriority (Value : TThreadPriority);
procedure DoIt;
protected
QPFrequency: Int64;
QPCurrentTime: Int64;
QPLastTime: Int64;
QPEnabled: Boolean;
procedure Execute; override;
function GetTime: Single;
public
constructor Create (CreateSuspended : boolean; ThreadProc : TThreadProcedure);
destructor Destroy; override;
property GLPriority : TThreadPriority read fGLPriority write SetfGLPriority;
property ThreadProc : TThreadProcedure write fThreadProc;
property IdleTime : Single read fIdleTime;
property AverageDrawTime : single read fAverageDrawTime;
property AverageIdleTime : single read fAverageIdleTime;
property FrameRate : single read fFrameRate;
property MaxFrameRate : integer read fMaxFrameRate write fMaxFrameRate;
property Unlimited : boolean read fUnlimited write fUnlimited;
property IsTerminated: Boolean read FIsTerminated;
end;
TGLThread = class(TComponent)
private
procedure ThreadProc;
protected
RunThread: TGLRunThread;
FOnDraw: TGLDrawEvent;
function GetAverageDrawTime: Single;
function GetFrameRate: Single;
function GetMaxFrameRate: Integer;
procedure SetMaxFrameRate(Value: Integer);
function GetRunning: Boolean;
function GetUnlimited: Boolean;
procedure SetUnlimited(Value: Boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Start;
procedure Stop;
property FrameRate: Single read GetFrameRate;
property AverageDrawTime: Single read GetAverageDrawTime;
property Running: Boolean read GetRunning;
published
property OnDraw: TGLDrawEvent read FOnDraw write FOnDraw;
property MaxFrameRate: Integer read GetMaxFrameRate write SetMaxFrameRate;
property Unlimited: Boolean read GetUnlimited write SetUnlimited;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('OpenGL', [TGLThread]);
end;
{---------------------------------------------------------------------------
-----------------------}
function TGLRunThread.GetTime: Single;
var
Time: Int64;
begin
QueryPerformanceCounter(Time);
Result := (Time / QPFrequency);
end;
//TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest, tpTimeCritical);
constructor TGLRunThread.Create(CreateSuspended : boolean; ThreadProc : TThreadProcedure);
begin
inherited Create(CreateSuspended);
fAverageDrawList := TList.Create;
fFrameRate := 0;
fMaxFrameRate := 60; // Need a frame rate of 60 frames / second.
fThreadProc := ThreadProc;
//FreeOnTerminate := true;
FreeOnTerminate := FALSE;
//GLPriority := tpIdle;
GLPriority := tpNormal;
fUnlimited := false;
FIsTerminated := FALSE;
QueryPerformanceFrequency(QPFrequency);
end; {constructor}
{---------------------------------------------------------------------------
-----------------------}
destructor TGLRunThread.Destroy;
begin
fAverageDrawList.Free;
inherited;
end; {destructor}
{---------------------------------------------------------------------------
-----------------------}
procedure TGLRunThread.SetfGLPriority(Value : TThreadPriority);
begin
if (fGLPriority <> Value) then begin
fGLPriority := Value;
Priority := fGLPriority;
end; {if}
end; {SetfGLPriority}
{---------------------------------------------------------------------------
-----------------------}
procedure TGLRunThread.Execute;
begin
FIsTerminated := FALSE;
FrameCount := 0; // Used to get the frame rate.
FrameTicks := GetTime;
while not Terminated do begin
//Synchronize(DoIt);
DoIt;
end; {while}
FIsTerminated := TRUE;
end; {Execute}
procedure TGLRunThread.DoIt;
{...........................................................................
.....................}
function AverageTime(TimeList : TList; TimeValue : Single; Samples : integer) : single;
var
lp1 : integer;
begin
TimeList.Add(Pointer(TimeValue));
if (TimeList.Count > Samples) then
TimeList.Delete(0);
Result := 0;
for lp1 := 0 to pred(TimeList.Count) do
Result := Result + Single(TimeList[lp1]);
Result := Result / TimeList.Count;
end; {AverageTime}
{...........................................................................
.....................}
var
StartTicks : Single;
DrawTime : Single;
begin
//StartTicks := GetTickCount; // Get the start time.
StartTicks := GetTime; // Get the start time.
if Assigned(fThreadProc) then // Do the drawing ...
Synchronize(fThreadProc); // <------- The main draw routine
//DrawTime := Integer(GetTickCount-StartTicks); // Get the draw time.
DrawTime := (GetTime-StartTicks); // Get the draw time.
fAverageDrawTime := AverageTime(fAverageDrawList, DrawTime, 50); // Work out the average draw time.
if fUnlimited then begin // Frame rate limited ?
fIdleTime := 0; // Set these to zero ... then ignore.
fAverageIdleTime := 0;
end else begin
fIdleTime := (1/fMaxFrameRate) - DrawTime; // Idle time is the difference between the
fAverageIdleTime := 1/fMaxFrameRate - fAverageDrawTime; // wanted frame duration and the draw time.
end; {if}
if (fIdleTime > 0) then // If there is some idle time then delay
Sleep(Round(fIdleTime * 1000)); // for the idle time by sleeping.
inc(FrameCount); // Work out the frame rate ... effectively
if (StartTicks - FrameTicks > 1) then begin // sample every second and count the number
fFrameRate := (1*FrameCount) / (StartTicks-FrameTicks); // of frames.
FrameCount := 0;
//FrameTicks := GetTickCount;
FrameTicks := GetTime;
end; {if}
end;
{---------------------------------------------------------------------------
-----------------------}
{ajGLThread}
constructor TGLThread.Create(AOwner: TComponent);
begin
inherited;
RunThread := TGLRunThread.Create(TRUE, ThreadProc);
end;
destructor TGLThread.Destroy;
begin
Stop;
RunThread.Free;
inherited;
end;
function TGLThread.GetAverageDrawTime: Single;
begin
Result := RunThread.AverageDrawTime;
end;
function TGLThread.GetFrameRate: Single;
begin
Result := RunThread.FrameRate;
end;
function TGLThread.GetMaxFrameRate: Integer;
begin
Result := RunThread.MaxFrameRate;
end;
procedure TGLThread.SetMaxFrameRate(Value: Integer);
begin
RunThread.MaxFrameRate := Value;
end;
function TGLThread.GetRunning: Boolean;
begin
Result := not RunThread.IsTerminated;
end;
function TGLThread.GetUnlimited: Boolean;
begin
Result := RunThread.Unlimited;
end;
procedure TGLThread.SetUnlimited(Value: Boolean);
begin
RunThread.Unlimited := Value;
end;
procedure TGLThread.Start;
begin
RunThread.Resume;
end;
procedure TGLThread.Stop;
begin
if not RunThread.IsTerminated then
begin
RunThread.Terminate;
RunThread.WaitFor;
end;
end;
procedure TGLThread.ThreadProc;
begin
if Assigned(FOnDraw) then
FOnDraw(Self);
end;
end.
Bookmarks