Timer.pas
资源名称:CAST2SDK.rar [点击查看]
上传用户:yj_qiu
上传日期:2022-08-08
资源大小:23636k
文件大小:15k
源码类别:
游戏引擎
开发平台:
Delphi
- (*
- @Abstract(Timer unit)
- (C) 2006-2007 George "Mirage" Bakhtadze. <a href="http://www.casteng.com">www.casteng.com</a> <br>
- The source code may be used under either MPL 1.1 or LGPL 2.1 license. See included license.txt file <br>
- Created: May 16, 2007 <br>
- Unit contains base timer-related types and classes
- *)
- {$Include GDefines.inc}
- unit Timer;
- interface
- uses
- TextFile,
- BaseTypes, BaseMsg, OSUtils;
- const
- // Number of internal time units per millisecond
- InternalUnitsInMillisecond = 10;
- // Event ID corresponding to no event
- eIDNone = -1;
- type
- // Type for time measured in seconds
- TSecond = TTimeUnit;
- // Type for timer internal time processing. Currently one tenth of millisecond.
- TInternalTimeUnit = Int64;
- // Type of recurring event identifiers
- TEventID = Integer;
- { Methods of this type can be bound to timer events.
- <b>EventID</b> - identifies event (specified in <b>SetEvent()</b> call).
- <b>ErrorDelta</b> - delta time between time the event actually occured and scheduled event time. }
- TTimerDelegate = procedure(EventID: Integer; const ErrorDelta: TTimeUnit) of object;
- { Timer query function type. Methods of this type can be used to query a custom implementation of timer.
- Should return time in @Link(TInternalTimeUnit) units. }
- TTimerQueryFunc = function: TInternalTimeUnit of object;
- { Timer event data structure. <br>
- <b>Time</b> - time of the event in @Link(TInternalTimeUnit) units <br>
- <b>Delegate</b> - a function of @Link(TTimerDelegate) which will be called when the event occurs. <b>Nil</b> for no call <br>
- <b>MessageClass</b> - class of message generated when the event occurs. <b>Nil</b> for no message <br>
- <b>EventID</b> - Some identification number to supply delegate with }
- TTimerEvent = record
- Time: TInternalTimeUnit;
- Delegate: TTimerDelegate;
- case Boolean of
- False: (MessageClass: CMessage);
- True: (EventID: Integer)
- end;
- { Timer recurring event data structure. <br>
- <b>Delay</b> - delay between occurences of the event in @Link(TInternalTimeUnit) units <br>
- <b>Time</b> - time of next occurence in @Link(TInternalTimeUnit) units <br>
- <b>Delegate</b> - a function of @Link(TTimerDelegate) which will be called when the event occurs. <b>Nil</b> for no call <br>
- <b>MessageClass</b> - class of message generated when the event occurs. <b>Nil</b> for no message <br>
- <b>EventID</b> - Some identification number to supply delegate with }
- TRecurringEvent = record
- Delay, Time: TInternalTimeUnit;
- Delegate: TTimerDelegate;
- case Boolean of
- False: (MessageClass: CMessage);
- True: (EventID: Integer)
- end;
- // Data structure containing the information necessary for correct measure of intervals
- TTimeMark = record
- Signature: TFileSignature;
- ID: Integer;
- Stamp: TInternalTimeUnit;
- end;
- { @Abstract(Timer service class)
- The class can be used to measure time intervals as well as to bind a message generation or
- a delegate call. <br>
- Default implementation uses <b>GetPerformanceCounter</b> from @Link(OSUtils) if available or less precise <b>GetCurrentMs()</b>
- otherwise. A custom implemetation can be easily connected. <br>
- ToDo: Make the class thread-safe. }
- TTimer = class(TSubsystem)
- private
- MessageHandler: TMessageHandler;
- InsideProcess: Boolean;
- TmpEvents: array of TTimerEvent;
- TotalTmpEvents: Integer;
- PerfCounterMultiplier: TSecond;
- SecondsToInternalMultiplier: Int64;
- InternalToSecondsMultiplier: TSecond;
- // Events sorted by Time
- Events: array of TTimerEvent;
- // Recurring events
- RecEvents: array of TRecurringEvent;
- FTotalRecEvents, FMaxRecEvents, FTotalEvents: Integer;
- TimerBias: TInternalTimeUnit;
- FLastTime: TInternalTimeUnit;
- function SecondsToInternal(Value: TSecond): TInternalTimeUnit;
- function InternalToSeconds(Value: TInternalTimeUnit): TSecond;
- function QueryTimer: TInternalTimeUnit;
- function QueryHiResTimer: TInternalTimeUnit;
- function GetCurrent: TInternalTimeUnit;
- // Adds an event to a temporary array to handle calls to SetEvent() from Process();
- procedure AddTmpEvent(const Time: TInternalTimeUnit; MessageClass: CMessage; Delegate: TTimerDelegate; EventID: Integer);
- // Inserts a new event and returns its index
- function Insert(const EventTime: TInternalTimeUnit): Integer;
- function IsRecEventIndexValid(EventID: Integer): Boolean;
- function GetFreeRecIndex: Integer;
- public
- { This variable limits the time interval on which recurring events will be processed
- to prevent too much computations when a lot of time passed since last Process() call.
- Default value is 3 seconds. }
- MaxInterval: TTimeUnit;
- // Timer query delegate. Can be overwritten to use a custom timer implementation
- TimerQueryFunc: TTimerQueryFunc;
- constructor Create(AMessageHandler: TMessageHandler);
- // Message handler. No messages need to be handled so it's empty.
- procedure HandleMessage(const Msg: TMessage); override;
- { Returns time passed from previous call of the method with the same TimeMark variable and ModifyMark set to True.
- First call (with uninitialized TimeMark) returns 0 and performs initialization of the TimeMark. }
- function GetInterval(var TimeMark: TTimeMark; ModifyMark: Boolean): TSecond;
- { Returns True if more then Intervak time passed from previous call of the method with the same TimeMark variable and ModifyMark set to True.
- First call (with uninitialized TimeMark) returns True and performs initialization of the TimeMark. }
- function IsIntervalPassed(var TimeMark: TTimeMark; ModifyMark: Boolean; Interval: TSecond): Boolean;
- // Sets (binds) a message of the specified class to generate in <b>Delay</b> seconds
- procedure SetEvent(const Delay: TSecond; MessageClass: CMessage); overload;
- // Sets (binds) the specified delegate to call in <b>Delay</b> seconds. <b>EventID</b> is an application-specific identification number to supply the delegate with.
- procedure SetEvent(const Delay: TSecond; Delegate: TTimerDelegate; EventID: Integer); overload;
- { Sets (binds) a message of the specified class to generate every <b>Delay</b> seconds starting from the moment of call.
- Returns an ID of the new event. }
- function SetRecurringEvent(const Delay: TSecond; MessageClass: CMessage): Integer; overload;
- { Sets (binds) the specified delegate to call every <b>Delay</b> seconds starting from the moment of call.
- <b>EventID</b> is an application-specific identification number to supply the delegate with. Returns an ID of the new event. }
- function SetRecurringEvent(const Delay: TSecond; Delegate: TTimerDelegate; EventID: Integer): Integer; overload;
- // Removes the specified recurring event
- procedure RemoveRecurringEvent(EventID: Integer);
- // Changes interval of the specified recurring event
- procedure SetRecurringEventInterval(EventID: Integer; const Delay: TSecond);
- { Processes timer events and returns delay to the nearest event.
- Events will be processed and therefore can emerge only within this method. }
- function Process: TSecond;
- // Number of active events not including recurring ones
- property TotalEvents: Integer read FTotalEvents;
- // Number of active recurring events
- property TotalRecurringEvents: Integer read FTotalRecEvents;
- end;
- implementation
- { TTimer }
- const
- CapacityStep = 8;
- OneOver1000 = 1/1000;
- TimeMarkSignature: TFileSignature = 'TSTP';
- function TTimer.InternalToSeconds(Value: TInternalTimeUnit): TSecond;
- begin
- Result := Value * InternalToSecondsMultiplier;
- end;
- function TTimer.SecondsToInternal(Value: TSecond): TInternalTimeUnit;
- begin
- Assert(Value * SecondsToInternalMultiplier < MaxInt);
- Result := Round(Value * SecondsToInternalMultiplier);
- end;
- function TTimer.QueryTimer: TInternalTimeUnit;
- begin
- Result := TInternalTimeUnit(OSUtils.GetCurrentMs()) * TInternalTimeUnit(InternalUnitsInMillisecond);
- end;
- function TTimer.QueryHiResTimer: TInternalTimeUnit;
- begin
- Result := Round((OSUtils.GetPerformanceCounter() - TimerBias) * PerfCounterMultiplier);
- end;
- function TTimer.GetCurrent: TInternalTimeUnit;
- begin
- FLastTime := TimerQueryFunc();
- Result := FLastTime;
- end;
- procedure TTimer.AddTmpEvent(const Time: TInternalTimeUnit; MessageClass: CMessage; Delegate: TTimerDelegate; EventID: Integer);
- begin
- if Length(TmpEvents) <= TotalTmpEvents then SetLength(TmpEvents, Length(TmpEvents) + CapacityStep);
- TmpEvents[TotalTmpEvents].Time := Time;
- TmpEvents[TotalTmpEvents].MessageClass := MessageClass;
- TmpEvents[TotalTmpEvents].Delegate := Delegate;
- TmpEvents[TotalTmpEvents].EventID := EventID;
- Inc(TotalTmpEvents);
- end;
- function TTimer.Insert(const EventTime: TInternalTimeUnit): Integer;
- var i: Integer;
- begin
- Result := FTotalEvents-1;
- while (Result >= 0) and (Events[Result].Time < EventTime) do Dec(Result);
- if FTotalEvents >= Length(Events) then SetLength(Events, Length(Events) + CapacityStep);
- Inc(Result);
- for i := Result to FTotalEvents-1 do Events[i+1] := Events[i];
- Inc(FTotalEvents);
- Events[Result].Time := EventTime;
- end;
- constructor TTimer.Create(AMessageHandler: TMessageHandler);
- begin
- MessageHandler := AMessageHandler;
- Assert(Assigned(MessageHandler), 'TTimer.Create: Message handler should be assigned');
- MaxInterval := 3;
- FMaxRecEvents := 0; // Current capacity of recurring events array
- OSUtils.ObtainPerformanceFrequency;
- SecondsToInternalMultiplier := 1000 * InternalUnitsInMillisecond;
- if OSUtils.PerformanceFrequency <> 0 then begin
- PerfCounterMultiplier := OSUtils.OneOverPerformanceFrequency * SecondsToInternalMultiplier;
- TimerQueryFunc := {$IFDEF OBJFPCEnable}@{$ENDIF}QueryHiResTimer;
- TimerBias := OSUtils.GetPerformanceCounter();
- end else begin
- TimerQueryFunc := {$IFDEF OBJFPCEnable}@{$ENDIF}QueryTimer;
- Log.Log('TTimer.Create: High resolution timer initialization failed. Using low resolution timer', lkWarning);
- end;
- InternalToSecondsMultiplier := 1/SecondsToInternalMultiplier;
- GetCurrent();
- end;
- procedure TTimer.HandleMessage(const Msg: TMessage);
- begin
- end;
- procedure TTimer.SetEvent(const Delay: TSecond; MessageClass: CMessage);
- var Ind: Integer;
- begin
- if InsideProcess then
- AddTmpEvent(TimerQueryFunc() + SecondsToInternal(Delay), MessageClass, nil, 0)
- else begin
- Ind := Insert(TimerQueryFunc() + SecondsToInternal(Delay));
- Events[Ind].MessageClass := MessageClass;
- end;
- end;
- procedure TTimer.SetEvent(const Delay: TSecond; Delegate: TTimerDelegate; EventID: Integer);
- var Ind: Integer;
- begin
- if InsideProcess then
- AddTmpEvent(TimerQueryFunc() + SecondsToInternal(Delay), nil, Delegate, EventID)
- else begin
- Ind := Insert(TimerQueryFunc() + SecondsToInternal(Delay));
- Events[Ind].Delegate := Delegate;
- Events[Ind].EventID := EventID;
- end;
- end;
- function TTimer.IsRecEventIndexValid(EventID: Integer): Boolean;
- begin
- Result := (EventID >= 0) or (EventID < FMaxRecEvents) and
- (Assigned(RecEvents[EventID].Delegate) or (RecEvents[EventID].MessageClass <> nil));
- end;
- function TTimer.GetFreeRecIndex: Integer;
- begin
- Result := 0;
- while (Result < FMaxRecEvents) and IsRecEventIndexValid(Result) do Inc(Result);
- if not (Result < FMaxRecEvents) then begin
- FMaxRecEvents := Result + 1;
- if FMaxRecEvents > Length(RecEvents) then SetLength(RecEvents, Length(RecEvents) + CapacityStep);
- end;
- end;
- function TTimer.SetRecurringEvent(const Delay: TSecond; MessageClass: CMessage): Integer;
- begin
- Result := GetFreeRecIndex();
- RecEvents[Result].Delay := SecondsToInternal(Delay);
- RecEvents[Result].Time := GetCurrent() + RecEvents[Result].Delay;
- RecEvents[Result].MessageClass := MessageClass;
- Inc(FTotalRecEvents);
- end;
- function TTimer.SetRecurringEvent(const Delay: TSecond; Delegate: TTimerDelegate; EventID: Integer): Integer;
- begin
- Result := SetRecurringEvent(Delay, CMessage(nil));
- RecEvents[Result].Delegate := Delegate;
- RecEvents[Result].EventID := EventID;
- end;
- procedure TTimer.RemoveRecurringEvent(EventID: Integer);
- begin
- if not IsRecEventIndexValid(EventID) then begin
- Log.Log(ClassName + '.RemoveRecurringEvent: Invalid event ID', lkError);
- Exit;
- end;
- RecEvents[EventID].Delegate := nil;
- RecEvents[EventID].MessageClass := nil;
- if EventID = FMaxRecEvents-1 then Dec(FMaxRecEvents);
- Dec(FTotalRecEvents);
- end;
- procedure TTimer.SetRecurringEventInterval(EventID: Integer; const Delay: TSecond);
- begin
- if not IsRecEventIndexValid(EventID) then begin
- Log.Log(ClassName + '.SetRecurringEventInterval: Invalid event ID', lkError);
- Exit;
- end;
- RecEvents[EventID].Delay := SecondsToInternal(Delay);
- end;
- function TTimer.Process: TSecond;
- var i, Ind: Integer; Cur, MaxIntervalInternal, Nearest: TInternalTimeUnit;
- begin
- InsideProcess := True;
- Cur := GetCurrent();
- Nearest := Cur;
- // Process disposable events
- i := FTotalEvents-1;
- while (i >= 0) and (Events[i].Time <= Cur) do begin
- if Assigned(Events[i].Delegate) then
- Events[i].Delegate(Events[i].EventID, InternalToSeconds(Cur - Events[i].Time))
- else if
- Assigned(Events[i].MessageClass) then MessageHandler(Events[i].MessageClass.Create);
- Dec(i);
- Dec(FTotalEvents);
- end;
- if FTotalEvents > 0 then Nearest := Events[FTotalEvents-1].Time;
- // Process recurring events
- MaxIntervalInternal := SecondsToInternal(MaxInterval);
- for i := 0 to FMaxRecEvents-1 do if IsRecEventIndexValid(i) then begin
- if Cur - RecEvents[i].Time > MaxIntervalInternal then
- RecEvents[i].Time := Cur - MaxIntervalInternal;
- while RecEvents[i].Time <= Cur do begin
- if Assigned(RecEvents[i].Delegate) then
- RecEvents[i].Delegate(RecEvents[i].EventID, 0)
- else if
- Assigned(RecEvents[i].MessageClass) then MessageHandler(RecEvents[i].MessageClass.Create);
- RecEvents[i].Time := RecEvents[i].Time + RecEvents[i].Delay;
- end;
- if (Nearest > RecEvents[i].Time) or (Nearest = Cur) then Nearest := RecEvents[i].Time;
- end;
- Result := InternalToSeconds(Nearest - Cur);
- InsideProcess := False;
- // Insert events which was issued during process
- for i := 0 to TotalTmpEvents-1 do begin
- Ind := Insert(TmpEvents[i].Time);
- Events[Ind] := TmpEvents[i];
- end;
- TotalTmpEvents := 0;
- end;
- function TTimer.GetInterval(var TimeMark: TTimeMark; ModifyMark: Boolean): TSecond;
- var RawTime: TInternalTimeUnit;
- begin
- RawTime := TimerQueryFunc();
- if TimeMark.Signature = TimeMarkSignature then begin
- Result := InternalToSeconds(RawTime - TimeMark.Stamp);
- if ModifyMark then TimeMark.Stamp := RawTime;
- end else begin
- TimeMark.Signature := TimeMarkSignature;
- Result := 0;
- TimeMark.Stamp := RawTime;
- end;
- end;
- function TTimer.IsIntervalPassed(var TimeMark: TTimeMark; ModifyMark: Boolean; Interval: TSecond): Boolean;
- var Passed: TSecond;
- begin
- Passed := GetInterval(TimeMark, ModifyMark);
- Result := (Passed = 0) or (Passed >= Interval);
- end;
- end.