Timer.pas
上传用户:yj_qiu
上传日期:2022-08-08
资源大小:23636k
文件大小:15k
源码类别:

游戏引擎

开发平台:

Delphi

  1. (*
  2.  @Abstract(Timer unit)
  3.  (C) 2006-2007 George "Mirage" Bakhtadze. <a href="http://www.casteng.com">www.casteng.com</a> <br>
  4.  The source code may be used under either MPL 1.1 or LGPL 2.1 license. See included license.txt file <br>
  5.  Created: May 16, 2007 <br>
  6.  Unit contains base timer-related types and classes
  7. *)
  8. {$Include GDefines.inc}
  9. unit Timer;
  10. interface
  11. uses
  12.   TextFile,
  13.   BaseTypes, BaseMsg, OSUtils;
  14. const
  15.   // Number of internal time units per millisecond
  16.   InternalUnitsInMillisecond = 10;
  17.   // Event ID corresponding to no event
  18.   eIDNone = -1;
  19. type
  20.   // Type for time measured in seconds
  21.   TSecond = TTimeUnit;
  22.   // Type for timer internal time processing. Currently one tenth of millisecond.
  23.   TInternalTimeUnit = Int64;
  24.   // Type of recurring event identifiers
  25.   TEventID = Integer;
  26.   { Methods of this type can be bound to timer events.
  27.     <b>EventID</b> - identifies event (specified in <b>SetEvent()</b> call).
  28.     <b>ErrorDelta</b> - delta time between time the event actually occured and scheduled event time. }
  29.   TTimerDelegate = procedure(EventID: Integer; const ErrorDelta: TTimeUnit) of object;
  30.   { Timer query function type. Methods of this type can be used to query a custom implementation of timer.
  31.     Should return time in @Link(TInternalTimeUnit) units. }
  32.   TTimerQueryFunc = function: TInternalTimeUnit of object;
  33.   { Timer event data structure. <br>
  34.     <b>Time</b>         - time of the event in @Link(TInternalTimeUnit) units <br>
  35.     <b>Delegate</b>     - a function of @Link(TTimerDelegate) which will be called when the event occurs. <b>Nil</b> for no call <br>
  36.     <b>MessageClass</b> - class of message generated when the event occurs. <b>Nil</b> for no message <br>
  37.     <b>EventID</b>      - Some identification number to supply delegate with }
  38.   TTimerEvent = record
  39.     Time: TInternalTimeUnit;
  40.     Delegate: TTimerDelegate; 
  41.     case Boolean of
  42.       False: (MessageClass: CMessage);
  43.       True:  (EventID: Integer)
  44.   end;
  45.   { Timer recurring event data structure. <br>
  46.     <b>Delay</b>        - delay between occurences of the event in @Link(TInternalTimeUnit) units <br>
  47.     <b>Time</b>         - time of next occurence in @Link(TInternalTimeUnit) units <br>
  48.     <b>Delegate</b>     - a function of @Link(TTimerDelegate) which will be called when the event occurs. <b>Nil</b> for no call <br>
  49.     <b>MessageClass</b> - class of message generated when the event occurs. <b>Nil</b> for no message <br>
  50.     <b>EventID</b>      - Some identification number to supply delegate with }
  51.   TRecurringEvent = record
  52.     Delay, Time: TInternalTimeUnit;
  53.     Delegate: TTimerDelegate; 
  54.     case Boolean of
  55.       False: (MessageClass: CMessage);
  56.       True:  (EventID: Integer)
  57.   end;
  58.   // Data structure containing the information necessary for correct measure of intervals
  59.   TTimeMark = record
  60.     Signature: TFileSignature;
  61.     ID: Integer;
  62.     Stamp: TInternalTimeUnit;
  63.   end;
  64.   { @Abstract(Timer service class)
  65.     The class can be used to measure time intervals as well as to bind a message generation or
  66.     a delegate call. <br>
  67.     Default implementation uses <b>GetPerformanceCounter</b> from @Link(OSUtils) if available or less precise <b>GetCurrentMs()</b>
  68.     otherwise. A custom implemetation can be easily connected. <br>
  69.     ToDo: Make the class thread-safe. }
  70.   TTimer = class(TSubsystem)
  71.   private
  72.     MessageHandler: TMessageHandler;
  73.     InsideProcess: Boolean;
  74.     TmpEvents: array of TTimerEvent;
  75.     TotalTmpEvents: Integer;
  76.     PerfCounterMultiplier: TSecond;
  77.     SecondsToInternalMultiplier: Int64;
  78.     InternalToSecondsMultiplier: TSecond;
  79.     // Events sorted by Time
  80.     Events: array of TTimerEvent;
  81.     // Recurring events
  82.     RecEvents: array of TRecurringEvent;
  83.     FTotalRecEvents, FMaxRecEvents, FTotalEvents: Integer;
  84.     TimerBias: TInternalTimeUnit;
  85.     FLastTime: TInternalTimeUnit;
  86.     function SecondsToInternal(Value: TSecond): TInternalTimeUnit;
  87.     function InternalToSeconds(Value: TInternalTimeUnit): TSecond;
  88.     function QueryTimer: TInternalTimeUnit;
  89.     function QueryHiResTimer: TInternalTimeUnit;
  90.     function GetCurrent: TInternalTimeUnit;
  91.     // Adds an event to a temporary array to handle calls to SetEvent() from Process();
  92.     procedure AddTmpEvent(const Time: TInternalTimeUnit; MessageClass: CMessage; Delegate: TTimerDelegate; EventID: Integer);
  93.     // Inserts a new event and returns its index
  94.     function Insert(const EventTime: TInternalTimeUnit): Integer;
  95.     function IsRecEventIndexValid(EventID: Integer): Boolean;
  96.     function GetFreeRecIndex: Integer;
  97.   public
  98.     { This variable limits the time interval on which recurring events will be processed
  99.       to prevent too much computations when a lot of time passed since last Process() call.
  100.       Default value is 3 seconds. }
  101.     MaxInterval: TTimeUnit;
  102.     // Timer query delegate. Can be overwritten to use a custom timer implementation
  103.     TimerQueryFunc: TTimerQueryFunc;
  104.     constructor Create(AMessageHandler: TMessageHandler);
  105.     // Message handler. No messages need to be handled so it's empty.
  106.     procedure HandleMessage(const Msg: TMessage); override;
  107.     { Returns time passed from previous call of the method with the same TimeMark variable and ModifyMark set to True.
  108.       First call (with uninitialized TimeMark) returns 0 and performs initialization of the TimeMark. }
  109.     function GetInterval(var TimeMark: TTimeMark; ModifyMark: Boolean): TSecond;
  110.     { Returns True if more then Intervak time passed from previous call of the method with the same TimeMark variable and ModifyMark set to True.
  111.       First call (with uninitialized TimeMark) returns True and performs initialization of the TimeMark. }
  112.     function IsIntervalPassed(var TimeMark: TTimeMark; ModifyMark: Boolean; Interval: TSecond): Boolean;
  113.     // Sets (binds) a message of the specified class to generate in <b>Delay</b> seconds
  114.     procedure SetEvent(const Delay: TSecond; MessageClass: CMessage); overload;
  115.     // 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.
  116.     procedure SetEvent(const Delay: TSecond; Delegate: TTimerDelegate; EventID: Integer); overload;
  117.     { Sets (binds) a message of the specified class to generate every <b>Delay</b> seconds starting from the moment of call.
  118.       Returns an ID of the new event. }
  119.     function SetRecurringEvent(const Delay: TSecond; MessageClass: CMessage): Integer; overload;
  120.     { Sets (binds) the specified delegate to call every <b>Delay</b> seconds starting from the moment of call.
  121.       <b>EventID</b> is an application-specific identification number to supply the delegate with. Returns an ID of the new event. }
  122.     function SetRecurringEvent(const Delay: TSecond; Delegate: TTimerDelegate; EventID: Integer): Integer; overload;
  123.     // Removes the specified recurring event
  124.     procedure RemoveRecurringEvent(EventID: Integer);
  125.     // Changes interval of the specified recurring event
  126.     procedure SetRecurringEventInterval(EventID: Integer; const Delay: TSecond);
  127.     { Processes timer events and returns delay to the nearest event.
  128.       Events will be processed and therefore can emerge only within this method. }
  129.     function Process: TSecond;
  130.     // Number of active events not including recurring ones
  131.     property TotalEvents: Integer read FTotalEvents;
  132.     // Number of active recurring events
  133.     property TotalRecurringEvents: Integer read FTotalRecEvents;
  134.   end;
  135. implementation
  136. { TTimer }
  137. const
  138.   CapacityStep = 8;
  139.   OneOver1000 = 1/1000;
  140.   TimeMarkSignature: TFileSignature = 'TSTP';
  141. function TTimer.InternalToSeconds(Value: TInternalTimeUnit): TSecond;
  142. begin
  143.   Result := Value * InternalToSecondsMultiplier;
  144. end;
  145. function TTimer.SecondsToInternal(Value: TSecond): TInternalTimeUnit;
  146. begin
  147.   Assert(Value * SecondsToInternalMultiplier < MaxInt);
  148.   Result := Round(Value * SecondsToInternalMultiplier);
  149. end;
  150. function TTimer.QueryTimer: TInternalTimeUnit;
  151. begin
  152.   Result := TInternalTimeUnit(OSUtils.GetCurrentMs()) * TInternalTimeUnit(InternalUnitsInMillisecond);
  153. end;
  154. function TTimer.QueryHiResTimer: TInternalTimeUnit;
  155. begin
  156.   Result := Round((OSUtils.GetPerformanceCounter() - TimerBias) * PerfCounterMultiplier);
  157. end;
  158. function TTimer.GetCurrent: TInternalTimeUnit;
  159. begin
  160.   FLastTime := TimerQueryFunc();
  161.   Result := FLastTime;
  162. end;
  163. procedure TTimer.AddTmpEvent(const Time: TInternalTimeUnit; MessageClass: CMessage; Delegate: TTimerDelegate; EventID: Integer);
  164. begin
  165.   if Length(TmpEvents) <= TotalTmpEvents then SetLength(TmpEvents, Length(TmpEvents) + CapacityStep);
  166.   TmpEvents[TotalTmpEvents].Time         := Time;
  167.   TmpEvents[TotalTmpEvents].MessageClass := MessageClass;
  168.   TmpEvents[TotalTmpEvents].Delegate     := Delegate;
  169.   TmpEvents[TotalTmpEvents].EventID      := EventID;
  170.   Inc(TotalTmpEvents);
  171. end;
  172. function TTimer.Insert(const EventTime: TInternalTimeUnit): Integer;
  173. var i: Integer;
  174. begin
  175.   Result := FTotalEvents-1;
  176.   while (Result >= 0) and (Events[Result].Time < EventTime) do Dec(Result);
  177.   if FTotalEvents >= Length(Events) then SetLength(Events, Length(Events) + CapacityStep);
  178.   Inc(Result);
  179.   for i := Result to FTotalEvents-1 do Events[i+1] := Events[i];
  180.   Inc(FTotalEvents);
  181.   Events[Result].Time := EventTime;
  182. end;
  183. constructor TTimer.Create(AMessageHandler: TMessageHandler);
  184. begin
  185.   MessageHandler := AMessageHandler;
  186.   Assert(Assigned(MessageHandler), 'TTimer.Create: Message handler should be assigned');
  187.   MaxInterval := 3;
  188.   FMaxRecEvents := 0;                      // Current capacity of recurring events array
  189.   OSUtils.ObtainPerformanceFrequency;
  190.   SecondsToInternalMultiplier := 1000 * InternalUnitsInMillisecond;
  191.   if OSUtils.PerformanceFrequency <> 0 then begin
  192.     PerfCounterMultiplier := OSUtils.OneOverPerformanceFrequency * SecondsToInternalMultiplier;
  193.     TimerQueryFunc := {$IFDEF OBJFPCEnable}@{$ENDIF}QueryHiResTimer;
  194.     TimerBias := OSUtils.GetPerformanceCounter();
  195.   end else begin
  196.     TimerQueryFunc := {$IFDEF OBJFPCEnable}@{$ENDIF}QueryTimer;
  197.     Log.Log('TTimer.Create: High resolution timer initialization failed. Using low resolution timer', lkWarning);
  198.   end;
  199.   InternalToSecondsMultiplier := 1/SecondsToInternalMultiplier;
  200.   GetCurrent();
  201. end;
  202. procedure TTimer.HandleMessage(const Msg: TMessage);
  203. begin
  204. end;
  205. procedure TTimer.SetEvent(const Delay: TSecond; MessageClass: CMessage);
  206. var Ind: Integer;
  207. begin
  208.   if InsideProcess then
  209.     AddTmpEvent(TimerQueryFunc() + SecondsToInternal(Delay), MessageClass, nil, 0)
  210.   else begin
  211.     Ind := Insert(TimerQueryFunc() + SecondsToInternal(Delay));
  212.     Events[Ind].MessageClass := MessageClass;
  213.   end;
  214. end;
  215. procedure TTimer.SetEvent(const Delay: TSecond; Delegate: TTimerDelegate; EventID: Integer);
  216. var Ind: Integer;
  217. begin
  218.   if InsideProcess then
  219.     AddTmpEvent(TimerQueryFunc() + SecondsToInternal(Delay), nil, Delegate, EventID)
  220.   else begin
  221.     Ind := Insert(TimerQueryFunc() + SecondsToInternal(Delay));
  222.     Events[Ind].Delegate := Delegate;
  223.     Events[Ind].EventID  := EventID;
  224.   end;
  225. end;
  226. function TTimer.IsRecEventIndexValid(EventID: Integer): Boolean;
  227. begin
  228.   Result := (EventID >= 0) or (EventID < FMaxRecEvents) and
  229.             (Assigned(RecEvents[EventID].Delegate) or (RecEvents[EventID].MessageClass <> nil));
  230. end;
  231. function TTimer.GetFreeRecIndex: Integer;
  232. begin
  233.   Result := 0;
  234.   while (Result < FMaxRecEvents) and IsRecEventIndexValid(Result) do Inc(Result);
  235.   if not (Result < FMaxRecEvents) then begin
  236.     FMaxRecEvents := Result + 1;
  237.     if FMaxRecEvents > Length(RecEvents) then SetLength(RecEvents, Length(RecEvents) + CapacityStep);
  238.   end;
  239. end;
  240. function TTimer.SetRecurringEvent(const Delay: TSecond; MessageClass: CMessage): Integer;
  241. begin
  242.   Result := GetFreeRecIndex();
  243.   RecEvents[Result].Delay        := SecondsToInternal(Delay);
  244.   RecEvents[Result].Time         := GetCurrent() + RecEvents[Result].Delay;
  245.   RecEvents[Result].MessageClass := MessageClass;
  246.   Inc(FTotalRecEvents);
  247. end;
  248. function TTimer.SetRecurringEvent(const Delay: TSecond; Delegate: TTimerDelegate; EventID: Integer): Integer;
  249. begin
  250.   Result := SetRecurringEvent(Delay, CMessage(nil));
  251.   RecEvents[Result].Delegate := Delegate;
  252.   RecEvents[Result].EventID  := EventID;
  253. end;
  254. procedure TTimer.RemoveRecurringEvent(EventID: Integer);
  255. begin
  256.   if not IsRecEventIndexValid(EventID) then begin
  257.     Log.Log(ClassName + '.RemoveRecurringEvent: Invalid event ID', lkError);
  258.     Exit;
  259.   end;
  260.   RecEvents[EventID].Delegate     := nil;
  261.   RecEvents[EventID].MessageClass := nil;
  262.   if EventID = FMaxRecEvents-1 then Dec(FMaxRecEvents);
  263.   Dec(FTotalRecEvents);
  264. end;
  265. procedure TTimer.SetRecurringEventInterval(EventID: Integer; const Delay: TSecond);
  266. begin
  267.   if not IsRecEventIndexValid(EventID) then begin
  268.     Log.Log(ClassName + '.SetRecurringEventInterval: Invalid event ID', lkError);
  269.     Exit;
  270.   end;
  271.   RecEvents[EventID].Delay := SecondsToInternal(Delay);
  272. end;
  273. function TTimer.Process: TSecond;
  274. var i, Ind: Integer; Cur, MaxIntervalInternal, Nearest: TInternalTimeUnit;
  275. begin
  276.   InsideProcess := True;
  277.   Cur := GetCurrent();
  278.   Nearest := Cur;
  279.   // Process disposable events
  280.   i := FTotalEvents-1;
  281.   while (i >= 0) and (Events[i].Time <= Cur) do begin
  282.     if Assigned(Events[i].Delegate) then
  283.       Events[i].Delegate(Events[i].EventID, InternalToSeconds(Cur - Events[i].Time))
  284.     else if
  285.       Assigned(Events[i].MessageClass) then MessageHandler(Events[i].MessageClass.Create);
  286.     Dec(i);
  287.     Dec(FTotalEvents);
  288.   end;
  289.   if FTotalEvents > 0 then Nearest := Events[FTotalEvents-1].Time;
  290.   // Process recurring events
  291.   MaxIntervalInternal := SecondsToInternal(MaxInterval);
  292.   for i := 0 to FMaxRecEvents-1 do if IsRecEventIndexValid(i) then begin
  293.     if Cur - RecEvents[i].Time > MaxIntervalInternal then
  294.       RecEvents[i].Time := Cur - MaxIntervalInternal;
  295.     while RecEvents[i].Time <= Cur do begin
  296.       if Assigned(RecEvents[i].Delegate) then
  297.         RecEvents[i].Delegate(RecEvents[i].EventID, 0)
  298.       else if            
  299.         Assigned(RecEvents[i].MessageClass) then MessageHandler(RecEvents[i].MessageClass.Create);
  300.       RecEvents[i].Time := RecEvents[i].Time + RecEvents[i].Delay;
  301.     end;
  302.     if (Nearest > RecEvents[i].Time) or (Nearest = Cur) then Nearest := RecEvents[i].Time;
  303.   end;
  304.   Result := InternalToSeconds(Nearest - Cur);
  305.   InsideProcess := False;
  306.   // Insert events which was issued during process
  307.   for i := 0 to TotalTmpEvents-1 do begin
  308.     Ind := Insert(TmpEvents[i].Time);
  309.     Events[Ind] := TmpEvents[i];
  310.   end;
  311.   TotalTmpEvents := 0;
  312. end;
  313. function TTimer.GetInterval(var TimeMark: TTimeMark; ModifyMark: Boolean): TSecond;
  314. var RawTime: TInternalTimeUnit;
  315. begin
  316.   RawTime := TimerQueryFunc();
  317.   if TimeMark.Signature = TimeMarkSignature then begin
  318.     Result := InternalToSeconds(RawTime - TimeMark.Stamp);
  319.     if ModifyMark then TimeMark.Stamp := RawTime;
  320.   end else begin
  321.     TimeMark.Signature := TimeMarkSignature;
  322.     Result := 0;
  323.     TimeMark.Stamp := RawTime;
  324.   end;
  325. end;
  326. function TTimer.IsIntervalPassed(var TimeMark: TTimeMark; ModifyMark: Boolean; Interval: TSecond): Boolean;
  327. var Passed: TSecond;
  328. begin
  329.   Passed := GetInterval(TimeMark, ModifyMark);
  330.   Result := (Passed = 0) or (Passed >= Interval);
  331. end;
  332. end.