// // The graphics engine GLScene https://github.com/glscene // unit GLS.ParticleFX; (* Base classes for scene-wide blended particles FX. These provide a mechanism to render heterogenous particles systems with per particle depth-sorting (allowing correct rendering of interwoven separate fire and smoke particle systems for instance). *) interface {$I GLScene.Defines.inc} uses Winapi.OpenGL, System.Classes, System.SysUtils, System.Types, System.Math, GLScene.OpenGLTokens, GLS.Scene, GLScene.Utils, GLS.PipelineTransformation, GLS.State, GLScene.VectorTypes, GLScene.PersistentClasses, GLScene.VectorGeometry, GLScene.XCollection, GLS.Material, GLS.Cadencer, GLScene.VectorLists, GLS.Graphics, GLS.Context, GLS.Color, GLScene.BaseClasses, GLScene.Coordinates, GLS.RenderContextInfo, GLScene.Manager, GLScene.TextureFormat; const cPFXNbRegions = 128; // number of distance regions cPFXGranularity = 128; // granularity of particles per region type TGLParticleList = class; TGLParticleFXManager = class; TGLParticleFXEffect = class; (* Base class for particles. The class implements properties for position, velocity and time, whatever you need in excess of that will have to be placed in subclasses (this class should remain as compact as possible). *) TGLParticle = class(TGPersistentObject) private FID, FTag: Integer; FManager: TGLParticleFXManager; // NOT persistent FPosition: TAffineVector; FVelocity: TAffineVector; FRotation: Single; FCreationTime: Double; FEffectScale: Single; function GetPosition(const Index: Integer): Single; procedure WritePosition(const Index: Integer; const aValue: Single); function GetVelocity(const Index: Integer): Single; procedure WriteVelocity(const Index: Integer; const aValue: Single); public constructor Create; override; destructor Destroy; override; procedure WriteToFiler(writer: TGVirtualWriter); override; procedure ReadFromFiler(reader: TGVirtualReader); override; property Manager: TGLParticleFXManager read FManager write FManager; // Particle's ID, given at birth. ID is a value unique per manager. property ID: Integer read FID; (* Particle's absolute position. Note that this property is read-accessed directly at rendering time in the innards of the depth-sorting code. *) property Position: TAffineVector read FPosition write FPosition; (* Particle's velocity. This velocity is indicative and is NOT automatically applied to the position during progression events by this class (subclasses may implement that). *) property Velocity: TAffineVector read FVelocity write FVelocity; // Time at which particle was created property CreationTime: Double read FCreationTime write FCreationTime; property PosX : Single index 0 read GetPosition write WritePosition; property PosY : Single index 1 read GetPosition write WritePosition; property PosZ : Single index 2 read GetPosition write WritePosition; property VelX : Single index 0 read GetVelocity write WriteVelocity; property VelY : Single index 1 read GetVelocity write WriteVelocity; property VelZ : Single index 2 read GetVelocity write WriteVelocity; property Tag: Integer read FTag write FTag; end; TGLParticleClass = class of TGLParticle; TGLParticleArray = array[0..MaxInt shr 4] of TGLParticle; PGLParticleArray = ^TGLParticleArray; (* List of particles. This list is managed with particles and performance in mind, make sure to check methods doc. *) TGLParticleList = class(TGPersistentObject) private FOwner: TGLParticleFXManager; // NOT persistent FItemList: TGPersistentObjectList; FDirectList: PGLParticleArray; // NOT persistent protected function GetItems(index: Integer): TGLParticle; procedure SetItems(index: Integer; val: TGLParticle); procedure AfterItemCreated(Sender: TObject); public constructor Create; override; destructor Destroy; override; procedure WriteToFiler(writer: TGVirtualWriter); override; procedure ReadFromFiler(reader: TGVirtualReader); override; // Refers owner manager property Owner: TGLParticleFXManager read FOwner write FOwner; property Items[index: Integer]: TGLParticle read GetItems write SetItems; default; function ItemCount: Integer; (* Adds a particle to the list. Particle owneship is defined blindly, if the particle was previously in another list, it won't be automatically removed from that list. *) function AddItem(aItem: TGLParticle): Integer; (* Removes and frees a particular item for the list. If the item is not part of the list, nothing is done. If found in the list, the item's "slot" is set to nil and item is freed (after setting its ownership to nil). The nils can be removed with a call to Pack. *) procedure RemoveAndFreeItem(aItem: TGLParticle); function IndexOfItem(aItem: TGLParticle): Integer; (* Packs the list by removing all "nil" items. Note: this functions is orders of magnitude faster than the TList version. *) procedure Pack; property List: PGLParticleArray read FDirectList; end; TGLParticleFXRenderer = class; TPFXCreateParticleEvent = procedure(Sender: TObject; aParticle: TGLParticle) of object; (* Base class for particle FX managers. Managers take care of life and death of particles for a particular particles FX system. You can have multiple scene-wide particle FX managers in a scene, handled by the same ParticleFxRenderer. Before subclassing, make sure you understood how the Initialize/Finalize Rendering, Begin/End Particles and RenderParticles methods (and also understood that rendering of manager's particles may be interwoven). *) TGLParticleFXManager = class(TGLCadencedComponent) private FBlendingMode: TGLBlendingMode; FRenderer: TGLParticleFXRenderer; FParticles: TGLParticleList; FNextID: Integer; FOnCreateParticle: TPFXCreateParticleEvent; FAutoFreeWhenEmpty: Boolean; FUsers: TList; //list of objects that use this manager protected procedure SetRenderer(const val: TGLParticleFXRenderer); procedure SetParticles(const aParticles: TGLParticleList); (* Texturing mode for the particles. Subclasses should return GL_TEXTURE_1D, 2D or 3D depending on their needs, and zero if they don't use texturing. This method is used to reduce the number of texturing activations/deactivations. *) function TexturingMode: Cardinal; virtual; abstract; (* Invoked when the particles of the manager will be rendered. This method is fired with the "base" OpenGL states and matrices that will be used throughout the whole rendering, per-frame initialization should take place here. OpenGL states/matrices should not be altered in any way here. *) procedure InitializeRendering(var rci: TGLRenderContextInfo); virtual; abstract; (* Triggered just before rendering a set of particles. The current OpenGL state should be assumed to be the "base" one as was found during InitializeRendering. Manager-specific states should be established here. Multiple BeginParticles can occur during a render (but all will be between InitializeRendering and Finalizerendering, and at least one particle will be rendered before EndParticles is invoked). *) procedure BeginParticles(var rci: TGLRenderContextInfo); virtual; abstract; (* Request to render a particular particle. Due to the nature of the rendering, no particular order should be assumed. If possible, no OpenGL state changes should be made in this method, but should be placed in Begin/EndParticles. *) procedure RenderParticle(var rci: TGLRenderContextInfo; aParticle: TGLParticle); virtual; abstract; (* Triggered after a set of particles as been rendered. If OpenGL state were altered directly (ie. not through the states caches of GLMisc), it should be restored back to the "base" state. *) procedure EndParticles(var rci: TGLRenderContextInfo); virtual; abstract; // Invoked when rendering of particles for this manager is done. procedure FinalizeRendering(var rci: TGLRenderContextInfo); virtual; abstract; // ID for the next created particle. property NextID: Integer read FNextID write FNextID; // Blending mode for the particles. Protected and unused in the base class property BlendingMode: TGLBlendingMode read FBlendingMode write FBlendingMode; // Apply BlendingMode relatively to the renderer's blending mode. procedure ApplyBlendingMode(var rci: TGLRenderContextInfo); // Unapply BlendingMode relatively by restoring the renderer's blending mode. procedure UnapplyBlendingMode(var rci: TGLRenderContextInfo); procedure registerUser(obj: TGLParticleFXEffect); procedure unregisterUser(obj: TGLParticleFXEffect); public constructor Create(aOwner: TComponent); override; destructor Destroy; override; procedure NotifyChange(Sender: TObject); override; procedure DoProgress(const progressTime: TGProgressTimes); override; // Class of particles created by this manager. } class function ParticlesClass: TGLParticleClass; virtual; // Creates a new particle controled by the manager. function CreateParticle: TGLParticle; virtual; // Create several particles at once. procedure CreateParticles(nbParticles: Integer); // A TGLParticleList property. property Particles: TGLParticleList read FParticles write SetParticles; (* Return the number of particles. Note that subclasses may decide to return a particle count inferior to Particles.ItemCount, and the value returned by this method will be the one honoured at render time. *) function ParticleCount: Integer; virtual; (* If True the manager will free itself when its particle count reaches zero. Check happens in the progression event, use with caution and only if you know what you're doing! *) property AutoFreeWhenEmpty: Boolean read FAutoFreeWhenEmpty write FAutoFreeWhenEmpty; published (* References the renderer. The renderer takes care of ordering the particles of the manager (and other managers linked to it) and rendering them all depth-sorted. *) property Renderer: TGLParticleFXRenderer read FRenderer write SetRenderer; // Event triggered after standard particle creation and initialization. property OnCreateParticle: TPFXCreateParticleEvent read FOnCreateParticle write FOnCreateParticle; property Cadencer; end; // Base class for linking scene objects to a particle FX manager. TGLParticleFXEffect = class(TGLObjectPostEffect) private FManager: TGLParticleFXManager; FManagerName: string; FEffectScale: single; procedure SetEffectScale(const Value: single); // NOT persistent, temporarily used for persistence protected procedure SetManager(val: TGLParticleFXManager); procedure WriteToFiler(writer: TWriter); override; procedure ReadFromFiler(reader: TReader); override; procedure Loaded; override; procedure managerNotification(aManager: TGLParticleFXManager; Operation: TOperation); public constructor Create(aOwner: TXCollection); override; destructor Destroy; override; published // Reference to the Particle FX manager property Manager: TGLParticleFXManager read FManager write SetManager; property EffectScale: single read FEffectScale write SetEffectScale; end; // PFX region rendering structures TParticleReference = packed record particle: TGLParticle; distance: Integer; // stores an IEEE single! end; PParticleReference = ^TParticleReference; TParticleReferenceArray = packed array[0..MaxInt shr 8-1] of TParticleReference; PParticleReferenceArray = ^TParticleReferenceArray; PFXPointerList = ^TFXPointerList; TFXPointerList = array[0..MaxInt shr 8-1] of Pointer; TPFXRegion = record count, capacity: Integer; particleRef: PParticleReferenceArray; particleOrder: PFXPointerList; end; PPFXRegion = ^TPFXRegion; TPFXSortAccuracy = (saLow, saOneTenth, saOneThird, saOneHalf, saHigh); (* Rendering interface for scene-wide particle FX. A renderer can take care of rendering any number of particle systems, its main task being to depth-sort the particles so that they are blended appropriately. This object will usually be placed at the end of the scene hierarchy, just before the HUD overlays, its position, rotation etc. is of no importance and has no effect on the rendering of the particles. *) TGLParticleFXRenderer = class(TGLBaseSceneObject) private FManagerList: TList; FLastSortTime: Double; FLastParticleCount: Integer; FZWrite, FZTest, FZCull: Boolean; FZSortAccuracy: TPFXSortAccuracy; FZMaxDistance: Single; FBlendingMode: TGLBlendingMode; FRegions: array[0..cPFXNbRegions - 1] of TPFXRegion; protected function StoreZMaxDistance: Boolean; // Register a manager procedure RegisterManager(aManager: TGLParticleFXManager); // UnRegister a manager procedure UnRegisterManager(aManager: TGLParticleFXManager); procedure UnRegisterAll; public constructor Create(aOwner: TComponent); override; destructor Destroy; override; (* Quick Explanation of what is below: The purpose is to depth-sort a large number (thousandths) of particles and render them back to front. The rendering part is not particularly complex, it just invokes the various PFX managers involved and request particle renderings. The sort uses a first-pass region partition (the depth range is split into regions, and particles are assigned directly to the region they belong to), then each region is sorted with a QuickSort. The QuickSort itself is the regular classic variant, but the comparison is made on singles as if they were integers, this is allowed by the IEEE format in a very efficient manner if all values are superior to 1, which is ensured by the distance calculation and a fixed offset of 1 *) procedure BuildList(var rci: TGLRenderContextInfo); override; // Time (in msec) spent sorting the particles for last render. property LastSortTime: Double read FLastSortTime; // Amount of particles during the last render. property LastParticleCount: Integer read FLastParticleCount; published (* Specifies if particles should write to ZBuffer. If the PFXRenderer is the last object to be rendered in the scene, it is not necessary to write to the ZBuffer since the particles are depth-sorted. Writing to the ZBuffer has a performance penalty. *) property ZWrite: Boolean read FZWrite write FZWrite default False; // Specifies if particles should write to test ZBuffer. property ZTest: Boolean read FZTest write FZTest default True; // If true the renderer will cull particles that are behind the camera. property ZCull: Boolean read FZCull write FZCull default True; (* If true particles will be accurately sorted back to front. When false, only a rough ordering is used, which can result in visual glitches but may be faster. *) property ZSortAccuracy: TPFXSortAccuracy read FZSortAccuracy write FZSortAccuracy default saHigh; (* Maximum distance for rendering PFX particles. If zero, camera's DepthOfView is used. *) property ZMaxDistance: Single read FZMaxDistance write FZMaxDistance stored StoreZMaxDistance; (* Default blending mode for particles. "Additive" blending is the usual mode (increases brightness and saturates), "transparency" may be used for smoke or systems that opacify view, "opaque" is more rarely used. Note: specific PFX managers may override/ignore this setting. *) property BlendingMode: TGLBlendingMode read FBlendingMode write FBlendingMode default bmAdditive; property Visible; end; TGLSourcePFXVelocityMode = (svmAbsolute, svmRelative); TGLSourcePFXPositionMode = (spmAbsoluteOffset, spmRelative); TGLSourcePFXDispersionMode = (sdmFast, sdmIsotropic, sdmGaussian); // Simple Particles Source. TGLSourcePFXEffect = class(TGLParticleFXEffect) private FInitialVelocity: TGCoordinates; FInitialPosition: TGCoordinates; FPositionDispersionRange: TGCoordinates; FVelocityDispersion: Single; FPositionDispersion: Single; FParticleInterval: Single; FVelocityMode: TGLSourcePFXVelocityMode; FPositionMode: TGLSourcePFXPositionMode; FDispersionMode: TGLSourcePFXDispersionMode; FEnabled: Boolean; FDisabledIfOwnerInvisible: Boolean; FTimeRemainder: Double; FRotationDispersion: Single; protected procedure SetInitialVelocity(const val: TGCoordinates); procedure SetInitialPosition(const val: TGCoordinates); procedure SetPositionDispersionRange(const val: TGCoordinates); procedure SetParticleInterval(const val: Single); procedure WriteToFiler(writer: TWriter); override; procedure ReadFromFiler(reader: TReader); override; function ParticleAbsoluteInitialPos: TAffineVector; public constructor Create(aOwner: TXCollection); override; destructor Destroy; override; class function FriendlyName: string; override; class function FriendlyDescription: string; override; procedure DoProgress(const progressTime: TGProgressTimes); override; // Instantaneously creates nb particles procedure Burst(time: Double; nb: Integer); procedure RingExplosion(time: Double; minInitialSpeed, maxInitialSpeed: Single; nbParticles: Integer); published property InitialVelocity: TGCoordinates read FInitialVelocity write SetInitialVelocity; property VelocityDispersion: Single read FVelocityDispersion write FVelocityDispersion; property InitialPosition: TGCoordinates read FInitialPosition write SetInitialPosition; property PositionDispersion: Single read FPositionDispersion write FPositionDispersion; property PositionDispersionRange: TGCoordinates read FPositionDispersionRange write SetPositionDispersionRange; property ParticleInterval: Single read FParticleInterval write SetParticleInterval; property VelocityMode: TGLSourcePFXVelocityMode read FVelocityMode write FVelocityMode default svmAbsolute; property PositionMode: TGLSourcePFXPositionMode read FPositionMode write FPositionMode default spmAbsoluteOffset; property DispersionMode: TGLSourcePFXDispersionMode read FDispersionMode write FDispersionMode default sdmFast; property RotationDispersion: Single read FRotationDispersion write FRotationDispersion; property Enabled: boolean read FEnabled write FEnabled; property DisabledIfOwnerInvisible: boolean read FDisabledIfOwnerInvisible write FDisabledIfOwnerInvisible; end; (* An abstract PFX manager for simple dynamic particles. Adds properties and progress implementation for handling moving particles (simple velocity and const acceleration integration). *) TGLDynamicPFXManager = class(TGLParticleFXManager) private FAcceleration: TGCoordinates; FFriction: Single; FCurrentTime: Double; //FRotationCenter: TAffineVector; protected procedure SetAcceleration(const val: TGCoordinates); (* Returns the maximum age for a particle. Particles older than that will be killed by DoProgress. *) function MaxParticleAge: Single; virtual; abstract; property CurrentTime: Double read FCurrentTime; public constructor Create(aOwner: TComponent); override; destructor Destroy; override; procedure DoProgress(const progressTime: TGProgressTimes); override; published // Oriented acceleration applied to the particles. property Acceleration: TGCoordinates read FAcceleration write SetAcceleration; (* Friction applied to the particles. Friction is applied as a speed scaling factor over 1 second, ie. a friction of 0.5 will half speed over 1 second, a friction of 3 will triple speed over 1 second, and a friction of 1 (default value) will have no effect. *) property Friction: Single read FFriction write FFriction; end; TPFXLifeColor = class(TCollectionItem) private FColorInner: TGLColor; FColorOuter: TGLColor; FLifeTime, FInvLifeTime: Single; FIntervalRatio: Single; FSizeScale: Single; FDoScale: Boolean; FDoRotate: boolean; FRotateAngle: Single; protected function GetDisplayName: string; override; procedure SetColorInner(const val: TGLColor); procedure SetColorOuter(const val: TGLColor); procedure SetLifeTime(const val: Single); procedure SetSizeScale(const val: Single); procedure SetRotateAngle(const Value: Single); // indirectly persistent public constructor Create(Collection: TCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; // Stores 1/LifeTime property InvLifeTime: Single read FInvLifeTime; // Stores 1/(LifeTime[Next]-LifeTime[Self]) property InvIntervalRatio: Single read FIntervalRatio; published property ColorInner: TGLColor read FColorInner write SetColorInner; property ColorOuter: TGLColor read FColorOuter write SetColorOuter; property LifeTime: Single read FLifeTime write SetLifeTime; property SizeScale: Single read FSizeScale write SetSizeScale; property RotateAngle: Single read FRotateAngle write SetRotateAngle; end; TPFXLifeColors = class(TOwnedCollection) protected procedure SetItems(index: Integer; const val: TPFXLifeColor); function GetItems(index: Integer): TPFXLifeColor; public constructor Create(AOwner: TPersistent); function Add: TPFXLifeColor; function FindItemID(ID: Integer): TPFXLifeColor; property Items[index: Integer]: TPFXLifeColor read GetItems write SetItems; default; function MaxLifeTime: Double; function RotationsDefined: Boolean; function ScalingDefined: Boolean; procedure PrepareIntervalRatios; end; (* Base PFX manager for particles with life colors. Particles have a core and edge color, for subclassing. *) TGLLifeColoredPFXManager = class(TGLDynamicPFXManager) private FLifeColors: TPFXLifeColors; FLifeColorsLookup: TList; FLifeRotations: Boolean; FLifeScaling: Boolean; FColorInner: TGLColor; FColorOuter: TGLColor; FParticleSize: Single; protected procedure SetLifeColors(const val: TPFXLifeColors); procedure SetColorInner(const val: TGLColor); procedure SetColorOuter(const val: TGLColor); procedure InitializeRendering(var rci: TGLRenderContextInfo); override; procedure FinalizeRendering(var rci: TGLRenderContextInfo); override; function MaxParticleAge: Single; override; procedure ComputeColors(var lifeTime: Single; var inner, outer: TGLColorVector); procedure ComputeInnerColor(var lifeTime: Single; var inner: TGLColorVector); procedure ComputeOuterColor(var lifeTime: Single; var outer: TGLColorVector); function ComputeSizeScale(var lifeTime: Single; var sizeScale: Single): Boolean; function ComputeRotateAngle(var lifeTime, rotateAngle: Single): Boolean; procedure RotateVertexBuf(buf: TGAffineVectorList; lifeTime: Single; const axis: TAffineVector; offsetAngle: Single); public constructor Create(aOwner: TComponent); override; destructor Destroy; override; property ParticleSize: Single read FParticleSize write FParticleSize; property ColorInner: TGLColor read FColorInner write SetColorInner; property ColorOuter: TGLColor read FColorOuter write SetColorOuter; property LifeColors: TPFXLifeColors read FLifeColors write SetLifeColors; published property BlendingMode default bmAdditive; end; TPFXDirectRenderEvent = procedure(Sender: TObject; aParticle: TGLParticle; var rci: TGLRenderContextInfo) of object; TPFXProgressEvent = procedure(Sender: TObject; const progressTime: TGProgressTimes; var defaultProgress: Boolean) of object; TPFXParticleProgress = procedure(Sender: TObject; const progressTime: TGProgressTimes; aParticle: TGLParticle; var killParticle: Boolean) of object; TPFXGetParticleCountEvent = function(Sender: TObject): Integer of object; (* A particles FX manager offering events for customization/experimentation. This manager essentially surfaces the PFX methods as events, and is best suited when you have specific particles that don't fall into any existing category, or when you want to experiment with particles and later plan to wrap things up in a full-blown manager. If the events aren't handled, nothing will be rendered. *) TGLCustomPFXManager = class(TGLLifeColoredPFXManager) private FOnInitializeRendering: TGLDirectRenderEvent; FOnBeginParticles: TGLDirectRenderEvent; FOnRenderParticle: TPFXDirectRenderEvent; FOnEndParticles: TGLDirectRenderEvent; FOnFinalizeRendering: TGLDirectRenderEvent; FOnProgress: TPFXProgressEvent; FOnParticleProgress: TPFXParticleProgress; FOnGetParticleCountEvent: TPFXGetParticleCountEvent; protected function TexturingMode: Cardinal; override; procedure InitializeRendering(var rci: TGLRenderContextInfo); override; procedure BeginParticles(var rci: TGLRenderContextInfo); override; procedure RenderParticle(var rci: TGLRenderContextInfo; aParticle: TGLParticle); override; procedure EndParticles(var rci: TGLRenderContextInfo); override; procedure FinalizeRendering(var rci: TGLRenderContextInfo); override; public procedure DoProgress(const progressTime: TGProgressTimes); override; function ParticleCount: Integer; override; published property OnInitializeRendering: TGLDirectRenderEvent read FOnInitializeRendering write FOnInitializeRendering; property OnBeginParticles: TGLDirectRenderEvent read FOnBeginParticles write FOnBeginParticles; property OnRenderParticle: TPFXDirectRenderEvent read FOnRenderParticle write FOnRenderParticle; property OnEndParticles: TGLDirectRenderEvent read FOnEndParticles write FOnEndParticles; property OnFinalizeRendering: TGLDirectRenderEvent read FOnFinalizeRendering write FOnFinalizeRendering; property OnProgress: TPFXProgressEvent read FOnProgress write FOnProgress; property OnParticleProgress: TPFXParticleProgress read FOnParticleProgress write FOnParticleProgress; property OnGetParticleCountEvent: TPFXGetParticleCountEvent read FOnGetParticleCountEvent write FOnGetParticleCountEvent; property ParticleSize; property ColorInner; property ColorOuter; property LifeColors; end; (* Polygonal particles FX manager. The particles of this manager are made of N-face regular polygon with a core and edge color. No texturing is available. If you render large particles and don't have T&L acceleration, consider using TGLPointLightPFXManager. *) TGLPolygonPFXManager = class(TGLLifeColoredPFXManager) private FNbSides: Integer; Fvx, Fvy: TAffineVector; // NOT persistent FVertices: TGAffineVectorList; // NOT persistent FVertBuf: TGAffineVectorList; // NOT persistent protected procedure SetNbSides(const val: Integer); function TexturingMode: Cardinal; override; procedure InitializeRendering(var rci: TGLRenderContextInfo); override; procedure BeginParticles(var rci: TGLRenderContextInfo); override; procedure RenderParticle(var rci: TGLRenderContextInfo; aParticle: TGLParticle); override; procedure EndParticles(var rci: TGLRenderContextInfo); override; procedure FinalizeRendering(var rci: TGLRenderContextInfo); override; public constructor Create(aOwner: TComponent); override; destructor Destroy; override; published property NbSides: Integer read FNbSides write SetNbSides default 6; property ParticleSize; property ColorInner; property ColorOuter; property LifeColors; end; (* Sprite color modes. scmFade: vertex coloring is used to fade inner-outer scmInner: vertex coloring uses inner color only scmOuter: vertex coloring uses outer color only scmNone: vertex coloring is NOT used (colors are ignored) *) TSpriteColorMode = (scmFade, scmInner, scmOuter, scmNone); // Sprites per sprite texture for the SpritePFX. TSpritesPerTexture = (sptOne, sptFour); (* Base class for sprite-based particles FX managers. The particles are made of optionally centered single-textured quads. *) TGLBaseSpritePFXManager = class(TGLLifeColoredPFXManager) private FTexHandle: TGLTextureHandle; Fvx, Fvy, Fvz: TAffineVector; // NOT persistent FVertices: TGAffineVectorList; // NOT persistent FVertBuf: TGAffineVectorList; // NOT persistent FAspectRatio: Single; FRotation: Single; FShareSprites: TGLBaseSpritePFXManager; FSpritesPerTexture: TSpritesPerTexture; FColorMode: TSpriteColorMode; protected // Subclasses should draw their stuff in this bmp32. procedure PrepareImage(bmp32: TGLBitmap32; var texFormat: Integer); virtual; abstract; procedure BindTexture(var rci: TGLRenderContextInfo); procedure SetSpritesPerTexture(const val: TSpritesPerTexture); virtual; procedure SetColorMode(const val: TSpriteColorMode); procedure SetAspectRatio(const val: Single); function StoreAspectRatio: Boolean; procedure SetRotation(const val: Single); procedure SetShareSprites(const val: TGLBaseSpritePFXManager); function TexturingMode: Cardinal; override; procedure InitializeRendering(var rci: TGLRenderContextInfo); override; procedure BeginParticles(var rci: TGLRenderContextInfo); override; procedure RenderParticle(var rci: TGLRenderContextInfo; aParticle: TGLParticle); override; procedure EndParticles(var rci: TGLRenderContextInfo); override; procedure FinalizeRendering(var rci: TGLRenderContextInfo); override; property SpritesPerTexture: TSpritesPerTexture read FSpritesPerTexture write SetSpritesPerTexture; public constructor Create(aOwner: TComponent); override; destructor Destroy; override; property ColorMode: TSpriteColorMode read FColorMode write SetColorMode; published (* Ratio between width and height. An AspectRatio of 1 (default) will result in square sprite particles, values higher than one will result in horizontally stretched sprites, values below one will stretch vertically (assuming no rotation is applied). *) property AspectRatio: Single read FAspectRatio write SetAspectRatio stored StoreAspectRatio; (* Particle sprites rotation (in degrees). All particles of the PFX manager share this rotation. *) property Rotation: Single read FRotation write SetRotation; (* If specified the manager will reuse the other manager's sprites. Sharing sprites between PFX managers can help at the rendering stage if particles of the managers are mixed by helping reduce the number of texture switches. Note that only the texture is shared, not the colors, sizes or other dynamic parameters. *) property ShareSprites: TGLBaseSpritePFXManager read FShareSprites write FShareSprites; end; TPFXPrepareTextureImageEvent = procedure(Sender: TObject; destBmp32: TGLBitmap32; var texFormat: Integer) of object; // A sprite-based particles FX managers using user-specified code to prepare the texture TGLCustomSpritePFXManager = class(TGLBaseSpritePFXManager) private FOnPrepareTextureImage: TPFXPrepareTextureImageEvent; protected procedure PrepareImage(bmp32: TGLBitmap32; var texFormat: Integer); override; public constructor Create(aOwner: TComponent); override; destructor Destroy; override; published // Place your texture rendering code in this event. property OnPrepareTextureImage: TPFXPrepareTextureImageEvent read FOnPrepareTextureImage write FOnPrepareTextureImage; property ColorMode default scmInner; property SpritesPerTexture default sptOne; property ParticleSize; property ColorInner; property ColorOuter; property LifeColors; end; (* A sprite-based particles FX managers using point light maps. The texture map is a round, distance-based transparency map (center "opaque"), you can adjust the quality (size) of the underlying texture map with the TexMapSize property. This PFX manager renders particles similar to what you can get with TGLPolygonPFXManager but stresses fillrate more than T&L rate (and will usually be slower than the PolygonPFX when nbSides is low or T&L acceleration available). Consider this implementation as a sample for your own PFX managers that may use particles with more complex textures. *) TGLPointLightPFXManager = class(TGLBaseSpritePFXManager) private FTexMapSize: Integer; protected procedure PrepareImage(bmp32: TGLBitmap32; var texFormat: Integer); override; procedure SetTexMapSize(const val: Integer); public constructor Create(aOwner: TComponent); override; destructor Destroy; override; published (* Underlying texture map size, as a power of two. Min value is 3 (size=8), max value is 9 (size=512). *) property TexMapSize: Integer read FTexMapSize write SetTexMapSize default 5; property ColorMode default scmInner; property ParticleSize; property ColorInner; property ColorOuter; property LifeColors; end; // Returns or creates the TGLBInertia within the given object's behaviours. function GetOrCreateSourcePFX(obj: TGLBaseSceneObject; const name: string = ''): TGLSourcePFXEffect; // ------------------------------------------------------------------ implementation // ------------------------------------------------------------------ function GetOrCreateSourcePFX(obj: TGLBaseSceneObject; const name: string = ''): TGLSourcePFXEffect; var i: Integer; begin with obj.Effects do begin if name = '' then begin i := IndexOfClass(TGLSourcePFXEffect); if i >= 0 then Result := TGLSourcePFXEffect(Items[i]) else Result := TGLSourcePFXEffect.Create(obj.Effects); end else begin i := IndexOfName(name); if i >= 0 then Result := (Items[i] as TGLSourcePFXEffect) else begin Result := TGLSourcePFXEffect.Create(obj.Effects); Result.Name := name; end; end; end; end; function GaussianRandom(Sigma : single): single; begin Result := Sigma * Sqrt(-2.0 * Ln(Random)) * Cos(2 * Pi * Random); end; procedure RndVector(const dispersion: TGLSourcePFXDispersionMode; var v: TAffineVector; var f: Single; dispersionRange: TGCoordinates); function GetRandomVector(NotIsotropic : boolean) : TVector3f; // Isotropic gives constrainted vector within a radius const LRadius = 0.5; begin repeat Result.X := (Random - 0.5); Result.Y := (Random - 0.5); Result.Z := (Random - 0.5); until NotIsotropic or (VectorNorm(Result) <= LRadius * LRadius); end; var f2: Single; p: TGLVector; begin f2 := 2 * f; if Assigned(dispersionRange) then p := VectorScale(dispersionRange.DirectVector, f2) else p := VectorScale(XYZHmgVector, f2); v := GetRandomVector(dispersion = sdmFast); if dispersion = sdmGaussian then ScaleVector(v, MinFloat(0.5, GaussianRandom(0.6))); v.X := v.X * p.X; v.Y := v.Y * p.Y; v.Z := v.Z * p.Z; end; // ------------------ // ------------------ TGLParticle ------------------ // ------------------ constructor TGLParticle.Create; begin FEffectScale := 1; inherited Create; end; destructor TGLParticle.Destroy; begin inherited Destroy; end; function TGLParticle.GetPosition(const Index: Integer): Single; begin Result := FPosition.V[Index]; end; procedure TGLParticle.WritePosition(const Index: Integer; const aValue: Single); begin if (aValue <> FPosition.V[Index]) then FPosition.V[Index] := aValue; end; function TGLParticle.GetVelocity(const Index: Integer): Single; begin Result := FVelocity.X; end; procedure TGLParticle.WriteVelocity(const Index: Integer; const aValue: Single); begin if (aValue <> FVelocity.V[Index]) then FVelocity.V[Index] := aValue; end; procedure TGLParticle.WriteToFiler(writer: TGVirtualWriter); begin inherited WriteToFiler(writer); with writer do begin WriteInteger(0); // Archive Version 0 WriteInteger(FID); Write(FPosition, SizeOf(FPosition)); Write(FVelocity, SizeOf(FVelocity)); WriteFloat(FCreationTime); end; end; procedure TGLParticle.ReadFromFiler(reader: TGVirtualReader); var archiveVersion: integer; begin inherited ReadFromFiler(reader); archiveVersion := reader.ReadInteger; if archiveVersion = 0 then with reader do begin FID := ReadInteger; Read(FPosition, SizeOf(FPosition)); Read(FVelocity, SizeOf(FVelocity)); FCreationTime := ReadFloat; end else RaiseFilerException(archiveVersion); end; // ------------------ // ------------------ TGLParticleList ------------------ // ------------------ constructor TGLParticleList.Create; begin inherited Create; FItemList := TGPersistentObjectList.Create; FitemList.GrowthDelta := 64; FDirectList := nil; end; destructor TGLParticleList.Destroy; begin FItemList.CleanFree; inherited Destroy; end; procedure TGLParticleList.WriteToFiler(writer: TGVirtualWriter); begin inherited WriteToFiler(writer); with writer do begin WriteInteger(0); // Archive Version 0 FItemList.WriteToFiler(writer); end; end; procedure TGLParticleList.ReadFromFiler(reader: TGVirtualReader); var archiveVersion: integer; begin inherited ReadFromFiler(reader); archiveVersion := reader.ReadInteger; if archiveVersion = 0 then with reader do begin FItemList.ReadFromFilerWithEvent(reader, AfterItemCreated); FDirectList := PGLParticleArray(FItemList.List); end else RaiseFilerException(archiveVersion); end; function TGLParticleList.GetItems(index: Integer): TGLParticle; begin Result := TGLParticle(FItemList[index]); end; procedure TGLParticleList.SetItems(index: Integer; val: TGLParticle); begin FItemList[index] := val; end; procedure TGLParticleList.AfterItemCreated(Sender: TObject); begin (Sender as TGLParticle).Manager := Self.Owner; end; function TGLParticleList.ItemCount: Integer; begin Result := FItemList.Count; end; function TGLParticleList.AddItem(aItem: TGLParticle): Integer; begin aItem.Manager := Self.Owner; Result := FItemList.Add(aItem); FDirectList := PGLParticleArray(FItemList.List); end; procedure TGLParticleList.RemoveAndFreeItem(aItem: TGLParticle); var i: Integer; begin i := FItemList.IndexOf(aItem); if i >= 0 then begin if aItem.Manager = Self.Owner then aItem.Manager := nil; aItem.Free; FItemList.List^[i] := nil; end; end; function TGLParticleList.IndexOfItem(aItem: TGLParticle): Integer; begin Result := FItemList.IndexOf(aItem); end; procedure TGLParticleList.Pack; begin FItemList.Pack; FDirectList := PGLParticleArray(FItemList.List); end; // ------------------ // ------------------ TGLParticleFXManager ------------------ // ------------------ constructor TGLParticleFXManager.Create(aOwner: TComponent); begin inherited; FUsers := TList.create; FParticles := TGLParticleList.Create; FParticles.Owner := Self; FBlendingMode := bmAdditive; RegisterManager(Self); end; destructor TGLParticleFXManager.Destroy; var i: integer; begin inherited Destroy; for i := FUsers.Count - 1 downto 0 do TGLParticleFXEffect(FUsers[i]).managerNotification(self, opRemove); DeRegisterManager(Self); Renderer := nil; FParticles.Free; FUsers.Free; end; procedure TGLParticleFXManager.NotifyChange(Sender: TObject); begin if Assigned(FRenderer) then Renderer.StructureChanged; end; procedure TGLParticleFXManager.DoProgress(const progressTime: TGProgressTimes); begin inherited; if FAutoFreeWhenEmpty and (FParticles.ItemCount = 0) then Free; end; class function TGLParticleFXManager.ParticlesClass: TGLParticleClass; begin Result := TGLParticle; end; function TGLParticleFXManager.CreateParticle: TGLParticle; begin Result := ParticlesClass.Create; Result.FID := FNextID; if Assigned(cadencer) then Result.FCreationTime := Cadencer.CurrentTime; Inc(FNextID); FParticles.AddItem(Result); if Assigned(FOnCreateParticle) then FOnCreateParticle(Self, Result); end; procedure TGLParticleFXManager.CreateParticles(nbParticles: Integer); var i: Integer; begin FParticles.FItemList.RequiredCapacity(FParticles.ItemCount + nbParticles); for i := 1 to nbParticles do CreateParticle; end; procedure TGLParticleFXManager.SetRenderer(const val: TGLParticleFXRenderer); begin if FRenderer <> val then begin if Assigned(FRenderer) then FRenderer.UnRegisterManager(Self); FRenderer := val; if Assigned(FRenderer) then FRenderer.RegisterManager(Self); end; end; procedure TGLParticleFXManager.SetParticles(const aParticles: TGLParticleList); begin FParticles.Assign(aParticles); end; function TGLParticleFXManager.ParticleCount: Integer; begin Result := FParticles.FItemList.Count; end; procedure TGLParticleFXManager.ApplyBlendingMode; begin if Renderer.BlendingMode <> BlendingMode then begin // case disjunction to minimize OpenGL State changes if Renderer.BlendingMode in [bmAdditive, bmTransparency] then begin case BlendingMode of bmAdditive: rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOne); bmTransparency: rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha); else // bmOpaque rci.GLStates.Disable(stBlend); end; end else begin case BlendingMode of bmAdditive: begin rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOne); rci.GLStates.Enable(stBlend); end; bmTransparency: begin rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha); rci.GLStates.Enable(stBlend); end; else // bmOpaque, do nothing end; end; end; end; procedure TGLParticleFXManager.UnapplyBlendingMode; begin if Renderer.BlendingMode <> BlendingMode then begin // case disjunction to minimize OpenGL State changes if BlendingMode in [bmAdditive, bmTransparency] then begin case Renderer.BlendingMode of bmAdditive: rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOne); bmTransparency: rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha); else // bmOpaque rci.GLStates.Disable(stBlend); end; end else begin case Renderer.BlendingMode of bmAdditive: begin rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOne); rci.GLStates.Enable(stBlend); end; bmTransparency: begin rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha); rci.GLStates.Enable(stBlend); end; else // bmOpaque, do nothing end; end; end; end; procedure TGLParticleFXManager.registerUser(obj: TGLParticleFXEffect); begin if FUsers.IndexOf(obj) = -1 then FUsers.Add(obj); end; procedure TGLParticleFXManager.unregisterUser(obj: TGLParticleFXEffect); begin FUsers.Remove(obj); end; // ------------------ // ------------------ TGLParticleFXEffect ------------------ // ------------------ constructor TGLParticleFXEffect.Create(aOwner: TXCollection); begin FEffectScale := 1; inherited; end; destructor TGLParticleFXEffect.Destroy; begin Manager := nil; inherited Destroy; end; procedure TGLParticleFXEffect.WriteToFiler(writer: TWriter); var st: string; begin with writer do begin // ArchiveVersion 1, added EffectScale // ArchiveVersion 2, added inherited call WriteInteger(2); inherited; if Manager <> nil then st := Manager.GetNamePath else st := ''; WriteString(st); WriteFloat(FEffectScale); end; end; procedure TGLParticleFXEffect.ReadFromFiler(reader: TReader); var archiveVersion: integer; begin with reader do begin archiveVersion := ReadInteger; Assert(archiveVersion in [0..2]); if archiveVersion >= 2 then inherited; if archiveVersion >= 0 then begin FManagerName := ReadString; Manager := nil; end; if archiveVersion >= 1 then begin FEffectScale := ReadFloat; end; end; end; procedure TGLParticleFXEffect.Loaded; var mng: TComponent; begin inherited; if FManagerName <> '' then begin mng := FindManager(TGLParticleFXManager, FManagerName); if Assigned(mng) then Manager := TGLParticleFXManager(mng); FManagerName := ''; end; end; procedure TGLParticleFXEffect.SetManager(val: TGLParticleFXManager); begin if assigned(FManager) then FManager.unregisterUser(self); FManager := val; if assigned(FManager) then FManager.registerUser(self); end; procedure TGLParticleFXEffect.SetEffectScale(const Value: single); begin FEffectScale := Value; end; procedure TGLParticleFXEffect.managerNotification( aManager: TGLParticleFXManager; Operation: TOperation); begin if (Operation = opRemove) and (aManager = manager) then manager := nil; end; // ------------------ // ------------------ TGLParticleFXRenderer ------------------ // ------------------ constructor TGLParticleFXRenderer.Create(aOwner: TComponent); begin inherited; ObjectStyle := ObjectStyle + [osNoVisibilityCulling, osDirectDraw]; FZTest := True; FZCull := True; FZSortAccuracy := saHigh; FManagerList := TList.Create; FBlendingMode := bmAdditive; end; destructor TGLParticleFXRenderer.Destroy; var i: Integer; begin for i := 0 to cPFXNbRegions - 1 do begin FreeMem(FRegions[i].particleRef); FreeMem(FRegions[i].particleOrder); end; UnRegisterAll; FManagerList.Free; inherited Destroy; end; procedure TGLParticleFXRenderer.RegisterManager(aManager: TGLParticleFXManager); begin FManagerList.Add(aManager); end; procedure TGLParticleFXRenderer.UnRegisterManager(aManager: TGLParticleFXManager); begin FManagerList.Remove(aManager); end; procedure TGLParticleFXRenderer.UnRegisterAll; begin while FManagerList.Count > 0 do TGLParticleFXManager(FManagerList[FManagerList.Count - 1]).Renderer := nil; end; // BuildList // (beware, large and complex stuff below... this is the heart of the ParticleFX) procedure TGLParticleFXRenderer.BuildList(var rci: TGLRenderContextInfo); var dist, distDelta, invRegionSize: Single; managerIdx, particleIdx, regionIdx: Integer; procedure QuickSortRegion(startIndex, endIndex: Integer; region: PPFXRegion); var I, J: Integer; P: Integer; poptr: PPointerArray; buf: Pointer; begin if endIndex - startIndex > 1 then begin poptr := @region^.particleOrder^[0]; repeat I := startIndex; J := endIndex; P := PParticleReference(poptr^[(I + J) shr 1])^.distance; repeat while PParticleReference(poptr^[I])^.distance < P do Inc(I); while PParticleReference(poptr^[J])^.distance > P do Dec(J); if I <= J then begin buf := poptr^[I]; poptr^[I] := poptr^[J]; poptr^[J] := buf; Inc(I); Dec(J); end; until I > J; if startIndex < J then QuickSortRegion(startIndex, J, region); startIndex := I; until I >= endIndex; end else if endIndex - startIndex > 0 then begin poptr := @region^.particleOrder^[0]; if PParticleReference(poptr^[endIndex])^.distance < PParticleReference(poptr^[startIndex])^.distance then begin buf := poptr^[startIndex]; poptr^[startIndex] := poptr^[endIndex]; poptr^[endIndex] := buf; end; end; end; procedure DistToRegionIdx; register; begin regionIdx := Trunc((dist - distDelta) * invRegionSize); end; var minDist, maxDist, sortMaxRegion: Integer; curManager: TGLParticleFXManager; curList: PGLParticleArray; curParticle: TGLParticle; curRegion: PPFXRegion; curParticleOrder: PPointerArray; cameraPos, cameraVector: TAffineVector; timer: Int64; currentTexturingMode: Cardinal; begin if csDesigning in ComponentState then Exit; timer := StartPrecisionTimer; // precalcs PSingle(@minDist)^ := rci.rcci.nearClippingDistance + 1; if ZMaxDistance <= 0 then begin PSingle(@maxDist)^ := rci.rcci.farClippingDistance + 1; invRegionSize := (cPFXNbRegions - 2) / (rci.rcci.farClippingDistance - rci.rcci.nearClippingDistance); end else begin PSingle(@maxDist)^ := rci.rcci.nearClippingDistance + ZMaxDistance + 1; invRegionSize := (cPFXNbRegions - 2) / ZMaxDistance; end; distDelta := rci.rcci.nearClippingDistance + 1 + 0.49999 / invRegionSize; SetVector(cameraPos, rci.cameraPosition); SetVector(cameraVector, rci.cameraDirection); try // Collect particles // only depth-clipping performed as of now. FLastParticleCount := 0; for managerIdx := 0 to FManagerList.Count - 1 do begin curManager := TGLParticleFXManager(FManagerList[managerIdx]); curList := curManager.FParticles.List; Inc(FLastParticleCount, curManager.ParticleCount); for particleIdx := 0 to curManager.ParticleCount - 1 do begin curParticle := curList^[particleIdx]; dist := PointProject(curParticle.FPosition, cameraPos, cameraVector) + 1; if not FZCull then begin if PInteger(@dist)^ < minDist then PInteger(@dist)^ := minDist; end; if (PInteger(@dist)^ >= minDist) and (PInteger(@dist)^ <= maxDist) then begin DistToRegionIdx; curRegion := @FRegions[regionIdx]; // add particle to region if curRegion^.count = curRegion^.capacity then begin Inc(curRegion^.capacity, cPFXGranularity); ReallocMem(curRegion^.particleRef, curRegion^.capacity * SizeOf(TParticleReference)); ReallocMem(curRegion^.particleOrder, curRegion^.capacity * SizeOf(Pointer)); end; with curRegion^.particleRef^[curRegion^.count] do begin particle := curParticle; distance := PInteger(@dist)^; end; Inc(curRegion^.count); end; end; end; // Sort regions case ZSortAccuracy of saLow: sortMaxRegion := 0; saOneTenth: sortMaxRegion := cPFXNbRegions div 10; saOneThird: sortMaxRegion := cPFXNbRegions div 3; saOneHalf: sortMaxRegion := cPFXNbRegions div 2; else sortMaxRegion := cPFXNbRegions; end; for regionIdx := 0 to cPFXNbRegions - 1 do begin curRegion := @FRegions[regionIdx]; if curRegion^.count > 1 then begin // Prepare order table with curRegion^ do for particleIdx := 0 to count - 1 do particleOrder^[particleIdx] := @particleRef[particleIdx]; // QuickSort if (regionIdx < sortMaxRegion) and (FBlendingMode <> bmAdditive) then QuickSortRegion(0, curRegion^.count - 1, curRegion); end else if curRegion^.Count = 1 then begin // Prepare order table curRegion^.particleOrder^[0] := @curRegion^.particleRef[0]; end; end; FLastSortTime := StopPrecisionTimer(timer) * 1000; rci.PipelineTransformation.Push; rci.PipelineTransformation.SetModelMatrix(IdentityHmgMatrix); rci.GLStates.Disable(stCullFace); rci.GLStates.ActiveTextureEnabled[ttTexture2D] := True; currentTexturingMode := 0; rci.GLStates.Disable(stLighting); rci.GLStates.PolygonMode := pmFill; case FBlendingMode of bmAdditive: begin rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOne); rci.GLStates.Enable(stBlend); end; bmTransparency: begin rci.GLStates.SetBlendFunc(bfSrcAlpha, bfOneMinusSrcAlpha); rci.GLStates.Enable(stBlend); end; else // bmOpaque, do nothing end; rci.GLStates.DepthFunc := cfLEqual; if not FZWrite then begin rci.GLStates.DepthWriteMask := False; end; if not FZTest then rci.GLStates.Disable(stDepthTest); try // Initialize managers for managerIdx := 0 to FManagerList.Count - 1 do TGLParticleFXManager(FManagerList.Items[managerIdx]).InitializeRendering(rci); // Start Rendering... at last ;) try curManager := nil; for regionIdx := cPFXNbRegions - 1 downto 0 do begin curRegion := @FRegions[regionIdx]; if curRegion^.count > 0 then begin curParticleOrder := @curRegion^.particleOrder^[0]; for particleIdx := curRegion^.count - 1 downto 0 do begin curParticle := PParticleReference(curParticleOrder^[particleIdx])^.particle; if curParticle.Manager <> curManager then begin if Assigned(curManager) then curManager.EndParticles(rci); curManager := curParticle.Manager; if curManager.TexturingMode <> currentTexturingMode then begin if currentTexturingMode <> 0 then gl.Disable(currentTexturingMode); currentTexturingMode := curManager.TexturingMode; if currentTexturingMode <> 0 then gl.Enable(currentTexturingMode); end; curManager.BeginParticles(rci); end; curManager.RenderParticle(rci, curParticle); end; end; end; if Assigned(curManager) then curManager.EndParticles(rci); finally // Finalize managers for managerIdx := 0 to FManagerList.Count - 1 do TGLParticleFXManager(FManagerList.Items[managerIdx]).FinalizeRendering(rci); end; finally rci.PipelineTransformation.Pop; end; rci.GLStates.ActiveTextureEnabled[ttTexture2D] := False; rci.GLStates.DepthWriteMask := True; finally // cleanup for regionIdx := cPFXNbRegions - 1 downto 0 do FRegions[regionIdx].count := 0; end; end; function TGLParticleFXRenderer.StoreZMaxDistance: Boolean; begin Result := (FZMaxDistance <> 0); end; // ------------------ // ------------------ TGLSourcePFXEffect ------------------ // ------------------ constructor TGLSourcePFXEffect.Create(aOwner: TXCollection); begin inherited; FInitialVelocity := TGCoordinates.CreateInitialized(Self, NullHmgVector, csVector); FInitialPosition := TGCoordinates.CreateInitialized(Self, NullHmgVector, csPoint); FPositionDispersionRange := TGCoordinates.CreateInitialized(Self, XYZHmgVector, csPoint); FVelocityDispersion := 0; FPositionDispersion := 0; FParticleInterval := 0.1; FVelocityMode := svmAbsolute; FPositionMode := spmAbsoluteOffset; FDispersionMode := sdmFast; FEnabled := true; FDisabledIfOwnerInvisible := False; end; destructor TGLSourcePFXEffect.Destroy; begin FPositionDispersionRange.Free; FInitialVelocity.Free; FInitialPosition.Free; inherited Destroy; end; class function TGLSourcePFXEffect.FriendlyName: string; begin Result := 'PFX Source'; end; class function TGLSourcePFXEffect.FriendlyDescription: string; begin Result := 'Simple Particles FX Source'; end; procedure TGLSourcePFXEffect.WriteToFiler(writer: TWriter); begin inherited; with writer do begin WriteInteger(6); // ArchiveVersion 6, added FPositionMode // ArchiveVersion 5, added FDisabledIfOwnerInvisible: // ArchiveVersion 4, added FRotationDispersion // ArchiveVersion 3, added FEnabled // ArchiveVersion 2, added FPositionDispersionRange // ArchiveVersion 1, added FDispersionMode FInitialVelocity.WriteToFiler(writer); FInitialPosition.WriteToFiler(writer); FPositionDispersionRange.WriteToFiler(writer); WriteFloat(FVelocityDispersion); WriteFloat(FPositionDispersion); WriteFloat(FParticleInterval); WriteInteger(Integer(FVelocityMode)); WriteInteger(Integer(FDispersionMode)); WriteBoolean(FEnabled); WriteFloat(FRotationDispersion); WriteBoolean(FDisabledIfOwnerInvisible); WriteInteger(Integer(FPositionMode)); end; end; procedure TGLSourcePFXEffect.ReadFromFiler(reader: TReader); var archiveVersion: Integer; begin inherited; with reader do begin archiveVersion := ReadInteger; Assert(archiveVersion in [0..6]); FInitialVelocity.ReadFromFiler(reader); FInitialPosition.ReadFromFiler(reader); if archiveVersion >= 2 then FPositionDispersionRange.ReadFromFiler(reader); FVelocityDispersion := ReadFloat; FPositionDispersion := ReadFloat; FParticleInterval := ReadFloat; FVelocityMode := TGLSourcePFXVelocityMode(ReadInteger); if archiveVersion >= 1 then FDispersionMode := TGLSourcePFXDispersionMode(ReadInteger); if archiveVersion >= 3 then FEnabled := ReadBoolean; if archiveVersion >= 4 then FRotationDispersion := ReadFloat; if archiveVersion >= 5 then FDisabledIfOwnerInvisible := ReadBoolean; if archiveVersion >= 6 then FPositionMode := TGLSourcePFXPositionMode(ReadInteger); end; end; procedure TGLSourcePFXEffect.SetInitialVelocity(const val: TGCoordinates); begin FInitialVelocity.Assign(val); end; procedure TGLSourcePFXEffect.SetInitialPosition(const val: TGCoordinates); begin FInitialPosition.Assign(val); end; procedure TGLSourcePFXEffect.SetPositionDispersionRange(const val: TGCoordinates); begin FPositionDispersionRange.Assign(val); end; procedure TGLSourcePFXEffect.SetParticleInterval(const val: Single); begin if FParticleInterval <> val then begin FParticleInterval := val; if FParticleInterval < 0 then FParticleInterval := 0; if FTimeRemainder > FParticleInterval then FTimeRemainder := FParticleInterval; end; end; procedure TGLSourcePFXEffect.DoProgress(const progressTime: TGProgressTimes); var n: Integer; begin if Enabled and Assigned(Manager) and (ParticleInterval > 0) then begin if OwnerBaseSceneObject.Visible or (not DisabledIfOwnerInvisible) then begin FTimeRemainder := FTimeRemainder + progressTime.deltaTime; if FTimeRemainder > FParticleInterval then begin n := Trunc((FTimeRemainder - FParticleInterval) / FParticleInterval); Burst(progressTime.newTime, n); FTimeRemainder := FTimeRemainder - n * FParticleInterval; end; end; end; end; function TGLSourcePFXEffect.ParticleAbsoluteInitialPos: TAffineVector; begin if PositionMode = spmRelative then begin Result := OwnerBaseSceneObject.LocalToAbsolute(InitialPosition.AsAffineVector); end else begin SetVector(Result, OwnerBaseSceneObject.AbsolutePosition); AddVector(Result, InitialPosition.AsAffineVector); end; end; procedure TGLSourcePFXEffect.Burst(time: Double; nb: Integer); var particle: TGLParticle; av, pos: TAffineVector; OwnerObjRelPos: TAffineVector; begin if Manager = nil then Exit; OwnerObjRelPos := OwnerBaseSceneObject.LocalToAbsolute(NullVector); pos := ParticleAbsoluteInitialPos; // if FManager is TGLDynamicPFXManager then // TGLDynamicPFXManager(FManager).FRotationCenter := pos; while nb > 0 do begin particle := Manager.CreateParticle; particle.FEffectScale := FEffectScale; RndVector(DispersionMode, av, FPositionDispersion, FPositionDispersionRange); if VelocityMode = svmRelative then av := VectorSubtract(OwnerBaseSceneObject.LocalToAbsolute(av), OwnerObjRelPos); ScaleVector(av, FEffectScale); VectorAdd(pos, av, @particle.Position); RndVector(DispersionMode, av, FVelocityDispersion, nil); VectorAdd(InitialVelocity.AsAffineVector, av, @particle.Velocity); particle.Velocity := VectorScale(particle.Velocity, FEffectScale); if VelocityMode = svmRelative then particle.FVelocity := VectorSubtract(OwnerBaseSceneObject.LocalToAbsolute(particle.FVelocity), OwnerObjRelPos); particle.CreationTime := time; if FRotationDispersion <> 0 then particle.FRotation := Random * FRotationDispersion else particle.FRotation := 0; Dec(nb); end; end; procedure TGLSourcePFXEffect.RingExplosion(time: Double; minInitialSpeed, maxInitialSpeed: Single; nbParticles: Integer); var particle: TGLParticle; av, pos, tmp: TAffineVector; ringVectorX, ringVectorY: TAffineVector; fx, fy, d: Single; begin if (Manager = nil) or (nbParticles <= 0) then Exit; pos := ParticleAbsoluteInitialPos; SetVector(ringVectorY, OwnerBaseSceneObject.AbsoluteUp); SetVector(ringVectorX, OwnerBaseSceneObject.AbsoluteDirection); ringVectorY := VectorCrossProduct(ringVectorX, ringVectorY); while (nbParticles > 0) do begin // okay, ain't exactly an "isotropic" ring... fx := Random - 0.5; fy := Random - 0.5; d := RLength(fx, fy); tmp := VectorCombine(ringVectorX, ringVectorY, fx * d, fy * d); ScaleVector(tmp, minInitialSpeed + Random * (maxInitialSpeed - minInitialSpeed)); AddVector(tmp, InitialVelocity.AsVector); particle := Manager.CreateParticle; with particle do begin RndVector(DispersionMode, av, FPositionDispersion, FPositionDispersionRange); VectorAdd(pos, av, @Position); RndVector(DispersionMode, av, FVelocityDispersion, nil); VectorAdd(tmp, av, @Velocity); if VelocityMode = svmRelative then Velocity := OwnerBaseSceneObject.LocalToAbsolute(Velocity); particle.CreationTime := time; end; Dec(nbParticles); end; end; // ------------------ // ------------------ TPFXLifeColor ------------------ // ------------------ constructor TPFXLifeColor.Create(Collection: TCollection); begin inherited Create(Collection); FColorInner := TGLColor.CreateInitialized(Self, NullHmgVector); FColorOuter := TGLColor.CreateInitialized(Self, NullHmgVector); FLifeTime := 1; FInvLifeTime := 1; FSizeScale := 1; FRotateAngle := 0; end; destructor TPFXLifeColor.Destroy; begin FColorOuter.Free; FColorInner.Free; inherited Destroy; end; procedure TPFXLifeColor.Assign(Source: TPersistent); begin if Source is TPFXLifeColor then begin FColorInner.Assign(TPFXLifeColor(Source).ColorInner); FColorOuter.Assign(TPFXLifeColor(Source).ColorOuter); FLifeTime := TPFXLifeColor(Source).LifeTime; FRotateAngle := TPFXLifeColor(Source).RotateAngle; end else inherited; end; function TPFXLifeColor.GetDisplayName: string; begin Result := Format('LifeTime %f - Inner [%.2f, %.2f, %.2f, %.2f] - Outer [%.2f, %.2f, %.2f, %.2f]', [LifeTime, ColorInner.Red, ColorInner.Green, ColorInner.Blue, ColorInner.Alpha, ColorOuter.Red, ColorOuter.Green, ColorOuter.Blue, ColorOuter.Alpha]); end; procedure TPFXLifeColor.SetColorInner(const val: TGLColor); begin FColorInner.Assign(val); end; procedure TPFXLifeColor.SetColorOuter(const val: TGLColor); begin FColorOuter.Assign(val); end; procedure TPFXLifeColor.SetLifeTime(const val: Single); begin if FLifeTime <> val then begin FLifeTime := val; if FLifeTime <= 0 then FLifeTime := 1e-6; FInvLifeTime := 1 / FLifeTime; end; end; procedure TPFXLifeColor.SetSizeScale(const val: Single); begin if FSizeScale <> val then begin FSizeScale := val; FDoScale := (FSizeScale <> 1); end; end; procedure TPFXLifeColor.SetRotateAngle(const Value: Single); begin if FRotateAngle <> Value then begin FRotateAngle := Value; FDoRotate := (FRotateAngle <> 0); end; end; // ------------------ // ------------------ TPFXLifeColors ------------------ // ------------------ constructor TPFXLifeColors.Create(AOwner: TPersistent); begin inherited Create(AOwner, TPFXLifeColor); end; procedure TPFXLifeColors.SetItems(index: Integer; const val: TPFXLifeColor); begin inherited Items[index] := val; end; function TPFXLifeColors.GetItems(index: Integer): TPFXLifeColor; begin Result := TPFXLifeColor(inherited Items[index]); end; function TPFXLifeColors.Add: TPFXLifeColor; begin Result := (inherited Add) as TPFXLifeColor; end; function TPFXLifeColors.FindItemID(ID: Integer): TPFXLifeColor; begin Result := (inherited FindItemID(ID)) as TPFXLifeColor; end; function TPFXLifeColors.MaxLifeTime: Double; begin if Count > 0 then Result := Items[Count - 1].LifeTime else Result := 1e30; end; function TPFXLifeColors.RotationsDefined: Boolean; var i: Integer; begin for i := 0 to Count - 1 do begin if Items[i].RotateAngle <> 0 then begin Result := True; Exit; end; end; Result := False; end; function TPFXLifeColors.ScalingDefined: Boolean; var i: Integer; begin for i := 0 to Count - 1 do begin if Items[i].SizeScale <> 1 then begin Result := True; Exit; end; end; Result := False; end; procedure TPFXLifeColors.PrepareIntervalRatios; var i: Integer; begin for i := 0 to Count - 2 do Items[i].FIntervalRatio := 1 / (Items[i + 1].LifeTime - Items[i].LifeTime); end; // ------------------ // ------------------ TGLDynamicPFXManager ------------------ // ------------------ constructor TGLDynamicPFXManager.Create(aOwner: TComponent); begin inherited; FAcceleration := TGCoordinates.CreateInitialized(Self, NullHmgVector, csVector); FFriction := 1; end; destructor TGLDynamicPFXManager.Destroy; begin FAcceleration.Free; inherited Destroy; end; procedure TGLDynamicPFXManager.DoProgress(const progressTime: TGProgressTimes); var i: Integer; curParticle: TGLParticle; maxAge: Double; {pos, pos1, axis,}accelVector: TAffineVector; {ff,}dt: Single; list: PGLParticleArray; doFriction, doPack: Boolean; frictionScale: Single; //pos4: TGLVector; begin maxAge := MaxParticleAge; accelVector := Acceleration.AsAffineVector; dt := progressTime.deltaTime; doFriction := (FFriction <> 1); if doFriction then begin frictionScale := PowerSingle(FFriction, dt) end else frictionScale := 1; FCurrentTime := progressTime.newTime; doPack := False; list := Particles.List; for i := 0 to Particles.ItemCount - 1 do begin curParticle := list^[i]; if (progressTime.newTime - curParticle.CreationTime) < maxAge then begin // particle alive, just update velocity and position with curParticle do begin CombineVector(FPosition, FVelocity, dt); // DanB - this doesn't seem to fit here, rotation is already // calculated when rendering {if (FRotation <> 0) and (Renderer <> nil) then begin pos := FPosition; pos1 := FPosition; ff := 1; CombineVector(pos1, FVelocity, ff); SetVector(axis, Renderer.Scene.CurrentGLCamera.AbsolutePosition); SetVector(axis, VectorSubtract(axis, FRotationCenter)); NormalizeVector(axis); MakeVector(pos4, pos1); pos4[0] := pos4[0] - FRotationCenter[0]; pos4[1] := pos4[1] - FRotationCenter[1]; pos4[2] := pos4[2] - FRotationCenter[2]; RotateVector(pos4, axis, FRotation * dt); pos4[0] := pos4[0] + FRotationCenter[0]; pos4[1] := pos4[1] + FRotationCenter[1]; pos4[2] := pos4[2] + FRotationCenter[2]; MakeVector(pos1, pos4[0], pos4[1], pos4[2]); FVelocity := VectorSubtract(pos1, pos); CombineVector(FPosition, FVelocity, dt); end;} CombineVector(FVelocity, accelVector, dt); if doFriction then ScaleVector(FVelocity, frictionScale); end; end else begin // kill particle curParticle.Free; list^[i] := nil; doPack := True; end; end; if doPack then Particles.Pack; end; procedure TGLDynamicPFXManager.SetAcceleration(const val: TGCoordinates); begin FAcceleration.Assign(val); end; // ------------------ // ------------------ TGLLifeColoredPFXManager ------------------ // ------------------ constructor TGLLifeColoredPFXManager.Create(aOwner: TComponent); begin inherited; FLifeColors := TPFXLifeColors.Create(Self); FColorInner := TGLColor.CreateInitialized(Self, clrYellow); FColorOuter := TGLColor.CreateInitialized(Self, NullHmgVector); with FLifeColors.Add do begin LifeTime := 3; end; FParticleSize := 1; end; destructor TGLLifeColoredPFXManager.Destroy; begin FLifeColors.Free; FColorInner.Free; FColorOuter.Free; inherited Destroy; end; procedure TGLLifeColoredPFXManager.SetColorInner(const val: TGLColor); begin FColorInner.Assign(val); end; procedure TGLLifeColoredPFXManager.SetColorOuter(const val: TGLColor); begin FColorOuter.Assign(val); end; procedure TGLLifeColoredPFXManager.SetLifeColors(const val: TPFXLifeColors); begin FLifeColors.Assign(Self); end; procedure TGLLifeColoredPFXManager.InitializeRendering(var rci: TGLRenderContextInfo); var i, n: Integer; begin n := LifeColors.Count; FLifeColorsLookup := TList.Create; FLifeColorsLookup.Capacity := n; for i := 0 to n - 1 do FLifeColorsLookup.Add(LifeColors[i]); FLifeRotations := LifeColors.RotationsDefined; FLifeScaling := LifeColors.ScalingDefined; LifeColors.PrepareIntervalRatios; end; procedure TGLLifeColoredPFXManager.FinalizeRendering(var rci: TGLRenderContextInfo); begin FLifeColorsLookup.Free; end; function TGLLifeColoredPFXManager.MaxParticleAge: Single; begin Result := LifeColors.MaxLifeTime; end; procedure TGLLifeColoredPFXManager.ComputeColors(var lifeTime: Single; var inner, outer: TGLColorVector); var i, k, n: Integer; f: Single; lck, lck1: TPFXLifeColor; begin with LifeColors do begin n := Count - 1; if n < 0 then begin inner := ColorInner.Color; outer := ColorOuter.Color; end else begin if n > 0 then begin k := -1; for i := 0 to n do if TPFXLifeColor(FLifeColorsLookup.Items[i]).LifeTime < lifeTime then k := i; if k < n then Inc(k); end else k := 0; case k of 0: begin lck := TPFXLifeColor(FLifeColorsLookup.Items[k]); f := lifeTime * lck.InvLifeTime; VectorLerp(ColorInner.Color, lck.ColorInner.Color, f, inner); VectorLerp(ColorOuter.Color, lck.ColorOuter.Color, f, outer); end; else lck := TPFXLifeColor(FLifeColorsLookup.Items[k]); lck1 := TPFXLifeColor(FLifeColorsLookup.Items[k - 1]); f := (lifeTime - lck1.LifeTime) * lck1.InvIntervalRatio; VectorLerp(lck1.ColorInner.Color, lck.ColorInner.Color, f, inner); VectorLerp(lck1.ColorOuter.Color, lck.ColorOuter.Color, f, outer); end; end; end; end; procedure TGLLifeColoredPFXManager.ComputeInnerColor(var lifeTime: Single; var inner: TGLColorVector); var i, k, n: Integer; f: Single; lck, lck1: TPFXLifeColor; lifeColorsLookupList: PFXPointerList; begin with LifeColors do begin n := Count - 1; if n < 0 then inner := ColorInner.Color else begin lifeColorsLookupList := @FLifeColorsLookup.List[0]; if n > 0 then begin k := -1; for i := 0 to n do if TPFXLifeColor(lifeColorsLookupList^[i]).LifeTime < lifeTime then k := i; if k < n then Inc(k); end else k := 0; if k = 0 then begin lck := TPFXLifeColor(lifeColorsLookupList^[k]); f := lifeTime * lck.InvLifeTime; VectorLerp(ColorInner.Color, lck.ColorInner.Color, f, inner); end else begin lck := TPFXLifeColor(lifeColorsLookupList^[k]); lck1 := TPFXLifeColor(lifeColorsLookupList^[k - 1]); f := (lifeTime - lck1.LifeTime) * lck1.InvIntervalRatio; VectorLerp(lck1.ColorInner.Color, lck.ColorInner.Color, f, inner); end; end; end; end; procedure TGLLifeColoredPFXManager.ComputeOuterColor(var lifeTime: Single; var outer: TGLColorVector); var i, k, n: Integer; f: Single; lck, lck1: TPFXLifeColor; begin with LifeColors do begin n := Count - 1; if n < 0 then outer := ColorOuter.Color else begin if n > 0 then begin k := -1; for i := 0 to n do if TPFXLifeColor(FLifeColorsLookup.Items[i]).LifeTime < lifeTime then k := i; if k < n then Inc(k); end else k := 0; case k of 0: begin lck := TPFXLifeColor(FLifeColorsLookup.Items[k]); f := lifeTime * lck.InvLifeTime; VectorLerp(ColorOuter.Color, lck.ColorOuter.Color, f, outer); end; else lck := TPFXLifeColor(FLifeColorsLookup.Items[k]); lck1 := TPFXLifeColor(FLifeColorsLookup.Items[k - 1]); f := (lifeTime - lck1.LifeTime) * lck1.InvIntervalRatio; VectorLerp(lck1.ColorOuter.Color, lck.ColorOuter.Color, f, outer); end; end; end; end; function TGLLifeColoredPFXManager.ComputeSizeScale(var lifeTime: Single; var sizeScale: Single): Boolean; var i, k, n: Integer; f: Single; lck, lck1: TPFXLifeColor; begin with LifeColors do begin n := Count - 1; if n < 0 then Result := False else begin if n > 0 then begin k := -1; for i := 0 to n do if TPFXLifeColor(FLifeColorsLookup.Items[i]).LifeTime < lifeTime then k := i; if k < n then Inc(k); end else k := 0; case k of 0: begin lck := TPFXLifeColor(FLifeColorsLookup.Items[k]); Result := lck.FDoScale; if Result then begin f := lifeTime * lck.InvLifeTime; sizeScale := Lerp(1, lck.SizeScale, f); end; end; else lck := TPFXLifeColor(FLifeColorsLookup.Items[k]); lck1 := TPFXLifeColor(FLifeColorsLookup.Items[k - 1]); Result := lck.FDoScale or lck1.FDoScale; if Result then begin f := (lifeTime - lck1.LifeTime) * lck1.InvIntervalRatio; sizeScale := Lerp(lck1.SizeScale, lck.SizeScale, f); end; end; end; end; end; function TGLLifeColoredPFXManager.ComputeRotateAngle(var lifeTime: Single; var rotateAngle: Single): Boolean; var i, k, n: Integer; f: Single; lck, lck1: TPFXLifeColor; begin with LifeColors do begin n := Count - 1; if n < 0 then Result := False else begin if n > 0 then begin k := -1; for i := 0 to n do if Items[i].LifeTime < lifeTime then k := i; if k < n then Inc(k); end else k := 0; case k of 0: begin lck := LifeColors[k]; Result := lck.FDoRotate; if Result then begin f := lifeTime * lck.InvLifeTime; rotateAngle := Lerp(1, lck.rotateAngle, f); end; end; else lck := LifeColors[k]; lck1 := LifeColors[k - 1]; Result := lck.FDoRotate or lck1.FDoRotate; if Result then begin f := (lifeTime - lck1.LifeTime) * lck1.InvIntervalRatio; rotateAngle := Lerp(lck1.rotateAngle, lck.rotateAngle, f); end; end; end; end; end; procedure TGLLifeColoredPFXManager.RotateVertexBuf(buf: TGAffineVectorList; lifeTime: Single; const axis: TAffineVector; offsetAngle: Single); var rotateAngle: Single; rotMatrix: TGLMatrix; diff: Single; lifeRotationApplied: Boolean; begin rotateAngle := 0; lifeRotationApplied := ComputeRotateAngle(lifeTime, rotateAngle); rotateAngle := rotateAngle + offsetAngle; if lifeRotationApplied or (rotateAngle <> 0) then begin diff := DegToRadian(rotateAngle); rotMatrix := CreateRotationMatrix(axis, diff); buf.TransformAsVectors(rotMatrix); end; end; // ------------------ // ------------------ TGLCustomPFXManager ------------------ // ------------------ procedure TGLCustomPFXManager.DoProgress(const progressTime: TGProgressTimes); var i: Integer; list: PGLParticleArray; curParticle: TGLParticle; defaultProgress, killParticle, doPack: Boolean; begin if Assigned(FOnProgress) then begin defaultProgress := False; FOnProgress(Self, progressTime, defaultProgress); if defaultProgress then inherited; end else inherited; if Assigned(FOnParticleProgress) then begin doPack := False; list := Particles.List; for i := 0 to Particles.ItemCount - 1 do begin killParticle := True; curParticle := list^[i]; FOnParticleProgress(Self, progressTime, curParticle, killParticle); if killParticle then begin curParticle.Free; list^[i] := nil; doPack := True; end; end; if doPack then Particles.Pack; end; end; function TGLCustomPFXManager.TexturingMode: Cardinal; begin Result := 0; end; procedure TGLCustomPFXManager.InitializeRendering(var rci: TGLRenderContextInfo); begin inherited; if Assigned(FOnInitializeRendering) then FOnInitializeRendering(Self, rci); end; procedure TGLCustomPFXManager.BeginParticles(var rci: TGLRenderContextInfo); begin if Assigned(FOnBeginParticles) then FOnBeginParticles(Self, rci); end; procedure TGLCustomPFXManager.RenderParticle(var rci: TGLRenderContextInfo; aParticle: TGLParticle); begin if Assigned(FOnRenderParticle) then FOnRenderParticle(Self, aParticle, rci); end; procedure TGLCustomPFXManager.EndParticles(var rci: TGLRenderContextInfo); begin if Assigned(FOnEndParticles) then FOnEndParticles(Self, rci); end; procedure TGLCustomPFXManager.FinalizeRendering(var rci: TGLRenderContextInfo); begin if Assigned(FOnFinalizeRendering) then FOnFinalizeRendering(Self, rci); inherited; end; function TGLCustomPFXManager.ParticleCount: Integer; begin if Assigned(FOnGetParticleCountEvent) then Result := FOnGetParticleCountEvent(Self) else Result := FParticles.FItemList.Count; end; // ------------------ // ------------------ TGLPolygonPFXManager ------------------ // ------------------ constructor TGLPolygonPFXManager.Create(aOwner: TComponent); begin inherited; FNbSides := 6; end; destructor TGLPolygonPFXManager.Destroy; begin inherited Destroy; end; procedure TGLPolygonPFXManager.SetNbSides(const val: Integer); begin if val <> FNbSides then begin FNbSides := val; if FNbSides < 3 then FNbSides := 3; NotifyChange(Self); end; end; function TGLPolygonPFXManager.TexturingMode: Cardinal; begin Result := 0; end; procedure TGLPolygonPFXManager.InitializeRendering(var rci: TGLRenderContextInfo); var i: Integer; matrix: TGLMatrix; s, c: Single; begin inherited; gl.GetFloatv(GL_MODELVIEW_MATRIX, @matrix); for i := 0 to 2 do begin Fvx.V[i] := matrix.V[i].X * FParticleSize; Fvy.V[i] := matrix.V[i].Y * FParticleSize; end; FVertices := TGAffineVectorList.Create; FVertices.Capacity := FNbSides; for i := 0 to FNbSides - 1 do begin SinCosine(i * c2PI / FNbSides, s, c); FVertices.Add(VectorCombine(FVx, Fvy, c, s)); end; FVertBuf := TGAffineVectorList.Create; FVertBuf.Count := FVertices.Count; end; procedure TGLPolygonPFXManager.BeginParticles(var rci: TGLRenderContextInfo); begin ApplyBlendingMode(rci); end; procedure TGLPolygonPFXManager.RenderParticle(var rci: TGLRenderContextInfo; aParticle: TGLParticle); var i: Integer; lifeTime, sizeScale: Single; inner, outer: TGLColorVector; pos: TAffineVector; vertexList: PAffineVectorArray; begin lifeTime := FCurrentTime - aParticle.CreationTime; ComputeColors(lifeTime, inner, outer); pos := aParticle.Position; vertexList := FVertBuf.List; // copy vertices for I := 0 to FVertBuf.Count - 1 do vertexList[i] := FVertices[i]; // rotate vertices (if needed) if FLifeRotations or (aParticle.FRotation <> 0) then RotateVertexBuf(FVertBuf, lifeTime, AffineVectorMake(rci.cameraDirection), aParticle.FRotation); // scale vertices (if needed) then translate to particle position if FLifeScaling or (aParticle.FEffectScale <> 1) then begin if FLifeScaling and ComputeSizeScale(lifeTime, sizeScale) then sizeScale := sizeScale * aParticle.FEffectScale else sizeScale := aParticle.FEffectScale; for i := 0 to FVertBuf.Count - 1 do vertexList^[i] := VectorCombine(vertexList^[i], pos, sizeScale, 1); end else FVertBuf.Translate(pos); gl.Begin_(GL_TRIANGLE_FAN); gl.Color4fv(@inner); gl.Vertex3fv(@pos); gl.Color4fv(@outer); for i := 0 to FVertBuf.Count - 1 do gl.Vertex3fv(@vertexList[i]); gl.Vertex3fv(@vertexList[0]); gl.End_; end; procedure TGLPolygonPFXManager.EndParticles(var rci: TGLRenderContextInfo); begin UnapplyBlendingMode(rci); end; procedure TGLPolygonPFXManager.FinalizeRendering(var rci: TGLRenderContextInfo); begin FVertBuf.Free; FVertices.Free; inherited; end; // ------------------ // ------------------ TGLBaseSpritePFXManager ------------------ // ------------------ constructor TGLBaseSpritePFXManager.Create(aOwner: TComponent); begin inherited; FTexHandle := TGLTextureHandle.Create; FSpritesPerTexture := sptOne; FAspectRatio := 1; end; destructor TGLBaseSpritePFXManager.Destroy; begin FTexHandle.Free; FShareSprites := nil; inherited Destroy; end; procedure TGLBaseSpritePFXManager.SetSpritesPerTexture(const val: TSpritesPerTexture); begin if val <> FSpritesPerTexture then begin FSpritesPerTexture := val; FTexHandle.DestroyHandle; NotifyChange(Self); end; end; procedure TGLBaseSpritePFXManager.SetColorMode(const val: TSpriteColorMode); begin if val <> FColorMode then begin FColorMode := val; NotifyChange(Self); end; end; procedure TGLBaseSpritePFXManager.SetAspectRatio(const val: Single); begin if FAspectRatio <> val then begin FAspectRatio := ClampValue(val, 1e-3, 1e3); NotifyChange(Self); end; end; function TGLBaseSpritePFXManager.StoreAspectRatio: Boolean; begin Result := (FAspectRatio <> 1); end; procedure TGLBaseSpritePFXManager.SetRotation(const val: Single); begin if FRotation <> val then begin FRotation := val; NotifyChange(Self); end; end; procedure TGLBaseSpritePFXManager.SetShareSprites(const val: TGLBaseSpritePFXManager); begin if FShareSprites <> val then begin if Assigned(FShareSprites) then FShareSprites.RemoveFreeNotification(Self); FShareSprites := val; if Assigned(FShareSprites) then FShareSprites.FreeNotification(Self); end; end; procedure TGLBaseSpritePFXManager.BindTexture(var rci: TGLRenderContextInfo); var bmp32: TGLBitmap32; tw, th, td, tf: Integer; begin if Assigned(FShareSprites) then FShareSprites.BindTexture(rci) else begin if FTexHandle.Handle = 0 then begin FTexHandle.AllocateHandle; FTexHandle.Target := ttTexture2D; rci.GLStates.TextureBinding[0, ttTexture2D] := FTexHandle.Handle; gl.Hint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST); rci.GLStates.UnpackAlignment := 4; rci.GLStates.UnpackRowLength := 0; rci.GLStates.UnpackSkipRows := 0; rci.GLStates.UnpackSkipPixels := 0; gl.TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR); gl.TexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); bmp32 := TGLBitmap32.Create; try tf := GL_RGBA; PrepareImage(bmp32, tf); bmp32.RegisterAsOpenGLTexture( FTexHandle, True, tf, tw, th, td); finally bmp32.Free; end; end else begin rci.GLStates.TextureBinding[0, ttTexture2D] := FTexHandle.Handle; end; end; end; function TGLBaseSpritePFXManager.TexturingMode: Cardinal; begin Result := GL_TEXTURE_2D; end; procedure TGLBaseSpritePFXManager.InitializeRendering(var rci: TGLRenderContextInfo); var i: Integer; matrix: TGLMatrix; s, c, w, h: Single; begin inherited; gl.GetFloatv(GL_MODELVIEW_MATRIX, @matrix); w := FParticleSize * Sqrt(FAspectRatio); h := Sqr(FParticleSize) / w; for i := 0 to 2 do begin Fvx.V[i] := matrix.V[i].X * w; Fvy.V[i] := matrix.V[i].Y * h; Fvz.V[i] := matrix.V[i].Z; end; FVertices := TGAffineVectorList.Create; for i := 0 to 3 do begin SinCosine(i * cPIdiv2 + cPIdiv4, s, c); FVertices.Add(VectorCombine(Fvx, Fvy, c, s)); end; if FRotation <> 0 then begin matrix := CreateRotationMatrix(Fvz, -FRotation); FVertices.TransformAsPoints(matrix); end; FVertBuf := TGAffineVectorList.Create; FVertBuf.Count := FVertices.Count; end; procedure TGLBaseSpritePFXManager.BeginParticles(var rci: TGLRenderContextInfo); begin BindTexture(rci); if ColorMode = scmNone then gl.TexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE) else gl.TexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE); ApplyBlendingMode(rci); if ColorMode <> scmFade then gl.Begin_(GL_QUADS); end; procedure TGLBaseSpritePFXManager.RenderParticle(var rci: TGLRenderContextInfo; aParticle: TGLParticle); type TTexCoordsSet = array[0..3] of TTexPoint; PTexCoordsSet = ^TTexCoordsSet; const cBaseTexCoordsSet: TTexCoordsSet = ((S: 1; T: 1), (S: 0; T: 1), (S: 0; T: 0), (S: 1; T: 0)); cTexCoordsSets: array[0..3] of TTexCoordsSet = (((S: 1.0; T: 1.0), (S: 0.5; T: 1.0), (S: 0.5; T: 0.5), (S: 1.0; T: 0.5)), ((S: 0.5; T: 1.0), (S: 0.0; T: 1.0), (S: 0.0; T: 0.5), (S: 0.5; T: 0.5)), ((S: 1.0; T: 0.5), (S: 0.5; T: 0.5), (S: 0.5; T: 0.0), (S: 1.0; T: 0.0)), ((S: 0.5; T: 0.5), (S: 0.0; T: 0.5), (S: 0.0; T: 0.0), (S: 0.5; T: 0.0))); var lifeTime, sizeScale: Single; inner, outer: TGLColorVector; pos: TAffineVector; vertexList: PAffineVectorArray; i: Integer; tcs: PTexCoordsSet; spt: TSpritesPerTexture; procedure IssueVertices; begin gl.TexCoord2fv(@tcs[0]); gl.Vertex3fv(@vertexList[0]); gl.TexCoord2fv(@tcs[1]); gl.Vertex3fv(@vertexList[1]); gl.TexCoord2fv(@tcs[2]); gl.Vertex3fv(@vertexList[2]); gl.TexCoord2fv(@tcs[3]); gl.Vertex3fv(@vertexList[3]); end; begin lifeTime := FCurrentTime - aParticle.CreationTime; if Assigned(ShareSprites) then spt := ShareSprites.SpritesPerTexture else spt := SpritesPerTexture; case spt of sptFour: tcs := @cTexCoordsSets[(aParticle.ID and 3)]; else tcs := @cBaseTexCoordsSet; end; pos := aParticle.Position; vertexList := FVertBuf.List; sizeScale := 1; // copy vertices for i := 0 to FVertBuf.Count - 1 do vertexList^[i] := FVertices[i]; // rotate vertices (if needed) if FLifeRotations or (aParticle.FRotation <> 0) then RotateVertexBuf(FVertBuf, lifeTime, AffineVectorMake(rci.cameraDirection), aParticle.FRotation); // scale vertices (if needed) then translate to particle position if FLifeScaling or (aParticle.FEffectScale <> 1) then begin if FLifeScaling and ComputeSizeScale(lifeTime, sizeScale) then sizeScale := sizeScale * aParticle.FEffectScale else sizeScale := aParticle.FEffectScale; for i := 0 to FVertBuf.Count - 1 do vertexList^[i] := VectorCombine(vertexList^[i], pos, sizeScale, 1); end else FVertBuf.Translate(pos); case ColorMode of scmFade: begin ComputeColors(lifeTime, inner, outer); gl.Begin_(GL_TRIANGLE_FAN); gl.Color4fv(@inner); gl.TexCoord2f((tcs^[0].S + tcs^[2].S) * 0.5, (tcs^[0].T + tcs^[2].T) * 0.5); gl.Vertex3fv(@pos); gl.Color4fv(@outer); IssueVertices; gl.TexCoord2fv(@tcs[0]); gl.Vertex3fv(@vertexList[0]); gl.End_; end; scmInner: begin ComputeInnerColor(lifeTime, inner); gl.Color4fv(@inner); IssueVertices; end; scmOuter: begin ComputeOuterColor(lifeTime, outer); gl.Color4fv(@outer); IssueVertices; end; scmNone: begin IssueVertices; end; else Assert(False); end; end; procedure TGLBaseSpritePFXManager.EndParticles(var rci: TGLRenderContextInfo); begin if ColorMode <> scmFade then gl.End_; UnApplyBlendingMode(rci); end; procedure TGLBaseSpritePFXManager.FinalizeRendering(var rci: TGLRenderContextInfo); begin FVertBuf.Free; FVertices.Free; inherited; end; // ------------------ // ------------------ TGLCustomSpritePFXManager ------------------ // ------------------ constructor TGLCustomSpritePFXManager.Create(aOwner: TComponent); begin inherited; FColorMode := scmInner; FSpritesPerTexture := sptOne; end; // destructor TGLCustomSpritePFXManager.Destroy; begin inherited Destroy; end; procedure TGLCustomSpritePFXManager.PrepareImage(bmp32: TGLBitmap32; var texFormat: Integer); begin if Assigned(FOnPrepareTextureImage) then FOnPrepareTextureImage(Self, bmp32, texFormat); end; // ------------------ // ------------------ TGLPointLightPFXManager ------------------ // ------------------ constructor TGLPointLightPFXManager.Create(aOwner: TComponent); begin inherited; FTexMapSize := 5; FColorMode := scmInner; end; destructor TGLPointLightPFXManager.Destroy; begin inherited Destroy; end; procedure TGLPointLightPFXManager.SetTexMapSize(const val: Integer); begin if val <> FTexMapSize then begin FTexMapSize := val; if FTexMapSize < 3 then FTexMapSize := 3; if FTexMapSize > 9 then FTexMapSize := 9; NotifyChange(Self); end; end; procedure TGLPointLightPFXManager.PrepareImage(bmp32: TGLBitmap32; var texFormat: Integer); var s: Integer; x, y, d, h2: Integer; ih2, f, fy: Single; scanLine1, scanLine2: PGLPixel32Array; begin s := (1 shl TexMapSize); bmp32.Width := s; bmp32.Height := s; bmp32.Blank := false; texFormat := GL_LUMINANCE_ALPHA; h2 := s div 2; ih2 := 1 / h2; for y := 0 to h2 - 1 do begin fy := Sqr((y + 0.5 - h2) * ih2); scanLine1 := bmp32.ScanLine[y]; scanLine2 := bmp32.ScanLine[s - 1 - y]; for x := 0 to h2 - 1 do begin f := Sqr((x + 0.5 - h2) * ih2) + fy; if f < 1 then begin d := Trunc((1 - Sqrt(f)) * 256); d := d + (d shl 8) + (d shl 16) + (d shl 24); end else d := 0; PInteger(@scanLine1[x])^ := d; PInteger(@scanLine2[x])^ := d; PInteger(@scanLine1[s - 1 - x])^ := d; PInteger(@scanLine2[s - 1 - x])^ := d; end; end; end; // ------------------------------------------------------------------ initialization // ------------------------------------------------------------------ // class registrations RegisterClasses([TGLParticle, TGLParticleList, TGLParticleFXEffect, TGLParticleFXRenderer, TGLCustomPFXManager, TGLPolygonPFXManager, TGLCustomSpritePFXManager, TGLPointLightPFXManager]); RegisterXCollectionItemClass(TGLSourcePFXEffect); finalization UnregisterXCollectionItemClass(TGLSourcePFXEffect); end.