2
// This unit is part of the GLScene Engine https://github.com/glscene
5
Base classes and structures for GLScene.
48
{Defines which features are taken from the master object. }49
TGLProxyObjectOption = (pooEffects, pooObjects, pooTransformation);
50
TGLProxyObjectOptions = set of TGLProxyObjectOption;
52
TGLCameraInvarianceMode = (cimNone, cimPosition, cimOrientation);
54
TGLSceneViewerMode = (svmDisabled, svmDefault, svmNavigation, svmGizmo);
57
cDefaultProxyOptions = [pooEffects, pooObjects, pooTransformation];
58
GLSCENE_REVISION = '$Revision: 6695$';
59
GLSCENE_VERSION = '1.5.0.%s';
63
TNormalDirection = (ndInside, ndOutside);
65
// used to describe only the changes in an object,
66
// which have to be reflected in the scene
67
TObjectChange = (ocTransformation, ocAbsoluteMatrix, ocInvAbsoluteMatrix,
69
TObjectChanges = set of TObjectChange;
71
TObjectBBChange = (oBBcChild, oBBcStructure);
72
TObjectBBChanges = set of TObjectBBChange;
74
// flags for design notification
75
TSceneOperation = (soAdd, soRemove, soMove, soRename, soSelect, soBeginUpdate,
78
{Options for the rendering context.79
roSoftwareMode: force software rendering.
80
roDoubleBuffer: enables double-buffering.
81
roRenderToWindows: ignored (legacy).
82
roTwoSideLighting: enables two-side lighting model.
83
roStereo: enables stereo support in the driver (dunno if it works,
84
I don't have a stereo device to test...)
85
roDestinationAlpha: request an Alpha channel for the rendered output
86
roNoColorBuffer: don't request a color buffer (color depth setting ignored)
87
roNoColorBufferClear: do not clear the color buffer automatically, if the
88
whole viewer is fully repainted each frame, this can improve framerate
89
roNoSwapBuffers: don't perform RenderingContext.SwapBuffers after rendering
90
roNoDepthBufferClear: do not clear the depth buffer automatically. Useful for
92
roForwardContext: force OpenGL forward context }
93
TContextOption = (roSoftwareMode, roDoubleBuffer, roStencilBuffer,
94
roRenderToWindow, roTwoSideLighting, roStereo,
95
roDestinationAlpha, roNoColorBuffer, roNoColorBufferClear,
96
roNoSwapBuffers, roNoDepthBufferClear, roDebugContext,
97
roForwardContext, roOpenGL_ES2_Context);
98
TContextOptions = set of TContextOption;
100
// IDs for limit determination
101
TLimitType = (limClipPlanes, limEvalOrder, limLights, limListNesting,
102
limModelViewStack, limNameStack, limPixelMapTable, limProjectionStack,
103
limTextureSize, limTextureStack, limViewportDims, limAccumAlphaBits,
104
limAccumBlueBits, limAccumGreenBits, limAccumRedBits, limAlphaBits,
105
limAuxBuffers, limBlueBits, limGreenBits, limRedBits, limIndexBits,
106
limStereo, limDoubleBuffer, limSubpixelBits, limDepthBits, limStencilBits,
109
TGLBaseSceneObject = class;
110
TGLSceneObjectClass = class of TGLBaseSceneObject;
111
TGLCustomSceneObject = class;
113
TGLBehaviour = class;
114
TGLBehaviourClass = class of TGLBehaviour;
115
TGLBehaviours = class;
116
TGLObjectEffect = class;
117
TGLObjectEffectClass = class of TGLObjectEffect;
118
TGLObjectEffects = class;
119
TGLSceneBuffer = class;
121
{Possible styles/options for a GLScene object.123
osDirectDraw : object shall not make use of compiled call lists, but issue
124
direct calls each time a render should be performed.
125
osIgnoreDepthBuffer : object is rendered with depth test disabled,
126
this is true for its children too.
127
osNoVisibilityCulling : whatever the VisibilityCulling setting,
128
it will be ignored and the object rendered
133
osNoVisibilityCulling);
134
TGLObjectStyles = set of TGLObjectStyle;
136
{Interface to objects that need initialization }137
IGLInitializable = interface
138
['{EA40AE8E-79B3-42F5-ADF1-7A901B665E12}']139
procedure InitializeObject(ASender: TObject; const ARci:
140
TGLRenderContextInfo);
143
// TGLInitializableObjectList
145
{ Just a list of objects that support IGLInitializable. }146
TGLInitializableObjectList = class(TList)
148
function GetItems(const Index: Integer): IGLInitializable;
149
procedure PutItems(const Index: Integer; const Value: IGLInitializable);
151
function Add(const Item: IGLInitializable): Integer;
152
property Items[const Index: Integer]: IGLInitializable read GetItems write
156
{Base class for all scene objects.157
A scene object is part of scene hierarchy (each scene object can have
158
multiple children), this hierarchy primarily defines transformations
159
(each child coordinates are relative to its parent), but is also used
160
for depth-sorting, bounding and visibility culling purposes.
161
Subclasses implement either visual scene objects (that are made to be
162
visible at runtime, like a Cube) or structural objects (that influence
163
rendering or are used for varied structural manipulations,
164
like the ProxyObject).
165
To add children at runtime, use the AddNewChild method of TGLBaseSceneObject;
166
other children manipulations methods and properties are provided (to browse,
167
move and delete them). Using the regular TComponent methods is not
170
TGLBaseSceneObject = class(TGLCoordinatesUpdateAbleComponent)
172
FAbsoluteMatrix, FInvAbsoluteMatrix: PMatrix;
173
FLocalMatrix: PMatrix;
174
FObjectStyle: TGLObjectStyles;
175
FListHandle: TGLListHandle; // created on 1st use
176
FPosition: TGLCoordinates;
177
FDirection, FUp: TGLCoordinates;
178
FScaling: TGLCoordinates;
179
FChanges: TObjectChanges;
180
FParent: TGLBaseSceneObject;
182
FBBChanges: TObjectBBChanges;
183
FBoundingBoxPersonalUnscaled: THmgBoundingBox;
184
FBoundingBoxOfChildren: THmgBoundingBox;
185
FBoundingBoxIncludingChildren: THmgBoundingBox;
186
FChildren: TPersistentObjectList; // created on 1st use
188
FUpdateCount: Integer;
190
FRotation: TGLCoordinates; // current rotation angles
191
FIsCalculating: Boolean;
192
FObjectsSorting: TGLObjectsSorting;
193
FVisibilityCulling: TGLVisibilityCulling;
194
FOnProgress: TGLProgressEvent;
195
FOnAddedToParent: TNotifyEvent;
196
FGLBehaviours: TGLBehaviours;
197
FGLObjectEffects: TGLObjectEffects;
199
FOnPicked: TNotifyEvent;
203
// FOriginalFiler: TFiler; //used to allow persistent events in behaviours & effects
204
{If somebody could look at DefineProperties, ReadBehaviours, ReadEffects and verify code205
is safe to use then it could be uncommented}
206
function Get(Index: Integer): TGLBaseSceneObject;
207
function GetCount: Integer;
208
function GetIndex: Integer;
209
procedure SetParent(const val: TGLBaseSceneObject);
210
procedure SetIndex(aValue: Integer);
211
procedure SetDirection(AVector: TGLCoordinates);
212
procedure SetUp(AVector: TGLCoordinates);
213
function GetMatrix: TMatrix;
214
procedure SetMatrix(const aValue: TMatrix);
215
procedure SetPosition(APosition: TGLCoordinates);
216
procedure SetPitchAngle(AValue: Single);
217
procedure SetRollAngle(AValue: Single);
218
procedure SetTurnAngle(AValue: Single);
219
procedure SetRotation(aRotation: TGLCoordinates);
220
function GetPitchAngle: Single;
221
function GetTurnAngle: Single;
222
function GetRollAngle: Single;
223
procedure SetShowAxes(AValue: Boolean);
224
procedure SetScaling(AValue: TGLCoordinates);
225
procedure SetObjectsSorting(const val: TGLObjectsSorting);
226
procedure SetVisibilityCulling(const val: TGLVisibilityCulling);
227
procedure SetBehaviours(const val: TGLBehaviours);
228
function GetBehaviours: TGLBehaviours;
229
procedure SetEffects(const val: TGLObjectEffects);
230
function GetEffects: TGLObjectEffects;
231
function GetAbsoluteAffineScale: TAffineVector;
232
function GetAbsoluteScale: TVector;
233
procedure SetAbsoluteAffineScale(const Value: TAffineVector);
234
procedure SetAbsoluteScale(const Value: TVector);
235
function GetAbsoluteMatrix: TMatrix;
236
procedure SetAbsoluteMatrix(const Value: TMatrix);
237
procedure SetBBChanges(const Value: TObjectBBChanges);
239
procedure Loaded; override;
240
procedure SetScene(const Value: TGLScene); virtual;
241
procedure DefineProperties(Filer: TFiler); override;
242
procedure WriteBehaviours(stream: TStream);
243
procedure ReadBehaviours(stream: TStream);
244
procedure WriteEffects(stream: TStream);
245
procedure ReadEffects(stream: TStream);
246
procedure WriteRotations(stream: TStream);
247
procedure ReadRotations(stream: TStream);
248
function GetVisible: Boolean; virtual;
249
function GetPickable: Boolean; virtual;
250
procedure SetVisible(aValue: Boolean); virtual;
251
procedure SetPickable(aValue: Boolean); virtual;
252
procedure SetAbsolutePosition(const v: TVector);
253
function GetAbsolutePosition: TVector;
254
procedure SetAbsoluteUp(const v: TVector);
255
function GetAbsoluteUp: TVector;
256
procedure SetAbsoluteDirection(const v: TVector);
257
function GetAbsoluteDirection: TVector;
258
function GetAbsoluteAffinePosition: TAffineVector;
259
procedure SetAbsoluteAffinePosition(const Value: TAffineVector);
260
procedure SetAbsoluteAffineUp(const v: TAffineVector);
261
function GetAbsoluteAffineUp: TAffineVector;
262
procedure SetAbsoluteAffineDirection(const v: TAffineVector);
263
function GetAbsoluteAffineDirection: TAffineVector;
264
procedure RecTransformationChanged;
265
procedure DrawAxes(var rci: TGLRenderContextInfo; pattern: Word);
266
procedure GetChildren(AProc: TGetChildProc; Root: TComponent); override;
267
// Should the object be considered as blended for sorting purposes?
268
function Blended: Boolean; virtual;
269
procedure RebuildMatrix;
270
procedure SetName(const NewName: TComponentName); override;
271
procedure SetParentComponent(Value: TComponent); override;
272
procedure DestroyHandle; dynamic;
273
procedure DestroyHandles;
274
procedure DeleteChildCameras;
275
procedure DoOnAddedToParent; virtual;
277
{ Used to re-calculate BoundingBoxes every time we need it.278
GetLocalUnscaleBB() must return the local BB, not the axis-aligned one.
280
By default it is calculated from AxisAlignedBoundingBoxUnscaled and
281
BarycenterAbsolutePosition, but for most objects there is a more
282
efficient method, that's why it is virtual. }
283
procedure CalculateBoundingBoxPersonalUnscaled(var ANewBoundingBox:
284
THmgBoundingBox); virtual;
287
constructor Create(AOwner: TComponent); override;
288
constructor CreateAsChild(aParentOwner: TGLBaseSceneObject);
289
destructor Destroy; override;
290
procedure Assign(Source: TPersistent); override;
292
{ Controls and adjusts internal optimizations based on object's style.293
Advanced user only. }
294
property ObjectStyle: TGLObjectStyles read FObjectStyle write FObjectStyle;
296
{ Returns the handle to the object's build list.297
Use with caution! Some objects don't support buildlists! }
298
function GetHandle(var rci: TGLRenderContextInfo): Cardinal; virtual;
299
function ListHandleAllocated: Boolean;
301
{ The local transformation (relative to parent).302
If you're *sure* the local matrix is up-to-date, you may use LocalMatrix
303
for quicker access. }
304
property Matrix: TMatrix read GetMatrix write SetMatrix;
306
function MatrixAsAddress: PMatrix;
307
{ Holds the local transformation (relative to parent).308
If you're not *sure* the local matrix is up-to-date, use Matrix property. }
309
property LocalMatrix: PMatrix read FLocalMatrix;
310
{ Forces the local matrix to the specified value.311
AbsoluteMatrix, InverseMatrix, etc. will honour that change, but
312
may become invalid if the specified matrix isn't orthonormal (can
313
be used for specific rendering or projection effects).
314
The local matrix will be reset by the next TransformationChanged,
315
position or attitude change. }
316
procedure ForceLocalMatrix(const aMatrix: TMatrix);
318
{ See AbsoluteMatrix. }319
function AbsoluteMatrixAsAddress: PMatrix;
320
{ Holds the absolute transformation matrix.321
If you're not *sure* the absolute matrix is up-to-date,
322
use the AbsoluteMatrix property, this one may be nil... }
323
property DirectAbsoluteMatrix: PMatrix read FAbsoluteMatrix;
325
{ Calculates the object's absolute inverse matrix.326
Multiplying an absolute coordinate with this matrix gives a local coordinate.
327
The current implem uses transposition(AbsoluteMatrix), which is true
328
unless you're using some scaling... }
329
function InvAbsoluteMatrix: TMatrix;
330
{ See InvAbsoluteMatrix. }331
function InvAbsoluteMatrixAsAddress: PMatrix;
333
{ The object's absolute matrix by composing all local matrices.334
Multiplying a local coordinate with this matrix gives an absolute coordinate. }
335
property AbsoluteMatrix: TMatrix read GetAbsoluteMatrix write
338
{ Direction vector in absolute coordinates. }339
property AbsoluteDirection: TVector read GetAbsoluteDirection write
340
SetAbsoluteDirection;
341
property AbsoluteAffineDirection: TAffineVector read
342
GetAbsoluteAffineDirection write SetAbsoluteAffineDirection;
344
{ Scale vector in absolute coordinates.345
Warning: SetAbsoluteScale() does not work correctly at the moment. }
346
property AbsoluteScale: TVector read GetAbsoluteScale write
348
property AbsoluteAffineScale: TAffineVector read GetAbsoluteAffineScale write
349
SetAbsoluteAffineScale;
351
{ Up vector in absolute coordinates. }352
property AbsoluteUp: TVector read GetAbsoluteUp write SetAbsoluteUp;
353
property AbsoluteAffineUp: TAffineVector read GetAbsoluteAffineUp write
356
{ Calculate the right vector in absolute coordinates. }357
function AbsoluteRight: TVector;
359
{ Calculate the left vector in absolute coordinates. }360
function AbsoluteLeft: TVector;
362
{ Computes and allows to set the object's absolute coordinates. }363
property AbsolutePosition: TVector read GetAbsolutePosition write
365
property AbsoluteAffinePosition: TAffineVector read GetAbsoluteAffinePosition
366
write SetAbsoluteAffinePosition;
367
function AbsolutePositionAsAddress: PVector;
369
{ Returns the Absolute X Vector expressed in local coordinates. }370
function AbsoluteXVector: TVector;
371
{ Returns the Absolute Y Vector expressed in local coordinates. }372
function AbsoluteYVector: TVector;
373
{ Returns the Absolute Z Vector expressed in local coordinates. }374
function AbsoluteZVector: TVector;
376
{ Converts a vector/point from absolute coordinates to local coordinates. }377
function AbsoluteToLocal(const v: TVector): TVector; overload;
378
{ Converts a vector from absolute coordinates to local coordinates. }379
function AbsoluteToLocal(const v: TAffineVector): TAffineVector; overload;
380
{ Converts a vector/point from local coordinates to absolute coordinates. }381
function LocalToAbsolute(const v: TVector): TVector; overload;
382
{ Converts a vector from local coordinates to absolute coordinates. }383
function LocalToAbsolute(const v: TAffineVector): TAffineVector; overload;
385
{ Returns the Right vector (based on Up and Direction) }386
function Right: TVector;
387
{ Returns the Left vector (based on Up and Direction) }388
function LeftVector: TVector;
390
{ Returns the Right vector (based on Up and Direction) }391
function AffineRight: TAffineVector;
392
{ Returns the Left vector (based on Up and Direction) }393
function AffineLeftVector: TAffineVector;
395
{ Calculates the object's square distance to a point/object.396
pt is assumed to be in absolute coordinates,
397
AbsolutePosition is considered as being the object position. }
398
function SqrDistanceTo(anObject: TGLBaseSceneObject): Single; overload;
399
function SqrDistanceTo(const pt: TVector): Single; overload;
400
function SqrDistanceTo(const pt: TAffineVector): Single; overload;
402
{ Computes the object's distance to a point/object.403
Only objects AbsolutePositions are considered. }
404
function DistanceTo(anObject: TGLBaseSceneObject): Single; overload;
405
function DistanceTo(const pt: TAffineVector): Single; overload;
406
function DistanceTo(const pt: TVector): Single; overload;
408
{ Calculates the object's barycenter in absolute coordinates.409
Default behaviour is to consider Barycenter=AbsolutePosition
410
(whatever the number of children).
411
SubClasses where AbsolutePosition is not the barycenter should
412
override this method as it is used for distance calculation, during
413
rendering for instance, and may lead to visual inconsistencies. }
414
function BarycenterAbsolutePosition: TVector; virtual;
415
{ Calculates the object's barycenter distance to a point. }416
function BarycenterSqrDistanceTo(const pt: TVector): Single;
418
{ Shall returns the object's axis aligned extensions.419
The dimensions are measured from object center and are expressed
420
<i>with</i> scale accounted for, in the object's coordinates
421
(not in absolute coordinates).
422
Default value is half the object's Scale. }
423
function AxisAlignedDimensions: TVector; virtual;
424
function AxisAlignedDimensionsUnscaled: TVector; virtual;
425
{Calculates and return the AABB for the object.426
The AABB is currently calculated from the BB.
427
There is no caching scheme for them. }
428
function AxisAlignedBoundingBox(const AIncludeChilden: Boolean = True): TAABB;
429
function AxisAlignedBoundingBoxUnscaled(const AIncludeChilden: Boolean = True): TAABB;
430
function AxisAlignedBoundingBoxAbsolute(const AIncludeChilden: Boolean =
431
True; const AUseBaryCenter: Boolean = False): TAABB;
433
{Advanced AABB functions that use a caching scheme.434
Also they include children and use BaryCenter. }
435
function AxisAlignedBoundingBoxEx: TAABB;
436
function AxisAlignedBoundingBoxAbsoluteEx: TAABB;
438
{Calculates and return the Bounding Box for the object.439
The BB is calculated each time this method is invoked,
440
based on the AxisAlignedDimensions of the object and that of its
442
There is no caching scheme for them. }
443
function BoundingBox(const AIncludeChilden: Boolean = True; const
444
AUseBaryCenter: Boolean = False): THmgBoundingBox;
445
function BoundingBoxUnscaled(const AIncludeChilden: Boolean = True; const
446
AUseBaryCenter: Boolean = False): THmgBoundingBox;
447
function BoundingBoxAbsolute(const AIncludeChilden: Boolean = True; const
448
AUseBaryCenter: Boolean = False): THmgBoundingBox;
450
{Advanced BB functions that use a caching scheme.451
Also they include children and use BaryCenter. }
452
function BoundingBoxPersonalUnscaledEx: THmgBoundingBox;
453
function BoundingBoxOfChildrenEx: THmgBoundingBox;
454
function BoundingBoxIncludingChildrenEx: THmgBoundingBox;
456
{Max distance of corners of the BoundingBox. }457
function BoundingSphereRadius: Single;
458
function BoundingSphereRadiusUnscaled: Single;
460
{Indicates if a point is within an object. 461
Given coordinate is an absolute coordinate.
462
Linear or surfacic objects shall always return False.
463
Default value is based on AxisAlignedDimension and a cube bounding. }
464
function PointInObject(const point: TVector): Boolean; virtual;
465
{Request to determine an intersection with a casted ray. 466
Given coordinates & vector are in absolute coordinates, rayVector
468
rayStart may be a point inside the object, allowing retrieval of
469
the multiple intersects of the ray.
470
When intersectXXX parameters are nil (default) implementation should
471
take advantage of this to optimize calculus, if not, and an intersect
472
is found, non nil parameters should be defined.
473
The intersectNormal needs NOT be normalized by the implementations.
474
Default value is based on bounding sphere. }
475
function RayCastIntersect(const rayStart, rayVector: TVector;
476
intersectPoint: PVector = nil;
477
intersectNormal: PVector = nil): Boolean; virtual;
478
{Request to generate silhouette outlines.479
Default implementation assumes the objects is a sphere of
480
AxisAlignedDimensionUnscaled size. Subclasses may choose to return
481
nil instead, which will be understood as an empty silhouette. }
482
function GenerateSilhouette(const silhouetteParameters:
483
TGLSilhouetteParameters): TGLSilhouette; virtual;
485
property Children[Index: Integer]: TGLBaseSceneObject read Get; default;
486
property Count: Integer read GetCount;
487
property Index: Integer read GetIndex write SetIndex;
488
// Create a new scene object and add it to this object as new child
489
function AddNewChild(AChild: TGLSceneObjectClass): TGLBaseSceneObject; dynamic;
490
// Create a new scene object and add it to this object as first child
491
function AddNewChildFirst(AChild: TGLSceneObjectClass): TGLBaseSceneObject; dynamic;
492
procedure AddChild(AChild: TGLBaseSceneObject); dynamic;
493
function GetOrCreateBehaviour(aBehaviour: TGLBehaviourClass): TGLBehaviour;
494
function AddNewBehaviour(aBehaviour: TGLBehaviourClass): TGLBehaviour;
496
function GetOrCreateEffect(anEffect: TGLObjectEffectClass): TGLObjectEffect;
497
function AddNewEffect(anEffect: TGLObjectEffectClass): TGLObjectEffect;
499
function HasSubChildren: Boolean;
500
procedure DeleteChildren; dynamic;
501
procedure Insert(AIndex: Integer; AChild: TGLBaseSceneObject); dynamic;
502
{Takes a scene object out of the child list, but doesn't destroy it.503
If 'KeepChildren' is true its children will be kept as new children
504
in this scene object. }
505
procedure Remove(aChild: TGLBaseSceneObject; keepChildren: Boolean); dynamic;
506
function IndexOfChild(aChild: TGLBaseSceneObject): Integer;
507
function FindChild(const aName: string; ownChildrenOnly: Boolean):
509
{The "safe" version of this procedure checks if indexes are inside510
the list. If not, no exception if raised. }
511
procedure ExchangeChildrenSafe(anIndex1, anIndex2: Integer);
512
{The "regular" version of this procedure does not perform any checks513
and calls FChildren.Exchange directly. User should/can perform range
515
procedure ExchangeChildren(anIndex1, anIndex2: Integer);
516
{These procedures are safe. }517
procedure MoveChildUp(anIndex: Integer);
518
procedure MoveChildDown(anIndex: Integer);
519
procedure MoveChildFirst(anIndex: Integer);
520
procedure MoveChildLast(anIndex: Integer);
521
procedure DoProgress(const progressTime: TProgressTimes); override;
522
procedure MoveTo(newParent: TGLBaseSceneObject); dynamic;
527
procedure BeginUpdate; virtual;
528
procedure EndUpdate; virtual;
529
{Make object-specific geometry description here.530
Subclasses should MAINTAIN OpenGL states (restore the states if
531
they were altered). }
532
procedure BuildList(var rci: TGLRenderContextInfo); virtual;
533
function GetParentComponent: TComponent; override;
534
function HasParent: Boolean; override;
535
function IsUpdating: Boolean;
536
// Moves the object along the Up vector (move up/down)
537
procedure Lift(ADistance: Single);
538
// Moves the object along the direction vector
539
procedure Move(ADistance: Single);
540
// Translates the object
541
procedure Translate(tx, ty, tz: Single);
542
procedure MoveObjectAround(anObject: TGLBaseSceneObject;
543
pitchDelta, turnDelta: Single);
544
procedure MoveObjectAllAround(anObject: TGLBaseSceneObject;
545
pitchDelta, turnDelta: Single);
546
procedure Pitch(angle: Single);
547
procedure Roll(angle: Single);
548
procedure Turn(angle: Single);
550
{ Sets all rotations to zero and restores default Direction/Up.551
Using this function then applying roll/pitch/turn in the order that
552
suits you, you can give an "absolute" meaning to rotation angles
553
(they are still applied locally though).
554
Scale and Position are not affected. }
555
procedure ResetRotations;
556
{Reset rotations and applies them back in the specified order. }557
procedure ResetAndPitchTurnRoll(const degX, degY, degZ: Single);
559
{Applies rotations around absolute X, Y and Z axis. }560
procedure RotateAbsolute(const rx, ry, rz: Single); overload;
561
{Applies rotations around the absolute given vector (angle in degrees). }562
procedure RotateAbsolute(const axis: TAffineVector; angle: Single);
564
// Moves camera along the right vector (move left and right)
565
procedure Slide(ADistance: Single);
566
// Orients the object toward a target object
567
procedure PointTo(const ATargetObject: TGLBaseSceneObject; const AUpVector:
569
// Orients the object toward a target absolute position
570
procedure PointTo(const AAbsolutePosition, AUpVector: TVector); overload;
572
procedure Render(var ARci: TGLRenderContextInfo);
573
procedure DoRender(var ARci: TGLRenderContextInfo;
574
ARenderSelf, ARenderChildren: Boolean); virtual;
575
procedure RenderChildren(firstChildIndex, lastChildIndex: Integer;
576
var rci: TGLRenderContextInfo); virtual;
578
procedure StructureChanged; dynamic;
579
procedure ClearStructureChanged;
580
// Recalculate an orthonormal system
581
procedure CoordinateChanged(Sender: TGLCustomCoordinates); override;
582
procedure TransformationChanged;
583
procedure NotifyChange(Sender: TObject); override;
584
property Rotation: TGLCoordinates read FRotation write SetRotation;
585
property PitchAngle: Single read GetPitchAngle write SetPitchAngle;
586
property RollAngle: Single read GetRollAngle write SetRollAngle;
587
property TurnAngle: Single read GetTurnAngle write SetTurnAngle;
589
property ShowAxes: Boolean read FShowAxes write SetShowAxes default False;
591
property Changes: TObjectChanges read FChanges;
592
property BBChanges: TObjectBBChanges read fBBChanges write SetBBChanges;
593
property Parent: TGLBaseSceneObject read FParent write SetParent;
594
property Position: TGLCoordinates read FPosition write SetPosition;
595
property Direction: TGLCoordinates read FDirection write SetDirection;
596
property Up: TGLCoordinates read FUp write SetUp;
597
property Scale: TGLCoordinates read FScaling write SetScaling;
598
property Scene: TGLScene read FScene;
599
property Visible: Boolean read FVisible write SetVisible default True;
600
property Pickable: Boolean read FPickable write SetPickable default True;
601
property ObjectsSorting: TGLObjectsSorting read FObjectsSorting write
602
SetObjectsSorting default osInherited;
603
property VisibilityCulling: TGLVisibilityCulling read FVisibilityCulling
604
write SetVisibilityCulling default vcInherited;
605
property OnProgress: TGLProgressEvent read FOnProgress write FOnProgress;
606
property OnPicked: TNotifyEvent read FOnPicked write FOnPicked;
607
property OnAddedToParent: TNotifyEvent read FOnAddedToParent write
609
property Behaviours: TGLBehaviours read GetBehaviours write SetBehaviours
611
property Effects: TGLObjectEffects read GetEffects write SetEffects stored
613
property TagObject: TObject read FTagObject write FTagObject;
615
property TagFloat: Single read FTagFloat write FTagFloat;
618
{Base class for implementing behaviours in TGLScene.619
Behaviours are regrouped in a collection attached to a TGLBaseSceneObject,
620
and are part of the "Progress" chain of events. Behaviours allows clean
621
application of time-based alterations to objects (movements, shape or
623
Since behaviours are implemented as classes, there are basicly two kinds
624
of strategies for subclasses :
625
stand-alone : the subclass does it all, and holds all necessary data
626
(covers animation, inertia etc.)
627
proxy : the subclass is an interface to and external, shared operator
628
(like gravity, force-field effects etc.)
630
Some behaviours may be cooperative (like force-fields affects inertia)
631
or unique (e.g. only one inertia behaviour per object).
633
Don't forget to override the ReadFromFiler/WriteToFiler persistence
634
methods if you add data in a subclass !
635
Subclasses must be registered using the RegisterXCollectionItemClass
637
TGLBaseBehaviour = class(TGLXCollectionItem)
639
procedure SetName(const val: string); override;
640
{Override this function to write subclass data. }641
procedure WriteToFiler(writer: TWriter); override;
642
{Override this function to read subclass data. }643
procedure ReadFromFiler(reader: TReader); override;
644
{Returns the TGLBaseSceneObject on which the behaviour should be applied.645
Does NOT check for nil owners. }
646
function OwnerBaseSceneObject: TGLBaseSceneObject;
648
constructor Create(aOwner: TGLXCollection); override;
649
destructor Destroy; override;
650
procedure DoProgress(const progressTime: TProgressTimes); virtual;
653
{Ancestor for non-rendering behaviours.654
This class shall never receive any properties, it's just here to differentiate
655
rendereing and non-rendering behaviours. Rendereing behaviours are named
656
"TGLObjectEffect", non-rendering effects (like inertia) are simply named
658
TGLBehaviour = class(TGLBaseBehaviour)
661
{Holds a list of TGLBehaviour objects.662
This object expects itself to be owned by a TGLBaseSceneObject.
663
As a TGLXCollection (and contrary to a TCollection), this list can contain
664
objects of varying class, the only constraint being that they should all
665
be TGLBehaviour subclasses. }
666
TGLBehaviours = class(TGLXCollection)
668
function GetBehaviour(index: Integer): TGLBehaviour;
670
constructor Create(aOwner: TPersistent); override;
671
function GetNamePath: string; override;
672
class function ItemsClass: TGLXCollectionItemClass; override;
673
property Behaviour[index: Integer]: TGLBehaviour read GetBehaviour; default;
674
function CanAdd(aClass: TGLXCollectionItemClass): Boolean; override;
675
procedure DoProgress(const progressTimes: TProgressTimes);
678
{A rendering effect that can be applied to SceneObjects.679
ObjectEffect is a subclass of behaviour that gets a chance to Render
680
an object-related special effect.
681
TGLObjectEffect should not be used as base class for custom effects,
682
instead you should use the following base classes :
683
TGLObjectPreEffect is rendered before owner object render
684
TGLObjectPostEffect is rendered after the owner object render
685
TGLObjectAfterEffect is rendered at the end of the scene rendering
687
Don't forget to override the ReadFromFiler/WriteToFiler persistence
688
methods if you add data in a subclass !
689
Subclasses must be registered using the RegisterXCollectionItemClass
692
// TGLObjectEffectClass = class of TGLObjectEffect;
694
TGLObjectEffect = class(TGLBaseBehaviour)
696
{Override this function to write subclass data. }697
procedure WriteToFiler(writer: TWriter); override;
698
{Override this function to read subclass data. }699
procedure ReadFromFiler(reader: TReader); override;
702
procedure Render(var rci: TGLRenderContextInfo); virtual;
705
{An object effect that gets rendered before owner object's render.706
The current OpenGL matrices and material are that of the owner object. }
707
TGLObjectPreEffect = class(TGLObjectEffect)
710
{An object effect that gets rendered after owner object's render.711
The current OpenGL matrices and material are that of the owner object. }
712
TGLObjectPostEffect = class(TGLObjectEffect)
715
{An object effect that gets rendered at scene's end.716
No particular OpenGL matrices or material should be assumed. }
717
TGLObjectAfterEffect = class(TGLObjectEffect)
720
{Holds a list of object effects.721
This object expects itself to be owned by a TGLBaseSceneObject. }
722
TGLObjectEffects = class(TGLXCollection)
724
function GetEffect(index: Integer): TGLObjectEffect;
726
constructor Create(aOwner: TPersistent); override;
727
function GetNamePath: string; override;
728
class function ItemsClass: TGLXCollectionItemClass; override;
729
property ObjectEffect[index: Integer]: TGLObjectEffect read GetEffect;
731
function CanAdd(aClass: TGLXCollectionItemClass): Boolean; override;
732
procedure DoProgress(const progressTime: TProgressTimes);
733
procedure RenderPreEffects(var rci: TGLRenderContextInfo);
734
{ Also take care of registering after effects with the GLSceneViewer. }735
procedure RenderPostEffects(var rci: TGLRenderContextInfo);
738
{Extended base scene object class with a material property.739
The material allows defining a color and texture for the object,
741
TGLCustomSceneObject = class(TGLBaseSceneObject)
743
FMaterial: TGLMaterial;
746
function Blended: Boolean; override;
747
procedure SetGLMaterial(AValue: TGLMaterial);
748
procedure DestroyHandle; override;
749
procedure Loaded; override;
751
constructor Create(AOwner: TComponent); override;
752
destructor Destroy; override;
753
procedure Assign(Source: TPersistent); override;
754
procedure DoRender(var ARci: TGLRenderContextInfo;
755
ARenderSelf, ARenderChildren: Boolean); override;
756
property Material: TGLMaterial read FMaterial write SeTGLMaterial;
757
property Hint: string read FHint write FHint;
760
{This class shall be used only as a hierarchy root.761
It exists only as a container and shall never be rotated/scaled etc. as
762
the class type is used in parenting optimizations.
763
Shall never implement or add any functionality, the "Create" override
764
only take cares of disabling the build list. }
765
TGLSceneRootObject = class(TGLBaseSceneObject)
767
constructor Create(AOwner: TComponent); override;
770
{Base class for objects that do not have a published "material".771
Note that the material is available in public properties, but isn't
772
applied automatically before invoking BuildList.
773
Subclassing should be reserved to structural objects and objects that
774
have no material of their own. }
775
TGLImmaterialSceneObject = class(TGLCustomSceneObject)
778
procedure DoRender(var ARci: TGLRenderContextInfo;
779
ARenderSelf, ARenderChildren: Boolean); override;
781
property ObjectsSorting;
782
property VisibilityCulling;
800
{Base class for camera invariant objects.801
Camera invariant objects bypass camera settings, such as camera
802
position (object is always centered on camera) or camera orientation
803
(object always has same orientation as camera). }
804
TGLCameraInvariantObject = class(TGLImmaterialSceneObject)
806
FCamInvarianceMode: TGLCameraInvarianceMode;
808
procedure SetCamInvarianceMode(const val: TGLCameraInvarianceMode);
809
property CamInvarianceMode: TGLCameraInvarianceMode read FCamInvarianceMode
810
write SetCamInvarianceMode;
812
constructor Create(AOwner: TComponent); override;
813
procedure Assign(Source: TPersistent); override;
814
procedure DoRender(var ARci: TGLRenderContextInfo;
815
ARenderSelf, ARenderChildren: Boolean); override;
818
{Base class for standard scene objects. Publishes the Material property. }819
TGLSceneObject = class(TGLCustomSceneObject)
822
property ObjectsSorting;
823
property VisibilityCulling;
841
{Event for user-specific rendering in a TGLDirectOpenGL object. }842
TDirectRenderEvent = procedure(Sender: TObject; var rci: TGLRenderContextInfo)
845
{Provides a way to issue direct OpenGL calls during the rendering.846
You can use this object to do your specific rendering task in its OnRender
847
event. The OpenGL calls shall restore the OpenGL states they found when
848
entering, or exclusively use the GLMisc utility functions to alter the
850
TGLDirectOpenGL = class(TGLImmaterialSceneObject)
853
FUseBuildList: Boolean;
854
FOnRender: TDirectRenderEvent;
857
procedure SetUseBuildList(const val: Boolean);
858
function Blended: Boolean; override;
859
procedure SetBlend(const val: Boolean);
862
constructor Create(AOwner: TComponent); override;
864
procedure Assign(Source: TPersistent); override;
865
procedure BuildList(var rci: TGLRenderContextInfo); override;
867
function AxisAlignedDimensionsUnscaled: TVector; override;
869
{Specifies if a build list be made.870
If True, GLScene will generate a build list (OpenGL-side cache),
871
ie. OnRender will only be invoked once for the first render, or after
872
a StructureChanged call. This is suitable for "static" geometry and
873
will usually speed up rendering of things that don't change.
874
If false, OnRender will be invoked for each render. This is suitable
875
for dynamic geometry (things that change often or constantly). }
876
property UseBuildList: Boolean read FUseBuildList write SetUseBuildList;
877
{Place your specific OpenGL code here.878
The OpenGL calls shall restore the OpenGL states they found when
879
entering, or exclusively use the GLMisc utility functions to alter
881
property OnRender: TDirectRenderEvent read FOnRender write FOnRender;
882
{ Defines if the object uses blending.883
This property will allow direct opengl objects to be flagged as
884
blended for object sorting purposes. }
885
property Blend: Boolean read FBlend write SetBlend;
888
{Scene object that allows other objects to issue rendering at some point.889
This object is used to specify a render point for which other components
890
have (rendering) tasks to perform. It doesn't render anything itself
891
and is invisible, but other components can register and be notified
892
when the point is reached in the rendering phase.
893
Callbacks must be explicitly unregistered. }
894
TGLRenderPoint = class(TGLImmaterialSceneObject)
897
FCallBacks: array of TDirectRenderEvent;
898
FFreeCallBacks: array of TNotifyEvent;
900
constructor Create(AOwner: TComponent); override;
901
destructor Destroy; override;
902
procedure BuildList(var rci: TGLRenderContextInfo); override;
904
procedure RegisterCallBack(renderEvent: TDirectRenderEvent;
905
renderPointFreed: TNotifyEvent);
906
procedure UnRegisterCallBack(renderEvent: TDirectRenderEvent);
910
{A full proxy object.911
This object literally uses another object's Render method to do its own
912
rendering, however, it has a coordinate system and a life of its own.
913
Use it for duplicates of an object. }
914
TGLProxyObject = class(TGLBaseSceneObject)
916
FMasterObject: TGLBaseSceneObject;
917
FProxyOptions: TGLProxyObjectOptions;
920
procedure Notification(AComponent: TComponent; Operation: TOperation);
922
procedure SetMasterObject(const val: TGLBaseSceneObject); virtual;
923
procedure SetProxyOptions(const val: TGLProxyObjectOptions);
925
constructor Create(AOwner: TComponent); override;
926
destructor Destroy; override;
927
procedure Assign(Source: TPersistent); override;
928
procedure DoRender(var ARci: TGLRenderContextInfo;
929
ARenderSelf, ARenderChildren: Boolean); override;
930
function BarycenterAbsolutePosition: TVector; override;
931
function AxisAlignedDimensions: TVector; override;
932
function AxisAlignedDimensionsUnscaled: TVector; override;
933
function RayCastIntersect(const rayStart, rayVector: TVector;
934
intersectPoint: PVector = nil;
935
intersectNormal: PVector = nil): Boolean; override;
936
function GenerateSilhouette(const silhouetteParameters:
937
TGLSilhouetteParameters): TGLSilhouette; override;
940
{Specifies the Master object which will be proxy'ed. }941
property MasterObject: TGLBaseSceneObject read FMasterObject write
943
{Specifies how and what is proxy'ed. }944
property ProxyOptions: TGLProxyObjectOptions read FProxyOptions write
945
SetProxyOptions default cDefaultProxyOptions;
946
property ObjectsSorting;
962
TGLProxyObjectClass = class of TGLProxyObject;
964
{Defines the various styles for lightsources.965
lsSpot : a spot light, oriented and with a cutoff zone (note that if
966
cutoff is 180, the spot is rendered as an omni source)
967
lsOmni : an omnidirectionnal source, punctual and sending light in
968
all directions uniformously
969
lsParallel : a parallel light, oriented as the light source is (this
970
type of light can help speed up rendering)}
971
TLightStyle = (lsSpot, lsOmni, lsParallel, lsParallelSpot);
973
{Standard light source.974
The standard GLScene light source covers spotlights, omnidirectionnal and
975
parallel sources (see TLightStyle).
976
Lights are colored, have distance attenuation parameters and are turned
977
on/off through their Shining property.
978
Lightsources are managed in a specific object by the TGLScene for rendering
979
purposes. The maximum number of light source in a scene is limited by the
980
OpenGL implementation (8 lights are supported under most ICDs), though the
981
more light you use, the slower rendering may get. If you want to render
982
many more light/lightsource, you may have to resort to other techniques
984
TGLLightSource = class(TGLBaseSceneObject)
987
FSpotDirection: TGLCoordinates;
988
FSpotExponent, FSpotCutOff: Single;
989
FConstAttenuation, FLinearAttenuation, FQuadraticAttenuation: Single;
991
FAmbient, FDiffuse, FSpecular: TGLColor;
992
FLightStyle: TLightStyle;
995
procedure SetAmbient(AValue: TGLColor);
996
procedure SetDiffuse(AValue: TGLColor);
997
procedure SetSpecular(AValue: TGLColor);
998
procedure SetConstAttenuation(AValue: Single);
999
procedure SetLinearAttenuation(AValue: Single);
1000
procedure SetQuadraticAttenuation(AValue: Single);
1001
procedure SetShining(AValue: Boolean);
1002
procedure SetSpotDirection(AVector: TGLCoordinates);
1003
procedure SetSpotExponent(AValue: Single);
1004
procedure SetSpotCutOff(const val: Single);
1005
procedure SetLightStyle(const val: TLightStyle);
1008
constructor Create(AOwner: TComponent); override;
1009
destructor Destroy; override;
1010
procedure DoRender(var ARci: TGLRenderContextInfo;
1011
ARenderSelf, ARenderChildren: Boolean); override;
1012
// light sources have different handle types than normal scene objects
1013
function GetHandle(var rci: TGLRenderContextInfo): Cardinal; override;
1014
function RayCastIntersect(const rayStart, rayVector: TVector;
1015
intersectPoint: PVector = nil;
1016
intersectNormal: PVector = nil): Boolean; override;
1017
procedure CoordinateChanged(Sender: TGLCustomCoordinates); override;
1018
function GenerateSilhouette(const silhouetteParameters:
1019
TGLSilhouetteParameters): TGLSilhouette; override;
1020
property LightID: Cardinal read FLightID;
1021
function Attenuated: Boolean;
1023
property Ambient: TGLColor read FAmbient write SetAmbient;
1024
property ConstAttenuation: Single read FConstAttenuation write
1025
SetConstAttenuation;
1026
property Diffuse: TGLColor read FDiffuse write SetDiffuse;
1027
property LinearAttenuation: Single read FLinearAttenuation write
1028
SetLinearAttenuation;
1029
property QuadraticAttenuation: Single read FQuadraticAttenuation write
1030
SetQuadraticAttenuation;
1032
property LightStyle: TLightStyle read FLightStyle write SetLightStyle default
1034
property Shining: Boolean read FShining write SetShining default True;
1035
property Specular: TGLColor read FSpecular write SetSpecular;
1036
property SpotCutOff: Single read FSpotCutOff write SetSpotCutOff;
1037
property SpotDirection: TGLCoordinates read FSpotDirection write
1039
property SpotExponent: Single read FSpotExponent write SetSpotExponent;
1040
property OnProgress;
1043
TGLCameraStyle = (csPerspective, csOrthogonal, csOrtho2D, csCustom,
1044
csInfinitePerspective, csPerspectiveKeepFOV);
1046
TGLCameraKeepFOVMode = (ckmHorizontalFOV, ckmVerticalFOV);
1048
TOnCustomPerspective = procedure(const viewport: TRectangle;
1049
width, height: Integer; DPI: Integer;
1050
var viewPortRadius: Single) of object;
1053
This object is commonly referred by TGLSceneViewer and defines a position,
1054
direction, focal length, depth of view... all the properties needed for
1055
defining a point of view and optical characteristics. }
1056
TGLCamera = class(TGLBaseSceneObject)
1058
FFocalLength: Single;
1059
FDepthOfView: Single;
1060
FNearPlane: Single; // nearest distance to the camera
1061
FNearPlaneBias: Single; // scaling bias applied to near plane
1062
FViewPortRadius: Single; // viewport bounding radius per distance unit
1063
FTargetObject: TGLBaseSceneObject;
1064
FLastDirection: TVector; // Not persistent
1065
FCameraStyle: TGLCameraStyle;
1066
FKeepFOVMode: TGLCameraKeepFOVMode;
1067
FSceneScale: Single;
1068
FDeferredApply: TNotifyEvent;
1069
FOnCustomPerspective: TOnCustomPerspective;
1071
FFOVY, FFOVX: Double;
1073
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
1074
procedure SetTargetObject(const val: TGLBaseSceneObject);
1075
procedure SetDepthOfView(AValue: Single);
1076
procedure SetFocalLength(AValue: Single);
1077
procedure SetCameraStyle(const val: TGLCameraStyle);
1078
procedure SetKeepFOVMode(const val: TGLCameraKeepFOVMode);
1079
procedure SetSceneScale(value: Single);
1080
function StoreSceneScale: Boolean;
1081
procedure SetNearPlaneBias(value: Single);
1082
function StoreNearPlaneBias: Boolean;
1084
constructor Create(aOwner: TComponent); override;
1085
destructor Destroy; override;
1086
procedure Assign(Source: TPersistent); override;
1087
{Nearest clipping plane for the frustum.1088
This value depends on the FocalLength and DepthOfView fields and
1089
is calculated to minimize Z-Buffer crawling as suggested by the
1090
OpenGL documentation. }
1091
property NearPlane: Single read FNearPlane;
1092
// Apply camera transformation
1094
procedure DoRender(var ARci: TGLRenderContextInfo;
1095
ARenderSelf, ARenderChildren: Boolean); override;
1096
function RayCastIntersect(const rayStart, rayVector: TVector;
1097
intersectPoint: PVector = nil;
1098
intersectNormal: PVector = nil): Boolean; override;
1099
procedure ApplyPerspective(const AViewport: TRectangle;
1100
AWidth, AHeight: Integer; ADPI: Integer);
1101
procedure AutoLeveling(Factor: Single);
1102
procedure Reset(aSceneBuffer: TGLSceneBuffer);
1103
// Position the camera so that the whole scene can be seen
1104
procedure ZoomAll(aSceneBuffer: TGLSceneBuffer);
1106
procedure RotateObject(obj: TGLBaseSceneObject; pitchDelta, turnDelta: Single; rollDelta: Single = 0);
1107
procedure RotateTarget(pitchDelta, turnDelta: Single; rollDelta: Single = 0);
1108
{Change camera's position to make it move around its target.1109
If TargetObject is nil, nothing happens. This method helps in quickly
1110
implementing camera controls. Camera's Up and Direction properties are unchanged.
1111
Angle deltas are in degrees, camera parent's coordinates should be identity.
1112
Tip : make the camera a child of a "target" dummycube and make
1113
it a target the dummycube. Now, to pan across the scene, just move
1114
the dummycube, to change viewing angle, use this method. }
1115
procedure MoveAroundTarget(pitchDelta, turnDelta: Single);
1116
{Change camera's position to make it move all around its target.1117
If TargetObject is nil, nothing happens. This method helps in quickly
1118
implementing camera controls. Camera's Up and Direction properties are changed.
1119
Angle deltas are in degrees. }
1120
procedure MoveAllAroundTarget(pitchDelta, turnDelta :Single);
1121
{Moves the camera in eye space coordinates. }1122
procedure MoveInEyeSpace(forwardDistance, rightDistance, upDistance: Single);
1123
{ Moves the target in eye space coordinates. }1124
procedure MoveTargetInEyeSpace(forwardDistance, rightDistance, upDistance:
1126
{ Computes the absolute vector corresponding to the eye-space translations. }1127
function AbsoluteEyeSpaceVector(forwardDistance, rightDistance, upDistance:
1129
{ Adjusts distance from camera to target by applying a ratio.1130
If TargetObject is nil, nothing happens. This method helps in quickly
1131
implementing camera controls. Only the camera's position is changed. }
1132
procedure AdjustDistanceToTarget(distanceRatio: Single);
1133
{ Returns the distance from camera to target.1134
If TargetObject is nil, returns 1. }
1135
function DistanceToTarget: Single;
1136
{ Computes the absolute normalized vector to the camera target.1137
If no target is defined, AbsoluteDirection is returned. }
1138
function AbsoluteVectorToTarget: TVector;
1139
{ Computes the absolute normalized right vector to the camera target.1140
If no target is defined, AbsoluteRight is returned. }
1141
function AbsoluteRightVectorToTarget: TVector;
1142
{ Computes the absolute normalized up vector to the camera target.1143
If no target is defined, AbsoluteUpt is returned. }
1144
function AbsoluteUpVectorToTarget: TVector;
1145
{ Calculate an absolute translation vector from a screen vector.1146
Ratio is applied to both screen delta, planeNormal should be the
1147
translation plane's normal. }
1148
function ScreenDeltaToVector(deltaX, deltaY: Integer; ratio: Single;
1149
const planeNormal: TVector): TVector;
1150
{ Same as ScreenDeltaToVector but optimized for XY plane. }1151
function ScreenDeltaToVectorXY(deltaX, deltaY: Integer; ratio: Single):
1153
{ Same as ScreenDeltaToVector but optimized for XZ plane. }1154
function ScreenDeltaToVectorXZ(deltaX, deltaY: Integer; ratio: Single):
1156
{ Same as ScreenDeltaToVector but optimized for YZ plane. }1157
function ScreenDeltaToVectorYZ(deltaX, deltaY: Integer; ratio: Single):
1159
{ Returns true if a point is in front of the camera. }1160
function PointInFront(const point: TVector): boolean; overload;
1161
{ Calculates the field of view in degrees, given a viewport dimension1162
(width or height). F.i. you may wish to use the minimum of the two. }
1163
function GetFieldOfView(const AViewportDimension: single): single;
1164
{ Sets the FocalLength in degrees, given a field of view and a viewport1165
dimension (width or height). }
1166
procedure SetFieldOfView(const AFieldOfView, AViewportDimension: single);
1169
{ Depth of field/view.1170
Adjusts the maximum distance, beyond which objects will be clipped
1172
You must adjust this value if you are experiencing disappearing
1173
objects (increase the value) of Z-Buffer crawling (decrease the
1174
value). Z-Buffer crawling happens when depth of view is too large
1175
and the Z-Buffer precision cannot account for all that depth
1176
accurately : objects farther overlap closer objects and vice-versa.
1177
Note that this value is ignored in cSOrtho2D mode. }
1178
property DepthOfView: Single read FDepthOfView write SetDepthOfView;
1179
{ Focal Length of the camera.1180
Adjusting this value allows for lens zooming effects (use SceneScale
1181
for linear zooming). This property affects near/far planes clipping. }
1182
property FocalLength: Single read FFocalLength write SetFocalLength;
1183
{ Scene scaling for camera point.1184
This is a linear 2D scaling of the camera's output, allows for
1185
linear zooming (use FocalLength for lens zooming). }
1186
property SceneScale: Single read FSceneScale write SetSceneScale stored
1188
{ Scaling bias applied to near-plane calculation.1189
Values inferior to one will move the nearplane nearer, and also
1190
reduce medium/long range Z-Buffer precision, values superior
1191
to one will move the nearplane farther, and also improve medium/long
1192
range Z-Buffer precision. }
1193
property NearPlaneBias: Single read FNearPlaneBias write SetNearPlaneBias
1194
stored StoreNearPlaneBias;
1195
{ If set, camera will point to this object.1196
When camera is pointing an object, the Direction vector is ignored
1197
and the Up vector is used as an absolute vector to the up. }
1198
property TargetObject: TGLBaseSceneObject read FTargetObject write
1200
{ Adjust the camera style.1201
Three styles are available :
1202
csPerspective, the default value for perspective projection
1203
csOrthogonal, for orthogonal (or isometric) projection.
1204
csOrtho2D, setups orthogonal 2D projection in which 1 unit
1205
(in x or y) represents 1 pixel.
1206
csInfinitePerspective, for perspective view without depth limit.
1207
csKeepCamAnglePerspective, for perspective view with keeping aspect on view resize.
1208
csCustom, setup is deferred to the OnCustomPerspective event.
1210
property CameraStyle: TGLCameraStyle read FCameraStyle write SetCameraStyle
1211
default csPerspective;
1213
{ Keep camera angle mode. 1214
When CameraStyle is csKeepCamAnglePerspective, select which camera angle you want to keep.
1215
kaHeight, for Keep Height oriented camera angle
1216
kaWidth, for Keep Width oriented camera angle
1218
property KeepFOVMode: TGLCameraKeepFOVMode read FKeepFOVMode
1219
write SetKeepFOVMode default ckmHorizontalFOV;
1221
{ Custom perspective event.1222
This event allows you to specify your custom perpective, either
1223
with a glFrustrum, a glOrtho or whatever method suits you.
1224
You must compute viewPortRadius for culling to work.
1225
This event is only called if CameraStyle is csCustom. }
1226
property OnCustomPerspective: TOnCustomPerspective read FOnCustomPerspective
1227
write FOnCustomPerspective;
1232
property OnProgress;
1238
The scene contains the scene description (lights, geometry...), which is
1239
basicly a hierarchical scene graph made of TGLBaseSceneObject. It will
1240
usually contain one or more TGLCamera object, which can be referred by
1241
a Viewer component for rendering purposes.
1242
The scene's objects can be accessed directly from Delphi code (as regular
1243
components), but those are edited with a specific editor (double-click
1244
on the TGLScene component at design-time to invoke it). To add objects
1245
at runtime, use the AddNewChild method of TGLBaseSceneObject. }
1246
TGLScene = class(TGLUpdateAbleComponent)
1249
FUpdateCount: Integer;
1250
FObjects: TGLSceneRootObject;
1251
FBaseContext: TGLContext; //reference, not owned!
1252
FLights, FBuffers: TPersistentObjectList;
1253
FCurrentGLCamera: TGLCamera;
1254
FCurrentBuffer: TGLSceneBuffer;
1255
FObjectsSorting: TGLObjectsSorting;
1256
FVisibilityCulling: TGLVisibilityCulling;
1257
FOnBeforeProgress: TGLProgressEvent;
1258
FOnProgress: TGLProgressEvent;
1259
FCurrentDeltaTime: Double;
1260
FInitializableObjects: TGLInitializableObjectList;
1264
procedure AddLight(aLight: TGLLightSource);
1265
procedure RemoveLight(aLight: TGLLightSource);
1266
// Adds all lights in the subtree (anObj included)
1267
procedure AddLights(anObj: TGLBaseSceneObject);
1268
// Removes all lights in the subtree (anObj included)
1269
procedure RemoveLights(anObj: TGLBaseSceneObject);
1271
procedure GetChildren(AProc: TGetChildProc; Root: TComponent); override;
1272
procedure SetChildOrder(AChild: TComponent; Order: Integer); override;
1273
procedure SetObjectsSorting(const val: TGLObjectsSorting);
1274
procedure SetVisibilityCulling(const val: TGLVisibilityCulling);
1276
procedure ReadState(Reader: TReader); override;
1279
constructor Create(AOwner: TComponent); override;
1280
destructor Destroy; override;
1282
procedure BeginUpdate;
1283
procedure EndUpdate;
1284
function IsUpdating: Boolean;
1286
procedure AddBuffer(aBuffer: TGLSceneBuffer);
1287
procedure RemoveBuffer(aBuffer: TGLSceneBuffer);
1288
procedure SetupLights(maxLights: Integer);
1289
procedure NotifyChange(Sender: TObject); override;
1290
procedure Progress(const deltaTime, newTime: Double);
1292
function FindSceneObject(const AName: string): TGLBaseSceneObject;
1293
{ Calculates, finds and returns the first object intercepted by the ray.1294
Returns nil if no intersection was found. This function will be
1295
accurate only for objects that overrided their RayCastIntersect
1296
method with accurate code, otherwise, bounding sphere intersections
1298
function RayCastIntersect(const rayStart, rayVector: TVector;
1299
intersectPoint: PVector = nil;
1300
intersectNormal: PVector = nil): TGLBaseSceneObject; virtual;
1302
procedure ShutdownAllLights;
1304
{ Saves the scene to a file (recommended extension : .GLS) }1305
procedure SaveToFile(const fileName: string);
1306
{ Load the scene from a file.1307
Existing objects/lights/cameras are freed, then the file is loaded.
1308
Delphi's IDE is not handling this behaviour properly yet, ie. if
1309
you load a scene in the IDE, objects will be properly loaded, but
1310
no declare will be placed in the code. }
1311
procedure LoadFromFile(const fileName: string);
1313
procedure SaveToStream(aStream: TStream);
1314
procedure LoadFromStream(aStream: TStream);
1316
{ Saves the scene to a text file }1317
procedure SaveToTextFile(const fileName: string);
1318
{ Load the scene from a text files.1319
See LoadFromFile for details. }
1320
procedure LoadFromTextFile(const fileName: string);
1322
property CurrentGLCamera: TGLCamera read FCurrentGLCamera;
1323
property Lights: TPersistentObjectList read FLights;
1324
property Objects: TGLSceneRootObject read FObjects;
1325
property CurrentBuffer: TGLSceneBuffer read FCurrentBuffer;
1327
{ List of objects that request to be initialized when rendering context is active.1328
They are removed automaticly from this list once initialized. }
1329
property InitializableObjects: TGLInitializableObjectList read
1330
FInitializableObjects;
1331
property CurrentDeltaTime: Double read FCurrentDeltaTime;
1334
{ Defines default ObjectSorting option for scene objects. }1335
property ObjectsSorting: TGLObjectsSorting read FObjectsSorting write
1336
SetObjectsSorting default osRenderBlendedLast;
1337
{ Defines default VisibilityCulling option for scene objects. }1338
property VisibilityCulling: TGLVisibilityCulling read FVisibilityCulling
1339
write SetVisibilityCulling default vcNone;
1340
property OnBeforeProgress: TGLProgressEvent read FOnBeforeProgress write FOnBeforeProgress;
1341
property OnProgress: TGLProgressEvent read FOnProgress write FOnProgress;
1346
TFogMode = (fmLinear, fmExp, fmExp2);
1350
{ Fog distance calculation mode.1352
fdDefault: let OpenGL use its default formula
1353
fdEyeRadial: uses radial "true" distance (best quality)
1354
fdEyePlane: uses the distance to the projection plane
1355
(same as Z-Buffer, faster)
1356
Requires support of GL_NV_fog_distance extension, otherwise,
1358
TFogDistance = (fdDefault, fdEyeRadial, fdEyePlane);
1360
// TGLFogEnvironment
1362
{ Parameters for fog environment in a scene.1363
The fog descibed by this object is a distance-based fog, ie. the "intensity"
1364
of the fog is given by a formula depending solely on the distance, this
1365
intensity is used for blending to a fixed color. }
1366
TGLFogEnvironment = class(TGLUpdateAbleObject)
1369
FSceneBuffer: TGLSceneBuffer;
1370
FFogColor: TGLColor; // alpha value means the fog density
1371
FFogStart, FFogEnd: Single;
1373
FFogDistance: TFogDistance;
1377
procedure SetFogColor(Value: TGLColor);
1378
procedure SetFogStart(Value: Single);
1379
procedure SetFogEnd(Value: Single);
1380
procedure SetFogMode(Value: TFogMode);
1381
procedure SetFogDistance(const val: TFogDistance);
1385
constructor Create(AOwner: TPersistent); override;
1386
destructor Destroy; override;
1389
procedure Assign(Source: TPersistent); override;
1391
function IsAtDefaultValues: Boolean;
1395
{ Color of the fog when it is at 100% intensity. }1396
property FogColor: TGLColor read FFogColor write SetFogColor;
1397
{ Minimum distance for fog, what is closer is not affected. }1398
property FogStart: Single read FFogStart write SetFogStart;
1399
{ Maximum distance for fog, what is farther is at 100% fog intensity. }1400
property FogEnd: Single read FFogEnd write SetFogEnd;
1401
{ The formula used for converting distance to fog intensity. }1402
property FogMode: TFogMode read FFogMode write SetFogMode default fmLinear;
1403
{ Adjusts the formula used for calculating fog distances.1404
This option is honoured if and only if the OpenGL ICD supports the
1405
GL_NV_fog_distance extension, otherwise, it is ignored.
1406
fdDefault: let OpenGL use its default formula
1407
fdEyeRadial: uses radial "true" distance (best quality)
1408
fdEyePlane: uses the distance to the projection plane
1409
(same as Z-Buffer, faster)
1411
property FogDistance: TFogDistance read FFogDistance write SetFogDistance
1415
// TGLDepthPrecision
1417
TGLDepthPrecision = (dpDefault, dp16bits, dp24bits, dp32bits);
1421
TGLColorDepth = (cdDefault, cd8bits, cd16bits, cd24bits, cdFloat64bits,
1422
cdFloat128bits); // float_type
1426
TGLShadeModel = (smDefault, smSmooth, smFlat);
1430
{ Encapsulates an OpenGL frame/rendering buffer. }1431
TGLSceneBuffer = class(TGLUpdateAbleObject)
1435
FRendering: Boolean;
1436
FRenderingContext: TGLContext;
1437
FAfterRenderEffects: TPersistentObjectList;
1438
FViewMatrixStack: array of TMatrix;
1439
FProjectionMatrixStack: array of TMatrix;
1440
FBaseProjectionMatrix: TMatrix;
1441
FCameraAbsolutePosition: TVector;
1442
FViewPort: TRectangle;
1443
FSelector: TGLBaseSelectTechnique;
1445
// Options & User Properties
1446
FFaceCulling, FFogEnable, FLighting: Boolean;
1447
FDepthTest: Boolean;
1448
FBackgroundColor: TColor;
1449
FBackgroundAlpha: Single;
1450
FAmbientColor: TGLColor;
1451
FAntiAliasing: TGLAntiAliasing;
1452
FDepthPrecision: TGLDepthPrecision;
1453
FColorDepth: TGLColorDepth;
1454
FContextOptions: TContextOptions;
1455
FShadeModel: TGLShadeModel;
1456
FRenderDPI: Integer;
1457
FFogEnvironment: TGLFogEnvironment;
1458
FAccumBufferBits: Integer;
1459
FLayer: TGLContextLayer;
1465
FFreezeBuffer: Pointer;
1467
FFreezedViewPort: TRectangle;
1470
FFrameCount: Longint;
1471
FFramesPerSecond: Single;
1472
FFirstPerfCounter: Int64;
1473
FLastFrameTime: Single;
1476
FOnChange: TNotifyEvent;
1477
FOnStructuralChange: TNotifyEvent;
1478
FOnPrepareGLContext: TNotifyEvent;
1480
FBeforeRender: TNotifyEvent;
1481
FViewerBeforeRender: TNotifyEvent;
1482
FPostRender: TNotifyEvent;
1483
FAfterRender: TNotifyEvent;
1484
FInitiateRendering: TDirectRenderEvent;
1485
FWrapUpRendering: TDirectRenderEvent;
1486
procedure SetLayer(const Value: TGLContextLayer);
1490
procedure SetBackgroundColor(AColor: TColor);
1491
procedure SetBackgroundAlpha(alpha: Single);
1492
procedure SetAmbientColor(AColor: TGLColor);
1493
function GetLimit(Which: TLimitType): Integer;
1494
procedure SetCamera(ACamera: TGLCamera);
1495
procedure SetContextOptions(Options: TContextOptions);
1496
procedure SetDepthTest(AValue: Boolean);
1497
procedure SetFaceCulling(AValue: Boolean);
1498
procedure SetLighting(AValue: Boolean);
1499
procedure SetAntiAliasing(const val: TGLAntiAliasing);
1500
procedure SetDepthPrecision(const val: TGLDepthPrecision);
1501
procedure SetColorDepth(const val: TGLColorDepth);
1502
procedure SetShadeModel(const val: TGLShadeModel);
1503
procedure SetFogEnable(AValue: Boolean);
1504
procedure SetGLFogEnvironment(AValue: TGLFogEnvironment);
1505
function StoreFog: Boolean;
1506
procedure SetAccumBufferBits(const val: Integer);
1508
procedure PrepareRenderingMatrices(const aViewPort: TRectangle;
1509
resolution: Integer; pickingRect: PGLRect = nil);
1510
procedure DoBaseRender(const aViewPort: TRectangle; resolution: Integer;
1511
drawState: TDrawState; baseObject: TGLBaseSceneObject);
1513
procedure SetupRenderingContext(context: TGLContext);
1514
procedure SetupRCOptions(context: TGLContext);
1515
procedure PrepareGLContext;
1518
procedure DoStructuralChange;
1520
// DPI for current/last render
1521
property RenderDPI: Integer read FRenderDPI;
1523
property OnPrepareGLContext: TNotifyEvent read FOnPrepareGLContext write
1524
FOnPrepareGLContext;
1528
constructor Create(AOwner: TPersistent); override;
1529
destructor Destroy; override;
1531
procedure NotifyChange(Sender: TObject); override;
1533
procedure CreateRC(AWindowHandle: HWND; memoryContext: Boolean;
1534
BufferCount: integer = 1); overload;
1535
procedure ClearBuffers;
1536
procedure DestroyRC;
1537
function RCInstantiated: Boolean;
1538
procedure Resize(newLeft, newTop, newWidth, newHeight: Integer);
1539
// Indicates hardware acceleration support
1540
function Acceleration: TGLContextAcceleration;
1542
// ViewPort for current/last render
1543
property ViewPort: TRectangle read FViewPort;
1545
// Fills the PickList with objects in Rect area
1546
procedure PickObjects(const rect: TGLRect; pickList: TGLPickList;
1547
objectCountGuess: Integer);
1548
{ Returns a PickList with objects in Rect area.1549
Returned list should be freed by caller.
1550
Objects are sorted by depth (nearest objects first). }
1551
function GetPickedObjects(const rect: TGLRect; objectCountGuess: Integer =
1553
// Returns the nearest object at x, y coordinates or nil if there is none
1554
function GetPickedObject(x, y: Integer): TGLBaseSceneObject;
1556
// Returns the color of the pixel at x, y in the frame buffer
1557
function GetPixelColor(x, y: Integer): TColor;
1558
{ Returns the raw depth (Z buffer) of the pixel at x, y in the frame buffer.1559
This value does not map to the actual eye-object distance, but to
1560
a depth buffer value in the [0; 1] range. }
1561
function GetPixelDepth(x, y: Integer): Single;
1562
{ Converts a raw depth (Z buffer value) to frustrum distance.1563
This calculation is only accurate for the pixel at the centre of the viewer,
1564
because it does not take into account that the corners of the frustrum
1565
are further from the eye than its centre. }
1566
function PixelDepthToDistance(aDepth: Single): Single;
1567
{ Converts a raw depth (Z buffer value) to world distance.1568
It also compensates for the fact that the corners of the frustrum
1569
are further from the eye, than its centre.}
1570
function PixelToDistance(x, y: integer): Single;
1571
{ Design time notification }1572
procedure NotifyMouseMove(Shift: TShiftState; X, Y: Integer);
1574
{ Renders the scene on the viewer.1575
You do not need to call this method, unless you explicitly want a
1576
render at a specific time. If you just want the control to get
1577
refreshed, use Invalidate instead. }
1578
procedure Render(baseObject: TGLBaseSceneObject); overload;
1579
procedure Render; overload;
1580
procedure RenderScene(aScene: TGLScene;
1581
const viewPortSizeX, viewPortSizeY: Integer;
1582
drawState: TDrawState;
1583
baseObject: TGLBaseSceneObject);
1584
{ Render the scene to a bitmap at given DPI.1585
DPI = "dots per inch".
1586
The "magic" DPI of the screen is 96 under Windows. }
1587
procedure RenderToBitmap(ABitmap: TGLBitmap; DPI: Integer = 0);
1588
{ Render the scene to a bitmap at given DPI and saves it to a file.1589
DPI = "dots per inch".
1590
The "magic" DPI of the screen is 96 under Windows. }
1591
procedure RenderToFile(const AFile: string; DPI: Integer = 0); overload;
1592
{ Renders to bitmap of given size, then saves it to a file.1593
DPI is adjusted to make the bitmap similar to the viewer. }
1594
procedure RenderToFile(const AFile: string; bmpWidth, bmpHeight: Integer);
1596
{ Creates a TGLBitmap32 that is a snapshot of current OpenGL content.1597
When possible, use this function instead of RenderToBitmap, it won't
1598
request a redraw and will be significantly faster.
1599
The returned TGLBitmap32 should be freed by calling code. }
1600
function CreateSnapShot: TGLImage;
1601
{ Creates a VCL bitmap that is a snapshot of current OpenGL content. }1602
function CreateSnapShotBitmap: TGLBitmap;
1603
procedure CopyToTexture(aTexture: TGLTexture); overload;
1604
procedure CopyToTexture(aTexture: TGLTexture; xSrc, ySrc, AWidth, AHeight:
1606
xDest, yDest: Integer; glCubeFace: TGLEnum = 0); overload;
1607
{ Save as raw float data to a file }1608
procedure SaveAsFloatToFile(const aFilename: string);
1609
{ Event reserved for viewer-specific uses. }1610
property ViewerBeforeRender: TNotifyEvent read FViewerBeforeRender write
1611
FViewerBeforeRender stored False;
1612
procedure SetViewPort(X, Y, W, H: Integer);
1613
function Width: Integer;
1614
function Height: Integer;
1616
{ Indicates if the Viewer is "frozen". }1617
property Freezed: Boolean read FFreezed;
1618
{ Freezes rendering leaving the last rendered scene on the buffer. This1619
is usefull in windowed applications for temporarily stoping rendering
1620
(when moving the window, for example). }
1622
{ Restarts rendering after it was freezed. }1625
{ Displays a window with info on current OpenGL ICD and context. }1626
procedure ShowInfo(Modal: boolean = false);
1628
{ Currently Rendering? }1629
property Rendering: Boolean read FRendering;
1631
{ Adjusts background alpha channel. }1632
property BackgroundAlpha: Single read FBackgroundAlpha write
1634
{ Returns the projection matrix in use or used for the last rendering. }1635
function ProjectionMatrix: TMatrix; deprecated;
1636
{ Returns the view matrix in use or used for the last rendering. }1637
function ViewMatrix: TMatrix; deprecated;
1638
function ModelMatrix: TMatrix; deprecated;
1640
{ Returns the base projection matrix in use or used for the last rendering.1641
The "base" projection is (as of now) either identity or the pick
1642
matrix, ie. it is the matrix on which the perspective or orthogonal
1643
matrix gets applied. }
1644
property BaseProjectionMatrix: TMatrix read FBaseProjectionMatrix;
1646
{ Back up current View matrix and replace it with newMatrix.1647
This method has no effect on the OpenGL matrix, only on the Buffer's
1648
matrix, and is intended for special effects rendering. }
1649
procedure PushViewMatrix(const newMatrix: TMatrix); deprecated;
1650
{ Restore a View matrix previously pushed. }1651
procedure PopViewMatrix; deprecated;
1653
procedure PushProjectionMatrix(const newMatrix: TMatrix); deprecated;
1654
procedure PopProjectionMatrix; deprecated;
1656
{ Converts a screen pixel coordinate into 3D coordinates for orthogonal projection.1657
This function accepts standard canvas coordinates, with (0,0) being
1658
the top left corner, and returns, when the camera is in orthogonal
1659
mode, the corresponding 3D world point that is in the camera's plane. }
1660
function OrthoScreenToWorld(screenX, screenY: Integer): TAffineVector;
1662
{ Converts a screen coordinate into world (3D) coordinates.1663
This methods wraps a call to gluUnProject.
1664
Note that screen coord (0,0) is the lower left corner. }
1665
function ScreenToWorld(const aPoint: TAffineVector): TAffineVector; overload;
1666
function ScreenToWorld(const aPoint: TVector): TVector; overload;
1667
{ Converts a screen pixel coordinate into 3D world coordinates.1668
This function accepts standard canvas coordinates, with (0,0) being
1669
the top left corner. }
1670
function ScreenToWorld(screenX, screenY: Integer): TAffineVector; overload;
1671
{ Converts an absolute world coordinate into screen coordinate.1672
This methods wraps a call to gluProject.
1673
Note that screen coord (0,0) is the lower left corner. }
1674
function WorldToScreen(const aPoint: TAffineVector): TAffineVector;
1676
function WorldToScreen(const aPoint: TVector): TVector; overload;
1677
{ Converts a set of point absolute world coordinates into screen coordinates. }1678
procedure WorldToScreen(points: PVector; nbPoints: Integer); overload;
1679
{ Calculates the 3D vector corresponding to a 2D screen coordinate.1680
The vector originates from the camera's absolute position and is
1681
expressed in absolute coordinates.
1682
Note that screen coord (0,0) is the lower left corner. }
1683
function ScreenToVector(const aPoint: TAffineVector): TAffineVector;
1685
function ScreenToVector(const aPoint: TVector): TVector; overload;
1686
function ScreenToVector(const x, y: Integer): TVector; overload;
1687
{ Calculates the 2D screen coordinate of a vector from the camera's1688
absolute position and is expressed in absolute coordinates.
1689
Note that screen coord (0,0) is the lower left corner. }
1690
function VectorToScreen(const VectToCam: TAffineVector): TAffineVector;
1691
{ Calculates intersection between a plane and screen vector.1692
If an intersection is found, returns True and places result in
1694
function ScreenVectorIntersectWithPlane(
1695
const aScreenPoint: TVector;
1696
const planePoint, planeNormal: TVector;
1697
var intersectPoint: TVector): Boolean;
1698
{ Calculates intersection between plane XY and screen vector.1699
If an intersection is found, returns True and places result in
1701
function ScreenVectorIntersectWithPlaneXY(
1702
const aScreenPoint: TVector; const z: Single;
1703
var intersectPoint: TVector): Boolean;
1704
{ Calculates intersection between plane YZ and screen vector.1705
If an intersection is found, returns True and places result in
1707
function ScreenVectorIntersectWithPlaneYZ(
1708
const aScreenPoint: TVector; const x: Single;
1709
var intersectPoint: TVector): Boolean;
1710
{ Calculates intersection between plane XZ and screen vector.1711
If an intersection is found, returns True and places result in
1713
function ScreenVectorIntersectWithPlaneXZ(
1714
const aScreenPoint: TVector; const y: Single;
1715
var intersectPoint: TVector): Boolean;
1716
{ Calculates a 3D coordinate from screen position and ZBuffer.1717
This function returns a world absolute coordinate from a 2D point
1718
in the viewer, the depth being extracted from the ZBuffer data
1719
(DepthTesting and ZBuffer must be enabled for this function to work).
1720
Note that ZBuffer precision is not linear and can be quite low on
1721
some boards (either from compression or resolution approximations). }
1722
function PixelRayToWorld(x, y: Integer): TAffineVector;
1723
{ Time (in second) spent to issue rendering order for the last frame.1724
Be aware that since execution by the hardware isn't synchronous,
1725
this value may not be an accurate measurement of the time it took
1726
to render the last frame, it's a measurement of only the time it
1727
took to issue rendering orders. }
1728
property LastFrameTime: Single read FLastFrameTime;
1729
{ Current FramesPerSecond rendering speed.1730
You must keep the renderer busy to get accurate figures from this
1732
This is an average value, to reset the counter, call
1733
ResetPerfomanceMonitor. }
1734
property FramesPerSecond: Single read FFramesPerSecond;
1735
{ Resets the perfomance monitor and begin a new statistics set.1736
See FramesPerSecond. }
1737
procedure ResetPerformanceMonitor;
1739
{ Retrieve one of the OpenGL limits for the current viewer.1740
Limits include max texture size, OpenGL stack depth, etc. }
1741
property LimitOf[Which: TLimitType]: Integer read GetLimit;
1742
{ Current rendering context.1743
The context is a wrapper around platform-specific contexts
1744
(see TGLContext) and takes care of context activation and handle
1746
property RenderingContext: TGLContext read FRenderingContext;
1747
{ The camera from which the scene is rendered.1748
A camera is an object you can add and define in a TGLScene component. }
1749
property Camera: TGLCamera read FCamera write SetCamera;
1750
{ Specifies the layer plane that the rendering context is bound to. }1751
property Layer: TGLContextLayer read FLayer write SetLayer
1752
default clMainPlane;
1755
{ Fog environment options.1756
See TGLFogEnvironment. }
1757
property FogEnvironment: TGLFogEnvironment read FFogEnvironment write
1758
SetGLFogEnvironment stored StoreFog;
1759
{ Color used for filling the background prior to any rendering. }1760
property BackgroundColor: TColor read FBackgroundColor write
1761
SetBackgroundColor default clBtnFace;
1762
{ Scene ambient color vector.1763
This ambient color is defined independantly from all lightsources,
1764
which can have their own ambient components. }
1765
property AmbientColor: TGLColor read FAmbientColor write SetAmbientColor;
1767
{ Context options allows to setup specifics of the rendering context.1768
Not all contexts support all options. }
1769
property ContextOptions: TContextOptions read FContextOptions write
1770
SetContextOptions default [roDoubleBuffer, roRenderToWindow, roDebugContext];
1771
{ Number of precision bits for the accumulation buffer. }1772
property AccumBufferBits: Integer read FAccumBufferBits write
1773
SetAccumBufferBits default 0;
1774
{ DepthTest enabling.1775
When DepthTest is enabled, objects closer to the camera will hide
1776
farther ones (via use of Z-Buffering).
1777
When DepthTest is disabled, the latest objects drawn/rendered overlap
1778
all previous objects, whatever their distance to the camera.
1779
Even when DepthTest is enabled, objects may chose to ignore depth
1780
testing through the osIgnoreDepthBuffer of their ObjectStyle property. }
1781
property DepthTest: Boolean read FDepthTest write SetDepthTest default True;
1782
{ Enable or disable face culling in the renderer.1783
Face culling is used in hidden faces removal algorithms : each face
1784
is given a normal or 'outside' direction. When face culling is enabled,
1785
only faces whose normal points towards the observer are rendered. }
1786
property FaceCulling: Boolean read FFaceCulling write SetFaceCulling default
1788
{ Toggle to enable or disable the fog settings. }1789
property FogEnable: Boolean read FFogEnable write SetFogEnable default
1791
{ Toggle to enable or disable lighting calculations.1792
When lighting is enabled, objects will be lit according to lightsources,
1793
when lighting is disabled, objects are rendered in their own colors,
1794
without any shading.
1795
Lighting does NOT generate shadows in OpenGL. }
1796
property Lighting: Boolean read FLighting write SetLighting default True;
1797
{ AntiAliasing option.1798
Ignored if not hardware supported, currently based on ARB_multisample. }
1799
property AntiAliasing: TGLAntiAliasing read FAntiAliasing write
1800
SetAntiAliasing default aaDefault;
1801
{ Depth buffer precision.1802
Default is highest available (below and including 24 bits) }
1803
property DepthPrecision: TGLDepthPrecision read FDepthPrecision write
1804
SetDepthPrecision default dpDefault;
1805
{ Color buffer depth.1806
Default depth buffer is highest available (below and including 24 bits) }
1807
property ColorDepth: TGLColorDepth read FColorDepth write SetColorDepth
1810
Default is "Smooth". }
1811
property ShadeModel: TGLShadeModel read FShadeModel write SetShadeModel
1814
{ Indicates a change in the scene or buffer options.1815
A simple re-render is enough to take into account the changes. }
1816
property OnChange: TNotifyEvent read FOnChange write FOnChange stored False;
1817
{ Indicates a structural change in the scene or buffer options.1818
A reconstruction of the RC is necessary to take into account the
1819
changes (this may lead to a driver switch or lengthy operations). }
1820
property OnStructuralChange: TNotifyEvent read FOnStructuralChange write
1821
FOnStructuralChange stored False;
1823
{ Triggered before the scene's objects get rendered.1824
You may use this event to execute your own OpenGL rendering
1825
(usually background stuff). }
1826
property BeforeRender: TNotifyEvent read FBeforeRender write FBeforeRender
1828
{ Triggered after BeforeRender, before rendering objects.1829
This one is fired after the rci has been initialized and can be used
1830
to alter it or perform early renderings that require an rci,
1831
the Sender is the buffer. }
1832
property InitiateRendering: TDirectRenderEvent read FInitiateRendering write
1833
FInitiateRendering stored False;
1834
{ Triggered after rendering all scene objects, before PostRender.1835
This is the last point after which the rci becomes unavailable,
1836
the Sender is the buffer. }
1837
property WrapUpRendering: TDirectRenderEvent read FWrapUpRendering write
1838
FWrapUpRendering stored False;
1839
{ Triggered just after all the scene's objects have been rendered.1840
The OpenGL context is still active in this event, and you may use it
1841
to execute your own OpenGL rendering (usually for HUD, 2D overlays
1842
or after effects). }
1843
property PostRender: TNotifyEvent read FPostRender write FPostRender stored
1845
{ Called after rendering.1846
You cannot issue OpenGL calls in this event, if you want to do your own
1847
OpenGL stuff, use the PostRender event. }
1848
property AfterRender: TNotifyEvent read FAfterRender write FAfterRender
1852
// TGLNonVisualViewer
1854
{ Base class for non-visual viewer.1855
Non-visual viewer may actually render visuals, but they are non-visual
1856
(ie. non interactive) at design time. Such viewers include memory
1857
or full-screen viewers. }
1858
TGLNonVisualViewer = class(TComponent)
1861
FBuffer: TGLSceneBuffer;
1862
FWidth, FHeight: Integer;
1863
FCubeMapRotIdx: Integer;
1864
FCubeMapZNear, FCubeMapZFar: Single;
1865
FCubeMapTranslation: TAffineVector;
1866
//FCreateTexture : Boolean;
1870
procedure SetBeforeRender(const val: TNotifyEvent);
1871
function GetBeforeRender: TNotifyEvent;
1872
procedure SetPostRender(const val: TNotifyEvent);
1873
function GetPostRender: TNotifyEvent;
1874
procedure SetAfterRender(const val: TNotifyEvent);
1875
function GetAfterRender: TNotifyEvent;
1876
procedure SetCamera(const val: TGLCamera);
1877
function GetCamera: TGLCamera;
1878
procedure SetBuffer(const val: TGLSceneBuffer);
1879
procedure SetWidth(const val: Integer);
1880
procedure SetHeight(const val: Integer);
1882
procedure SetupCubeMapCamera(Sender: TObject);
1883
procedure DoOnPrepareGLContext(Sender: TObject);
1884
procedure PrepareGLContext; dynamic;
1885
procedure DoBufferChange(Sender: TObject); virtual;
1886
procedure DoBufferStructuralChange(Sender: TObject); virtual;
1890
constructor Create(AOwner: TComponent); override;
1891
destructor Destroy; override;
1893
procedure Notification(AComponent: TComponent; Operation: TOperation);
1896
procedure Render(baseObject: TGLBaseSceneObject = nil); virtual; abstract;
1897
procedure CopyToTexture(aTexture: TGLTexture); overload; virtual;
1898
procedure CopyToTexture(aTexture: TGLTexture; xSrc, ySrc, width, height:
1900
xDest, yDest: Integer); overload;
1901
{ CopyToTexture for Multiple-Render-Target }1902
procedure CopyToTextureMRT(aTexture: TGLTexture; BufferIndex: integer);
1904
procedure CopyToTextureMRT(aTexture: TGLTexture; xSrc, ySrc, width, height:
1906
xDest, yDest: Integer; BufferIndex: integer); overload;
1907
{ Renders the 6 texture maps from a scene.1908
The viewer is used to render the 6 images, one for each face
1909
of the cube, from the absolute position of the camera.
1910
This does NOT alter the content of the Pictures in the image,
1911
and will only change or define the content of textures as
1912
registered by OpenGL. }
1913
procedure RenderCubeMapTextures(cubeMapTexture: TGLTexture;
1917
{Camera from which the scene is rendered. }1918
property Camera: TGLCamera read GetCamera write SetCamera;
1919
property Width: Integer read FWidth write SetWidth default 256;
1920
property Height: Integer read FHeight write SetHeight default 256;
1921
{Triggered before the scene's objects get rendered.1922
You may use this event to execute your own OpenGL rendering. }
1923
property BeforeRender: TNotifyEvent read GetBeforeRender write SetBeforeRender;
1924
{Triggered just after all the scene's objects have been rendered.1925
The OpenGL context is still active in this event, and you may use it
1926
to execute your own OpenGL rendering. }
1927
property PostRender: TNotifyEvent read GetPostRender write SetPostRender;
1928
{ Called after rendering.1929
You cannot issue OpenGL calls in this event, if you want to do your own
1930
OpenGL stuff, use the PostRender event. }
1931
property AfterRender: TNotifyEvent read GetAfterRender write SetAfterRender;
1933
{ Access to buffer properties. }1934
property Buffer: TGLSceneBuffer read FBuffer write SetBuffer;
1937
{Component to render a scene to memory only.1938
This component curently requires that the OpenGL ICD supports the
1939
WGL_ARB_pbuffer extension (indirectly). }
1940
TGLMemoryViewer = class(TGLNonVisualViewer)
1942
FBufferCount: integer;
1943
procedure SetBufferCount(const Value: integer);
1945
constructor Create(AOwner: TComponent); override;
1946
procedure InstantiateRenderingContext;
1947
procedure Render(baseObject: TGLBaseSceneObject = nil); override;
1949
{Set BufferCount > 1 for multiple render targets.1950
Users should check if the corresponding extension (GL_ATI_draw_buffers)
1951
is supported. Current hardware limit is BufferCount = 4. }
1952
property BufferCount: integer read FBufferCount write SetBufferCount default 1;
1955
TInvokeInfoForm = procedure(aSceneBuffer: TGLSceneBuffer; Modal: boolean);
1957
{ Register an event handler triggered by any TGLBaseSceneObject Name change.1958
*INCOMPLETE*, currently allows for only 1 (one) event, and is used by
1959
GLSceneEdit in the IDE. }
1960
procedure RegisterGLBaseSceneObjectNameChangeEvent(notifyEvent: TNotifyEvent);
1961
{Deregister an event handler triggered by any TGLBaseSceneObject Name change.1962
See RegisterGLBaseSceneObjectNameChangeEvent. }
1963
procedure DeRegisterGLBaseSceneObjectNameChangeEvent(notifyEvent: TNotifyEvent);
1964
{ Register an event handler triggered by any TGLBehaviour Name change.1965
*INCOMPLETE*, currently allows for only 1 (one) event, and is used by
1966
FBehavioursEditor in the IDE. }
1967
procedure RegisterGLBehaviourNameChangeEvent(notifyEvent: TNotifyEvent);
1968
{ Deregister an event handler triggered by any TGLBaseSceneObject Name change.1969
See RegisterGLBaseSceneObjectNameChangeEvent. }
1970
procedure DeRegisterGLBehaviourNameChangeEvent(notifyEvent: TNotifyEvent);
1972
{ Issues OpenGL calls for drawing X, Y, Z axes in a standard style. }1973
procedure AxesBuildList(var rci: TGLRenderContextInfo; pattern: Word; AxisLen:
1976
{Registers the procedure call used to invoke the info form. }1977
procedure RegisterInfoForm(infoForm: TInvokeInfoForm);
1978
procedure InvokeInfoForm(aSceneBuffer: TGLSceneBuffer; Modal: boolean);
1980
function GetCurrentRenderingObject: TGLBaseSceneObject;
1982
//------------------------------------------------------------------------------
1983
//------------------------------------------------------------------------------
1984
//------------------------------------------------------------------------------
1986
//------------------------------------------------------------------------------
1987
//------------------------------------------------------------------------------
1988
//------------------------------------------------------------------------------
1991
vCounterFrequency: Int64;
1992
{$IFNDEF GLS_MULTITHREAD}1997
vCurrentRenderingObject: TGLBaseSceneObject;
1999
function GetCurrentRenderingObject: TGLBaseSceneObject;
2001
Result := vCurrentRenderingObject;
2007
procedure AxesBuildList(var rci: TGLRenderContextInfo; pattern: Word; axisLen:
2010
{$IFDEF GLS_OPENGL_DEBUG}2011
if GL.GREMEDY_string_marker then
2012
GL.StringMarkerGREMEDY(13, 'AxesBuildList');
2014
with rci.GLStates do
2016
Disable(stLighting);
2017
if not rci.ignoreBlendingRequests then
2020
SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha);
2023
Enable(stLineStipple);
2024
LineStippleFactor := 1;
2025
LineStipplePattern := Pattern;
2026
DepthWriteMask := True;
2027
DepthFunc := cfLEqual;
2028
if rci.bufferDepthTest then
2029
Enable(stDepthTest);
2031
GL.Begin_(GL_LINES);
2032
GL.Color3f(0.5, 0.0, 0.0);
2033
GL.Vertex3f(0, 0, 0);
2034
GL.Vertex3f(-AxisLen, 0, 0);
2035
GL.Color3f(1.0, 0.0, 0.0);
2036
GL.Vertex3f(0, 0, 0);
2037
GL.Vertex3f(AxisLen, 0, 0);
2038
GL.Color3f(0.0, 0.5, 0.0);
2039
GL.Vertex3f(0, 0, 0);
2040
GL.Vertex3f(0, -AxisLen, 0);
2041
GL.Color3f(0.0, 1.0, 0.0);
2042
GL.Vertex3f(0, 0, 0);
2043
GL.Vertex3f(0, AxisLen, 0);
2044
GL.Color3f(0.0, 0.0, 0.5);
2045
GL.Vertex3f(0, 0, 0);
2046
GL.Vertex3f(0, 0, -AxisLen);
2047
GL.Color3f(0.0, 0.0, 1.0);
2048
GL.Vertex3f(0, 0, 0);
2049
GL.Vertex3f(0, 0, AxisLen);
2056
vInfoForm: TInvokeInfoForm = nil;
2058
procedure RegisterInfoForm(infoForm: TInvokeInfoForm);
2060
vInfoForm := infoForm;
2066
procedure InvokeInfoForm(aSceneBuffer: TGLSceneBuffer; Modal: boolean);
2068
if Assigned(vInfoForm) then
2069
vInfoForm(aSceneBuffer, Modal)
2071
InformationDlg('InfoForm not available.');2074
//------------------ internal global routines ----------------------------------
2077
vGLBaseSceneObjectNameChangeEvent: TNotifyEvent;
2078
vGLBehaviourNameChangeEvent: TNotifyEvent;
2080
// RegisterGLBaseSceneObjectNameChangeEvent
2083
procedure RegisterGLBaseSceneObjectNameChangeEvent(notifyEvent: TNotifyEvent);
2085
vGLBaseSceneObjectNameChangeEvent := notifyEvent;
2088
// DeRegisterGLBaseSceneObjectNameChangeEvent
2091
procedure DeRegisterGLBaseSceneObjectNameChangeEvent(notifyEvent: TNotifyEvent);
2093
vGLBaseSceneObjectNameChangeEvent := nil;
2096
// RegisterGLBehaviourNameChangeEvent
2099
procedure RegisterGLBehaviourNameChangeEvent(notifyEvent: TNotifyEvent);
2101
vGLBehaviourNameChangeEvent := notifyEvent;
2104
// DeRegisterGLBehaviourNameChangeEvent
2107
procedure DeRegisterGLBehaviourNameChangeEvent(notifyEvent: TNotifyEvent);
2109
vGLBehaviourNameChangeEvent := nil;
2112
// ------------------
2113
// ------------------ TGLBaseSceneObject ------------------
2114
// ------------------
2119
constructor TGLBaseSceneObject.Create(AOwner: TComponent);
2121
inherited Create(AOwner);
2123
FChanges := [ocTransformation, ocStructure,
2124
ocAbsoluteMatrix, ocInvAbsoluteMatrix];
2125
FPosition := TGLCoordinates.CreateInitialized(Self, NullHmgPoint, csPoint);
2126
FRotation := TGLCoordinates.CreateInitialized(Self, NullHmgVector, csVector);
2127
FDirection := TGLCoordinates.CreateInitialized(Self, ZHmgVector, csVector);
2128
FUp := TGLCoordinates.CreateInitialized(Self, YHmgVector, csVector);
2129
FScaling := TGLCoordinates.CreateInitialized(Self, XYZHmgVector, csVector);
2130
GetMem(FLocalMatrix, SizeOf(TMatrix));
2131
FLocalMatrix^ := IdentityHmgMatrix;
2134
FObjectsSorting := osInherited;
2135
FVisibilityCulling := vcInherited;
2137
fBBChanges := [oBBcChild, oBBcStructure];
2138
FBoundingBoxPersonalUnscaled := NullBoundingBox;
2139
FBoundingBoxOfChildren := NullBoundingBox;
2140
FBoundingBoxIncludingChildren := NullBoundingBox;
2146
constructor TGLBaseSceneObject.CreateAsChild(aParentOwner: TGLBaseSceneObject);
2148
Create(aParentOwner);
2149
aParentOwner.AddChild(Self);
2155
destructor TGLBaseSceneObject.Destroy;
2158
if assigned(FLocalMatrix) then
2159
FreeMem(FLocalMatrix, SizeOf(TMatrix));
2160
if assigned(FAbsoluteMatrix) then
2161
// This bug have coming surely from a bad commit file.
2162
FreeMem(FAbsoluteMatrix, SizeOf(TMatrix) * 2);
2163
// k00m memory fix and remove some leak of the old version.
2164
FGLObjectEffects.Free;
2172
if Assigned(FParent) then
2173
FParent.Remove(Self, False);
2174
if Assigned(FChildren) then
2185
function TGLBaseSceneObject.GetHandle(var rci: TGLRenderContextInfo): Cardinal;
2187
if not Assigned(FListHandle) then
2188
FListHandle := TGLListHandle.Create;
2189
Result := FListHandle.Handle;
2191
Result := FListHandle.AllocateHandle;
2193
if ocStructure in FChanges then
2195
ClearStructureChanged;
2196
FListHandle.NotifyChangesOfData;
2199
if FListHandle.IsDataNeedUpdate then
2201
rci.GLStates.NewList(Result, GL_COMPILE);
2205
rci.GLStates.EndList;
2207
FListHandle.NotifyDataUpdated;
2211
// ListHandleAllocated
2214
function TGLBaseSceneObject.ListHandleAllocated: Boolean;
2216
Result := Assigned(FListHandle)
2217
and (FListHandle.Handle <> 0)
2218
and not (ocStructure in FChanges);
2224
procedure TGLBaseSceneObject.DestroyHandle;
2226
if Assigned(FListHandle) then
2227
FListHandle.DestroyHandle;
2233
procedure TGLBaseSceneObject.DestroyHandles;
2237
for i := 0 to Count - 1 do
2238
Children[i].DestroyHandles;
2245
procedure TGLBaseSceneObject.SetBBChanges(const Value: TObjectBBChanges);
2247
if value <> fBBChanges then
2249
fBBChanges := Value;
2250
if Assigned(FParent) then
2251
FParent.BBChanges := FParent.BBChanges + [oBBcChild];
2258
function TGLBaseSceneObject.Blended: Boolean;
2266
procedure TGLBaseSceneObject.BeginUpdate;
2274
procedure TGLBaseSceneObject.EndUpdate;
2276
if FUpdateCount > 0 then
2279
if FUpdateCount = 0 then
2283
Assert(False, glsUnBalancedBeginEndUpdate);
2289
procedure TGLBaseSceneObject.BuildList(var rci: TGLRenderContextInfo);
2294
// DeleteChildCameras
2297
procedure TGLBaseSceneObject.DeleteChildCameras;
2300
child: TGLBaseSceneObject;
2303
if Assigned(FChildren) then
2304
while i < FChildren.Count do
2306
child := TGLBaseSceneObject(FChildren.List^[i]);
2307
child.DeleteChildCameras;
2308
if child is TGLCamera then
2310
Remove(child, True);
2321
procedure TGLBaseSceneObject.DeleteChildren;
2323
child: TGLBaseSceneObject;
2326
if Assigned(FScene) then
2327
FScene.RemoveLights(Self);
2328
if Assigned(FChildren) then
2329
while FChildren.Count > 0 do
2331
child := TGLBaseSceneObject(FChildren.Pop);
2332
child.FParent := nil;
2335
BBChanges := BBChanges + [oBBcChild];
2341
procedure TGLBaseSceneObject.Loaded;
2345
if Assigned(FGLBehaviours) then
2346
FGLBehaviours.Loaded;
2347
if Assigned(FGLObjectEffects) then
2348
FGLObjectEffects.Loaded;
2354
procedure TGLBaseSceneObject.DefineProperties(Filer: TFiler);
2357
{FOriginalFiler := Filer;}2359
Filer.DefineBinaryProperty('BehavioursData',2360
ReadBehaviours, WriteBehaviours,
2361
(Assigned(FGLBehaviours) and (FGLBehaviours.Count > 0)));
2362
Filer.DefineBinaryProperty('EffectsData',2363
ReadEffects, WriteEffects,
2364
(Assigned(FGLObjectEffects) and (FGLObjectEffects.Count > 0)));
2365
{FOriginalFiler:=nil;}2371
procedure TGLBaseSceneObject.WriteBehaviours(stream: TStream);
2375
writer := TWriter.Create(stream, 16384);
2377
Behaviours.WriteToFiler(writer);
2386
procedure TGLBaseSceneObject.ReadBehaviours(stream: TStream);
2390
reader := TReader.Create(stream, 16384);
2391
{ with TReader(FOriginalFiler) do }2393
{ reader.Root := Root;2394
reader.OnError := OnError;
2395
reader.OnFindMethod := OnFindMethod;
2396
reader.OnSetName := OnSetName;
2397
reader.OnReferenceName := OnReferenceName;
2398
reader.OnAncestorNotFound := OnAncestorNotFound;
2399
reader.OnCreateComponent := OnCreateComponent;
2400
reader.OnFindComponentClass := OnFindComponentClass;}
2401
Behaviours.ReadFromFiler(reader);
2410
procedure TGLBaseSceneObject.WriteEffects(stream: TStream);
2414
writer := TWriter.Create(stream, 16384);
2416
Effects.WriteToFiler(writer);
2425
procedure TGLBaseSceneObject.ReadEffects(stream: TStream);
2429
reader := TReader.Create(stream, 16384);
2430
{with TReader(FOriginalFiler) do }2432
{ reader.Root := Root;2433
reader.OnError := OnError;
2434
reader.OnFindMethod := OnFindMethod;
2435
reader.OnSetName := OnSetName;
2436
reader.OnReferenceName := OnReferenceName;
2437
reader.OnAncestorNotFound := OnAncestorNotFound;
2438
reader.OnCreateComponent := OnCreateComponent;
2439
reader.OnFindComponentClass := OnFindComponentClass; }
2440
Effects.ReadFromFiler(reader);
2449
procedure TGLBaseSceneObject.WriteRotations(stream: TStream);
2451
stream.Write(FRotation.AsAddress^, 3 * SizeOf(TGLFloat));
2457
procedure TGLBaseSceneObject.ReadRotations(stream: TStream);
2459
stream.Read(FRotation.AsAddress^, 3 * SizeOf(TGLFloat));
2465
procedure TGLBaseSceneObject.DrawAxes(var rci: TGLRenderContextInfo; pattern:
2468
AxesBuildList(rci, Pattern, rci.rcci.farClippingDistance -
2469
rci.rcci.nearClippingDistance);
2475
procedure TGLBaseSceneObject.GetChildren(AProc: TGetChildProc; Root: TComponent);
2479
if Assigned(FChildren) then
2480
for i := 0 to FChildren.Count - 1 do
2481
if not IsSubComponent(TComponent(FChildren.List^[i])) then
2482
AProc(TComponent(FChildren.List^[i]));
2488
function TGLBaseSceneObject.Get(Index: Integer): TGLBaseSceneObject;
2490
if Assigned(FChildren) then
2491
Result := TGLBaseSceneObject(FChildren[Index])
2499
function TGLBaseSceneObject.GetCount: Integer;
2501
if Assigned(FChildren) then
2502
Result := FChildren.Count
2510
function TGLBaseSceneObject.HasSubChildren: Boolean;
2516
for I := 0 to Count - 1 do
2517
if IsSubComponent(Children[i]) then
2527
procedure TGLBaseSceneObject.AddChild(aChild: TGLBaseSceneObject);
2529
if Assigned(FScene) then
2530
FScene.AddLights(aChild);
2531
if not Assigned(FChildren) then
2532
FChildren := TPersistentObjectList.Create;
2533
FChildren.Add(aChild);
2534
aChild.FParent := Self;
2535
aChild.SetScene(FScene);
2536
TransformationChanged;
2537
aChild.TransformationChanged;
2538
aChild.DoOnAddedToParent;
2539
BBChanges := BBChanges + [oBBcChild];
2545
function TGLBaseSceneObject.AddNewChild(aChild: TGLSceneObjectClass):
2548
Result := aChild.Create(Owner);
2555
function TGLBaseSceneObject.AddNewChildFirst(aChild: TGLSceneObjectClass):
2558
Result := aChild.Create(Owner);
2562
// GetOrCreateBehaviour
2565
function TGLBaseSceneObject.GetOrCreateBehaviour(aBehaviour: TGLBehaviourClass):
2568
Result := TGLBehaviour(Behaviours.GetOrCreate(aBehaviour));
2574
function TGLBaseSceneObject.AddNewBehaviour(aBehaviour: TGLBehaviourClass):
2577
Assert(Behaviours.CanAdd(aBehaviour));
2578
result := aBehaviour.Create(Behaviours)
2584
function TGLBaseSceneObject.GetOrCreateEffect(anEffect: TGLObjectEffectClass):
2587
Result := TGLObjectEffect(Effects.GetOrCreate(anEffect));
2593
function TGLBaseSceneObject.AddNewEffect(anEffect: TGLObjectEffectClass):
2596
Assert(Effects.CanAdd(anEffect));
2597
result := anEffect.Create(Effects)
2603
procedure TGLBaseSceneObject.RebuildMatrix;
2605
if ocTransformation in Changes then
2607
VectorScale(LeftVector, Scale.X, FLocalMatrix^.V[0]);
2608
VectorScale(FUp.AsVector, Scale.Y, FLocalMatrix^.V[1]);
2609
VectorScale(FDirection.AsVector, Scale.Z, FLocalMatrix^.V[2]);
2610
SetVector(FLocalMatrix^.V[3], FPosition.AsVector);
2611
Exclude(FChanges, ocTransformation);
2612
Include(FChanges, ocAbsoluteMatrix);
2613
Include(FChanges, ocInvAbsoluteMatrix);
2620
procedure TGLBaseSceneObject.ForceLocalMatrix(const aMatrix: TMatrix);
2622
FLocalMatrix^ := aMatrix;
2623
Exclude(FChanges, ocTransformation);
2624
Include(FChanges, ocAbsoluteMatrix);
2625
Include(FChanges, ocInvAbsoluteMatrix);
2628
// AbsoluteMatrixAsAddress
2631
function TGLBaseSceneObject.AbsoluteMatrixAsAddress: PMatrix;
2633
if ocAbsoluteMatrix in FChanges then
2636
if not Assigned(FAbsoluteMatrix) then
2638
GetMem(FAbsoluteMatrix, SizeOf(TMatrix) * 2);
2639
FInvAbsoluteMatrix := PMatrix(PtrUInt(FAbsoluteMatrix) + SizeOf(TMatrix));
2641
if Assigned(Parent) and (not (Parent is TGLSceneRootObject)) then
2643
MatrixMultiply(FLocalMatrix^,
2644
TGLBaseSceneObject(Parent).AbsoluteMatrixAsAddress^,
2648
FAbsoluteMatrix^ := FLocalMatrix^;
2649
Exclude(FChanges, ocAbsoluteMatrix);
2650
Include(FChanges, ocInvAbsoluteMatrix);
2652
Result := FAbsoluteMatrix;
2658
function TGLBaseSceneObject.InvAbsoluteMatrix: TMatrix;
2660
Result := InvAbsoluteMatrixAsAddress^;
2666
function TGLBaseSceneObject.InvAbsoluteMatrixAsAddress: PMatrix;
2668
if ocInvAbsoluteMatrix in FChanges then
2670
if VectorEquals(Scale.DirectVector, XYZHmgVector) then
2672
if not Assigned(FAbsoluteMatrix) then
2674
GetMem(FAbsoluteMatrix, SizeOf(TMatrix) * 2);
2675
FInvAbsoluteMatrix := PMatrix(PtrUInt(FAbsoluteMatrix) +
2679
if Parent <> nil then
2680
FInvAbsoluteMatrix^ :=
2681
MatrixMultiply(Parent.InvAbsoluteMatrixAsAddress^,
2682
AnglePreservingMatrixInvert(FLocalMatrix^))
2684
FInvAbsoluteMatrix^ := AnglePreservingMatrixInvert(FLocalMatrix^);
2688
FInvAbsoluteMatrix^ := AbsoluteMatrixAsAddress^;
2689
InvertMatrix(FInvAbsoluteMatrix^);
2691
Exclude(FChanges, ocInvAbsoluteMatrix);
2693
Result := FInvAbsoluteMatrix;
2699
function TGLBaseSceneObject.GetAbsoluteMatrix: TMatrix;
2701
Result := AbsoluteMatrixAsAddress^;
2707
procedure TGLBaseSceneObject.SetAbsoluteMatrix(const Value: TMatrix);
2709
if not MatrixEquals(Value, FAbsoluteMatrix^) then
2711
FAbsoluteMatrix^ := Value;
2712
if Parent <> nil then
2713
SetMatrix(MatrixMultiply(FAbsoluteMatrix^,
2714
Parent.InvAbsoluteMatrixAsAddress^))
2720
// GetAbsoluteDirection
2723
function TGLBaseSceneObject.GetAbsoluteDirection: TVector;
2725
Result := VectorNormalize(AbsoluteMatrixAsAddress^.V[2]);
2728
// SetAbsoluteDirection
2731
procedure TGLBaseSceneObject.SetAbsoluteDirection(const v: TVector);
2733
if Parent <> nil then
2734
Direction.AsVector := Parent.AbsoluteToLocal(v)
2736
Direction.AsVector := v;
2742
function TGLBaseSceneObject.GetAbsoluteScale: TVector;
2744
Result.V[0] := AbsoluteMatrixAsAddress^.V[0].V[0];
2745
Result.V[1] := AbsoluteMatrixAsAddress^.V[1].V[1];
2746
Result.V[2] := AbsoluteMatrixAsAddress^.V[2].V[2];
2754
procedure TGLBaseSceneObject.SetAbsoluteScale(const Value: TVector);
2756
if Parent <> nil then
2757
Scale.AsVector := Parent.AbsoluteToLocal(Value)
2759
Scale.AsVector := Value;
2765
function TGLBaseSceneObject.GetAbsoluteUp: TVector;
2767
Result := VectorNormalize(AbsoluteMatrixAsAddress^.V[1]);
2773
procedure TGLBaseSceneObject.SetAbsoluteUp(const v: TVector);
2775
if Parent <> nil then
2776
Up.AsVector := Parent.AbsoluteToLocal(v)
2784
function TGLBaseSceneObject.AbsoluteRight: TVector;
2786
Result := VectorNormalize(AbsoluteMatrixAsAddress^.V[0]);
2792
function TGLBaseSceneObject.AbsoluteLeft: TVector;
2794
Result := VectorNegate(AbsoluteRight);
2797
// GetAbsolutePosition
2800
function TGLBaseSceneObject.GetAbsolutePosition: TVector;
2802
Result := AbsoluteMatrixAsAddress^.V[3];
2805
// SetAbsolutePosition
2808
procedure TGLBaseSceneObject.SetAbsolutePosition(const v: TVector);
2810
if Assigned(Parent) then
2811
Position.AsVector := Parent.AbsoluteToLocal(v)
2813
Position.AsVector := v;
2816
// AbsolutePositionAsAddress
2819
function TGLBaseSceneObject.AbsolutePositionAsAddress: PVector;
2821
Result := @AbsoluteMatrixAsAddress^.V[3];
2827
function TGLBaseSceneObject.AbsoluteXVector: TVector;
2829
AbsoluteMatrixAsAddress;
2830
SetVector(Result, PAffineVector(@FAbsoluteMatrix.V[0])^);
2836
function TGLBaseSceneObject.AbsoluteYVector: TVector;
2838
AbsoluteMatrixAsAddress;
2839
SetVector(Result, PAffineVector(@FAbsoluteMatrix.V[1])^);
2845
function TGLBaseSceneObject.AbsoluteZVector: TVector;
2847
AbsoluteMatrixAsAddress;
2848
SetVector(Result, PAffineVector(@FAbsoluteMatrix.V[2])^);
2851
// AbsoluteToLocal (hmg)
2854
function TGLBaseSceneObject.AbsoluteToLocal(const v: TVector): TVector;
2856
Result := VectorTransform(v, InvAbsoluteMatrixAsAddress^);
2859
// AbsoluteToLocal (affine)
2862
function TGLBaseSceneObject.AbsoluteToLocal(const v: TAffineVector):
2865
Result := VectorTransform(v, InvAbsoluteMatrixAsAddress^);
2868
// LocalToAbsolute (hmg)
2871
function TGLBaseSceneObject.LocalToAbsolute(const v: TVector): TVector;
2873
Result := VectorTransform(v, AbsoluteMatrixAsAddress^);
2876
// LocalToAbsolute (affine)
2879
function TGLBaseSceneObject.LocalToAbsolute(const v: TAffineVector):
2882
Result := VectorTransform(v, AbsoluteMatrixAsAddress^);
2888
function TGLBaseSceneObject.Right: TVector;
2890
Result := VectorCrossProduct(FDirection.AsVector, FUp.AsVector);
2896
function TGLBaseSceneObject.LeftVector: TVector;
2898
Result := VectorCrossProduct(FUp.AsVector, FDirection.AsVector);
2901
// BarycenterAbsolutePosition
2904
function TGLBaseSceneObject.BarycenterAbsolutePosition: TVector;
2906
Result := AbsolutePosition;
2909
// SqrDistanceTo (obj)
2912
function TGLBaseSceneObject.SqrDistanceTo(anObject: TGLBaseSceneObject): Single;
2914
if Assigned(anObject) then
2915
Result := VectorDistance2(AbsolutePosition, anObject.AbsolutePosition)
2920
// SqrDistanceTo (vec4)
2923
function TGLBaseSceneObject.SqrDistanceTo(const pt: TVector): Single;
2925
Result := VectorDistance2(pt, AbsolutePosition);
2931
function TGLBaseSceneObject.DistanceTo(anObject: TGLBaseSceneObject): Single;
2933
if Assigned(anObject) then
2934
Result := VectorDistance(AbsolutePosition, anObject.AbsolutePosition)
2942
function TGLBaseSceneObject.DistanceTo(const pt: TVector): Single;
2944
Result := VectorDistance(AbsolutePosition, pt);
2947
// BarycenterSqrDistanceTo
2950
function TGLBaseSceneObject.BarycenterSqrDistanceTo(const pt: TVector): Single;
2954
d := BarycenterAbsolutePosition;
2955
Result := VectorDistance2(d, pt);
2958
// AxisAlignedDimensions
2961
function TGLBaseSceneObject.AxisAlignedDimensions: TVector;
2963
Result := AxisAlignedDimensionsUnscaled();
2964
ScaleVector(Result, Scale.AsVector);
2967
// AxisAlignedDimensionsUnscaled
2970
function TGLBaseSceneObject.AxisAlignedDimensionsUnscaled: TVector;
2978
// AxisAlignedBoundingBox
2981
function TGLBaseSceneObject.AxisAlignedBoundingBox(
2982
const AIncludeChilden: Boolean): TAABB;
2986
child: TGLBaseSceneObject;
2988
SetAABB(Result, AxisAlignedDimensionsUnscaled);
2989
// not tested for child objects
2990
if AIncludeChilden and Assigned(FChildren) then
2992
for i := 0 to FChildren.Count - 1 do
2994
child := TGLBaseSceneObject(FChildren.List^[i]);
2995
aabb := child.AxisAlignedBoundingBoxUnscaled(AIncludeChilden);
2996
AABBTransform(aabb, child.Matrix);
2997
AddAABB(Result, aabb);
3000
AABBScale(Result, Scale.AsAffineVector);
3003
// AxisAlignedBoundingBoxUnscaled
3006
function TGLBaseSceneObject.AxisAlignedBoundingBoxUnscaled(
3007
const AIncludeChilden: Boolean): TAABB;
3012
SetAABB(Result, AxisAlignedDimensionsUnscaled);
3013
//not tested for child objects
3014
if AIncludeChilden and Assigned(FChildren) then
3016
for i := 0 to FChildren.Count - 1 do
3019
TGLBaseSceneObject(FChildren.List^[i]).AxisAlignedBoundingBoxUnscaled(AIncludeChilden);
3020
AABBTransform(aabb, TGLBaseSceneObject(FChildren.List^[i]).Matrix);
3021
AddAABB(Result, aabb);
3026
// AxisAlignedBoundingBoxAbsolute
3029
function TGLBaseSceneObject.AxisAlignedBoundingBoxAbsolute(
3030
const AIncludeChilden: Boolean; const AUseBaryCenter: Boolean): TAABB;
3032
Result := BBToAABB(BoundingBoxAbsolute(AIncludeChilden, AUseBaryCenter));
3038
function TGLBaseSceneObject.BoundingBox(const AIncludeChilden: Boolean;
3039
const AUseBaryCenter: Boolean): THmgBoundingBox;
3041
CurrentBaryOffset: TVector;
3043
Result := AABBToBB(AxisAlignedBoundingBox(AIncludeChilden));
3045
// DaStr: code not tested...
3046
if AUseBaryCenter then
3048
CurrentBaryOffset :=
3049
VectorSubtract(AbsoluteToLocal(BarycenterAbsolutePosition),
3051
OffsetBBPoint(Result, CurrentBaryOffset);
3055
// BoundingBoxUnscaled
3058
function TGLBaseSceneObject.BoundingBoxUnscaled(
3059
const AIncludeChilden: Boolean;
3060
const AUseBaryCenter: Boolean): THmgBoundingBox;
3062
CurrentBaryOffset: TVector;
3064
Result := AABBToBB(AxisAlignedBoundingBoxUnscaled(AIncludeChilden));
3066
// DaStr: code not tested...
3067
if AUseBaryCenter then
3069
CurrentBaryOffset :=
3070
VectorSubtract(AbsoluteToLocal(BarycenterAbsolutePosition),
3072
OffsetBBPoint(Result, CurrentBaryOffset);
3076
// BoundingBoxAbsolute
3079
function TGLBaseSceneObject.BoundingBoxAbsolute(
3080
const AIncludeChilden: Boolean;
3081
const AUseBaryCenter: Boolean): THmgBoundingBox;
3084
CurrentBaryOffset: TVector;
3086
Result := BoundingBoxUnscaled(AIncludeChilden, False);
3088
Result.BBox[I] := LocalToAbsolute(Result.BBox[I]);
3090
if AUseBaryCenter then
3092
CurrentBaryOffset := VectorSubtract(BarycenterAbsolutePosition,
3094
OffsetBBPoint(Result, CurrentBaryOffset);
3098
// BoundingSphereRadius
3101
function TGLBaseSceneObject.BoundingSphereRadius: Single;
3103
Result := VectorLength(AxisAlignedDimensions);
3106
// BoundingSphereRadiusUnscaled
3109
function TGLBaseSceneObject.BoundingSphereRadiusUnscaled: Single;
3111
Result := VectorLength(AxisAlignedDimensionsUnscaled);
3117
function TGLBaseSceneObject.PointInObject(const point: TVector): Boolean;
3119
localPt, dim: TVector;
3121
dim := AxisAlignedDimensions;
3122
localPt := VectorTransform(point, InvAbsoluteMatrix);
3123
Result := (Abs(localPt.V[0] * Scale.X) <= dim.V[0]) and
3124
(Abs(localPt.V[1] * Scale.Y) <= dim.V[1]) and
3125
(Abs(localPt.V[2] * Scale.Z) <= dim.V[2]);
3128
// CalculateBoundingBoxPersonalUnscaled
3131
procedure TGLBaseSceneObject.CalculateBoundingBoxPersonalUnscaled(var
3132
ANewBoundingBox: THmgBoundingBox);
3134
// Using the standard method to get the local BB.
3135
ANewBoundingBox := AABBToBB(AxisAlignedBoundingBoxUnscaled(False));
3136
OffsetBBPoint(ANewBoundingBox, AbsoluteToLocal(BarycenterAbsolutePosition));
3139
// BoundingBoxPersonalUnscaledEx
3142
function TGLBaseSceneObject.BoundingBoxPersonalUnscaledEx: THmgBoundingBox;
3144
if oBBcStructure in FBBChanges then
3146
CalculateBoundingBoxPersonalUnscaled(FBoundingBoxPersonalUnscaled);
3147
Exclude(FBBChanges, oBBcStructure);
3149
Result := FBoundingBoxPersonalUnscaled;
3152
// AxisAlignedBoundingBoxAbsoluteEx
3155
function TGLBaseSceneObject.AxisAlignedBoundingBoxAbsoluteEx: TAABB;
3157
pBB: THmgBoundingBox;
3159
pBB := BoundingBoxIncludingChildrenEx;
3160
BBTransform(pBB, AbsoluteMatrix);
3161
Result := BBtoAABB(pBB);
3164
// AxisAlignedBoundingBoxEx
3167
function TGLBaseSceneObject.AxisAlignedBoundingBoxEx: TAABB;
3169
Result := BBtoAABB(BoundingBoxIncludingChildrenEx);
3170
AABBScale(Result, Scale.AsAffineVector);
3173
// BoundingBoxOfChildrenEx
3176
function TGLBaseSceneObject.BoundingBoxOfChildrenEx: THmgBoundingBox;
3179
pBB: THmgBoundingBox;
3181
if oBBcChild in FBBChanges then
3184
FBoundingBoxOfChildren := NullBoundingBox;
3185
if assigned(FChildren) then
3187
for i := 0 to FChildren.count - 1 do
3190
TGLBaseSceneObject(FChildren.List^[i]).BoundingBoxIncludingChildrenEx;
3191
if not BoundingBoxesAreEqual(@pBB, @NullBoundingBox) then
3193
// transformation with local matrix
3194
BBTransform(pbb, TGLBaseSceneObject(FChildren.List^[i]).Matrix);
3195
if BoundingBoxesAreEqual(@FBoundingBoxOfChildren, @NullBoundingBox) then
3196
FBoundingBoxOfChildren := pBB
3198
AddBB(FBoundingBoxOfChildren, pBB);
3202
exclude(FBBChanges, oBBcChild);
3204
result := FBoundingBoxOfChildren;
3207
// BoundingBoxIncludingChildrenEx
3210
function TGLBaseSceneObject.BoundingBoxIncludingChildrenEx: THmgBoundingBox;
3212
pBB: THmgBoundingBox;
3214
if (oBBcStructure in FBBChanges) or
3215
(oBBcChild in FBBChanges) then
3217
pBB := BoundingBoxPersonalUnscaledEx;
3218
if BoundingBoxesAreEqual(@pBB, @NullBoundingBox) then
3219
FBoundingBoxIncludingChildren := BoundingBoxOfChildrenEx
3222
FBoundingBoxIncludingChildren := pBB;
3223
pBB := BoundingBoxOfChildrenEx;
3224
if not BoundingBoxesAreEqual(@pBB, @NullBoundingBox) then
3225
AddBB(FBoundingBoxIncludingChildren, pBB);
3228
Result := FBoundingBoxIncludingChildren;
3234
function TGLBaseSceneObject.RayCastIntersect(const rayStart, rayVector: TVector;
3235
intersectPoint: PVector = nil;
3236
intersectNormal: PVector = nil): Boolean;
3238
i1, i2, absPos: TVector;
3240
SetVector(absPos, AbsolutePosition);
3241
if RayCastSphereIntersect(rayStart, rayVector, absPos, BoundingSphereRadius,
3245
if Assigned(intersectPoint) then
3246
SetVector(intersectPoint^, i1);
3247
if Assigned(intersectNormal) then
3249
SubtractVector(i1, absPos);
3250
NormalizeVector(i1);
3251
SetVector(intersectNormal^, i1);
3258
// GenerateSilhouette
3261
function TGLBaseSceneObject.GenerateSilhouette(const silhouetteParameters:
3262
TGLSilhouetteParameters): TGLSilhouette;
3267
d, r, vr, s, c, angleFactor: Single;
3268
sVec, tVec: TAffineVector;
3270
r := BoundingSphereRadiusUnscaled;
3271
d := VectorLength(silhouetteParameters.SeenFrom);
3272
// determine visible radius
3273
case silhouetteParameters.Style of
3274
ssOmni: vr := SphereVisibleRadius(d, r);
3275
ssParallel: vr := r;
3280
// determine a local orthonormal matrix, viewer-oriented
3281
sVec := VectorCrossProduct(silhouetteParameters.SeenFrom, XVector);
3282
if VectorLength(sVec) < 1e-3 then
3283
sVec := VectorCrossProduct(silhouetteParameters.SeenFrom, YVector);
3284
tVec := VectorCrossProduct(silhouetteParameters.SeenFrom, sVec);
3285
NormalizeVector(sVec);
3286
NormalizeVector(tVec);
3287
// generate the silhouette (outline and capping)
3288
Result := TGLSilhouette.Create;
3289
angleFactor := (2 * PI) / cNbSegments;
3291
for i := 0 to cNbSegments - 1 do
3293
SinCos(i * angleFactor, vr, s, c);
3294
Result.Vertices.AddPoint(VectorCombine(sVec, tVec, s, c));
3295
j := (i + 1) mod cNbSegments;
3296
Result.Indices.Add(i, j);
3297
if silhouetteParameters.CappingRequired then
3298
Result.CapIndices.Add(cNbSegments, i, j)
3300
if silhouetteParameters.CappingRequired then
3301
Result.Vertices.Add(NullHmgPoint);
3307
procedure TGLBaseSceneObject.Assign(Source: TPersistent);
3310
child, newChild: TGLBaseSceneObject;
3312
if Assigned(Source) and (Source is TGLBaseSceneObject) then
3315
FVisible := TGLBaseSceneObject(Source).FVisible;
3316
TGLBaseSceneObject(Source).RebuildMatrix;
3317
SetMatrix(TGLBaseSceneObject(Source).FLocalMatrix^);
3318
FShowAxes := TGLBaseSceneObject(Source).FShowAxes;
3319
FObjectsSorting := TGLBaseSceneObject(Source).FObjectsSorting;
3320
FVisibilityCulling := TGLBaseSceneObject(Source).FVisibilityCulling;
3321
FRotation.Assign(TGLBaseSceneObject(Source).FRotation);
3323
if Assigned(Scene) then
3325
if Assigned(TGLBaseSceneObject(Source).FChildren) then
3327
for i := 0 to TGLBaseSceneObject(Source).FChildren.Count - 1 do
3329
child := TGLBaseSceneObject(TGLBaseSceneObject(Source).FChildren[i]);
3330
newChild := AddNewChild(TGLSceneObjectClass(child.ClassType));
3331
newChild.Assign(child);
3334
if Assigned(Scene) then
3336
OnProgress := TGLBaseSceneObject(Source).OnProgress;
3337
if Assigned(TGLBaseSceneObject(Source).FGLBehaviours) then
3338
Behaviours.Assign(TGLBaseSceneObject(Source).Behaviours)
3340
FreeAndNil(FGLBehaviours);
3341
if Assigned(TGLBaseSceneObject(Source).FGLObjectEffects) then
3342
Effects.Assign(TGLBaseSceneObject(Source).Effects)
3344
FreeAndNil(FGLObjectEffects);
3345
Tag := TGLBaseSceneObject(Source).Tag;
3346
FTagFloat := TGLBaseSceneObject(Source).FTagFloat;
3349
inherited Assign(Source);
3355
function TGLBaseSceneObject.IsUpdating: Boolean;
3357
Result := (FUpdateCount <> 0) or (csReading in ComponentState);
3360
// GetParentComponent
3363
function TGLBaseSceneObject.GetParentComponent: TComponent;
3365
if FParent is TGLSceneRootObject then
3374
function TGLBaseSceneObject.HasParent: Boolean;
3376
Result := assigned(FParent);
3382
procedure TGLBaseSceneObject.Lift(aDistance: Single);
3384
FPosition.AddScaledVector(aDistance, FUp.AsVector);
3385
TransformationChanged;
3391
procedure TGLBaseSceneObject.Move(ADistance: Single);
3393
FPosition.AddScaledVector(ADistance, FDirection.AsVector);
3394
TransformationChanged;
3400
procedure TGLBaseSceneObject.Slide(ADistance: Single);
3402
FPosition.AddScaledVector(ADistance, Right);
3403
TransformationChanged;
3409
procedure TGLBaseSceneObject.ResetRotations;
3411
FillChar(FLocalMatrix^, SizeOf(TMatrix), 0);
3412
FLocalMatrix^.V[0].V[0] := Scale.DirectX;
3413
FLocalMatrix^.V[1].V[1] := Scale.DirectY;
3414
FLocalMatrix^.V[2].V[2] := Scale.DirectZ;
3415
SetVector(FLocalMatrix^.V[3], Position.DirectVector);
3416
FRotation.DirectVector := NullHmgPoint;
3417
FDirection.DirectVector := ZHmgVector;
3418
FUp.DirectVector := YHmgVector;
3419
TransformationChanged;
3420
Exclude(FChanges, ocTransformation);
3423
// ResetAndPitchTurnRoll
3426
procedure TGLBaseSceneObject.ResetAndPitchTurnRoll(const degX, degY, degZ:
3434
rotMatrix := CreateRotationMatrix(Right, degX * cPIdiv180);
3435
V := VectorTransform(FUp.AsVector, rotMatrix);
3437
FUp.DirectVector := V;
3438
V := VectorTransform(FDirection.AsVector, rotMatrix);
3440
FDirection.DirectVector := V;
3441
FRotation.DirectX := NormalizeDegAngle(DegX);
3443
rotMatrix := CreateRotationMatrix(FUp.AsVector, degY * cPIdiv180);
3444
V := VectorTransform(FUp.AsVector, rotMatrix);
3446
FUp.DirectVector := V;
3447
V := VectorTransform(FDirection.AsVector, rotMatrix);
3449
FDirection.DirectVector := V;
3450
FRotation.DirectY := NormalizeDegAngle(DegY);
3452
rotMatrix := CreateRotationMatrix(Direction.AsVector, degZ * cPIdiv180);
3453
V := VectorTransform(FUp.AsVector, rotMatrix);
3455
FUp.DirectVector := V;
3456
V := VectorTransform(FDirection.AsVector, rotMatrix);
3458
FDirection.DirectVector := V;
3459
FRotation.DirectZ := NormalizeDegAngle(DegZ);
3460
TransformationChanged;
3467
procedure TGLBaseSceneObject.RotateAbsolute(const rx, ry, rz: Single);
3473
// No we build rotation matrices and use them to rotate the obj
3476
SetVector(v, AbsoluteToLocal(XVector));
3477
resMat := MatrixMultiply(CreateRotationMatrix(v, -DegToRad(rx)), resMat);
3481
SetVector(v, AbsoluteToLocal(YVector));
3482
resMat := MatrixMultiply(CreateRotationMatrix(v, -DegToRad(ry)), resMat);
3486
SetVector(v, AbsoluteToLocal(ZVector));
3487
resMat := MatrixMultiply(CreateRotationMatrix(v, -DegToRad(rz)), resMat);
3495
procedure TGLBaseSceneObject.RotateAbsolute(const axis: TAffineVector; angle:
3502
SetVector(v, AbsoluteToLocal(axis));
3503
Matrix := MatrixMultiply(CreateRotationMatrix(v, DegToRad(angle)), Matrix);
3510
procedure TGLBaseSceneObject.Pitch(angle: Single);
3513
rightVector: TVector;
3515
FIsCalculating := True;
3517
angle := -DegToRad(angle);
3518
rightVector := Right;
3519
FUp.Rotate(rightVector, angle);
3521
FDirection.Rotate(rightVector, angle);
3522
FDirection.Normalize;
3523
r := -RadToDeg(ArcTan2(FDirection.Y, VectorLength(FDirection.X,
3525
if FDirection.X < 0 then
3526
if FDirection.Y < 0 then
3532
FIsCalculating := False;
3534
TransformationChanged;
3540
procedure TGLBaseSceneObject.SetPitchAngle(AValue: Single);
3545
if AValue <> FRotation.X then
3547
if not (csLoading in ComponentState) then
3549
FIsCalculating := True;
3551
diff := DegToRad(FRotation.X - AValue);
3552
rotMatrix := CreateRotationMatrix(Right, diff);
3553
FUp.DirectVector := VectorTransform(FUp.AsVector, rotMatrix);
3555
FDirection.DirectVector := VectorTransform(FDirection.AsVector,
3557
FDirection.Normalize;
3558
TransformationChanged;
3560
FIsCalculating := False;
3563
FRotation.DirectX := NormalizeDegAngle(AValue);
3570
procedure TGLBaseSceneObject.Roll(angle: Single);
3573
rightVector, directionVector: TVector;
3575
FIsCalculating := True;
3577
angle := DegToRad(angle);
3578
directionVector := Direction.AsVector;
3579
FUp.Rotate(directionVector, angle);
3581
FDirection.Rotate(directionVector, angle);
3582
FDirection.Normalize;
3584
// calculate new rotation angle from vectors
3585
rightVector := Right;
3586
r := -RadToDeg(ArcTan2(rightVector.V[1],
3587
VectorLength(rightVector.V[0],
3588
rightVector.V[2])));
3589
if rightVector.V[0] < 0 then
3590
if rightVector.V[1] < 0 then
3596
FIsCalculating := False;
3598
TransformationChanged;
3604
procedure TGLBaseSceneObject.SetRollAngle(AValue: Single);
3609
if AValue <> FRotation.Z then
3611
if not (csLoading in ComponentState) then
3613
FIsCalculating := True;
3615
diff := DegToRad(FRotation.Z - AValue);
3616
rotMatrix := CreateRotationMatrix(Direction.AsVector, diff);
3617
FUp.DirectVector := VectorTransform(FUp.AsVector, rotMatrix);
3619
FDirection.DirectVector := VectorTransform(FDirection.AsVector,
3621
FDirection.Normalize;
3622
TransformationChanged;
3624
FIsCalculating := False;
3627
FRotation.DirectZ := NormalizeDegAngle(AValue);
3634
procedure TGLBaseSceneObject.Turn(angle: Single);
3639
FIsCalculating := True;
3641
angle := DegToRad(angle);
3642
upVector := Up.AsVector;
3643
FUp.Rotate(upVector, angle);
3645
FDirection.Rotate(upVector, angle);
3646
FDirection.Normalize;
3647
r := -RadToDeg(ArcTan2(FDirection.X, VectorLength(FDirection.Y,
3649
if FDirection.X < 0 then
3650
if FDirection.Y < 0 then
3656
FIsCalculating := False;
3658
TransformationChanged;
3664
procedure TGLBaseSceneObject.SetTurnAngle(AValue: Single);
3669
if AValue <> FRotation.Y then
3671
if not (csLoading in ComponentState) then
3673
FIsCalculating := True;
3675
diff := DegToRad(FRotation.Y - AValue);
3676
rotMatrix := CreateRotationMatrix(Up.AsVector, diff);
3677
FUp.DirectVector := VectorTransform(FUp.AsVector, rotMatrix);
3679
FDirection.DirectVector := VectorTransform(FDirection.AsVector,
3681
FDirection.Normalize;
3682
TransformationChanged;
3684
FIsCalculating := False;
3687
FRotation.DirectY := NormalizeDegAngle(AValue);
3691
procedure TGLBaseSceneObject.SetRotation(aRotation: TGLCoordinates);
3693
FRotation.Assign(aRotation);
3694
TransformationChanged;
3697
function TGLBaseSceneObject.GetPitchAngle: Single;
3699
Result := FRotation.X;
3702
function TGLBaseSceneObject.GetTurnAngle: Single;
3704
Result := FRotation.Y;
3707
function TGLBaseSceneObject.GetRollAngle: Single;
3709
Result := FRotation.Z;
3712
procedure TGLBaseSceneObject.PointTo(const ATargetObject: TGLBaseSceneObject;
3713
const AUpVector: TVector);
3715
PointTo(ATargetObject.AbsolutePosition, AUpVector);
3718
procedure TGLBaseSceneObject.PointTo(const AAbsolutePosition, AUpVector:
3721
absDir, absRight, absUp: TVector;
3723
// first compute absolute attitude for pointing
3724
absDir := VectorSubtract(AAbsolutePosition, Self.AbsolutePosition);
3725
NormalizeVector(absDir);
3726
absRight := VectorCrossProduct(absDir, AUpVector);
3727
NormalizeVector(absRight);
3728
absUp := VectorCrossProduct(absRight, absDir);
3729
// convert absolute to local and adjust object
3730
if Parent <> nil then
3732
FDirection.AsVector := Parent.AbsoluteToLocal(absDir);
3733
FUp.AsVector := Parent.AbsoluteToLocal(absUp);
3737
FDirection.AsVector := absDir;
3738
FUp.AsVector := absUp;
3740
TransformationChanged
3743
procedure TGLBaseSceneObject.SetShowAxes(AValue: Boolean);
3745
if FShowAxes <> AValue then
3747
FShowAxes := AValue;
3752
procedure TGLBaseSceneObject.SetScaling(AValue: TGLCoordinates);
3754
FScaling.Assign(AValue);
3755
TransformationChanged;
3758
procedure TGLBaseSceneObject.SetName(const NewName: TComponentName);
3760
if Name <> NewName then
3762
inherited SetName(NewName);
3763
if Assigned(vGLBaseSceneObjectNameChangeEvent) then
3764
vGLBaseSceneObjectNameChangeEvent(Self);
3768
procedure TGLBaseSceneObject.SetParent(const val: TGLBaseSceneObject);
3773
function TGLBaseSceneObject.GetIndex: Integer;
3775
if Assigned(FParent) then
3776
Result := FParent.FChildren.IndexOf(Self)
3781
procedure TGLBaseSceneObject.SetIndex(aValue: Integer);
3784
parentBackup: TGLBaseSceneObject;
3786
if Assigned(FParent) then
3790
LCount := FParent.Count;
3791
if aValue >= LCount then
3792
aValue := LCount - 1;
3793
if aValue <> Index then
3795
if Assigned(FScene) then
3797
parentBackup := FParent;
3798
parentBackup.Remove(Self, False);
3799
parentBackup.Insert(AValue, Self);
3800
if Assigned(FScene) then
3806
procedure TGLBaseSceneObject.SetParentComponent(Value: TComponent);
3809
if Value = FParent then
3812
if Value is TGLScene then
3813
SetParent(TGLScene(Value).Objects)
3814
else if Value is TGLBaseSceneObject then
3815
SetParent(TGLBaseSceneObject(Value))
3820
procedure TGLBaseSceneObject.StructureChanged;
3822
if not (ocStructure in FChanges) then
3824
Include(FChanges, ocStructure);
3827
else if osDirectDraw in ObjectStyle then
3831
procedure TGLBaseSceneObject.ClearStructureChanged;
3833
Exclude(FChanges, ocStructure);
3834
SetBBChanges(BBChanges + [oBBcStructure]);
3837
procedure TGLBaseSceneObject.RecTransformationChanged;
3840
list: PPointerObjectList;
3841
matSet: TObjectChanges;
3843
matSet := [ocAbsoluteMatrix, ocInvAbsoluteMatrix];
3844
if matSet * FChanges <> matSet then
3846
FChanges := FChanges + matSet;
3847
if Assigned(FChildren) then
3849
list := FChildren.List;
3850
for i := 0 to FChildren.Count - 1 do
3851
TGLBaseSceneObject(list^[i]).RecTransformationChanged;
3856
procedure TGLBaseSceneObject.TransformationChanged;
3858
if not (ocTransformation in FChanges) then
3860
Include(FChanges, ocTransformation);
3861
RecTransformationChanged;
3862
if not (csLoading in ComponentState) then
3867
procedure TGLBaseSceneObject.MoveTo(newParent: TGLBaseSceneObject);
3869
if newParent = FParent then
3871
if Assigned(FParent) then
3873
FParent.Remove(Self, False);
3876
if Assigned(newParent) then
3877
newParent.AddChild(Self)
3882
procedure TGLBaseSceneObject.MoveUp;
3884
if Assigned(parent) then
3885
parent.MoveChildUp(parent.IndexOfChild(Self));
3888
procedure TGLBaseSceneObject.MoveDown;
3890
if Assigned(parent) then
3891
parent.MoveChildDown(parent.IndexOfChild(Self));
3894
procedure TGLBaseSceneObject.MoveFirst;
3896
if Assigned(parent) then
3897
parent.MoveChildFirst(parent.IndexOfChild(Self));
3900
procedure TGLBaseSceneObject.MoveLast;
3902
if Assigned(parent) then
3903
parent.MoveChildLast(parent.IndexOfChild(Self));
3906
procedure TGLBaseSceneObject.MoveObjectAround(anObject: TGLBaseSceneObject;
3907
pitchDelta, turnDelta: Single);
3909
originalT2C, normalT2C, normalCameraRight, newPos: TVector;
3910
pitchNow, dist: Single;
3912
if Assigned(anObject) then
3914
// normalT2C points away from the direction the camera is looking
3915
originalT2C := VectorSubtract(AbsolutePosition,
3916
anObject.AbsolutePosition);
3917
SetVector(normalT2C, originalT2C);
3918
dist := VectorLength(normalT2C);
3919
NormalizeVector(normalT2C);
3920
// normalRight points to the camera's right
3921
// the camera is pitching around this axis.
3922
normalCameraRight := VectorCrossProduct(AbsoluteUp, normalT2C);
3923
if VectorLength(normalCameraRight) < 0.001 then
3924
SetVector(normalCameraRight, XVector) // arbitrary vector
3926
NormalizeVector(normalCameraRight);
3927
// calculate the current pitch.
3928
// 0 is looking down and PI is looking up
3929
pitchNow := ArcCos(VectorDotProduct(AbsoluteUp, normalT2C));
3930
pitchNow := ClampValue(pitchNow + DegToRad(pitchDelta), 0 + 0.025, PI -
3932
// create a new vector pointing up and then rotate it down
3933
// into the new position
3934
SetVector(normalT2C, AbsoluteUp);
3935
RotateVector(normalT2C, normalCameraRight, -pitchNow);
3936
RotateVector(normalT2C, AbsoluteUp, -DegToRad(turnDelta));
3937
ScaleVector(normalT2C, dist);
3938
newPos := VectorAdd(AbsolutePosition, VectorSubtract(normalT2C,
3940
if Assigned(Parent) then
3941
newPos := Parent.AbsoluteToLocal(newPos);
3942
Position.AsVector := newPos;
3946
procedure TGLBaseSceneObject.MoveObjectAllAround(anObject: TGLBaseSceneObject;
3947
pitchDelta, turnDelta: Single);
3951
rightvector : TVector;
3952
tempvector: TVector;
3957
// if camera has got a target
3958
if Assigned(anObject) then
3960
//vector camera to target
3961
lookat := VectorNormalize(VectorSubtract(anObject.AbsolutePosition, AbsolutePosition));
3963
upvector := VectorNormalize(AbsoluteUp);
3965
// if upvector and lookat vector are colinear, it is necessary to compute new up vector
3966
if Abs(VectorDotProduct(lookat,upvector))>0.99 then
3968
//X or Y vector use to generate upvector
3969
SetVector(tempvector,1,0,0);
3970
//if lookat is colinear to X vector use Y vector to generate upvector
3971
if Abs(VectorDotProduct(tempvector,lookat))>0.99 then
3973
SetVector(tempvector,0,1,0);
3975
upvector:= VectorCrossProduct(tempvector,lookat);
3976
rightvector := VectorCrossProduct(lookat,upvector);
3980
rightvector := VectorCrossProduct(lookat,upvector);
3981
upvector:= VectorCrossProduct(rightvector,lookat);
3983
//now the up right and lookat vector are orthogonal
3985
// vector Target to camera
3986
T2C:= VectorSubtract(AbsolutePosition,anObject.AbsolutePosition);
3987
RotateVector(T2C,rightvector,DegToRad(-PitchDelta));
3988
RotateVector(T2C,upvector,DegToRad(-TurnDelta));
3989
AbsolutePosition := VectorAdd(anObject.AbsolutePosition, T2C);
3991
//now update new up vector
3992
RotateVector(upvector,rightvector,DegToRad(-PitchDelta));
3993
AbsoluteUp := upvector;
3994
AbsoluteDirection := VectorSubtract(anObject.AbsolutePosition,AbsolutePosition);
3999
procedure TGLBaseSceneObject.CoordinateChanged(Sender: TGLCustomCoordinates);
4001
rightVector: TVector;
4003
if FIsCalculating then
4005
FIsCalculating := True;
4007
if Sender = FDirection then
4009
if FDirection.VectorLength = 0 then
4010
FDirection.DirectVector := ZHmgVector;
4011
FDirection.Normalize;
4013
rightVector := VectorCrossProduct(FDirection.AsVector, FUp.AsVector);
4014
// Rightvector is zero if direction changed exactly by 90 degrees,
4015
// in this case assume a default vector
4016
if VectorLength(rightVector) < 1e-5 then
4018
rightVector := VectorCrossProduct(ZHmgVector, FUp.AsVector);
4019
if VectorLength(rightVector) < 1e-5 then
4020
rightVector := VectorCrossProduct(XHmgVector, FUp.AsVector);
4022
FUp.DirectVector := VectorCrossProduct(rightVector, FDirection.AsVector);
4025
else if Sender = FUp then
4027
if FUp.VectorLength = 0 then
4028
FUp.DirectVector := YHmgVector;
4031
rightVector := VectorCrossProduct(FDirection.AsVector, FUp.AsVector);
4032
// Rightvector is zero if direction changed exactly by 90 degrees,
4033
// in this case assume a default vector
4034
if VectorLength(rightVector) < 1e-5 then
4036
rightVector := VectorCrossProduct(ZHmgVector, FUp.AsVector);
4037
if VectorLength(rightVector) < 1e-5 then
4038
rightVector := VectorCrossProduct(XHmgVector, FUp.AsVector);
4040
FDirection.DirectVector := VectorCrossProduct(FUp.AsVector, RightVector);
4041
FDirection.Normalize;
4043
TransformationChanged;
4045
FIsCalculating := False;
4049
procedure TGLBaseSceneObject.DoProgress(const progressTime: TProgressTimes);
4053
if Assigned(FChildren) then
4054
for i := FChildren.Count - 1 downto 0 do
4055
TGLBaseSceneObject(FChildren.List^[i]).DoProgress(progressTime);
4056
if Assigned(FGLBehaviours) then
4057
FGLBehaviours.DoProgress(progressTime);
4058
if Assigned(FGLObjectEffects) then
4059
FGLObjectEffects.DoProgress(progressTime);
4060
if Assigned(FOnProgress) then
4061
with progressTime do
4062
FOnProgress(Self, deltaTime, newTime);
4065
procedure TGLBaseSceneObject.Insert(aIndex: Integer; aChild:
4066
TGLBaseSceneObject);
4068
if not Assigned(FChildren) then
4069
FChildren := TPersistentObjectList.Create;
4072
if Assigned(aChild.FParent) then
4073
aChild.FParent.Remove(aChild, False);
4074
Insert(aIndex, aChild);
4076
aChild.FParent := Self;
4077
if AChild.FScene <> FScene then
4078
AChild.DestroyHandles;
4079
AChild.SetScene(FScene);
4080
if Assigned(FScene) then
4081
FScene.AddLights(aChild);
4082
AChild.TransformationChanged;
4084
aChild.DoOnAddedToParent;
4087
procedure TGLBaseSceneObject.Remove(aChild: TGLBaseSceneObject; keepChildren:
4092
if not Assigned(FChildren) then
4094
if aChild.Parent = Self then
4096
if Assigned(FScene) then
4097
FScene.RemoveLights(aChild);
4098
if aChild.Owner = Self then
4099
RemoveComponent(aChild);
4100
FChildren.Remove(aChild);
4101
aChild.FParent := nil;
4102
if keepChildren then
4105
if aChild.Count <> 0 then
4106
for I := aChild.Count - 1 downto 0 do
4107
if not IsSubComponent(aChild.Children[I]) then
4108
aChild.Children[I].MoveTo(Self);
4116
function TGLBaseSceneObject.IndexOfChild(aChild: TGLBaseSceneObject): Integer;
4118
if Assigned(FChildren) then
4119
Result := FChildren.IndexOf(aChild)
4124
function TGLBaseSceneObject.FindChild(const aName: string;
4125
ownChildrenOnly: Boolean): TGLBaseSceneObject;
4128
res: TGLBaseSceneObject;
4132
if not Assigned(FChildren) then
4134
for i := 0 to FChildren.Count - 1 do
4136
if CompareText(TGLBaseSceneObject(FChildren[i]).Name, aName) = 0 then
4138
res := TGLBaseSceneObject(FChildren[i]);
4142
if not ownChildrenOnly then
4144
for i := 0 to FChildren.Count - 1 do
4145
with TGLBaseSceneObject(FChildren[i]) do
4147
Result := FindChild(aName, ownChildrenOnly);
4148
if Assigned(Result) then
4152
if not Assigned(Result) then
4156
procedure TGLBaseSceneObject.ExchangeChildren(anIndex1, anIndex2: Integer);
4158
Assert(Assigned(FChildren), 'No children found!');
4159
FChildren.Exchange(anIndex1, anIndex2);
4163
procedure TGLBaseSceneObject.ExchangeChildrenSafe(anIndex1, anIndex2: Integer);
4165
Assert(Assigned(FChildren), 'No children found!');
4166
if (anIndex1 < FChildren.Count) and (anIndex2 < FChildren.Count) and
4167
(anIndex1 > -1) and (anIndex2 > -1) and (anIndex1 <> anIndex2) then
4169
FChildren.Exchange(anIndex1, anIndex2);
4174
procedure TGLBaseSceneObject.MoveChildUp(anIndex: Integer);
4176
Assert(Assigned(FChildren), 'No children found!');
4179
FChildren.Exchange(anIndex, anIndex - 1);
4184
procedure TGLBaseSceneObject.MoveChildDown(anIndex: Integer);
4186
Assert(Assigned(FChildren), 'No children found!');
4187
if anIndex < FChildren.Count - 1 then
4189
FChildren.Exchange(anIndex, anIndex + 1);
4194
procedure TGLBaseSceneObject.MoveChildFirst(anIndex: Integer);
4196
Assert(Assigned(FChildren), 'No children found!');
4197
if anIndex <> 0 then
4199
FChildren.Move(anIndex, 0);
4204
procedure TGLBaseSceneObject.MoveChildLast(anIndex: Integer);
4206
Assert(Assigned(FChildren), 'No children found!');
4207
if anIndex <> FChildren.Count - 1 then
4209
FChildren.Move(anIndex, FChildren.Count - 1);
4217
procedure TGLBaseSceneObject.Render(var ARci: TGLRenderContextInfo);
4219
shouldRenderSelf, shouldRenderChildren: Boolean;
4223
{$IFDEF GLS_OPENGL_DEBUG}4224
if GL.GREMEDY_string_marker then
4225
GL.StringMarkerGREMEDY(
4226
Length(Name) + Length('.Render'), PGLChar(TGLString(Name + '.Render')));4228
if (ARci.drawState = dsPicking) and not FPickable then
4230
// visibility culling determination
4231
if ARci.visibilityCulling in [vcObjectBased, vcHierarchical] then
4233
if ARci.visibilityCulling = vcObjectBased then
4235
shouldRenderSelf := (osNoVisibilityCulling in ObjectStyle)
4236
or (not IsVolumeClipped(BarycenterAbsolutePosition,
4237
BoundingSphereRadius,
4238
ARci.rcci.frustum));
4239
shouldRenderChildren := Assigned(FChildren);
4242
begin // vcHierarchical
4243
aabb := AxisAlignedBoundingBox;
4244
shouldRenderSelf := (osNoVisibilityCulling in ObjectStyle)
4245
or (not IsVolumeClipped(aabb.min, aabb.max, ARci.rcci.frustum));
4246
shouldRenderChildren := shouldRenderSelf and Assigned(FChildren);
4248
if not (shouldRenderSelf or shouldRenderChildren) then
4253
Assert(ARci.visibilityCulling in [vcNone, vcInherited],
4254
'Unknown visibility culling option');
4255
shouldRenderSelf := True;
4256
shouldRenderChildren := Assigned(FChildren);
4259
// Prepare Matrix and PickList stuff
4260
ARci.PipelineTransformation.Push;
4261
if ocTransformation in FChanges then
4264
if ARci.proxySubObject then
4265
ARci.PipelineTransformation.ModelMatrix :=
4266
MatrixMultiply(LocalMatrix^, ARci.PipelineTransformation.ModelMatrix)
4268
ARci.PipelineTransformation.ModelMatrix := AbsoluteMatrix;
4271
if ARci.drawState = dsPicking then
4273
if ARci.proxySubObject then
4274
master := TGLSceneBuffer(ARci.buffer).FSelector.CurrentObject;
4275
TGLSceneBuffer(ARci.buffer).FSelector.CurrentObject := Self;
4279
if shouldRenderSelf then
4281
vCurrentRenderingObject := Self;
4282
{$IFNDEF GLS_OPTIMIZATIONS}4284
DrawAxes(ARci, $CCCC);
4286
if Assigned(FGLObjectEffects) and (FGLObjectEffects.Count > 0) then
4288
ARci.PipelineTransformation.Push;
4289
FGLObjectEffects.RenderPreEffects(ARci);
4290
ARci.PipelineTransformation.Pop;
4292
ARci.PipelineTransformation.Push;
4293
if osIgnoreDepthBuffer in ObjectStyle then
4295
ARci.GLStates.Disable(stDepthTest);
4296
DoRender(ARci, True, shouldRenderChildren);
4297
ARci.GLStates.Enable(stDepthTest);
4300
DoRender(ARci, True, shouldRenderChildren);
4302
FGLObjectEffects.RenderPostEffects(ARci);
4303
ARci.PipelineTransformation.Pop;
4307
if osIgnoreDepthBuffer in ObjectStyle then
4309
ARci.GLStates.Disable(stDepthTest);
4310
DoRender(ARci, True, shouldRenderChildren);
4311
ARci.GLStates.Enable(stDepthTest);
4314
DoRender(ARci, True, shouldRenderChildren);
4317
vCurrentRenderingObject := nil;
4321
if (osIgnoreDepthBuffer in ObjectStyle) and
4322
TGLSceneBuffer(ARCi.buffer).DepthTest then
4324
ARci.GLStates.Disable(stDepthTest);
4325
DoRender(ARci, False, shouldRenderChildren);
4326
ARci.GLStates.Enable(stDepthTest);
4329
DoRender(ARci, False, shouldRenderChildren);
4331
// Pop Name & Matrix
4332
if Assigned(master) then
4333
TGLSceneBuffer(ARci.buffer).FSelector.CurrentObject := master;
4334
ARci.PipelineTransformation.Pop;
4340
procedure TGLBaseSceneObject.DoRender(var ARci: TGLRenderContextInfo;
4341
ARenderSelf, ARenderChildren: Boolean);
4343
// start rendering self
4346
if (osDirectDraw in ObjectStyle) or ARci.amalgamating then
4349
ARci.GLStates.CallList(GetHandle(ARci));
4351
// start rendering children (if any)
4352
if ARenderChildren then
4353
Self.RenderChildren(0, Count - 1, ARci);
4359
procedure TGLBaseSceneObject.RenderChildren(firstChildIndex, lastChildIndex:
4361
var rci: TGLRenderContextInfo);
4364
objList: TPersistentObjectList;
4365
distList: TSingleList;
4366
plist: PPointerObjectList;
4367
obj: TGLBaseSceneObject;
4368
oldSorting: TGLObjectsSorting;
4369
oldCulling: TGLVisibilityCulling;
4371
if not Assigned(FChildren) then
4373
oldCulling := rci.visibilityCulling;
4374
if Self.VisibilityCulling <> vcInherited then
4375
rci.visibilityCulling := Self.VisibilityCulling;
4376
if lastChildIndex = firstChildIndex then
4378
obj := TGLBaseSceneObject(FChildren.List^[firstChildIndex]);
4382
else if lastChildIndex > firstChildIndex then
4384
oldSorting := rci.objectsSorting;
4385
if Self.ObjectsSorting <> osInherited then
4386
rci.objectsSorting := Self.ObjectsSorting;
4387
case rci.objectsSorting of
4390
plist := FChildren.List;
4391
for i := firstChildIndex to lastChildIndex do
4393
obj := TGLBaseSceneObject(plist^[i]);
4398
osRenderFarthestFirst, osRenderBlendedLast, osRenderNearestFirst:
4400
distList := TSingleList.Create;
4401
objList := TPersistentObjectList.Create;
4402
distList.GrowthDelta := lastChildIndex + 1; // no reallocations
4403
objList.GrowthDelta := distList.GrowthDelta;
4405
case rci.objectsSorting of
4406
osRenderBlendedLast:
4407
// render opaque stuff
4408
for i := firstChildIndex to lastChildIndex do
4410
obj := TGLBaseSceneObject(FChildren.List^[i]);
4413
if not obj.Blended then
4419
obj.BarycenterSqrDistanceTo(rci.cameraPosition));
4423
osRenderFarthestFirst:
4424
for i := firstChildIndex to lastChildIndex do
4426
obj := TGLBaseSceneObject(FChildren.List^[i]);
4431
obj.BarycenterSqrDistanceTo(rci.cameraPosition));
4434
osRenderNearestFirst:
4435
for i := firstChildIndex to lastChildIndex do
4437
obj := TGLBaseSceneObject(FChildren.List^[i]);
4442
obj.BarycenterSqrDistanceTo(rci.cameraPosition));
4448
if distList.Count > 0 then
4450
if distList.Count > 1 then
4451
FastQuickSortLists(0, distList.Count - 1, distList, objList);
4452
plist := objList.List;
4453
for i := objList.Count - 1 downto 0 do
4454
TGLBaseSceneObject(plist^[i]).Render(rci);
4464
rci.objectsSorting := oldSorting;
4466
rci.visibilityCulling := oldCulling;
4472
procedure TGLBaseSceneObject.NotifyChange(Sender: TObject);
4474
if Assigned(FScene) and (not IsUpdating) then
4475
FScene.NotifyChange(Self);
4481
function TGLBaseSceneObject.GetMatrix: TMatrix;
4484
Result := FLocalMatrix^;
4490
function TGLBaseSceneObject.MatrixAsAddress: PMatrix;
4493
Result := FLocalMatrix;
4499
procedure TGLBaseSceneObject.SetMatrix(const aValue: TMatrix);
4501
FLocalMatrix^ := aValue;
4502
FDirection.DirectVector := VectorNormalize(FLocalMatrix^.V[2]);
4503
FUp.DirectVector := VectorNormalize(FLocalMatrix^.V[1]);
4504
Scale.SetVector(VectorLength(FLocalMatrix^.V[0]),
4505
VectorLength(FLocalMatrix^.V[1]),
4506
VectorLength(FLocalMatrix^.V[2]), 0);
4507
FPosition.DirectVector := FLocalMatrix^.V[3];
4508
TransformationChanged;
4511
procedure TGLBaseSceneObject.SetPosition(APosition: TGLCoordinates);
4513
FPosition.SetPoint(APosition.DirectX, APosition.DirectY, APosition.DirectZ);
4516
procedure TGLBaseSceneObject.SetDirection(AVector: TGLCoordinates);
4518
if not VectorIsNull(AVector.DirectVector) then
4519
FDirection.SetVector(AVector.DirectX, AVector.DirectY, AVector.DirectZ);
4522
procedure TGLBaseSceneObject.SetUp(AVector: TGLCoordinates);
4524
if not VectorIsNull(AVector.DirectVector) then
4525
FUp.SetVector(AVector.DirectX, AVector.DirectY, AVector.DirectZ);
4528
function TGLBaseSceneObject.GetVisible: Boolean;
4533
function TGLBaseSceneObject.GetPickable: Boolean;
4535
Result := FPickable;
4541
procedure TGLBaseSceneObject.SetVisible(aValue: Boolean);
4543
if FVisible <> aValue then
4553
procedure TGLBaseSceneObject.SetPickable(aValue: Boolean);
4555
if FPickable <> aValue then
4557
FPickable := AValue;
4565
procedure TGLBaseSceneObject.SetObjectsSorting(const val: TGLObjectsSorting);
4567
if FObjectsSorting <> val then
4569
FObjectsSorting := val;
4574
// SetVisibilityCulling
4577
procedure TGLBaseSceneObject.SetVisibilityCulling(const val:
4578
TGLVisibilityCulling);
4580
if FVisibilityCulling <> val then
4582
FVisibilityCulling := val;
4590
procedure TGLBaseSceneObject.SetBehaviours(const val: TGLBehaviours);
4592
Behaviours.Assign(val);
4598
function TGLBaseSceneObject.GetBehaviours: TGLBehaviours;
4600
if not Assigned(FGLBehaviours) then
4601
FGLBehaviours := TGLBehaviours.Create(Self);
4602
Result := FGLBehaviours;
4608
procedure TGLBaseSceneObject.SetEffects(const val: TGLObjectEffects);
4610
Effects.Assign(val);
4616
function TGLBaseSceneObject.GetEffects: TGLObjectEffects;
4618
if not Assigned(FGLObjectEffects) then
4619
FGLObjectEffects := TGLObjectEffects.Create(Self);
4620
Result := FGLObjectEffects;
4626
procedure TGLBaseSceneObject.SetScene(const value: TGLScene);
4630
if value <> FScene then
4632
// must be freed, the new scene may be using a non-compatible RC
4633
if FScene <> nil then
4636
// propagate for childs
4637
if Assigned(FChildren) then
4638
for i := 0 to FChildren.Count - 1 do
4639
Children[I].SetScene(FScene);
4646
procedure TGLBaseSceneObject.Translate(tx, ty, tz: Single);
4648
FPosition.Translate(AffineVectorMake(tx, ty, tz));
4651
// GetAbsoluteAffinePosition
4654
function TGLBaseSceneObject.GetAbsoluteAffinePosition: TAffineVector;
4658
temp := GetAbsolutePosition;
4659
Result := AffineVectorMake(temp.V[0], temp.V[1], temp.V[2]);
4662
// GetAbsoluteAffineDirection
4665
function TGLBaseSceneObject.GetAbsoluteAffineDirection: TAffineVector;
4669
temp := GetAbsoluteDirection;
4670
Result := AffineVectorMake(temp.V[0], temp.V[1], temp.V[2]);
4673
// GetAbsoluteAffineUp
4676
function TGLBaseSceneObject.GetAbsoluteAffineUp: TAffineVector;
4680
temp := GetAbsoluteUp;
4681
Result := AffineVectorMake(temp.V[0], temp.V[1], temp.V[2]);
4684
// SetAbsoluteAffinePosition
4687
procedure TGLBaseSceneObject.SetAbsoluteAffinePosition(const Value:
4690
SetAbsolutePosition(VectorMake(Value, 1));
4693
// SetAbsoluteAffineUp
4696
procedure TGLBaseSceneObject.SetAbsoluteAffineUp(const v: TAffineVector);
4698
SetAbsoluteUp(VectorMake(v, 1));
4701
// SetAbsoluteAffineDirection
4704
procedure TGLBaseSceneObject.SetAbsoluteAffineDirection(const v: TAffineVector);
4706
SetAbsoluteDirection(VectorMake(v, 1));
4712
function TGLBaseSceneObject.AffineLeftVector: TAffineVector;
4714
Result := AffineVectorMake(LeftVector);
4720
function TGLBaseSceneObject.AffineRight: TAffineVector;
4722
Result := AffineVectorMake(Right);
4728
function TGLBaseSceneObject.DistanceTo(const pt: TAffineVector): Single;
4730
Result := VectorDistance(AbsoluteAffinePosition, pt);
4736
function TGLBaseSceneObject.SqrDistanceTo(const pt: TAffineVector): Single;
4738
Result := VectorDistance2(AbsoluteAffinePosition, pt);
4744
procedure TGLBaseSceneObject.DoOnAddedToParent;
4746
if Assigned(FOnAddedToParent) then
4747
FOnAddedToParent(self);
4750
// GetAbsoluteAffineScale
4753
function TGLBaseSceneObject.GetAbsoluteAffineScale: TAffineVector;
4755
Result := AffineVectorMake(GetAbsoluteScale);
4758
// SetAbsoluteAffineScale
4761
procedure TGLBaseSceneObject.SetAbsoluteAffineScale(
4762
const Value: TAffineVector);
4764
SetAbsoluteScale(VectorMake(Value, GetAbsoluteScale.V[3]));
4767
// ------------------
4768
// ------------------ TGLBaseBehaviour ------------------
4769
// ------------------
4774
constructor TGLBaseBehaviour.Create(aOwner: TGLXCollection);
4776
inherited Create(aOwner);
4777
// nothing more, yet
4783
destructor TGLBaseBehaviour.Destroy;
4785
// nothing more, yet
4792
procedure TGLBaseBehaviour.SetName(const val: string);
4794
inherited SetName(val);
4795
if Assigned(vGLBehaviourNameChangeEvent) then
4796
vGLBehaviourNameChangeEvent(Self);
4802
procedure TGLBaseBehaviour.WriteToFiler(writer: TWriter);
4808
WriteInteger(0); // Archive Version 0
4809
// nothing more, yet
4816
procedure TGLBaseBehaviour.ReadFromFiler(reader: TReader);
4818
if Owner.ArchiveVersion > 0 then
4823
if ReadInteger <> 0 then
4825
// nothing more, yet
4829
// OwnerBaseSceneObject
4832
function TGLBaseBehaviour.OwnerBaseSceneObject: TGLBaseSceneObject;
4834
Result := TGLBaseSceneObject(Owner.Owner);
4840
procedure TGLBaseBehaviour.DoProgress(const progressTime: TProgressTimes);
4845
// ------------------
4846
// ------------------ TGLBehaviours ------------------
4847
// ------------------
4852
constructor TGLBehaviours.Create(aOwner: TPersistent);
4854
Assert(aOwner is TGLBaseSceneObject);
4855
inherited Create(aOwner);
4861
function TGLBehaviours.GetNamePath: string;
4865
Result := ClassName;
4866
if GetOwner = nil then
4868
s := GetOwner.GetNamePath;
4871
Result := s + '.Behaviours';
4877
class function TGLBehaviours.ItemsClass: TGLXCollectionItemClass;
4879
Result := TGLBehaviour;
4885
function TGLBehaviours.GetBehaviour(index: Integer): TGLBehaviour;
4887
Result := TGLBehaviour(Items[index]);
4893
function TGLBehaviours.CanAdd(aClass: TGLXCollectionItemClass): Boolean;
4895
Result := (not aClass.InheritsFrom(TGLObjectEffect)) and (inherited
4902
procedure TGLBehaviours.DoProgress(const progressTimes: TProgressTimes);
4906
for i := 0 to Count - 1 do
4907
TGLBehaviour(Items[i]).DoProgress(progressTimes);
4910
// ------------------
4911
// ------------------ TGLObjectEffect ------------------
4912
// ------------------
4917
procedure TGLObjectEffect.WriteToFiler(writer: TWriter);
4922
WriteInteger(0); // Archive Version 0
4923
// nothing more, yet
4930
procedure TGLObjectEffect.ReadFromFiler(reader: TReader);
4932
if Owner.ArchiveVersion > 0 then
4937
if ReadInteger <> 0 then
4939
// nothing more, yet
4946
procedure TGLObjectEffect.Render(var rci: TGLRenderContextInfo);
4948
// nothing here, this implem is just to avoid "abstract error"
4951
// ------------------
4952
// ------------------ TGLObjectEffects ------------------
4953
// ------------------
4958
constructor TGLObjectEffects.Create(aOwner: TPersistent);
4960
Assert(aOwner is TGLBaseSceneObject);
4961
inherited Create(aOwner);
4967
function TGLObjectEffects.GetNamePath: string;
4971
Result := ClassName;
4972
if GetOwner = nil then
4974
s := GetOwner.GetNamePath;
4977
Result := s + '.Effects';
4983
class function TGLObjectEffects.ItemsClass: TGLXCollectionItemClass;
4985
Result := TGLObjectEffect;
4991
function TGLObjectEffects.GetEffect(index: Integer): TGLObjectEffect;
4993
Result := TGLObjectEffect(Items[index]);
4999
function TGLObjectEffects.CanAdd(aClass: TGLXCollectionItemClass): Boolean;
5001
Result := (aClass.InheritsFrom(TGLObjectEffect)) and (inherited
5008
procedure TGLObjectEffects.DoProgress(const progressTime: TProgressTimes);
5012
for i := 0 to Count - 1 do
5013
TGLObjectEffect(Items[i]).DoProgress(progressTime);
5019
procedure TGLObjectEffects.RenderPreEffects(var rci: TGLRenderContextInfo);
5022
effect: TGLObjectEffect;
5024
for i := 0 to Count - 1 do
5026
effect := TGLObjectEffect(Items[i]);
5027
if effect is TGLObjectPreEffect then
5035
procedure TGLObjectEffects.RenderPostEffects(var rci: TGLRenderContextInfo);
5038
effect: TGLObjectEffect;
5040
for i := 0 to Count - 1 do
5042
effect := TGLObjectEffect(Items[i]);
5043
if effect is TGLObjectPostEffect then
5045
else if Assigned(rci.afterRenderEffects) and (effect is TGLObjectAfterEffect) then
5046
rci.afterRenderEffects.Add(effect);
5050
// ------------------
5051
// ------------------ TGLCustomSceneObject ------------------
5052
// ------------------
5054
constructor TGLCustomSceneObject.Create(AOwner: TComponent);
5056
inherited Create(AOwner);
5057
FMaterial := TGLMaterial.Create(Self);
5060
destructor TGLCustomSceneObject.Destroy;
5066
procedure TGLCustomSceneObject.Assign(Source: TPersistent);
5068
if Source is TGLCustomSceneObject then
5070
FMaterial.Assign(TGLCustomSceneObject(Source).FMaterial);
5071
FHint := TGLCustomSceneObject(Source).FHint;
5073
inherited Assign(Source);
5076
function TGLCustomSceneObject.Blended: Boolean;
5078
Result := Material.Blended;
5081
procedure TGLCustomSceneObject.Loaded;
5087
procedure TGLCustomSceneObject.SetGLMaterial(AValue: TGLMaterial);
5089
FMaterial.Assign(AValue);
5093
procedure TGLCustomSceneObject.DestroyHandle;
5096
FMaterial.DestroyHandles;
5102
procedure TGLCustomSceneObject.DoRender(var ARci: TGLRenderContextInfo;
5103
ARenderSelf, ARenderChildren: Boolean);
5105
// start rendering self
5107
if ARci.ignoreMaterials then
5108
if (osDirectDraw in ObjectStyle) or ARci.amalgamating then
5111
ARci.GLStates.CallList(GetHandle(ARci))
5114
FMaterial.Apply(ARci);
5116
if (osDirectDraw in ObjectStyle) or ARci.amalgamating then
5119
ARci.GLStates.CallList(GetHandle(ARci));
5120
until not FMaterial.UnApply(ARci);
5122
// start rendering children (if any)
5123
if ARenderChildren then
5124
Self.RenderChildren(0, Count - 1, ARci);
5127
// ------------------
5128
// ------------------ TGLSceneRootObject ------------------
5129
// ------------------
5131
constructor TGLSceneRootObject.Create(AOwner: TComponent);
5133
Assert(AOwner is TGLScene);
5134
inherited Create(AOwner);
5135
ObjectStyle := ObjectStyle + [osDirectDraw];
5136
FScene := TGLScene(AOwner);
5139
// ------------------
5140
// ------------------ TGLCamera ------------------
5141
// ------------------
5143
constructor TGLCamera.Create(aOwner: TComponent);
5145
inherited Create(aOwner);
5147
FDepthOfView := 100;
5148
FNearPlaneBias := 1;
5149
FDirection.Initialize(VectorMake(0, 0, -1, 0));
5150
FCameraStyle := csPerspective;
5154
FKeepFOVMode := ckmHorizontalFOV;
5157
destructor TGLCamera.Destroy;
5159
TargetObject := nil;
5163
procedure TGLCamera.Assign(Source: TPersistent);
5168
if Assigned(Source) then
5170
inherited Assign(Source);
5172
if Source is TGLCamera then
5174
cam := TGLCamera(Source);
5175
SetDepthOfView(cam.DepthOfView);
5176
SetFocalLength(cam.FocalLength);
5177
SetCameraStyle(cam.CameraStyle);
5178
SetSceneScale(cam.SceneScale);
5179
SetNearPlaneBias(cam.NearPlaneBias);
5180
SetScene(cam.Scene);
5181
SetKeepFOVMode(cam.FKeepFOVMode);
5183
if Parent <> nil then
5185
SetTargetObject(cam.TargetObject);
5187
else // Design camera
5189
Position.AsVector := cam.AbsolutePosition;
5190
if Assigned(cam.TargetObject) then
5192
VectorSubtract(cam.TargetObject.AbsolutePosition, AbsolutePosition, dir);
5193
NormalizeVector(dir);
5194
Direction.AsVector := dir;
5201
function TGLCamera.AbsoluteVectorToTarget: TVector;
5203
if TargetObject <> nil then
5205
VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition, Result);
5206
NormalizeVector(Result);
5209
Result := AbsoluteDirection;
5212
function TGLCamera.AbsoluteRightVectorToTarget: TVector;
5214
if TargetObject <> nil then
5216
VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition, Result);
5217
Result := VectorCrossProduct(Result, AbsoluteUp);
5218
NormalizeVector(Result);
5221
Result := AbsoluteRight;
5224
function TGLCamera.AbsoluteUpVectorToTarget: TVector;
5226
if TargetObject <> nil then
5227
Result := VectorCrossProduct(AbsoluteRightVectorToTarget,
5228
AbsoluteVectorToTarget)
5230
Result := AbsoluteUp;
5233
procedure TGLCamera.Apply;
5239
if Assigned(FDeferredApply) then
5240
FDeferredApply(Self)
5243
if Assigned(FTargetObject) then
5245
v := TargetObject.AbsolutePosition;
5246
absPos := AbsolutePosition;
5247
VectorSubtract(v, absPos, d);
5249
FLastDirection := d;
5250
LM := CreateLookAtMatrix(absPos, v, Up.AsVector);
5254
if Assigned(Parent) then
5255
mat := Parent.AbsoluteMatrix
5257
mat := IdentityHmgMatrix;
5258
absPos := AbsolutePosition;
5259
v := VectorTransform(Direction.AsVector, mat);
5260
FLastDirection := v;
5261
d := VectorTransform(Up.AsVector, mat);
5262
v2 := VectorAdd(absPos, v);
5263
LM := CreateLookAtMatrix(absPos, v2, d);
5265
with CurrentGLContext.PipelineTransformation do
5266
ViewMatrix := MatrixMultiply(LM, ViewMatrix);
5267
ClearStructureChanged;
5271
procedure TGLCamera.ApplyPerspective(const AViewport: TRectangle;
5272
AWidth, AHeight: Integer; ADPI: Integer);
5274
vLeft, vRight, vBottom, vTop, vFar: Single;
5275
MaxDim, Ratio, f: Double;
5279
cEpsilon: Single = 1e-4;
5281
function IsPerspective(CamStyle: TGLCameraStyle): Boolean;
5283
Result := CamStyle in [csPerspective, csInfinitePerspective, csPerspectiveKeepFOV];
5287
if (AWidth <= 0) or (AHeight <= 0) then
5290
if CameraStyle = csOrtho2D then
5298
mat := CreateOrthoMatrix(vLeft, vRight, vBottom, vTop, FNearPlane, vFar);
5299
with CurrentGLContext.PipelineTransformation do
5300
ProjectionMatrix := MatrixMultiply(mat, ProjectionMatrix);
5301
FViewPortRadius := VectorLength(AWidth, AHeight) / 2;
5303
else if CameraStyle = csCustom then
5305
FViewPortRadius := VectorLength(AWidth, AHeight) / 2;
5306
if Assigned(FOnCustomPerspective) then
5307
FOnCustomPerspective(AViewport, AWidth, AHeight, ADPI, FViewPortRadius);
5311
// determine biggest dimension and resolution (height or width)
5313
if AHeight > MaxDim then
5316
// calculate near plane distance and extensions;
5317
// Scene ratio is determined by the window ratio. The viewport is just a
5318
// specific part of the entire window and has therefore no influence on the
5319
// scene ratio. What we need to know, though, is the ratio between the window
5320
// borders (left, top, right and bottom) and the viewport borders.
5321
// Note: viewport.top is actually bottom, because the window (and viewport) origin
5322
// in OGL is the lower left corner
5324
if IsPerspective(CameraStyle) then
5325
f := FNearPlaneBias / (AWidth * FSceneScale)
5327
f := 100 * FNearPlaneBias / (focalLength * AWidth * FSceneScale);
5329
// calculate window/viewport ratio for right extent
5330
Ratio := (2 * AViewport.Width + 2 * AViewport.Left - AWidth) * f;
5331
// calculate aspect ratio correct right value of the view frustum and take
5332
// the window/viewport ratio also into account
5333
vRight := Ratio * AWidth / (2 * MaxDim);
5335
// the same goes here for the other three extents
5337
Ratio := (AWidth - 2 * AViewport.Left) * f;
5338
vLeft := -Ratio * AWidth / (2 * MaxDim);
5340
if IsPerspective(CameraStyle) then
5341
f := FNearPlaneBias / (AHeight * FSceneScale)
5343
f := 100 * FNearPlaneBias / (focalLength * AHeight * FSceneScale);
5345
// top extent (keep in mind the origin is left lower corner):
5346
Ratio := (2 * AViewport.Height + 2 * AViewport.Top - AHeight) * f;
5347
vTop := Ratio * AHeight / (2 * MaxDim);
5350
Ratio := (AHeight - 2 * AViewport.Top) * f;
5351
vBottom := -Ratio * AHeight / (2 * MaxDim);
5353
FNearPlane := FFocalLength * 2 * ADPI / (25.4 * MaxDim) * FNearPlaneBias;
5354
vFar := FNearPlane + FDepthOfView;
5356
// finally create view frustum (perspective or orthogonal)
5360
mat := CreateMatrixFromFrustum(vLeft, vRight, vBottom, vTop, FNearPlane, vFar);
5362
csPerspectiveKeepFOV:
5364
if FFOVY < 0 then // Need Update FOV
5366
FFOVY := ArcTan2(vTop - vBottom, 2 * FNearPlane) * 2;
5367
FFOVX := ArcTan2(vRight - vLeft, 2 * FNearPlane) * 2;
5370
case FKeepFOVMode of
5373
ymax := FNearPlane * tan(FFOVY / 2);
5374
xmax := ymax * AWidth / AHeight;
5378
xmax := FNearPlane * tan(FFOVX / 2);
5379
ymax := xmax * AHeight / AWidth;
5385
Assert(False, 'Unknown keep camera angle mode');
5388
mat := CreateMatrixFromFrustum(-xmax, xmax, -ymax, ymax, FNearPlane, vFar);
5390
csInfinitePerspective:
5392
mat := IdentityHmgMatrix;
5393
mat.V[0].V[0] := 2 * FNearPlane / (vRight - vLeft);
5394
mat.V[1].V[1] := 2 * FNearPlane / (vTop - vBottom);
5395
mat.V[2].V[0] := (vRight + vLeft) / (vRight - vLeft);
5396
mat.V[2].V[1] := (vTop + vBottom) / (vTop - vBottom);
5397
mat.V[2].V[2] := cEpsilon - 1;
5398
mat.V[2].V[3] := -1;
5399
mat.V[3].V[2] := FNearPlane * (cEpsilon - 2);
5404
mat := CreateOrthoMatrix(vLeft, vRight, vBottom, vTop, FNearPlane, vFar);
5410
with CurrentGLContext.PipelineTransformation do
5411
ProjectionMatrix := MatrixMultiply(mat, ProjectionMatrix);
5413
FViewPortRadius := VectorLength(vRight, vTop) / FNearPlane;
5417
//------------------------------------------------------------------------------
5419
procedure TGLCamera.AutoLeveling(Factor: Single);
5421
rightVector, rotAxis: TVector;
5424
angle := RadToDeg(arccos(VectorDotProduct(FUp.AsVector, YVector)));
5425
rotAxis := VectorCrossProduct(YHmgVector, FUp.AsVector);
5426
if (angle > 1) and (VectorLength(rotAxis) > 0) then
5428
rightVector := VectorCrossProduct(FDirection.AsVector, FUp.AsVector);
5429
FUp.Rotate(AffineVectorMake(rotAxis), Angle / (10 * Factor));
5431
// adjust local coordinates
5432
FDirection.DirectVector := VectorCrossProduct(FUp.AsVector, rightVector);
5433
FRotation.Z := -RadToDeg(ArcTan2(RightVector.V[1],
5434
VectorLength(RightVector.V[0], RightVector.V[2])));
5438
//------------------------------------------------------------------------------
5440
procedure TGLCamera.Notification(AComponent: TComponent; Operation: TOperation);
5442
if (Operation = opRemove) and (AComponent = FTargetObject) then
5443
TargetObject := nil;
5448
procedure TGLCamera.SetTargetObject(const val: TGLBaseSceneObject);
5450
if (FTargetObject <> val) then
5452
if Assigned(FTargetObject) then
5453
FTargetObject.RemoveFreeNotification(Self);
5454
FTargetObject := val;
5455
if Assigned(FTargetObject) then
5456
FTargetObject.FreeNotification(Self);
5457
if not (csLoading in ComponentState) then
5458
TransformationChanged;
5462
procedure TGLCamera.Reset(aSceneBuffer: TGLSceneBuffer);
5468
with aSceneBuffer do
5470
ApplyPerspective(FViewport, FViewport.Width, FViewport.Height, FRenderDPI);
5471
FUp.DirectVector := YHmgVector;
5472
if FViewport.Height < FViewport.Width then
5473
Extent := FViewport.Height * 0.25
5475
Extent := FViewport.Width * 0.25;
5477
FPosition.SetPoint(0, 0, FNearPlane * Extent);
5478
FDirection.SetVector(0, 0, -1, 0);
5479
TransformationChanged;
5482
procedure TGLCamera.ZoomAll(aSceneBuffer: TGLSceneBuffer);
5486
with aSceneBuffer do
5488
if FViewport.Height < FViewport.Width then
5489
Extent := FViewport.Height * 0.25
5491
Extent := FViewport.Width * 0.25;
5492
FPosition.DirectVector := NullHmgPoint;
5493
Move(-FNearPlane * Extent);
5494
// let the camera look at the scene center
5495
FDirection.SetVector(-FPosition.X, -FPosition.Y, -FPosition.Z, 0);
5499
procedure TGLCamera.RotateObject(obj: TGLBaseSceneObject; pitchDelta, turnDelta:
5501
rollDelta: Single = 0);
5504
vDir, vUp, vRight: TVector;
5509
// First we need to compute the actual camera's vectors, which may not be
5510
// directly available if we're in "targeting" mode
5512
if TargetObject <> nil then
5514
vDir := AbsoluteVectorToTarget;
5515
vRight := VectorCrossProduct(vDir, vUp);
5516
vUp := VectorCrossProduct(vRight, vDir);
5520
vDir := AbsoluteDirection;
5521
vRight := VectorCrossProduct(vDir, vUp);
5524
//save scale & position info
5525
Scale1 := obj.Scale.AsVector;
5526
position1 := obj.Position.asVector;
5527
resMat := obj.Matrix;
5528
//get rid of scaling & location info
5529
NormalizeMatrix(resMat);
5530
// Now we build rotation matrices and use them to rotate the obj
5531
if rollDelta <> 0 then
5533
SetVector(v, obj.AbsoluteToLocal(vDir));
5534
resMat := MatrixMultiply(CreateRotationMatrix(v, DegToRad(rollDelta)),
5537
if turnDelta <> 0 then
5539
SetVector(v, obj.AbsoluteToLocal(vUp));
5540
resMat := MatrixMultiply(CreateRotationMatrix(v, DegToRad(turnDelta)),
5543
if pitchDelta <> 0 then
5545
SetVector(v, obj.AbsoluteToLocal(vRight));
5546
resMat := MatrixMultiply(CreateRotationMatrix(v, DegToRad(pitchDelta)),
5549
obj.Matrix := resMat;
5550
//restore scaling & rotation info
5551
obj.Scale.AsVector := Scale1;
5552
obj.Position.AsVector := Position1;
5555
procedure TGLCamera.RotateTarget(pitchDelta, turnDelta: Single; rollDelta: Single
5558
if Assigned(FTargetObject) then
5559
RotateObject(FTargetObject, pitchDelta, turnDelta, rollDelta)
5562
procedure TGLCamera.MoveAroundTarget(pitchDelta, turnDelta: Single);
5564
MoveObjectAround(FTargetObject, pitchDelta, turnDelta);
5567
procedure TGLCamera.MoveAllAroundTarget(pitchDelta, turnDelta :Single);
5569
MoveObjectAllAround(FTargetObject, pitchDelta, turnDelta);
5572
procedure TGLCamera.MoveInEyeSpace(forwardDistance, rightDistance, upDistance:
5577
trVector := AbsoluteEyeSpaceVector(forwardDistance, rightDistance,
5579
if Assigned(Parent) then
5580
Position.Translate(Parent.AbsoluteToLocal(trVector))
5582
Position.Translate(trVector);
5585
procedure TGLCamera.MoveTargetInEyeSpace(forwardDistance, rightDistance,
5586
upDistance: Single);
5590
if TargetObject <> nil then
5592
trVector := AbsoluteEyeSpaceVector(forwardDistance, rightDistance,
5594
TargetObject.Position.Translate(TargetObject.Parent.AbsoluteToLocal(trVector));
5598
function TGLCamera.AbsoluteEyeSpaceVector(forwardDistance, rightDistance,
5599
upDistance: Single): TVector;
5601
Result := NullHmgVector;
5602
if forwardDistance <> 0 then
5603
CombineVector(Result, AbsoluteVectorToTarget, forwardDistance);
5604
if rightDistance <> 0 then
5605
CombineVector(Result, AbsoluteRightVectorToTarget, rightDistance);
5606
if upDistance <> 0 then
5607
CombineVector(Result, AbsoluteUpVectorToTarget, upDistance);
5610
procedure TGLCamera.AdjustDistanceToTarget(distanceRatio: Single);
5614
if Assigned(FTargetObject) then
5616
// calculate vector from target to camera in absolute coordinates
5617
vect := VectorSubtract(AbsolutePosition, TargetObject.AbsolutePosition);
5618
// ratio -> translation vector
5619
ScaleVector(vect, -(1 - distanceRatio));
5620
AddVector(vect, AbsolutePosition);
5621
if Assigned(Parent) then
5622
vect := Parent.AbsoluteToLocal(vect);
5623
Position.AsVector := vect;
5627
function TGLCamera.DistanceToTarget: Single;
5631
if Assigned(FTargetObject) then
5633
vect := VectorSubtract(AbsolutePosition, TargetObject.AbsolutePosition);
5634
Result := VectorLength(vect);
5640
function TGLCamera.ScreenDeltaToVector(deltaX, deltaY: Integer; ratio: Single;
5641
const planeNormal: TVector): TVector;
5643
screenY, screenX: TVector;
5644
screenYoutOfPlaneComponent: Single;
5646
// calculate projection of direction vector on the plane
5647
if Assigned(FTargetObject) then
5648
screenY := VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition)
5650
screenY := Direction.AsVector;
5651
screenYoutOfPlaneComponent := VectorDotProduct(screenY, planeNormal);
5652
screenY := VectorCombine(screenY, planeNormal, 1,
5653
-screenYoutOfPlaneComponent);
5654
NormalizeVector(screenY);
5655
// calc the screenX vector
5656
screenX := VectorCrossProduct(screenY, planeNormal);
5657
// and here, we're done
5658
Result := VectorCombine(screenX, screenY, deltaX * ratio, deltaY * ratio);
5661
function TGLCamera.ScreenDeltaToVectorXY(deltaX, deltaY: Integer; ratio:
5665
dxr, dyr, d: Single;
5667
// calculate projection of direction vector on the plane
5668
if Assigned(FTargetObject) then
5669
screenY := VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition)
5671
screenY := Direction.AsVector;
5672
d := VectorLength(screenY.V[0], screenY.V[1]);
5677
// and here, we're done
5680
Result.V[0] := screenY.V[1] * dxr + screenY.V[0] * dyr;
5681
Result.V[1] := screenY.V[1] * dyr - screenY.V[0] * dxr;
5686
function TGLCamera.ScreenDeltaToVectorXZ(deltaX, deltaY: Integer; ratio:
5690
d, dxr, dzr: Single;
5692
// calculate the projection of direction vector on the plane
5693
if Assigned(fTargetObject) then
5694
screenY := VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition)
5696
screenY := Direction.AsVector;
5697
d := VectorLength(screenY.V[0], screenY.V[2]);
5704
Result.V[0] := -screenY.V[2] * dxr + screenY.V[0] * dzr;
5706
Result.V[2] := screenY.V[2] * dzr + screenY.V[0] * dxr;
5710
function TGLCamera.ScreenDeltaToVectorYZ(deltaX, deltaY: Integer; ratio:
5714
d, dyr, dzr: single;
5716
// calculate the projection of direction vector on the plane
5717
if Assigned(fTargetObject) then
5718
screenY := VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition)
5720
screenY := Direction.AsVector;
5721
d := VectorLength(screenY.V[1], screenY.V[2]);
5729
Result.V[1] := screenY.V[2] * dyr + screenY.V[1] * dzr;
5730
Result.V[2] := screenY.V[2] * dzr - screenY.V[1] * dyr;
5737
function TGLCamera.PointInFront(const point: TVector): boolean;
5739
result := PointIsInHalfSpace(point, AbsolutePosition, AbsoluteDirection);
5745
procedure TGLCamera.SetDepthOfView(AValue: Single);
5747
if FDepthOfView <> AValue then
5749
FDepthOfView := AValue;
5751
if not (csLoading in ComponentState) then
5752
TransformationChanged;
5759
procedure TGLCamera.SetFocalLength(AValue: Single);
5763
if FFocalLength <> AValue then
5765
FFocalLength := AValue;
5767
if not (csLoading in ComponentState) then
5768
TransformationChanged;
5775
function TGLCamera.GetFieldOfView(const AViewportDimension: single): single;
5777
if FFocalLength = 0 then
5780
result := RadToDeg(2 * ArcTan2(AViewportDimension * 0.5, FFocalLength));
5786
procedure TGLCamera.SetFieldOfView(const AFieldOfView,
5787
AViewportDimension: single);
5789
FocalLength := AViewportDimension / (2 * Tan(DegToRad(AFieldOfView / 2)));
5795
procedure TGLCamera.SetCameraStyle(const val: TGLCameraStyle);
5797
if FCameraStyle <> val then
5799
FCameraStyle := val;
5805
// SetKeepCamAngleMode
5808
procedure TGLCamera.SetKeepFOVMode(const val: TGLCameraKeepFOVMode);
5810
if FKeepFOVMode <> val then
5812
FKeepFOVMode := val;
5814
if FCameraStyle = csPerspectiveKeepFOV then
5822
procedure TGLCamera.SetSceneScale(value: Single);
5826
if FSceneScale <> value then
5828
FSceneScale := value;
5837
function TGLCamera.StoreSceneScale: Boolean;
5839
Result := (FSceneScale <> 1);
5845
procedure TGLCamera.SetNearPlaneBias(value: Single);
5849
if FNearPlaneBias <> value then
5851
FNearPlaneBias := value;
5857
// StoreNearPlaneBias
5860
function TGLCamera.StoreNearPlaneBias: Boolean;
5862
Result := (FNearPlaneBias <> 1);
5868
procedure TGLCamera.DoRender(var ARci: TGLRenderContextInfo;
5869
ARenderSelf, ARenderChildren: Boolean);
5871
if ARenderChildren and (Count > 0) then
5872
Self.RenderChildren(0, Count - 1, ARci);
5878
function TGLCamera.RayCastIntersect(const rayStart, rayVector: TVector;
5879
intersectPoint: PVector = nil;
5880
intersectNormal: PVector = nil): Boolean;
5885
// ------------------
5886
// ------------------ TGLImmaterialSceneObject ------------------
5887
// ------------------
5892
procedure TGLImmaterialSceneObject.DoRender(var ARci: TGLRenderContextInfo;
5893
ARenderSelf, ARenderChildren: Boolean);
5895
// start rendering self
5898
if (osDirectDraw in ObjectStyle) or ARci.amalgamating then
5901
ARci.GLStates.CallList(GetHandle(ARci));
5903
// start rendering children (if any)
5904
if ARenderChildren then
5905
Self.RenderChildren(0, Count - 1, ARci);
5908
// ------------------
5909
// ------------------ TGLCameraInvariantObject ------------------
5910
// ------------------
5915
constructor TGLCameraInvariantObject.Create(AOwner: TComponent);
5918
FCamInvarianceMode := cimNone;
5924
procedure TGLCameraInvariantObject.Assign(Source: TPersistent);
5926
if Source is TGLCameraInvariantObject then
5928
FCamInvarianceMode := TGLCameraInvariantObject(Source).FCamInvarianceMode;
5930
inherited Assign(Source);
5936
procedure TGLCameraInvariantObject.DoRender(var ARci: TGLRenderContextInfo;
5937
ARenderSelf, ARenderChildren: Boolean);
5939
if CamInvarianceMode <> cimNone then
5940
with ARci.PipelineTransformation do
5945
case CamInvarianceMode of
5948
ViewMatrix := MatrixMultiply(
5949
CreateTranslationMatrix(ARci.cameraPosition),
5950
ARci.PipelineTransformation.ViewMatrix);
5954
// makes the coordinates system more 'intuitive' (Z+ forward)
5955
ViewMatrix := CreateScaleMatrix(Vector3fMake(1, -1, -1))
5960
// Apply local transform
5961
ModelMatrix := LocalMatrix^;
5965
if (osDirectDraw in ObjectStyle) or ARci.amalgamating then
5968
ARci.GLStates.CallList(GetHandle(ARci));
5970
if ARenderChildren then
5971
Self.RenderChildren(0, Count - 1, ARci);
5980
// SetCamInvarianceMode
5983
procedure TGLCameraInvariantObject.SetCamInvarianceMode(const val:
5984
TGLCameraInvarianceMode);
5986
if FCamInvarianceMode <> val then
5988
FCamInvarianceMode := val;
5993
// ------------------
5994
// ------------------ TGLDirectOpenGL ------------------
5995
// ------------------
6000
constructor TGLDirectOpenGL.Create(AOwner: TComponent);
6003
ObjectStyle := ObjectStyle + [osDirectDraw];
6010
procedure TGLDirectOpenGL.Assign(Source: TPersistent);
6012
if Source is TGLDirectOpenGL then
6014
UseBuildList := TGLDirectOpenGL(Source).UseBuildList;
6015
FOnRender := TGLDirectOpenGL(Source).FOnRender;
6016
FBlend := TGLDirectOpenGL(Source).Blend;
6018
inherited Assign(Source);
6024
procedure TGLDirectOpenGL.BuildList(var rci: TGLRenderContextInfo);
6026
if Assigned(FOnRender) then
6028
xgl.MapTexCoordToMain; // single texturing by default
6029
OnRender(Self, rci);
6033
// AxisAlignedDimensionsUnscaled
6036
function TGLDirectOpenGL.AxisAlignedDimensionsUnscaled: TVector;
6038
Result := NullHmgPoint;
6044
procedure TGLDirectOpenGL.SetUseBuildList(const val: Boolean);
6046
if val <> FUseBuildList then
6048
FUseBuildList := val;
6050
ObjectStyle := ObjectStyle - [osDirectDraw]
6052
ObjectStyle := ObjectStyle + [osDirectDraw];
6059
function TGLDirectOpenGL.Blended: Boolean;
6067
procedure TGLDirectOpenGL.SetBlend(const val: Boolean);
6069
if val <> FBlend then
6076
// ------------------
6077
// ------------------ TGLRenderPoint ------------------
6078
// ------------------
6083
constructor TGLRenderPoint.Create(AOwner: TComponent);
6086
ObjectStyle := ObjectStyle + [osDirectDraw];
6092
destructor TGLRenderPoint.Destroy;
6101
procedure TGLRenderPoint.BuildList(var rci: TGLRenderContextInfo);
6105
for i := 0 to High(FCallBacks) do
6106
FCallBacks[i](Self, rci);
6112
procedure TGLRenderPoint.RegisterCallBack(renderEvent: TDirectRenderEvent;
6113
renderPointFreed: TNotifyEvent);
6117
n := Length(FCallBacks);
6118
SetLength(FCallBacks, n + 1);
6119
SetLength(FFreeCallBacks, n + 1);
6120
FCallBacks[n] := renderEvent;
6121
FFreeCallBacks[n] := renderPointFreed;
6124
// UnRegisterCallBack
6127
procedure TGLRenderPoint.UnRegisterCallBack(renderEvent: TDirectRenderEvent);
6129
TEventContainer = record
6130
event: TDirectRenderEvent;
6134
refContainer, listContainer: TEventContainer;
6136
refContainer.event := renderEvent;
6137
n := Length(FCallBacks);
6138
for i := 0 to n - 1 do
6140
listContainer.event := FCallBacks[i];
6141
if CompareMem(@listContainer, @refContainer, SizeOf(TEventContainer)) then
6143
for j := i + 1 to n - 1 do
6145
FCallBacks[j - 1] := FCallBacks[j];
6146
FFreeCallBacks[j - 1] := FFreeCallBacks[j];
6148
SetLength(FCallBacks, n - 1);
6149
SetLength(FFreeCallBacks, n - 1);
6158
procedure TGLRenderPoint.Clear;
6160
while Length(FCallBacks) > 0 do
6162
FFreeCallBacks[High(FCallBacks)](Self);
6163
SetLength(FCallBacks, Length(FCallBacks) - 1);
6167
// ------------------
6168
// ------------------ TGLProxyObject ------------------
6169
// ------------------
6174
constructor TGLProxyObject.Create(AOwner: TComponent);
6177
FProxyOptions := cDefaultProxyOptions;
6183
destructor TGLProxyObject.Destroy;
6185
SetMasterObject(nil);
6192
procedure TGLProxyObject.Assign(Source: TPersistent);
6194
if Source is TGLProxyObject then
6196
SetMasterObject(TGLProxyObject(Source).MasterObject);
6198
inherited Assign(Source);
6204
procedure TGLProxyObject.DoRender(var ARci: TGLRenderContextInfo;
6205
ARenderSelf, ARenderChildren: Boolean);
6207
gotMaster, masterGotEffects, oldProxySubObject: Boolean;
6213
gotMaster := Assigned(FMasterObject);
6214
masterGotEffects := gotMaster and (pooEffects in FProxyOptions)
6215
and (FMasterObject.Effects.Count > 0);
6218
if pooObjects in FProxyOptions then
6220
oldProxySubObject := ARci.proxySubObject;
6221
ARci.proxySubObject := True;
6222
if pooTransformation in FProxyOptions then
6223
with ARci.PipelineTransformation do
6224
ModelMatrix := MatrixMultiply(FMasterObject.Matrix, ModelMatrix);
6225
FMasterObject.DoRender(ARci, ARenderSelf, (FMasterObject.Count > 0));
6226
ARci.proxySubObject := oldProxySubObject;
6229
// now render self stuff (our children, our effects, etc.)
6230
if ARenderChildren and (Count > 0) then
6231
Self.RenderChildren(0, Count - 1, ARci);
6232
if masterGotEffects then
6233
FMasterObject.Effects.RenderPostEffects(ARci);
6235
FRendering := False;
6237
ClearStructureChanged;
6240
// AxisAlignedDimensions
6243
function TGLProxyObject.AxisAlignedDimensions: TVector;
6245
If Assigned(FMasterObject) then
6247
Result := FMasterObject.AxisAlignedDimensionsUnscaled;
6248
If (pooTransformation in ProxyOptions) then
6249
ScaleVector(Result,FMasterObject.Scale.AsVector)
6251
ScaleVector(Result, Scale.AsVector);
6254
Result := inherited AxisAlignedDimensions;
6257
function TGLProxyObject.AxisAlignedDimensionsUnscaled: TVector;
6259
if Assigned(FMasterObject) then
6261
Result := FMasterObject.AxisAlignedDimensionsUnscaled;
6264
Result := inherited AxisAlignedDimensionsUnscaled;
6267
// BarycenterAbsolutePosition
6270
function TGLProxyObject.BarycenterAbsolutePosition: TVector;
6272
lAdjustVector: TVector;
6274
if Assigned(FMasterObject) then
6276
// Not entirely correct, but better than nothing...
6277
lAdjustVector := VectorSubtract(FMasterObject.BarycenterAbsolutePosition,
6278
FMasterObject.AbsolutePosition);
6279
Position.AsVector := VectorAdd(Position.AsVector, lAdjustVector);
6280
Result := AbsolutePosition;
6281
Position.AsVector := VectorSubtract(Position.AsVector, lAdjustVector);
6284
Result := inherited BarycenterAbsolutePosition;
6290
procedure TGLProxyObject.Notification(AComponent: TComponent; Operation:
6293
if (Operation = opRemove) and (AComponent = FMasterObject) then
6294
MasterObject := nil;
6301
procedure TGLProxyObject.SetMasterObject(const val: TGLBaseSceneObject);
6303
if FMasterObject <> val then
6305
if Assigned(FMasterObject) then
6306
FMasterObject.RemoveFreeNotification(Self);
6307
FMasterObject := val;
6308
if Assigned(FMasterObject) then
6309
FMasterObject.FreeNotification(Self);
6317
procedure TGLProxyObject.SetProxyOptions(const val: TGLProxyObjectOptions);
6319
if FProxyOptions <> val then
6321
FProxyOptions := val;
6329
function TGLProxyObject.RayCastIntersect(const rayStart, rayVector: TVector;
6330
intersectPoint: PVector = nil;
6331
intersectNormal: PVector = nil): Boolean;
6333
localRayStart, localRayVector: TVector;
6335
if Assigned(MasterObject) then
6337
SetVector(localRayStart, AbsoluteToLocal(rayStart));
6338
SetVector(localRayStart, MasterObject.LocalToAbsolute(localRayStart));
6339
SetVector(localRayVector, AbsoluteToLocal(rayVector));
6340
SetVector(localRayVector, MasterObject.LocalToAbsolute(localRayVector));
6341
NormalizeVector(localRayVector);
6343
Result := MasterObject.RayCastIntersect(localRayStart, localRayVector,
6344
intersectPoint, intersectNormal);
6347
if Assigned(intersectPoint) then
6349
SetVector(intersectPoint^,
6350
MasterObject.AbsoluteToLocal(intersectPoint^));
6351
SetVector(intersectPoint^, LocalToAbsolute(intersectPoint^));
6353
if Assigned(intersectNormal) then
6355
SetVector(intersectNormal^,
6356
MasterObject.AbsoluteToLocal(intersectNormal^));
6357
SetVector(intersectNormal^, LocalToAbsolute(intersectNormal^));
6365
// GenerateSilhouette
6368
function TGLProxyObject.GenerateSilhouette(const silhouetteParameters:
6369
TGLSilhouetteParameters): TGLSilhouette;
6371
if Assigned(MasterObject) then
6372
Result := MasterObject.GenerateSilhouette(silhouetteParameters)
6377
// ------------------
6378
// ------------------ TGLLightSource ------------------
6379
// ------------------
6384
constructor TGLLightSource.Create(AOwner: TComponent);
6386
inherited Create(AOwner);
6388
FSpotDirection := TGLCoordinates.CreateInitialized(Self, VectorMake(0, 0, -1,0),csVector);
6389
FConstAttenuation := 1;
6390
FLinearAttenuation := 0;
6391
FQuadraticAttenuation := 0;
6394
FLightStyle := lsSpot;
6395
FAmbient := TGLColor.Create(Self);
6396
FDiffuse := TGLColor.Create(Self);
6397
FDiffuse.Initialize(clrWhite);
6398
FSpecular := TGLColor.Create(Self);
6404
destructor TGLLightSource.Destroy;
6406
FSpotDirection.Free;
6416
procedure TGLLightSource.DoRender(var ARci: TGLRenderContextInfo;
6417
ARenderSelf, ARenderChildren: Boolean);
6419
if ARenderChildren and Assigned(FChildren) then
6420
Self.RenderChildren(0, Count - 1, ARci);
6426
function TGLLightSource.RayCastIntersect(const rayStart, rayVector: TVector;
6427
intersectPoint: PVector = nil;
6428
intersectNormal: PVector = nil): Boolean;
6436
procedure TGLLightSource.CoordinateChanged(Sender: TGLCustomCoordinates);
6439
if Sender = FSpotDirection then
6440
TransformationChanged;
6443
// GenerateSilhouette
6446
function TGLLightSource.GenerateSilhouette(const silhouetteParameters:
6447
TGLSilhouetteParameters): TGLSilhouette;
6455
function TGLLightSource.GetHandle(var rci: TGLRenderContextInfo): Cardinal;
6463
procedure TGLLightSource.SetShining(AValue: Boolean);
6465
if AValue <> FShining then
6475
procedure TGLLightSource.SetSpotDirection(AVector: TGLCoordinates);
6477
FSpotDirection.DirectVector := AVector.AsVector;
6478
FSpotDirection.W := 0;
6485
procedure TGLLightSource.SetSpotExponent(AValue: Single);
6487
if FSpotExponent <> AValue then
6489
FSpotExponent := AValue;
6497
procedure TGLLightSource.SetSpotCutOff(const val: Single);
6499
if FSpotCutOff <> val then
6501
if ((val >= 0) and (val <= 90)) or (val = 180) then
6512
procedure TGLLightSource.SetLightStyle(const val: TLightStyle);
6514
if FLightStyle <> val then
6524
procedure TGLLightSource.SetAmbient(AValue: TGLColor);
6526
FAmbient.Color := AValue.Color;
6533
procedure TGLLightSource.SetDiffuse(AValue: TGLColor);
6535
FDiffuse.Color := AValue.Color;
6542
procedure TGLLightSource.SetSpecular(AValue: TGLColor);
6544
FSpecular.Color := AValue.Color;
6548
// SetConstAttenuation
6551
procedure TGLLightSource.SetConstAttenuation(AValue: Single);
6553
if FConstAttenuation <> AValue then
6555
FConstAttenuation := AValue;
6560
// SetLinearAttenuation
6563
procedure TGLLightSource.SetLinearAttenuation(AValue: Single);
6565
if FLinearAttenuation <> AValue then
6567
FLinearAttenuation := AValue;
6572
// SetQuadraticAttenuation
6575
procedure TGLLightSource.SetQuadraticAttenuation(AValue: Single);
6577
if FQuadraticAttenuation <> AValue then
6579
FQuadraticAttenuation := AValue;
6587
function TGLLightSource.Attenuated: Boolean;
6589
Result := (LightStyle <> lsParallel)
6590
and ((ConstAttenuation <> 1) or (LinearAttenuation <> 0) or
6591
(QuadraticAttenuation <> 0));
6594
// ------------------
6595
// ------------------ TGLScene ------------------
6596
// ------------------
6601
constructor TGLScene.Create(AOwner: TComponent);
6605
FCurrentBuffer := nil;
6606
FObjects := TGLSceneRootObject.Create(Self);
6607
FObjects.Name := 'ObjectRoot';
6608
FLights := TPersistentObjectList.Create;
6609
FObjectsSorting := osRenderBlendedLast;
6610
FVisibilityCulling := vcNone;
6611
// actual maximum number of lights is stored in TGLSceneViewer
6613
FInitializableObjects := TGLInitializableObjectList.Create;
6619
destructor TGLScene.Destroy;
6621
InitializableObjects.Free;
6622
FObjects.DestroyHandles;
6625
if Assigned(FBuffers) then FreeAndNil(FBuffers);
6632
procedure TGLScene.AddLight(ALight: TGLLightSource);
6636
for i := 0 to FLights.Count - 1 do
6637
if FLights.List^[i] = nil then
6639
FLights.List^[i] := ALight;
6640
ALight.FLightID := i;
6648
procedure TGLScene.RemoveLight(ALight: TGLLightSource);
6652
idx := FLights.IndexOf(ALight);
6654
FLights[idx] := nil;
6660
procedure TGLScene.AddLights(anObj: TGLBaseSceneObject);
6664
if anObj is TGLLightSource then
6665
AddLight(TGLLightSource(anObj));
6666
for i := 0 to anObj.Count - 1 do
6667
AddLights(anObj.Children[i]);
6673
procedure TGLScene.RemoveLights(anObj: TGLBaseSceneObject);
6677
if anObj is TGLLightSource then
6678
RemoveLight(TGLLightSource(anObj));
6679
for i := 0 to anObj.Count - 1 do
6680
RemoveLights(anObj.Children[i]);
6686
procedure TGLScene.ShutdownAllLights;
6688
procedure DoShutdownLight(Obj: TGLBaseSceneObject);
6692
if Obj is TGLLightSource then
6693
TGLLightSource(Obj).Shining := False;
6694
for i := 0 to Obj.Count - 1 do
6695
DoShutDownLight(Obj[i]);
6699
DoShutdownLight(FObjects);
6705
procedure TGLScene.AddBuffer(aBuffer: TGLSceneBuffer);
6707
if not Assigned(FBuffers) then
6708
FBuffers := TPersistentObjectList.Create;
6709
if FBuffers.IndexOf(aBuffer) < 0 then
6711
FBuffers.Add(aBuffer);
6712
if FBaseContext = nil then
6713
FBaseContext := TGLSceneBuffer(FBuffers[0]).RenderingContext;
6714
if (FBuffers.Count > 1) and Assigned(FBaseContext) then
6715
aBuffer.RenderingContext.ShareLists(FBaseContext);
6722
procedure TGLScene.RemoveBuffer(aBuffer: TGLSceneBuffer);
6726
if Assigned(FBuffers) then
6728
i := FBuffers.IndexOf(aBuffer);
6731
if FBuffers.Count = 1 then
6733
FreeAndNil(FBuffers);
6734
FBaseContext := nil;
6739
FBaseContext := TGLSceneBuffer(FBuffers[0]).RenderingContext;
6748
procedure TGLScene.GetChildren(AProc: TGetChildProc; Root: TComponent);
6750
FObjects.GetChildren(AProc, Root);
6756
procedure TGLScene.SetChildOrder(AChild: TComponent; Order: Integer);
6758
(AChild as TGLBaseSceneObject).Index := Order;
6764
function TGLScene.IsUpdating: Boolean;
6766
Result := (FUpdateCount <> 0) or (csLoading in ComponentState) or (csDestroying
6773
procedure TGLScene.BeginUpdate;
6781
procedure TGLScene.EndUpdate;
6783
Assert(FUpdateCount > 0);
6785
if FUpdateCount = 0 then
6792
procedure TGLScene.SetObjectsSorting(const val: TGLObjectsSorting);
6794
if FObjectsSorting <> val then
6796
if val = osInherited then
6797
FObjectsSorting := osRenderBlendedLast
6799
FObjectsSorting := val;
6804
// SetVisibilityCulling
6807
procedure TGLScene.SetVisibilityCulling(const val: TGLVisibilityCulling);
6809
if FVisibilityCulling <> val then
6811
if val = vcInherited then
6812
FVisibilityCulling := vcNone
6814
FVisibilityCulling := val;
6822
procedure TGLScene.ReadState(Reader: TReader);
6824
SaveRoot: TComponent;
6826
SaveRoot := Reader.Root;
6828
if Owner <> nil then
6829
Reader.Root := Owner;
6832
Reader.Root := SaveRoot;
6839
procedure TGLScene.Progress(const deltaTime, newTime: Double);
6843
pt.deltaTime := deltaTime;
6844
pt.newTime := newTime;
6845
FCurrentDeltaTime := deltaTime;
6846
if Assigned(FOnBeforeProgress) then
6847
FOnBeforeProgress(Self, deltaTime, newTime);
6848
FObjects.DoProgress(pt);
6849
if Assigned(FOnProgress) then
6850
FOnProgress(Self, deltaTime, newTime);
6856
procedure TGLScene.SaveToFile(const fileName: string);
6860
stream := CreateFileStream(fileName, fmCreate);
6862
SaveToStream(stream);
6871
procedure TGLScene.LoadFromFile(const fileName: string);
6873
procedure CheckResFileStream(Stream: TStream);
6878
N := Stream.Position;
6879
Stream.Read(B, Sizeof(B));
6880
Stream.Position := N;
6882
Stream.ReadResHeader;
6888
stream := CreateFileStream(fileName, fmOpenRead);
6890
CheckResFileStream(stream);
6891
LoadFromStream(stream);
6900
procedure TGLScene.SaveToTextFile(const fileName: string);
6905
mem := TMemoryStream.Create;
6906
fil := CreateFileStream(fileName, fmCreate);
6910
ObjectBinaryToText(mem, fil);
6920
procedure TGLScene.LoadFromTextFile(const fileName: string);
6925
Mem := TMemoryStream.Create;
6926
Fil := CreateFileStream(fileName, fmOpenRead);
6928
ObjectTextToBinary(Fil, Mem);
6930
LoadFromStream(Mem);
6940
procedure TGLScene.LoadFromStream(aStream: TStream);
6942
fixups: TStringList;
6944
obj: TGLBaseSceneObject;
6946
Fixups := TStringList.Create;
6948
if Assigned(FBuffers) then
6950
for i := 0 to FBuffers.Count - 1 do
6951
Fixups.AddObject(TGLSceneBuffer(FBuffers[i]).Camera.Name, FBuffers[i]);
6954
// will remove Viewer from FBuffers
6955
Objects.DeleteChildren;
6956
aStream.ReadComponent(Self);
6957
for i := 0 to Fixups.Count - 1 do
6959
obj := FindSceneObject(fixups[I]);
6960
if obj is TGLCamera then
6961
TGLSceneBuffer(Fixups.Objects[i]).Camera := TGLCamera(obj)
6962
else { can assign default camera (if existing, of course) instead }6973
procedure TGLScene.SaveToStream(aStream: TStream);
6975
aStream.WriteComponent(Self);
6981
function TGLScene.FindSceneObject(const AName: string): TGLBaseSceneObject;
6983
Result := FObjects.FindChild(AName, False);
6989
function TGLScene.RayCastIntersect(const rayStart, rayVector: TVector;
6990
intersectPoint: PVector = nil;
6991
intersectNormal: PVector = nil): TGLBaseSceneObject;
6994
bestHit: TGLBaseSceneObject;
6995
iPoint, iNormal: TVector;
6998
function RecursiveDive(baseObject: TGLBaseSceneObject): TGLBaseSceneObject;
7001
curObj: TGLBaseSceneObject;
7003
fNear, fFar: single;
7006
for i := 0 to baseObject.Count - 1 do
7008
curObj := baseObject.Children[i];
7009
if curObj.Visible then
7011
if RayCastAABBIntersect(rayStart, rayVector,
7012
curObj.AxisAlignedBoundingBoxAbsoluteEx, fNear, fFar) then
7014
if fnear * fnear > bestDist2 then
7016
if not PointInAABB(rayStart, curObj.AxisAlignedBoundingBoxAbsoluteEx) then
7019
if curObj.RayCastIntersect(rayStart, rayVector, @iPoint, pINormal) then
7021
dist2 := VectorDistance2(rayStart, iPoint);
7022
if dist2 < bestDist2 then
7026
if Assigned(intersectPoint) then
7027
intersectPoint^ := iPoint;
7028
if Assigned(intersectNormal) then
7029
intersectNormal^ := iNormal;
7032
RecursiveDive(curObj);
7041
if Assigned(intersectNormal) then
7042
pINormal := @iNormal
7045
RecursiveDive(Objects);
7052
procedure TGLScene.NotifyChange(Sender: TObject);
7056
if (not IsUpdating) and Assigned(FBuffers) then
7057
for i := 0 to FBuffers.Count - 1 do
7058
TGLSceneBuffer(FBuffers[i]).NotifyChange(Self);
7064
procedure TGLScene.SetupLights(maxLights: Integer);
7067
lightSource: TGLLightSource;
7071
nbLights := FLights.Count;
7072
if nbLights > maxLights then
7073
nbLights := maxLights;
7074
// setup all light sources
7075
with CurrentGLContext.GLStates, CurrentGLContext.PipelineTransformation do
7077
for i := 0 to nbLights - 1 do
7079
lightSource := TGLLightSource(FLights[i]);
7080
if Assigned(lightSource) then
7083
LightEnabling[FLightID] := Shining;
7086
if FixedFunctionPipeLight then
7089
if LightStyle in [lsParallel, lsParallelSpot] then
7091
ModelMatrix := AbsoluteMatrix;
7092
GL.Lightfv(GL_LIGHT0 + FLightID, GL_POSITION, SpotDirection.AsAddress);
7096
ModelMatrix := Parent.AbsoluteMatrix;
7097
GL.Lightfv(GL_LIGHT0 + FLightID, GL_POSITION, Position.AsAddress);
7099
if LightStyle in [lsSpot, lsParallelSpot] then
7101
if FSpotCutOff <> 180 then
7102
GL.Lightfv(GL_LIGHT0 + FLightID, GL_SPOT_DIRECTION, FSpotDirection.AsAddress);
7106
lPos := lightSource.AbsolutePosition;
7107
if LightStyle in [lsParallel, lsParallelSpot] then
7111
LightPosition[FLightID] := lPos;
7112
LightSpotDirection[FLightID] := lightSource.SpotDirection.AsAffineVector;
7114
LightAmbient[FLightID] := FAmbient.Color;
7115
LightDiffuse[FLightID] := FDiffuse.Color;
7116
LightSpecular[FLightID] := FSpecular.Color;
7118
LightConstantAtten[FLightID] := FConstAttenuation;
7119
LightLinearAtten[FLightID] := FLinearAttenuation;
7120
LightQuadraticAtten[FLightID] := FQuadraticAttenuation;
7122
LightSpotExponent[FLightID] := FSpotExponent;
7123
LightSpotCutoff[FLightID] := FSpotCutOff;
7127
LightEnabling[i] := False;
7129
// turn off other lights
7130
for i := nbLights to maxLights - 1 do
7131
LightEnabling[i] := False;
7132
ModelMatrix := IdentityHmgMatrix;
7136
// ------------------
7137
// ------------------ TGLFogEnvironment ------------------
7138
// ------------------
7140
// Note: The fog implementation is not conformal with the rest of the scene management
7141
// because it is viewer bound not scene bound.
7146
constructor TGLFogEnvironment.Create(AOwner: TPersistent);
7149
FSceneBuffer := (AOwner as TGLSceneBuffer);
7150
FFogColor := TGLColor.CreateInitialized(Self, clrBlack);
7151
FFogMode := fmLinear;
7154
FFogDistance := fdDefault;
7160
destructor TGLFogEnvironment.Destroy;
7169
procedure TGLFogEnvironment.SetFogColor(Value: TGLColor);
7171
if Assigned(Value) then
7173
FFogColor.Assign(Value);
7181
procedure TGLFogEnvironment.SetFogStart(Value: Single);
7183
if Value <> FFogStart then
7193
procedure TGLFogEnvironment.SetFogEnd(Value: Single);
7195
if Value <> FFogEnd then
7205
procedure TGLFogEnvironment.Assign(Source: TPersistent);
7207
if Source is TGLFogEnvironment then
7209
FFogColor.Assign(TGLFogEnvironment(Source).FFogColor);
7210
FFogStart := TGLFogEnvironment(Source).FFogStart;
7211
FFogEnd := TGLFogEnvironment(Source).FFogEnd;
7212
FFogMode := TGLFogEnvironment(Source).FFogMode;
7213
FFogDistance := TGLFogEnvironment(Source).FFogDistance;
7222
function TGLFogEnvironment.IsAtDefaultValues: Boolean;
7224
Result := VectorEquals(FogColor.Color, FogColor.DefaultColor)
7227
and (FogMode = fmLinear)
7228
and (FogDistance = fdDefault);
7234
procedure TGLFogEnvironment.SetFogMode(Value: TFogMode);
7236
if Value <> FFogMode then
7246
procedure TGLFogEnvironment.SetFogDistance(const val: TFogDistance);
7248
if val <> FFogDistance then
7250
FFogDistance := val;
7258
vImplemDependantFogDistanceDefault: Integer = -1;
7260
procedure TGLFogEnvironment.ApplyFog;
7262
tempActivation: Boolean;
7264
with FSceneBuffer do
7266
if not Assigned(FRenderingContext) then
7268
tempActivation := not FRenderingContext.Active;
7269
if tempActivation then
7270
FRenderingContext.Activate;
7274
fmLinear: GL.Fogi(GL_FOG_MODE, GL_LINEAR);
7277
GL.Fogi(GL_FOG_MODE, GL_EXP);
7278
GL.Fogf(GL_FOG_DENSITY, FFogColor.Alpha);
7282
GL.Fogi(GL_FOG_MODE, GL_EXP2);
7283
GL.Fogf(GL_FOG_DENSITY, FFogColor.Alpha);
7286
GL.Fogfv(GL_FOG_COLOR, FFogColor.AsAddress);
7287
GL.Fogf(GL_FOG_START, FFogStart);
7288
GL.Fogf(GL_FOG_END, FFogEnd);
7289
if GL.NV_fog_distance then
7294
if vImplemDependantFogDistanceDefault = -1 then
7295
GL.GetIntegerv(GL_FOG_DISTANCE_MODE_NV,
7296
@vImplemDependantFogDistanceDefault)
7298
GL.Fogi(GL_FOG_DISTANCE_MODE_NV, vImplemDependantFogDistanceDefault);
7301
GL.Fogi(GL_FOG_DISTANCE_MODE_NV, GL_EYE_PLANE_ABSOLUTE_NV);
7303
GL.Fogi(GL_FOG_DISTANCE_MODE_NV, GL_EYE_RADIAL_NV);
7309
if tempActivation then
7310
FSceneBuffer.RenderingContext.Deactivate;
7313
// ------------------
7314
// ------------------ TGLSceneBuffer ------------------
7315
// ------------------
7320
constructor TGLSceneBuffer.Create(AOwner: TPersistent);
7322
inherited Create(AOwner);
7324
// initialize private state variables
7325
FFogEnvironment := TGLFogEnvironment.Create(Self);
7326
FBackgroundColor := clBtnFace;
7327
FBackgroundAlpha := 1;
7328
FAmbientColor := TGLColor.CreateInitialized(Self, clrGray20);
7330
FFaceCulling := True;
7332
FAntiAliasing := aaDefault;
7333
FDepthPrecision := dpDefault;
7334
FColorDepth := cdDefault;
7335
FShadeModel := smDefault;
7336
FFogEnable := False;
7337
FLayer := clMainPlane;
7338
FAfterRenderEffects := TPersistentObjectList.Create;
7340
FContextOptions := [roDoubleBuffer, roRenderToWindow, roDebugContext];
7342
ResetPerformanceMonitor;
7348
destructor TGLSceneBuffer.Destroy;
7353
FAfterRenderEffects.Free;
7354
FFogEnvironment.Free;
7361
procedure TGLSceneBuffer.PrepareGLContext;
7363
if Assigned(FOnPrepareGLContext) then
7364
FOnPrepareGLContext(Self);
7370
procedure TGLSceneBuffer.SetupRCOptions(context: TGLContext);
7372
cColorDepthToColorBits: array[cdDefault..cdFloat128bits] of Integer =
7373
(24, 8, 16, 24, 64, 128); // float_type
7374
cDepthPrecisionToDepthBits: array[dpDefault..dp32bits] of Integer =
7377
locOptions: TGLRCOptions;
7378
locStencilBits, locAlphaBits, locColorBits: Integer;
7382
if roDoubleBuffer in ContextOptions then
7383
locOptions := locOptions + [rcoDoubleBuffered];
7384
if roStereo in ContextOptions then
7385
locOptions := locOptions + [rcoStereo];
7386
if roDebugContext in ContextOptions then
7387
locOptions := locOptions + [rcoDebug];
7388
if roOpenGL_ES2_Context in ContextOptions then
7389
locOptions := locOptions + [rcoOGL_ES];
7390
if roNoColorBuffer in ContextOptions then
7393
locColorBits := cColorDepthToColorBits[ColorDepth];
7394
if roStencilBuffer in ContextOptions then
7397
locStencilBits := 0;
7398
if roDestinationAlpha in ContextOptions then
7404
if roSoftwareMode in ContextOptions then
7405
Acceleration := chaSoftware
7407
Acceleration := chaHardware;
7408
Options := locOptions;
7409
ColorBits := locColorBits;
7410
DepthBits := cDepthPrecisionToDepthBits[DepthPrecision];
7411
StencilBits := locStencilBits;
7412
AlphaBits := locAlphaBits;
7413
AccumBits := AccumBufferBits;
7415
AntiAliasing := Self.AntiAliasing;
7416
Layer := Self.Layer;
7417
GLStates.ForwardContext := roForwardContext in ContextOptions;
7422
procedure TGLSceneBuffer.CreateRC(AWindowHandle: HWND; memoryContext:
7423
Boolean; BufferCount: Integer);
7429
// will be freed in DestroyWindowHandle
7430
FRenderingContext := GLContextManager.CreateContext;
7431
if not Assigned(FRenderingContext) then
7432
raise Exception.Create('Failed to create RenderingContext.');7433
SetupRCOptions(FRenderingContext);
7435
if Assigned(FCamera) and Assigned(FCamera.FScene) then
7436
FCamera.FScene.AddBuffer(Self);
7438
with FRenderingContext do
7441
if memoryContext then
7442
CreateMemoryContext(AWindowHandle, FViewPort.Width, FViewPort.Height,
7445
CreateContext(AWindowHandle);
7447
FreeAndNil(FRenderingContext);
7451
FRenderingContext.Activate;
7453
// this one should NOT be replaced with an assert
7454
if not GL.VERSION_1_1 then
7456
GLSLogger.LogFatalError(glsWrongVersion);
7459
// define viewport, this is necessary because the first WM_SIZE message
7460
// is posted before the rendering context has been created
7461
FRenderingContext.GLStates.ViewPort :=
7462
Vector4iMake(FViewPort.Left, FViewPort.Top, FViewPort.Width, FViewPort.Height);
7463
// set up initial context states
7464
SetupRenderingContext(FRenderingContext);
7465
FRenderingContext.GLStates.ColorClearValue :=
7466
ConvertWinColor(FBackgroundColor);
7468
FRenderingContext.Deactivate;
7471
FRendering := False;
7478
procedure TGLSceneBuffer.DestroyRC;
7480
if Assigned(FRenderingContext) then
7483
// for some obscure reason, Mesa3D doesn't like this call... any help welcome
7484
FreeAndNil(FSelector);
7485
FreeAndNil(FRenderingContext);
7486
if Assigned(FCamera) and Assigned(FCamera.FScene) then
7487
FCamera.FScene.RemoveBuffer(Self);
7494
function TGLSceneBuffer.RCInstantiated: Boolean;
7496
Result := Assigned(FRenderingContext);
7502
procedure TGLSceneBuffer.Resize(newLeft, newTop, newWidth, newHeight: Integer);
7504
if newWidth < 1 then
7506
if newHeight < 1 then
7508
FViewPort.Left := newLeft;
7509
FViewPort.Top := newTop;
7510
FViewPort.Width := newWidth;
7511
FViewPort.Height := newHeight;
7512
if Assigned(FRenderingContext) then
7514
FRenderingContext.Activate;
7516
// Part of workaround for MS OpenGL "black borders" bug
7517
FRenderingContext.GLStates.ViewPort :=
7518
Vector4iMake(FViewPort.Left, FViewPort.Top, FViewPort.Width, FViewPort.Height);
7520
FRenderingContext.Deactivate;
7528
function TGLSceneBuffer.Acceleration: TGLContextAcceleration;
7530
if Assigned(FRenderingContext) then
7531
Result := FRenderingContext.Acceleration
7533
Result := chaUnknown;
7536
// SetupRenderingContext
7539
procedure TGLSceneBuffer.SetupRenderingContext(context: TGLContext);
7541
procedure SetState(bool: Boolean; csState: TGLState);
7544
true: context.GLStates.PerformEnable(csState);
7545
false: context.GLStates.PerformDisable(csState);
7550
LColorDepth: Cardinal;
7552
if not Assigned(context) then
7555
if not (roForwardContext in ContextOptions) then
7557
GL.LightModelfv(GL_LIGHT_MODEL_AMBIENT, FAmbientColor.AsAddress);
7558
if roTwoSideLighting in FContextOptions then
7559
GL.LightModeli(GL_LIGHT_MODEL_TWO_SIDE, GL_TRUE)
7561
GL.LightModeli(GL_LIGHT_MODEL_TWO_SIDE, GL_FALSE);
7562
GL.Hint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);
7564
smDefault, smSmooth: GL.ShadeModel(GL_SMOOTH);
7565
smFlat: GL.ShadeModel(GL_FLAT);
7567
Assert(False, glsErrorEx + glsUnknownType);
7571
with context.GLStates do
7573
Enable(stNormalize);
7574
SetState(DepthTest, stDepthTest);
7575
SetState(FaceCulling, stCullFace);
7576
SetState(Lighting, stLighting);
7577
SetState(FogEnable, stFog);
7578
if GL.ARB_depth_clamp then
7579
Disable(stDepthClamp);
7580
if not (roForwardContext in ContextOptions) then
7582
GL.GetIntegerv(GL_BLUE_BITS, @LColorDepth); // could've used red or green too
7583
SetState((LColorDepth < 8), stDither);
7585
ResetAllGLTextureMatrix;
7592
function TGLSceneBuffer.GetLimit(Which: TLimitType): Integer;
7594
VP: array[0..1] of Double;
7598
GL.GetIntegerv(GL_MAX_CLIP_PLANES, @Result);
7600
GL.GetIntegerv(GL_MAX_EVAL_ORDER, @Result);
7602
GL.GetIntegerv(GL_MAX_LIGHTS, @Result);
7604
GL.GetIntegerv(GL_MAX_LIST_NESTING, @Result);
7606
GL.GetIntegerv(GL_MAX_MODELVIEW_STACK_DEPTH, @Result);
7608
GL.GetIntegerv(GL_MAX_NAME_STACK_DEPTH, @Result);
7610
GL.GetIntegerv(GL_MAX_PIXEL_MAP_TABLE, @Result);
7612
GL.GetIntegerv(GL_MAX_PROJECTION_STACK_DEPTH, @Result);
7614
GL.GetIntegerv(GL_MAX_TEXTURE_SIZE, @Result);
7616
GL.GetIntegerv(GL_MAX_TEXTURE_STACK_DEPTH, @Result);
7619
GL.GetDoublev(GL_MAX_VIEWPORT_DIMS, @VP);
7620
if VP[0] > VP[1] then
7621
Result := Round(VP[0])
7623
Result := Round(VP[1]);
7626
GL.GetIntegerv(GL_ACCUM_ALPHA_BITS, @Result);
7628
GL.GetIntegerv(GL_ACCUM_BLUE_BITS, @Result);
7630
GL.GetIntegerv(GL_ACCUM_GREEN_BITS, @Result);
7632
GL.GetIntegerv(GL_ACCUM_RED_BITS, @Result);
7634
GL.GetIntegerv(GL_ALPHA_BITS, @Result);
7636
GL.GetIntegerv(GL_AUX_BUFFERS, @Result);
7638
GL.GetIntegerv(GL_DEPTH_BITS, @Result);
7640
GL.GetIntegerv(GL_STENCIL_BITS, @Result);
7642
GL.GetIntegerv(GL_BLUE_BITS, @Result);
7644
GL.GetIntegerv(GL_GREEN_BITS, @Result);
7646
GL.GetIntegerv(GL_RED_BITS, @Result);
7648
GL.GetIntegerv(GL_INDEX_BITS, @Result);
7650
GL.GetIntegerv(GL_STEREO, @Result);
7652
GL.GetIntegerv(GL_DOUBLEBUFFER, @Result);
7654
GL.GetIntegerv(GL_SUBPIXEL_BITS, @Result);
7656
if GL.ARB_multitexture then
7657
GL.GetIntegerv(GL_MAX_TEXTURE_UNITS_ARB, @Result)
7668
procedure TGLSceneBuffer.RenderToFile(const aFile: string; DPI: Integer);
7671
saveAllowed: Boolean;
7674
Assert((not FRendering), glsAlreadyRendering);
7675
aBitmap := TGLBitmap.Create;
7677
aBitmap.Width := FViewPort.Width;
7678
aBitmap.Height := FViewPort.Height;
7679
aBitmap.PixelFormat := glpf24Bit;
7680
RenderToBitmap(ABitmap, DPI);
7682
if fileName = '' then
7683
saveAllowed := SavePictureDialog(fileName)
7685
saveAllowed := True;
7688
if FileExists(fileName) then
7689
saveAllowed := QuestionDlg(Format('Overwrite file %s?', [fileName]));7691
aBitmap.SaveToFile(fileName);
7701
procedure TGLSceneBuffer.RenderToFile(const AFile: string; bmpWidth, bmpHeight:
7705
saveAllowed: Boolean;
7708
Assert((not FRendering), glsAlreadyRendering);
7709
aBitmap := TGLBitmap.Create;
7711
aBitmap.Width := bmpWidth;
7712
aBitmap.Height := bmpHeight;
7713
aBitmap.PixelFormat := glpf24Bit;
7714
RenderToBitmap(aBitmap,
7715
(GetDeviceLogicalPixelsX(Cardinal(ABitmap.Canvas.Handle)) * bmpWidth) div
7718
if fileName = '' then
7719
saveAllowed := SavePictureDialog(fileName)
7721
saveAllowed := True;
7724
if FileExists(fileName) then
7725
saveAllowed := QuestionDlg(Format('Overwrite file %s?', [fileName]));7727
aBitmap.SaveToFile(fileName);
7737
function TGLSceneBuffer.CreateSnapShot: TGLBitmap32;
7739
Result := TGLBitmap32.Create;
7740
Result.Width := FViewPort.Width;
7741
Result.Height := FViewPort.Height;
7742
if Assigned(Camera) and Assigned(Camera.Scene) then
7744
FRenderingContext.Activate;
7746
Result.ReadPixels(Rect(0, 0, FViewPort.Width, FViewPort.Height));
7748
FRenderingContext.DeActivate;
7753
// CreateSnapShotBitmap
7756
function TGLSceneBuffer.CreateSnapShotBitmap: TGLBitmap;
7760
bmp32 := CreateSnapShot;
7762
Result := bmp32.Create32BitsBitmap;
7771
procedure TGLSceneBuffer.CopyToTexture(aTexture: TGLTexture);
7773
CopyToTexture(aTexture, 0, 0, Width, Height, 0, 0);
7779
procedure TGLSceneBuffer.CopyToTexture(aTexture: TGLTexture;
7780
xSrc, ySrc, AWidth, AHeight: Integer;
7781
xDest, yDest: Integer;
7782
glCubeFace: TGLEnum = 0);
7784
bindTarget: TGLTextureTarget;
7786
if RenderingContext <> nil then
7788
RenderingContext.Activate;
7790
if not (aTexture.Image is TGLBlankImage) then
7791
aTexture.ImageClassName := TGLBlankImage.ClassName;
7792
if aTexture.Image.Width <> AWidth then
7793
TGLBlankImage(aTexture.Image).Width := AWidth;
7794
if aTexture.Image.Height <> AHeight then
7795
TGLBlankImage(aTexture.Image).Height := AHeight;
7796
if aTexture.Image.Depth <> 0 then
7797
TGLBlankImage(aTexture.Image).Depth := 0;
7798
if TGLBlankImage(aTexture.Image).CubeMap <> (glCubeFace > 0) then
7799
TGLBlankImage(aTexture.Image).CubeMap := (glCubeFace > 0);
7801
bindTarget := aTexture.Image.NativeTextureTarget;
7802
RenderingContext.GLStates.TextureBinding[0, bindTarget] := aTexture.Handle;
7803
if glCubeFace > 0 then
7804
GL.CopyTexSubImage2D(glCubeFace,
7805
0, xDest, yDest, xSrc, ySrc, AWidth, AHeight)
7807
GL.CopyTexSubImage2D(DecodeGLTextureTarget(bindTarget),
7808
0, xDest, yDest, xSrc, ySrc, AWidth, AHeight)
7810
RenderingContext.Deactivate;
7815
procedure TGLSceneBuffer.SaveAsFloatToFile(const aFilename: string);
7819
Stream: TMemoryStream;
7823
if Assigned(Camera) and Assigned(Camera.Scene) then
7825
DataSize := Width * Height * FloatSize * FloatSize;
7826
GetMem(Data, DataSize);
7827
FRenderingContext.Activate;
7829
GL.ReadPixels(0, 0, Width, Height, GL_RGBA, GL_FLOAT, Data);
7832
Stream := TMemoryStream.Create;
7834
Stream.Write(Data^, DataSize);
7835
Stream.SaveToFile(aFilename);
7840
FRenderingContext.DeActivate;
7849
procedure TGLSceneBuffer.SetViewPort(X, Y, W, H: Integer);
7864
function TGLSceneBuffer.Width: Integer;
7866
Result := FViewPort.Width;
7872
function TGLSceneBuffer.Height: Integer;
7874
Result := FViewPort.Height;
7880
procedure TGLSceneBuffer.Freeze;
7884
if RenderingContext = nil then
7888
RenderingContext.Activate;
7890
FFreezeBuffer := AllocMem(FViewPort.Width * FViewPort.Height * 4);
7891
GL.ReadPixels(0, 0, FViewport.Width, FViewPort.Height,
7892
GL_RGBA, GL_UNSIGNED_BYTE, FFreezeBuffer);
7893
FFreezedViewPort := FViewPort;
7895
RenderingContext.Deactivate;
7902
procedure TGLSceneBuffer.Melt;
7906
FreeMem(FFreezeBuffer);
7907
FFreezeBuffer := nil;
7914
procedure TGLSceneBuffer.RenderToBitmap(ABitmap: TGLBitmap; DPI: Integer);
7916
nativeContext: TGLContext;
7917
aColorBits: Integer;
7919
Assert((not FRendering), glsAlreadyRendering);
7921
nativeContext := RenderingContext;
7923
aColorBits := PixelFormatToColorBits(ABitmap.PixelFormat);
7924
if aColorBits < 8 then
7926
FRenderingContext := GLContextManager.CreateContext;
7927
SetupRCOptions(FRenderingContext);
7928
with FRenderingContext do
7930
Options := []; // no such things for bitmap rendering
7931
ColorBits := aColorBits; // honour Bitmap's pixel depth
7932
AntiAliasing := aaNone; // no AA for bitmap rendering
7933
CreateContext(ABitmap.Canvas.Handle);
7936
FRenderingContext.Activate;
7938
SetupRenderingContext(FRenderingContext);
7939
FRenderingContext.GLStates.ColorClearValue := ConvertWinColor(FBackgroundColor);
7940
// set the desired viewport and limit output to this rectangle
7945
Width := ABitmap.Width;
7946
Height := ABitmap.Height;
7947
FRenderingContext.GLStates.ViewPort :=
7948
Vector4iMake(Left, Top, Width, Height);
7952
if FRenderDPI = 0 then
7953
FRenderDPI := GetDeviceLogicalPixelsX(ABitmap.Canvas.Handle);
7955
DoBaseRender(FViewport, FRenderDPI, dsPrinting, nil);
7956
if nativeContext <> nil then
7957
FViewport := TRectangle(nativeContext.GLStates.ViewPort);
7960
FRenderingContext.Deactivate;
7963
FRenderingContext.Free;
7966
FRenderingContext := nativeContext;
7967
FRendering := False;
7969
if Assigned(FAfterRender) then
7970
if Owner is TComponent then
7971
if not (csDesigning in TComponent(Owner).ComponentState) then
7978
procedure TGLSceneBuffer.ShowInfo(Modal: boolean);
7980
if not Assigned(FRenderingContext) then
7982
// most info is available with active context only
7983
FRenderingContext.Activate;
7985
InvokeInfoForm(Self, Modal);
7987
FRenderingContext.Deactivate;
7991
// ResetPerformanceMonitor
7994
procedure TGLSceneBuffer.ResetPerformanceMonitor;
7996
FFramesPerSecond := 0;
7998
FFirstPerfCounter := 0;
8004
procedure TGLSceneBuffer.PushViewMatrix(const newMatrix: TMatrix);
8008
n := Length(FViewMatrixStack);
8009
SetLength(FViewMatrixStack, n + 1);
8010
FViewMatrixStack[n] := RenderingContext.PipelineTransformation.ViewMatrix;
8011
RenderingContext.PipelineTransformation.ViewMatrix := newMatrix;
8014
// PopModelViewMatrix
8017
procedure TGLSceneBuffer.PopViewMatrix;
8021
n := High(FViewMatrixStack);
8022
Assert(n >= 0, 'Unbalanced PopViewMatrix');
8023
RenderingContext.PipelineTransformation.ViewMatrix := FViewMatrixStack[n];
8024
SetLength(FViewMatrixStack, n);
8027
// PushProjectionMatrix
8030
procedure TGLSceneBuffer.PushProjectionMatrix(const newMatrix: TMatrix);
8034
n := Length(FProjectionMatrixStack);
8035
SetLength(FProjectionMatrixStack, n + 1);
8036
FProjectionMatrixStack[n] := RenderingContext.PipelineTransformation.ProjectionMatrix;
8037
RenderingContext.PipelineTransformation.ProjectionMatrix := newMatrix;
8040
// PopProjectionMatrix
8043
procedure TGLSceneBuffer.PopProjectionMatrix;
8047
n := High(FProjectionMatrixStack);
8048
Assert(n >= 0, 'Unbalanced PopProjectionMatrix');
8049
RenderingContext.PipelineTransformation.ProjectionMatrix := FProjectionMatrixStack[n];
8050
SetLength(FProjectionMatrixStack, n);
8053
function TGLSceneBuffer.ProjectionMatrix;
8055
Result := RenderingContext.PipelineTransformation.ProjectionMatrix;
8058
function TGLSceneBuffer.ViewMatrix: TMatrix;
8060
Result := RenderingContext.PipelineTransformation.ViewMatrix;
8063
function TGLSceneBuffer.ModelMatrix: TMatrix;
8065
Result := RenderingContext.PipelineTransformation.ModelMatrix;
8068
// OrthoScreenToWorld
8071
function TGLSceneBuffer.OrthoScreenToWorld(screenX, screenY: Integer):
8074
camPos, camUp, camRight: TAffineVector;
8077
if Assigned(FCamera) then
8079
SetVector(camPos, FCameraAbsolutePosition);
8080
if Camera.TargetObject <> nil then
8082
SetVector(camUp, FCamera.AbsoluteUpVectorToTarget);
8083
SetVector(camRight, FCamera.AbsoluteRightVectorToTarget);
8087
SetVector(camUp, Camera.AbsoluteUp);
8088
SetVector(camRight, Camera.AbsoluteRight);
8090
f := 100 * FCamera.NearPlaneBias / (FCamera.FocalLength *
8091
FCamera.SceneScale);
8092
if FViewPort.Width > FViewPort.Height then
8093
f := f / FViewPort.Width
8095
f := f / FViewPort.Height;
8097
VectorCombine3(camPos, camUp, camRight, 1,
8098
(screenY - (FViewPort.Height div 2)) * f,
8099
(screenX - (FViewPort.Width div 2)) * f));
8102
Result := NullVector;
8105
// ScreenToWorld (affine)
8108
function TGLSceneBuffer.ScreenToWorld(const aPoint: TAffineVector):
8113
if Assigned(FCamera)
8116
RenderingContext.PipelineTransformation.ViewProjectionMatrix,
8117
PHomogeneousIntVector(@FViewPort)^,
8119
Result := Vector3fMake(rslt)
8124
// ScreenToWorld (hmg)
8127
function TGLSceneBuffer.ScreenToWorld(const aPoint: TVector): TVector;
8129
MakePoint(Result, ScreenToWorld(AffineVectorMake(aPoint)));
8132
// ScreenToWorld (x, y)
8135
function TGLSceneBuffer.ScreenToWorld(screenX, screenY: Integer): TAffineVector;
8137
Result := ScreenToWorld(AffineVectorMake(screenX, FViewPort.Height - screenY,
8144
function TGLSceneBuffer.WorldToScreen(const aPoint: TAffineVector):
8149
RenderingContext.Activate;
8151
PrepareRenderingMatrices(FViewPort, FRenderDPI);
8152
if Assigned(FCamera)
8155
RenderingContext.PipelineTransformation.ViewProjectionMatrix,
8156
TVector4i(FViewPort),
8158
Result := Vector3fMake(rslt)
8162
RenderingContext.Deactivate;
8169
function TGLSceneBuffer.WorldToScreen(const aPoint: TVector): TVector;
8171
SetVector(Result, WorldToScreen(AffineVectorMake(aPoint)));
8177
procedure TGLSceneBuffer.WorldToScreen(points: PVector; nbPoints: Integer);
8181
if Assigned(FCamera) then
8183
for i := nbPoints - 1 downto 0 do
8185
Project(points^, RenderingContext.PipelineTransformation.ViewProjectionMatrix, PHomogeneousIntVector(@FViewPort)^, points^);
8191
// ScreenToVector (affine)
8194
function TGLSceneBuffer.ScreenToVector(const aPoint: TAffineVector):
8197
Result := VectorSubtract(ScreenToWorld(aPoint),
8198
PAffineVector(@FCameraAbsolutePosition)^);
8201
// ScreenToVector (hmg)
8204
function TGLSceneBuffer.ScreenToVector(const aPoint: TVector): TVector;
8206
SetVector(Result, VectorSubtract(ScreenToWorld(aPoint),
8207
FCameraAbsolutePosition));
8214
function TGLSceneBuffer.ScreenToVector(const x, y: Integer): TVector;
8221
SetVector(Result, ScreenToVector(av));
8227
function TGLSceneBuffer.VectorToScreen(const VectToCam: TAffineVector):
8230
Result := WorldToScreen(VectorAdd(VectToCam,
8231
PAffineVector(@FCameraAbsolutePosition)^));
8234
// ScreenVectorIntersectWithPlane
8237
function TGLSceneBuffer.ScreenVectorIntersectWithPlane(
8238
const aScreenPoint: TVector;
8239
const planePoint, planeNormal: TVector;
8240
var intersectPoint: TVector): Boolean;
8244
if Assigned(FCamera) then
8246
SetVector(v, ScreenToVector(aScreenPoint));
8247
Result := RayCastPlaneIntersect(FCameraAbsolutePosition,
8248
v, planePoint, planeNormal, @intersectPoint);
8249
intersectPoint.V[3] := 1;
8255
// ScreenVectorIntersectWithPlaneXY
8258
function TGLSceneBuffer.ScreenVectorIntersectWithPlaneXY(
8259
const aScreenPoint: TVector; const z: Single;
8260
var intersectPoint: TVector): Boolean;
8262
Result := ScreenVectorIntersectWithPlane(aScreenPoint, VectorMake(0, 0, z),
8263
ZHmgVector, intersectPoint);
8264
intersectPoint.V[3] := 0;
8267
// ScreenVectorIntersectWithPlaneYZ
8270
function TGLSceneBuffer.ScreenVectorIntersectWithPlaneYZ(
8271
const aScreenPoint: TVector; const x: Single;
8272
var intersectPoint: TVector): Boolean;
8274
Result := ScreenVectorIntersectWithPlane(aScreenPoint, VectorMake(x, 0, 0),
8275
XHmgVector, intersectPoint);
8276
intersectPoint.V[3] := 0;
8279
// ScreenVectorIntersectWithPlaneXZ
8282
function TGLSceneBuffer.ScreenVectorIntersectWithPlaneXZ(
8283
const aScreenPoint: TVector; const y: Single;
8284
var intersectPoint: TVector): Boolean;
8286
Result := ScreenVectorIntersectWithPlane(aScreenPoint, VectorMake(0, y, 0),
8287
YHmgVector, intersectPoint);
8288
intersectPoint.V[3] := 0;
8294
function TGLSceneBuffer.PixelRayToWorld(x, y: Integer): TAffineVector;
8296
dov, np, fp, z, dst, wrpdst: Single;
8297
vec, cam, targ, rayhit, pix: TAffineVector;
8300
if Camera.CameraStyle = csOrtho2D then
8303
dov := Camera.DepthOfView;
8304
np := Camera.NearPlane;
8305
fp := Camera.NearPlane + dov;
8306
z := GetPixelDepth(x, y);
8307
dst := (fp * np) / (fp - z * dov); //calc from z-buffer value to world depth
8308
//------------------------
8309
//z:=1-(fp/d-1)/(fp/np-1); //calc from world depth to z-buffer value
8310
//------------------------
8312
vec.V[1] := FViewPort.Height - y;
8314
vec := ScreenToVector(vec);
8315
NormalizeVector(vec);
8316
SetVector(cam, Camera.AbsolutePosition);
8317
//targ:=Camera.TargetObject.Position.AsAffineVector;
8318
//SubtractVector(targ,cam);
8319
pix.V[0] := FViewPort.Width * 0.5;
8320
pix.V[1] := FViewPort.Height * 0.5;
8322
targ := self.ScreenToVector(pix);
8324
camAng := VectorAngleCosine(targ, vec);
8325
wrpdst := dst / camAng;
8327
CombineVector(rayhit, vec, wrpdst);
8334
procedure TGLSceneBuffer.ClearBuffers;
8336
bufferBits: TGLBitfield;
8338
if roNoDepthBufferClear in ContextOptions then
8342
bufferBits := GL_DEPTH_BUFFER_BIT;
8343
CurrentGLContext.GLStates.DepthWriteMask := True;
8345
if ContextOptions * [roNoColorBuffer, roNoColorBufferClear] = [] then
8347
bufferBits := bufferBits or GL_COLOR_BUFFER_BIT;
8348
CurrentGLContext.GLStates.SetColorMask(cAllColorComponents);
8350
if roStencilBuffer in ContextOptions then
8352
bufferBits := bufferBits or GL_STENCIL_BUFFER_BIT;
8354
GL.Clear(BufferBits);
8360
procedure TGLSceneBuffer.NotifyChange(Sender: TObject);
8368
procedure TGLSceneBuffer.PickObjects(const rect: TGLRect; pickList: TGLPickList;
8369
objectCountGuess: Integer);
8372
obj: TGLBaseSceneObject;
8374
if not Assigned(FCamera) then
8376
Assert((not FRendering), glsAlreadyRendering);
8377
Assert(Assigned(PickList));
8378
FRenderingContext.Activate;
8381
// Create best selector which techniques is hardware can do
8382
if not Assigned(FSelector) then
8383
FSelector := GetBestSelectorClass.Create;
8385
xgl.MapTexCoordToNull; // turn off
8386
PrepareRenderingMatrices(FViewPort, RenderDPI, @Rect);
8387
FSelector.Hits := -1;
8388
if objectCountGuess > 0 then
8389
FSelector.ObjectCountGuess := objectCountGuess;
8392
// render the scene (in select mode, nothing is drawn)
8394
if Assigned(FCamera) and Assigned(FCamera.FScene) then
8395
RenderScene(FCamera.FScene, FViewPort.Width, FViewPort.Height,
8397
until FSelector.Stop;
8398
FSelector.FillPickingList(PickList);
8399
for I := 0 to PickList.Count-1 do
8401
obj := TGLBaseSceneObject(PickList[I]);
8402
if Assigned(obj.FOnPicked) then
8406
FRendering := False;
8407
FRenderingContext.Deactivate;
8414
function TGLSceneBuffer.GetPickedObjects(const rect: TGLRect; objectCountGuess:
8415
Integer = 64): TGLPickList;
8417
Result := TGLPickList.Create(psMinDepth);
8418
PickObjects(Rect, Result, objectCountGuess);
8424
function TGLSceneBuffer.GetPickedObject(x, y: Integer): TGLBaseSceneObject;
8426
pkList: TGLPickList;
8428
pkList := GetPickedObjects(Rect(x - 1, y - 1, x + 1, y + 1));
8430
if pkList.Count > 0 then
8431
Result := TGLBaseSceneObject(pkList.Hit[0])
8442
function TGLSceneBuffer.GetPixelColor(x, y: Integer): TColor;
8444
buf: array[0..2] of Byte;
8446
if not Assigned(FCamera) then
8451
FRenderingContext.Activate;
8453
GL.ReadPixels(x, FViewPort.Height - y, 1, 1, GL_RGB, GL_UNSIGNED_BYTE,
8456
FRenderingContext.Deactivate;
8458
Result := RGB(buf[0], buf[1], buf[2]);
8464
function TGLSceneBuffer.GetPixelDepth(x, y: Integer): Single;
8466
if not Assigned(FCamera) then
8471
FRenderingContext.Activate;
8473
GL.ReadPixels(x, FViewPort.Height - y, 1, 1, GL_DEPTH_COMPONENT, GL_FLOAT,
8476
FRenderingContext.Deactivate;
8480
// PixelDepthToDistance
8483
function TGLSceneBuffer.PixelDepthToDistance(aDepth: Single): Single;
8485
dov, np, fp: Single;
8487
if Camera.CameraStyle = csOrtho2D then
8490
dov := Camera.DepthOfView; // Depth of View (from np to fp)
8491
np := Camera.NearPlane; // Near plane distance
8492
fp := np + dov; // Far plane distance
8493
Result := (fp * np) / (fp - aDepth * dov);
8494
// calculate world distance from z-buffer value
8500
function TGLSceneBuffer.PixelToDistance(x, y: integer): Single;
8502
z, dov, np, fp, dst, camAng: Single;
8503
norm, coord, vec: TAffineVector;
8505
z := GetPixelDepth(x, y);
8506
if Camera.CameraStyle = csOrtho2D then
8509
dov := Camera.DepthOfView; // Depth of View (from np to fp)
8510
np := Camera.NearPlane; // Near plane distance
8511
fp := np + dov; // Far plane distance
8512
dst := (np * fp) / (fp - z * dov);
8513
//calculate from z-buffer value to frustrum depth
8516
vec := self.ScreenToVector(coord); //get the pixel vector
8517
coord.V[0] := FViewPort.Width div 2;
8518
coord.V[1] := FViewPort.Height div 2;
8519
norm := self.ScreenToVector(coord); //get the absolute camera direction
8520
camAng := VectorAngleCosine(norm, vec);
8521
Result := dst / camAng; //compensate for flat frustrum face
8527
procedure TGLSceneBuffer.NotifyMouseMove(Shift: TShiftState; X, Y: Integer);
8532
// PrepareRenderingMatrices
8535
procedure TGLSceneBuffer.PrepareRenderingMatrices(const aViewPort: TRectangle;
8536
resolution: Integer; pickingRect: PGLRect = nil);
8538
RenderingContext.PipelineTransformation.IdentityAll;
8539
// setup projection matrix
8540
if Assigned(pickingRect) then
8542
CurrentGLContext.PipelineTransformation.ProjectionMatrix := CreatePickMatrix(
8543
(pickingRect^.Left + pickingRect^.Right) div 2,
8544
FViewPort.Height - ((pickingRect^.Top + pickingRect^.Bottom) div 2),
8545
Abs(pickingRect^.Right - pickingRect^.Left),
8546
Abs(pickingRect^.Bottom - pickingRect^.Top),
8547
TVector4i(FViewport));
8549
FBaseProjectionMatrix := CurrentGLContext.PipelineTransformation.ProjectionMatrix;
8551
if Assigned(FCamera) then
8553
FCamera.Scene.FCurrentGLCamera := FCamera;
8554
// apply camera perpective
8555
FCamera.ApplyPerspective(
8560
// setup model view matrix
8561
// apply camera transformation (viewpoint)
8563
FCameraAbsolutePosition := FCamera.AbsolutePosition;
8570
procedure TGLSceneBuffer.DoBaseRender(const aViewPort: TRectangle; resolution:
8572
drawState: TDrawState; baseObject: TGLBaseSceneObject);
8574
with RenderingContext.GLStates do
8576
PrepareRenderingMatrices(aViewPort, resolution);
8577
if not ForwardContext then
8579
xgl.MapTexCoordToNull; // force XGL rebind
8580
xgl.MapTexCoordToMain;
8583
if Assigned(FViewerBeforeRender) and (drawState <> dsPrinting) then
8584
FViewerBeforeRender(Self);
8585
if Assigned(FBeforeRender) then
8586
if Owner is TComponent then
8587
if not (csDesigning in TComponent(Owner).ComponentState) then
8588
FBeforeRender(Self);
8590
if Assigned(FCamera) and Assigned(FCamera.FScene) then
8592
with FCamera.FScene do
8594
SetupLights(MaxLights);
8595
if not ForwardContext then
8600
FogEnvironment.ApplyFog;
8606
RenderScene(FCamera.FScene, aViewPort.Width, aViewPort.Height,
8611
if Assigned(FPostRender) then
8612
if Owner is TComponent then
8613
if not (csDesigning in TComponent(Owner).ComponentState) then
8616
Assert(Length(FViewMatrixStack) = 0,
8617
'Unbalance Push/PopViewMatrix.');
8618
Assert(Length(FProjectionMatrixStack) = 0,
8619
'Unbalance Push/PopProjectionMatrix.');
8625
procedure TGLSceneBuffer.Render;
8633
procedure TGLSceneBuffer.Render(baseObject: TGLBaseSceneObject);
8635
perfCounter, framePerf: Int64;
8639
if not Assigned(FRenderingContext) then
8642
if Freezed and (FFreezeBuffer <> nil) then
8644
RenderingContext.Activate;
8646
RenderingContext.GLStates.ColorClearValue :=
8647
ConvertWinColor(FBackgroundColor, FBackgroundAlpha);
8649
GL.MatrixMode(GL_PROJECTION);
8651
GL.MatrixMode(GL_MODELVIEW);
8653
GL.RasterPos2f(-1, -1);
8654
GL.DrawPixels(FFreezedViewPort.Width, FFreezedViewPort.Height,
8655
GL_RGBA, GL_UNSIGNED_BYTE, FFreezeBuffer);
8656
if not (roNoSwapBuffers in ContextOptions) then
8657
RenderingContext.SwapBuffers;
8659
RenderingContext.Deactivate;
8664
QueryPerformanceCounter(framePerf);
8666
if Assigned(FCamera) and Assigned(FCamera.FScene) then
8668
FCamera.AbsoluteMatrixAsAddress;
8669
FCamera.FScene.AddBuffer(Self);
8674
FRenderingContext.Activate;
8676
if FFrameCount = 0 then
8677
QueryPerformanceCounter(FFirstPerfCounter);
8679
FRenderDPI := 96; // default value for screen
8681
SetupRenderingContext(FRenderingContext);
8682
// clear the buffers
8683
FRenderingContext.GLStates.ColorClearValue :=
8684
ConvertWinColor(FBackgroundColor, FBackgroundAlpha);
8688
DoBaseRender(FViewport, RenderDPI, dsRendering, baseObject);
8690
if not (roNoSwapBuffers in ContextOptions) then
8691
RenderingContext.SwapBuffers;
8693
// yes, calculate average frames per second...
8695
QueryPerformanceCounter(perfCounter);
8696
FLastFrameTime := (perfCounter - framePerf) / vCounterFrequency;
8697
Dec(perfCounter, FFirstPerfCounter);
8698
if perfCounter > 0 then
8699
FFramesPerSecond := (FFrameCount * vCounterFrequency) / perfCounter;
8702
FRenderingContext.Deactivate;
8704
if Assigned(FAfterRender) and (Owner is TComponent) then
8705
if not (csDesigning in TComponent(Owner).ComponentState) then
8708
FRendering := False;
8715
procedure TGLSceneBuffer.RenderScene(aScene: TGLScene;
8716
const viewPortSizeX, viewPortSizeY: Integer;
8717
drawState: TDrawState;
8718
baseObject: TGLBaseSceneObject);
8722
rci: TGLRenderContextInfo;
8723
rightVector: TVector;
8725
FAfterRenderEffects.Clear;
8726
aScene.FCurrentBuffer := Self;
8727
FillChar(rci, SizeOf(rci), 0);
8728
rci.scene := aScene;
8730
rci.afterRenderEffects := FAfterRenderEffects;
8731
rci.objectsSorting := aScene.ObjectsSorting;
8732
rci.visibilityCulling := aScene.VisibilityCulling;
8733
rci.bufferFaceCull := FFaceCulling;
8734
rci.bufferLighting := FLighting;
8735
rci.bufferFog := FFogEnable;
8736
rci.bufferDepthTest := FDepthTest;
8737
rci.drawState := drawState;
8738
rci.sceneAmbientColor := FAmbientColor.Color;
8739
rci.primitiveMask := cAllMeshPrimitive;
8742
rci.cameraPosition := FCameraAbsolutePosition;
8743
rci.cameraDirection := FLastDirection;
8744
NormalizeVector(rci.cameraDirection);
8745
rci.cameraDirection.V[3] := 0;
8746
rightVector := VectorCrossProduct(rci.cameraDirection, Up.AsVector);
8747
rci.cameraUp := VectorCrossProduct(rightVector, rci.cameraDirection);
8748
NormalizeVector(rci.cameraUp);
8752
origin := rci.cameraPosition;
8753
clippingDirection := rci.cameraDirection;
8754
viewPortRadius := FViewPortRadius;
8755
nearClippingDistance := FNearPlane;
8756
farClippingDistance := FNearPlane + FDepthOfView;
8757
frustum := RenderingContext.PipelineTransformation.Frustum;
8760
rci.viewPortSize.cx := viewPortSizeX;
8761
rci.viewPortSize.cy := viewPortSizeY;
8762
rci.renderDPI := FRenderDPI;
8763
rci.GLStates := RenderingContext.GLStates;
8764
rci.PipelineTransformation := RenderingContext.PipelineTransformation;
8765
rci.proxySubObject := False;
8766
rci.ignoreMaterials := (roNoColorBuffer in FContextOptions)
8767
or (rci.drawState = dsPicking);
8768
rci.amalgamating := rci.drawState = dsPicking;
8769
rci.GLStates.SetGLColorWriting(not rci.ignoreMaterials);
8770
if Assigned(FInitiateRendering) then
8771
FInitiateRendering(Self, rci);
8773
if aScene.InitializableObjects.Count <> 0 then
8775
// First initialize all objects and delete them from the list.
8776
for I := aScene.InitializableObjects.Count - 1 downto 0 do
8778
aScene.InitializableObjects.Items[I].InitializeObject({Self?}aScene, rci);8779
aScene.InitializableObjects.Delete(I);
8783
if RenderingContext.IsPraparationNeed then
8784
RenderingContext.PrepareHandlesData;
8786
if baseObject = nil then
8788
aScene.Objects.Render(rci);
8791
baseObject.Render(rci);
8792
rci.GLStates.SetGLColorWriting(True);
8793
with FAfterRenderEffects do
8795
for i := 0 to Count - 1 do
8796
TGLObjectAfterEffect(Items[i]).Render(rci);
8797
if Assigned(FWrapUpRendering) then
8798
FWrapUpRendering(Self, rci);
8801
// SetBackgroundColor
8804
procedure TGLSceneBuffer.SetBackgroundColor(AColor: TColor);
8806
if FBackgroundColor <> AColor then
8808
FBackgroundColor := AColor;
8813
// SetBackgroundAlpha
8816
procedure TGLSceneBuffer.SetBackgroundAlpha(alpha: Single);
8818
if FBackgroundAlpha <> alpha then
8820
FBackgroundAlpha := alpha;
8828
procedure TGLSceneBuffer.SetAmbientColor(AColor: TGLColor);
8830
FAmbientColor.Assign(AColor);
8836
procedure TGLSceneBuffer.SetCamera(ACamera: TGLCamera);
8838
if FCamera <> ACamera then
8840
if Assigned(FCamera) then
8842
if Assigned(FCamera.FScene) then
8843
FCamera.FScene.RemoveBuffer(Self);
8846
if Assigned(ACamera) and Assigned(ACamera.FScene) then
8849
FCamera.TransformationChanged;
8858
procedure TGLSceneBuffer.SetContextOptions(Options: TContextOptions);
8860
if FContextOptions <> Options then
8862
FContextOptions := Options;
8870
procedure TGLSceneBuffer.SetDepthTest(AValue: Boolean);
8872
if FDepthTest <> AValue then
8874
FDepthTest := AValue;
8882
procedure TGLSceneBuffer.SetFaceCulling(AValue: Boolean);
8884
if FFaceCulling <> AValue then
8886
FFaceCulling := AValue;
8891
procedure TGLSceneBuffer.SetLayer(const Value: TGLContextLayer);
8893
if FLayer <> Value then
8900
procedure TGLSceneBuffer.SetLighting(aValue: Boolean);
8902
if FLighting <> aValue then
8904
FLighting := aValue;
8912
procedure TGLSceneBuffer.SetAntiAliasing(const val: TGLAntiAliasing);
8914
if FAntiAliasing <> val then
8916
FAntiAliasing := val;
8924
procedure TGLSceneBuffer.SetDepthPrecision(const val: TGLDepthPrecision);
8926
if FDepthPrecision <> val then
8928
FDepthPrecision := val;
8936
procedure TGLSceneBuffer.SetColorDepth(const val: TGLColorDepth);
8938
if FColorDepth <> val then
8948
procedure TGLSceneBuffer.SetShadeModel(const val: TGLShadeModel);
8950
if FShadeModel <> val then
8960
procedure TGLSceneBuffer.SetFogEnable(AValue: Boolean);
8962
if FFogEnable <> AValue then
8964
FFogEnable := AValue;
8969
// SetGLFogEnvironment
8972
procedure TGLSceneBuffer.SetGLFogEnvironment(AValue: TGLFogEnvironment);
8974
FFogEnvironment.Assign(AValue);
8981
function TGLSceneBuffer.StoreFog: Boolean;
8983
Result := (not FFogEnvironment.IsAtDefaultValues);
8986
// SetAccumBufferBits
8989
procedure TGLSceneBuffer.SetAccumBufferBits(const val: Integer);
8991
if FAccumBufferBits <> val then
8993
FAccumBufferBits := val;
9001
procedure TGLSceneBuffer.DoChange;
9003
if (not FRendering) and Assigned(FOnChange) then
9007
// DoStructuralChange
9010
procedure TGLSceneBuffer.DoStructuralChange;
9014
if Assigned(Owner) then
9015
bCall := not (csLoading in TComponent(GetOwner).ComponentState)
9018
if bCall and Assigned(FOnStructuralChange) then
9019
FOnStructuralChange(Self);
9022
// ------------------
9023
// ------------------ TGLNonVisualViewer ------------------
9024
// ------------------
9029
constructor TGLNonVisualViewer.Create(AOwner: TComponent);
9031
inherited Create(AOwner);
9034
FBuffer := TGLSceneBuffer.Create(Self);
9035
FBuffer.OnChange := DoBufferChange;
9036
FBuffer.OnStructuralChange := DoBufferStructuralChange;
9037
FBuffer.OnPrepareGLContext := DoOnPrepareGLContext;
9043
destructor TGLNonVisualViewer.Destroy;
9052
procedure TGLNonVisualViewer.Notification(AComponent: TComponent; Operation:
9055
if (Operation = opRemove) and (AComponent = Camera) then
9063
procedure TGLNonVisualViewer.CopyToTexture(aTexture: TGLTexture);
9065
CopyToTexture(aTexture, 0, 0, Width, Height, 0, 0);
9071
procedure TGLNonVisualViewer.CopyToTexture(aTexture: TGLTexture;
9072
xSrc, ySrc, width, height: Integer;
9073
xDest, yDest: Integer);
9075
Buffer.CopyToTexture(aTexture, xSrc, ySrc, width, height, xDest, yDest);
9081
procedure TGLNonVisualViewer.CopyToTextureMRT(aTexture: TGLTexture;
9082
BufferIndex: integer);
9084
CopyToTextureMRT(aTexture, 0, 0, Width, Height, 0, 0, BufferIndex);
9090
procedure TGLNonVisualViewer.CopyToTextureMRT(aTexture: TGLTexture; xSrc,
9091
ySrc, width, height, xDest, yDest, BufferIndex: integer);
9093
target, handle: Integer;
9095
createTexture: Boolean;
9097
procedure CreateNewTexture;
9099
GetMem(buf, Width * Height * 4);
9101
GL.ReadPixels(0, 0, Width, Height, GL_RGBA, GL_UNSIGNED_BYTE, buf);
9102
case aTexture.MinFilter of
9103
miNearest, miLinear:
9104
GL.TexImage2d(target, 0, aTexture.OpenGLTextureFormat, Width, Height,
9105
0, GL_RGBA, GL_UNSIGNED_BYTE, buf);
9107
if GL.SGIS_generate_mipmap and (target = GL_TEXTURE_2D) then
9109
// hardware-accelerated when supported
9110
GL.TexParameteri(target, GL_GENERATE_MIPMAP_SGIS, GL_TRUE);
9111
GL.TexImage2d(target, 0, aTexture.OpenGLTextureFormat, Width, Height,
9112
0, GL_RGBA, GL_UNSIGNED_BYTE, buf);
9116
GL.TexImage2d(target, 0, aTexture.OpenGLTextureFormat, Width, Height,
9117
0, GL_RGBA, GL_UNSIGNED_BYTE, buf);
9118
GL.GenerateMipmap(target);
9127
if Buffer.RenderingContext <> nil then
9129
Buffer.RenderingContext.Activate;
9131
target := DecodeGLTextureTarget(aTexture.Image.NativeTextureTarget);
9133
CreateTexture := true;
9135
if aTexture.IsFloatType then
9136
begin // float_type special treatment
9137
CreateTexture := false;
9138
handle := aTexture.Handle;
9140
else if (target <> GL_TEXTURE_CUBE_MAP_ARB) or (FCubeMapRotIdx = 0) then
9142
CreateTexture := not aTexture.IsHandleAllocated;
9143
if CreateTexture then
9144
handle := aTexture.AllocateHandle
9146
handle := aTexture.Handle;
9149
handle := aTexture.Handle;
9152
GL.ReadBuffer(MRT_BUFFERS[BufferIndex]);
9154
Buffer.RenderingContext.GLStates.TextureBinding[0,
9155
EncodeGLTextureTarget(target)] := handle;
9157
if target = GL_TEXTURE_CUBE_MAP_ARB then
9158
target := GL_TEXTURE_CUBE_MAP_POSITIVE_X_ARB + FCubeMapRotIdx;
9160
if CreateTexture then
9163
GL.CopyTexSubImage2D(target, 0, xDest, yDest, xSrc, ySrc, Width, Height);
9167
Buffer.RenderingContext.Deactivate;
9172
// SetupCubeMapCamera
9175
procedure TGLNonVisualViewer.SetupCubeMapCamera(Sender: TObject);
9178
cFaceMat: array[0..5] of TMatrix =
9180
(X: (X:0; Y:0; Z:-1; W:0);
9181
Y: (X:0; Y:-1; Z:0; W:0);
9182
Z: (X:-1; Y:0; Z:0; W:0);
9183
W: (X:0; Y:0; Z:0; W:1)),
9184
(X:(X:2.4335928828e-08; Y:0; Z:1; W:0);
9185
Y:(X:0; Y:-1; Z:0; W:0);
9186
Z:(X:1; Y:0; Z:-2.4335928828e-08; W:0);
9187
W:(X:0; Y:0; Z:0; W:1)),
9188
(X:(X:1; Y:1.2167964414e-08; Z:-1.4805936071e-16; W:0);
9189
Y:(X:0; Y:-1.2167964414e-08; Z:-1; W:0);
9190
Z:(X:-1.2167964414e-08; Y:1; Z:-1.2167964414e-08; W:0);
9191
W:(X:0; Y:0; Z:0; W:1)),
9192
(X:(X:1; Y:-1.2167964414e-08; Z:-1.4805936071e-16; W:0);
9193
Y:(X:0; Y:-1.2167964414e-08; Z:1; W:0);
9194
Z:(X:-1.2167964414e-08; Y:-1; Z:-1.2167964414e-08; W:0);
9195
W:(X:0; Y:0; Z:0; W:1)),
9196
(X:(X:1; Y:0; Z:-1.2167964414e-08; W:0);
9197
Y:(X:0; Y:-1; Z:0; W:0);
9198
Z:(X:-1.2167964414e-08; Y:0; Z:-1; W:0);
9199
W:(X:0; Y:0; Z:0; W:1)),
9200
(X:(X:-1; Y:0; Z:-1.2167964414e-08; W:0);
9201
Y:(X:0; Y:-1; Z:0; W:0);
9202
Z:(X:-1.2167964414e-08; Y:0; Z:1; W:0);
9203
W:(X:0; Y:0; Z:0; W:1))
9209
// Setup appropriate FOV
9210
with CurrentGLContext.PipelineTransformation do
9212
ProjectionMatrix := CreatePerspectiveMatrix(90, 1, FCubeMapZNear, FCubeMapZFar);
9213
TM := CreateTranslationMatrix(FCubeMapTranslation);
9214
ViewMatrix := MatrixMultiply(cFaceMat[FCubeMapRotIdx], TM);
9221
procedure TGLNonVisualViewer.RenderCubeMapTextures(cubeMapTexture: TGLTexture;
9225
oldEvent: TNotifyEvent;
9227
Assert((Width = Height), 'Memory Viewer must render to a square!');
9228
Assert(Assigned(FBuffer.FCamera), 'Camera not specified');
9229
Assert(Assigned(cubeMapTexture), 'Texture not specified');
9232
zFar := FBuffer.FCamera.DepthOfView;
9234
zNear := zFar * 0.001;
9236
oldEvent := FBuffer.FCamera.FDeferredApply;
9237
FBuffer.FCamera.FDeferredApply := SetupCubeMapCamera;
9238
FCubeMapZNear := zNear;
9239
FCubeMapZFar := zFar;
9240
VectorScale(FBuffer.FCamera.AbsolutePosition, -1, FCubeMapTranslation);
9242
FCubeMapRotIdx := 0;
9243
while FCubeMapRotIdx < 6 do
9246
Buffer.CopyToTexture(cubeMapTexture, 0, 0, Width, Height, 0, 0,
9247
GL_TEXTURE_CUBE_MAP_POSITIVE_X + FCubeMapRotIdx);
9248
Inc(FCubeMapRotIdx);
9251
FBuffer.FCamera.FDeferredApply := oldEvent;
9258
procedure TGLNonVisualViewer.SetBeforeRender(const val: TNotifyEvent);
9260
FBuffer.BeforeRender := val;
9266
function TGLNonVisualViewer.GetBeforeRender: TNotifyEvent;
9268
Result := FBuffer.BeforeRender;
9274
procedure TGLNonVisualViewer.SetPostRender(const val: TNotifyEvent);
9276
FBuffer.PostRender := val;
9282
function TGLNonVisualViewer.GetPostRender: TNotifyEvent;
9284
Result := FBuffer.PostRender;
9290
procedure TGLNonVisualViewer.SetAfterRender(const val: TNotifyEvent);
9292
FBuffer.AfterRender := val;
9298
function TGLNonVisualViewer.GetAfterRender: TNotifyEvent;
9300
Result := FBuffer.AfterRender;
9306
procedure TGLNonVisualViewer.SetCamera(const val: TGLCamera);
9308
FBuffer.Camera := val;
9314
function TGLNonVisualViewer.GetCamera: TGLCamera;
9316
Result := FBuffer.Camera;
9322
procedure TGLNonVisualViewer.SetBuffer(const val: TGLSceneBuffer);
9324
FBuffer.Assign(val);
9327
// DoOnPrepareGLContext
9330
procedure TGLNonVisualViewer.DoOnPrepareGLContext(sender: TObject);
9338
procedure TGLNonVisualViewer.PrepareGLContext;
9340
// nothing, reserved for subclasses
9346
procedure TGLNonVisualViewer.DoBufferChange(Sender: TObject);
9348
// nothing, reserved for subclasses
9351
// DoBufferStructuralChange
9354
procedure TGLNonVisualViewer.DoBufferStructuralChange(Sender: TObject);
9362
procedure TGLNonVisualViewer.SetWidth(const val: Integer);
9364
if val <> FWidth then
9369
DoBufferStructuralChange(Self);
9376
procedure TGLNonVisualViewer.SetHeight(const val: Integer);
9378
if val <> FHeight then
9383
DoBufferStructuralChange(Self);
9387
// ------------------
9388
// ------------------ TGLMemoryViewer ------------------
9389
// ------------------
9394
constructor TGLMemoryViewer.Create(AOwner: TComponent);
9396
inherited Create(AOwner);
9402
// InstantiateRenderingContext
9405
procedure TGLMemoryViewer.InstantiateRenderingContext;
9407
if FBuffer.RenderingContext = nil then
9409
FBuffer.SetViewPort(0, 0, Width, Height);
9410
FBuffer.CreateRC(HWND(0), True, FBufferCount);
9417
procedure TGLMemoryViewer.Render(baseObject: TGLBaseSceneObject = nil);
9419
InstantiateRenderingContext;
9420
FBuffer.Render(baseObject);
9426
procedure TGLMemoryViewer.SetBufferCount(const Value: integer);
9428
// MaxAxuBufCount : integer;
9430
MaxAxuBufCount = 4; // Current hardware limit = 4
9432
if FBufferCount = Value then
9434
FBufferCount := Value;
9436
if FBufferCount < 1 then
9439
if FBufferCount > MaxAxuBufCount then
9440
FBufferCount := MaxAxuBufCount;
9442
// Request a new Instantiation of RC on next render
9446
// ------------------
9447
// ------------------ TGLInitializableObjectList ------------------
9448
// ------------------
9453
function TGLInitializableObjectList.Add(const Item: IGLInitializable): Integer;
9455
Result := inherited Add(Pointer(Item));
9461
function TGLInitializableObjectList.GetItems(
9462
const Index: Integer): IGLInitializable;
9464
Result := IGLInitializable(inherited Get(Index));
9470
procedure TGLInitializableObjectList.PutItems(const Index: Integer;
9471
const Value: IGLInitializable);
9473
inherited Put(Index, Pointer(Value));
9476
//------------------------------------------------------------------------------
9477
//------------------------------------------------------------------------------
9478
//------------------------------------------------------------------------------
9480
//------------------------------------------------------------------------------
9481
//------------------------------------------------------------------------------
9482
//------------------------------------------------------------------------------
9484
RegisterClasses([TGLLightSource, TGLCamera, TGLProxyObject,
9485
TGLScene, TGLDirectOpenGL, TGLRenderPoint,
9488
// preparation for high resolution timer
9489
QueryPerformanceFrequency(vCounterFrequency);