LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   Cadencing composant for GLScene (ease Progress processing)
6

7
  History :  
8
       10/11/12 - PW - Added CPP compatibility: restored GetCurrenttime instead of GetCurrentTime
9
       07/08/11 - Yar - Added OnTotalProgress event, which happens after all iterations with fixed delta time (thanks Controller)
10
       06/02/11 - Predator - Improved TGLCadencer for Lazarus
11
       29/11/10 - Yar - Changed TASAPHandler.FMessageTime type to unsigned (thanks olkondr)
12
       21/11/09 - DaStr - Bugfixed FSubscribedCadenceableComponents
13
                             (thanks Roshal Sasha)
14
       09/11/09 - DaStr - Improved FPC compatibility
15
                             (thanks Predator) (BugtrackerID = 2893580)
16
       21/09/07 - DaStr - Added TGLCadencer.SetCurrentTime()
17
       17/03/07 - DaStr - Dropped Kylix support in favor of FPC (BugTracekrID=1681585)
18
       02/08/04 - LR, YHC - BCB corrections: changed GetCurrentTime to GetCurrenttime
19
       28/06/04 - LR - Added some ifdef Win32 for Linux
20
       20/10/03 - EG - Fixed issues about cadencer destruction
21
       29/08/03 - EG - Added MinDeltaTime and FixedDeltaTime
22
       21/08/03 - EG - Fixed Application.OnIdle reset bug (Solerman Kaplon)
23
       04/07/03 - EG - Improved TimeMultiplier transitions (supports zero)
24
       06/06/03 - EG - Added cmApplicationIdle Mode
25
       19/05/03 - EG - Added Reset (Roberto Bussola)
26
       04/03/02 - EG - Added SetTimeMultiplier
27
       01/07/02 - EG - Added TGLCadencedComponent
28
       05/12/01 - EG - Fix in subscription mechanism (D6 IDE freezes gone?)
29
       30/11/01 - EG - Added IsBusy (thx Chris S)
30
       08/09/01 - EG - Added MaxDeltaTime limiter
31
       23/08/01 - EG - No more "deprecated" warning for Delphi6
32
       12/08/01 - EG - Protection against "timer flood"
33
       19/07/01 - EG - Fixed Memory Leak in RegisterASAPCadencer,
34
                          Added speed limiter TASAPHandler.WndProc
35
       01/02/01 - EG - Fixed "Freezing" when Enabled set to False
36
       08/10/00 - EG - Added TASAPHandler to support multiple ASAP cadencers
37
       19/06/00 - EG - Fixed TGLCadencer.Notification
38
       14/04/00 - EG - Minor fixes
39
       13/04/00 - EG - Creation
40
  
41
}
42
unit GLCadencer;
43

44
interface
45

46
{$I GLScene.inc}
47

48
uses
49
  GLScene, GLCrossPlatform, GLBaseClasses,
50
  Classes, Types, Forms, lmessages, SyncObjs;
51
//**************************************
52

53
type
54

55
  // TGLCadencerMode
56
  //
57
  { Determines how the TGLCadencer operates.
58
   - cmManual : you must trigger progress manually (in your code) 
59
   - cmASAP : progress is triggered As Soon As Possible after a previous
60
    progress (uses windows messages).
61
       - cmApplicationIdle : will hook Application.OnIdle, this will overwrite
62
          any previous event handle, and only one cadencer may be in this mode. }
63
  TGLCadencerMode = (cmManual, cmASAP, cmApplicationIdle);
64

65
  // TGLCadencerTimeReference
66
  //
67
  { Determines which time reference the TGLCadencer should use.
68
   - cmRTC : the Real Time Clock is used (precise over long periods, but
69
    not accurate to the millisecond, may limit your effective framerate
70
          to less than 50 FPS on some systems) 
71
   - cmPerformanceCounter : the windows performance counter is used (nice
72
    precision, may derive over long periods, this is the default option
73
    as it allows the smoothest animation on fast systems) 
74
   - cmExternal : the CurrentTime property is used }
75
  TGLCadencerTimeReference = (cmRTC, cmPerformanceCounter, cmExternal);
76

77
  // TGLCadencer
78
  //
79
  { This component allows auto-progression of animation.
80
   Basicly dropping this component and linking it to your TGLScene will send
81
   it real-time progression events (time will be measured in seconds) while
82
   keeping the CPU 100% busy if possible (ie. if things change in your scene).
83
   The progression time (the one you'll see in you progression events)
84
   is calculated using  (CurrentTime-OriginTime)*TimeMultiplier,
85
   CurrentTime being either manually or automatically updated using
86
   TimeReference (setting CurrentTime does NOT trigger progression). }
87
  TGLCadencer = class(TComponent)
88
  private
89
     
90
    FSubscribedCadenceableComponents: TList;
91
    FScene: TGLScene;
92
    FTimeMultiplier: Double;
93
    lastTime, downTime, lastMultiplier: Double;
94
    FEnabled: Boolean;
95
    FSleepLength: Integer;
96
    FMode: TGLCadencerMode;
97
    FTimeReference: TGLCadencerTimeReference;
98
    FCurrentTime: Double;
99
    FOriginTime: Double;
100
    FMaxDeltaTime, FMinDeltaTime, FFixedDeltaTime: Double;
101
  	FOnProgress, FOnTotalProgress : TGLProgressEvent;
102
    FProgressing: Integer;
103
    procedure SetCurrentTime(const Value: Double);
104

105
  protected
106
     
107
    procedure Notification(AComponent: TComponent; Operation: TOperation);
108
      override;
109
    function StoreTimeMultiplier: Boolean;
110
    procedure SetEnabled(const val: Boolean);
111
    procedure SetScene(const val: TGLScene);
112
    procedure SetMode(const val: TGLCadencerMode);
113
    procedure SetTimeReference(const val: TGLCadencerTimeReference);
114
    procedure SetTimeMultiplier(const val: Double);
115
    { Returns raw ref time (no multiplier, no offset) }
116
    function GetRawReferenceTime: Double;
117
    procedure RestartASAP;
118
    procedure Loaded; override;
119

120
    procedure OnIdleEvent(Sender: TObject; var Done: Boolean);
121

122
  public
123
     
124
    constructor Create(AOwner: TComponent); override;
125
    destructor Destroy; override;
126

127
    procedure Subscribe(aComponent: TGLCadenceAbleComponent);
128
    procedure UnSubscribe(aComponent: TGLCadenceAbleComponent);
129

130
    { Allows to manually trigger a progression.
131
     Time stuff is handled automatically. 
132
     If cadencer is disabled, this functions does nothing. }
133
    procedure Progress;
134

135
    { Adjusts CurrentTime if necessary, then returns its value. }
136
    function GetCurrenttime: Double;
137

138
    { Returns True if a "Progress" is underway.
139
       Be aware that as long as IsBusy is True, the Cadencer may be
140
       sending messages and progression calls to cadenceable components
141
       and scenes. }
142
    function IsBusy: Boolean;
143

144
    { Reset the time parameters and returns to zero.}
145
    procedure Reset;
146

147
    { Value soustracted to current time to obtain progression time. }
148
    property OriginTime: Double read FOriginTime write FOriginTime;
149
    { Current time (manually or automatically set, see TimeReference). }
150
    property CurrentTime: Double read FCurrentTime write SetCurrentTime;
151

152
  published
153
     
154
    { The TGLScene that will be cadenced (progressed). }
155
    property Scene: TGLScene read FScene write SetScene;
156
    { Enables/Disables cadencing.
157
     Disabling won't cause a jump when restarting, it is working like
158
     a play/pause (ie. may modify OriginTime to keep things smooth). }
159
    property Enabled: Boolean read FEnabled write SetEnabled default True;
160

161
    { Defines how CurrentTime is updated.
162
     See TGLCadencerTimeReference. 
163
     Dynamically changeing the TimeReference may cause a "jump".  }
164
    property TimeReference: TGLCadencerTimeReference read FTimeReference write
165
      SetTimeReference default cmPerformanceCounter;
166

167
    { Multiplier applied to the time reference.
168
      Zero isn't an allowed value, and be aware that if negative values
169
      are accepted, they may not be supported by other GLScene objects. 
170
     Changing the TimeMultiplier will alter OriginTime. }
171
    property TimeMultiplier: Double read FTimeMultiplier write SetTimeMultiplier
172
      stored StoreTimeMultiplier;
173

174
    { Maximum value for deltaTime in progression events.
175
       If null or negative, no max deltaTime is defined, otherwise, whenever
176
       an event whose actual deltaTime would be superior to MaxDeltaTime
177
       occurs, deltaTime is clamped to this max, and the extra time is hidden
178
       by the cadencer (it isn't visible in CurrentTime either). 
179
       This option allows to limit progression rate in simulations where
180
       high values would result in errors/random behaviour. }
181
    property MaxDeltaTime: Double read FMaxDeltaTime write FMaxDeltaTime;
182

183
    { Minimum value for deltaTime in progression events.
184
       If superior to zero, this value specifies the minimum time step
185
       between two progression events. 
186
       This option allows to limit progression rate in simulations where
187
       low values would result in errors/random behaviour. }
188
    property MinDeltaTime: Double read FMinDeltaTime write FMinDeltaTime;
189

190
    { Fixed time-step value for progression events.
191
       If superior to zero, progression steps will happen with that fixed
192
       delta time. The progression remains time based, so zero to N events
193
       may be fired depending on the actual deltaTime (if deltaTime is
194
       inferior to FixedDeltaTime, no event will be fired, if it is superior
195
       to two times FixedDeltaTime, two events will be fired, etc.). 
196
       This option allows to use fixed time steps in simulations (while the
197
       animation and rendering itself may happen at a lower or higher
198
       framerate). }
199
    property FixedDeltaTime: Double read FFixedDeltaTime write FFixedDeltaTime;
200

201
    { Adjusts how progression events are triggered.
202
     See TGLCadencerMode. }
203
    property Mode: TGLCadencerMode read FMode write SetMode default cmASAP;
204

205
    { Allows relinquishing time to other threads/processes.
206
     A "sleep" is issued BEFORE each progress if SleepLength>=0 (see
207
     help for the "sleep" procedure in delphi for details). }
208
    property SleepLength: Integer read FSleepLength write FSleepLength default
209
      -1;
210

211
    { Happens AFTER scene was progressed. }
212
    property OnProgress: TGLProgressEvent read FOnProgress write FOnProgress;
213
    { Happens AFTER all iterations with fixed delta time. }
214
    property OnTotalProgress : TGLProgressEvent read FOnTotalProgress write FOnTotalProgress;
215
  end;
216

217
  // TGLCustomCadencedComponent
218
  //
219
  { Adds a property to connect/subscribe to a cadencer. }
220
  TGLCustomCadencedComponent = class(TGLUpdateAbleComponent)
221
  private
222
     
223
    FCadencer: TGLCadencer;
224

225
  protected
226
     
227
    procedure SetCadencer(const val: TGLCadencer);
228

229
    property Cadencer: TGLCadencer read FCadencer write SetCadencer;
230

231
  public
232
     
233
    destructor Destroy; override;
234

235
    procedure Notification(AComponent: TComponent; Operation: TOperation);
236
      override;
237
  end;
238

239
  // TGLCadencedComponent
240
  //
241
  TGLCadencedComponent = class(TGLCustomCadencedComponent)
242
  published
243
     
244
    property Cadencer;
245
  end;
246

247
  // ---------------------------------------------------------------------
248
  // ---------------------------------------------------------------------
249
  // ---------------------------------------------------------------------
250
implementation
251
// ---------------------------------------------------------------------
252
// ---------------------------------------------------------------------
253
// ---------------------------------------------------------------------
254

255
uses SysUtils;
256

257
const
258
  LM_GLTIMER = LM_INTERFACELAST + 326;
259

260

261
type
262

263
  TASAPHandler = class;
264
  // TTimerThread
265
  //
266
  TTimerThread = class(TThread)
267
  private
268
    FOwner: TASAPHandler;
269
    FInterval: Word;
270
  protected
271
    procedure Execute; override;
272
  public
273
    constructor Create(CreateSuspended: Boolean); virtual;
274
  end;
275

276

277
  { TASAPHandler }
278
  TASAPHandler = class
279
  private
280

281
    FTimerThread: TThread;
282
    FMutex: TCriticalSection;
283

284
  public
285

286
    procedure TimerProc;
287
    procedure Cadence(var Msg: TLMessage); message LM_GLTIMER;
288

289
    constructor Create;
290
    destructor Destroy; override;
291
  end;
292

293
var
294

295
  vASAPCadencerList: TList;
296
  vHandler: TASAPHandler;
297
  vCounterFrequency: Int64;
298

299
  // RegisterASAPCadencer
300
  //
301

302
procedure RegisterASAPCadencer(aCadencer: TGLCadencer);
303
begin
304
  if aCadencer.Mode = cmASAP then
305
  begin
306
    if not Assigned(vASAPCadencerList) then
307
      vASAPCadencerList := TList.Create;
308
    if vASAPCadencerList.IndexOf(aCadencer) < 0 then
309
    begin
310
      vASAPCadencerList.Add(aCadencer);
311
      if not Assigned(vHandler) then
312
        vHandler := TASAPHandler.Create;
313
    end;
314
  end
315
  else if aCadencer.Mode = cmApplicationIdle then
316
    Application.OnIdle := aCadencer.OnIdleEvent;
317
end;
318

319
// UnRegisterASAPCadencer
320
//
321

322
procedure UnRegisterASAPCadencer(aCadencer: TGLCadencer);
323
var
324
  i: Integer;
325
begin
326
  if aCadencer.Mode = cmASAP then
327
  begin
328
    if Assigned(vASAPCadencerList) then
329
    begin
330
      i := vASAPCadencerList.IndexOf(aCadencer);
331
      if i >= 0 then
332
        vASAPCadencerList[i] := nil;
333
    end;
334
  end
335
  else if aCadencer.Mode = cmApplicationIdle then
336
    Application.OnIdle := nil;
337
end;
338

339

340
constructor TTimerThread.Create(CreateSuspended: Boolean);
341
begin
342
  inherited Create(CreateSuspended);
343
end;
344

345
// Execute
346
//
347

348
procedure TTimerThread.Execute;
349
var
350
  lastTick, nextTick, curTick, perfFreq: Int64;
351
begin
352
  QueryPerformanceFrequency(perfFreq);
353
  QueryPerformanceCounter(lastTick);
354
  nextTick := lastTick + (FInterval * perfFreq) div 1000;
355
  while not Terminated do
356
  begin
357
    FOwner.FMutex.Acquire;
358
    FOwner.FMutex.Release;
359
    while not Terminated do
360
    begin
361
      QueryPerformanceCounter(lastTick);
362
      if lastTick >= nextTick then
363
        break;
364
      Sleep(1);
365
    end;
366
    if not Terminated then
367
    begin
368
      // if time elapsed run user-event
369
      Synchronize(FOwner.TimerProc);
370
      QueryPerformanceCounter(curTick);
371
      nextTick := lastTick + (FInterval * perfFreq) div 1000;
372
      if nextTick <= curTick then
373
      begin
374
        // CPU too slow... delay to avoid monopolizing what's left
375
        nextTick := curTick + (FInterval * perfFreq) div 1000;
376
      end;
377
    end;
378
  end;
379
end;
380

381
// ------------------
382
// ------------------ TASAPHandler ------------------
383
// ------------------
384

385
// Create
386
//
387

388
constructor TASAPHandler.Create;
389
begin
390
  inherited Create;
391

392
  // create timer thread
393
  FMutex := TCriticalSection.Create;
394
  FMutex.Acquire;
395
  FTimerThread := TTimerThread.Create(False);
396

397
  with TTimerThread(FTimerThread) do
398
  begin
399
    FOwner := Self;
400
    FreeOnTerminate := False;
401
    Priority := tpTimeCritical;
402
    FInterval := 1;
403
    FMutex.Release;
404
  end;
405

406
end;
407

408
// Destroy
409
//
410

411
destructor TASAPHandler.Destroy;
412
begin
413
  FMutex.Acquire;
414
  FTimerThread.Terminate;
415
  CheckSynchronize;
416
  // wait & free
417
  FTimerThread.WaitFor;
418
  FTimerThread.Free;
419
  FMutex.Free;
420

421
  inherited Destroy;
422
end;
423

424
procedure TASAPHandler.TimerProc;
425
var
426
  NewMsg: TLMessage;
427
begin
428
  NewMsg.Msg := LM_GLTIMER;
429
  Cadence(NewMsg);
430
end;
431

432
procedure TASAPHandler.Cadence(var Msg: TLMessage);
433
var
434
  i: Integer;
435
  cad: TGLCadencer;
436
begin
437
  if Assigned(vHandler) and Assigned(vASAPCadencerList)
438
    and (vASAPCadencerList.Count <> 0) then
439
    for i := vASAPCadencerList.Count - 1 downto 0 do
440
    begin
441
      cad := TGLCadencer(vASAPCadencerList[i]);
442
      if Assigned(cad) and (cad.Mode = cmASAP)
443
        and cad.Enabled and (cad.FProgressing = 0) then
444
      begin
445
        if Application.Terminated then
446
        begin
447
          // force stop
448
          cad.Enabled := False;
449
        end
450
        else
451
        begin
452
          try
453
            // do stuff
454
            cad.Progress;
455
          except
456
            Application.HandleException(Self);
457
            // it faulted, stop it
458
            cad.Enabled := False;
459
          end
460
        end;
461
      end;
462
    end;
463
end;
464

465
// ------------------
466
// ------------------ TGLCadencer ------------------
467
// ------------------
468

469
// Create
470
//
471

472
constructor TGLCadencer.Create(AOwner: TComponent);
473
begin
474
  inherited Create(AOwner);
475
  FTimeReference := cmPerformanceCounter;
476
  downTime := GetRawReferenceTime;
477
  FOriginTime := downTime;
478
  FTimeMultiplier := 1;
479
  FSleepLength := -1;
480
  Mode := cmASAP;
481
  Enabled := True;
482
end;
483

484
// Destroy
485
//
486

487
destructor TGLCadencer.Destroy;
488
begin
489
  Assert(FProgressing = 0);
490
  UnRegisterASAPCadencer(Self);
491
  FSubscribedCadenceableComponents.Free;
492
  FSubscribedCadenceableComponents := nil;
493
  inherited Destroy;
494
end;
495

496
// Subscribe
497
//
498

499
procedure TGLCadencer.Subscribe(aComponent: TGLCadenceAbleComponent);
500
begin
501
  if not Assigned(FSubscribedCadenceableComponents) then
502
    FSubscribedCadenceableComponents := TList.Create;
503
  if FSubscribedCadenceableComponents.IndexOf(aComponent) < 0 then
504
  begin
505
    FSubscribedCadenceableComponents.Add(aComponent);
506
    aComponent.FreeNotification(Self);
507
  end;
508
end;
509

510
// UnSubscribe
511
//
512

513
procedure TGLCadencer.UnSubscribe(aComponent: TGLCadenceAbleComponent);
514
var
515
  i: Integer;
516
begin
517
  if Assigned(FSubscribedCadenceableComponents) then
518
  begin
519
    i := FSubscribedCadenceableComponents.IndexOf(aComponent);
520
    if i >= 0 then
521
    begin
522
      FSubscribedCadenceableComponents.Delete(i);
523
      aComponent.RemoveFreeNotification(Self);
524
    end;
525
  end;
526
end;
527

528
// Notification
529
//
530

531
procedure TGLCadencer.Notification(AComponent: TComponent; Operation:
532
  TOperation);
533
begin
534
  if Operation = opRemove then
535
  begin
536
    if AComponent = FScene then
537
      FScene := nil;
538
    if Assigned(FSubscribedCadenceableComponents) then
539
      FSubscribedCadenceableComponents.Remove(AComponent);
540
  end;
541
  inherited;
542
end;
543

544
// Loaded
545
//
546

547
procedure TGLCadencer.Loaded;
548
begin
549
  inherited Loaded;
550
  RestartASAP;
551
end;
552

553
// OnIdleEvent
554
//
555

556
procedure TGLCadencer.OnIdleEvent(Sender: TObject; var Done: Boolean);
557
begin
558
  Progress;
559
  Done := False;
560
end;
561

562
// RestartASAP
563
//
564

565
procedure TGLCadencer.RestartASAP;
566
begin
567
  if not (csLoading in ComponentState) then
568
  begin
569
    if (Mode in [cmASAP, cmApplicationIdle]) and (not (csDesigning in
570
      ComponentState))
571
      and Assigned(FScene) and Enabled then
572
      RegisterASAPCadencer(Self)
573
    else
574
      UnRegisterASAPCadencer(Self);
575
  end;
576
end;
577

578
// SetEnabled
579
//
580

581
procedure TGLCadencer.SetEnabled(const val: Boolean);
582
begin
583
  if FEnabled <> val then
584
  begin
585
    FEnabled := val;
586
    if not (csDesigning in ComponentState) then
587
    begin
588
      if Enabled then
589
        FOriginTime := FOriginTime + GetRawReferenceTime - downTime
590
      else
591
        downTime := GetRawReferenceTime;
592
      RestartASAP;
593
    end;
594
  end;
595
end;
596

597
// SetScene
598
//
599

600
procedure TGLCadencer.SetScene(const val: TGLScene);
601
begin
602
  if FScene <> val then
603
  begin
604
    if Assigned(FScene) then
605
      FScene.RemoveFreeNotification(Self);
606
    FScene := val;
607
    if Assigned(FScene) then
608
      FScene.FreeNotification(Self);
609
    RestartASAP;
610
  end;
611
end;
612

613
// SetTimeMultiplier
614
//
615

616
procedure TGLCadencer.SetTimeMultiplier(const val: Double);
617
var
618
  rawRef: Double;
619
begin
620
  if val <> FTimeMultiplier then
621
  begin
622
    if val = 0 then
623
    begin
624
      lastMultiplier := FTimeMultiplier;
625
      Enabled := False;
626
    end
627
    else
628
    begin
629
      rawRef := GetRawReferenceTime;
630
      if FTimeMultiplier = 0 then
631
      begin
632
        Enabled := True;
633
        // continuity of time:
634
        // (rawRef-newOriginTime)*val = (rawRef-FOriginTime)*lastMultiplier
635
        FOriginTime := rawRef - (rawRef - FOriginTime) * lastMultiplier / val;
636
      end
637
      else
638
      begin
639
        // continuity of time:
640
        // (rawRef-newOriginTime)*val = (rawRef-FOriginTime)*FTimeMultiplier
641
        FOriginTime := rawRef - (rawRef - FOriginTime) * FTimeMultiplier / val;
642
      end;
643
    end;
644
    FTimeMultiplier := val;
645
  end;
646
end;
647

648
// StoreTimeMultiplier
649
//
650

651
function TGLCadencer.StoreTimeMultiplier: Boolean;
652
begin
653
  Result := (FTimeMultiplier <> 1);
654
end;
655

656
// SetMode
657
//
658

659
procedure TGLCadencer.SetMode(const val: TGLCadencerMode);
660
begin
661
  if FMode <> val then
662
  begin
663
    if FMode <> cmManual then
664
      UnRegisterASAPCadencer(Self);
665
    FMode := val;
666
    RestartASAP;
667
  end;
668
end;
669

670
// SetTimeReference
671
//
672

673
procedure TGLCadencer.SetTimeReference(const val: TGLCadencerTimeReference);
674
begin
675
  // nothing more, yet
676
  FTimeReference := val;
677
end;
678

679
// Progress
680
//
681

682
procedure TGLCadencer.Progress;
683
var
684
  deltaTime, newTime, totalDelta: Double;
685
  fullTotalDelta, firstLastTime : Double;
686
  i: Integer;
687
  pt: TProgressTimes;
688
begin
689
  // basic protection against infinite loops,
690
    // shall never happen, unless there is a bug in user code
691
  if FProgressing < 0 then
692
    Exit;
693
  if Enabled then
694
  begin
695
    // avoid stalling everything else...
696
    if SleepLength >= 0 then
697
      Sleep(SleepLength);
698
    // in manual mode, the user is supposed to make sure messages are handled
699
    // in Idle mode, this processing is implicit
700
    if Mode = cmASAP then
701
    begin
702
      //Application.ProcessMessages; Eater of resources and time
703
      if (not Assigned(vASAPCadencerList))
704
        or (vASAPCadencerList.IndexOf(Self) < 0) then
705
        Exit;
706
    end;
707
  end;
708
  Inc(FProgressing);
709
  try
710
    if Enabled then
711
    begin
712
      // One of the processed messages might have disabled us
713
      if Enabled then
714
      begin
715
        // ...and progress !
716
        newTime := GetCurrenttime;
717
        deltaTime := newTime - lastTime;
718
        if (deltaTime >= MinDeltaTime) and (deltaTime >= FixedDeltaTime) then
719
        begin
720
          if FMaxDeltaTime > 0 then
721
          begin
722
            if deltaTime > FMaxDeltaTime then
723
            begin
724
              FOriginTime := FOriginTime + (deltaTime - FMaxDeltaTime) /
725
                FTimeMultiplier;
726
              deltaTime := FMaxDeltaTime;
727
              newTime := lastTime + deltaTime;
728
            end;
729
          end;
730
          totalDelta := deltaTime;
731
          fullTotalDelta := totalDelta;
732
          firstLastTime := lastTime;
733
          if FixedDeltaTime > 0 then
734
            deltaTime := FixedDeltaTime;
735
          while totalDelta >= deltaTime do
736
          begin
737
            lastTime := lastTime + deltaTime;
738
            if Assigned(FScene) and (deltaTime <> 0) then
739
            begin
740
              FProgressing := -FProgressing;
741
              try
742
                FScene.Progress(deltaTime, lastTime);
743
              finally
744
                FProgressing := -FProgressing;
745
              end;
746
            end;
747
            pt.deltaTime := deltaTime;
748
            pt.newTime := lastTime;
749
            i := 0;
750
            while Assigned(FSubscribedCadenceableComponents) and
751
              (i <= FSubscribedCadenceableComponents.Count - 1) do
752
            begin
753
              TGLCadenceAbleComponent(FSubscribedCadenceableComponents[i]).DoProgress(pt);
754
              i := i + 1;
755
            end;
756
            if Assigned(FOnProgress) and (not (csDesigning in ComponentState))
757
              then
758
              FOnProgress(Self, deltaTime, newTime);
759
            if deltaTime <= 0 then
760
              Break;
761
            totalDelta := totalDelta - deltaTime;
762
          end;
763
          if Assigned(FOnTotalProgress)
764
            and (not (csDesigning in ComponentState)) then
765
            FOnTotalProgress(Self, fullTotalDelta, firstLastTime);
766
        end;
767
      end;
768
    end;
769
  finally
770
    Dec(FProgressing);
771
  end;
772
end;
773

774
// GetRawReferenceTime
775
//
776

777
function TGLCadencer.GetRawReferenceTime: Double;
778
var
779
  counter: Int64;
780
begin
781
  case FTimeReference of
782
    cmRTC: // Real Time Clock
783
      Result := Now * (3600 * 24);
784
    cmPerformanceCounter:
785
      begin // HiRes Performance Counter
786
        QueryPerformanceCounter(counter);
787
        Result := counter / vCounterFrequency;
788
      end;
789
    cmExternal: // User defined value
790
      Result := FCurrentTime;
791
  else
792
    Result := 0;
793
    Assert(False);
794
  end;
795
end;
796

797
// GetCurrenttime
798
//
799

800
function TGLCadencer.GetCurrenttime: Double;
801
begin
802
  Result := (GetRawReferenceTime - FOriginTime) * FTimeMultiplier;
803
  FCurrentTime := Result;
804
end;
805

806
// IsBusy
807
//
808

809
function TGLCadencer.IsBusy: Boolean;
810
begin
811
  Result := (FProgressing <> 0);
812
end;
813

814
//  Reset
815
//
816

817
procedure TGLCadencer.Reset;
818
begin
819
  lasttime := 0;
820
  downTime := GetRawReferenceTime;
821
  FOriginTime := downTime;
822
end;
823

824
// SetCurrentTime
825
//
826

827
procedure TGLCadencer.SetCurrentTime(const Value: Double);
828
begin
829
  LastTime := Value - (FCurrentTime - LastTime);
830
  FOriginTime := FOriginTime + (FCurrentTime - Value);
831
  FCurrentTime := Value;
832
end;
833

834
// ------------------
835
// ------------------ TGLCustomCadencedComponent ------------------
836
// ------------------
837

838
// Destroy
839
//
840

841
destructor TGLCustomCadencedComponent.Destroy;
842
begin
843
  Cadencer := nil;
844
  inherited Destroy;
845
end;
846

847
// Notification
848
//
849

850
procedure TGLCustomCadencedComponent.Notification(AComponent: TComponent;
851
  Operation: TOperation);
852
begin
853
  if (Operation = opRemove) and (AComponent = FCadencer) then
854
    Cadencer := nil;
855
  inherited;
856
end;
857

858
// SetCadencer
859
//
860

861
procedure TGLCustomCadencedComponent.SetCadencer(const val: TGLCadencer);
862
begin
863
  if FCadencer <> val then
864
  begin
865
    if Assigned(FCadencer) then
866
      FCadencer.UnSubscribe(Self);
867
    FCadencer := val;
868
    if Assigned(FCadencer) then
869
      FCadencer.Subscribe(Self);
870
  end;
871
end;
872

873
// ---------------------------------------------------------------------
874
// ---------------------------------------------------------------------
875
// ---------------------------------------------------------------------
876
initialization
877
  // ---------------------------------------------------------------------
878
  // ---------------------------------------------------------------------
879
  // ---------------------------------------------------------------------
880

881
  RegisterClasses([TGLCadencer]);
882

883

884
  // Preparation for high resolution timer
885
  if not QueryPerformanceFrequency(vCounterFrequency) then
886
    vCounterFrequency := 0;
887

888
finalization
889
  FreeAndNil(vHandler);
890
  FreeAndNil(vASAPCadencerList);
891
end.
892