LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
    A simple component written by request from someone at the www.glscene.ru forums.
6
    Allows to view the FPS and do the usual Zoom and MoveAroundTarget stuff 
7
    that all demos usually have in themselves. All that is just by dropping 
8
    this component on the form.
9

10
    History :  
11
       14/12/10 - DaStr - Fixed compiler hint
12
       12/12/10 - Yar   - Adapted to using with TGLSceneForm
13
       01/07/10 - Yar   - Fixed zooming for FPC (by Rustam Asmandiarov aka Predator)
14
       17/06/10 - YP    - Fixed Zoom in/out inconsistence (mousewheel up/down inverted)
15
       11/06/10 - YP    - Fixed wheeldata can be equal to 0 in FormMouseWheel (div by 0 exception)
16
       21/01/10 - Yar   - Bugfixed zooming in design time (BugtrackerID = 2936266)
17
       25/12/09 - DaStr - Added OnMouseMove event (thanks YarUnderoaker)
18
       18/10/09 - DaStr - Added snoShowFPS option (thanks YarUnderoaker)
19
                             Fixed a small bug with FPS string
20
       29/09/07 - DaStr - Component now automaticly detects Form Caption
21
       24/03/07 - DaStr - Replaced GLWin32Viewer with GLViewer
22
                             (thanks Burkhard Carstens) (Bugtracker ID = 1684432)
23
                             Got rid of Types dependancy
24
       20/03/07 - DaStr - Improved SceneViewer detection
25
       02/03/07 - DaStr - Added default values to all properties
26
                             Added TGLSimpleNavigationOptions
27
                             Added TGLSimpleNavigationKeyCombination
28
                             Some renamings
29
                             Added TGLSimpleNavigation.Assign
30
                             MouseWheel is now handled by default
31
       06/02/07 - DaStr - Creation (donated to GLScene)
32
  
33

34
   Previous version history:
35
           v1.0   08 May        '2006  Creation
36
           v1.1   04 September  '2006  FreeNotification fix
37
                                       Automatic Form detection fix
38
           v1.2   11 September  '2006  Automatic SceneViewer detection
39
                                       FormCaption added
40
           v1.3   06 February   '2007  FPS is only updated in Run-Time now
41
                                       Donated to GLScene
42
}
43

44
unit GLSimpleNavigation;
45

46
interface
47

48
{$I GLScene.inc}
49

50
uses
51
  Classes, SysUtils, TypInfo, Forms, Controls, ExtCtrls,
52
   
53
  GLSceneForm, GLVectorGeometry, GLScene,
54
  GLViewer, GLStrings, GLCrossPlatform;
55

56
type
57

58
  TPoint = GLCrossPlatform.TGLPoint; // for Mouse Wheel
59

60
  TGLSimpleNavigationOption = (
61
    snoInvertMoveAroundX, snoInvertMoveAroundY, // MoveAroundTarget.
62
    snoInvertZoom, snoInvertMouseWheel, // Zoom.
63
    snoInvertRotateX, snoInvertRotateY, // RotateTarget.
64
    snoMouseWheelHandled, // MouseWheel.
65
    snoShowFPS // Show FPS
66
    );
67

68
  TGLSimpleNavigationOptions = set of TGLSimpleNavigationOption;
69

70
  TGLSimpleNavigationAction = (snaNone, snaMoveAroundTarget, snaZoom, snaRotateTarget, snaCustom);
71

72
  TGLSimpleNavigationKeyCombination = class;
73
  TSimpleNavigationCustomActionEvent =
74
    procedure(Sender: TGLSimpleNavigationKeyCombination; Shift: TShiftState; X, Y: Integer) of object;
75

76
  TGLSimpleNavigationKeyCombination = class(TCollectionItem)
77
  private
78
    FExitOnMatch: Boolean;
79
    FAction: TGLSimpleNavigationAction;
80
    FOnCustomAction: TSimpleNavigationCustomActionEvent;
81
    FShiftState: TShiftState;
82
  protected
83
    function GetDisplayName: string; override;
84
    procedure DoOnCustomAction(Shift: TShiftState; X, Y: Integer); virtual;
85
  public
86
    constructor Create(Collection: TCollection); override;
87
    procedure Assign(Source: TPersistent); override;
88
  published
89
    property ShiftState: TShiftState read FShiftState write FShiftState default [];
90
    property ExitOnMatch: Boolean read FExitOnMatch write FExitOnMatch default True;
91
    property Action: TGLSimpleNavigationAction read FAction write FAction default snaNone;
92
    property OnCustomAction: TSimpleNavigationCustomActionEvent read FOnCustomAction write FOnCustomAction;
93
  end;
94

95
  TGLSimpleNavigationKeyCombinations = class(TOwnedCollection)
96
  private
97
    function GetItems(Index: Integer): TGLSimpleNavigationKeyCombination;
98
    procedure SetItems(Index: Integer; const Value: TGLSimpleNavigationKeyCombination);
99
  public
100
    function Add: TGLSimpleNavigationKeyCombination; overload;
101
    function Add(const AShiftState: TShiftState; const AAction: TGLSimpleNavigationAction; const AExitOnMatch: Boolean = True): TGLSimpleNavigationKeyCombination; overload;
102
    property Items[Index: Integer]: TGLSimpleNavigationKeyCombination read GetItems write SetItems; default;
103
  end;
104

105
  TGLSimpleNavigation = class(TComponent)
106
  private
107
    FTimer: TTimer;
108
    FForm: TCustomForm;
109
    FGLSceneViewer: TGLSceneViewer;
110

111
    FOldX, FOldY: Integer;
112
    FFormCaption: string;
113
    FMoveAroundTargetSpeed: Single;
114
    FZoomSpeed: Single;
115
    FOptions: TGLSimpleNavigationOptions;
116
    FKeyCombinations: TGLSimpleNavigationKeyCombinations;
117
    FRotateTargetSpeed: Single;
118
    FOnMouseMove: TMouseMoveEvent;
119
    FSceneForm: Boolean;
120
    procedure ShowFPS(Sender: TObject);
121
    procedure ViewerMouseMove(Sender: TObject;
122
      Shift: TShiftState; X, Y: Integer);
123
    procedure ViewerMouseWheel(Sender: TObject; Shift: TShiftState;
124
      WheelDelta: Integer; MousePos: TGLPoint; var Handled: Boolean);
125

126
    procedure SetGLSceneViewer(const Value: TGLSceneViewer);
127
    procedure SetForm(const Value: TCustomForm);
128
    function StoreFormCaption: Boolean;
129
    function StoreMoveAroundTargetSpeed: Boolean;
130
    function StoreZoomSpeed: Boolean;
131
    procedure SetKeyCombinations(const Value: TGLSimpleNavigationKeyCombinations);
132
    function StoreRotateTargetSpeed: Boolean;
133
    procedure SetOptions(const Value: TGLSimpleNavigationOptions);
134
  protected
135
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
136
  public
137
    constructor Create(AOwner: TComponent); override;
138
    destructor Destroy; override;
139
    procedure Assign(Source: TPersistent); override;
140
  published
141
    property Form: TCustomForm read FForm write SetForm;
142
    property GLSceneViewer: TGLSceneViewer read FGLSceneViewer write SetGLSceneViewer;
143

144
    property ZoomSpeed: Single read FZoomSpeed write FZoomSpeed stored StoreZoomSpeed;
145
    property MoveAroundTargetSpeed: Single read FMoveAroundTargetSpeed write FMoveAroundTargetSpeed stored StoreMoveAroundTargetSpeed;
146
    property RotateTargetSpeed: Single read FRotateTargetSpeed write FRotateTargetSpeed stored StoreRotateTargetSpeed;
147

148
    property FormCaption: string read FFormCaption write FFormCaption stored StoreFormCaption;
149
    property Options: TGLSimpleNavigationOptions read FOptions write SetOptions default [snoMouseWheelHandled, snoShowFPS];
150
    property KeyCombinations: TGLSimpleNavigationKeyCombinations read FKeyCombinations write SetKeyCombinations;
151

152
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
153
  end;
154

155
implementation
156

157
const
158
  vFPSString = '%FPS';
159
  EPS = 0.001;
160

161
  { TGLSimpleNavigation }
162

163
procedure TGLSimpleNavigation.Assign(Source: TPersistent);
164
begin
165
  if Source is TGLSimpleNavigation then
166
  begin
167
    { Don't do that, because that might overide the original component's event handlers
168
    SetForm(TGLSimpleNavigation(Source).FForm);
169
    SetGLSceneViewer(TGLSimpleNavigation(Source).FGLSceneViewer);
170
    }
171
    FZoomSpeed := TGLSimpleNavigation(Source).FZoomSpeed;
172
    FMoveAroundTargetSpeed := TGLSimpleNavigation(Source).FMoveAroundTargetSpeed;
173
    FRotateTargetSpeed := TGLSimpleNavigation(Source).FRotateTargetSpeed;
174

175
    FFormCaption := TGLSimpleNavigation(Source).FFormCaption;
176
    FOptions := TGLSimpleNavigation(Source).FOptions;
177
    FKeyCombinations.Assign(TGLSimpleNavigation(Source).FKeyCombinations);
178
  end
179
  else
180
    inherited; // Die!
181
end;
182

183
constructor TGLSimpleNavigation.Create(AOwner: TComponent);
184
var
185
  I: Integer;
186
begin
187
  inherited;
188
  FKeyCombinations := TGLSimpleNavigationKeyCombinations.Create(Self, TGLSimpleNavigationKeyCombination);
189
  FKeyCombinations.Add([ssLeft, ssRight], snaZoom, True);
190
  FKeyCombinations.Add([ssLeft], snaMoveAroundTarget, True);
191
  FKeyCombinations.Add([ssRight], snaMoveAroundTarget, True);
192

193
  FMoveAroundTargetSpeed := 1;
194
  FRotateTargetSpeed := 1;
195
  FZoomSpeed := 1.5;
196
  FOptions := [snoMouseWheelHandled, snoShowFPS];
197
  FFormCaption := vFPSString;
198

199
  FTimer := TTimer.Create(nil);
200
  FTimer.OnTimer := ShowFPS;
201

202
  FOnMouseMove := nil;
203
  //Detect form
204
  if AOwner is TCustomForm then
205
    SetForm(TCustomForm(AOwner));
206

207
  //Detect SceneViewer
208
  if FForm <> nil then
209
  begin
210
    if FForm.ComponentCount <> 0 then
211
      for I := 0 to FForm.ComponentCount - 1 do
212
        if FForm.Components[I] is TGLSceneViewer then
213
        begin
214
          SetGLSceneViewer(TGLSceneViewer(FForm.Components[I]));
215
          Exit;
216
        end;
217
  end;
218
end;
219

220
destructor TGLSimpleNavigation.Destroy;
221
begin
222
  FTimer.Free;
223
  FKeyCombinations.Free;
224

225
  if FForm <> nil then
226
    TForm(FForm).OnMouseWheel := nil;
227

228
  if FGLSceneViewer <> nil then
229
    FGLSceneViewer.OnMouseMove := nil;
230

231
  inherited;
232
end;
233

234
procedure TGLSimpleNavigation.ViewerMouseWheel(Sender: TObject;
235
  Shift: TShiftState; WheelDelta: Integer; MousePos: TGLPoint;
236
  var Handled: Boolean);
237
var
238
  Sign: SmallInt;
239
  lCamera: TGLCamera;
240
begin
241
  if (csDesigning in ComponentState) or (WheelDelta = 0) then
242
    Exit;
243

244
  if snoInvertMouseWheel in FOptions then
245
    Sign := 1
246
  else
247
    Sign := -1;
248

249
  if FGLSceneViewer <> nil then
250
    lCamera := FGLSceneViewer.Camera
251
  else if FSceneForm then
252
    lCamera := TGLSceneForm(FForm).Camera
253
  else
254
    lCamera := nil;
255

256
  if Assigned(lCamera) then
257
  begin
258
    if lCamera.CameraStyle = csOrthogonal then
259
      lCamera.FocalLength := FGLSceneViewer.Camera.FocalLength
260
        / Power(FZoomSpeed, Sign * WheelDelta div Abs(WheelDelta))
261
    else
262
      lCamera.AdjustDistanceToTarget(
263
        Power(FZoomSpeed, Sign * WheelDelta div Abs(WheelDelta)));
264
  end;
265

266
  Handled := snoMouseWheelHandled in FOptions;
267
end;
268

269
procedure TGLSimpleNavigation.ViewerMouseMove(Sender: TObject;
270
  Shift: TShiftState; X, Y: Integer);
271

272
var
273
  lCamera: TGLCamera;
274

275
  procedure DoZoom;
276
  var
277
    Sign: SmallInt;
278
  begin
279
    if snoInvertZoom in FOptions then
280
      Sign := -1
281
    else
282
      Sign := 1;
283
    lCamera.AdjustDistanceToTarget(
284
      Power(FZoomSpeed, Sign * (Y - FOldY) / 20));
285
  end;
286

287
  procedure DoMoveAroundTarget;
288
  var
289
    SignX: SmallInt;
290
    SignY: SmallInt;
291
  begin
292
    if snoInvertMoveAroundX in FOptions then
293
      SignX := -1
294
    else
295
      SignX := 1;
296

297
    if snoInvertMoveAroundY in FOptions then
298
      SignY := -1
299
    else
300
      SignY := 1;
301

302
    lCamera.MoveAroundTarget(SignX * FMoveAroundTargetSpeed * (FOldY - Y),
303
      SignY * FMoveAroundTargetSpeed * (FOldX - X));
304
  end;
305

306
  procedure DoRotateTarget;
307
  var
308
    SignX: SmallInt;
309
    SignY: SmallInt;
310
  begin
311
    if snoInvertRotateX in FOptions then
312
      SignX := -1
313
    else
314
      SignX := 1;
315

316
    if snoInvertRotateY in FOptions then
317
      SignY := -1
318
    else
319
      SignY := 1;
320

321
    lCamera.RotateTarget(SignY * FRotateTargetSpeed * (FOldY - Y),
322
      SignX * FRotateTargetSpeed * (FOldX - X));
323
  end;
324

325
var
326
  I: Integer;
327

328
begin
329
  if csDesigning in ComponentState then
330
    exit;
331

332
  if FGLSceneViewer <> nil then
333
    lCamera := FGLSceneViewer.Camera
334
  else if FSceneForm then
335
    lCamera := TGLSceneForm(FForm).Camera;
336

337
  if Assigned(lCamera) then
338
  begin
339
    if FKeyCombinations.Count <> 0 then
340
      for I := 0 to FKeyCombinations.Count - 1 do
341
        if FKeyCombinations[I].FShiftState <= Shift then
342
        begin
343
          case FKeyCombinations[I].FAction of
344
            snaNone: ; //Ignore.
345
            snaMoveAroundTarget: DoMoveAroundTarget;
346
            snaZoom: DoZoom;
347
            snaRotateTarget: DoRotateTarget;
348
            snaCustom: FKeyCombinations[I].DoOnCustomAction(Shift, X, Y);
349
          else
350
            Assert(False, glsErrorEx + glsUnknownType);
351
          end;
352

353
          if FKeyCombinations[I].FExitOnMatch then
354
            Break;
355
        end;
356
  end;
357

358
  FOldX := X;
359
  FOldY := Y;
360

361
  if Assigned(FOnMouseMove) then
362
    FOnMouseMove(Self, Shift, X, Y);
363
end;
364

365
procedure TGLSimpleNavigation.Notification(AComponent: TComponent;
366
  Operation: TOperation);
367
begin
368
  inherited;
369
  if (AComponent = FGLSceneViewer) and (Operation = opRemove) then
370
    FGLSceneViewer := nil;
371
  if (AComponent = FForm) and (Operation = opRemove) then
372
    FForm := nil;
373
end;
374

375
procedure TGLSimpleNavigation.SetKeyCombinations(
376
  const Value: TGLSimpleNavigationKeyCombinations);
377
begin
378
  FKeyCombinations.Assign(Value);
379
end;
380

381
procedure TGLSimpleNavigation.SetForm(const Value: TCustomForm);
382
begin
383
  if FForm <> nil then
384
  begin
385
    FForm.RemoveFreeNotification(Self);
386
    TForm(FForm).OnMouseWheel := nil;
387

388
    if FSceneForm then TForm(FForm).OnMouseMove := nil;
389
    FSceneForm := False;
390
  end;
391

392
  FForm := Value;
393

394
  if FForm <> nil then
395
  begin
396
    if FFormCaption = vFPSString then
397
      FFormCaption := FForm.Caption + ' - ' + vFPSString;
398
    TForm(FForm).OnMouseWheel := ViewerMouseWheel;
399
    FForm.FreeNotification(Self);
400
{$IFDEF GLS_MULTITHREAD}
401
    if FForm is TGLSceneForm then
402
    begin
403
      FSceneForm := True;
404
      TForm(FForm).OnMouseMove := ViewerMouseMove;
405
    end;
406
{$ENDIF}
407
  end;
408
end;
409

410
procedure TGLSimpleNavigation.SetGLSceneViewer(
411
  const Value: TGLSceneViewer);
412
begin
413
  if FGLSceneViewer <> nil then
414
  begin
415
    FGLSceneViewer.RemoveFreeNotification(Self);
416
    FGLSceneViewer.OnMouseMove := nil;
417

418
    FGLSceneViewer.OnMouseWheel := nil;
419

420
  end;
421

422
  FGLSceneViewer := Value;
423

424
  if FGLSceneViewer <> nil then
425
  begin
426
    FGLSceneViewer.OnMouseWheel := ViewerMouseWheel;
427
    FGLSceneViewer.OnMouseMove := ViewerMouseMove;
428
    FGLSceneViewer.FreeNotification(Self);
429
  end;
430
end;
431

432
procedure TGLSimpleNavigation.ShowFPS(Sender: TObject);
433
var
434
  Index: Integer;
435
  Temp: string;
436
begin
437
  if (FForm <> nil) and
438
    not (csDesigning in ComponentState) and
439
    (snoShowFPS in FOptions) then
440
  begin
441
    Temp := FFormCaption;
442
    Index := Pos(vFPSString, Temp);
443
    if FForm is TGLSceneForm then
444
    begin
445
      if Index <> 0 then
446
      begin
447
        Delete(Temp, Index, Length(vFPSString));
448
        Insert(Format('%.*f FPS', [1, TGLSceneForm(FForm).Buffer.FramesPerSecond]), Temp, Index);
449
      end;
450
      TGLSceneForm(FForm).Buffer.ResetPerformanceMonitor;
451
    end
452
    else if Assigned(FGLSceneViewer) then
453
    begin
454
      if Index <> 0 then
455
      begin
456
        Delete(Temp, Index, Length(vFPSString));
457
        Insert(Format('%.*f FPS', [1, FGLSceneViewer.Buffer.FramesPerSecond]), Temp, Index);
458
      end;
459
      FGLSceneViewer.ResetPerformanceMonitor;
460
    end;
461
    FForm.Caption := Temp;
462
  end;
463
end;
464

465
function TGLSimpleNavigation.StoreFormCaption: Boolean;
466
begin
467
  Result := (FFormCaption <> vFPSString);
468
end;
469

470
function TGLSimpleNavigation.StoreMoveAroundTargetSpeed: Boolean;
471
begin
472
  Result := Abs(FMoveAroundTargetSpeed - 1) > EPS;
473
end;
474

475
function TGLSimpleNavigation.StoreZoomSpeed: Boolean;
476
begin
477
  Result := Abs(FZoomSpeed - 1.5) > EPS;
478
end;
479

480
function TGLSimpleNavigation.StoreRotateTargetSpeed: Boolean;
481
begin
482
  Result := Abs(FRotateTargetSpeed - 1) > EPS;
483
end;
484

485
procedure TGLSimpleNavigation.SetOptions(
486
  const Value: TGLSimpleNavigationOptions);
487
begin
488
  if FOptions <> Value then
489
  begin
490
    FOptions := Value;
491

492
  end;
493
end;
494

495
{ TGLSimpleNavigationKeyCombination }
496

497
procedure TGLSimpleNavigationKeyCombination.Assign(Source: TPersistent);
498
begin
499
  if Source is TGLSimpleNavigationKeyCombination then
500
  begin
501
    FExitOnMatch := TGLSimpleNavigationKeyCombination(Source).FExitOnMatch;
502
    FAction := TGLSimpleNavigationKeyCombination(Source).FAction;
503
    FOnCustomAction := TGLSimpleNavigationKeyCombination(Source).FOnCustomAction;
504
    FShiftState := TGLSimpleNavigationKeyCombination(Source).FShiftState;
505
  end
506
  else
507
    inherited; // Die!
508
end;
509

510
constructor TGLSimpleNavigationKeyCombination.Create(Collection: TCollection);
511
begin
512
  inherited;
513
  FAction := snaNone;
514
  FExitOnMatch := True;
515
end;
516

517
procedure TGLSimpleNavigationKeyCombination.DoOnCustomAction(
518
  Shift: TShiftState; X, Y: Integer);
519
begin
520
  if Assigned(FOnCustomAction) then
521
    FOnCustomAction(Self, Shift, X, Y);
522
end;
523

524
function TGLSimpleNavigationKeyCombination.GetDisplayName: string;
525
begin
526
  Result := GetSetProp(Self, 'ShiftState', True) + '  -  ' +
527
    GetEnumName(TypeInfo(TGLSimpleNavigationAction), Integer(FAction));
528
end;
529

530
{ TGLSimpleNavigationKeyCombinations }
531

532
function TGLSimpleNavigationKeyCombinations.Add: TGLSimpleNavigationKeyCombination;
533
begin
534
  Result := TGLSimpleNavigationKeyCombination(inherited Add);
535
end;
536

537
function TGLSimpleNavigationKeyCombinations.Add(
538
  const AShiftState: TShiftState; const AAction: TGLSimpleNavigationAction;
539
  const AExitOnMatch: Boolean): TGLSimpleNavigationKeyCombination;
540
begin
541
  Result := Add;
542
  with Result do
543
  begin
544
    FShiftState := AShiftState;
545
    FAction := AAction;
546
    FExitOnMatch := AExitOnMatch;
547
  end;
548
end;
549

550
function TGLSimpleNavigationKeyCombinations.GetItems(
551
  Index: Integer): TGLSimpleNavigationKeyCombination;
552
begin
553
  Result := TGLSimpleNavigationKeyCombination(inherited GetItem(Index));
554
end;
555

556
procedure TGLSimpleNavigationKeyCombinations.SetItems(Index: Integer;
557
  const Value: TGLSimpleNavigationKeyCombination);
558
begin
559
  inherited SetItem(Index, Value);
560
end;
561

562
end.
563

564