// // The graphics engine GLScene // unit GLS.Scene; (* Base classes and structures. The registered classes are: [TGLScene, TGLLightSource, TGLCamera, TGLProxyObject, TGLRenderPoint, TGLMemoryViewer, TGLDirectOpenGL] *) interface {$I Stage.Defines.inc} uses Winapi.Windows, Winapi.OpenGL, Winapi.OpenGLext, System.Classes, System.SysUtils, System.UITypes, System.Math, Vcl.Graphics, Vcl.Controls, Stage.VectorTypes, Stage.VectorGeometry, Stage.OpenGLTokens, GLS.XCollection, Stage.Strings, Stage.PipelineTransform, Stage.TextureFormat, Stage.Utils, Stage.Logger, GLS.Context, GLS.Silhouette, GLS.PersistentClasses, GLS.State, GLS.Graphics, GLS.GeometryBB, GLS.VectorLists, GLS.Texture, GLS.Color, GLS.BaseClasses, GLS.Coordinates, GLS.RenderContextInfo, GLS.Material, GLS.XOpenGL, GLS.Selection, GLS.ApplicationFileIO, GLS.ImageUtils; type // Defines which features are taken from the master object. TGLProxyObjectOption = (pooEffects, pooObjects, pooTransformation); TGLProxyObjectOptions = set of TGLProxyObjectOption; TGLCameraInvarianceMode = (cimNone, cimPosition, cimOrientation); TGLSceneViewerMode = (svmDisabled, svmDefault, svmNavigation, svmGizmo); const cDefaultProxyOptions = [pooEffects, pooObjects, pooTransformation]; GLSCENE_REVISION = '$Revision: 2024$'; GLSCENE_VERSION = 'v2.5 %s'; type TGLNormalDirection = (ndInside, ndOutside); // Used to describe the changes in an object, which have to be reflected in the scene TGLObjectChange = (ocTransformation, ocAbsoluteMatrix, ocInvAbsoluteMatrix, ocStructure); TGLObjectChanges = set of TGLObjectChange; TGLObjectBBChange = (oBBcChild, oBBcStructure); TGLObjectBBChanges = set of TGLObjectBBChange; // Flags for design notification TGLSceneOperation = (soAdd, soRemove, soMove, soRename, soSelect, soBeginUpdate, soEndUpdate); (* Options for the rendering context. roSoftwareMode: force software rendering. roDoubleBuffer: enables double-buffering. roRenderToWindows: ignored (legacy). roTwoSideLighting: enables two-side lighting model. roStereo: enables stereo support in the driver (need to test with a stereo device...) roDestinationAlpha: request an Alpha channel for the rendered output roNoColorBuffer: don't request a color buffer (color depth setting ignored) roNoColorBufferClear: do not clear the color buffer automatically, if the whole viewer is fully repainted each frame, this can improve framerate roNoSwapBuffers: don't perform RenderingContext.SwapBuffers after rendering roNoDepthBufferClear: do not clear the depth buffer automatically. Useful for early-z culling. roForwardContext: force OpenGL forward context *) TGLContextOption = (roSoftwareMode, roDoubleBuffer, roStencilBuffer, roRenderToWindow, roTwoSideLighting, roStereo, roDestinationAlpha, roNoColorBuffer, roNoColorBufferClear, roNoSwapBuffers, roNoDepthBufferClear, roDebugContext, roForwardContext, roOpenGL_ES2_Context); TGLContextOptions = set of TGLContextOption; // IDs for limit determination TGLLimitType = (limClipPlanes, limEvalOrder, limLights, limListNesting, limModelViewStack, limNameStack, limPixelMapTable, limProjectionStack, limTextureSize, limTextureStack, limViewportDims, limAccumAlphaBits, limAccumBlueBits, limAccumGreenBits, limAccumRedBits, limAlphaBits, limAuxBuffers, limBlueBits, limGreenBits, limRedBits, limIndexBits, limStereo, limDoubleBuffer, limSubpixelBits, limDepthBits, limStencilBits, limNbTextureUnits); TGLBaseSceneObject = class; TGLSceneObjectClass = class of TGLBaseSceneObject; TGLCustomSceneObject = class; TGLScene = class; TGLBehaviour = class; TGLBehaviourClass = class of TGLBehaviour; TGLBehaviours = class; TGLEffect = class; TGLEffectClass = class of TGLEffect; TGLEffects = class; TGLSceneBuffer = class; (* Possible styles/options for a GLScene object. Allowed styles are: osDirectDraw : object shall not make use of compiled call lists, but issue direct calls each time a render should be performed. osIgnoreDepthBuffer : object is rendered with depth test disabled, this is true for its children too. osNoVisibilityCulling : whatever the VisibilityCulling setting, it will be ignored and the object rendered *) TGLObjectStyle = ( osDirectDraw, osIgnoreDepthBuffer, osNoVisibilityCulling); TGLObjectStyles = set of TGLObjectStyle; // Interface to objects that need initialization IGLInitializable = interface ['{EA40AE8E-79B3-42F5-ADF1-7A901B665E12}'] procedure InitializeObject(ASender: TObject; const ARci: TGLRenderContextInfo); end; // Just a list of objects that support IGLInitializable. TGLInitializableObjectList = class(TList) private function GetItems(const Index: Integer): IGLInitializable; procedure PutItems(const Index: Integer; const Value: IGLInitializable); public function Add(const Item: IGLInitializable): Integer; property Items[const Index: Integer]: IGLInitializable read GetItems write PutItems; default; end; (* Base class for all scene objects. A scene object is part of scene hierarchy (each scene object can have multiple children), this hierarchy primarily defines transformations (each child coordinates are relative to its parent), but is also used for depth-sorting, bounding and visibility culling purposes. Subclasses implement either visual scene objects (that are made to be visible at runtime, like a Cube) or structural objects (that influence rendering or are used for varied structural manipulations, like the ProxyObject). To add children at runtime, use the AddNewChild method of TGLBaseSceneObject; other children manipulations methods and properties are provided (to browse, move and delete them). Using the regular TComponent methods is not encouraged *) TGLBaseSceneObject = class(TGLCoordinatesUpdateAbleComponent) private FAbsoluteMatrix, FInvAbsoluteMatrix: TGLMatrix; FLocalMatrix: TGLMatrix; FObjectStyle: TGLObjectStyles; FListHandle: TGLListHandle; // created on 1st use FPosition: TGLCoordinates; FDirection, FUp: TGLCoordinates; FScaling: TGLCoordinates; FChanges: TGLObjectChanges; FParent: TGLBaseSceneObject; FScene: TGLScene; FBBChanges: TGLObjectBBChanges; FBoundingBoxPersonalUnscaled: THmgBoundingBox; FBoundingBoxOfChildren: THmgBoundingBox; FBoundingBoxIncludingChildren: THmgBoundingBox; FChildren: TGLPersistentObjectList; // created on 1st use FVisible: Boolean; FUpdateCount: Integer; FShowAxes: Boolean; FRotation: TGLCoordinates; // current rotation angles FIsCalculating: Boolean; FObjectsSorting: TGLObjectsSorting; FVisibilityCulling: TGLVisibilityCulling; FOnProgress: TGLProgressEvent; FOnAddedToParent: TNotifyEvent; FBehaviours: TGLBehaviours; FEffects: TGLEffects; FPickable: Boolean; FOnPicked: TNotifyEvent; FTagObject: TObject; FTagFloat: Single; objList: TGLPersistentObjectList; distList: TGLSingleList; /// FOriginalFiler: TFiler; //used to allow persistent events in behaviours & effects (* If somebody could look at DefineProperties, ReadBehaviours, ReadEffects and verify code is safe to use then it could be uncommented *) function Get(Index: Integer): TGLBaseSceneObject; inline; function GetCount: Integer; inline; function GetIndex: Integer; inline; procedure SetParent(const val: TGLBaseSceneObject); inline; procedure SetIndex(aValue: Integer); procedure SetDirection(AVector: TGLCoordinates); procedure SetUp(AVector: TGLCoordinates); function GetMatrix: PGLMatrix; inline; procedure SetPosition(APosition: TGLCoordinates); procedure SetPitchAngle(AValue: Single); procedure SetRollAngle(AValue: Single); procedure SetTurnAngle(AValue: Single); procedure SetRotation(aRotation: TGLCoordinates); function GetPitchAngle: Single; inline; function GetTurnAngle: Single; inline; function GetRollAngle: Single; inline; procedure SetShowAxes(AValue: Boolean); procedure SetScaling(AValue: TGLCoordinates); procedure SetObjectsSorting(const val: TGLObjectsSorting); procedure SetVisibilityCulling(const val: TGLVisibilityCulling); procedure SetBehaviours(const val: TGLBehaviours); function GetBehaviours: TGLBehaviours; procedure SetEffects(const val: TGLEffects); function GetEffects: TGLEffects; function GetAbsoluteAffineScale: TAffineVector; function GetAbsoluteScale: TGLVector; procedure SetAbsoluteAffineScale(const Value: TAffineVector); procedure SetAbsoluteScale(const Value: TGLVector); function GetAbsoluteMatrix: TGLMatrix; inline; procedure SetAbsoluteMatrix(const Value: TGLMatrix); procedure SetBBChanges(const Value: TGLObjectBBChanges); function GetDirectAbsoluteMatrix: PGLMatrix; function GetLocalMatrix: PGLMatrix; inline; protected procedure Loaded; override; procedure SetScene(const Value: TGLScene); virtual; procedure DefineProperties(Filer: TFiler); override; procedure WriteBehaviours(stream: TStream); procedure ReadBehaviours(stream: TStream); procedure WriteEffects(stream: TStream); procedure ReadEffects(stream: TStream); procedure WriteRotations(stream: TStream); procedure ReadRotations(stream: TStream); function GetVisible: Boolean; virtual; function GetPickable: Boolean; virtual; procedure SetVisible(aValue: Boolean); virtual; procedure SetPickable(aValue: Boolean); virtual; procedure SetAbsolutePosition(const v: TGLVector); function GetAbsolutePosition: TGLVector; inline; procedure SetAbsoluteUp(const v: TGLVector); function GetAbsoluteUp: TGLVector; procedure SetAbsoluteDirection(const v: TGLVector); function GetAbsoluteDirection: TGLVector; function GetAbsoluteAffinePosition: TAffineVector; procedure SetAbsoluteAffinePosition(const Value: TAffineVector); procedure SetAbsoluteAffineUp(const v: TAffineVector); function GetAbsoluteAffineUp: TAffineVector; procedure SetAbsoluteAffineDirection(const v: TAffineVector); function GetAbsoluteAffineDirection: TAffineVector; procedure RecTransformationChanged; inline; procedure DrawAxes(var rci: TGLRenderContextInfo; pattern: Word); procedure GetChildren(AProc: TGetChildProc; Root: TComponent); override; // Should the object be considered as blended for sorting purposes? function Blended: Boolean; virtual; procedure RebuildMatrix; procedure SetName(const NewName: TComponentName); override; procedure SetParentComponent(Value: TComponent); override; procedure DestroyHandle; virtual; procedure DestroyHandles; procedure DeleteChildCameras; procedure DoOnAddedToParent; virtual; (* Used to re-calculate BoundingBoxes every time we need it. GetLocalUnscaleBB() must return the local BB, not the axis-aligned one. By default it is calculated from AxisAlignedBoundingBoxUnscaled and BarycenterAbsolutePosition, but for most objects there is a more efficient method, that's why it is virtual. *) procedure CalculateBoundingBoxPersonalUnscaled(var ANewBoundingBox: THmgBoundingBox); virtual; public constructor Create(AOwner: TComponent); override; constructor CreateAsChild(aParentOwner: TGLBaseSceneObject); destructor Destroy; override; procedure Assign(Source: TPersistent); override; (* Controls and adjusts internal optimizations based on object's style. Advanced user only. *) property ObjectStyle: TGLObjectStyles read FObjectStyle write FObjectStyle; (* Returns the handle to the object's build list. Use with caution! Some objects don't support buildlists! *) function GetHandle(var rci: TGLRenderContextInfo): Cardinal; function ListHandleAllocated: Boolean; inline; (* The local transformation (relative to parent). If you're *sure* the local matrix is up-to-date, you may use LocalMatrix for quicker access. *) procedure SetMatrix(const aValue: TGLMatrix); inline; property Matrix: PGLMatrix read GetMatrix; (* Holds the local transformation (relative to parent). If you're not *sure* the local matrix is up-to-date, use Matrix property. *) property LocalMatrix: PGLMatrix read GetLocalMatrix; (* Forces the local matrix to the specified value. AbsoluteMatrix, InverseMatrix, etc. will honour that change, but may become invalid if the specified matrix isn't orthonormal (can be used for specific rendering or projection effects). The local matrix will be reset by the next TransformationChanged, position or attitude change. *) procedure ForceLocalMatrix(const aMatrix: TGLMatrix); inline; // See AbsoluteMatrix. function AbsoluteMatrixAsAddress: PGLMatrix; (* Holds the absolute transformation matrix. If you're not *sure* the absolute matrix is up-to-date, use the AbsoluteMatrix property, this one may be nil... *) property DirectAbsoluteMatrix: PGLMatrix read GetDirectAbsoluteMatrix; (* Calculates the object's absolute inverse matrix. Multiplying an absolute coordinate with this matrix gives a local coordinate. The current implem uses transposition(AbsoluteMatrix), which is true unless you're using some scaling... *) function InvAbsoluteMatrix: TGLMatrix; inline; //See InvAbsoluteMatrix. function InvAbsoluteMatrixAsAddress: PGLMatrix; (* The object's absolute matrix by composing all local matrices. Multiplying a local coordinate with this matrix gives an absolute coordinate. *) property AbsoluteMatrix: TGLMatrix read GetAbsoluteMatrix write SetAbsoluteMatrix; // Direction vector in absolute coordinates. property AbsoluteDirection: TGLVector read GetAbsoluteDirection write SetAbsoluteDirection; property AbsoluteAffineDirection: TAffineVector read GetAbsoluteAffineDirection write SetAbsoluteAffineDirection; (* Scale vector in absolute coordinates. Warning: SetAbsoluteScale() does not work correctly at the moment. *) property AbsoluteScale: TGLVector read GetAbsoluteScale write SetAbsoluteScale; property AbsoluteAffineScale: TAffineVector read GetAbsoluteAffineScale write SetAbsoluteAffineScale; // Up vector in absolute coordinates. property AbsoluteUp: TGLVector read GetAbsoluteUp write SetAbsoluteUp; property AbsoluteAffineUp: TAffineVector read GetAbsoluteAffineUp write SetAbsoluteAffineUp; // Calculate the right vector in absolute coordinates. function AbsoluteRight: TGLVector; // Calculate the left vector in absolute coordinates. function AbsoluteLeft: TGLVector; // Computes and allows to set the object's absolute coordinates. property AbsolutePosition: TGLVector read GetAbsolutePosition write SetAbsolutePosition; property AbsoluteAffinePosition: TAffineVector read GetAbsoluteAffinePosition write SetAbsoluteAffinePosition; function AbsolutePositionAsAddress: PGLVector; // Returns the Absolute X Vector expressed in local coordinates. function AbsoluteXVector: TGLVector; // Returns the Absolute Y Vector expressed in local coordinates. function AbsoluteYVector: TGLVector; // Returns the Absolute Z Vector expressed in local coordinates. function AbsoluteZVector: TGLVector; // Converts a vector/point from absolute coordinates to local coordinates. function AbsoluteToLocal(const v: TGLVector): TGLVector; overload; // Converts a vector from absolute coordinates to local coordinates. function AbsoluteToLocal(const v: TAffineVector): TAffineVector; overload; // Converts a vector/point from local coordinates to absolute coordinates. function LocalToAbsolute(const v: TGLVector): TGLVector; overload; // Converts a vector from local coordinates to absolute coordinates. function LocalToAbsolute(const v: TAffineVector): TAffineVector; overload; // Returns the Right vector (based on Up and Direction) function Right: TGLVector; inline; // Returns the Left vector (based on Up and Direction) function LeftVector: TGLVector; inline; // Returns the Right vector (based on Up and Direction) function AffineRight: TAffineVector; inline; // Returns the Left vector (based on Up and Direction) function AffineLeftVector: TAffineVector; inline; (* Calculates the object's square distance to a point/object. pt is assumed to be in absolute coordinates, AbsolutePosition is considered as being the object position. *) function SqrDistanceTo(anObject: TGLBaseSceneObject): Single; overload; function SqrDistanceTo(const pt: TGLVector): Single; overload; function SqrDistanceTo(const pt: TAffineVector): Single; overload; (* Computes the object's distance to a point/object. Only objects AbsolutePositions are considered. *) function DistanceTo(anObject: TGLBaseSceneObject): Single; overload; function DistanceTo(const pt: TAffineVector): Single; overload; function DistanceTo(const pt: TGLVector): Single; overload; (* Calculates the object's barycenter in absolute coordinates. Default behaviour is to consider Barycenter=AbsolutePosition (whatever the number of children). SubClasses where AbsolutePosition is not the barycenter should override this method as it is used for distance calculation, during rendering for instance, and may lead to visual inconsistencies. *) function BarycenterAbsolutePosition: TGLVector; virtual; // Calculates the object's barycenter distance to a point. function BarycenterSqrDistanceTo(const pt: TGLVector): Single; (* Shall returns the object's axis aligned extensions. The dimensions are measured from object center and are expressed with scale accounted for, in the object's coordinates (not in absolute ones). Default value is half the object's Scale. *) function AxisAlignedDimensions: TGLVector; virtual; function AxisAlignedDimensionsUnscaled: TGLVector; virtual; (* Calculates and return the AABB for the object. The AABB is currently calculated from the BB. There is no caching scheme for them. *) function AxisAlignedBoundingBox(const AIncludeChilden: Boolean = True): TAABB; function AxisAlignedBoundingBoxUnscaled(const AIncludeChilden: Boolean = True): TAABB; function AxisAlignedBoundingBoxAbsolute(const AIncludeChilden: Boolean = True; const AUseBaryCenter: Boolean = False): TAABB; (* Advanced AABB functions that use a caching scheme. Also they include children and use BaryCenter. *) function AxisAlignedBoundingBoxEx: TAABB; function AxisAlignedBoundingBoxAbsoluteEx: TAABB; (* Calculates and return the Bounding Box for the object. The BB is calculated each time this method is invoked, based on the AxisAlignedDimensions of the object and that of its children. There is no caching scheme for them. *) function BoundingBox(const AIncludeChilden: Boolean = True; const AUseBaryCenter: Boolean = False): THmgBoundingBox; function BoundingBoxUnscaled(const AIncludeChilden: Boolean = True; const AUseBaryCenter: Boolean = False): THmgBoundingBox; function BoundingBoxAbsolute(const AIncludeChilden: Boolean = True; const AUseBaryCenter: Boolean = False): THmgBoundingBox; (* Advanced BB functions that use a caching scheme. Also they include children and use BaryCenter. *) function BoundingBoxPersonalUnscaledEx: THmgBoundingBox; function BoundingBoxOfChildrenEx: THmgBoundingBox; function BoundingBoxIncludingChildrenEx: THmgBoundingBox; // Max distance of corners of the BoundingBox. function BoundingSphereRadius: Single; inline; function BoundingSphereRadiusUnscaled: Single; inline; (* Indicates if a point is within an object. Given coordinate is an absolute coordinate. Linear or surfacic objects shall always return False. Default value is based on AxisAlignedDimension and a cube bounding. *) function PointInObject(const point: TGLVector): Boolean; virtual; (* Request to determine an intersection with a casted ray. Given coordinates & vector are in absolute coordinates, rayVector must be normalized. rayStart may be a point inside the object, allowing retrieval of the multiple intersects of the ray. When intersectXXX parameters are nil (default) implementation should take advantage of this to optimize calculus, if not, and an intersect is found, non nil parameters should be defined. The intersectNormal needs NOT be normalized by the implementations. Default value is based on bounding sphere. *) function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; virtual; (* Request to generate silhouette outlines. Default implementation assumes the objects is a sphere of AxisAlignedDimensionUnscaled size. Subclasses may choose to return nil instead, which will be understood as an empty silhouette. *) function GenerateSilhouette(const silhouetteParameters: TGLSilhouetteParameters): TGLSilhouette; virtual; property Children[Index: Integer]: TGLBaseSceneObject read Get; default; property Count: Integer read GetCount; property Index: Integer read GetIndex write SetIndex; // Creates a new scene object and add it to this object as new child function AddNewChild(aChild: TGLSceneObjectClass): TGLBaseSceneObject; virtual; // Creates a new scene object and add it to this object as first child function AddNewChildFirst(aChild: TGLSceneObjectClass): TGLBaseSceneObject; virtual; procedure AddChild(aChild: TGLBaseSceneObject); virtual; function GetOrCreateBehaviour(aBehaviour: TGLBehaviourClass): TGLBehaviour; function AddNewBehaviour(aBehaviour: TGLBehaviourClass): TGLBehaviour; function GetOrCreateEffect(aEffect: TGLEffectClass): TGLEffect; function AddNewEffect(aEffect: TGLEffectClass): TGLEffect; function HasSubChildren: Boolean; procedure DeleteChildren; virtual; procedure Insert(aIndex: Integer; aChild: TGLBaseSceneObject); virtual; (* Takes a scene object out of the child list, but doesn't destroy it. If 'KeepChildren' is true its children will be kept as new children in this scene object. *) procedure Remove(aChild: TGLBaseSceneObject; keepChildren: Boolean); virtual; function IndexOfChild(aChild: TGLBaseSceneObject): Integer; function FindChild(const aName: string; ownChildrenOnly: Boolean): TGLBaseSceneObject; (* The "safe" version of this procedure checks if indexes are inside the list. If not, no exception if raised. *) procedure ExchangeChildrenSafe(anIndex1, anIndex2: Integer); (* The "regular" version of this procedure does not perform any checks and calls FChildren.Exchange directly. User should/can perform range checks manualy. *) procedure ExchangeChildren(anIndex1, anIndex2: Integer); //These procedures are safe. procedure MoveChildUp(anIndex: Integer); procedure MoveChildDown(anIndex: Integer); procedure MoveChildFirst(anIndex: Integer); procedure MoveChildLast(anIndex: Integer); procedure DoProgress(const progressTime: TGLProgressTimes); override; procedure MoveTo(newParent: TGLBaseSceneObject); virtual; procedure MoveUp; procedure MoveDown; procedure MoveFirst; procedure MoveLast; procedure BeginUpdate; inline; procedure EndUpdate; inline; (* Make object-specific geometry description here. Subclasses should MAINTAIN OpenGL states (restore the states if they were altered). *) procedure BuildList(var rci: TGLRenderContextInfo); virtual; function GetParentComponent: TComponent; override; function HasParent: Boolean; override; final; function IsUpdating: Boolean; inline; // Moves the object along the Up vector (move up/down) procedure Lift(ADistance: Single); // Moves the object along the direction vector procedure Move(ADistance: Single); // Translates the object procedure Translate(tx, ty, tz: Single); procedure MoveObjectAround(anObject: TGLBaseSceneObject; pitchDelta, turnDelta: Single); procedure MoveObjectAllAround(anObject: TGLBaseSceneObject; pitchDelta, turnDelta: Single); procedure Pitch(angle: Single); procedure Roll(angle: Single); procedure Turn(angle: Single); (* Sets all rotations to zero and restores default Direction/Up. Using this function then applying roll/pitch/turn in the order that suits you, you can give an "absolute" meaning to rotation angles (they are still applied locally though). Scale and Position are not affected. *) procedure ResetRotations; //Reset rotations and applies them back in the specified order. procedure ResetAndPitchTurnRoll(const degX, degY, degZ: Single); //Applies rotations around absolute X, Y and Z axis. procedure RotateAbsolute(const rx, ry, rz: Single); overload; //Applies rotations around the absolute given vector (angle in degrees). procedure RotateAbsolute(const axis: TAffineVector; angle: Single); overload; // Moves camera along the right vector (move left and right) procedure Slide(ADistance: Single); // Orients the object toward a target object procedure PointTo(const ATargetObject: TGLBaseSceneObject; const AUpVector: TGLVector); overload; // Orients the object toward a target absolute position procedure PointTo(const AAbsolutePosition, AUpVector: TGLVector); overload; procedure Render(var ARci: TGLRenderContextInfo); procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); virtual; procedure RenderChildren(firstChildIndex, lastChildIndex: Integer; var rci: TGLRenderContextInfo); procedure StructureChanged; virtual; procedure ClearStructureChanged; inline; // Recalculate an orthonormal system procedure CoordinateChanged(Sender: TGLCustomCoordinates); override; procedure TransformationChanged; inline; procedure NotifyChange(Sender: TObject); override; property Rotation: TGLCoordinates read FRotation write SetRotation; property PitchAngle: Single read GetPitchAngle write SetPitchAngle; property RollAngle: Single read GetRollAngle write SetRollAngle; property TurnAngle: Single read GetTurnAngle write SetTurnAngle; property ShowAxes: Boolean read FShowAxes write SetShowAxes default False; property Changes: TGLObjectChanges read FChanges; property BBChanges: TGLObjectBBChanges read fBBChanges write SetBBChanges; property Parent: TGLBaseSceneObject read FParent write SetParent; property Position: TGLCoordinates read FPosition write SetPosition; property Direction: TGLCoordinates read FDirection write SetDirection; property Up: TGLCoordinates read FUp write SetUp; property Scale: TGLCoordinates read FScaling write SetScaling; property Scene: TGLScene read FScene; // Scene property Visible: Boolean read FVisible write SetVisible default True; property Pickable: Boolean read FPickable write SetPickable default True; property ObjectsSorting: TGLObjectsSorting read FObjectsSorting write SetObjectsSorting default osInherited; property VisibilityCulling: TGLVisibilityCulling read FVisibilityCulling write SetVisibilityCulling default vcInherited; property OnProgress: TGLProgressEvent read FOnProgress write FOnProgress; property OnPicked: TNotifyEvent read FOnPicked write FOnPicked; property OnAddedToParent: TNotifyEvent read FOnAddedToParent write FOnAddedToParent; property Behaviours: TGLBehaviours read GetBehaviours write SetBehaviours stored False; property Effects: TGLEffects read GetEffects write SetEffects stored False; property TagObject: TObject read FTagObject write FTagObject; published property TagFloat: Single read FTagFloat write FTagFloat; end; (* Base class for implementing behaviours in TGLScene. Behaviours are regrouped in a collection attached to a TGLBaseSceneObject, and are part of the "Progress" chain of events. Behaviours allows clean application of time-based alterations to objects (movements, shape or texture changes...). Since behaviours are implemented as classes, there are basicly two kinds of strategies for subclasses : stand-alone : the subclass does it all, and holds all necessary data (covers animation, inertia etc.) proxy : the subclass is an interface to and external, shared operator (like gravity, force-field effects etc.) Some behaviours may be cooperative (like force-fields affects inertia) or unique (e.g. only one inertia behaviour per object). NOTES : Don't forget to override the ReadFromFiler/WriteToFiler persistence methods if you add data in a subclass ! Subclasses must be registered using the RegisterXCollectionItemClass function *) TGLBaseBehaviour = class(TXCollectionItem) protected procedure SetName(const val: string); override; // Override this function to write subclass data. procedure WriteToFiler(writer: TWriter); override; // Override this function to read subclass data. procedure ReadFromFiler(reader: TReader); override; (* Returns the TGLBaseSceneObject on which the behaviour should be applied. Does NOT check for nil owners. *) function OwnerBaseSceneObject: TGLBaseSceneObject; public constructor Create(aOwner: TXCollection); override; destructor Destroy; override; procedure DoProgress(const progressTime: TGLProgressTimes); virtual; end; (* Ancestor for non-rendering behaviours. This class shall never receive any properties, it's just here to differentiate rendereing and non-rendering behaviours. Rendereing behaviours are named "TGLEffect", non-rendering effects (like inertia) are simply named "TGLBehaviour". *) TGLBehaviour = class(TGLBaseBehaviour) end; (* Holds a list of TGLBehaviour objects. This object expects itself to be owned by a TGLBaseSceneObject. As a TXCollection (and contrary to a TCollection), this list can contain objects of varying class, the only constraint being that they should all be TGLBehaviour subclasses. *) TGLBehaviours = class(TXCollection) protected function GetBehaviour(index: Integer): TGLBehaviour; public constructor Create(aOwner: TPersistent); override; function GetNamePath: string; override; class function ItemsClass: TXCollectionItemClass; override; property Behaviour[index: Integer]: TGLBehaviour read GetBehaviour; default; function CanAdd(aClass: TXCollectionItemClass): Boolean; override; procedure DoProgress(const progressTimes: TGLProgressTimes); inline; end; (* A rendering effect that can be applied to SceneObjects. ObjectEffect is a subclass of behaviour that gets a chance to Render an object-related special effect. TGLEffect should not be used as base class for custom effects, instead you should use the following base classes : TGLObjectPreEffect is rendered before owner object render TGLObjectPostEffect is rendered after the owner object render TGLObjectAfterEffect is rendered at the end of the scene rendering NOTES : Don't forget to override the ReadFromFiler/WriteToFiler persistence methods if you add data in a subclass ! Subclasses must be registered using the RegisterXCollectionItemClass function *) TGLEffect = class(TGLBaseBehaviour) protected // Override this function to write subclass data. procedure WriteToFiler(writer: TWriter); override; // Override this function to read subclass data. procedure ReadFromFiler(reader: TReader); override; public procedure Render(var rci: TGLRenderContextInfo); virtual; end; (* An object effect that gets rendered before owner object's render. The current OpenGL matrices and material are that of the owner object. *) TGLObjectPreEffect = class(TGLEffect) end; (*An object effect that gets rendered after owner object's render. The current OpenGL matrices and material are that of the owner object. *) TGLObjectPostEffect = class(TGLEffect) end; (*An object effect that gets rendered at scene's end. No particular OpenGL matrices or material should be assumed. *) TGLObjectAfterEffect = class(TGLEffect) end; (*Holds a list of object effects. This object expects itself to be owned by a TGLBaseSceneObject. *) TGLEffects = class(TXCollection) protected function GetEffect(index: Integer): TGLEffect; public constructor Create(aOwner: TPersistent); override; function GetNamePath: string; override; class function ItemsClass: TXCollectionItemClass; override; property ObjectEffect[index: Integer]: TGLEffect read GetEffect; default; function CanAdd(aClass: TXCollectionItemClass): Boolean; override; procedure DoProgress(const progressTime: TGLProgressTimes); procedure RenderPreEffects(var rci: TGLRenderContextInfo); inline; //Also take care of registering after effects with the GLSceneViewer. procedure RenderPostEffects(var rci: TGLRenderContextInfo); inline; end; (*Extended base scene object class with a material property. The material allows defining a color and texture for the object, see TGLMaterial *) TGLCustomSceneObject = class(TGLBaseSceneObject) private FMaterial: TGLMaterial; FHint: string; protected function Blended: Boolean; override; procedure SetGLMaterial(AValue: TGLMaterial); inline; procedure DestroyHandle; override; procedure Loaded; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); override; property Material: TGLMaterial read FMaterial write SetGLMaterial; property Hint: string read FHint write FHint; end; (* This class shall be used only as a hierarchy root. It exists only as a container and shall never be rotated/scaled etc. as the class type is used in parenting optimizations. Shall never implement or add any functionality, the "Create" override only take cares of disabling the build list. *) TGLSceneRootObject = class(TGLBaseSceneObject) public constructor Create(AOwner: TComponent); override; end; (*Base class for objects that do not have a published "material". Note that the material is available in public properties, but isn't applied automatically before invoking BuildList. Subclassing should be reserved to structural objects and objects that have no material of their own. *) TGLImmaterialSceneObject = class(TGLCustomSceneObject) public procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); override; published property ObjectsSorting; property VisibilityCulling; property Direction; property PitchAngle; property Position; property RollAngle; property Scale; property ShowAxes; property TurnAngle; property Up; property Visible; property Pickable; property OnProgress; property OnPicked; property Behaviours; property Effects; property Hint; end; (* Base class for camera invariant objects. Camera invariant objects bypass camera settings, such as camera position (object is always centered on camera) or camera orientation (object always has same orientation as camera). *) TGLCameraInvariantObject = class(TGLImmaterialSceneObject) private FCamInvarianceMode: TGLCameraInvarianceMode; protected procedure SetCamInvarianceMode(const val: TGLCameraInvarianceMode); property CamInvarianceMode: TGLCameraInvarianceMode read FCamInvarianceMode write SetCamInvarianceMode; public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); override; end; // Base class for standard scene objects. Publishes the Material property. TGLSceneObject = class(TGLCustomSceneObject) published property Material; property ObjectsSorting; property VisibilityCulling; property Direction; property PitchAngle; property Position; property RollAngle; property Scale; property ShowAxes; property TurnAngle; property Up; property Visible; property Pickable; property OnProgress; property OnPicked; property Behaviours; property Effects; property Hint; end; // Event for user-specific rendering in a TGLDirectOpenGL object. TGLDirectRenderEvent = procedure(Sender: TObject; var rci: TGLRenderContextInfo) of object; (* Provides a way to issue direct OpenGL calls during the rendering. You can use this object to do your specific rendering task in its OnRender event. The OpenGL calls shall restore the OpenGL states they found when entering, or exclusively use the GLMisc utility functions to alter the states. *) TGLDirectOpenGL = class(TGLImmaterialSceneObject) private FUseBuildList: Boolean; FOnRender: TGLDirectRenderEvent; FBlend: Boolean; protected procedure SetUseBuildList(const val: Boolean); function Blended: Boolean; override; procedure SetBlend(const val: Boolean); public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; function AxisAlignedDimensionsUnscaled: TGLVector; override; published (* Specifies if a build list be made. If True, GLScene will generate a build list (side cache), ie. OnRender will only be invoked once for the first render, or after a StructureChanged call. This is suitable for "static" geometry and will usually speed up rendering of things that don't change. If false, OnRender will be invoked for each render. This is suitable for dynamic geometry (things that change often or constantly). *) property UseBuildList: Boolean read FUseBuildList write SetUseBuildList; (* Place your specific OpenGL code here. The OpenGL calls shall restore the OpenGL states they found when entering, or exclusively use the GLMisc utility functions to alter the states. *) property OnRender: TGLDirectRenderEvent read FOnRender write FOnRender; (* Defines if the object uses blending. This property will allow direct opengl objects to be flagged as blended for object sorting purposes. *) property Blend: Boolean read FBlend write SetBlend; end; (* Scene object that allows other objects to issue rendering at some point. This object is used to specify a render point for which other components have (rendering) tasks to perform. It doesn't render anything itself and is invisible, but other components can register and be notified when the point is reached in the rendering phase. Callbacks must be explicitly unregistered. *) TGLRenderPoint = class(TGLImmaterialSceneObject) private FCallBacks: array of TGLDirectRenderEvent; FFreeCallBacks: array of TNotifyEvent; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure BuildList(var rci: TGLRenderContextInfo); override; procedure RegisterCallBack(renderEvent: TGLDirectRenderEvent; renderPointFreed: TNotifyEvent); procedure UnRegisterCallBack(renderEvent: TGLDirectRenderEvent); procedure Clear; end; (* A full proxy object. This object literally uses another object's Render method to do its own rendering, however, it has a coordinate system and a life of its own. Use it for duplicates of an object. *) TGLProxyObject = class(TGLBaseSceneObject) private FMasterObject: TGLBaseSceneObject; FProxyOptions: TGLProxyObjectOptions; protected FRendering: Boolean; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure SetMasterObject(const val: TGLBaseSceneObject); virtual; procedure SetProxyOptions(const val: TGLProxyObjectOptions); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); override; function BarycenterAbsolutePosition: TGLVector; override; function AxisAlignedDimensions: TGLVector; override; function AxisAlignedDimensionsUnscaled: TGLVector; override; function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; override; function GenerateSilhouette(const silhouetteParameters: TGLSilhouetteParameters): TGLSilhouette; override; published // Specifies the Master object which will be proxy'ed. property MasterObject: TGLBaseSceneObject read FMasterObject write SetMasterObject; // Specifies how and what is proxy'ed. property ProxyOptions: TGLProxyObjectOptions read FProxyOptions write SetProxyOptions default cDefaultProxyOptions; property ObjectsSorting; property Direction; property PitchAngle; property Position; property RollAngle; property Scale; property ShowAxes; property TurnAngle; property Up; property Visible; property Pickable; property OnProgress; property OnPicked; property Behaviours; end; TGLProxyObjectClass = class of TGLProxyObject; (* Defines the various styles for lightsources. lsSpot : a spot light, oriented and with a cutoff zone (note that if cutoff is 180, the spot is rendered as an omni source) lsOmni : an omnidirectionnal source, punctual and sending light in all directions uniformously lsParallel : a parallel light, oriented as the light source is (this type of light can help speed up rendering) *) TGLLightStyle = (lsSpot, lsOmni, lsParallel, lsParallelSpot); (* Standard light source. The standard GLScene light source covers spotlights, omnidirectionnal and parallel sources (see TLightStyle). Lights are colored, have distance attenuation parameters and are turned on/off through their Shining property. Lightsources are managed in a specific object by the TGLScene for rendering purposes. The maximum number of light source in a scene is limited by the OpenGL implementation (8 lights are supported under most ICDs), though the more light you use, the slower rendering may get. If you want to render many more light/lightsource, you may have to resort to other techniques like lightmapping. *) TGLLightSource = class(TGLBaseSceneObject) private FLightID: Cardinal; FSpotDirection: TGLCoordinates; FSpotExponent, FSpotCutOff: Single; FConstAttenuation, FLinearAttenuation, FQuadraticAttenuation: Single; FShining: Boolean; FAmbient, FDiffuse, FSpecular: TGLColor; FLightStyle: TGLLightStyle; protected procedure SetAmbient(AValue: TGLColor); procedure SetDiffuse(AValue: TGLColor); procedure SetSpecular(AValue: TGLColor); procedure SetConstAttenuation(AValue: Single); procedure SetLinearAttenuation(AValue: Single); procedure SetQuadraticAttenuation(AValue: Single); procedure SetShining(AValue: Boolean); procedure SetSpotDirection(AVector: TGLCoordinates); procedure SetSpotExponent(AValue: Single); procedure SetSpotCutOff(const val: Single); procedure SetLightStyle(const val: TGLLightStyle); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); override; // light sources have different handle types than normal scene objects function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; override; procedure CoordinateChanged(Sender: TGLCustomCoordinates); override; function GenerateSilhouette(const silhouetteParameters: TGLSilhouetteParameters): TGLSilhouette; override; property LightID: Cardinal read FLightID; function Attenuated: Boolean; published property Ambient: TGLColor read FAmbient write SetAmbient; property ConstAttenuation: Single read FConstAttenuation write SetConstAttenuation; property Diffuse: TGLColor read FDiffuse write SetDiffuse; property LinearAttenuation: Single read FLinearAttenuation write SetLinearAttenuation; property QuadraticAttenuation: Single read FQuadraticAttenuation write SetQuadraticAttenuation; property Position; property LightStyle: TGLLightStyle read FLightStyle write SetLightStyle default lsSpot; property Shining: Boolean read FShining write SetShining default True; property Specular: TGLColor read FSpecular write SetSpecular; property SpotCutOff: Single read FSpotCutOff write SetSpotCutOff; property SpotDirection: TGLCoordinates read FSpotDirection write SetSpotDirection; property SpotExponent: Single read FSpotExponent write SetSpotExponent; property OnProgress; end; TGLCameraStyle = (csPerspective, csOrthogonal, csOrtho2D, csCustom, csInfinitePerspective, csPerspectiveKeepFOV); TGLCameraKeepFOVMode = (ckmHorizontalFOV, ckmVerticalFOV); TOnCustomPerspective = procedure(const viewport: TRectangle; width, height: Integer; DPI: Integer; var viewPortRadius: Single) of object; (* Camera object. This object is commonly referred by TGLSceneViewer and defines a position, direction, focal length, depth of view... all the properties needed for defining a point of view and optical characteristics. *) TGLCamera = class(TGLBaseSceneObject) private FFocalLength: Single; FDepthOfView: Single; FNearPlane: Single; // nearest distance to the camera FNearPlaneBias: Single; // scaling bias applied to near plane FViewPortRadius: Single; // viewport bounding radius per distance unit FTargetObject: TGLBaseSceneObject; FLastDirection: TGLVector; // Not persistent FCameraStyle: TGLCameraStyle; FKeepFOVMode: TGLCameraKeepFOVMode; FSceneScale: Single; FDeferredApply: TNotifyEvent; FOnCustomPerspective: TOnCustomPerspective; FDesign: Boolean; FFOVY, FFOVX: Double; protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure SetTargetObject(const val: TGLBaseSceneObject); procedure SetDepthOfView(AValue: Single); procedure SetFocalLength(AValue: Single); procedure SetCameraStyle(const val: TGLCameraStyle); procedure SetKeepFOVMode(const val: TGLCameraKeepFOVMode); procedure SetSceneScale(value: Single); function StoreSceneScale: Boolean; procedure SetNearPlaneBias(value: Single); function StoreNearPlaneBias: Boolean; public constructor Create(aOwner: TComponent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; (* Nearest clipping plane for the frustum. This value depends on the FocalLength and DepthOfView fields and is calculated to minimize Z-Buffer crawling as suggested by the OpenGL documentation. *) property NearPlane: Single read FNearPlane; // Apply camera transformation procedure Apply; procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); override; function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; override; procedure ApplyPerspective(const AViewport: TRectangle; AWidth, AHeight: Integer; ADPI: Integer); procedure AutoLeveling(Factor: Single); procedure Reset(aSceneBuffer: TGLSceneBuffer); // Position the camera so that the whole scene can be seen procedure ZoomAll(aSceneBuffer: TGLSceneBuffer); procedure RotateObject(obj: TGLBaseSceneObject; pitchDelta, turnDelta: Single; rollDelta: Single = 0); procedure RotateTarget(pitchDelta, turnDelta: Single; rollDelta: Single = 0); (* Change camera's position to make it move around its target. If TargetObject is nil, nothing happens. This method helps in quickly implementing camera controls. Camera's Up and Direction properties are unchanged. Angle deltas are in degrees, camera parent's coordinates should be identity. Tip : make the camera a child of a "target" dummycube and make it a target the dummycube. Now, to pan across the scene, just move the dummycube, to change viewing angle, use this method. *) procedure MoveAroundTarget(pitchDelta, turnDelta: Single); (* Change camera's position to make it move all around its target. If TargetObject is nil, nothing happens. This method helps in quickly implementing camera controls. Camera's Up and Direction properties are changed. Angle deltas are in degrees. *) procedure MoveAllAroundTarget(pitchDelta, turnDelta :Single); // Moves the camera in eye space coordinates. procedure MoveInEyeSpace(forwardDistance, rightDistance, upDistance: Single); // Moves the target in eye space coordinates. procedure MoveTargetInEyeSpace(forwardDistance, rightDistance, upDistance: Single); // Computes the absolute vector corresponding to the eye-space translations. function AbsoluteEyeSpaceVector(forwardDistance, rightDistance, upDistance: Single): TGLVector; (* Adjusts distance from camera to target by applying a ratio. If TargetObject is nil, nothing happens. This method helps in quickly implementing camera controls. Only the camera's position is changed. *) procedure AdjustDistanceToTarget(distanceRatio: Single); (* Returns the distance from camera to target. If TargetObject is nil, returns 1. *) function DistanceToTarget: Single; (* Computes the absolute normalized vector to the camera target. If no target is defined, AbsoluteDirection is returned. *) function AbsoluteVectorToTarget: TGLVector; (* Computes the absolute normalized right vector to the camera target. If no target is defined, AbsoluteRight is returned. *) function AbsoluteRightVectorToTarget: TGLVector; (* Computes the absolute normalized up vector to the camera target. If no target is defined, AbsoluteUpt is returned. *) function AbsoluteUpVectorToTarget: TGLVector; (* Calculate an absolute translation vector from a screen vector. Ratio is applied to both screen delta, planeNormal should be the translation plane's normal. *) function ScreenDeltaToVector(deltaX, deltaY: Integer; ratio: Single; const planeNormal: TGLVector): TGLVector; // Same as ScreenDeltaToVector but optimized for XY plane. function ScreenDeltaToVectorXY(deltaX, deltaY: Integer; ratio: Single): TGLVector; // Same as ScreenDeltaToVector but optimized for XZ plane. function ScreenDeltaToVectorXZ(deltaX, deltaY: Integer; ratio: Single): TGLVector; // Same as ScreenDeltaToVector but optimized for YZ plane. function ScreenDeltaToVectorYZ(deltaX, deltaY: Integer; ratio: Single): TGLVector; // Returns true if a point is in front of the camera. function PointInFront(const point: TGLVector): boolean; overload; (* Calculates the field of view in degrees, given a viewport dimension (width or height). F.i. you may wish to use the minimum of the two. *) function GetFieldOfView(const AViewportDimension: single): single; (* Sets the FocalLength in degrees, given a field of view and a viewport dimension (width or height). *) procedure SetFieldOfView(const AFieldOfView, AViewportDimension: single); published (* Depth of field/view. Adjusts the maximum distance, beyond which objects will be clipped (ie. not visisble). You must adjust this value if you are experiencing disappearing objects (increase the value) of Z-Buffer crawling (decrease the value). Z-Buffer crawling happens when depth of view is too large and the Z-Buffer precision cannot account for all that depth accurately : objects farther overlap closer objects and vice-versa. Note that this value is ignored in cSOrtho2D mode. *) property DepthOfView: Single read FDepthOfView write SetDepthOfView; (* Focal Length of the camera. Adjusting this value allows for lens zooming effects (use SceneScale for linear zooming). This property affects near/far planes clipping. *) property FocalLength: Single read FFocalLength write SetFocalLength; {Scene scaling for camera point. This is a linear 2D scaling of the camera's output, allows for linear zooming (use FocalLength for lens zooming). } property SceneScale: Single read FSceneScale write SetSceneScale stored StoreSceneScale; (* Scaling bias applied to near-plane calculation. Values inferior to one will move the nearplane nearer, and also reduce medium/long range Z-Buffer precision, values superior to one will move the nearplane farther, and also improve medium/long range Z-Buffer precision. *) property NearPlaneBias: Single read FNearPlaneBias write SetNearPlaneBias stored StoreNearPlaneBias; (* If set, camera will point to this object. When camera is pointing an object, the Direction vector is ignored and the Up vector is used as an absolute vector to the up. *) property TargetObject: TGLBaseSceneObject read FTargetObject write SetTargetObject; (* Adjust the camera style. Three styles are available : csPerspective, the default value for perspective projection csOrthogonal, for orthogonal (or isometric) projection. csOrtho2D, setups orthogonal 2D projection in which 1 unit (in x or y) represents 1 pixel. csInfinitePerspective, for perspective view without depth limit. csKeepCamAnglePerspective, for perspective view with keeping aspect on view resize. csCustom, setup is deferred to the OnCustomPerspective event. *) property CameraStyle: TGLCameraStyle read FCameraStyle write SetCameraStyle default csPerspective; (* Keep camera angle mode. When CameraStyle is csKeepCamAnglePerspective, select which camera angle you want to keep. kaHeight, for Keep Height oriented camera angle kaWidth, for Keep Width oriented camera angle *) property KeepFOVMode: TGLCameraKeepFOVMode read FKeepFOVMode write SetKeepFOVMode default ckmHorizontalFOV; (* Custom perspective event. This event allows you to specify your custom perpective, either with a glFrustrum, a glOrtho or whatever method suits you. You must compute viewPortRadius for culling to work. This event is only called if CameraStyle is csCustom. *) property OnCustomPerspective: TOnCustomPerspective read FOnCustomPerspective write FOnCustomPerspective; property Position; property Direction; property Up; property OnProgress; end; (* Scene component class. The scene contains the scene description (lights, geometry...), which is basicly a hierarchical scene graph made of TGLBaseSceneObject. It will usually contain one or more TGLCamera object, which can be referred by a Viewer component for rendering purposes. The scene's objects can be accessed directly from code (as regular components), but those are edited with a specific editor (double-click on the TGLScene component at design-time to invoke it). To add objects at runtime, use the AddNewChild method of TGLBaseSceneObject. *) TGLScene = class(TGLUpdateAbleComponent) private FUpdateCount: Integer; FObjects: TGLSceneRootObject; FBaseContext: TGLContext; //reference, not owned! FLights, FBuffers: TGLPersistentObjectList; FCurrentGLCamera: TGLCamera; FCurrentBuffer: TGLSceneBuffer; FObjectsSorting: TGLObjectsSorting; FVisibilityCulling: TGLVisibilityCulling; FOnBeforeProgress: TGLProgressEvent; FOnProgress: TGLProgressEvent; FCurrentDeltaTime: Double; FInitializableObjects: TGLInitializableObjectList; protected procedure AddLight(aLight: TGLLightSource); procedure RemoveLight(aLight: TGLLightSource); // Adds all lights in the subtree (anObj included) procedure AddLights(anObj: TGLBaseSceneObject); // Removes all lights in the subtree (anObj included) procedure RemoveLights(anObj: TGLBaseSceneObject); procedure GetChildren(AProc: TGetChildProc; Root: TComponent); override; procedure SetChildOrder(AChild: TComponent; Order: Integer); override; procedure SetObjectsSorting(const val: TGLObjectsSorting); procedure SetVisibilityCulling(const val: TGLVisibilityCulling); procedure ReadState(Reader: TReader); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure BeginUpdate; procedure EndUpdate; function IsUpdating: Boolean; procedure AddBuffer(aBuffer: TGLSceneBuffer); procedure RemoveBuffer(aBuffer: TGLSceneBuffer); procedure SetupLights(maxLights: Integer); procedure NotifyChange(Sender: TObject); override; procedure Progress(const deltaTime, newTime: Double); function FindSceneObject(const AName: string): TGLBaseSceneObject; (* Calculates, finds and returns the first object intercepted by the ray. Returns nil if no intersection was found. This function will be accurate only for objects that overrided their RayCastIntersect method with accurate code, otherwise, bounding sphere intersections will be returned. *) function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): TGLBaseSceneObject; procedure ShutdownAllLights; // Saves the scene to a file (recommended extension : .GLSM) procedure SaveToFile(const fileName: string); (* Load the scene from a file. Existing objects/lights/cameras are freed, then the file is loaded. Delphi's IDE is not handling this behaviour properly yet, ie. if you load a scene in the IDE, objects will be properly loaded, but no declare will be placed in the code. *) procedure LoadFromFile(const fileName: string); procedure SaveToStream(aStream: TStream); procedure LoadFromStream(aStream: TStream); // Saves the scene to a text file procedure SaveToTextFile(const fileName: string); // Load the scene from a text files. See LoadFromFile for details. procedure LoadFromTextFile(const fileName: string); property CurrentGLCamera: TGLCamera read FCurrentGLCamera; property Lights: TGLPersistentObjectList read FLights; property Objects: TGLSceneRootObject read FObjects; property CurrentBuffer: TGLSceneBuffer read FCurrentBuffer; (* List of objects that request to be initialized when rendering context is active. They are removed automaticly from this list once initialized. *) property InitializableObjects: TGLInitializableObjectList read FInitializableObjects; property CurrentDeltaTime: Double read FCurrentDeltaTime; published // Defines default ObjectSorting option for scene objects. property ObjectsSorting: TGLObjectsSorting read FObjectsSorting write SetObjectsSorting default osRenderBlendedLast; // Defines default VisibilityCulling option for scene objects. property VisibilityCulling: TGLVisibilityCulling read FVisibilityCulling write SetVisibilityCulling default vcNone; property OnBeforeProgress: TGLProgressEvent read FOnBeforeProgress write FOnBeforeProgress; property OnProgress: TGLProgressEvent read FOnProgress write FOnProgress; end; TFogMode = (fmLinear, fmExp, fmExp2); (*Fog distance calculation mode. fdDefault: let OpenGL use its default formula fdEyeRadial: uses radial "true" distance (best quality) fdEyePlane: uses the distance to the projection plane (same as Z-Buffer, faster) Requires support of GL_NV_fog_distance extension, otherwise, it is ignored. *) TFogDistance = (fdDefault, fdEyeRadial, fdEyePlane); (* Parameters for fog environment in a scene. The fog descibed by this object is a distance-based fog, ie. the "intensity" of the fog is given by a formula depending solely on the distance, this intensity is used for blending to a fixed color. *) TGLFogEnvironment = class(TGLUpdateAbleObject) private FSceneBuffer: TGLSceneBuffer; FFogColor: TGLColor; // alpha value means the fog density FFogStart, FFogEnd: Single; FFogMode: TFogMode; FFogDistance: TFogDistance; protected procedure SetFogColor(Value: TGLColor); procedure SetFogStart(Value: Single); procedure SetFogEnd(Value: Single); procedure SetFogMode(Value: TFogMode); procedure SetFogDistance(const val: TFogDistance); public constructor Create(AOwner: TPersistent); override; destructor Destroy; override; procedure ApplyFog; procedure Assign(Source: TPersistent); override; function IsAtDefaultValues: Boolean; published // Color of the fog when it is at 100% intensity. property FogColor: TGLColor read FFogColor write SetFogColor; // Minimum distance for fog, what is closer is not affected. property FogStart: Single read FFogStart write SetFogStart; // Maximum distance for fog, what is farther is at 100% fog intensity. property FogEnd: Single read FFogEnd write SetFogEnd; // The formula used for converting distance to fog intensity. property FogMode: TFogMode read FFogMode write SetFogMode default fmLinear; (* Adjusts the formula used for calculating fog distances. This option is honoured if and only if the OpenGL ICD supports the GL_NV_fog_distance extension, otherwise, it is ignored. fdDefault: let OpenGL use its default formula fdEyeRadial: uses radial "true" distance (best quality) fdEyePlane: uses the distance to the projection plane (same as Z-Buffer, faster)*) property FogDistance: TFogDistance read FFogDistance write SetFogDistance default fdDefault; end; TGLDepthPrecision = (dpDefault, dp16bits, dp24bits, dp32bits); TGLColorDepth = (cdDefault, cd8bits, cd16bits, cd24bits, cdFloat64bits, cdFloat128bits); TGLShadeModel = (smDefault, smSmooth, smFlat); // Encapsulates a frame/rendering buffer. TGLSceneBuffer = class(TGLUpdateAbleObject) private // Internal state FRendering: Boolean; FRenderingContext: TGLContext; FAfterRenderEffects: TGLPersistentObjectList; FViewMatrixStack: array of TGLMatrix; FProjectionMatrixStack: array of TGLMatrix; FBaseProjectionMatrix: TGLMatrix; FCameraAbsolutePosition: TGLVector; FViewPort: TRectangle; FSelector: TGLBaseSelectTechnique; // Options & User Properties FFaceCulling, FFogEnable, FLighting: Boolean; FDepthTest: Boolean; FBackgroundColor: TColor; FBackgroundAlpha: Single; FAmbientColor: TGLColor; FAntiAliasing: TGLAntiAliasing; FDepthPrecision: TGLDepthPrecision; FColorDepth: TGLColorDepth; FContextOptions: TGLContextOptions; FShadeModel: TGLShadeModel; FRenderDPI: Integer; FFogEnvironment: TGLFogEnvironment; FAccumBufferBits: Integer; FLayer: TGLContextLayer; // Cameras FCamera: TGLCamera; // Freezing FFreezeBuffer: Pointer; FFreezed: Boolean; FFreezedViewPort: TRectangle; // Monitoring FFrameCount: Longint; FFramesPerSecond: Single; FFirstPerfCounter: Int64; FLastFrameTime: Single; // Events FOnChange: TNotifyEvent; FOnStructuralChange: TNotifyEvent; FOnPrepareGLContext: TNotifyEvent; FBeforeRender: TNotifyEvent; FViewerBeforeRender: TNotifyEvent; FPostRender: TNotifyEvent; FAfterRender: TNotifyEvent; FInitiateRendering: TGLDirectRenderEvent; FWrapUpRendering: TGLDirectRenderEvent; procedure SetLayer(const Value: TGLContextLayer); protected procedure SetBackgroundColor(AColor: TColor); procedure SetBackgroundAlpha(alpha: Single); procedure SetAmbientColor(AColor: TGLColor); function GetLimit(Which: TGLLimitType): Integer; procedure SetCamera(ACamera: TGLCamera); procedure SetContextOptions(Options: TGLContextOptions); procedure SetDepthTest(AValue: Boolean); procedure SetFaceCulling(AValue: Boolean); procedure SetLighting(AValue: Boolean); procedure SetAntiAliasing(const val: TGLAntiAliasing); procedure SetDepthPrecision(const val: TGLDepthPrecision); procedure SetColorDepth(const val: TGLColorDepth); procedure SetShadeModel(const val: TGLShadeModel); procedure SetFogEnable(AValue: Boolean); procedure SetGLFogEnvironment(AValue: TGLFogEnvironment); function StoreFog: Boolean; procedure SetAccumBufferBits(const val: Integer); procedure PrepareRenderingMatrices(const aViewPort: TRectangle; resolution: Integer; pickingRect: PRect = nil); inline; procedure DoBaseRender(const aViewPort: TRectangle; resolution: Integer; drawState: TGLDrawState; baseObject: TGLBaseSceneObject); procedure SetupRenderingContext(context: TGLContext); procedure SetupRCOptions(context: TGLContext); procedure PrepareGLContext; procedure DoChange; procedure DoStructuralChange; // DPI for current/last render property RenderDPI: Integer read FRenderDPI; property OnPrepareGLContext: TNotifyEvent read FOnPrepareGLContext write FOnPrepareGLContext; public constructor Create(AOwner: TPersistent); override; destructor Destroy; override; procedure NotifyChange(Sender: TObject); override; procedure CreateRC(AWindowHandle: HWND; memoryContext: Boolean; BufferCount: integer = 1); overload; procedure ClearBuffers; inline; procedure DestroyRC; function RCInstantiated: Boolean; procedure Resize(newLeft, newTop, newWidth, newHeight: Integer); // Indicates hardware acceleration support function Acceleration: TGLContextAcceleration; inline; // ViewPort for current/last render property ViewPort: TRectangle read FViewPort; // Fills the PickList with objects in Rect area procedure PickObjects(const rect: TRect; pickList: TGLPickList; objectCountGuess: Integer); (* Returns a PickList with objects in Rect area. Returned list should be freed by caller. Objects are sorted by depth (nearest objects first). *) function GetPickedObjects(const rect: TRect; objectCountGuess: Integer = 64): TGLPickList; // Returns the nearest object at x, y coordinates or nil if there is none function GetPickedObject(x, y: Integer): TGLBaseSceneObject; // Returns the color of the pixel at x, y in the frame buffer function GetPixelColor(x, y: Integer): TColor; (* Returns the raw depth (Z buffer) of the pixel at x, y in the frame buffer. This value does not map to the actual eye-object distance, but to a depth buffer value in the [0; 1] range. *) function GetPixelDepth(x, y: Integer): Single; (* Converts a raw depth (Z buffer value) to frustrum distance. This calculation is only accurate for the pixel at the centre of the viewer, because it does not take into account that the corners of the frustrum are further from the eye than its centre. *) function PixelDepthToDistance(aDepth: Single): Single; (* Converts a raw depth (Z buffer value) to world distance. It also compensates for the fact that the corners of the frustrum are further from the eye, than its centre.*) function PixelToDistance(x, y: integer): Single; // Design time notification procedure NotifyMouseMove(Shift: TShiftState; X, Y: Integer); (* Renders the scene on the viewer. You do not need to call this method, unless you explicitly want a render at a specific time. If you just want the control to get refreshed, use Invalidate instead. *) procedure Render(baseObject: TGLBaseSceneObject); overload; procedure Render; overload; inline; procedure RenderScene(aScene: TGLScene; const viewPortSizeX, viewPortSizeY: Integer; drawState: TGLDrawState; baseObject: TGLBaseSceneObject); (*Render the scene to a bitmap at given DPI. DPI = "dots per inch". The "magic" DPI of the screen is 96 under Windows. *) procedure RenderToBitmap(ABitmap: TBitmap; DPI: Integer = 0); (* Render the scene to a bitmap at given DPI and saves it to a file. DPI = "dots per inch". The "magic" DPI of the screen is 96 under Windows. *) procedure RenderToFile(const AFile: string; DPI: Integer = 0); overload; (* Renders to bitmap of given size, then saves it to a file. DPI is adjusted to make the bitmap similar to the viewer. *) procedure RenderToFile(const AFile: string; bmpWidth, bmpHeight: Integer); overload; (* Creates a TGLBitmap32 that is a snapshot of current OpenGL content. When possible, use this function instead of RenderToBitmap, it won't request a redraw and will be significantly faster. The returned TGLBitmap32 should be freed by calling code. *) function CreateSnapShot: TGLImage; // Creates a bitmap that is a snapshot of current OpenGL content. function CreateSnapShotBitmap: TBitmap; procedure CopyToTexture(aTexture: TGLTexture); overload; procedure CopyToTexture(aTexture: TGLTexture; xSrc, ySrc, AWidth, AHeight: Integer; xDest, yDest: Integer; glCubeFace: Cardinal = 0); overload; // Save as raw float data to a file procedure SaveAsFloatToFile(const aFilename: string); // Event reserved for viewer-specific uses. property ViewerBeforeRender: TNotifyEvent read FViewerBeforeRender write FViewerBeforeRender stored False; procedure SetViewPort(X, Y, W, H: Integer); function Width: Integer; function Height: Integer; // Indicates if the Viewer is "frozen". property Freezed: Boolean read FFreezed; (* Freezes rendering leaving the last rendered scene on the buffer. This is usefull in windowed applications for temporarily stoping rendering (when moving the window, for example). *) procedure Freeze; // Restarts rendering after it was freezed. procedure Melt; // Displays a window with info on current OpenGL ICD and context. procedure ShowInfo(Modal: boolean = false); // Currently Rendering? property Rendering: Boolean read FRendering; // Adjusts background alpha channel. property BackgroundAlpha: Single read FBackgroundAlpha write SetBackgroundAlpha; // Returns the projection matrix in use or used for the last rendering. function ProjectionMatrix: TGLMatrix; deprecated; // Returns the view matrix in use or used for the last rendering. function ViewMatrix: TGLMatrix; deprecated; function ModelMatrix: TGLMatrix; deprecated; (* Returns the base projection matrix in use or used for the last rendering. The "base" projection is (as of now) either identity or the pick matrix, ie. it is the matrix on which the perspective or orthogonal matrix gets applied. *) property BaseProjectionMatrix: TGLMatrix read FBaseProjectionMatrix; (* Back up current View matrix and replace it with newMatrix. This method has no effect on the OpenGL matrix, only on the Buffer's matrix, and is intended for special effects rendering. *) procedure PushViewMatrix(const newMatrix: TGLMatrix); deprecated; // Restore a View matrix previously pushed. procedure PopViewMatrix; deprecated; procedure PushProjectionMatrix(const newMatrix: TGLMatrix); deprecated; procedure PopProjectionMatrix; deprecated; (* Converts a screen pixel coordinate into 3D coordinates for orthogonal projection. This function accepts standard canvas coordinates, with (0,0) being the top left corner, and returns, when the camera is in orthogonal mode, the corresponding 3D world point that is in the camera's plane. *) function OrthoScreenToWorld(screenX, screenY: Integer): TAffineVector; overload; (* Converts a screen coordinate into world (3D) coordinates. This methods wraps a call to gluUnProject. Note that screen coord (0,0) is the lower left corner. *) function ScreenToWorld(const aPoint: TAffineVector): TAffineVector; overload; function ScreenToWorld(const aPoint: TGLVector): TGLVector; overload; {Converts a screen pixel coordinate into 3D world coordinates. This function accepts standard canvas coordinates, with (0,0) being the top left corner. } function ScreenToWorld(screenX, screenY: Integer): TAffineVector; overload; (* Converts an absolute world coordinate into screen coordinate. This methods wraps a call to gluProject. Note that screen coord (0,0) is the lower left corner. *) function WorldToScreen(const aPoint: TAffineVector): TAffineVector; overload; function WorldToScreen(const aPoint: TGLVector): TGLVector; overload; // Converts a set of point absolute world coordinates into screen coordinates. procedure WorldToScreen(points: PGLVector; nbPoints: Integer); overload; (* Calculates the 3D vector corresponding to a 2D screen coordinate. The vector originates from the camera's absolute position and is expressed in absolute coordinates. Note that screen coord (0,0) is the lower left corner. *) function ScreenToVector(const aPoint: TAffineVector): TAffineVector; overload; function ScreenToVector(const aPoint: TGLVector): TGLVector; overload; function ScreenToVector(const x, y: Integer): TGLVector; overload; (* Calculates the 2D screen coordinate of a vector from the camera's absolute position and is expressed in absolute coordinates. Note that screen coord (0,0) is the lower left corner. *) function VectorToScreen(const VectToCam: TAffineVector): TAffineVector; (* Calculates intersection between a plane and screen vector. If an intersection is found, returns True and places result in intersectPoint. *) function ScreenVectorIntersectWithPlane( const aScreenPoint: TGLVector; const planePoint, planeNormal: TGLVector; var intersectPoint: TGLVector): Boolean; (* Calculates intersection between plane XY and screen vector. If an intersection is found, returns True and places result in intersectPoint. *) function ScreenVectorIntersectWithPlaneXY( const aScreenPoint: TGLVector; const z: Single; var intersectPoint: TGLVector): Boolean; (* Calculates intersection between plane YZ and screen vector. If an intersection is found, returns True and places result in intersectPoint. *) function ScreenVectorIntersectWithPlaneYZ( const aScreenPoint: TGLVector; const x: Single; var intersectPoint: TGLVector): Boolean; (* Calculates intersection between plane XZ and screen vector. If an intersection is found, returns True and places result in intersectPoint. *) function ScreenVectorIntersectWithPlaneXZ( const aScreenPoint: TGLVector; const y: Single; var intersectPoint: TGLVector): Boolean; (* Calculates a 3D coordinate from screen position and ZBuffer. This function returns a world absolute coordinate from a 2D point in the viewer, the depth being extracted from the ZBuffer data (DepthTesting and ZBuffer must be enabled for this function to work). Note that ZBuffer precision is not linear and can be quite low on some boards (either from compression or resolution approximations). *) function PixelRayToWorld(x, y: Integer): TAffineVector; (* Time (in second) spent to issue rendering order for the last frame. Be aware that since execution by the hardware isn't synchronous, this value may not be an accurate measurement of the time it took to render the last frame, it's a measurement of only the time it took to issue rendering orders. *) property LastFrameTime: Single read FLastFrameTime; (* Current FramesPerSecond rendering speed. You must keep the renderer busy to get accurate figures from this property. This is an average value, to reset the counter, call ResetPerfomanceMonitor. *) property FramesPerSecond: Single read FFramesPerSecond; (* Resets the perfomance monitor and begin a new statistics set. See FramesPerSecond. *) procedure ResetPerformanceMonitor; (* Retrieve one of the OpenGL limits for the current viewer. Limits include max texture size, OpenGL stack depth, etc. *) property LimitOf[Which: TGLLimitType]: Integer read GetLimit; (* Current rendering context. The context is a wrapper around platform-specific contexts (see TGLContext) and takes care of context activation and handle management. *) property RenderingContext: TGLContext read FRenderingContext; (* The camera from which the scene is rendered. A camera is an object you can add and define in a TGLScene component. *) property Camera: TGLCamera read FCamera write SetCamera; // Specifies the layer plane that the rendering context is bound to. property Layer: TGLContextLayer read FLayer write SetLayer default clMainPlane; published // Fog environment options. See TGLFogEnvironment. property FogEnvironment: TGLFogEnvironment read FFogEnvironment write SetGLFogEnvironment stored StoreFog; // Color used for filling the background prior to any rendering. property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor default clBtnFace; (* Scene ambient color vector. This ambient color is defined independantly from all lightsources, which can have their own ambient components. *) property AmbientColor: TGLColor read FAmbientColor write SetAmbientColor; (* Context options allows to setup specifics of the rendering context. Not all contexts support all options. *) property ContextOptions: TGLContextOptions read FContextOptions write SetContextOptions default [roDoubleBuffer, roRenderToWindow, roDebugContext]; // Number of precision bits for the accumulation buffer. property AccumBufferBits: Integer read FAccumBufferBits write SetAccumBufferBits default 0; (* DepthTest enabling. When DepthTest is enabled, objects closer to the camera will hide farther ones (via use of Z-Buffering). When DepthTest is disabled, the latest objects drawn/rendered overlap all previous objects, whatever their distance to the camera. Even when DepthTest is enabled, objects may chose to ignore depth testing through the osIgnoreDepthBuffer of their ObjectStyle property. *) property DepthTest: Boolean read FDepthTest write SetDepthTest default True; (* Enable or disable face culling in the renderer. Face culling is used in hidden faces removal algorithms : each face is given a normal or 'outside' direction. When face culling is enabled, only faces whose normal points towards the observer are rendered. *) property FaceCulling: Boolean read FFaceCulling write SetFaceCulling default True; // Toggle to enable or disable the fog settings. property FogEnable: Boolean read FFogEnable write SetFogEnable default False; (* Toggle to enable or disable lighting calculations. When lighting is enabled, objects will be lit according to lightsources, when lighting is disabled, objects are rendered in their own colors, without any shading. Lighting does NOT generate shadows. *) property Lighting: Boolean read FLighting write SetLighting default True; (* AntiAliasing option. Ignored if not hardware supported, currently based on ARB_multisample. *) property AntiAliasing: TGLAntiAliasing read FAntiAliasing write SetAntiAliasing default aaDefault; (* Depth buffer precision. Default is highest available (below and including 24 bits) *) property DepthPrecision: TGLDepthPrecision read FDepthPrecision write SetDepthPrecision default dpDefault; (* Color buffer depth. Default depth buffer is highest available (below and including 24 bits) *) property ColorDepth: TGLColorDepth read FColorDepth write SetColorDepth default cdDefault; // Shade model. Default is "Smooth". property ShadeModel: TGLShadeModel read FShadeModel write SetShadeModel default smDefault; (* Indicates a change in the scene or buffer options. A simple re-render is enough to take into account the changes. *) property OnChange: TNotifyEvent read FOnChange write FOnChange stored False; (* Indicates a structural change in the scene or buffer options. A reconstruction of the RC is necessary to take into account the changes (this may lead to a driver switch or lengthy operations). *) property OnStructuralChange: TNotifyEvent read FOnStructuralChange write FOnStructuralChange stored False; (* Triggered before the scene's objects get rendered. You may use this event to execute your own OpenGL rendering (usually background stuff). *) property BeforeRender: TNotifyEvent read FBeforeRender write FBeforeRender stored False; (* Triggered after BeforeRender, before rendering objects. This one is fired after the rci has been initialized and can be used to alter it or perform early renderings that require an rci, the Sender is the buffer. *) property InitiateRendering: TGLDirectRenderEvent read FInitiateRendering write FInitiateRendering stored False; (* Triggered after rendering all scene objects, before PostRender. This is the last point after which the rci becomes unavailable, the Sender is the buffer. *) property WrapUpRendering: TGLDirectRenderEvent read FWrapUpRendering write FWrapUpRendering stored False; (* Triggered just after all the scene's objects have been rendered. The OpenGL context is still active in this event, and you may use it to execute your own OpenGL rendering (usually for HUD, 2D overlays or after effects). *) property PostRender: TNotifyEvent read FPostRender write FPostRender stored False; (* Called after rendering. You cannot issue OpenGL calls in this event, if you want to do your own OpenGL stuff, use the PostRender event. *) property AfterRender: TNotifyEvent read FAfterRender write FAfterRender stored False; end; (* Base class for non-visual viewer. Non-visual viewer may actually render visuals, but they are non-visual (ie. non interactive) at design time. Such viewers include memory or full-screen viewers. *) TGLNonVisualViewer = class(TComponent) private FBuffer: TGLSceneBuffer; FWidth, FHeight: Integer; FCubeMapRotIdx: Integer; FCubeMapZNear, FCubeMapZFar: Single; FCubeMapTranslation: TAffineVector; //FCreateTexture : Boolean; protected procedure SetBeforeRender(const val: TNotifyEvent); function GetBeforeRender: TNotifyEvent; procedure SetPostRender(const val: TNotifyEvent); function GetPostRender: TNotifyEvent; procedure SetAfterRender(const val: TNotifyEvent); function GetAfterRender: TNotifyEvent; procedure SetCamera(const val: TGLCamera); function GetCamera: TGLCamera; procedure SetBuffer(const val: TGLSceneBuffer); procedure SetWidth(const val: Integer); procedure SetHeight(const val: Integer); procedure SetupCubeMapCamera(Sender: TObject); procedure DoOnPrepareGLContext(Sender: TObject); procedure PrepareGLContext; virtual; procedure DoBufferChange(Sender: TObject); virtual; procedure DoBufferStructuralChange(Sender: TObject); virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Render(baseObject: TGLBaseSceneObject = nil); virtual; abstract; procedure CopyToTexture(aTexture: TGLTexture); overload; virtual; procedure CopyToTexture(aTexture: TGLTexture; xSrc, ySrc, width, height: Integer; xDest, yDest: Integer); overload; // CopyToTexture for Multiple-Render-Target procedure CopyToTextureMRT(aTexture: TGLTexture; BufferIndex: integer); overload; virtual; procedure CopyToTextureMRT(aTexture: TGLTexture; xSrc, ySrc, width, height: Integer; xDest, yDest: Integer; BufferIndex: integer); overload; (* Renders the 6 texture maps from a scene. The viewer is used to render the 6 images, one for each face of the cube, from the absolute position of the camera. This does NOT alter the content of the Pictures in the image, and will only change or define the content of textures as registered by OpenGL. *) procedure RenderCubeMapTextures(cubeMapTexture: TGLTexture; zNear: Single = 0; zFar: Single = 0); published // Camera from which the scene is rendered. property Camera: TGLCamera read GetCamera write SetCamera; property Width: Integer read FWidth write SetWidth default 256; property Height: Integer read FHeight write SetHeight default 256; (* Triggered before the scene's objects get rendered. You may use this event to execute your own OpenGL rendering. *) property BeforeRender: TNotifyEvent read GetBeforeRender write SetBeforeRender; (* Triggered just after all the scene's objects have been rendered. The OpenGL context is still active in this event, and you may use it to execute your own OpenGL rendering. *) property PostRender: TNotifyEvent read GetPostRender write SetPostRender; (* Called after rendering. You cannot issue OpenGL calls in this event, if you want to do your own OpenGL stuff, use the PostRender event. *) property AfterRender: TNotifyEvent read GetAfterRender write SetAfterRender; // Access to buffer properties. property Buffer: TGLSceneBuffer read FBuffer write SetBuffer; end; (* Component to render a scene to memory only. This component curently requires that the OpenGL ICD supports the WGL_ARB_pbuffer extension (indirectly). *) TGLMemoryViewer = class(TGLNonVisualViewer) private FBufferCount: integer; procedure SetBufferCount(const Value: integer); public constructor Create(AOwner: TComponent); override; procedure InstantiateRenderingContext; procedure Render(baseObject: TGLBaseSceneObject = nil); override; published (* Set BufferCount > 1 for multiple render targets. Users should check if the corresponding extension (GL_ATI_draw_buffers) is supported. Current hardware limit is BufferCount = 4. *) property BufferCount: integer read FBufferCount write SetBufferCount default 1; end; TInvokeInfoForm = procedure(aSceneBuffer: TGLSceneBuffer; Modal: boolean); (* Register an event handler triggered by any TGLBaseSceneObject Name change. *INCOMPLETE*, currently allows for only 1 (one) event, and is used by GLSceneEdit in the IDE. *) procedure RegisterGLBaseSceneObjectNameChangeEvent(notifyEvent: TNotifyEvent); (* Deregister an event handler triggered by any TGLBaseSceneObject Name change. See RegisterGLBaseSceneObjectNameChangeEvent. *) procedure DeRegisterGLBaseSceneObjectNameChangeEvent(notifyEvent: TNotifyEvent); (* Register an event handler triggered by any TGLBehaviour Name change. *INCOMPLETE*, currently allows for only 1 (one) event, and is used by FBehavioursEditor in the IDE. *) procedure RegisterGLBehaviourNameChangeEvent(notifyEvent: TNotifyEvent); (* Deregister an event handler triggered by any TGLBaseSceneObject Name change. See RegisterGLBaseSceneObjectNameChangeEvent. *) procedure DeRegisterGLBehaviourNameChangeEvent(notifyEvent: TNotifyEvent); // Issues OpenGL calls for drawing X, Y, Z axes in a standard style. procedure AxesBuildList(var rci: TGLRenderContextInfo; pattern: Word; AxisLen: Single); // Registers the procedure call used to invoke the info form. procedure RegisterInfoForm(infoForm: TInvokeInfoForm); procedure InvokeInfoForm(aSceneBuffer: TGLSceneBuffer; Modal: boolean); function GetCurrentRenderingObject: TGLBaseSceneObject; var vCounterFrequency: Int64; {$IFNDEF USE_MULTITHREAD} var {$ELSE} threadvar {$ENDIF} vCurrentRenderingObject: TGLBaseSceneObject; //------------------------------------------------------------------------------ implementation //------------------------------------------------------------------------------ function GetCurrentRenderingObject: TGLBaseSceneObject; begin Result := vCurrentRenderingObject; end; procedure AxesBuildList(var rci: TGLRenderContextInfo; pattern: Word; axisLen: Single); begin {$IFDEF USE_OPENGL_DEBUG} if GL.GREMEDY_string_marker then GL.StringMarkerGREMEDY(13, 'AxesBuildList'); {$ENDIF} with rci.GLStates do begin Disable(stLighting); if not rci.ignoreBlendingRequests then begin Enable(stBlend); SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha); end; LineWidth := 1; Enable(stLineStipple); LineStippleFactor := 1; LineStipplePattern := Pattern; DepthWriteMask := True; DepthFunc := cfLEqual; if rci.bufferDepthTest then Enable(stDepthTest); end; gl.Begin_(GL_LINES); gl.Color3f(0.5, 0.0, 0.0); gl.Vertex3f(0, 0, 0); gl.Vertex3f(-AxisLen, 0, 0); gl.Color3f(1.0, 0.0, 0.0); gl.Vertex3f(0, 0, 0); gl.Vertex3f(AxisLen, 0, 0); gl.Color3f(0.0, 0.5, 0.0); gl.Vertex3f(0, 0, 0); gl.Vertex3f(0, -AxisLen, 0); gl.Color3f(0.0, 1.0, 0.0); gl.Vertex3f(0, 0, 0); gl.Vertex3f(0, AxisLen, 0); gl.Color3f(0.0, 0.0, 0.5); gl.Vertex3f(0, 0, 0); gl.Vertex3f(0, 0, -AxisLen); gl.Color3f(0.0, 0.0, 1.0); gl.Vertex3f(0, 0, 0); gl.Vertex3f(0, 0, AxisLen); gl.End_; end; var vInfoForm: TInvokeInfoForm = nil; procedure RegisterInfoForm(infoForm: TInvokeInfoForm); begin vInfoForm := infoForm; end; procedure InvokeInfoForm(aSceneBuffer: TGLSceneBuffer; Modal: boolean); begin if Assigned(vInfoForm) then vInfoForm(aSceneBuffer, Modal) else InformationDlg('InfoForm not available.'); end; //------------------ internal global routines ---------------------------------- var vGLBaseSceneObjectNameChangeEvent: TNotifyEvent; vGLBehaviourNameChangeEvent: TNotifyEvent; procedure RegisterGLBaseSceneObjectNameChangeEvent(notifyEvent: TNotifyEvent); begin vGLBaseSceneObjectNameChangeEvent := notifyEvent; end; procedure DeRegisterGLBaseSceneObjectNameChangeEvent(notifyEvent: TNotifyEvent); begin vGLBaseSceneObjectNameChangeEvent := nil; end; procedure RegisterGLBehaviourNameChangeEvent(notifyEvent: TNotifyEvent); begin vGLBehaviourNameChangeEvent := notifyEvent; end; procedure DeRegisterGLBehaviourNameChangeEvent(notifyEvent: TNotifyEvent); begin vGLBehaviourNameChangeEvent := nil; end; // ------------------ // ------------------ TGLBaseSceneObject ------------------ // ------------------ constructor TGLBaseSceneObject.Create(AOwner: TComponent); begin inherited Create(AOwner); FListHandle := TGLListHandle.Create; FObjectStyle := []; FChanges := [ocTransformation, ocStructure, ocAbsoluteMatrix, ocInvAbsoluteMatrix]; FPosition := TGLCoordinates.CreateInitialized(Self, NullHmgPoint, csPoint); FRotation := TGLCoordinates.CreateInitialized(Self, NullHmgVector, csVector); FDirection := TGLCoordinates.CreateInitialized(Self, ZHmgVector, csVector); FUp := TGLCoordinates.CreateInitialized(Self, YHmgVector, csVector); FScaling := TGLCoordinates.CreateInitialized(Self, XYZHmgVector, csVector); FLocalMatrix := IdentityHmgMatrix; FVisible := True; FPickable := True; FObjectsSorting := osInherited; FVisibilityCulling := vcInherited; FChildren := TGLPersistentObjectList.Create; fBBChanges := [oBBcChild, oBBcStructure]; FBoundingBoxPersonalUnscaled := NullBoundingBox; FBoundingBoxOfChildren := NullBoundingBox; FBoundingBoxIncludingChildren := NullBoundingBox; distList := TGLSingleList.Create; objList := TGLPersistentObjectList.Create; end; constructor TGLBaseSceneObject.CreateAsChild(aParentOwner: TGLBaseSceneObject); begin Create(aParentOwner); aParentOwner.AddChild(Self); end; destructor TGLBaseSceneObject.Destroy; begin DeleteChildCameras; FEffects.Free; FBehaviours.Free; FListHandle.Free; FPosition.Free; FRotation.Free; FDirection.Free; FUp.Free; FScaling.Free; if Assigned(FParent) then FParent.Remove(Self, False); DeleteChildren; FChildren.Free; objList.Free; distList.Free; inherited Destroy; end; function TGLBaseSceneObject.GetHandle(var rci: TGLRenderContextInfo): Cardinal; begin // Special case.. dirty trixxors if not Assigned(FListHandle) then begin Result := 0; Exit; end; Result := FListHandle.Handle; if Result = 0 then Result := FListHandle.AllocateHandle; if ocStructure in FChanges then begin ClearStructureChanged; FListHandle.NotifyChangesOfData; end; if FListHandle.IsDataNeedUpdate then begin rci.GLStates.NewList(Result, GL_COMPILE); try BuildList(rci); finally rci.GLStates.EndList; end; FListHandle.NotifyDataUpdated; end; end; function TGLBaseSceneObject.ListHandleAllocated: Boolean; begin Result := Assigned(FListHandle) and (FListHandle.Handle <> 0) and not (ocStructure in FChanges); end; procedure TGLBaseSceneObject.DestroyHandle; begin if Assigned(FListHandle) then FListHandle.DestroyHandle; end; procedure TGLBaseSceneObject.DestroyHandles; var i: Integer; begin for i := 0 to Count - 1 do Children[i].DestroyHandles; DestroyHandle; end; procedure TGLBaseSceneObject.SetBBChanges(const Value: TGLObjectBBChanges); begin if value <> fBBChanges then begin fBBChanges := Value; if Assigned(FParent) then FParent.BBChanges := FParent.BBChanges + [oBBcChild]; end; end; function TGLBaseSceneObject.Blended: Boolean; begin Result := False; end; procedure TGLBaseSceneObject.BeginUpdate; begin Inc(FUpdateCount); end; procedure TGLBaseSceneObject.EndUpdate; begin if FUpdateCount > 0 then begin Dec(FUpdateCount); if FUpdateCount = 0 then NotifyChange(Self); end else Assert(False, strUnBalancedBeginEndUpdate); end; procedure TGLBaseSceneObject.BuildList(var rci: TGLRenderContextInfo); begin // nothing end; procedure TGLBaseSceneObject.DeleteChildCameras; var i: Integer; child: TGLBaseSceneObject; begin i := 0; while i < FChildren.Count do begin child := TGLBaseSceneObject(FChildren.List^[i]); child.DeleteChildCameras; if child is TGLCamera then begin Remove(child, True); child.Free; end else Inc(i); end; end; procedure TGLBaseSceneObject.DeleteChildren; var child: TGLBaseSceneObject; begin DeleteChildCameras; if Assigned(FScene) then FScene.RemoveLights(Self); while FChildren.Count > 0 do begin child := TGLBaseSceneObject(FChildren.Pop); child.FParent := nil; child.Free; end; BBChanges := BBChanges + [oBBcChild]; end; procedure TGLBaseSceneObject.Loaded; begin inherited; FPosition.W := 1; if Assigned(FBehaviours) then FBehaviours.Loaded; if Assigned(FEffects) then FEffects.Loaded; end; procedure TGLBaseSceneObject.DefineProperties(Filer: TFiler); begin inherited; (*FOriginalFiler := Filer;*) Filer.DefineBinaryProperty('BehavioursData', ReadBehaviours, WriteBehaviours, (Assigned(FBehaviours) and (FBehaviours.Count > 0))); Filer.DefineBinaryProperty('EffectsData', ReadEffects, WriteEffects, (Assigned(FEffects) and (FEffects.Count > 0))); (*FOriginalFiler := nil;*) end; procedure TGLBaseSceneObject.WriteBehaviours(stream: TStream); var writer: TWriter; begin writer := TWriter.Create(stream, 16384); try Behaviours.WriteToFiler(writer); finally writer.Free; end; end; procedure TGLBaseSceneObject.ReadBehaviours(stream: TStream); var reader: TReader; begin reader := TReader.Create(stream, 16384); (* with TReader(FOriginalFiler) do *) try (* reader.Root := Root; reader.OnError := OnError; reader.OnFindMethod := OnFindMethod; reader.OnSetName := OnSetName; reader.OnReferenceName := OnReferenceName; reader.OnAncestorNotFound := OnAncestorNotFound; reader.OnCreateComponent := OnCreateComponent; reader.OnFindComponentClass := OnFindComponentClass; *) Behaviours.ReadFromFiler(reader); finally reader.Free; end; end; procedure TGLBaseSceneObject.WriteEffects(stream: TStream); var writer: TWriter; begin writer := TWriter.Create(stream, 16384); try Effects.WriteToFiler(writer); finally writer.Free; end; end; procedure TGLBaseSceneObject.ReadEffects(stream: TStream); var reader: TReader; begin reader := TReader.Create(stream, 16384); (*with TReader(FOriginalFiler) do *) try (* reader.Root := Root; reader.OnError := OnError; reader.OnFindMethod := OnFindMethod; reader.OnSetName := OnSetName; reader.OnReferenceName := OnReferenceName; reader.OnAncestorNotFound := OnAncestorNotFound; reader.OnCreateComponent := OnCreateComponent; reader.OnFindComponentClass := OnFindComponentClass; *) Effects.ReadFromFiler(reader); finally reader.Free; end; end; procedure TGLBaseSceneObject.WriteRotations(stream: TStream); begin stream.Write(FRotation.AsAddress^, 3 * SizeOf(TGLFloat)); end; procedure TGLBaseSceneObject.ReadRotations(stream: TStream); begin stream.Read(FRotation.AsAddress^, 3 * SizeOf(TGLFloat)); end; procedure TGLBaseSceneObject.DrawAxes(var rci: TGLRenderContextInfo; pattern: Word); begin AxesBuildList(rci, Pattern, rci.rcci.farClippingDistance - rci.rcci.nearClippingDistance); end; procedure TGLBaseSceneObject.GetChildren(AProc: TGetChildProc; Root: TComponent); var i: Integer; begin for i := 0 to FChildren.Count - 1 do if not IsSubComponent(TComponent(FChildren.List^[i])) then AProc(TComponent(FChildren.List^[i])); end; function TGLBaseSceneObject.Get(Index: Integer): TGLBaseSceneObject; begin Result := TGLBaseSceneObject(FChildren[Index]); end; function TGLBaseSceneObject.GetCount: Integer; begin Result := FChildren.Count; end; function TGLBaseSceneObject.GetDirectAbsoluteMatrix: PGLMatrix; begin Result := @FAbsoluteMatrix; end; function TGLBaseSceneObject.HasSubChildren: Boolean; var I: Integer; begin Result := False; if Count <> 0 then for I := 0 to Count - 1 do if IsSubComponent(Children[i]) then begin Result := True; Exit; end; end; procedure TGLBaseSceneObject.AddChild(aChild: TGLBaseSceneObject); begin if Assigned(FScene) then FScene.AddLights(aChild); FChildren.Add(aChild); aChild.FParent := Self; aChild.SetScene(FScene); TransformationChanged; aChild.TransformationChanged; aChild.DoOnAddedToParent; BBChanges := BBChanges + [oBBcChild]; end; function TGLBaseSceneObject.AddNewChild(aChild: TGLSceneObjectClass): TGLBaseSceneObject; begin Result := aChild.Create(Owner); AddChild(Result); end; function TGLBaseSceneObject.AddNewChildFirst(aChild: TGLSceneObjectClass): TGLBaseSceneObject; begin Result := aChild.Create(Owner); Insert(0, Result); end; function TGLBaseSceneObject.GetOrCreateBehaviour(aBehaviour: TGLBehaviourClass): TGLBehaviour; begin Result := TGLBehaviour(Behaviours.GetOrCreate(aBehaviour)); end; function TGLBaseSceneObject.AddNewBehaviour(aBehaviour: TGLBehaviourClass): TGLBehaviour; begin Assert(Behaviours.CanAdd(aBehaviour)); result := aBehaviour.Create(Behaviours) end; function TGLBaseSceneObject.GetOrCreateEffect(aEffect: TGLEffectClass): TGLEffect; begin Result := TGLEffect(Effects.GetOrCreate(aEffect)); end; function TGLBaseSceneObject.AddNewEffect(aEffect: TGLEffectClass): TGLEffect; begin Assert(Effects.CanAdd(aEffect)); result := aEffect.Create(Effects) end; procedure TGLBaseSceneObject.RebuildMatrix; begin if ocTransformation in Changes then begin VectorScale(LeftVector, Scale.X, FLocalMatrix.X); VectorScale(FUp.AsVector, Scale.Y, FLocalMatrix.Y); VectorScale(FDirection.AsVector, Scale.Z, FLocalMatrix.Z); SetVector(FLocalMatrix.W, FPosition.AsVector); Exclude(FChanges, ocTransformation); Include(FChanges, ocAbsoluteMatrix); Include(FChanges, ocInvAbsoluteMatrix); end; end; procedure TGLBaseSceneObject.ForceLocalMatrix(const aMatrix: TGLMatrix); begin FLocalMatrix := aMatrix; Exclude(FChanges, ocTransformation); Include(FChanges, ocAbsoluteMatrix); Include(FChanges, ocInvAbsoluteMatrix); end; function TGLBaseSceneObject.AbsoluteMatrixAsAddress: PGLMatrix; begin if ocAbsoluteMatrix in FChanges then begin RebuildMatrix; if Assigned(Parent) (*and (not (Parent is TGLSceneRootObject))*) then begin MatrixMultiply(FLocalMatrix, TGLBaseSceneObject(Parent).AbsoluteMatrixAsAddress^, FAbsoluteMatrix); end else FAbsoluteMatrix := FLocalMatrix; Exclude(FChanges, ocAbsoluteMatrix); Include(FChanges, ocInvAbsoluteMatrix); end; Result := @FAbsoluteMatrix; end; function TGLBaseSceneObject.InvAbsoluteMatrix: TGLMatrix; begin Result := InvAbsoluteMatrixAsAddress^; end; function TGLBaseSceneObject.InvAbsoluteMatrixAsAddress: PGLMatrix; begin if ocInvAbsoluteMatrix in FChanges then begin if VectorEquals(Scale.DirectVector, XYZHmgVector) then begin RebuildMatrix; if Parent <> nil then FInvAbsoluteMatrix := MatrixMultiply(Parent.InvAbsoluteMatrixAsAddress^, AnglePreservingMatrixInvert(FLocalMatrix)) else FInvAbsoluteMatrix := AnglePreservingMatrixInvert(FLocalMatrix); end else begin FInvAbsoluteMatrix := AbsoluteMatrixAsAddress^; InvertMatrix(FInvAbsoluteMatrix); end; Exclude(FChanges, ocInvAbsoluteMatrix); end; Result := @FInvAbsoluteMatrix; end; function TGLBaseSceneObject.GetAbsoluteMatrix: TGLMatrix; begin Result := AbsoluteMatrixAsAddress^; end; procedure TGLBaseSceneObject.SetAbsoluteMatrix(const Value: TGLMatrix); begin if not MatrixEquals(Value, FAbsoluteMatrix) then begin FAbsoluteMatrix := Value; if Parent <> nil then SetMatrix(MatrixMultiply(FAbsoluteMatrix, Parent.InvAbsoluteMatrixAsAddress^)) else SetMatrix(Value); end; end; function TGLBaseSceneObject.GetAbsoluteDirection: TGLVector; begin Result := VectorNormalize(AbsoluteMatrixAsAddress^.V[2]); end; procedure TGLBaseSceneObject.SetAbsoluteDirection(const v: TGLVector); begin if Parent <> nil then Direction.AsVector := Parent.AbsoluteToLocal(v) else Direction.AsVector := v; end; function TGLBaseSceneObject.GetAbsoluteScale: TGLVector; begin Result.X := AbsoluteMatrixAsAddress^.X.X; Result.Y := AbsoluteMatrixAsAddress^.Y.Y; Result.Z := AbsoluteMatrixAsAddress^.Z.Z; Result.W := 0; end; procedure TGLBaseSceneObject.SetAbsoluteScale(const Value: TGLVector); begin if Parent <> nil then Scale.AsVector := Parent.AbsoluteToLocal(Value) else Scale.AsVector := Value; end; function TGLBaseSceneObject.GetAbsoluteUp: TGLVector; begin Result := VectorNormalize(AbsoluteMatrixAsAddress^.Y); end; procedure TGLBaseSceneObject.SetAbsoluteUp(const v: TGLVector); begin if Parent <> nil then Up.AsVector := Parent.AbsoluteToLocal(v) else Up.AsVector := v; end; function TGLBaseSceneObject.AbsoluteRight: TGLVector; begin Result := VectorNormalize(AbsoluteMatrixAsAddress^.X); end; function TGLBaseSceneObject.AbsoluteLeft: TGLVector; begin Result := VectorNegate(AbsoluteRight); end; function TGLBaseSceneObject.GetAbsolutePosition: TGLVector; begin Result := AbsoluteMatrixAsAddress^.W; end; procedure TGLBaseSceneObject.SetAbsolutePosition(const v: TGLVector); begin if Assigned(Parent) then Position.AsVector := Parent.AbsoluteToLocal(v) else Position.AsVector := v; end; function TGLBaseSceneObject.AbsolutePositionAsAddress: PGLVector; begin Result := @AbsoluteMatrixAsAddress^.W; end; function TGLBaseSceneObject.AbsoluteXVector: TGLVector; begin AbsoluteMatrixAsAddress; SetVector(Result, PAffineVector(@FAbsoluteMatrix.X)^); end; function TGLBaseSceneObject.AbsoluteYVector: TGLVector; begin AbsoluteMatrixAsAddress; SetVector(Result, PAffineVector(@FAbsoluteMatrix.Y)^); end; function TGLBaseSceneObject.AbsoluteZVector: TGLVector; begin AbsoluteMatrixAsAddress; SetVector(Result, PAffineVector(@FAbsoluteMatrix.Z)^); end; function TGLBaseSceneObject.AbsoluteToLocal(const v: TGLVector): TGLVector; begin Result := VectorTransform(v, InvAbsoluteMatrixAsAddress^); end; function TGLBaseSceneObject.AbsoluteToLocal(const v: TAffineVector): TAffineVector; begin Result := VectorTransform(v, InvAbsoluteMatrixAsAddress^); end; function TGLBaseSceneObject.LocalToAbsolute(const v: TGLVector): TGLVector; begin Result := VectorTransform(v, AbsoluteMatrixAsAddress^); end; function TGLBaseSceneObject.LocalToAbsolute(const v: TAffineVector): TAffineVector; begin Result := VectorTransform(v, AbsoluteMatrixAsAddress^); end; function TGLBaseSceneObject.Right: TGLVector; begin Result := VectorCrossProduct(FDirection.AsVector, FUp.AsVector); end; function TGLBaseSceneObject.LeftVector: TGLVector; begin Result := VectorCrossProduct(FUp.AsVector, FDirection.AsVector); end; function TGLBaseSceneObject.BarycenterAbsolutePosition: TGLVector; begin Result := AbsolutePosition; end; function TGLBaseSceneObject.SqrDistanceTo(anObject: TGLBaseSceneObject): Single; begin if Assigned(anObject) then Result := VectorDistance2(AbsolutePosition, anObject.AbsolutePosition) else Result := 0; end; function TGLBaseSceneObject.SqrDistanceTo(const pt: TGLVector): Single; begin Result := VectorDistance2(pt, AbsolutePosition); end; function TGLBaseSceneObject.DistanceTo(anObject: TGLBaseSceneObject): Single; begin if Assigned(anObject) then Result := VectorDistance(AbsolutePosition, anObject.AbsolutePosition) else Result := 0; end; function TGLBaseSceneObject.DistanceTo(const pt: TGLVector): Single; begin Result := VectorDistance(AbsolutePosition, pt); end; function TGLBaseSceneObject.BarycenterSqrDistanceTo(const pt: TGLVector): Single; var d: TGLVector; begin d := BarycenterAbsolutePosition; Result := VectorDistance2(d, pt); end; function TGLBaseSceneObject.AxisAlignedDimensions: TGLVector; begin Result := AxisAlignedDimensionsUnscaled(); ScaleVector(Result, Scale.AsVector); end; function TGLBaseSceneObject.AxisAlignedDimensionsUnscaled: TGLVector; begin Result.X := 0.5; Result.Y := 0.5; Result.Z := 0.5; Result.W := 0; end; function TGLBaseSceneObject.AxisAlignedBoundingBox(const AIncludeChilden: Boolean): TAABB; var i: Integer; aabb: TAABB; child: TGLBaseSceneObject; begin SetAABB(Result, AxisAlignedDimensionsUnscaled); // not tested for child objects if AIncludeChilden then begin for i := 0 to FChildren.Count - 1 do begin child := TGLBaseSceneObject(FChildren.List^[i]); aabb := child.AxisAlignedBoundingBoxUnscaled(AIncludeChilden); AABBTransform(aabb, child.Matrix^); AddAABB(Result, aabb); end; end; AABBScale(Result, Scale.AsAffineVector); end; function TGLBaseSceneObject.AxisAlignedBoundingBoxUnscaled( const AIncludeChilden: Boolean): TAABB; var i: Integer; aabb: TAABB; begin SetAABB(Result, AxisAlignedDimensionsUnscaled); //not tested for child objects if AIncludeChilden then begin for i := 0 to FChildren.Count - 1 do begin aabb := TGLBaseSceneObject(FChildren.List^[i]).AxisAlignedBoundingBoxUnscaled(AIncludeChilden); AABBTransform(aabb, TGLBaseSceneObject(FChildren.List^[i]).Matrix^); AddAABB(Result, aabb); end; end; end; function TGLBaseSceneObject.AxisAlignedBoundingBoxAbsolute( const AIncludeChilden: Boolean; const AUseBaryCenter: Boolean): TAABB; begin Result := BBToAABB(BoundingBoxAbsolute(AIncludeChilden, AUseBaryCenter)); end; function TGLBaseSceneObject.BoundingBox(const AIncludeChilden: Boolean; const AUseBaryCenter: Boolean): THmgBoundingBox; var CurrentBaryOffset: TGLVector; begin Result := AABBToBB(AxisAlignedBoundingBox(AIncludeChilden)); // code not tested... if AUseBaryCenter then begin CurrentBaryOffset := VectorSubtract(AbsoluteToLocal(BarycenterAbsolutePosition), Position.AsVector); OffsetBBPoint(Result, CurrentBaryOffset); end; end; function TGLBaseSceneObject.BoundingBoxUnscaled( const AIncludeChilden: Boolean; const AUseBaryCenter: Boolean): THmgBoundingBox; var CurrentBaryOffset: TGLVector; begin Result := AABBToBB(AxisAlignedBoundingBoxUnscaled(AIncludeChilden)); // code not tested... if AUseBaryCenter then begin CurrentBaryOffset := VectorSubtract(AbsoluteToLocal(BarycenterAbsolutePosition), Position.AsVector); OffsetBBPoint(Result, CurrentBaryOffset); end; end; function TGLBaseSceneObject.BoundingBoxAbsolute(const AIncludeChilden: Boolean; const AUseBaryCenter: Boolean): THmgBoundingBox; var I: Integer; CurrentBaryOffset: TGLVector; begin Result := BoundingBoxUnscaled(AIncludeChilden, False); for I := 0 to 7 do Result.BBox[I] := LocalToAbsolute(Result.BBox[I]); if AUseBaryCenter then begin CurrentBaryOffset := VectorSubtract(BarycenterAbsolutePosition, AbsolutePosition); OffsetBBPoint(Result, CurrentBaryOffset); end; end; function TGLBaseSceneObject.BoundingSphereRadius: Single; begin Result := VectorLength(AxisAlignedDimensions); end; function TGLBaseSceneObject.BoundingSphereRadiusUnscaled: Single; begin Result := VectorLength(AxisAlignedDimensionsUnscaled); end; function TGLBaseSceneObject.PointInObject(const point: TGLVector): Boolean; var localPt, dim: TGLVector; begin dim := AxisAlignedDimensions; localPt := VectorTransform(point, InvAbsoluteMatrix); Result := (Abs(localPt.X * Scale.X) <= dim.X) and (Abs(localPt.Y * Scale.Y) <= dim.Y) and (Abs(localPt.Z * Scale.Z) <= dim.Z); end; procedure TGLBaseSceneObject.CalculateBoundingBoxPersonalUnscaled(var ANewBoundingBox: THmgBoundingBox); begin // Using the standard method to get the local BB. ANewBoundingBox := AABBToBB(AxisAlignedBoundingBoxUnscaled(False)); OffsetBBPoint(ANewBoundingBox, AbsoluteToLocal(BarycenterAbsolutePosition)); end; function TGLBaseSceneObject.BoundingBoxPersonalUnscaledEx: THmgBoundingBox; begin if oBBcStructure in FBBChanges then begin CalculateBoundingBoxPersonalUnscaled(FBoundingBoxPersonalUnscaled); Exclude(FBBChanges, oBBcStructure); end; Result := FBoundingBoxPersonalUnscaled; end; function TGLBaseSceneObject.AxisAlignedBoundingBoxAbsoluteEx: TAABB; var pBB: THmgBoundingBox; begin pBB := BoundingBoxIncludingChildrenEx; BBTransform(pBB, AbsoluteMatrix); Result := BBtoAABB(pBB); end; function TGLBaseSceneObject.AxisAlignedBoundingBoxEx: TAABB; begin Result := BBtoAABB(BoundingBoxIncludingChildrenEx); AABBScale(Result, Scale.AsAffineVector); end; function TGLBaseSceneObject.BoundingBoxOfChildrenEx: THmgBoundingBox; var i: Integer; pBB: THmgBoundingBox; begin if oBBcChild in FBBChanges then begin // Computing FBoundingBoxOfChildren := NullBoundingBox; for i := 0 to FChildren.count - 1 do begin pBB := TGLBaseSceneObject(FChildren.List^[i]).BoundingBoxIncludingChildrenEx; if not BoundingBoxesAreEqual(@pBB, @NullBoundingBox) then begin // transformation with local matrix BBTransform(pbb, TGLBaseSceneObject(FChildren.List^[i]).Matrix^); if BoundingBoxesAreEqual(@FBoundingBoxOfChildren, @NullBoundingBox) then FBoundingBoxOfChildren := pBB else AddBB(FBoundingBoxOfChildren, pBB); end; end; exclude(FBBChanges, oBBcChild); end; result := FBoundingBoxOfChildren; end; function TGLBaseSceneObject.BoundingBoxIncludingChildrenEx: THmgBoundingBox; var pBB: THmgBoundingBox; begin if (oBBcStructure in FBBChanges) or (oBBcChild in FBBChanges) then begin pBB := BoundingBoxPersonalUnscaledEx; if BoundingBoxesAreEqual(@pBB, @NullBoundingBox) then FBoundingBoxIncludingChildren := BoundingBoxOfChildrenEx else begin FBoundingBoxIncludingChildren := pBB; pBB := BoundingBoxOfChildrenEx; if not BoundingBoxesAreEqual(@pBB, @NullBoundingBox) then AddBB(FBoundingBoxIncludingChildren, pBB); end; end; Result := FBoundingBoxIncludingChildren; end; function TGLBaseSceneObject.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; var i1, i2, absPos: TGLVector; begin SetVector(absPos, AbsolutePosition); if RayCastSphereIntersect(rayStart, rayVector, absPos, BoundingSphereRadius, i1, i2) > 0 then begin Result := True; if Assigned(intersectPoint) then SetVector(intersectPoint^, i1); if Assigned(intersectNormal) then begin SubtractVector(i1, absPos); NormalizeVector(i1); SetVector(intersectNormal^, i1); end; end else Result := False; end; function TGLBaseSceneObject.GenerateSilhouette(const silhouetteParameters: TGLSilhouetteParameters): TGLSilhouette; const cNbSegments = 21; var i, j: Integer; d, r, vr, s, c, angleFactor: Single; sVec, tVec: TAffineVector; begin r := BoundingSphereRadiusUnscaled; d := VectorLength(silhouetteParameters.SeenFrom); // determine visible radius case silhouetteParameters.Style of ssOmni: vr := SphereVisibleRadius(d, r); ssParallel: vr := r; else Assert(False); vr := r; end; // determine a local orthonormal matrix, viewer-oriented sVec := VectorCrossProduct(silhouetteParameters.SeenFrom, XVector); if VectorLength(sVec) < 1e-3 then sVec := VectorCrossProduct(silhouetteParameters.SeenFrom, YVector); tVec := VectorCrossProduct(silhouetteParameters.SeenFrom, sVec); NormalizeVector(sVec); NormalizeVector(tVec); // generate the silhouette (outline and capping) Result := TGLSilhouette.Create; angleFactor := (2 * PI) / cNbSegments; vr := vr * 0.98; for i := 0 to cNbSegments - 1 do begin SinCosine(i * angleFactor, vr, s, c); Result.Vertices.AddPoint(VectorCombine(sVec, tVec, s, c)); j := (i + 1) mod cNbSegments; Result.Indices.Add(i, j); if silhouetteParameters.CappingRequired then Result.CapIndices.Add(cNbSegments, i, j) end; if silhouetteParameters.CappingRequired then Result.Vertices.Add(NullHmgPoint); end; procedure TGLBaseSceneObject.Assign(Source: TPersistent); var i: Integer; child, newChild: TGLBaseSceneObject; begin if Assigned(Source) and (Source is TGLBaseSceneObject) then begin DestroyHandles; FVisible := TGLBaseSceneObject(Source).FVisible; TGLBaseSceneObject(Source).RebuildMatrix; SetMatrix(TGLBaseSceneObject(Source).FLocalMatrix); FShowAxes := TGLBaseSceneObject(Source).FShowAxes; FObjectsSorting := TGLBaseSceneObject(Source).FObjectsSorting; FVisibilityCulling := TGLBaseSceneObject(Source).FVisibilityCulling; FRotation.Assign(TGLBaseSceneObject(Source).FRotation); DeleteChildren; if Assigned(Scene) then Scene.BeginUpdate; if Assigned(TGLBaseSceneObject(Source).FChildren) then begin for i := 0 to TGLBaseSceneObject(Source).FChildren.Count - 1 do begin child := TGLBaseSceneObject(TGLBaseSceneObject(Source).FChildren[i]); newChild := AddNewChild(TGLSceneObjectClass(child.ClassType)); newChild.Assign(child); end; end; if Assigned(Scene) then Scene.EndUpdate; OnProgress := TGLBaseSceneObject(Source).OnProgress; if Assigned(TGLBaseSceneObject(Source).FBehaviours) then Behaviours.Assign(TGLBaseSceneObject(Source).Behaviours) else FreeAndNil(FBehaviours); if Assigned(TGLBaseSceneObject(Source).FEffects) then Effects.Assign(TGLBaseSceneObject(Source).Effects) else FreeAndNil(FEffects); Tag := TGLBaseSceneObject(Source).Tag; FTagFloat := TGLBaseSceneObject(Source).FTagFloat; end else inherited Assign(Source); end; function TGLBaseSceneObject.IsUpdating: Boolean; begin Result := (FUpdateCount <> 0) or (csReading in ComponentState); end; function TGLBaseSceneObject.GetParentComponent: TComponent; begin if FParent is TGLSceneRootObject then Result := FScene else Result := FParent; end; function TGLBaseSceneObject.HasParent: Boolean; begin Result := assigned(FParent); end; procedure TGLBaseSceneObject.Lift(aDistance: Single); begin FPosition.AddScaledVector(aDistance, FUp.AsVector); TransformationChanged; end; procedure TGLBaseSceneObject.Move(ADistance: Single); begin FPosition.AddScaledVector(ADistance, FDirection.AsVector); TransformationChanged; end; procedure TGLBaseSceneObject.Slide(ADistance: Single); begin FPosition.AddScaledVector(ADistance, Right); TransformationChanged; end; procedure TGLBaseSceneObject.ResetRotations; begin FillChar(FLocalMatrix, SizeOf(TGLMatrix), 0); FLocalMatrix.X.X := Scale.DirectX; FLocalMatrix.Y.Y := Scale.DirectY; FLocalMatrix.Z.Z := Scale.DirectZ; SetVector(FLocalMatrix.W, Position.DirectVector); FRotation.DirectVector := NullHmgPoint; FDirection.DirectVector := ZHmgVector; FUp.DirectVector := YHmgVector; TransformationChanged; Exclude(FChanges, ocTransformation); end; procedure TGLBaseSceneObject.ResetAndPitchTurnRoll(const degX, degY, degZ: Single); var rotMatrix: TGLMatrix; V: TGLVector; begin ResetRotations; // set DegX (Pitch) rotMatrix := CreateRotationMatrix(Right, degX * cPIdiv180); V := VectorTransform(FUp.AsVector, rotMatrix); NormalizeVector(V); FUp.DirectVector := V; V := VectorTransform(FDirection.AsVector, rotMatrix); NormalizeVector(V); FDirection.DirectVector := V; FRotation.DirectX := NormalizeDegAngle(DegX); // set DegY (Turn) rotMatrix := CreateRotationMatrix(FUp.AsVector, degY * cPIdiv180); V := VectorTransform(FUp.AsVector, rotMatrix); NormalizeVector(V); FUp.DirectVector := V; V := VectorTransform(FDirection.AsVector, rotMatrix); NormalizeVector(V); FDirection.DirectVector := V; FRotation.DirectY := NormalizeDegAngle(DegY); // set DegZ (Roll) rotMatrix := CreateRotationMatrix(Direction.AsVector, degZ * cPIdiv180); V := VectorTransform(FUp.AsVector, rotMatrix); NormalizeVector(V); FUp.DirectVector := V; V := VectorTransform(FDirection.AsVector, rotMatrix); NormalizeVector(V); FDirection.DirectVector := V; FRotation.DirectZ := NormalizeDegAngle(DegZ); TransformationChanged; NotifyChange(self); end; procedure TGLBaseSceneObject.RotateAbsolute(const rx, ry, rz: Single); var resMat: TGLMatrix; v: TAffineVector; begin resMat := Matrix^; // No we build rotation matrices and use them to rotate the obj if rx <> 0 then begin SetVector(v, AbsoluteToLocal(XVector)); resMat := MatrixMultiply(CreateRotationMatrix(v, -DegToRadian(rx)), resMat); end; if ry <> 0 then begin SetVector(v, AbsoluteToLocal(YVector)); resMat := MatrixMultiply(CreateRotationMatrix(v, -DegToRadian(ry)), resMat); end; if rz <> 0 then begin SetVector(v, AbsoluteToLocal(ZVector)); resMat := MatrixMultiply(CreateRotationMatrix(v, -DegToRadian(rz)), resMat); end; SetMatrix(resMat); end; procedure TGLBaseSceneObject.RotateAbsolute(const axis: TAffineVector; angle: Single); var v: TAffineVector; begin if angle <> 0 then begin SetVector(v, AbsoluteToLocal(axis)); SetMatrix(MatrixMultiply(CreateRotationMatrix(v, DegToRadian(angle)), Matrix^)); end; end; procedure TGLBaseSceneObject.Pitch(angle: Single); var r: Single; rightVector: TGLVector; begin FIsCalculating := True; try angle := -DegToRad(angle); rightVector := Right; FUp.Rotate(rightVector, angle); FUp.Normalize; FDirection.Rotate(rightVector, angle); FDirection.Normalize; r := -RadToDeg(ArcTan2(FDirection.Y, VectorLength(FDirection.X, FDirection.Z))); if FDirection.X < 0 then if FDirection.Y < 0 then r := 180 - r else r := -180 - r; FRotation.X := r; finally FIsCalculating := False; end; TransformationChanged; end; procedure TGLBaseSceneObject.SetPitchAngle(AValue: Single); var diff: Single; rotMatrix: TGLMatrix; begin if AValue <> FRotation.X then begin if not (csLoading in ComponentState) then begin FIsCalculating := True; try diff := DegToRadian(FRotation.X - AValue); rotMatrix := CreateRotationMatrix(Right, diff); FUp.DirectVector := VectorTransform(FUp.AsVector, rotMatrix); FUp.Normalize; FDirection.DirectVector := VectorTransform(FDirection.AsVector, rotMatrix); FDirection.Normalize; TransformationChanged; finally FIsCalculating := False; end; end; FRotation.DirectX := NormalizeDegAngle(AValue); end; end; procedure TGLBaseSceneObject.Roll(angle: Single); var r: Single; rightVector, directionVector: TGLVector; begin FIsCalculating := True; try angle := DegToRadian(angle); directionVector := Direction.AsVector; FUp.Rotate(directionVector, angle); FUp.Normalize; FDirection.Rotate(directionVector, angle); FDirection.Normalize; // calculate new rotation angle from vectors rightVector := Right; r := -RadToDeg(ArcTan2(rightVector.Y, VectorLength(rightVector.X, rightVector.Z))); if rightVector.X < 0 then if rightVector.Y < 0 then r := 180 - r else r := -180 - r; FRotation.Z := r; finally FIsCalculating := False; end; TransformationChanged; end; procedure TGLBaseSceneObject.SetRollAngle(AValue: Single); var diff: Single; rotMatrix: TGLMatrix; begin if AValue <> FRotation.Z then begin if not (csLoading in ComponentState) then begin FIsCalculating := True; try diff := DegToRadian(FRotation.Z - AValue); rotMatrix := CreateRotationMatrix(Direction.AsVector, diff); FUp.DirectVector := VectorTransform(FUp.AsVector, rotMatrix); FUp.Normalize; FDirection.DirectVector := VectorTransform(FDirection.AsVector, rotMatrix); FDirection.Normalize; TransformationChanged; finally FIsCalculating := False; end; end; FRotation.DirectZ := NormalizeDegAngle(AValue); end; end; procedure TGLBaseSceneObject.Turn(angle: Single); var r: Single; upVector: TGLVector; begin FIsCalculating := True; try angle := DegToRadian(angle); upVector := Up.AsVector; FUp.Rotate(upVector, angle); FUp.Normalize; FDirection.Rotate(upVector, angle); FDirection.Normalize; r := -RadToDeg(ArcTan2(FDirection.X, VectorLength(FDirection.Y, FDirection.Z))); if FDirection.X < 0 then if FDirection.Y < 0 then r := 180 - r else r := -180 - r; FRotation.Y := r; finally FIsCalculating := False; end; TransformationChanged; end; procedure TGLBaseSceneObject.SetTurnAngle(AValue: Single); var diff: Single; rotMatrix: TGLMatrix; begin if AValue <> FRotation.Y then begin if not (csLoading in ComponentState) then begin FIsCalculating := True; try diff := DegToRadian(FRotation.Y - AValue); rotMatrix := CreateRotationMatrix(Up.AsVector, diff); FUp.DirectVector := VectorTransform(FUp.AsVector, rotMatrix); FUp.Normalize; FDirection.DirectVector := VectorTransform(FDirection.AsVector, rotMatrix); FDirection.Normalize; TransformationChanged; finally FIsCalculating := False; end; end; FRotation.DirectY := NormalizeDegAngle(AValue); end; end; procedure TGLBaseSceneObject.SetRotation(aRotation: TGLCoordinates); begin FRotation.Assign(aRotation); TransformationChanged; end; function TGLBaseSceneObject.GetPitchAngle: Single; begin Result := FRotation.X; end; function TGLBaseSceneObject.GetTurnAngle: Single; begin Result := FRotation.Y; end; function TGLBaseSceneObject.GetRollAngle: Single; begin Result := FRotation.Z; end; procedure TGLBaseSceneObject.PointTo(const ATargetObject: TGLBaseSceneObject; const AUpVector: TGLVector); begin PointTo(ATargetObject.AbsolutePosition, AUpVector); end; procedure TGLBaseSceneObject.PointTo(const AAbsolutePosition, AUpVector: TGLVector); var absDir, absRight, absUp: TGLVector; begin // first compute absolute attitude for pointing absDir := VectorSubtract(AAbsolutePosition, Self.AbsolutePosition); NormalizeVector(absDir); absRight := VectorCrossProduct(absDir, AUpVector); NormalizeVector(absRight); absUp := VectorCrossProduct(absRight, absDir); // convert absolute to local and adjust object if Parent <> nil then begin FUp.AsVector := Parent.AbsoluteToLocal(absUp); FDirection.AsVector := Parent.AbsoluteToLocal(absDir); end else begin FUp.AsVector := absUp; FDirection.AsVector := absDir; end; TransformationChanged end; procedure TGLBaseSceneObject.SetShowAxes(AValue: Boolean); begin if FShowAxes <> AValue then begin FShowAxes := AValue; NotifyChange(Self); end; end; procedure TGLBaseSceneObject.SetScaling(AValue: TGLCoordinates); begin FScaling.Assign(AValue); TransformationChanged; end; procedure TGLBaseSceneObject.SetName(const NewName: TComponentName); begin if Name <> NewName then begin inherited SetName(NewName); if Assigned(vGLBaseSceneObjectNameChangeEvent) then vGLBaseSceneObjectNameChangeEvent(Self); end; end; procedure TGLBaseSceneObject.SetParent(const val: TGLBaseSceneObject); begin MoveTo(val); end; function TGLBaseSceneObject.GetIndex: Integer; begin if Assigned(FParent) then Result := FParent.FChildren.IndexOf(Self) else Result := -1; end; function TGLBaseSceneObject.GetLocalMatrix: PGLMatrix; begin Result := @FLocalMatrix; end; procedure TGLBaseSceneObject.SetIndex(aValue: Integer); var LCount: Integer; parentBackup: TGLBaseSceneObject; begin if Assigned(FParent) then begin if aValue < 0 then aValue := 0; LCount := FParent.Count; if aValue >= LCount then aValue := LCount - 1; if aValue <> Index then begin if Assigned(FScene) then FScene.BeginUpdate; parentBackup := FParent; parentBackup.Remove(Self, False); parentBackup.Insert(AValue, Self); if Assigned(FScene) then FScene.EndUpdate; end; end; end; procedure TGLBaseSceneObject.SetParentComponent(Value: TComponent); begin inherited; if Value = FParent then Exit; if Value is TGLScene then SetParent(TGLScene(Value).Objects) else if Value is TGLBaseSceneObject then SetParent(TGLBaseSceneObject(Value)) else SetParent(nil); end; procedure TGLBaseSceneObject.StructureChanged; begin if not (ocStructure in FChanges) then begin Include(FChanges, ocStructure); NotifyChange(Self); end else if osDirectDraw in ObjectStyle then NotifyChange(Self); end; procedure TGLBaseSceneObject.ClearStructureChanged; begin Exclude(FChanges, ocStructure); SetBBChanges(BBChanges + [oBBcStructure]); end; procedure TGLBaseSceneObject.RecTransformationChanged; var i: Integer; list: PGLPointerObjectList; matSet: TGLObjectChanges; begin matSet := [ocAbsoluteMatrix, ocInvAbsoluteMatrix]; if matSet * FChanges <> matSet then begin FChanges := FChanges + matSet; list := FChildren.List; for i := 0 to FChildren.Count - 1 do TGLBaseSceneObject(list^[i]).RecTransformationChanged; end; end; procedure TGLBaseSceneObject.TransformationChanged; begin if not (ocTransformation in FChanges) then begin Include(FChanges, ocTransformation); RecTransformationChanged; if not (csLoading in ComponentState) then NotifyChange(Self); end; end; procedure TGLBaseSceneObject.MoveTo(newParent: TGLBaseSceneObject); begin if newParent = FParent then Exit; if Assigned(FParent) then begin FParent.Remove(Self, False); FParent := nil; end; if Assigned(newParent) then newParent.AddChild(Self) else SetScene(nil); end; procedure TGLBaseSceneObject.MoveUp; begin if Assigned(parent) then parent.MoveChildUp(parent.IndexOfChild(Self)); end; procedure TGLBaseSceneObject.MoveDown; begin if Assigned(parent) then parent.MoveChildDown(parent.IndexOfChild(Self)); end; procedure TGLBaseSceneObject.MoveFirst; begin if Assigned(parent) then parent.MoveChildFirst(parent.IndexOfChild(Self)); end; procedure TGLBaseSceneObject.MoveLast; begin if Assigned(parent) then parent.MoveChildLast(parent.IndexOfChild(Self)); end; procedure TGLBaseSceneObject.MoveObjectAround(anObject: TGLBaseSceneObject; pitchDelta, turnDelta: Single); var originalT2C, normalT2C, normalCameraRight, newPos: TGLVector; pitchNow, dist: Single; begin if Assigned(anObject) then begin // normalT2C points away from the direction the camera is looking originalT2C := VectorSubtract(AbsolutePosition, anObject.AbsolutePosition); SetVector(normalT2C, originalT2C); dist := VectorLength(normalT2C); NormalizeVector(normalT2C); // normalRight points to the camera's right // the camera is pitching around this axis. normalCameraRight := VectorCrossProduct(AbsoluteUp, normalT2C); if VectorLength(normalCameraRight) < 0.001 then SetVector(normalCameraRight, XVector) // arbitrary vector else NormalizeVector(normalCameraRight); // calculate the current pitch. // 0 is looking down and PI is looking up pitchNow := ArcCos(VectorDotProduct(AbsoluteUp, normalT2C)); pitchNow := ClampValue(pitchNow + DegToRad(pitchDelta), 0 + 0.025, PI - 0.025); // creates a new vector pointing up and then rotate it down // into the new position SetVector(normalT2C, AbsoluteUp); RotateVector(normalT2C, normalCameraRight, -pitchNow); RotateVector(normalT2C, AbsoluteUp, -DegToRadian(turnDelta)); ScaleVector(normalT2C, dist); newPos := VectorAdd(AbsolutePosition, VectorSubtract(normalT2C, originalT2C)); if Assigned(Parent) then newPos := Parent.AbsoluteToLocal(newPos); Position.AsVector := newPos; end; end; procedure TGLBaseSceneObject.MoveObjectAllAround(anObject: TGLBaseSceneObject; pitchDelta, turnDelta: Single); var upvector: TGLVector; lookat : TGLVector; rightvector : TGLVector; tempvector: TGLVector; T2C: TGLVector; begin // if camera has got a target if Assigned(anObject) then begin //vector camera to target lookat := VectorNormalize(VectorSubtract(anObject.AbsolutePosition, AbsolutePosition)); //camera up vector upvector := VectorNormalize(AbsoluteUp); // if upvector and lookat vector are colinear, it is necessary to compute new up vector if Abs(VectorDotProduct(lookat,upvector))>0.99 then begin //X or Y vector use to generate upvector SetVector(tempvector,1,0,0); //if lookat is colinear to X vector use Y vector to generate upvector if Abs(VectorDotProduct(tempvector,lookat))>0.99 then begin SetVector(tempvector,0,1,0); end; upvector:= VectorCrossProduct(tempvector,lookat); rightvector := VectorCrossProduct(lookat,upvector); end else begin rightvector := VectorCrossProduct(lookat,upvector); upvector:= VectorCrossProduct(rightvector,lookat); end; //now the up right and look at vector are orthogonal // vector Target to camera T2C:= VectorSubtract(AbsolutePosition,anObject.AbsolutePosition); RotateVector(T2C,rightvector,DegToRadian(-PitchDelta)); RotateVector(T2C,upvector,DegToRadian(-TurnDelta)); AbsolutePosition := VectorAdd(anObject.AbsolutePosition, T2C); //now update new up vector RotateVector(upvector,rightvector,DegToRadian(-PitchDelta)); AbsoluteUp := upvector; AbsoluteDirection := VectorSubtract(anObject.AbsolutePosition,AbsolutePosition); end; end; procedure TGLBaseSceneObject.CoordinateChanged(Sender: TGLCustomCoordinates); var rightVector: TGLVector; begin if FIsCalculating then Exit; FIsCalculating := True; try if Sender = FDirection then begin if FDirection.VectorLength = 0 then FDirection.DirectVector := ZHmgVector; FDirection.Normalize; // adjust up vector rightVector := VectorCrossProduct(FDirection.AsVector, FUp.AsVector); // Rightvector is zero if direction changed exactly by 90 degrees, // in this case assume a default vector if VectorLength(rightVector) < 1e-5 then begin rightVector := VectorCrossProduct(ZHmgVector, FUp.AsVector); if VectorLength(rightVector) < 1e-5 then rightVector := VectorCrossProduct(XHmgVector, FUp.AsVector); end; FUp.DirectVector := VectorCrossProduct(rightVector, FDirection.AsVector); FUp.Normalize; end else if Sender = FUp then begin if FUp.VectorLength = 0 then FUp.DirectVector := YHmgVector; FUp.Normalize; // adjust up vector rightVector := VectorCrossProduct(FDirection.AsVector, FUp.AsVector); // Rightvector is zero if direction changed exactly by 90 degrees, // in this case assume a default vector if VectorLength(rightVector) < 1e-5 then begin rightVector := VectorCrossProduct(ZHmgVector, FUp.AsVector); if VectorLength(rightVector) < 1e-5 then rightVector := VectorCrossProduct(XHmgVector, FUp.AsVector); end; FDirection.DirectVector := VectorCrossProduct(FUp.AsVector, RightVector); FDirection.Normalize; end; TransformationChanged; finally FIsCalculating := False; end; end; procedure TGLBaseSceneObject.DoProgress(const progressTime: TGLProgressTimes); var i: Integer; begin for i := FChildren.Count - 1 downto 0 do TGLBaseSceneObject(FChildren.List^[i]).DoProgress(progressTime); if Assigned(FBehaviours) then FBehaviours.DoProgress(progressTime); if Assigned(FEffects) then FEffects.DoProgress(progressTime); if Assigned(FOnProgress) then with progressTime do FOnProgress(Self, deltaTime, newTime); end; procedure TGLBaseSceneObject.Insert(aIndex: Integer; aChild: TGLBaseSceneObject); begin with FChildren do begin if Assigned(aChild.FParent) then aChild.FParent.Remove(aChild, False); Insert(aIndex, aChild); end; aChild.FParent := Self; if AChild.FScene <> FScene then AChild.DestroyHandles; AChild.SetScene(FScene); if Assigned(FScene) then FScene.AddLights(aChild); AChild.TransformationChanged; aChild.DoOnAddedToParent; end; procedure TGLBaseSceneObject.Remove(aChild: TGLBaseSceneObject; keepChildren: Boolean); var I: Integer; begin if not Assigned(FChildren) then Exit; if aChild.Parent = Self then begin if Assigned(FScene) then FScene.RemoveLights(aChild); if aChild.Owner = Self then RemoveComponent(aChild); FChildren.Remove(aChild); aChild.FParent := nil; if keepChildren then begin BeginUpdate; if aChild.Count <> 0 then for I := aChild.Count - 1 downto 0 do if not IsSubComponent(aChild.Children[I]) then aChild.Children[I].MoveTo(Self); EndUpdate; end else NotifyChange(Self); end; end; function TGLBaseSceneObject.IndexOfChild(aChild: TGLBaseSceneObject): Integer; begin Result := FChildren.IndexOf(aChild) end; function TGLBaseSceneObject.FindChild(const aName: string; ownChildrenOnly: Boolean): TGLBaseSceneObject; var i: integer; res: TGLBaseSceneObject; begin res := nil; Result := nil; for i := 0 to FChildren.Count - 1 do begin if CompareText(TGLBaseSceneObject(FChildren[i]).Name, aName) = 0 then begin res := TGLBaseSceneObject(FChildren[i]); Break; end; end; if not ownChildrenOnly then begin for i := 0 to FChildren.Count - 1 do with TGLBaseSceneObject(FChildren[i]) do begin Result := FindChild(aName, ownChildrenOnly); if Assigned(Result) then Break; end; end; if not Assigned(Result) then Result := res; end; procedure TGLBaseSceneObject.ExchangeChildren(anIndex1, anIndex2: Integer); begin Assert(Assigned(FChildren), 'No children found!'); FChildren.Exchange(anIndex1, anIndex2); NotifyChange(Self); end; procedure TGLBaseSceneObject.ExchangeChildrenSafe(anIndex1, anIndex2: Integer); begin Assert(Assigned(FChildren), 'No children found!'); if (anIndex1 < FChildren.Count) and (anIndex2 < FChildren.Count) and (anIndex1 > -1) and (anIndex2 > -1) and (anIndex1 <> anIndex2) then begin FChildren.Exchange(anIndex1, anIndex2); NotifyChange(Self); end; end; procedure TGLBaseSceneObject.MoveChildUp(anIndex: Integer); begin Assert(Assigned(FChildren), 'No children found!'); if anIndex > 0 then begin FChildren.Exchange(anIndex, anIndex - 1); NotifyChange(Self); end; end; procedure TGLBaseSceneObject.MoveChildDown(anIndex: Integer); begin Assert(Assigned(FChildren), 'No children found!'); if anIndex < FChildren.Count - 1 then begin FChildren.Exchange(anIndex, anIndex + 1); NotifyChange(Self); end; end; procedure TGLBaseSceneObject.MoveChildFirst(anIndex: Integer); begin Assert(Assigned(FChildren), 'No children found!'); if anIndex <> 0 then begin FChildren.Move(anIndex, 0); NotifyChange(Self); end; end; procedure TGLBaseSceneObject.MoveChildLast(anIndex: Integer); begin Assert(Assigned(FChildren), 'No children found!'); if anIndex <> FChildren.Count - 1 then begin FChildren.Move(anIndex, FChildren.Count - 1); NotifyChange(Self); end; end; procedure TGLBaseSceneObject.Render(var ARci: TGLRenderContextInfo); var shouldRenderSelf, shouldRenderChildren: Boolean; aabb: TAABB; master: TObject; begin {$IFDEF USE_OPENGL_DEBUG} if gl.GREMEDY_string_marker then gl.StringMarkerGREMEDY( Length(Name) + Length('.Render'), PChar(TString(Name + '.Render'))); {$ENDIF} if (ARci.drawState = dsPicking) and not FPickable then exit; // visibility culling determination if ARci.visibilityCulling in [vcObjectBased, vcHierarchical] then begin if ARci.visibilityCulling = vcObjectBased then begin shouldRenderSelf := (osNoVisibilityCulling in ObjectStyle) or (not IsVolumeClipped(BarycenterAbsolutePosition, BoundingSphereRadius, ARci.rcci.frustum)); shouldRenderChildren := FChildren.Count>0; end else begin // vcHierarchical aabb := AxisAlignedBoundingBox; shouldRenderSelf := (osNoVisibilityCulling in ObjectStyle) or (not IsVolumeClipped(aabb.min, aabb.max, ARci.rcci.frustum)); shouldRenderChildren := shouldRenderSelf and Assigned(FChildren); end; if not (shouldRenderSelf or shouldRenderChildren) then Exit; end else begin Assert(ARci.visibilityCulling in [vcNone, vcInherited], 'Unknown visibility culling option'); shouldRenderSelf := True; shouldRenderChildren := FChildren.Count>0; end; // Prepare Matrix and PickList stuff ARci.PipelineTransformation.Push; if ocTransformation in FChanges then RebuildMatrix; if ARci.proxySubObject then ARci.PipelineTransformation.SetModelMatrix( MatrixMultiply(LocalMatrix^, ARci.PipelineTransformation.ModelMatrix^)) else ARci.PipelineTransformation.SetModelMatrix(AbsoluteMatrix); master := nil; if ARci.drawState = dsPicking then begin if ARci.proxySubObject then master := TGLSceneBuffer(ARci.buffer).FSelector.CurrentObject; TGLSceneBuffer(ARci.buffer).FSelector.CurrentObject := Self; end; // Start rendering if shouldRenderSelf then begin vCurrentRenderingObject := Self; {$IFNDEF USE_OPTIMIZATIONS} if FShowAxes then DrawAxes(ARci, $CCCC); {$ENDIF} if Assigned(FEffects) and (FEffects.Count > 0) then begin ARci.PipelineTransformation.Push; FEffects.RenderPreEffects(ARci); ARci.PipelineTransformation.Pop; ARci.PipelineTransformation.Push; if osIgnoreDepthBuffer in ObjectStyle then begin ARci.GLStates.Disable(stDepthTest); DoRender(ARci, True, shouldRenderChildren); ARci.GLStates.Enable(stDepthTest); end else DoRender(ARci, True, shouldRenderChildren); FEffects.RenderPostEffects(ARci); ARci.PipelineTransformation.Pop; end else begin if osIgnoreDepthBuffer in ObjectStyle then begin ARci.GLStates.Disable(stDepthTest); DoRender(ARci, True, shouldRenderChildren); ARci.GLStates.Enable(stDepthTest); end else DoRender(ARci, True, shouldRenderChildren); end; vCurrentRenderingObject := nil; end else begin if (osIgnoreDepthBuffer in ObjectStyle) and TGLSceneBuffer(ARCi.buffer).DepthTest then begin ARci.GLStates.Disable(stDepthTest); DoRender(ARci, False, shouldRenderChildren); ARci.GLStates.Enable(stDepthTest); end else DoRender(ARci, False, shouldRenderChildren); end; // Pop Name & Matrix if Assigned(master) then TGLSceneBuffer(ARci.buffer).FSelector.CurrentObject := master; ARci.PipelineTransformation.Pop; end; procedure TGLBaseSceneObject.DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); begin // start rendering self if ARenderSelf then begin if (osDirectDraw in ObjectStyle) or ARci.amalgamating then BuildList(ARci) else ARci.GLStates.CallList(GetHandle(ARci)); end; // start rendering children (if any) if ARenderChildren then Self.RenderChildren(0, Count - 1, ARci); end; procedure TGLBaseSceneObject.RenderChildren(firstChildIndex, lastChildIndex: Integer; var rci: TGLRenderContextInfo); var i: Integer; plist: PGLPointerObjectList; obj: TGLBaseSceneObject; oldSorting: TGLObjectsSorting; oldCulling: TGLVisibilityCulling; begin oldCulling := rci.visibilityCulling; if Self.VisibilityCulling <> vcInherited then rci.visibilityCulling := Self.VisibilityCulling; if lastChildIndex = firstChildIndex then begin obj := TGLBaseSceneObject(FChildren.List^[firstChildIndex]); if obj.Visible then obj.Render(rci) end else if lastChildIndex > firstChildIndex then begin oldSorting := rci.objectsSorting; if Self.ObjectsSorting <> osInherited then rci.objectsSorting := Self.ObjectsSorting; case rci.objectsSorting of osNone: begin plist := FChildren.List; for i := firstChildIndex to lastChildIndex do begin obj := TGLBaseSceneObject(plist^[i]); if obj.Visible then obj.Render(rci); end; end; osRenderFarthestFirst, osRenderBlendedLast, osRenderNearestFirst: begin distList.Flush; objList.Count := 0; distList.GrowthDelta := lastChildIndex + 1; // no reallocations objList.GrowthDelta := distList.GrowthDelta; //try case rci.objectsSorting of osRenderBlendedLast: // render opaque stuff for i := firstChildIndex to lastChildIndex do begin obj := TGLBaseSceneObject(FChildren.List^[i]); if obj.Visible then begin if not obj.Blended then obj.Render(rci) else begin objList.Add(obj); distList.Add(1 + obj.BarycenterSqrDistanceTo(rci.cameraPosition)); end; end; end; osRenderFarthestFirst: for i := firstChildIndex to lastChildIndex do begin obj := TGLBaseSceneObject(FChildren.List^[i]); if obj.Visible then begin objList.Add(obj); distList.Add(1 + obj.BarycenterSqrDistanceTo(rci.cameraPosition)); end; end; osRenderNearestFirst: for i := firstChildIndex to lastChildIndex do begin obj := TGLBaseSceneObject(FChildren.List^[i]); if obj.Visible then begin objList.Add(obj); distList.Add(-1 - obj.BarycenterSqrDistanceTo(rci.cameraPosition)); end; end; else Assert(False); end; if distList.Count > 0 then begin if distList.Count > 1 then FastQuickSortLists(0, distList.Count - 1, distList, objList); plist := objList.List; for i := objList.Count - 1 downto 0 do TGLBaseSceneObject(plist^[i]).Render(rci); end; //finally //end; end; else Assert(False); end; rci.objectsSorting := oldSorting; end; rci.visibilityCulling := oldCulling; end; procedure TGLBaseSceneObject.NotifyChange(Sender: TObject); begin if Assigned(FScene) and (not IsUpdating) then FScene.NotifyChange(Self); end; function TGLBaseSceneObject.GetMatrix: PGLMatrix; begin RebuildMatrix; Result := @FLocalMatrix; end; procedure TGLBaseSceneObject.SetMatrix(const aValue: TGLMatrix); begin FLocalMatrix := aValue; FDirection.DirectVector := VectorNormalize(FLocalMatrix.Z); FUp.DirectVector := VectorNormalize(FLocalMatrix.Y); Scale.SetVector(VectorLength(FLocalMatrix.X), VectorLength(FLocalMatrix.Y), VectorLength(FLocalMatrix.Z), 0); FPosition.DirectVector := FLocalMatrix.W; TransformationChanged; end; procedure TGLBaseSceneObject.SetPosition(APosition: TGLCoordinates); begin FPosition.SetPoint(APosition.DirectX, APosition.DirectY, APosition.DirectZ); end; procedure TGLBaseSceneObject.SetDirection(AVector: TGLCoordinates); begin if not VectorIsNull(AVector.DirectVector) then FDirection.SetVector(AVector.DirectX, AVector.DirectY, AVector.DirectZ); end; procedure TGLBaseSceneObject.SetUp(AVector: TGLCoordinates); begin if not VectorIsNull(AVector.DirectVector) then FUp.SetVector(AVector.DirectX, AVector.DirectY, AVector.DirectZ); end; function TGLBaseSceneObject.GetVisible: Boolean; begin Result := FVisible; end; function TGLBaseSceneObject.GetPickable: Boolean; begin Result := FPickable; end; procedure TGLBaseSceneObject.SetVisible(aValue: Boolean); begin if FVisible <> aValue then begin FVisible := AValue; NotifyChange(Self); end; end; procedure TGLBaseSceneObject.SetPickable(aValue: Boolean); begin if FPickable <> aValue then begin FPickable := AValue; NotifyChange(Self); end; end; procedure TGLBaseSceneObject.SetObjectsSorting(const val: TGLObjectsSorting); begin if FObjectsSorting <> val then begin FObjectsSorting := val; NotifyChange(Self); end; end; procedure TGLBaseSceneObject.SetVisibilityCulling(const val: TGLVisibilityCulling); begin if FVisibilityCulling <> val then begin FVisibilityCulling := val; NotifyChange(Self); end; end; procedure TGLBaseSceneObject.SetBehaviours(const val: TGLBehaviours); begin Behaviours.Assign(val); end; function TGLBaseSceneObject.GetBehaviours: TGLBehaviours; begin if not Assigned(FBehaviours) then FBehaviours := TGLBehaviours.Create(Self); Result := FBehaviours; end; procedure TGLBaseSceneObject.SetEffects(const val: TGLEffects); begin Effects.Assign(val); end; function TGLBaseSceneObject.GetEffects: TGLEffects; begin if not Assigned(FEffects) then FEffects := TGLEffects.Create(Self); Result := FEffects; end; procedure TGLBaseSceneObject.SetScene(const value: TGLScene); var i: Integer; begin if value <> FScene then begin // must be freed, the new scene may be using a non-compatible RC if FScene <> nil then DestroyHandles; FScene := value; // propagate for childs if Assigned(FChildren) then for i := 0 to FChildren.Count - 1 do Children[I].SetScene(FScene); end; end; procedure TGLBaseSceneObject.Translate(tx, ty, tz: Single); begin FPosition.Translate(AffineVectorMake(tx, ty, tz)); end; function TGLBaseSceneObject.GetAbsoluteAffinePosition: TAffineVector; var temp: TGLVector; begin temp := GetAbsolutePosition; Result := AffineVectorMake(temp.X, temp.Y, temp.Z); end; function TGLBaseSceneObject.GetAbsoluteAffineDirection: TAffineVector; var temp: TGLVector; begin temp := GetAbsoluteDirection; Result := AffineVectorMake(temp.X, temp.Y, temp.Z); end; function TGLBaseSceneObject.GetAbsoluteAffineUp: TAffineVector; var temp: TGLVector; begin temp := GetAbsoluteUp; Result := AffineVectorMake(temp.X, temp.Y, temp.Z); end; procedure TGLBaseSceneObject.SetAbsoluteAffinePosition(const Value: TAffineVector); begin SetAbsolutePosition(VectorMake(Value, 1)); end; procedure TGLBaseSceneObject.SetAbsoluteAffineUp(const v: TAffineVector); begin SetAbsoluteUp(VectorMake(v, 1)); end; procedure TGLBaseSceneObject.SetAbsoluteAffineDirection(const v: TAffineVector); begin SetAbsoluteDirection(VectorMake(v, 1)); end; function TGLBaseSceneObject.AffineLeftVector: TAffineVector; begin Result := AffineVectorMake(LeftVector); end; function TGLBaseSceneObject.AffineRight: TAffineVector; begin Result := AffineVectorMake(Right); end; function TGLBaseSceneObject.DistanceTo(const pt: TAffineVector): Single; begin Result := VectorDistance(AbsoluteAffinePosition, pt); end; function TGLBaseSceneObject.SqrDistanceTo(const pt: TAffineVector): Single; begin Result := VectorDistance2(AbsoluteAffinePosition, pt); end; procedure TGLBaseSceneObject.DoOnAddedToParent; begin if Assigned(FOnAddedToParent) then FOnAddedToParent(self); end; function TGLBaseSceneObject.GetAbsoluteAffineScale: TAffineVector; begin Result := AffineVectorMake(GetAbsoluteScale); end; procedure TGLBaseSceneObject.SetAbsoluteAffineScale( const Value: TAffineVector); begin SetAbsoluteScale(VectorMake(Value, GetAbsoluteScale.W)); end; // ------------------ // ------------------ TGLBaseBehaviour ------------------ // ------------------ constructor TGLBaseBehaviour.Create(aOwner: TXCollection); begin inherited Create(aOwner); // nothing more, yet end; destructor TGLBaseBehaviour.Destroy; begin // nothing more, yet inherited Destroy; end; procedure TGLBaseBehaviour.SetName(const val: string); begin inherited SetName(val); if Assigned(vGLBehaviourNameChangeEvent) then vGLBehaviourNameChangeEvent(Self); end; procedure TGLBaseBehaviour.WriteToFiler(writer: TWriter); begin inherited; with writer do begin WriteInteger(0); // Archive Version 0 // nothing more, yet end; end; procedure TGLBaseBehaviour.ReadFromFiler(reader: TReader); begin if Owner.ArchiveVersion > 0 then inherited; with reader do begin if ReadInteger <> 0 then Assert(False); // nothing more, yet end; end; function TGLBaseBehaviour.OwnerBaseSceneObject: TGLBaseSceneObject; begin Result := TGLBaseSceneObject(Owner.Owner); end; procedure TGLBaseBehaviour.DoProgress(const progressTime: TGLProgressTimes); begin // does nothing end; // ------------------ // ------------------ TGLBehaviours ------------------ // ------------------ constructor TGLBehaviours.Create(aOwner: TPersistent); begin Assert(aOwner is TGLBaseSceneObject); inherited Create(aOwner); end; function TGLBehaviours.GetNamePath: string; var s: string; begin Result := ClassName; if GetOwner = nil then Exit; s := GetOwner.GetNamePath; if s = '' then Exit; Result := s + '.Behaviours'; end; class function TGLBehaviours.ItemsClass: TXCollectionItemClass; begin Result := TGLBehaviour; end; function TGLBehaviours.GetBehaviour(index: Integer): TGLBehaviour; begin Result := TGLBehaviour(Items[index]); end; function TGLBehaviours.CanAdd(aClass: TXCollectionItemClass): Boolean; begin Result := (not aClass.InheritsFrom(TGLEffect)) and (inherited CanAdd(aClass)); end; procedure TGLBehaviours.DoProgress(const progressTimes: TGLProgressTimes); var i: Integer; begin for i := 0 to Count - 1 do TGLBehaviour(Items[i]).DoProgress(progressTimes); end; // ------------------ // ------------------ TGLEffect ------------------ // ------------------ procedure TGLEffect.WriteToFiler(writer: TWriter); begin inherited; with writer do begin WriteInteger(0); // Archive Version 0 // nothing more, yet end; end; procedure TGLEffect.ReadFromFiler(reader: TReader); begin if Owner.ArchiveVersion > 0 then inherited; with reader do begin if ReadInteger <> 0 then Assert(False); // nothing more, yet end; end; procedure TGLEffect.Render(var rci: TGLRenderContextInfo); begin // nothing here, this implem is just to avoid "abstract error" end; // ------------------ // ------------------ TGLEffects ------------------ // ------------------ constructor TGLEffects.Create(aOwner: TPersistent); begin Assert(aOwner is TGLBaseSceneObject); inherited Create(aOwner); end; function TGLEffects.GetNamePath: string; var s: string; begin Result := ClassName; if GetOwner = nil then Exit; s := GetOwner.GetNamePath; if s = '' then Exit; Result := s + '.Effects'; end; class function TGLEffects.ItemsClass: TXCollectionItemClass; begin Result := TGLEffect; end; function TGLEffects.GetEffect(index: Integer): TGLEffect; begin Result := TGLEffect(Items[index]); end; function TGLEffects.CanAdd(aClass: TXCollectionItemClass): Boolean; begin Result := (aClass.InheritsFrom(TGLEffect)) and (inherited CanAdd(aClass)); end; procedure TGLEffects.DoProgress(const progressTime: TGLProgressTimes); var i: Integer; begin for i := 0 to Count - 1 do TGLEffect(Items[i]).DoProgress(progressTime); end; procedure TGLEffects.RenderPreEffects(var rci: TGLRenderContextInfo); var i: Integer; effect: TGLEffect; begin for i := 0 to Count - 1 do begin effect := TGLEffect(Items[i]); if effect is TGLObjectPreEffect then effect.Render(rci); end; end; procedure TGLEffects.RenderPostEffects(var rci: TGLRenderContextInfo); var i: Integer; effect: TGLEffect; begin for i := 0 to Count - 1 do begin effect := TGLEffect(Items[i]); if effect is TGLObjectPostEffect then effect.Render(rci) else if Assigned(rci.afterRenderEffects) and (effect is TGLObjectAfterEffect) then rci.afterRenderEffects.Add(effect); end; end; // ------------------ // ------------------ TGLCustomSceneObject ------------------ // ------------------ constructor TGLCustomSceneObject.Create(AOwner: TComponent); begin inherited Create(AOwner); FMaterial := TGLMaterial.Create(Self); end; destructor TGLCustomSceneObject.Destroy; begin inherited Destroy; FMaterial.Free; end; procedure TGLCustomSceneObject.Assign(Source: TPersistent); begin if Source is TGLCustomSceneObject then begin FMaterial.Assign(TGLCustomSceneObject(Source).FMaterial); FHint := TGLCustomSceneObject(Source).FHint; end; inherited Assign(Source); end; function TGLCustomSceneObject.Blended: Boolean; begin Result := Material.Blended; end; procedure TGLCustomSceneObject.Loaded; begin inherited; FMaterial.Loaded; end; procedure TGLCustomSceneObject.SetGLMaterial(AValue: TGLMaterial); begin FMaterial.Assign(AValue); NotifyChange(Self); end; procedure TGLCustomSceneObject.DestroyHandle; begin inherited; FMaterial.DestroyHandles; end; procedure TGLCustomSceneObject.DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); begin // start rendering self if ARenderSelf then if ARci.ignoreMaterials then if (osDirectDraw in ObjectStyle) or ARci.amalgamating then BuildList(ARci) else ARci.GLStates.CallList(GetHandle(ARci)) else begin FMaterial.Apply(ARci); repeat if (osDirectDraw in ObjectStyle) or ARci.amalgamating then BuildList(ARci) else ARci.GLStates.CallList(GetHandle(ARci)); until not FMaterial.UnApply(ARci); end; // start rendering children (if any) if ARenderChildren then Self.RenderChildren(0, Count - 1, ARci); end; // ------------------ // ------------------ TGLSceneRootObject ------------------ // ------------------ constructor TGLSceneRootObject.Create(AOwner: TComponent); begin Assert(AOwner is TGLScene); inherited Create(AOwner); ObjectStyle := ObjectStyle + [osDirectDraw]; FScene := TGLScene(AOwner); end; // ------------------ // ------------------ TGLCamera ------------------ // ------------------ constructor TGLCamera.Create(aOwner: TComponent); begin inherited Create(aOwner); FFocalLength := 50; FDepthOfView := 100; FNearPlaneBias := 1; FDirection.Initialize(VectorMake(0, 0, -1, 0)); FCameraStyle := csPerspective; FSceneScale := 1; FDesign := False; FFOVY := -1; FKeepFOVMode := ckmHorizontalFOV; end; destructor TGLCamera.Destroy; begin TargetObject := nil; inherited; end; procedure TGLCamera.Assign(Source: TPersistent); var cam: TGLCamera; dir: TGLVector; begin if Assigned(Source) then begin inherited Assign(Source); if Source is TGLCamera then begin cam := TGLCamera(Source); SetDepthOfView(cam.DepthOfView); SetFocalLength(cam.FocalLength); SetCameraStyle(cam.CameraStyle); SetSceneScale(cam.SceneScale); SetNearPlaneBias(cam.NearPlaneBias); SetScene(cam.Scene); SetKeepFOVMode(cam.FKeepFOVMode); if Parent <> nil then begin SetTargetObject(cam.TargetObject); end else // Design camera begin Position.AsVector := cam.AbsolutePosition; if Assigned(cam.TargetObject) then begin VectorSubtract(cam.TargetObject.AbsolutePosition, AbsolutePosition, dir); NormalizeVector(dir); Direction.AsVector := dir; end; end; end; end; end; function TGLCamera.AbsoluteVectorToTarget: TGLVector; begin if TargetObject <> nil then begin VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition, Result); NormalizeVector(Result); end else Result := AbsoluteDirection; end; function TGLCamera.AbsoluteRightVectorToTarget: TGLVector; begin if TargetObject <> nil then begin VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition, Result); Result := VectorCrossProduct(Result, AbsoluteUp); NormalizeVector(Result); end else Result := AbsoluteRight; end; function TGLCamera.AbsoluteUpVectorToTarget: TGLVector; begin if TargetObject <> nil then Result := VectorCrossProduct(AbsoluteRightVectorToTarget, AbsoluteVectorToTarget) else Result := AbsoluteUp; end; procedure TGLCamera.Apply; var v, d, v2: TGLVector; absPos: TGLVector; LM, mat: TGLMatrix; begin if Assigned(FDeferredApply) then FDeferredApply(Self) else begin if Assigned(FTargetObject) then begin v := TargetObject.AbsolutePosition; absPos := AbsolutePosition; VectorSubtract(v, absPos, d); NormalizeVector(d); FLastDirection := d; LM := CreateLookAtMatrix(absPos, v, Up.AsVector); end else begin if Assigned(Parent) then mat := Parent.AbsoluteMatrix else mat := IdentityHmgMatrix; absPos := AbsolutePosition; v := VectorTransform(Direction.AsVector, mat); FLastDirection := v; d := VectorTransform(Up.AsVector, mat); v2 := VectorAdd(absPos, v); LM := CreateLookAtMatrix(absPos, v2, d); end; with CurrentGLContext.PipelineTransformation do SetViewMatrix(MatrixMultiply(LM, ViewMatrix^)); ClearStructureChanged; end; end; procedure TGLCamera.ApplyPerspective(const AViewport: TRectangle; AWidth, AHeight: Integer; ADPI: Integer); var vLeft, vRight, vBottom, vTop, vFar: Single; MaxDim, Ratio, f: Double; xmax, ymax: Double; mat: TGLMatrix; const cEpsilon: Single = 1e-4; function IsPerspective(CamStyle: TGLCameraStyle): Boolean; begin Result := CamStyle in [csPerspective, csInfinitePerspective, csPerspectiveKeepFOV]; end; begin if (AWidth <= 0) or (AHeight <= 0) then Exit; if CameraStyle = csOrtho2D then begin vLeft := 0; vRight := AWidth; vBottom := 0; vTop := AHeight; FNearPlane := -1; vFar := 1; mat := CreateOrthoMatrix(vLeft, vRight, vBottom, vTop, FNearPlane, vFar); with CurrentGLContext.PipelineTransformation do SetProjectionMatrix(MatrixMultiply(mat, ProjectionMatrix^)); FViewPortRadius := VectorLength(AWidth, AHeight) / 2; end else if CameraStyle = csCustom then begin FViewPortRadius := VectorLength(AWidth, AHeight) / 2; if Assigned(FOnCustomPerspective) then FOnCustomPerspective(AViewport, AWidth, AHeight, ADPI, FViewPortRadius); end else begin // determine biggest dimension and resolution (height or width) MaxDim := AWidth; if AHeight > MaxDim then MaxDim := AHeight; // calculate near plane distance and extensions; // Scene ratio is determined by the window ratio. The viewport is just a // specific part of the entire window and has therefore no influence on the // scene ratio. What we need to know, though, is the ratio between the window // borders (left, top, right and bottom) and the viewport borders. // Note: viewport.top is actually bottom, because the window (and viewport) origin // in OGL is the lower left corner if IsPerspective(CameraStyle) then f := FNearPlaneBias / (AWidth * FSceneScale) else f := 100 * FNearPlaneBias / (focalLength * AWidth * FSceneScale); // calculate window/viewport ratio for right extent Ratio := (2 * AViewport.Width + 2 * AViewport.Left - AWidth) * f; // calculate aspect ratio correct right value of the view frustum and take // the window/viewport ratio also into account vRight := Ratio * AWidth / (2 * MaxDim); // the same goes here for the other three extents // left extent: Ratio := (AWidth - 2 * AViewport.Left) * f; vLeft := -Ratio * AWidth / (2 * MaxDim); if IsPerspective(CameraStyle) then f := FNearPlaneBias / (AHeight * FSceneScale) else f := 100 * FNearPlaneBias / (focalLength * AHeight * FSceneScale); // top extent (keep in mind the origin is left lower corner): Ratio := (2 * AViewport.Height + 2 * AViewport.Top - AHeight) * f; vTop := Ratio * AHeight / (2 * MaxDim); // bottom extent: Ratio := (AHeight - 2 * AViewport.Top) * f; vBottom := -Ratio * AHeight / (2 * MaxDim); FNearPlane := FFocalLength * 2 * ADPI / (25.4 * MaxDim) * FNearPlaneBias; vFar := FNearPlane + FDepthOfView; // finally create view frustum (perspective or orthogonal) case CameraStyle of csPerspective: begin mat := CreateMatrixFromFrustum(vLeft, vRight, vBottom, vTop, FNearPlane, vFar); end; csPerspectiveKeepFOV: begin if FFOVY < 0 then // Need Update FOV begin FFOVY := ArcTan2(vTop - vBottom, 2 * FNearPlane) * 2; FFOVX := ArcTan2(vRight - vLeft, 2 * FNearPlane) * 2; end; case FKeepFOVMode of ckmVerticalFOV: begin ymax := FNearPlane * Tan(FFOVY / 2); xmax := ymax * AWidth / AHeight; end; ckmHorizontalFOV: begin xmax := FNearPlane * Tan(FFOVX / 2); ymax := xmax * AHeight / AWidth; end; else begin xmax := 0; ymax := 0; Assert(False, 'Unknown keep camera angle mode'); end; end; mat := CreateMatrixFromFrustum(-xmax, xmax, -ymax, ymax, FNearPlane, vFar); end; csInfinitePerspective: begin mat := IdentityHmgMatrix; mat.X.X := 2 * FNearPlane / (vRight - vLeft); mat.Y.Y := 2 * FNearPlane / (vTop - vBottom); mat.Z.X := (vRight + vLeft) / (vRight - vLeft); mat.Z.Y := (vTop + vBottom) / (vTop - vBottom); mat.Z.Z := cEpsilon - 1; mat.Z.W := -1; mat.W.Z := FNearPlane * (cEpsilon - 2); mat.W.W := 0; end; csOrthogonal: begin mat := CreateOrthoMatrix(vLeft, vRight, vBottom, vTop, FNearPlane, vFar); end; else Assert(False); end; with CurrentGLContext.PipelineTransformation do SetProjectionMatrix(MatrixMultiply(mat, ProjectionMatrix^)); FViewPortRadius := VectorLength(vRight, vTop) / FNearPlane end; end; //------------------------------------------------------------------------------ procedure TGLCamera.AutoLeveling(Factor: Single); var rightVector, rotAxis: TGLVector; angle: Single; begin angle := RadToDeg(ArcCos(VectorDotProduct(FUp.AsVector, YVector))); rotAxis := VectorCrossProduct(YHmgVector, FUp.AsVector); if (angle > 1) and (VectorLength(rotAxis) > 0) then begin rightVector := VectorCrossProduct(FDirection.AsVector, FUp.AsVector); FUp.Rotate(AffineVectorMake(rotAxis), Angle / (10 * Factor)); FUp.Normalize; // adjust local coordinates FDirection.DirectVector := VectorCrossProduct(FUp.AsVector, rightVector); FRotation.Z := -RadToDeg(ArcTan2(RightVector.Y, VectorLength(RightVector.X, RightVector.Z))); end; end; //------------------------------------------------------------------------------ procedure TGLCamera.Notification(AComponent: TComponent; Operation: TOperation); begin if (Operation = opRemove) and (AComponent = FTargetObject) then TargetObject := nil; inherited; end; procedure TGLCamera.SetTargetObject(const val: TGLBaseSceneObject); begin if (FTargetObject <> val) then begin if Assigned(FTargetObject) then FTargetObject.RemoveFreeNotification(Self); FTargetObject := val; if Assigned(FTargetObject) then FTargetObject.FreeNotification(Self); if not (csLoading in ComponentState) then TransformationChanged; end; end; procedure TGLCamera.Reset(aSceneBuffer: TGLSceneBuffer); var Extent: Single; begin FRotation.Z := 0; FFocalLength := 50; with aSceneBuffer do begin ApplyPerspective(FViewport, FViewport.Width, FViewport.Height, FRenderDPI); FUp.DirectVector := YHmgVector; if FViewport.Height < FViewport.Width then Extent := FViewport.Height * 0.25 else Extent := FViewport.Width * 0.25; end; FPosition.SetPoint(0, 0, FNearPlane * Extent); FDirection.SetVector(0, 0, -1, 0); TransformationChanged; end; procedure TGLCamera.ZoomAll(aSceneBuffer: TGLSceneBuffer); var extent: Single; begin with aSceneBuffer do begin if FViewport.Height < FViewport.Width then Extent := FViewport.Height * 0.25 else Extent := FViewport.Width * 0.25; FPosition.DirectVector := NullHmgPoint; Move(-FNearPlane * Extent); // let the camera look at the scene center FDirection.SetVector(-FPosition.X, -FPosition.Y, -FPosition.Z, 0); end; end; procedure TGLCamera.RotateObject(obj: TGLBaseSceneObject; pitchDelta, turnDelta: Single; rollDelta: Single = 0); var resMat: TGLMatrix; vDir, vUp, vRight: TGLVector; v: TAffineVector; position1: TGLVector; Scale1: TGLVector; begin // First we need to compute the actual camera's vectors, which may not be // directly available if we're in "targeting" mode vUp := AbsoluteUp; if TargetObject <> nil then begin vDir := AbsoluteVectorToTarget; vRight := VectorCrossProduct(vDir, vUp); vUp := VectorCrossProduct(vRight, vDir); end else begin vDir := AbsoluteDirection; vRight := VectorCrossProduct(vDir, vUp); end; //save scale & position info Scale1 := obj.Scale.AsVector; position1 := obj.Position.asVector; resMat := obj.Matrix^; //get rid of scaling & location info NormalizeMatrix(resMat); // Now we build rotation matrices and use them to rotate the obj if rollDelta <> 0 then begin SetVector(v, obj.AbsoluteToLocal(vDir)); resMat := MatrixMultiply(CreateRotationMatrix(v, DegToRadian(rollDelta)), resMat); end; if turnDelta <> 0 then begin SetVector(v, obj.AbsoluteToLocal(vUp)); resMat := MatrixMultiply(CreateRotationMatrix(v, DegToRadian(turnDelta)), resMat); end; if pitchDelta <> 0 then begin SetVector(v, obj.AbsoluteToLocal(vRight)); resMat := MatrixMultiply(CreateRotationMatrix(v, DegToRadian(pitchDelta)), resMat); end; obj.SetMatrix(resMat); //restore scaling & rotation info obj.Scale.AsVector := Scale1; obj.Position.AsVector := Position1; end; procedure TGLCamera.RotateTarget(pitchDelta, turnDelta: Single; rollDelta: Single = 0); begin if Assigned(FTargetObject) then RotateObject(FTargetObject, pitchDelta, turnDelta, rollDelta) end; procedure TGLCamera.MoveAroundTarget(pitchDelta, turnDelta: Single); begin MoveObjectAround(FTargetObject, pitchDelta, turnDelta); end; procedure TGLCamera.MoveAllAroundTarget(pitchDelta, turnDelta :Single); begin MoveObjectAllAround(FTargetObject, pitchDelta, turnDelta); end; procedure TGLCamera.MoveInEyeSpace(forwardDistance, rightDistance, upDistance: Single); var trVector: TGLVector; begin trVector := AbsoluteEyeSpaceVector(forwardDistance, rightDistance, upDistance); if Assigned(Parent) then Position.Translate(Parent.AbsoluteToLocal(trVector)) else Position.Translate(trVector); end; procedure TGLCamera.MoveTargetInEyeSpace(forwardDistance, rightDistance, upDistance: Single); var trVector: TGLVector; begin if TargetObject <> nil then begin trVector := AbsoluteEyeSpaceVector(forwardDistance, rightDistance, upDistance); TargetObject.Position.Translate(TargetObject.Parent.AbsoluteToLocal(trVector)); end; end; function TGLCamera.AbsoluteEyeSpaceVector(forwardDistance, rightDistance, upDistance: Single): TGLVector; begin Result := NullHmgVector; if forwardDistance <> 0 then CombineVector(Result, AbsoluteVectorToTarget, forwardDistance); if rightDistance <> 0 then CombineVector(Result, AbsoluteRightVectorToTarget, rightDistance); if upDistance <> 0 then CombineVector(Result, AbsoluteUpVectorToTarget, upDistance); end; procedure TGLCamera.AdjustDistanceToTarget(distanceRatio: Single); var vect: TGLVector; begin if Assigned(FTargetObject) then begin // calculate vector from target to camera in absolute coordinates vect := VectorSubtract(AbsolutePosition, TargetObject.AbsolutePosition); // ratio -> translation vector ScaleVector(vect, -(1 - distanceRatio)); AddVector(vect, AbsolutePosition); if Assigned(Parent) then vect := Parent.AbsoluteToLocal(vect); Position.AsVector := vect; end; end; function TGLCamera.DistanceToTarget: Single; var vect: TGLVector; begin if Assigned(FTargetObject) then begin vect := VectorSubtract(AbsolutePosition, TargetObject.AbsolutePosition); Result := VectorLength(vect); end else Result := 1; end; function TGLCamera.ScreenDeltaToVector(deltaX, deltaY: Integer; ratio: Single; const planeNormal: TGLVector): TGLVector; var screenY, screenX: TGLVector; screenYoutOfPlaneComponent: Single; begin // calculate projection of direction vector on the plane if Assigned(FTargetObject) then screenY := VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition) else screenY := Direction.AsVector; screenYoutOfPlaneComponent := VectorDotProduct(screenY, planeNormal); screenY := VectorCombine(screenY, planeNormal, 1, -screenYoutOfPlaneComponent); NormalizeVector(screenY); // calc the screenX vector screenX := VectorCrossProduct(screenY, planeNormal); // and here, we're done Result := VectorCombine(screenX, screenY, deltaX * ratio, deltaY * ratio); end; function TGLCamera.ScreenDeltaToVectorXY(deltaX, deltaY: Integer; ratio: Single): TGLVector; var screenY: TGLVector; dxr, dyr, d: Single; begin // calculate projection of direction vector on the plane if Assigned(FTargetObject) then screenY := VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition) else screenY := Direction.AsVector; d := VectorLength(screenY.X, screenY.Y); if d <= 1e-10 then d := ratio else d := ratio / d; // and here, we're done dxr := deltaX * d; dyr := deltaY * d; Result.X := screenY.Y * dxr + screenY.X * dyr; Result.Y := screenY.Y * dyr - screenY.X * dxr; Result.Z := 0; Result.W := 0; end; function TGLCamera.ScreenDeltaToVectorXZ(deltaX, deltaY: Integer; ratio: Single): TGLVector; var screenY: TGLVector; d, dxr, dzr: Single; begin // calculate the projection of direction vector on the plane if Assigned(fTargetObject) then screenY := VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition) else screenY := Direction.AsVector; d := VectorLength(screenY.X, screenY.Z); if d <= 1e-10 then d := ratio else d := ratio / d; dxr := deltaX * d; dzr := deltaY * d; Result.X := -screenY.Z * dxr + screenY.X * dzr; Result.Y := 0; Result.Z := screenY.Z * dzr + screenY.X * dxr; Result.W := 0; end; function TGLCamera.ScreenDeltaToVectorYZ(deltaX, deltaY: Integer; ratio: Single): TGLVector; var screenY: TGLVector; d, dyr, dzr: single; begin // calculate the projection of direction vector on the plane if Assigned(fTargetObject) then screenY := VectorSubtract(TargetObject.AbsolutePosition, AbsolutePosition) else screenY := Direction.AsVector; d := VectorLength(screenY.Y, screenY.Z); if d <= 1e-10 then d := ratio else d := ratio / d; dyr := deltaX * d; dzr := deltaY * d; Result.X := 0; Result.Y := screenY.Z * dyr + screenY.Y * dzr; Result.Z := screenY.Z * dzr - screenY.Y * dyr; Result.W := 0; end; function TGLCamera.PointInFront(const point: TGLVector): boolean; begin result := PointIsInHalfSpace(point, AbsolutePosition, AbsoluteDirection); end; procedure TGLCamera.SetDepthOfView(AValue: Single); begin if FDepthOfView <> AValue then begin FDepthOfView := AValue; FFOVY := - 1; if not (csLoading in ComponentState) then TransformationChanged; end; end; procedure TGLCamera.SetFocalLength(AValue: Single); begin if AValue <= 0 then AValue := 1; if FFocalLength <> AValue then begin FFocalLength := AValue; FFOVY := - 1; if not (csLoading in ComponentState) then TransformationChanged; end; end; function TGLCamera.GetFieldOfView(const AViewportDimension: single): single; begin if FFocalLength = 0 then result := 0 else result := RadToDeg(2 * ArcTan2(AViewportDimension * 0.5, FFocalLength)); end; procedure TGLCamera.SetFieldOfView(const AFieldOfView, AViewportDimension: single); begin FocalLength := AViewportDimension / (2 * Tan(DegToRadian(AFieldOfView / 2))); end; procedure TGLCamera.SetCameraStyle(const val: TGLCameraStyle); begin if FCameraStyle <> val then begin FCameraStyle := val; FFOVY := -1; NotifyChange(Self); end; end; procedure TGLCamera.SetKeepFOVMode(const val: TGLCameraKeepFOVMode); begin if FKeepFOVMode <> val then begin FKeepFOVMode := val; FFOVY := -1; if FCameraStyle = csPerspectiveKeepFOV then NotifyChange(Self); end; end; procedure TGLCamera.SetSceneScale(value: Single); begin if value = 0 then value := 1; if FSceneScale <> value then begin FSceneScale := value; FFOVY := -1; NotifyChange(Self); end; end; function TGLCamera.StoreSceneScale: Boolean; begin Result := (FSceneScale <> 1); end; procedure TGLCamera.SetNearPlaneBias(value: Single); begin if value <= 0 then value := 1; if FNearPlaneBias <> value then begin FNearPlaneBias := value; FFOVY := -1; NotifyChange(Self); end; end; function TGLCamera.StoreNearPlaneBias: Boolean; begin Result := (FNearPlaneBias <> 1); end; procedure TGLCamera.DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); begin if ARenderChildren and (Count > 0) then Self.RenderChildren(0, Count - 1, ARci); end; function TGLCamera.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; begin Result := False; end; // ------------------ // ------------------ TGLImmaterialSceneObject ------------------ // ------------------ procedure TGLImmaterialSceneObject.DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); begin // start rendering self if ARenderSelf then begin if (osDirectDraw in ObjectStyle) or ARci.amalgamating then BuildList(ARci) else ARci.GLStates.CallList(GetHandle(ARci)); end; // start rendering children (if any) if ARenderChildren then Self.RenderChildren(0, Count - 1, ARci); end; // ------------------ // ------------------ TGLCameraInvariantObject ------------------ // ------------------ constructor TGLCameraInvariantObject.Create(AOwner: TComponent); begin inherited; FCamInvarianceMode := cimNone; end; procedure TGLCameraInvariantObject.Assign(Source: TPersistent); begin if Source is TGLCameraInvariantObject then begin FCamInvarianceMode := TGLCameraInvariantObject(Source).FCamInvarianceMode; end; inherited Assign(Source); end; procedure TGLCameraInvariantObject.DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); begin if CamInvarianceMode <> cimNone then with ARci.PipelineTransformation do begin Push; //try // prepare case CamInvarianceMode of cimPosition: begin SetViewMatrix(MatrixMultiply( CreateTranslationMatrix(ARci.cameraPosition), ARci.PipelineTransformation.ViewMatrix^)); end; cimOrientation: begin // makes the coordinates system more 'intuitive' (Z+ forward) SetViewMatrix(CreateScaleMatrix(Vector3fMake(1, -1, -1))) end; else Assert(False); end; // Apply local transform SetModelMatrix(LocalMatrix^); if ARenderSelf then begin if (osDirectDraw in ObjectStyle) or ARci.amalgamating then BuildList(ARci) else ARci.GLStates.CallList(GetHandle(ARci)); end; if ARenderChildren then Self.RenderChildren(0, Count - 1, ARci); //finally Pop; //end; end else inherited; end; procedure TGLCameraInvariantObject.SetCamInvarianceMode(const val: TGLCameraInvarianceMode); begin if FCamInvarianceMode <> val then begin FCamInvarianceMode := val; NotifyChange(Self); end; end; // ------------------ // ------------------ TGLDirectOpenGL ------------------ // ------------------ constructor TGLDirectOpenGL.Create(AOwner: TComponent); begin inherited; ObjectStyle := ObjectStyle + [osDirectDraw]; FBlend := False; end; procedure TGLDirectOpenGL.Assign(Source: TPersistent); begin if Source is TGLDirectOpenGL then begin UseBuildList := TGLDirectOpenGL(Source).UseBuildList; FOnRender := TGLDirectOpenGL(Source).FOnRender; FBlend := TGLDirectOpenGL(Source).Blend; end; inherited Assign(Source); end; procedure TGLDirectOpenGL.BuildList(var rci: TGLRenderContextInfo); begin if Assigned(FOnRender) then begin xgl.MapTexCoordToMain; // single texturing by default OnRender(Self, rci); end; end; function TGLDirectOpenGL.AxisAlignedDimensionsUnscaled: TGLVector; begin Result := NullHmgPoint; end; procedure TGLDirectOpenGL.SetUseBuildList(const val: Boolean); begin if val <> FUseBuildList then begin FUseBuildList := val; if val then ObjectStyle := ObjectStyle - [osDirectDraw] else ObjectStyle := ObjectStyle + [osDirectDraw]; end; end; function TGLDirectOpenGL.Blended: Boolean; begin Result := FBlend; end; procedure TGLDirectOpenGL.SetBlend(const val: Boolean); begin if val <> FBlend then begin FBlend := val; StructureChanged; end; end; // ------------------ // ------------------ TGLRenderPoint ------------------ // ------------------ constructor TGLRenderPoint.Create(AOwner: TComponent); begin inherited; ObjectStyle := ObjectStyle + [osDirectDraw]; end; destructor TGLRenderPoint.Destroy; begin Clear; inherited; end; procedure TGLRenderPoint.BuildList(var rci: TGLRenderContextInfo); var i: Integer; begin for i := 0 to High(FCallBacks) do FCallBacks[i](Self, rci); end; procedure TGLRenderPoint.RegisterCallBack(renderEvent: TGLDirectRenderEvent; renderPointFreed: TNotifyEvent); var n: Integer; begin n := Length(FCallBacks); SetLength(FCallBacks, n + 1); SetLength(FFreeCallBacks, n + 1); FCallBacks[n] := renderEvent; FFreeCallBacks[n] := renderPointFreed; end; procedure TGLRenderPoint.UnRegisterCallBack(renderEvent: TGLDirectRenderEvent); type TEventContainer = record event: TGLDirectRenderEvent; end; var i, j, n: Integer; refContainer, listContainer: TEventContainer; begin refContainer.event := renderEvent; n := Length(FCallBacks); for i := 0 to n - 1 do begin listContainer.event := FCallBacks[i]; if CompareMem(@listContainer, @refContainer, SizeOf(TEventContainer)) then begin for j := i + 1 to n - 1 do begin FCallBacks[j - 1] := FCallBacks[j]; FFreeCallBacks[j - 1] := FFreeCallBacks[j]; end; SetLength(FCallBacks, n - 1); SetLength(FFreeCallBacks, n - 1); Break; end; end; end; procedure TGLRenderPoint.Clear; begin while Length(FCallBacks) > 0 do begin FFreeCallBacks[High(FCallBacks)](Self); SetLength(FCallBacks, Length(FCallBacks) - 1); end; end; // ------------------ // ------------------ TGLProxyObject ------------------ // ------------------ constructor TGLProxyObject.Create(AOwner: TComponent); begin inherited; FProxyOptions := cDefaultProxyOptions; end; destructor TGLProxyObject.Destroy; begin SetMasterObject(nil); inherited; end; procedure TGLProxyObject.Assign(Source: TPersistent); begin if Source is TGLProxyObject then begin SetMasterObject(TGLProxyObject(Source).MasterObject); end; inherited Assign(Source); end; procedure TGLProxyObject.DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); var gotMaster, masterGotEffects, oldProxySubObject: Boolean; begin if FRendering then Exit; FRendering := True; try gotMaster := Assigned(FMasterObject); masterGotEffects := gotMaster and (pooEffects in FProxyOptions) and (FMasterObject.Effects.Count > 0); if gotMaster then begin if pooObjects in FProxyOptions then begin oldProxySubObject := ARci.proxySubObject; ARci.proxySubObject := True; if pooTransformation in FProxyOptions then with ARci.PipelineTransformation do SetModelMatrix(MatrixMultiply(FMasterObject.Matrix^, ModelMatrix^)); FMasterObject.DoRender(ARci, ARenderSelf, (FMasterObject.Count > 0)); ARci.proxySubObject := oldProxySubObject; end; end; // now render self stuff (our children, our effects, etc.) if ARenderChildren and (Count > 0) then Self.RenderChildren(0, Count - 1, ARci); if masterGotEffects then FMasterObject.Effects.RenderPostEffects(ARci); finally FRendering := False; end; ClearStructureChanged; end; function TGLProxyObject.AxisAlignedDimensions: TGLVector; begin If Assigned(FMasterObject) then begin Result := FMasterObject.AxisAlignedDimensionsUnscaled; If (pooTransformation in ProxyOptions) then ScaleVector(Result,FMasterObject.Scale.AsVector) else ScaleVector(Result, Scale.AsVector); end else Result := inherited AxisAlignedDimensions; end; function TGLProxyObject.AxisAlignedDimensionsUnscaled: TGLVector; begin if Assigned(FMasterObject) then begin Result := FMasterObject.AxisAlignedDimensionsUnscaled; end else Result := inherited AxisAlignedDimensionsUnscaled; end; function TGLProxyObject.BarycenterAbsolutePosition: TGLVector; var lAdjustVector: TGLVector; begin if Assigned(FMasterObject) then begin // Not entirely correct, but better than nothing... lAdjustVector := VectorSubtract(FMasterObject.BarycenterAbsolutePosition, FMasterObject.AbsolutePosition); Position.AsVector := VectorAdd(Position.AsVector, lAdjustVector); Result := AbsolutePosition; Position.AsVector := VectorSubtract(Position.AsVector, lAdjustVector); end else Result := inherited BarycenterAbsolutePosition; end; procedure TGLProxyObject.Notification(AComponent: TComponent; Operation: TOperation); begin if (Operation = opRemove) and (AComponent = FMasterObject) then MasterObject := nil; inherited; end; procedure TGLProxyObject.SetMasterObject(const val: TGLBaseSceneObject); begin if FMasterObject <> val then begin if Assigned(FMasterObject) then FMasterObject.RemoveFreeNotification(Self); FMasterObject := val; if Assigned(FMasterObject) then FMasterObject.FreeNotification(Self); StructureChanged; end; end; procedure TGLProxyObject.SetProxyOptions(const val: TGLProxyObjectOptions); begin if FProxyOptions <> val then begin FProxyOptions := val; StructureChanged; end; end; function TGLProxyObject.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; var localRayStart, localRayVector: TGLVector; begin if Assigned(MasterObject) then begin SetVector(localRayStart, AbsoluteToLocal(rayStart)); SetVector(localRayStart, MasterObject.LocalToAbsolute(localRayStart)); SetVector(localRayVector, AbsoluteToLocal(rayVector)); SetVector(localRayVector, MasterObject.LocalToAbsolute(localRayVector)); NormalizeVector(localRayVector); Result := MasterObject.RayCastIntersect(localRayStart, localRayVector, intersectPoint, intersectNormal); if Result then begin if Assigned(intersectPoint) then begin SetVector(intersectPoint^, MasterObject.AbsoluteToLocal(intersectPoint^)); SetVector(intersectPoint^, LocalToAbsolute(intersectPoint^)); end; if Assigned(intersectNormal) then begin SetVector(intersectNormal^, MasterObject.AbsoluteToLocal(intersectNormal^)); SetVector(intersectNormal^, LocalToAbsolute(intersectNormal^)); end; end; end else Result := False; end; function TGLProxyObject.GenerateSilhouette(const silhouetteParameters: TGLSilhouetteParameters): TGLSilhouette; begin if Assigned(MasterObject) then Result := MasterObject.GenerateSilhouette(silhouetteParameters) else Result := nil; end; // ------------------ // ------------------ TGLLightSource ------------------ // ------------------ constructor TGLLightSource.Create(AOwner: TComponent); begin inherited Create(AOwner); FShining := True; FSpotDirection := TGLCoordinates.CreateInitialized(Self, VectorMake(0, 0, -1, 0), csVector); FConstAttenuation := 1; FLinearAttenuation := 0; FQuadraticAttenuation := 0; FSpotCutOff := 180; FSpotExponent := 0; FLightStyle := lsSpot; FAmbient := TGLColor.Create(Self); FDiffuse := TGLColor.Create(Self); FDiffuse.Initialize(clrWhite); FSpecular := TGLColor.Create(Self); end; destructor TGLLightSource.Destroy; begin FSpotDirection.Free; FAmbient.Free; FDiffuse.Free; FSpecular.Free; inherited Destroy; end; procedure TGLLightSource.DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); begin if ARenderChildren and Assigned(FChildren) then Self.RenderChildren(0, Count - 1, ARci); end; function TGLLightSource.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; begin Result := False; end; procedure TGLLightSource.CoordinateChanged(Sender: TGLCustomCoordinates); begin inherited; if Sender = FSpotDirection then TransformationChanged; end; function TGLLightSource.GenerateSilhouette(const silhouetteParameters: TGLSilhouetteParameters): TGLSilhouette; begin Result := nil; end; procedure TGLLightSource.SetShining(AValue: Boolean); begin if AValue <> FShining then begin FShining := AValue; NotifyChange(Self); end; end; procedure TGLLightSource.SetSpotDirection(AVector: TGLCoordinates); begin FSpotDirection.DirectVector := AVector.AsVector; FSpotDirection.W := 0; NotifyChange(Self); end; procedure TGLLightSource.SetSpotExponent(AValue: Single); begin if FSpotExponent <> AValue then begin FSpotExponent := AValue; NotifyChange(Self); end; end; procedure TGLLightSource.SetSpotCutOff(const val: Single); begin if FSpotCutOff <> val then begin if ((val >= 0) and (val <= 90)) or (val = 180) then begin FSpotCutOff := val; NotifyChange(Self); end; end; end; procedure TGLLightSource.SetLightStyle(const val: TGLLightStyle); begin if FLightStyle <> val then begin FLightStyle := val; NotifyChange(Self); end; end; procedure TGLLightSource.SetAmbient(AValue: TGLColor); begin FAmbient.Color := AValue.Color; NotifyChange(Self); end; procedure TGLLightSource.SetDiffuse(AValue: TGLColor); begin FDiffuse.Color := AValue.Color; NotifyChange(Self); end; procedure TGLLightSource.SetSpecular(AValue: TGLColor); begin FSpecular.Color := AValue.Color; NotifyChange(Self); end; procedure TGLLightSource.SetConstAttenuation(AValue: Single); begin if FConstAttenuation <> AValue then begin FConstAttenuation := AValue; NotifyChange(Self); end; end; procedure TGLLightSource.SetLinearAttenuation(AValue: Single); begin if FLinearAttenuation <> AValue then begin FLinearAttenuation := AValue; NotifyChange(Self); end; end; procedure TGLLightSource.SetQuadraticAttenuation(AValue: Single); begin if FQuadraticAttenuation <> AValue then begin FQuadraticAttenuation := AValue; NotifyChange(Self); end; end; function TGLLightSource.Attenuated: Boolean; begin Result := (LightStyle <> lsParallel) and ((ConstAttenuation <> 1) or (LinearAttenuation <> 0) or (QuadraticAttenuation <> 0)); end; // ------------------ // ------------------ TGLScene ------------------ // ------------------ constructor TGLScene.Create(AOwner: TComponent); begin inherited; // root creation FCurrentBuffer := nil; FObjects := TGLSceneRootObject.Create(Self); FObjects.Name := 'ObjectRoot'; FLights := TGLPersistentObjectList.Create; FObjectsSorting := osRenderBlendedLast; FVisibilityCulling := vcNone; // actual maximum number of lights is stored in TGLSceneViewer FLights.Count := 8; FInitializableObjects := TGLInitializableObjectList.Create; end; destructor TGLScene.Destroy; begin InitializableObjects.Free; FObjects.DestroyHandles; FLights.Free; FObjects.Free; if Assigned(FBuffers) then FreeAndNil(FBuffers); inherited Destroy; end; procedure TGLScene.AddLight(ALight: TGLLightSource); var i: Integer; begin for i := 0 to FLights.Count - 1 do if FLights.List^[i] = nil then begin FLights.List^[i] := ALight; ALight.FLightID := i; Break; end; end; procedure TGLScene.RemoveLight(ALight: TGLLightSource); var idx: Integer; begin idx := FLights.IndexOf(ALight); if idx >= 0 then FLights[idx] := nil; end; procedure TGLScene.AddLights(anObj: TGLBaseSceneObject); var i: Integer; begin if anObj is TGLLightSource then AddLight(TGLLightSource(anObj)); for i := 0 to anObj.Count - 1 do AddLights(anObj.Children[i]); end; procedure TGLScene.RemoveLights(anObj: TGLBaseSceneObject); var i: Integer; begin if anObj is TGLLightSource then RemoveLight(TGLLightSource(anObj)); for i := 0 to anObj.Count - 1 do RemoveLights(anObj.Children[i]); end; procedure TGLScene.ShutdownAllLights; procedure DoShutdownLight(Obj: TGLBaseSceneObject); var i: integer; begin if Obj is TGLLightSource then TGLLightSource(Obj).Shining := False; for i := 0 to Obj.Count - 1 do DoShutDownLight(Obj[i]); end; begin DoShutdownLight(FObjects); end; procedure TGLScene.AddBuffer(aBuffer: TGLSceneBuffer); begin if not Assigned(FBuffers) then FBuffers := TGLPersistentObjectList.Create; if FBuffers.IndexOf(aBuffer) < 0 then begin FBuffers.Add(aBuffer); if FBaseContext = nil then FBaseContext := TGLSceneBuffer(FBuffers[0]).RenderingContext; if (FBuffers.Count > 1) and Assigned(FBaseContext) then aBuffer.RenderingContext.ShareLists(FBaseContext); end; end; procedure TGLScene.RemoveBuffer(aBuffer: TGLSceneBuffer); var i: Integer; begin if Assigned(FBuffers) then begin i := FBuffers.IndexOf(aBuffer); if i >= 0 then begin if FBuffers.Count = 1 then begin FreeAndNil(FBuffers); FBaseContext := nil; end else begin FBuffers.Delete(i); FBaseContext := TGLSceneBuffer(FBuffers[0]).RenderingContext; end; end; end; end; procedure TGLScene.GetChildren(AProc: TGetChildProc; Root: TComponent); begin FObjects.GetChildren(AProc, Root); end; procedure TGLScene.SetChildOrder(AChild: TComponent; Order: Integer); begin (AChild as TGLBaseSceneObject).Index := Order; end; function TGLScene.IsUpdating: Boolean; begin Result := (FUpdateCount <> 0) or (csLoading in ComponentState) or (csDestroying in ComponentState); end; procedure TGLScene.BeginUpdate; begin Inc(FUpdateCount); end; procedure TGLScene.EndUpdate; begin Assert(FUpdateCount > 0); Dec(FUpdateCount); if FUpdateCount = 0 then NotifyChange(Self); end; procedure TGLScene.SetObjectsSorting(const val: TGLObjectsSorting); begin if FObjectsSorting <> val then begin if val = osInherited then FObjectsSorting := osRenderBlendedLast else FObjectsSorting := val; NotifyChange(Self); end; end; procedure TGLScene.SetVisibilityCulling(const val: TGLVisibilityCulling); begin if FVisibilityCulling <> val then begin if val = vcInherited then FVisibilityCulling := vcNone else FVisibilityCulling := val; NotifyChange(Self); end; end; procedure TGLScene.ReadState(Reader: TReader); var SaveRoot: TComponent; begin SaveRoot := Reader.Root; try if Owner <> nil then Reader.Root := Owner; inherited; finally Reader.Root := SaveRoot; end; end; procedure TGLScene.Progress(const deltaTime, newTime: Double); var pt: TGLProgressTimes; begin pt.deltaTime := deltaTime; pt.newTime := newTime; FCurrentDeltaTime := deltaTime; if Assigned(FOnBeforeProgress) then FOnBeforeProgress(Self, deltaTime, newTime); FObjects.DoProgress(pt); if Assigned(FOnProgress) then FOnProgress(Self, deltaTime, newTime); end; procedure TGLScene.SaveToFile(const fileName: string); var stream: TStream; begin stream := TFileStream.Create(fileName, fmCreate); try SaveToStream(stream); finally stream.Free; end; end; procedure TGLScene.LoadFromFile(const fileName: string); procedure CheckResFileStream(Stream: TStream); var N: Integer; B: Byte; begin N := Stream.Position; Stream.Read(B, Sizeof(B)); Stream.Position := N; if B = $FF then Stream.ReadResHeader; end; var stream: TStream; begin stream := TFileStream.Create(fileName, fmOpenRead); try CheckResFileStream(stream); LoadFromStream(stream); finally stream.Free; end; end; procedure TGLScene.SaveToTextFile(const fileName: string); var mem: TMemoryStream; fil: TStream; begin mem := TMemoryStream.Create; fil := TFileStream.Create(fileName, fmCreate); try SaveToStream(mem); mem.Position := 0; ObjectBinaryToText(mem, fil); finally fil.Free; mem.Free; end; end; procedure TGLScene.LoadFromTextFile(const fileName: string); var Mem: TMemoryStream; Fil: TStream; begin Mem := TMemoryStream.Create; Fil := TFileStream.Create(fileName, fmOpenRead); try ObjectTextToBinary(Fil, Mem); Mem.Position := 0; LoadFromStream(Mem); finally Fil.Free; Mem.Free; end; end; procedure TGLScene.LoadFromStream(aStream: TStream); var fixups: TStringList; i: Integer; obj: TGLBaseSceneObject; begin Fixups := TStringList.Create; try if Assigned(FBuffers) then begin for i := 0 to FBuffers.Count - 1 do Fixups.AddObject(TGLSceneBuffer(FBuffers[i]).Camera.Name, FBuffers[i]); end; ShutdownAllLights; // will remove Viewer from FBuffers Objects.DeleteChildren; aStream.ReadComponent(Self); for i := 0 to Fixups.Count - 1 do begin obj := FindSceneObject(fixups[I]); if obj is TGLCamera then TGLSceneBuffer(Fixups.Objects[i]).Camera := TGLCamera(obj) else { can assign default camera (if existing, of course) instead } ; end; finally Fixups.Free; end; end; procedure TGLScene.SaveToStream(aStream: TStream); begin aStream.WriteComponent(Self); end; function TGLScene.FindSceneObject(const AName: string): TGLBaseSceneObject; begin Result := FObjects.FindChild(AName, False); end; function TGLScene.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): TGLBaseSceneObject; var bestDist2: Single; bestHit: TGLBaseSceneObject; iPoint, iNormal: TGLVector; pINormal: PGLVector; function RecursiveDive(baseObject: TGLBaseSceneObject): TGLBaseSceneObject; var i: Integer; curObj: TGLBaseSceneObject; dist2: Single; fNear, fFar: single; begin Result := nil; for i := 0 to baseObject.Count - 1 do begin curObj := baseObject.Children[i]; if curObj.Visible then begin if RayCastAABBIntersect(rayStart, rayVector, curObj.AxisAlignedBoundingBoxAbsoluteEx, fNear, fFar) then begin if fnear * fnear > bestDist2 then begin if not PointInAABB(rayStart, curObj.AxisAlignedBoundingBoxAbsoluteEx) then continue; end; if curObj.RayCastIntersect(rayStart, rayVector, @iPoint, pINormal) then begin dist2 := VectorDistance2(rayStart, iPoint); if dist2 < bestDist2 then begin bestHit := curObj; bestDist2 := dist2; if Assigned(intersectPoint) then intersectPoint^ := iPoint; if Assigned(intersectNormal) then intersectNormal^ := iNormal; end; end; RecursiveDive(curObj); end; end; end; end; begin bestDist2 := 1e20; bestHit := nil; if Assigned(intersectNormal) then pINormal := @iNormal else pINormal := nil; RecursiveDive(Objects); Result := bestHit; end; procedure TGLScene.NotifyChange(Sender: TObject); var i: Integer; begin if (not IsUpdating) and Assigned(FBuffers) then for i := 0 to FBuffers.Count - 1 do TGLSceneBuffer(FBuffers[i]).NotifyChange(Self); end; procedure TGLScene.SetupLights(maxLights: Integer); var i: Integer; lightSource: TGLLightSource; nbLights: Integer; lPos: TGLVector; begin nbLights := FLights.Count; if nbLights > maxLights then nbLights := maxLights; // setup all light sources with CurrentGLContext.GLStates, CurrentGLContext.PipelineTransformation do begin for i := 0 to nbLights - 1 do begin lightSource := TGLLightSource(FLights[i]); if Assigned(lightSource) then with lightSource do begin LightEnabling[FLightID] := Shining; if Shining then begin if FixedFunctionPipeLight then begin RebuildMatrix; if LightStyle in [lsParallel, lsParallelSpot] then begin SetModelMatrix(AbsoluteMatrix); gl.Lightfv(GL_LIGHT0 + FLightID, GL_POSITION, SpotDirection.AsAddress); end else begin SetModelMatrix(Parent.AbsoluteMatrix); gl.Lightfv(GL_LIGHT0 + FLightID, GL_POSITION, Position.AsAddress); end; if LightStyle in [lsSpot, lsParallelSpot] then begin if FSpotCutOff <> 180 then gl.Lightfv(GL_LIGHT0 + FLightID, GL_SPOT_DIRECTION, FSpotDirection.AsAddress); end; end; lPos := lightSource.AbsolutePosition; if LightStyle in [lsParallel, lsParallelSpot] then lPos.W := 0.0 else lPos.W := 1.0; LightPosition[FLightID] := lPos; LightSpotDirection[FLightID] := lightSource.SpotDirection.AsAffineVector; LightAmbient[FLightID] := FAmbient.Color; LightDiffuse[FLightID] := FDiffuse.Color; LightSpecular[FLightID] := FSpecular.Color; LightConstantAtten[FLightID] := FConstAttenuation; LightLinearAtten[FLightID] := FLinearAttenuation; LightQuadraticAtten[FLightID] := FQuadraticAttenuation; LightSpotExponent[FLightID] := FSpotExponent; LightSpotCutoff[FLightID] := FSpotCutOff; end; end else LightEnabling[i] := False; end; // turn off other lights for i := nbLights to maxLights - 1 do LightEnabling[i] := False; SetModelMatrix(IdentityHmgMatrix); end; end; // ------------------ // ------------------ TGLFogEnvironment ------------------ // ------------------ // Note: The fog implementation is not conformal with the rest of the scene management // because it is viewer bound not scene bound. constructor TGLFogEnvironment.Create(AOwner: TPersistent); begin inherited; FSceneBuffer := (AOwner as TGLSceneBuffer); FFogColor := TGLColor.CreateInitialized(Self, clrBlack); FFogMode := fmLinear; FFogStart := 10; FFogEnd := 1000; FFogDistance := fdDefault; end; destructor TGLFogEnvironment.Destroy; begin FFogColor.Free; inherited Destroy; end; procedure TGLFogEnvironment.SetFogColor(Value: TGLColor); begin if Assigned(Value) then begin FFogColor.Assign(Value); NotifyChange(Self); end; end; procedure TGLFogEnvironment.SetFogStart(Value: Single); begin if Value <> FFogStart then begin FFogStart := Value; NotifyChange(Self); end; end; procedure TGLFogEnvironment.SetFogEnd(Value: Single); begin if Value <> FFogEnd then begin FFogEnd := Value; NotifyChange(Self); end; end; procedure TGLFogEnvironment.Assign(Source: TPersistent); begin if Source is TGLFogEnvironment then begin FFogColor.Assign(TGLFogEnvironment(Source).FFogColor); FFogStart := TGLFogEnvironment(Source).FFogStart; FFogEnd := TGLFogEnvironment(Source).FFogEnd; FFogMode := TGLFogEnvironment(Source).FFogMode; FFogDistance := TGLFogEnvironment(Source).FFogDistance; NotifyChange(Self); end; inherited; end; function TGLFogEnvironment.IsAtDefaultValues: Boolean; begin Result := VectorEquals(FogColor.Color, FogColor.DefaultColor) and (FogStart = 10) and (FogEnd = 1000) and (FogMode = fmLinear) and (FogDistance = fdDefault); end; procedure TGLFogEnvironment.SetFogMode(Value: TFogMode); begin if Value <> FFogMode then begin FFogMode := Value; NotifyChange(Self); end; end; procedure TGLFogEnvironment.SetFogDistance(const val: TFogDistance); begin if val <> FFogDistance then begin FFogDistance := val; NotifyChange(Self); end; end; var vImplemDependantFogDistanceDefault: Integer = -1; procedure TGLFogEnvironment.ApplyFog; var tempActivation: Boolean; begin with FSceneBuffer do begin if not Assigned(FRenderingContext) then Exit; tempActivation := not FRenderingContext.Active; if tempActivation then FRenderingContext.Activate; end; case FFogMode of fmLinear: gl.Fogi(GL_FOG_MODE, GL_LINEAR); fmExp: begin gl.Fogi(GL_FOG_MODE, GL_EXP); gl.Fogf(GL_FOG_DENSITY, FFogColor.Alpha); end; fmExp2: begin gl.Fogi(GL_FOG_MODE, GL_EXP2); gl.Fogf(GL_FOG_DENSITY, FFogColor.Alpha); end; end; gl.Fogfv(GL_FOG_COLOR, FFogColor.AsAddress); gl.Fogf(GL_FOG_START, FFogStart); gl.Fogf(GL_FOG_END, FFogEnd); if gl.NV_fog_distance then begin case FogDistance of fdDefault: begin if vImplemDependantFogDistanceDefault = -1 then gl.GetIntegerv(GL_FOG_DISTANCE_MODE_NV, @vImplemDependantFogDistanceDefault) else gl.Fogi(GL_FOG_DISTANCE_MODE_NV, vImplemDependantFogDistanceDefault); end; fdEyePlane: gl.Fogi(GL_FOG_DISTANCE_MODE_NV, GL_EYE_PLANE_ABSOLUTE_NV); fdEyeRadial: gl.Fogi(GL_FOG_DISTANCE_MODE_NV, GL_EYE_RADIAL_NV); else Assert(False); end; end; if tempActivation then FSceneBuffer.RenderingContext.Deactivate; end; // ------------------ // ------------------ TGLSceneBuffer ------------------ // ------------------ constructor TGLSceneBuffer.Create(AOwner: TPersistent); begin inherited Create(AOwner); // initialize private state variables FFogEnvironment := TGLFogEnvironment.Create(Self); FBackgroundColor := clBtnFace; FBackgroundAlpha := 1; FAmbientColor := TGLColor.CreateInitialized(Self, clrGray20); FDepthTest := True; FFaceCulling := True; FLighting := True; FAntiAliasing := aaDefault; FDepthPrecision := dpDefault; FColorDepth := cdDefault; FShadeModel := smDefault; FFogEnable := False; FLayer := clMainPlane; FAfterRenderEffects := TGLPersistentObjectList.Create; FContextOptions := [roDoubleBuffer, roRenderToWindow, roDebugContext]; ResetPerformanceMonitor; end; destructor TGLSceneBuffer.Destroy; begin Melt; DestroyRC; FAmbientColor.Free; FAfterRenderEffects.Free; FFogEnvironment.Free; inherited Destroy; end; procedure TGLSceneBuffer.PrepareGLContext; begin if Assigned(FOnPrepareGLContext) then FOnPrepareGLContext(Self); end; procedure TGLSceneBuffer.SetupRCOptions(context: TGLContext); const cColorDepthToColorBits: array[cdDefault..cdFloat128bits] of Integer = (24, 8, 16, 24, 64, 128); // float_type cDepthPrecisionToDepthBits: array[dpDefault..dp32bits] of Integer = (24, 16, 24, 32); var locOptions: TGLRCOptions; locStencilBits, locAlphaBits, locColorBits: Integer; begin locOptions := []; if roDoubleBuffer in ContextOptions then locOptions := locOptions + [rcoDoubleBuffered]; if roStereo in ContextOptions then locOptions := locOptions + [rcoStereo]; if roDebugContext in ContextOptions then locOptions := locOptions + [rcoDebug]; if roOpenGL_ES2_Context in ContextOptions then locOptions := locOptions + [rcoOGL_ES]; if roNoColorBuffer in ContextOptions then locColorBits := 0 else locColorBits := cColorDepthToColorBits[ColorDepth]; if roStencilBuffer in ContextOptions then locStencilBits := 8 else locStencilBits := 0; if roDestinationAlpha in ContextOptions then locAlphaBits := 8 else locAlphaBits := 0; with context do begin if roSoftwareMode in ContextOptions then Acceleration := chaSoftware else Acceleration := chaHardware; Options := locOptions; ColorBits := locColorBits; DepthBits := cDepthPrecisionToDepthBits[DepthPrecision]; StencilBits := locStencilBits; AlphaBits := locAlphaBits; AccumBits := AccumBufferBits; AuxBuffers := 0; AntiAliasing := Self.AntiAliasing; Layer := Self.Layer; { GLStates.ForwardContext := roForwardContext in ContextOptions;} PrepareGLContext; end; end; procedure TGLSceneBuffer.CreateRC(AWindowHandle: HWND; memoryContext: Boolean; BufferCount: Integer); begin DestroyRC; FRendering := True; try // will be freed in DestroyWindowHandle FRenderingContext := GLContextManager.CreateContext; if not Assigned(FRenderingContext) then raise Exception.Create('Failed to create RenderingContext.'); SetupRCOptions(FRenderingContext); if Assigned(FCamera) and Assigned(FCamera.FScene) then FCamera.FScene.AddBuffer(Self); with FRenderingContext do begin try if memoryContext then CreateMemoryContext(AWindowHandle, FViewPort.Width, FViewPort.Height, BufferCount) else CreateContext(AWindowHandle); except FreeAndNil(FRenderingContext); if Assigned(FCamera) and Assigned(FCamera.FScene) then FCamera.FScene.RemoveBuffer(Self); raise; end; end; FRenderingContext.Activate; try // this one should NOT be replaced with an assert if not gl.VERSION_1_1 then begin GLSLogger.LogFatalError(strWrongVersion); Abort; end; // define viewport, this is necessary because the first WM_SIZE message // is posted before the rendering context has been created FRenderingContext.GLStates.ViewPort := Vector4iMake(FViewPort.Left, FViewPort.Top, FViewPort.Width, FViewPort.Height); // set up initial context states SetupRenderingContext(FRenderingContext); FRenderingContext.GLStates.ColorClearValue := ConvertWinColor(FBackgroundColor); finally FRenderingContext.Deactivate; end; finally FRendering := False; end; end; procedure TGLSceneBuffer.DestroyRC; begin if Assigned(FRenderingContext) then begin Melt; // for some obscure reason, Mesa3D doesn't like this call... any help welcome FreeAndNil(FSelector); FreeAndNil(FRenderingContext); if Assigned(FCamera) and Assigned(FCamera.FScene) then FCamera.FScene.RemoveBuffer(Self); end; end; function TGLSceneBuffer.RCInstantiated: Boolean; begin Result := Assigned(FRenderingContext); end; procedure TGLSceneBuffer.Resize(newLeft, newTop, newWidth, newHeight: Integer); begin if newWidth < 1 then newWidth := 1; if newHeight < 1 then newHeight := 1; FViewPort.Left := newLeft; FViewPort.Top := newTop; FViewPort.Width := newWidth; FViewPort.Height := newHeight; if Assigned(FRenderingContext) then begin FRenderingContext.Activate; try // Part of workaround for MS OpenGL "black borders" bug FRenderingContext.GLStates.ViewPort := Vector4iMake(FViewPort.Left, FViewPort.Top, FViewPort.Width, FViewPort.Height); finally FRenderingContext.Deactivate; end; end; end; function TGLSceneBuffer.Acceleration: TGLContextAcceleration; begin if Assigned(FRenderingContext) then Result := FRenderingContext.Acceleration else Result := chaUnknown; end; procedure TGLSceneBuffer.SetupRenderingContext(context: TGLContext); procedure SetState(context: TGLContext; bool: Boolean; csState: TGLState); inline; begin case bool of true: context.GLStates.PerformEnable(csState); false: context.GLStates.PerformDisable(csState); end; end; var LColorDepth: Cardinal; begin if not Assigned(context) then Exit; if not (roForwardContext in ContextOptions) then begin gl.LightModelfv(GL_LIGHT_MODEL_AMBIENT, FAmbientColor.AsAddress); if roTwoSideLighting in FContextOptions then gl.LightModeli(GL_LIGHT_MODEL_TWO_SIDE, GL_TRUE) else gl.LightModeli(GL_LIGHT_MODEL_TWO_SIDE, GL_FALSE); gl.Hint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST); case ShadeModel of smDefault, smSmooth: gl.ShadeModel(GL_SMOOTH); smFlat: gl.ShadeModel(GL_FLAT); else Assert(False, strErrorEx + strUnknownType); end; end; with context.GLStates do begin Enable(stNormalize); SetState(context, DepthTest, stDepthTest); SetState(context, FaceCulling, stCullFace); SetState(context, Lighting, stLighting); SetState(context, FogEnable, stFog); if gl.ARB_depth_clamp then Disable(stDepthClamp); if not (roForwardContext in ContextOptions) then begin gl.GetIntegerv(GL_BLUE_BITS, @LColorDepth); // could've used red or green too SetState(context, (LColorDepth < 8), stDither); end; ResetAllTextureMatrix; end; end; function TGLSceneBuffer.GetLimit(Which: TGLLimitType): Integer; var VP: array[0..1] of Double; begin case Which of limClipPlanes: gl.GetIntegerv(GL_MAX_CLIP_PLANES, @Result); limEvalOrder: gl.GetIntegerv(GL_MAX_EVAL_ORDER, @Result); limLights: gl.GetIntegerv(GL_MAX_LIGHTS, @Result); limListNesting: gl.GetIntegerv(GL_MAX_LIST_NESTING, @Result); limModelViewStack: gl.GetIntegerv(GL_MAX_MODELVIEW_STACK_DEPTH, @Result); limNameStack: gl.GetIntegerv(GL_MAX_NAME_STACK_DEPTH, @Result); limPixelMapTable: gl.GetIntegerv(GL_MAX_PIXEL_MAP_TABLE, @Result); limProjectionStack: gl.GetIntegerv(GL_MAX_PROJECTION_STACK_DEPTH, @Result); limTextureSize: gl.GetIntegerv(GL_MAX_TEXTURE_SIZE, @Result); limTextureStack: gl.GetIntegerv(GL_MAX_TEXTURE_STACK_DEPTH, @Result); limViewportDims: begin gl.GetDoublev(GL_MAX_VIEWPORT_DIMS, @VP); if VP[0] > VP[1] then Result := Round(VP[0]) else Result := Round(VP[1]); end; limAccumAlphaBits: gl.GetIntegerv(GL_ACCUM_ALPHA_BITS, @Result); limAccumBlueBits: gl.GetIntegerv(GL_ACCUM_BLUE_BITS, @Result); limAccumGreenBits: gl.GetIntegerv(GL_ACCUM_GREEN_BITS, @Result); limAccumRedBits: gl.GetIntegerv(GL_ACCUM_RED_BITS, @Result); limAlphaBits: gl.GetIntegerv(GL_ALPHA_BITS, @Result); limAuxBuffers: gl.GetIntegerv(GL_AUX_BUFFERS, @Result); limDepthBits: gl.GetIntegerv(GL_DEPTH_BITS, @Result); limStencilBits: gl.GetIntegerv(GL_STENCIL_BITS, @Result); limBlueBits: gl.GetIntegerv(GL_BLUE_BITS, @Result); limGreenBits: gl.GetIntegerv(GL_GREEN_BITS, @Result); limRedBits: gl.GetIntegerv(GL_RED_BITS, @Result); limIndexBits: gl.GetIntegerv(GL_INDEX_BITS, @Result); limStereo: gl.GetIntegerv(GL_STEREO, @Result); limDoubleBuffer: gl.GetIntegerv(GL_DOUBLEBUFFER, @Result); limSubpixelBits: gl.GetIntegerv(GL_SUBPIXEL_BITS, @Result); limNbTextureUnits: if gl.ARB_multitexture then gl.GetIntegerv(GL_MAX_TEXTURE_UNITS_ARB, @Result) else Result := 1; else Result := 0; end; end; procedure TGLSceneBuffer.RenderToFile(const aFile: string; DPI: Integer); var aBitmap: TBitmap; saveAllowed: Boolean; fileName: string; begin Assert((not FRendering), strAlreadyRendering); aBitmap := TBitmap.Create; try aBitmap.Width := FViewPort.Width; aBitmap.Height := FViewPort.Height; aBitmap.PixelFormat := pf24Bit; RenderToBitmap(ABitmap, DPI); fileName := aFile; if fileName = '' then saveAllowed := SavePictureDialog(fileName) else saveAllowed := True; if saveAllowed then begin if FileExists(fileName) then saveAllowed := QuestionDlg(Format('Overwrite file %s?', [fileName])); if saveAllowed then aBitmap.SaveToFile(fileName); end; finally aBitmap.Free; end; end; procedure TGLSceneBuffer.RenderToFile(const AFile: string; bmpWidth, bmpHeight: Integer); var aBitmap: TBitmap; saveAllowed: Boolean; fileName: string; begin Assert((not FRendering), strAlreadyRendering); aBitmap := TBitmap.Create; try aBitmap.Width := bmpWidth; aBitmap.Height := bmpHeight; aBitmap.PixelFormat := pf24Bit; RenderToBitmap(aBitmap, (GetDeviceLogicalPixelsX(Cardinal(ABitmap.Canvas.Handle)) * bmpWidth) div FViewPort.Width); fileName := AFile; if fileName = '' then saveAllowed := SavePictureDialog(fileName) else saveAllowed := True; if saveAllowed then begin if FileExists(fileName) then saveAllowed := QuestionDlg(Format('Overwrite file %s?', [fileName])); if SaveAllowed then aBitmap.SaveToFile(fileName); end; finally aBitmap.Free; end; end; function TGLSceneBuffer.CreateSnapShot: TGLBitmap32; begin Result := TGLBitmap32.Create; Result.Width := FViewPort.Width; Result.Height := FViewPort.Height; if Assigned(Camera) and Assigned(Camera.Scene) then begin FRenderingContext.Activate; try Result.ReadPixels(Rect(0, 0, FViewPort.Width, FViewPort.Height)); finally FRenderingContext.DeActivate; end; end; end; function TGLSceneBuffer.CreateSnapShotBitmap: TBitmap; var bmp32: TGLBitmap32; begin bmp32 := CreateSnapShot; try Result := bmp32.Create32BitsBitmap; finally bmp32.Free; end; end; procedure TGLSceneBuffer.CopyToTexture(aTexture: TGLTexture); begin CopyToTexture(aTexture, 0, 0, Width, Height, 0, 0); end; procedure TGLSceneBuffer.CopyToTexture(aTexture: TGLTexture; xSrc, ySrc, AWidth, AHeight: Integer; xDest, yDest: Integer; glCubeFace: Cardinal = 0); var bindTarget: TGLTextureTarget; begin if RenderingContext <> nil then begin RenderingContext.Activate; try if not (aTexture.Image is TGLBlankImage) then aTexture.ImageClassName := TGLBlankImage.ClassName; if aTexture.Image.Width <> AWidth then TGLBlankImage(aTexture.Image).Width := AWidth; if aTexture.Image.Height <> AHeight then TGLBlankImage(aTexture.Image).Height := AHeight; if aTexture.Image.Depth <> 0 then TGLBlankImage(aTexture.Image).Depth := 0; if TGLBlankImage(aTexture.Image).CubeMap <> (glCubeFace > 0) then TGLBlankImage(aTexture.Image).CubeMap := (glCubeFace > 0); bindTarget := aTexture.Image.NativeTextureTarget; RenderingContext.GLStates.TextureBinding[0, bindTarget] := aTexture.Handle; if glCubeFace > 0 then gl.CopyTexSubImage2D(glCubeFace, 0, xDest, yDest, xSrc, ySrc, AWidth, AHeight) else gl.CopyTexSubImage2D(DecodeTextureTarget(bindTarget), 0, xDest, yDest, xSrc, ySrc, AWidth, AHeight) finally RenderingContext.Deactivate; end; end; end; procedure TGLSceneBuffer.SaveAsFloatToFile(const aFilename: string); var Data: pointer; DataSize: integer; Stream: TMemoryStream; const FloatSize = 4; begin if Assigned(Camera) and Assigned(Camera.Scene) then begin DataSize := Width * Height * FloatSize * FloatSize; GetMem(Data, DataSize); FRenderingContext.Activate; try gl.ReadPixels(0, 0, Width, Height, GL_RGBA, GL_FLOAT, Data); gl.CheckError; Stream := TMemoryStream.Create; try Stream.Write(Data^, DataSize); Stream.SaveToFile(aFilename); finally Stream.Free; end; finally FRenderingContext.DeActivate; FreeMem(Data); end; end; end; procedure TGLSceneBuffer.SetViewPort(X, Y, W, H: Integer); begin with FViewPort do begin Left := X; Top := Y; Width := W; Height := H; end; NotifyChange(Self); end; function TGLSceneBuffer.Width: Integer; begin Result := FViewPort.Width; end; function TGLSceneBuffer.Height: Integer; begin Result := FViewPort.Height; end; procedure TGLSceneBuffer.Freeze; begin if Freezed then Exit; if RenderingContext = nil then Exit; Render; FFreezed := True; RenderingContext.Activate; try FFreezeBuffer := AllocMem(FViewPort.Width * FViewPort.Height * 4); gl.ReadPixels(0, 0, FViewport.Width, FViewPort.Height, GL_RGBA, GL_UNSIGNED_BYTE, FFreezeBuffer); FFreezedViewPort := FViewPort; finally RenderingContext.Deactivate; end; end; procedure TGLSceneBuffer.Melt; begin if not Freezed then Exit; FreeMem(FFreezeBuffer); FFreezeBuffer := nil; FFreezed := False; end; procedure TGLSceneBuffer.RenderToBitmap(ABitmap: TBitmap; DPI: Integer); var nativeContext: TGLContext; aColorBits: Integer; begin Assert((not FRendering), strAlreadyRendering); FRendering := True; nativeContext := RenderingContext; try aColorBits := PixelFormatToColorBits(ABitmap.PixelFormat); if aColorBits < 8 then aColorBits := 8; FRenderingContext := GLContextManager.CreateContext; SetupRCOptions(FRenderingContext); with FRenderingContext do begin Options := []; // no such things for bitmap rendering ColorBits := aColorBits; // honour Bitmap's pixel depth AntiAliasing := aaNone; // no AA for bitmap rendering CreateContext(ABitmap.Canvas.Handle); end; try FRenderingContext.Activate; try SetupRenderingContext(FRenderingContext); FRenderingContext.GLStates.ColorClearValue := ConvertWinColor(FBackgroundColor); // set the desired viewport and limit output to this rectangle with FViewport do begin Left := 0; Top := 0; Width := ABitmap.Width; Height := ABitmap.Height; FRenderingContext.GLStates.ViewPort := Vector4iMake(Left, Top, Width, Height); end; ClearBuffers; FRenderDPI := DPI; if FRenderDPI = 0 then FRenderDPI := GetDeviceLogicalPixelsX(ABitmap.Canvas.Handle); // render DoBaseRender(FViewport, FRenderDPI, dsPrinting, nil); if nativeContext <> nil then FViewport := TRectangle(nativeContext.GLStates.ViewPort); gl.Finish; finally FRenderingContext.Deactivate; end; finally FRenderingContext.Free; end; finally FRenderingContext := nativeContext; FRendering := False; end; if Assigned(FAfterRender) then if Owner is TComponent then if not (csDesigning in TComponent(Owner).ComponentState) then FAfterRender(Self); end; procedure TGLSceneBuffer.ShowInfo(Modal: boolean); begin if not Assigned(FRenderingContext) then Exit; // most info is available with active context only FRenderingContext.Activate; try InvokeInfoForm(Self, Modal); finally FRenderingContext.Deactivate; end; end; procedure TGLSceneBuffer.ResetPerformanceMonitor; begin FFramesPerSecond := 0; FFrameCount := 0; FFirstPerfCounter := 0; end; procedure TGLSceneBuffer.PushViewMatrix(const newMatrix: TGLMatrix); var n: Integer; begin n := Length(FViewMatrixStack); SetLength(FViewMatrixStack, n + 1); FViewMatrixStack[n] := RenderingContext.PipelineTransformation.ViewMatrix^; RenderingContext.PipelineTransformation.SetViewMatrix(newMatrix); end; procedure TGLSceneBuffer.PopViewMatrix; var n: Integer; begin n := High(FViewMatrixStack); Assert(n >= 0, 'Unbalanced PopViewMatrix'); RenderingContext.PipelineTransformation.SetViewMatrix(FViewMatrixStack[n]); SetLength(FViewMatrixStack, n); end; procedure TGLSceneBuffer.PushProjectionMatrix(const newMatrix: TGLMatrix); var n: Integer; begin n := Length(FProjectionMatrixStack); SetLength(FProjectionMatrixStack, n + 1); FProjectionMatrixStack[n] := RenderingContext.PipelineTransformation.ProjectionMatrix^; RenderingContext.PipelineTransformation.SetProjectionMatrix(newMatrix); end; procedure TGLSceneBuffer.PopProjectionMatrix; var n: Integer; begin n := High(FProjectionMatrixStack); Assert(n >= 0, 'Unbalanced PopProjectionMatrix'); RenderingContext.PipelineTransformation.SetProjectionMatrix(FProjectionMatrixStack[n]); SetLength(FProjectionMatrixStack, n); end; function TGLSceneBuffer.ProjectionMatrix; begin Result := RenderingContext.PipelineTransformation.ProjectionMatrix^; end; function TGLSceneBuffer.ViewMatrix: TGLMatrix; begin Result := RenderingContext.PipelineTransformation.ViewMatrix^; end; function TGLSceneBuffer.ModelMatrix: TGLMatrix; begin Result := RenderingContext.PipelineTransformation.ModelMatrix^; end; function TGLSceneBuffer.OrthoScreenToWorld(screenX, screenY: Integer): TAffineVector; var camPos, camUp, camRight: TAffineVector; f: Single; begin if Assigned(FCamera) then begin SetVector(camPos, FCameraAbsolutePosition); if Camera.TargetObject <> nil then begin SetVector(camUp, FCamera.AbsoluteUpVectorToTarget); SetVector(camRight, FCamera.AbsoluteRightVectorToTarget); end else begin SetVector(camUp, Camera.AbsoluteUp); SetVector(camRight, Camera.AbsoluteRight); end; f := 100 * FCamera.NearPlaneBias / (FCamera.FocalLength * FCamera.SceneScale); if FViewPort.Width > FViewPort.Height then f := f / FViewPort.Width else f := f / FViewPort.Height; SetVector(Result, VectorCombine3(camPos, camUp, camRight, 1, (screenY - (FViewPort.Height div 2)) * f, (screenX - (FViewPort.Width div 2)) * f)); end else Result := NullVector; end; function TGLSceneBuffer.ScreenToWorld(const aPoint: TAffineVector): TAffineVector; var rslt: TGLVector; begin if Assigned(FCamera) and UnProject( VectorMake(aPoint), RenderingContext.PipelineTransformation.ViewProjectionMatrix^, PHomogeneousIntVector(@FViewPort)^, rslt) then Result := Vector3fMake(rslt) else Result := aPoint; end; function TGLSceneBuffer.ScreenToWorld(const aPoint: TGLVector): TGLVector; begin MakePoint(Result, ScreenToWorld(AffineVectorMake(aPoint))); end; function TGLSceneBuffer.ScreenToWorld(screenX, screenY: Integer): TAffineVector; begin Result := ScreenToWorld(AffineVectorMake(screenX, FViewPort.Height - screenY, 0)); end; function TGLSceneBuffer.WorldToScreen(const aPoint: TAffineVector): TAffineVector; var rslt: TGLVector; begin RenderingContext.Activate; try PrepareRenderingMatrices(FViewPort, FRenderDPI); if Assigned(FCamera) and Project( VectorMake(aPoint), RenderingContext.PipelineTransformation.ViewProjectionMatrix^, TVector4i(FViewPort), rslt) then Result := Vector3fMake(rslt) else Result := aPoint; finally RenderingContext.Deactivate; end; end; function TGLSceneBuffer.WorldToScreen(const aPoint: TGLVector): TGLVector; begin SetVector(Result, WorldToScreen(AffineVectorMake(aPoint))); end; procedure TGLSceneBuffer.WorldToScreen(points: PGLVector; nbPoints: Integer); var i: Integer; begin if Assigned(FCamera) then begin for i := nbPoints - 1 downto 0 do begin Project(points^, RenderingContext.PipelineTransformation.ViewProjectionMatrix^, PHomogeneousIntVector(@FViewPort)^, points^); Inc(points); end; end; end; function TGLSceneBuffer.ScreenToVector(const aPoint: TAffineVector): TAffineVector; begin Result := VectorSubtract(ScreenToWorld(aPoint), PAffineVector(@FCameraAbsolutePosition)^); end; function TGLSceneBuffer.ScreenToVector(const aPoint: TGLVector): TGLVector; begin SetVector(Result, VectorSubtract(ScreenToWorld(aPoint), FCameraAbsolutePosition)); Result.W := 0; end; function TGLSceneBuffer.ScreenToVector(const x, y: Integer): TGLVector; var av: TAffineVector; begin av.X := x; av.Y := y; av.Z := 0; SetVector(Result, ScreenToVector(av)); end; function TGLSceneBuffer.VectorToScreen(const VectToCam: TAffineVector): TAffineVector; begin Result := WorldToScreen(VectorAdd(VectToCam, PAffineVector(@FCameraAbsolutePosition)^)); end; function TGLSceneBuffer.ScreenVectorIntersectWithPlane( const aScreenPoint: TGLVector; const planePoint, planeNormal: TGLVector; var intersectPoint: TGLVector): Boolean; var v: TGLVector; begin if Assigned(FCamera) then begin SetVector(v, ScreenToVector(aScreenPoint)); Result := RayCastPlaneIntersect(FCameraAbsolutePosition, v, planePoint, planeNormal, @intersectPoint); intersectPoint.W := 1; end else Result := False; end; function TGLSceneBuffer.ScreenVectorIntersectWithPlaneXY( const aScreenPoint: TGLVector; const z: Single; var intersectPoint: TGLVector): Boolean; begin Result := ScreenVectorIntersectWithPlane(aScreenPoint, VectorMake(0, 0, z), ZHmgVector, intersectPoint); intersectPoint.W := 0; end; function TGLSceneBuffer.ScreenVectorIntersectWithPlaneYZ( const aScreenPoint: TGLVector; const x: Single; var intersectPoint: TGLVector): Boolean; begin Result := ScreenVectorIntersectWithPlane(aScreenPoint, VectorMake(x, 0, 0), XHmgVector, intersectPoint); intersectPoint.W := 0; end; function TGLSceneBuffer.ScreenVectorIntersectWithPlaneXZ( const aScreenPoint: TGLVector; const y: Single; var intersectPoint: TGLVector): Boolean; begin Result := ScreenVectorIntersectWithPlane(aScreenPoint, VectorMake(0, y, 0), YHmgVector, intersectPoint); intersectPoint.W := 0; end; function TGLSceneBuffer.PixelRayToWorld(x, y: Integer): TAffineVector; var dov, np, fp, z, dst, wrpdst: Single; vec, cam, targ, rayhit, pix: TAffineVector; camAng: real; begin if Camera.CameraStyle = csOrtho2D then dov := 2 else dov := Camera.DepthOfView; np := Camera.NearPlane; fp := Camera.NearPlane + dov; z := GetPixelDepth(x, y); dst := (fp * np) / (fp - z * dov); //calc from z-buffer value to world depth //------------------------ //z:=1-(fp/d-1)/(fp/np-1); //calc from world depth to z-buffer value //------------------------ vec.X := x; vec.Y := FViewPort.Height - y; vec.Z := 0; vec := ScreenToVector(vec); NormalizeVector(vec); SetVector(cam, Camera.AbsolutePosition); //targ:=Camera.TargetObject.Position.AsAffineVector; //SubtractVector(targ,cam); pix.X := FViewPort.Width * 0.5; pix.Y := FViewPort.Height * 0.5; pix.Z := 0; targ := self.ScreenToVector(pix); camAng := VectorAngleCosine(targ, vec); wrpdst := dst / camAng; rayhit := cam; CombineVector(rayhit, vec, wrpdst); result := rayhit; end; procedure TGLSceneBuffer.ClearBuffers; var bufferBits: TGLBitfield; begin if roNoDepthBufferClear in ContextOptions then bufferBits := 0 else begin bufferBits := GL_DEPTH_BUFFER_BIT; CurrentGLContext.GLStates.DepthWriteMask := True; end; if ContextOptions * [roNoColorBuffer, roNoColorBufferClear] = [] then begin bufferBits := bufferBits or GL_COLOR_BUFFER_BIT; CurrentGLContext.GLStates.SetColorMask(cAllColorComponents); end; if roStencilBuffer in ContextOptions then begin bufferBits := bufferBits or GL_STENCIL_BUFFER_BIT; end; if bufferBits<>0 then gl.Clear(BufferBits); end; procedure TGLSceneBuffer.NotifyChange(Sender: TObject); begin DoChange; end; procedure TGLSceneBuffer.PickObjects(const rect: TRect; pickList: TGLPickList; objectCountGuess: Integer); var I: Integer; obj: TGLBaseSceneObject; begin if not Assigned(FCamera) then Exit; Assert((not FRendering), strAlreadyRendering); Assert(Assigned(PickList)); FRenderingContext.Activate; FRendering := True; try // Creates best selector which techniques is hardware can do if not Assigned(FSelector) then FSelector := GetBestSelectorClass.Create; xgl.MapTexCoordToNull; // turn off PrepareRenderingMatrices(FViewPort, RenderDPI, @Rect); FSelector.Hits := -1; if objectCountGuess > 0 then FSelector.ObjectCountGuess := objectCountGuess; repeat FSelector.Start; // render the scene (in select mode, nothing is drawn) FRenderDPI := 96; if Assigned(FCamera) and Assigned(FCamera.FScene) then RenderScene(FCamera.FScene, FViewPort.Width, FViewPort.Height, dsPicking, nil); until FSelector.Stop; FSelector.FillPickingList(PickList); for I := 0 to PickList.Count-1 do begin obj := TGLBaseSceneObject(PickList[I]); if Assigned(obj.FOnPicked) then obj.FOnPicked(obj); end; finally FRendering := False; FRenderingContext.Deactivate; end; end; function TGLSceneBuffer.GetPickedObjects(const rect: TRect; objectCountGuess: Integer = 64): TGLPickList; begin Result := TGLPickList.Create(psMinDepth); PickObjects(Rect, Result, objectCountGuess); end; function TGLSceneBuffer.GetPickedObject(x, y: Integer): TGLBaseSceneObject; var pkList: TGLPickList; begin pkList := GetPickedObjects(Rect(x - 1, y - 1, x + 1, y + 1)); try if pkList.Count > 0 then Result := TGLBaseSceneObject(pkList.Hit[0]) else Result := nil; finally pkList.Free; end; end; function TGLSceneBuffer.GetPixelColor(x, y: Integer): TColor; var buf: array[0..2] of Byte; begin if not Assigned(FCamera) then begin Result := 0; Exit; end; FRenderingContext.Activate; try gl.ReadPixels(x, FViewPort.Height - y, 1, 1, GL_RGB, GL_UNSIGNED_BYTE, @buf[0]); finally FRenderingContext.Deactivate; end; Result := RGB2Color(buf[0], buf[1], buf[2]); end; function TGLSceneBuffer.GetPixelDepth(x, y: Integer): Single; begin if not Assigned(FCamera) then begin Result := 0; Exit; end; FRenderingContext.Activate; try gl.ReadPixels(x, FViewPort.Height - y, 1, 1, GL_DEPTH_COMPONENT, GL_FLOAT, @Result); finally FRenderingContext.Deactivate; end; end; function TGLSceneBuffer.PixelDepthToDistance(aDepth: Single): Single; var dov, np, fp: Single; begin if Camera.CameraStyle = csOrtho2D then dov := 2 else dov := Camera.DepthOfView; // Depth of View (from np to fp) np := Camera.NearPlane; // Near plane distance fp := np + dov; // Far plane distance Result := (fp * np) / (fp - aDepth * dov); // calculate world distance from z-buffer value end; function TGLSceneBuffer.PixelToDistance(x, y: integer): Single; var z, dov, np, fp, dst, camAng: Single; norm, coord, vec: TAffineVector; begin z := GetPixelDepth(x, y); if Camera.CameraStyle = csOrtho2D then dov := 2 else dov := Camera.DepthOfView; // Depth of View (from np to fp) np := Camera.NearPlane; // Near plane distance fp := np + dov; // Far plane distance dst := (np * fp) / (fp - z * dov); //calculate from z-buffer value to frustrum depth coord.X := x; coord.Y := y; vec := self.ScreenToVector(coord); //get the pixel vector coord.X := FViewPort.Width div 2; coord.Y := FViewPort.Height div 2; norm := self.ScreenToVector(coord); //get the absolute camera direction camAng := VectorAngleCosine(norm, vec); Result := dst / camAng; //compensate for flat frustrum face end; procedure TGLSceneBuffer.NotifyMouseMove(Shift: TShiftState; X, Y: Integer); begin // Nothing end; procedure TGLSceneBuffer.PrepareRenderingMatrices(const aViewPort: TRectangle; resolution: Integer; pickingRect: PRect = nil); begin RenderingContext.PipelineTransformation.IdentityAll; // setup projection matrix if Assigned(pickingRect) then begin CurrentGLContext.PipelineTransformation.SetProjectionMatrix( CreatePickMatrix( (pickingRect^.Left + pickingRect^.Right) div 2, FViewPort.Height - ((pickingRect^.Top + pickingRect^.Bottom) div 2), Abs(pickingRect^.Right - pickingRect^.Left), Abs(pickingRect^.Bottom - pickingRect^.Top), TVector4i(FViewport))); end; FBaseProjectionMatrix := CurrentGLContext.PipelineTransformation.ProjectionMatrix^; if Assigned(FCamera) then begin FCamera.Scene.FCurrentGLCamera := FCamera; // apply camera perpective FCamera.ApplyPerspective( aViewport, FViewPort.Width, FViewPort.Height, resolution); // setup model view matrix // apply camera transformation (viewpoint) FCamera.Apply; FCameraAbsolutePosition := FCamera.AbsolutePosition; end; end; procedure TGLSceneBuffer.DoBaseRender(const aViewPort: TRectangle; resolution: Integer; drawState: TGLDrawState; baseObject: TGLBaseSceneObject); begin with RenderingContext.GLStates do begin PrepareRenderingMatrices(aViewPort, resolution); (* if not ForwardContext then *) begin xgl.MapTexCoordToNull; // force XGL rebind xgl.MapTexCoordToMain; end; if Assigned(FViewerBeforeRender) and (drawState <> dsPrinting) then FViewerBeforeRender(Self); if Assigned(FBeforeRender) then if Owner is TComponent then if not (csDesigning in TComponent(Owner).ComponentState) then FBeforeRender(Self); if Assigned(FCamera) and Assigned(FCamera.FScene) then begin with FCamera.FScene do begin SetupLights(MaxLights); (* if not ForwardContext then *) begin if FogEnable then begin Enable(stFog); FogEnvironment.ApplyFog; end else Disable(stFog); end; RenderScene(FCamera.FScene, aViewPort.Width, aViewPort.Height, drawState, baseObject); end; end; if Assigned(FPostRender) then if Owner is TComponent then if not (csDesigning in TComponent(Owner).ComponentState) then FPostRender(Self); end; Assert(Length(FViewMatrixStack) = 0, 'Unbalance Push/PopViewMatrix.'); Assert(Length(FProjectionMatrixStack) = 0, 'Unbalance Push/PopProjectionMatrix.'); end; procedure TGLSceneBuffer.Render; begin Render(nil); end; procedure TGLSceneBuffer.Render(baseObject: TGLBaseSceneObject); var perfCounter, framePerf: Int64; begin if FRendering then Exit; if not Assigned(FRenderingContext) then Exit; if Freezed and (FFreezeBuffer <> nil) then begin RenderingContext.Activate; try RenderingContext.GLStates.ColorClearValue := ConvertWinColor(FBackgroundColor, FBackgroundAlpha); ClearBuffers; gl.MatrixMode(GL_PROJECTION); gl.LoadIdentity; gl.MatrixMode(GL_MODELVIEW); gl.LoadIdentity; gl.RasterPos2f(-1, -1); gl.DrawPixels(FFreezedViewPort.Width, FFreezedViewPort.Height, GL_RGBA, GL_UNSIGNED_BYTE, FFreezeBuffer); if not (roNoSwapBuffers in ContextOptions) then RenderingContext.SwapBuffers; finally RenderingContext.Deactivate; end; Exit; end; QueryPerformanceCounter(framePerf); if Assigned(FCamera) and Assigned(FCamera.FScene) then begin FCamera.AbsoluteMatrixAsAddress; FCamera.FScene.AddBuffer(Self); end; FRendering := True; try FRenderingContext.Activate; try if FFrameCount = 0 then QueryPerformanceCounter(FFirstPerfCounter); FRenderDPI := 96; // default value for screen gl.ClearError; SetupRenderingContext(FRenderingContext); // clear the buffers FRenderingContext.GLStates.ColorClearValue := ConvertWinColor(FBackgroundColor, FBackgroundAlpha); ClearBuffers; gl.CheckError; // render DoBaseRender(FViewport, RenderDPI, dsRendering, baseObject); if not (roNoSwapBuffers in ContextOptions) then RenderingContext.SwapBuffers; // yes, calculate average frames per second... Inc(FFrameCount); QueryPerformanceCounter(perfCounter); FLastFrameTime := (perfCounter - framePerf) / vCounterFrequency; Dec(perfCounter, FFirstPerfCounter); if perfCounter > 0 then FFramesPerSecond := (FFrameCount * vCounterFrequency) / perfCounter; gl.CheckError; finally FRenderingContext.Deactivate; end; if Assigned(FAfterRender) and (Owner is TComponent) then if not (csDesigning in TComponent(Owner).ComponentState) then FAfterRender(Self); finally FRendering := False; end; end; procedure TGLSceneBuffer.RenderScene(aScene: TGLScene; const viewPortSizeX, viewPortSizeY: Integer; drawState: TGLDrawState; baseObject: TGLBaseSceneObject); var i: Integer; rci: TGLRenderContextInfo; rightVector: TGLVector; begin FAfterRenderEffects.Clear; aScene.FCurrentBuffer := Self; FillChar(rci, SizeOf(rci), 0); rci.scene := aScene; rci.buffer := Self; rci.afterRenderEffects := FAfterRenderEffects; rci.objectsSorting := aScene.ObjectsSorting; rci.visibilityCulling := aScene.VisibilityCulling; rci.bufferFaceCull := FFaceCulling; rci.bufferLighting := FLighting; rci.bufferFog := FFogEnable; rci.bufferDepthTest := FDepthTest; rci.drawState := drawState; rci.sceneAmbientColor := FAmbientColor.Color; rci.primitiveMask := cAllMeshPrimitive; with FCamera do begin rci.cameraPosition := FCameraAbsolutePosition; rci.cameraDirection := FLastDirection; NormalizeVector(rci.cameraDirection); rci.cameraDirection.W := 0; rightVector := VectorCrossProduct(rci.cameraDirection, Up.AsVector); rci.cameraUp := VectorCrossProduct(rightVector, rci.cameraDirection); NormalizeVector(rci.cameraUp); with rci.rcci do begin origin := rci.cameraPosition; clippingDirection := rci.cameraDirection; viewPortRadius := FViewPortRadius; nearClippingDistance := FNearPlane; farClippingDistance := FNearPlane + FDepthOfView; frustum := RenderingContext.PipelineTransformation.Frustum; end; end; rci.viewPortSize.cx := viewPortSizeX; rci.viewPortSize.cy := viewPortSizeY; rci.renderDPI := FRenderDPI; rci.GLStates := RenderingContext.GLStates; rci.PipelineTransformation := RenderingContext.PipelineTransformation; rci.proxySubObject := False; rci.ignoreMaterials := (roNoColorBuffer in FContextOptions) or (rci.drawState = dsPicking); rci.amalgamating := rci.drawState = dsPicking; rci.GLStates.SetColorWriting(not rci.ignoreMaterials); if Assigned(FInitiateRendering) then FInitiateRendering(Self, rci); if aScene.InitializableObjects.Count <> 0 then begin // First initialize all objects and delete them from the list. for I := aScene.InitializableObjects.Count - 1 downto 0 do begin aScene.InitializableObjects.Items[I].InitializeObject({Self?}aScene, rci); aScene.InitializableObjects.Delete(I); end; end; if RenderingContext.IsPraparationNeed then RenderingContext.PrepareHandlesData; if baseObject = nil then begin aScene.Objects.Render(rci); end else baseObject.Render(rci); rci.GLStates.SetColorWriting(True); with FAfterRenderEffects do if Count > 0 then for i := 0 to Count - 1 do TGLObjectAfterEffect(Items[i]).Render(rci); if Assigned(FWrapUpRendering) then FWrapUpRendering(Self, rci); end; procedure TGLSceneBuffer.SetBackgroundColor(AColor: TColor); begin if FBackgroundColor <> AColor then begin FBackgroundColor := AColor; NotifyChange(Self); end; end; procedure TGLSceneBuffer.SetBackgroundAlpha(alpha: Single); begin if FBackgroundAlpha <> alpha then begin FBackgroundAlpha := alpha; NotifyChange(Self); end; end; procedure TGLSceneBuffer.SetAmbientColor(AColor: TGLColor); begin FAmbientColor.Assign(AColor); end; procedure TGLSceneBuffer.SetCamera(ACamera: TGLCamera); begin if FCamera <> ACamera then begin if Assigned(FCamera) then begin if Assigned(FCamera.FScene) then FCamera.FScene.RemoveBuffer(Self); FCamera := nil; end; if Assigned(ACamera) and Assigned(ACamera.FScene) then begin FCamera := ACamera; FCamera.TransformationChanged; end; NotifyChange(Self); end; end; procedure TGLSceneBuffer.SetContextOptions(Options: TGLContextOptions); begin if FContextOptions <> Options then begin FContextOptions := Options; DoStructuralChange; end; end; procedure TGLSceneBuffer.SetDepthTest(AValue: Boolean); begin if FDepthTest <> AValue then begin FDepthTest := AValue; NotifyChange(Self); end; end; procedure TGLSceneBuffer.SetFaceCulling(AValue: Boolean); begin if FFaceCulling <> AValue then begin FFaceCulling := AValue; NotifyChange(Self); end; end; procedure TGLSceneBuffer.SetLayer(const Value: TGLContextLayer); begin if FLayer <> Value then begin FLayer := Value; DoStructuralChange; end; end; procedure TGLSceneBuffer.SetLighting(aValue: Boolean); begin if FLighting <> aValue then begin FLighting := aValue; NotifyChange(Self); end; end; procedure TGLSceneBuffer.SetAntiAliasing(const val: TGLAntiAliasing); begin if FAntiAliasing <> val then begin FAntiAliasing := val; DoStructuralChange; end; end; procedure TGLSceneBuffer.SetDepthPrecision(const val: TGLDepthPrecision); begin if FDepthPrecision <> val then begin FDepthPrecision := val; DoStructuralChange; end; end; procedure TGLSceneBuffer.SetColorDepth(const val: TGLColorDepth); begin if FColorDepth <> val then begin FColorDepth := val; DoStructuralChange; end; end; procedure TGLSceneBuffer.SetShadeModel(const val: TGLShadeModel); begin if FShadeModel <> val then begin FShadeModel := val; NotifyChange(Self); end; end; procedure TGLSceneBuffer.SetFogEnable(AValue: Boolean); begin if FFogEnable <> AValue then begin FFogEnable := AValue; NotifyChange(Self); end; end; procedure TGLSceneBuffer.SetGLFogEnvironment(AValue: TGLFogEnvironment); begin FFogEnvironment.Assign(AValue); NotifyChange(Self); end; function TGLSceneBuffer.StoreFog: Boolean; begin Result := (not FFogEnvironment.IsAtDefaultValues); end; procedure TGLSceneBuffer.SetAccumBufferBits(const val: Integer); begin if FAccumBufferBits <> val then begin FAccumBufferBits := val; DoStructuralChange; end; end; procedure TGLSceneBuffer.DoChange; begin if (not FRendering) and Assigned(FOnChange) then FOnChange(Self); end; procedure TGLSceneBuffer.DoStructuralChange; var bCall: Boolean; begin if Assigned(Owner) then bCall := not (csLoading in TComponent(GetOwner).ComponentState) else bCall := True; if bCall and Assigned(FOnStructuralChange) then FOnStructuralChange(Self); end; // ------------------ // ------------------ TGLNonVisualViewer ------------------ // ------------------ constructor TGLNonVisualViewer.Create(AOwner: TComponent); begin inherited Create(AOwner); FWidth := 256; FHeight := 256; FBuffer := TGLSceneBuffer.Create(Self); FBuffer.OnChange := DoBufferChange; FBuffer.OnStructuralChange := DoBufferStructuralChange; FBuffer.OnPrepareGLContext := DoOnPrepareGLContext; end; destructor TGLNonVisualViewer.Destroy; begin FBuffer.Free; inherited Destroy; end; procedure TGLNonVisualViewer.Notification(AComponent: TComponent; Operation: TOperation); begin if (Operation = opRemove) and (AComponent = Camera) then Camera := nil; inherited; end; procedure TGLNonVisualViewer.CopyToTexture(aTexture: TGLTexture); begin CopyToTexture(aTexture, 0, 0, Width, Height, 0, 0); end; procedure TGLNonVisualViewer.CopyToTexture(aTexture: TGLTexture; xSrc, ySrc, width, height: Integer; xDest, yDest: Integer); begin Buffer.CopyToTexture(aTexture, xSrc, ySrc, width, height, xDest, yDest); end; procedure TGLNonVisualViewer.CopyToTextureMRT(aTexture: TGLTexture; BufferIndex: integer); begin CopyToTextureMRT(aTexture, 0, 0, Width, Height, 0, 0, BufferIndex); end; procedure TGLNonVisualViewer.CopyToTextureMRT(aTexture: TGLTexture; xSrc, ySrc, width, height, xDest, yDest, BufferIndex: integer); var target, handle: Integer; buf: Pointer; createTexture: Boolean; procedure CreateNewTexture; begin GetMem(buf, Width * Height * 4); try // float_type gl.ReadPixels(0, 0, Width, Height, GL_RGBA, GL_UNSIGNED_BYTE, buf); case aTexture.MinFilter of miNearest, miLinear: gl.TexImage2d(target, 0, aTexture.OpenGLTextureFormat, Width, Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, buf); else if gl.SGIS_generate_mipmap and (target = GL_TEXTURE_2D) then begin // hardware-accelerated when supported gl.TexParameteri(target, GL_GENERATE_MIPMAP_SGIS, GL_TRUE); gl.TexImage2d(target, 0, aTexture.OpenGLTextureFormat, Width, Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, buf); end else begin gl.TexImage2d(target, 0, aTexture.OpenGLTextureFormat, Width, Height, 0, GL_RGBA, GL_UNSIGNED_BYTE, buf); gl.GenerateMipmap(target); end; end; finally FreeMem(buf); end; end; begin if Buffer.RenderingContext <> nil then begin Buffer.RenderingContext.Activate; try target := DecodeTextureTarget(aTexture.Image.NativeTextureTarget); CreateTexture := true; if aTexture.IsFloatType then begin // float_type special treatment CreateTexture := false; handle := aTexture.Handle; end else if (target <> GL_TEXTURE_CUBE_MAP_ARB) or (FCubeMapRotIdx = 0) then begin CreateTexture := not aTexture.IsHandleAllocated; if CreateTexture then handle := aTexture.AllocateHandle else handle := aTexture.Handle; end else handle := aTexture.Handle; // For MRT gl.ReadBuffer(MRT_BUFFERS[BufferIndex]); Buffer.RenderingContext.GLStates.TextureBinding[0, EncodeGLTextureTarget(target)] := handle; if target = GL_TEXTURE_CUBE_MAP_ARB then target := GL_TEXTURE_CUBE_MAP_POSITIVE_X_ARB + FCubeMapRotIdx; if CreateTexture then CreateNewTexture else gl.CopyTexSubImage2D(target, 0, xDest, yDest, xSrc, ySrc, Width, Height); gl.ClearError; finally Buffer.RenderingContext.Deactivate; end; end; end; procedure TGLNonVisualViewer.SetupCubeMapCamera(Sender: TObject); (* const cFaceMat: array[0..5] of TGLMatrix = ( (X: (X:0; Y:0; Z:-1; W:0); Y: (X:0; Y:-1; Z:0; W:0); Z: (X:-1; Y:0; Z:0; W:0); W: (X:0; Y:0; Z:0; W:1)), (X:(X:2.4335928828e-08; Y:0; Z:1; W:0); Y:(X:0; Y:-1; Z:0; W:0); Z:(X:1; Y:0; Z:-2.4335928828e-08; W:0); W:(X:0; Y:0; Z:0; W:1)), (X:(X:1; Y:1.2167964414e-08; Z:-1.4805936071e-16; W:0); Y:(X:0; Y:-1.2167964414e-08; Z:-1; W:0); Z:(X:-1.2167964414e-08; Y:1; Z:-1.2167964414e-08; W:0); W:(X:0; Y:0; Z:0; W:1)), (X:(X:1; Y:-1.2167964414e-08; Z:-1.4805936071e-16; W:0); Y:(X:0; Y:-1.2167964414e-08; Z:1; W:0); Z:(X:-1.2167964414e-08; Y:-1; Z:-1.2167964414e-08; W:0); W:(X:0; Y:0; Z:0; W:1)), (X:(X:1; Y:0; Z:-1.2167964414e-08; W:0); Y:(X:0; Y:-1; Z:0; W:0); Z:(X:-1.2167964414e-08; Y:0; Z:-1; W:0); W:(X:0; Y:0; Z:0; W:1)), (X:(X:-1; Y:0; Z:-1.2167964414e-08; W:0); Y:(X:0; Y:-1; Z:0; W:0); Z:(X:-1.2167964414e-08; Y:0; Z:1; W:0); W:(X:0; Y:0; Z:0; W:1)) ); *) var TM: TGLMatrix; begin // Setup appropriate FOV with CurrentGLContext.PipelineTransformation do begin SetProjectionMatrix(CreatePerspectiveMatrix(90, 1, FCubeMapZNear, FCubeMapZFar)); TM := CreateTranslationMatrix(FCubeMapTranslation); (* SetViewMatrix(MatrixMultiply(cFaceMat[FCubeMapRotIdx], TM)); *) end; end; procedure TGLNonVisualViewer.RenderCubeMapTextures(cubeMapTexture: TGLTexture; zNear: Single = 0; zFar: Single = 0); var oldEvent: TNotifyEvent; begin Assert((Width = Height), 'Memory Viewer must render to a square!'); Assert(Assigned(FBuffer.FCamera), 'Camera not specified'); Assert(Assigned(cubeMapTexture), 'Texture not specified'); if zFar <= 0 then zFar := FBuffer.FCamera.DepthOfView; if zNear <= 0 then zNear := zFar * 0.001; oldEvent := FBuffer.FCamera.FDeferredApply; FBuffer.FCamera.FDeferredApply := SetupCubeMapCamera; FCubeMapZNear := zNear; FCubeMapZFar := zFar; VectorScale(FBuffer.FCamera.AbsolutePosition, -1, FCubeMapTranslation); try FCubeMapRotIdx := 0; while FCubeMapRotIdx < 6 do begin Render; Buffer.CopyToTexture(cubeMapTexture, 0, 0, Width, Height, 0, 0, GL_TEXTURE_CUBE_MAP_POSITIVE_X + FCubeMapRotIdx); Inc(FCubeMapRotIdx); end; finally FBuffer.FCamera.FDeferredApply := oldEvent; end; end; procedure TGLNonVisualViewer.SetBeforeRender(const val: TNotifyEvent); begin FBuffer.BeforeRender := val; end; function TGLNonVisualViewer.GetBeforeRender: TNotifyEvent; begin Result := FBuffer.BeforeRender; end; procedure TGLNonVisualViewer.SetPostRender(const val: TNotifyEvent); begin FBuffer.PostRender := val; end; function TGLNonVisualViewer.GetPostRender: TNotifyEvent; begin Result := FBuffer.PostRender; end; procedure TGLNonVisualViewer.SetAfterRender(const val: TNotifyEvent); begin FBuffer.AfterRender := val; end; function TGLNonVisualViewer.GetAfterRender: TNotifyEvent; begin Result := FBuffer.AfterRender; end; procedure TGLNonVisualViewer.SetCamera(const val: TGLCamera); begin FBuffer.Camera := val; end; function TGLNonVisualViewer.GetCamera: TGLCamera; begin Result := FBuffer.Camera; end; procedure TGLNonVisualViewer.SetBuffer(const val: TGLSceneBuffer); begin FBuffer.Assign(val); end; procedure TGLNonVisualViewer.DoOnPrepareGLContext(sender: TObject); begin PrepareGLContext; end; procedure TGLNonVisualViewer.PrepareGLContext; begin // nothing, reserved for subclasses end; procedure TGLNonVisualViewer.DoBufferChange(Sender: TObject); begin // nothing, reserved for subclasses end; procedure TGLNonVisualViewer.DoBufferStructuralChange(Sender: TObject); begin FBuffer.DestroyRC; end; procedure TGLNonVisualViewer.SetWidth(const val: Integer); begin if val <> FWidth then begin FWidth := val; if FWidth < 1 then FWidth := 1; DoBufferStructuralChange(Self); end; end; procedure TGLNonVisualViewer.SetHeight(const val: Integer); begin if val <> FHeight then begin FHeight := val; if FHeight < 1 then FHeight := 1; DoBufferStructuralChange(Self); end; end; // ------------------ // ------------------ TGLMemoryViewer ------------------ // ------------------ constructor TGLMemoryViewer.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 256; Height := 256; FBufferCount := 1; end; procedure TGLMemoryViewer.InstantiateRenderingContext; begin if FBuffer.RenderingContext = nil then begin FBuffer.SetViewPort(0, 0, Width, Height); FBuffer.CreateRC(HWND(0), True, FBufferCount); end; end; procedure TGLMemoryViewer.Render(baseObject: TGLBaseSceneObject = nil); begin InstantiateRenderingContext; FBuffer.Render(baseObject); end; procedure TGLMemoryViewer.SetBufferCount(const Value: integer); const MaxAxuBufCount = 4; // Current hardware limit = 4 begin if FBufferCount = Value then Exit; FBufferCount := Value; if FBufferCount < 1 then FBufferCount := 1; if FBufferCount > MaxAxuBufCount then FBufferCount := MaxAxuBufCount; // Request a new Instantiation of RC on next render FBuffer.DestroyRC; end; // ------------------ // ------------------ TGLInitializableObjectList ------------------ // ------------------ function TGLInitializableObjectList.Add(const Item: IGLInitializable): Integer; begin Result := inherited Add(Pointer(Item)); end; function TGLInitializableObjectList.GetItems( const Index: Integer): IGLInitializable; begin Result := IGLInitializable(inherited Get(Index)); end; procedure TGLInitializableObjectList.PutItems(const Index: Integer; const Value: IGLInitializable); begin inherited Put(Index, Pointer(Value)); end; //------------------------------------------------------------------------------ initialization //------------------------------------------------------------------------------ RegisterClasses([TGLLightSource, TGLCamera, TGLProxyObject, TGLScene, TGLDirectOpenGL, TGLRenderPoint, TGLMemoryViewer]); // preparation for high resolution timer QueryPerformanceFrequency(vCounterFrequency); end.