// // The multimedia graphics platform GLScene https://github.com/glscene // unit GLS.GeomObjects; (* Geometric objects: - TGLTetrahedron, TGLOctahedron, TGLHexahedron, TGLDodecahedron, TGLIcosahedron; - TGLDisk, TGLCylinderBase, TGLCone, TGLCylinder, TGLCapsule, TGLAnnulus, TGLTorus, TGLArrowLine, TGLArrowArc, TGLPolygon, TGLFrustum; - TGLTeapot; *) interface {$I GLScene.inc} uses Winapi.OpenGL, System.Math, System.Classes, GLS.OpenGLTokens, GLS.OpenGLAdapter, GLS.Scene, GLS.State, GLS.PersistentClasses, GLS.VectorGeometry, GLS.VectorLists, GLS.Polynomials, GLS.Silhouette, GLS.VectorTypes, GLS.GeometryBB, GLS.VectorFileObjects, GLS.PipelineTransformation, GLS.Material, GLS.Texture, GLS.Context, GLS.Objects, GLS.Mesh, GLS.RenderContextInfo, GLS.XOpenGL; type //-------------------- TGLBaseMesh Objects ----------------------- (* This objects has no texture coordinates defined, ie. without using a texture generation mode, no texture will be mapped. *) TGLTetrahedron = class(TGLBaseMesh) public procedure BuildList(var rci: TGLRenderContextInfo); override; end; TGLOctahedron = class(TGLBaseMesh) public procedure BuildList(var rci: TGLRenderContextInfo); override; end; TGLHexahedron = class(TGLBaseMesh) public procedure BuildList(var rci: TGLRenderContextInfo); override; end; TGLDodecahedron = class(TGLBaseMesh) public procedure BuildList(var rci: TGLRenderContextInfo); override; end; TGLIcosahedron = class(TGLBaseMesh) public procedure BuildList(var rci: TGLRenderContextInfo); override; end; //--------------------------- TGLQuadric Objects ------------------- (* A Disk object that may not be complete, it can have a hole (controlled by the InnerRadius property) and can only be a slice (controlled by the StartAngle and SweepAngle properties). *) TGLDisk = class(TGLQuadricObject) private FStartAngle, FSweepAngle, FOuterRadius, FInnerRadius: Single; FSlices, FLoops: Integer; procedure SetOuterRadius(const aValue: Single); procedure SetInnerRadius(const aValue: Single); procedure SetSlices(aValue: Integer); procedure SetLoops(aValue: Integer); procedure SetStartAngle(const aValue: Single); procedure SetSweepAngle(const aValue: Single); public constructor Create(AOwner: TComponent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; procedure Assign(Source: TPersistent); override; function AxisAlignedDimensionsUnscaled: TGLVector; override; function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil) : Boolean; override; published // Allows defining a "hole" in the disk property InnerRadius: Single read FInnerRadius write SetInnerRadius; // Number of radial mesh subdivisions property Loops: Integer read FLoops write SetLoops default 2; // Outer radius for the disk. If you leave InnerRadius at 0, this is the disk radius property OuterRadius: Single read FOuterRadius write SetOuterRadius; // Number of mesh slices. For instance, if Slices=6, your disk will look like an hexagon property Slices: Integer read FSlices write SetSlices default 16; property StartAngle: Single read FStartAngle write SetStartAngle; property SweepAngle: Single read FSweepAngle write SetSweepAngle; end; (* Base class to cylinder-like objects that introduces the basic cylinder description properties. Be aware teh default slices and stacks make up for a high-poly cylinder, unless you're after high-quality lighting it is recommended to reduce the Stacks property to 1. *) TGLCylinderBase = class(TGLQuadricObject) private FBottomRadius: Single; FSlices, FStacks, FLoops: Integer; FHeight: Single; protected procedure SetBottomRadius(const aValue: Single); procedure SetHeight(const aValue: Single); procedure SetSlices(aValue: Integer); procedure SetStacks(aValue: Integer); procedure SetLoops(aValue: Integer); function GetTopRadius: Single; virtual; public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; function GenerateSilhouette(const silhouetteParameters : TGLSilhouetteParameters): TGLSilhouette; override; published property BottomRadius: Single read FBottomRadius write SetBottomRadius; property Height: Single read FHeight write SetHeight; property Slices: Integer read FSlices write SetSlices default 16; property Stacks: Integer read FStacks write SetStacks default 4; // Number of concentric rings for top/bottom disk(s). property Loops: Integer read FLoops write SetLoops default 1; end; TGLConePart = (coSides, coBottom); TGLConeParts = set of TGLConePart; // A cone object TGLCone = class(TGLCylinderBase) private FParts: TGLConeParts; protected procedure SetParts(aValue: TGLConeParts); function GetTopRadius: Single; override; public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; function AxisAlignedDimensionsUnscaled: TGLVector; override; function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil) : Boolean; override; published property Parts: TGLConeParts read FParts write SetParts default [coSides, coBottom]; end; TGLCylinderPart = (cySides, cyBottom, cyTop); TGLCylinderParts = set of TGLCylinderPart; TGLCylinderAlignment = (caCenter, caTop, caBottom); // Cylinder object, can also be used to make truncated cones TGLCylinder = class(TGLCylinderBase) private FParts: TGLCylinderParts; FTopRadius: Single; FAlignment: TGLCylinderAlignment; protected procedure SetTopRadius(const aValue: Single); procedure SetParts(aValue: TGLCylinderParts); procedure SetAlignment(val: TGLCylinderAlignment); function GetTopRadius: Single; override; public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; function AxisAlignedDimensionsUnscaled: TGLVector; override; function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil) : Boolean; override; procedure Align(const startPoint, endPoint: TGLVector); overload; procedure Align(const startObj, endObj: TGLBaseSceneObject); overload; procedure Align(const startPoint, endPoint: TAffineVector); overload; published property TopRadius: Single read FTopRadius write SetTopRadius; property Parts: TGLCylinderParts read FParts write SetParts default [cySides, cyBottom, cyTop]; property Alignment: TGLCylinderAlignment read FAlignment write SetAlignment default caCenter; end; // Capsule object, can also be used to make truncated cones TGLCapsule = class(TGLSceneObject) private FParts: TGLCylinderParts; FRadius: Single; FSlices: Integer; FStacks: Integer; FHeight: Single; FAlignment: TGLCylinderAlignment; protected procedure SetHeight(const aValue: Single); procedure SetRadius(const aValue: Single); procedure SetSlices(const aValue: integer); procedure SetStacks(const aValue: integer); procedure SetParts(aValue: TGLCylinderParts); procedure SetAlignment(val: TGLCylinderAlignment); public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; function AxisAlignedDimensionsUnscaled: TGLVector; override; function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil) : Boolean; override; procedure Align(const startPoint, endPoint: TGLVector); overload; procedure Align(const startObj, endObj: TGLBaseSceneObject); overload; procedure Align(const startPoint, endPoint: TAffineVector); overload; published property Height: Single read FHeight write SetHeight; property Slices: Integer read FSlices write SetSlices; property Stacks: Integer read FStacks write SetStacks; property Radius: Single read FRadius write SetRadius; property Parts: TGLCylinderParts read FParts write SetParts default [cySides, cyBottom, cyTop]; property Alignment: TGLCylinderAlignment read FAlignment write SetAlignment default caCenter; end; TGLAnnulusPart = (anInnerSides, anOuterSides, anBottom, anTop); TGLAnnulusParts = set of TGLAnnulusPart; // An annulus is a cylinder that can be made hollow (pipe-like) TGLAnnulus = class(TGLCylinderBase) private FParts: TGLAnnulusParts; FBottomInnerRadius: Single; FTopInnerRadius: Single; FTopRadius: Single; protected procedure SetTopRadius(const aValue: Single); procedure SetTopInnerRadius(const aValue: Single); procedure SetBottomInnerRadius(const aValue: Single); procedure SetParts(aValue: TGLAnnulusParts); public constructor Create(AOwner: TComponent); override; procedure Assign(Source: TPersistent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; function AxisAlignedDimensionsUnscaled: TGLVector; override; function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil) : Boolean; override; published property BottomInnerRadius: Single read FBottomInnerRadius write SetBottomInnerRadius; property TopInnerRadius: Single read FTopInnerRadius write SetTopInnerRadius; property TopRadius: Single read FTopRadius write SetTopRadius; property Parts: TGLAnnulusParts read FParts write SetParts default [anInnerSides, anOuterSides, anBottom, anTop]; end; TGLTorusPart = (toSides, toStartDisk, toStopDisk); TGLTorusParts = set of TGLTorusPart; // A Torus object TGLTorus = class(TGLSceneObject) private FParts: TGLTorusParts; FRings, FSides: Cardinal; FStartAngle, FStopAngle: Single; FMinorRadius, FMajorRadius: Single; FMesh: array of array of TGLVertexRec; protected procedure SetMajorRadius(const aValue: Single); procedure SetMinorRadius(const aValue: Single); procedure SetRings(aValue: Cardinal); procedure SetSides(aValue: Cardinal); procedure SetStartAngle(const aValue: Single); procedure SetStopAngle(const aValue: Single); procedure SetParts(aValue: TGLTorusParts); public constructor Create(AOwner: TComponent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; function AxisAlignedDimensionsUnscaled: TGLVector; override; function RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; override; published property MajorRadius: Single read FMajorRadius write SetMajorRadius; property MinorRadius: Single read FMinorRadius write SetMinorRadius; property Rings: Cardinal read FRings write SetRings default 25; property Sides: Cardinal read FSides write SetSides default 15; property StartAngle: Single read FStartAngle write SetStartAngle; property StopAngle: Single read FStopAngle write SetStopAngle; property Parts: TGLTorusParts read FParts write SetParts default [toSides]; end; TGLArrowLinePart = (alLine, alTopArrow, alBottomArrow); TGLArrowLineParts = set of TGLArrowLinePart; TGLArrowHeadStyle = (ahssStacked, ahssCentered, ahssIncluded); (* Draws an arrowhead (cylinder + cone). The arrow head is a cone that shares the attributes of the cylinder (ie stacks/slices, materials etc). Seems to work ok. This is useful for displaying a vector based field (eg velocity) or other arrows that might be required. By default the bottom arrow is off *) TGLArrowLine = class(TGLCylinderBase) private FParts: TGLArrowLineParts; FTopRadius: Single; fTopArrowHeadHeight: Single; fTopArrowHeadRadius: Single; fBottomArrowHeadHeight: Single; fBottomArrowHeadRadius: Single; FHeadStackingStyle: TGLArrowHeadStyle; protected procedure SetTopRadius(const aValue: Single); procedure SetTopArrowHeadHeight(const aValue: Single); procedure SetTopArrowHeadRadius(const aValue: Single); procedure SetBottomArrowHeadHeight(const aValue: Single); procedure SetBottomArrowHeadRadius(const aValue: Single); procedure SetParts(aValue: TGLArrowLineParts); procedure SetHeadStackingStyle(const val: TGLArrowHeadStyle); public constructor Create(AOwner: TComponent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; procedure Assign(Source: TPersistent); override; published property TopRadius: Single read FTopRadius write SetTopRadius; property HeadStackingStyle: TGLArrowHeadStyle read FHeadStackingStyle write SetHeadStackingStyle default ahssStacked; property Parts: TGLArrowLineParts read FParts write SetParts default [alLine, alTopArrow]; property TopArrowHeadHeight: Single read fTopArrowHeadHeight write SetTopArrowHeadHeight; property TopArrowHeadRadius: Single read fTopArrowHeadRadius write SetTopArrowHeadRadius; property BottomArrowHeadHeight: Single read fBottomArrowHeadHeight write SetBottomArrowHeadHeight; property BottomArrowHeadRadius: Single read fBottomArrowHeadRadius write SetBottomArrowHeadRadius; end; TGLArrowArcPart = (aaArc, aaTopArrow, aaBottomArrow); TGLArrowArcParts = set of TGLArrowArcPart; (* Draws an arrowhead (Sliced Torus + cone). The arrow head is a cone that shares the attributes of the Torus (ie stacks/slices, materials etc). This is useful for displaying a movement (eg twist) or other arc arrows that might be required. By default the bottom arrow is off *) TGLArrowArc = class(TGLCylinderBase) private fArcRadius: Single; FStartAngle: Single; FStopAngle: Single; FParts: TGLArrowArcParts; FTopRadius: Single; fTopArrowHeadHeight: Single; fTopArrowHeadRadius: Single; fBottomArrowHeadHeight: Single; fBottomArrowHeadRadius: Single; FHeadStackingStyle: TGLArrowHeadStyle; FMesh: array of array of TGLVertexRec; protected procedure SetArcRadius(const aValue: Single); procedure SetStartAngle(const aValue: Single); procedure SetStopAngle(const aValue: Single); procedure SetTopRadius(const aValue: Single); procedure SetTopArrowHeadHeight(const aValue: Single); procedure SetTopArrowHeadRadius(const aValue: Single); procedure SetBottomArrowHeadHeight(const aValue: Single); procedure SetBottomArrowHeadRadius(const aValue: Single); procedure SetParts(aValue: TGLArrowArcParts); procedure SetHeadStackingStyle(const val: TGLArrowHeadStyle); public constructor Create(AOwner: TComponent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; procedure Assign(Source: TPersistent); override; published property ArcRadius: Single read fArcRadius write SetArcRadius; property StartAngle: Single read FStartAngle write SetStartAngle; property StopAngle: Single read FStopAngle write SetStopAngle; property TopRadius: Single read FTopRadius write SetTopRadius; property HeadStackingStyle: TGLArrowHeadStyle read FHeadStackingStyle write SetHeadStackingStyle default ahssStacked; property Parts: TGLArrowArcParts read FParts write SetParts default [aaArc, aaTopArrow]; property TopArrowHeadHeight: Single read fTopArrowHeadHeight write SetTopArrowHeadHeight; property TopArrowHeadRadius: Single read fTopArrowHeadRadius write SetTopArrowHeadRadius; property BottomArrowHeadHeight: Single read fBottomArrowHeadHeight write SetBottomArrowHeadHeight; property BottomArrowHeadRadius: Single read fBottomArrowHeadRadius write SetBottomArrowHeadRadius; end; TGLPolygonPart = (ppTop, ppBottom); TGLPolygonParts = set of TGLPolygonPart; (* A basic polygon object. The curve is described by the Nodes and SplineMode properties, should be planar and is automatically tessellated. Texture coordinates are deduced from X and Y coordinates only. This object allows only for polygons described by a single curve, if you need "complex polygons" with holes, patches and cutouts, see GLS.MultiPolygon. *) TGLPolygon = class(TGLPolygonBase) private FParts: TGLPolygonParts; protected procedure SetParts(const val: TGLPolygonParts); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; published (* Parts of polygon. The 'top' of the polygon is the position were the curve describing the polygon spin counter-clockwise (i.e. right handed convention). *) property Parts: TGLPolygonParts read FParts write SetParts default [ppTop, ppBottom]; end; TGLFrustrumPart = (fpTop, fpBottom, fpFront, fpBack, fpLeft, fpRight); TGLFrustrumParts = set of TGLFrustrumPart; const cAllFrustrumParts = [fpTop, fpBottom, fpFront, fpBack, fpLeft, fpRight]; type (* A frustrum is a pyramid with the top chopped off. The height of the imaginary pyramid is ApexHeight, the height of the frustrum is Height. If ApexHeight and Height are the same, the frustrum degenerates into a pyramid. Height cannot be greater than ApexHeight. *) TGLFrustrum = class(TGLSceneObject) private FApexHeight, FBaseDepth, FBaseWidth, FHeight: Single; FParts: TGLFrustrumParts; FNormalDirection: TGLNormalDirection; procedure SetApexHeight(const aValue: Single); procedure SetBaseDepth(const aValue: Single); procedure SetBaseWidth(const aValue: Single); procedure SetHeight(const aValue: Single); procedure SetParts(aValue: TGLFrustrumParts); procedure SetNormalDirection(aValue: TGLNormalDirection); protected procedure DefineProperties(Filer: TFiler); override; procedure ReadData(Stream: TStream); procedure WriteData(Stream: TStream); public constructor Create(AOwner: TComponent); override; procedure BuildList(var rci: TGLRenderContextInfo); override; procedure Assign(Source: TPersistent); override; function TopDepth: Single; function TopWidth: Single; function AxisAlignedBoundingBoxUnscaled: TAABB; function AxisAlignedDimensionsUnscaled: TGLVector; override; published property ApexHeight: Single read FApexHeight write SetApexHeight stored False; property BaseDepth: Single read FBaseDepth write SetBaseDepth stored False; property BaseWidth: Single read FBaseWidth write SetBaseWidth stored False; property Height: Single read FHeight write SetHeight stored False; property NormalDirection: TGLNormalDirection read FNormalDirection write SetNormalDirection default ndOutside; property Parts: TGLFrustrumParts read FParts write SetParts default cAllFrustrumParts; end; //--------------------- TGLTeapot ------------------------- (* The classic teapot. The only use of this object is as placeholder for testing... *) TGLTeapot = class(TGLSceneObject) private FGrid: Cardinal; public constructor Create(AOwner: TComponent); override; function AxisAlignedDimensionsUnscaled: TGLVector; override; procedure BuildList(var rci: TGLRenderContextInfo); override; procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); override; end; // ------------------------------------------------------------- implementation // ------------------------------------------------------------- //-------------------- //-------------------- TGLTetrahedron ------------------------ //-------------------- procedure TGLTetrahedron.BuildList(var rci: TGLRenderContextInfo); const Vertices: packed array [0 .. 3] of TAffineVector = ((X: 1.0; Y: 1.0; Z: 1.0), (X: 1.0; Y: -1.0; Z: -1.0), (X: -1.0; Y: 1.0; Z: -1.0), (X: -1.0; Y: -1.0; Z: 1.0)); Triangles: packed array [0 .. 3] of packed array [0 .. 2] of Byte = ((0, 1, 3), (2, 1, 0), (3, 2, 0), (1, 2, 3)); var i, j: Integer; n: TAffineVector; faceIndices: PByteArray; begin for i := 0 to 3 do begin faceIndices := @triangles[i, 0]; n := CalcPlaneNormal(vertices[faceIndices^[0]], vertices[faceIndices^[1]], vertices[faceIndices^[2]]); gl.Normal3fv(@n); gl.Begin_(GL_TRIANGLES); for j := 0 to 2 do gl.Vertex3fv(@vertices[faceIndices^[j]]); gl.End_; end; end; //-------------------- //-------------------- TGLOctahedron ------------------------ //-------------------- procedure TGLOctahedron.BuildList(var rci: TGLRenderContextInfo); const Vertices: packed array [0 .. 5] of TAffineVector = ((X: 1.0; Y: 0.0; Z: 0.0), (X:-1.0; Y: 0.0; Z: 0.0), (X: 0.0; Y: 1.0; Z: 0.0), (X: 0.0; Y: -1.0; Z: 0.0), (X: 0.0; Y: 0.0; Z: 1.0), (X: 0.0; Y: 0.0; Z: -1.0)); Triangles: packed array [0 .. 7] of packed array [0 .. 2] of Byte = ((0, 4, 2), (1, 2, 4), (0, 3, 4), (1, 4, 3), (0, 2, 5), (1, 5, 2), (0, 5, 3), (1, 3, 5)); var i, j: Integer; n: TAffineVector; faceIndices: PByteArray; begin for i := 0 to 7 do begin faceIndices := @triangles[i, 0]; n := CalcPlaneNormal(vertices[faceIndices^[0]], vertices[faceIndices^[1]], vertices[faceIndices^[2]]); gl.Normal3fv(@n); gl.Begin_(GL_TRIANGLES); for j := 0 to 2 do gl.Vertex3fv(@vertices[faceIndices^[j]]); gl.End_; end; end; // ------------------ // ------------------ TGLHexahedron ------------------ // ------------------ procedure TGLHexahedron.BuildList(var rci: TGLRenderContextInfo); const Vertices: packed array [0 .. 7] of TAffineVector = ((X:-1; Y:-1; Z:-1), (X: 1; Y:-1; Z:-1), (X: 1; Y:-1; Z: 1), (X:-1; Y:-1; Z: 1), (X:-1; Y: 1; Z:-1), (X: 1; Y: 1; Z:-1), (X: 1; Y: 1; Z: 1), (X:-1; Y: 1; Z: 1)); Quadrangles: packed array [0 .. 5] of packed array [0 .. 3] of Byte = ((0, 1, 2, 3), (3, 2, 6, 7), (7, 6, 5, 4), (4, 5, 1, 0), (0, 3, 7, 4), (1, 5, 6, 2)); var i, j: Integer; n: TAffineVector; faceIndices: PByteArray; begin for i := 0 to 4 do begin faceIndices := @Quadrangles[i, 0]; n := CalcPlaneNormal(vertices[faceIndices^[0]], vertices[faceIndices^[1]], vertices[faceIndices^[2]]); gl.Normal3fv(@n); gl.Begin_(GL_QUADS); for j := 0 to 7 do gl.Vertex3fv(@vertices[faceIndices^[j]]); gl.End_; end; end; // ------------------ // ------------------ TGLDodecahedron ------------------ // ------------------ procedure TGLDodecahedron.BuildList(var rci: TGLRenderContextInfo); const A = 1.61803398875 * 0.3; // (Sqrt(5)+1)/2 B = 0.61803398875 * 0.3; // (Sqrt(5)-1)/2 C = 1 * 0.3; const Vertices: packed array [0 .. 19] of TAffineVector = ((X: - A; Y: 0; Z: B), (X: - A; Y: 0; Z: - B), (X: A; Y: 0; Z: - B), (X: A; Y: 0; Z: B), (X: B; Y: - A; Z: 0), (X: - B; Y: - A; Z: 0), (X: - B; Y: A; Z: 0), (X: B; Y: A; Z: 0), (X: 0; Y: B; Z: - A), (X: 0; Y: - B; Z: - A), (X: 0; Y: - B; Z: A), (X: 0; Y: B; Z: A), (X: - C; Y: - C; Z: C), (X: - C; Y: - C; Z: - C), (X: C; Y: - C; Z: - C), (X: C; Y: - C; Z: C), (X: - C; Y: C; Z: C), (X: - C; Y: C; Z: - C), (X: C; Y: C; Z: - C), (X: C; Y: C; Z: C)); Polygons: packed array [0 .. 11] of packed array [0 .. 4] of Byte = ((0, 12, 10, 11, 16), (1, 17, 8, 9, 13), (2, 14, 9, 8, 18), (3, 19, 11, 10, 15), (4, 14, 2, 3, 15), (5, 12, 0, 1, 13), (6, 17, 1, 0, 16), (7, 19, 3, 2, 18), (8, 17, 6, 7, 18), (9, 14, 4, 5, 13), (10, 12, 5, 4, 15), (11, 19, 7, 6, 16)); var i, j: Integer; n: TAffineVector; faceIndices: PByteArray; begin for i := 0 to 11 do begin faceIndices := @polygons[i, 0]; n := CalcPlaneNormal(vertices[faceIndices^[0]], vertices[faceIndices^[1]], vertices[faceIndices^[2]]); gl.Normal3fv(@n); // gl.Begin_(GL_TRIANGLE_FAN); // for j := 0 to 4 do // gl.Vertex3fv(@vertices[faceIndices^[j]]); // gl.End_(); gl.Begin_(GL_TRIANGLES); for j := 1 to 3 do begin gl.Vertex3fv(@vertices[faceIndices^[0]]); gl.Vertex3fv(@vertices[faceIndices^[j]]); gl.Vertex3fv(@vertices[faceIndices^[j+1]]); end; gl.End_; end; end; // ------------------ // ------------------ TGLIcosahedron ------------------ // ------------------ procedure TGLIcosahedron.BuildList(var rci: TGLRenderContextInfo); const A = 0.5; B = 0.30901699437; // 1/(1+Sqrt(5)) const Vertices: packed array [0 .. 11] of TAffineVector = ((X: 0; Y: - B; Z: - A), (X: 0; Y: - B; Z: A), (X: 0; Y: B; Z: - A), (X: 0; Y: B; Z: A), (X: - A; Y: 0; Z: - B), (X: - A; Y: 0; Z: B), (X: A; Y: 0; Z: - B), (X: A; Y: 0; Z: B), (X: - B; Y: - A; Z: 0), (X: - B; Y: A; Z: 0), (X: B; Y: - A; Z: 0), (X: B; Y: A; Z: 0)); Triangles: packed array [0 .. 19] of packed array [0 .. 2] of Byte = ((2, 9, 11), (3, 11, 9), (3, 5, 1), (3, 1, 7), (2, 6, 0), (2, 0, 4), (1, 8, 10), (0, 10, 8), (9, 4, 5), (8, 5, 4), (11, 7, 6), (10, 6, 7), (3, 9, 5), (3, 7, 11), (2, 4, 9), (2, 11, 6), (0, 8, 4), (0, 6, 10), (1, 5, 8), (1, 10, 7)); var i, j: Integer; n: TAffineVector; faceIndices: PByteArray; begin for i := 0 to 19 do begin faceIndices := @triangles[i, 0]; n := CalcPlaneNormal(vertices[faceIndices^[0]], vertices[faceIndices^[1]], vertices[faceIndices^[2]]); gl.Normal3fv(@n); gl.Begin_(GL_TRIANGLES); for j := 0 to 2 do gl.Vertex3fv(@vertices[faceIndices^[j]]); gl.End_; end; end; // ------------------ // ------------------ TGLDisk ------------------ // ------------------ constructor TGLDisk.Create(AOwner: TComponent); begin inherited Create(AOwner); FOuterRadius := 0.5; FInnerRadius := 0; FSlices := 16; FLoops := 2; FStartAngle := 0; FSweepAngle := 360; end; procedure TGLDisk.BuildList(var rci: TGLRenderContextInfo); var quadric: PGLUquadric; begin quadric := gluNewQuadric(); SetupQuadricParams(quadric); gluPartialDisk(quadric, FInnerRadius, FOuterRadius, FSlices, FLoops, FStartAngle, FSweepAngle); gluDeleteQuadric(quadric); end; procedure TGLDisk.SetOuterRadius(const aValue: Single); begin if aValue <> FOuterRadius then begin FOuterRadius := aValue; StructureChanged; end; end; procedure TGLDisk.SetInnerRadius(const aValue: Single); begin if aValue <> FInnerRadius then begin FInnerRadius := aValue; StructureChanged; end; end; procedure TGLDisk.SetSlices(aValue: integer); begin if aValue <> FSlices then begin FSlices := aValue; StructureChanged; end; end; procedure TGLDisk.SetLoops(aValue: integer); begin if aValue <> FLoops then begin FLoops := aValue; StructureChanged; end; end; procedure TGLDisk.SetStartAngle(const aValue: Single); begin if aValue <> FStartAngle then begin FStartAngle := aValue; StructureChanged; end; end; procedure TGLDisk.SetSweepAngle(const aValue: Single); begin if aValue <> FSweepAngle then begin FSweepAngle := aValue; StructureChanged; end; end; procedure TGLDisk.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TGLDisk) then begin FOuterRadius := TGLDisk(Source).FOuterRadius; FInnerRadius := TGLDisk(Source).FInnerRadius; FSlices := TGLDisk(Source).FSlices; FLoops := TGLDisk(Source).FLoops; FStartAngle := TGLDisk(Source).FStartAngle; FSweepAngle := TGLDisk(Source).FSweepAngle; end; inherited Assign(Source); end; function TGLDisk.AxisAlignedDimensionsUnscaled: TGLVector; var r: Single; begin r := Abs(FOuterRadius); Result := VectorMake(r, r, 0); end; function TGLDisk.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; var ip: TGLVector; d: Single; angle, beginAngle, endAngle: Single; localIntPoint: TGLVector; begin Result := False; if SweepAngle > 0 then if RayCastPlaneIntersect(rayStart, rayVector, AbsolutePosition, AbsoluteDirection, @ip) then begin if Assigned(intersectPoint) then SetVector(intersectPoint^, ip); localIntPoint := AbsoluteToLocal(ip); d := VectorNorm(localIntPoint); if (d >= Sqr(InnerRadius)) and (d <= Sqr(OuterRadius)) then begin if SweepAngle >= 360 then Result := true else begin // arctan2 returns results between -pi and +pi, we want between 0 and 360 angle := 180 / pi * ArcTan2(localIntPoint.X, localIntPoint.Y); if angle < 0 then angle := angle + 360; // we also want StartAngle and StartAngle+SweepAngle to be in this range beginAngle := Trunc(StartAngle) mod 360; endAngle := Trunc(StartAngle + SweepAngle) mod 360; // If beginAngle > endAngle then area crosses the boundary from 360=>0 degrees // therefore have 2 valid regions (beginAngle to 360) & (0 to endAngle) // otherwise just 1 valid region (beginAngle to endAngle) if beginAngle > endAngle then begin if (angle > beginAngle) or (angle < endAngle) then Result := true; end else if (angle > beginAngle) and (angle < endAngle) then Result := true; end; end; end; if Result = true then if Assigned(intersectNormal) then SetVector(intersectNormal^, AbsoluteUp); end; // ------------------ // ------------------ TGLCylinderBase ------------------ // ------------------ constructor TGLCylinderBase.Create(AOwner: TComponent); begin inherited Create(AOwner); FBottomRadius := 0.5; FHeight := 1; FSlices := 16; FStacks := 4; FLoops := 1; end; procedure TGLCylinderBase.SetBottomRadius(const aValue: Single); begin if aValue <> FBottomRadius then begin FBottomRadius := aValue; StructureChanged; end; end; function TGLCylinderBase.GetTopRadius: Single; begin Result := FBottomRadius; end; procedure TGLCylinderBase.SetHeight(const aValue: Single); begin if aValue <> FHeight then begin FHeight := aValue; StructureChanged; end; end; procedure TGLCylinderBase.SetSlices(aValue: Integer); begin if aValue <> FSlices then begin FSlices := aValue; StructureChanged; end; end; procedure TGLCylinderBase.SetStacks(aValue: Integer); begin if aValue <> FStacks then begin FStacks := aValue; StructureChanged; end; end; procedure TGLCylinderBase.SetLoops(aValue: Integer); begin if (aValue >= 1) and (aValue <> FLoops) then begin FLoops := aValue; StructureChanged; end; end; procedure TGLCylinderBase.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TGLCylinderBase) then begin FBottomRadius := TGLCylinderBase(Source).FBottomRadius; FSlices := TGLCylinderBase(Source).FSlices; FStacks := TGLCylinderBase(Source).FStacks; FLoops := TGLCylinderBase(Source).FLoops; FHeight := TGLCylinderBase(Source).FHeight; end; inherited Assign(Source); end; function TGLCylinderBase.GenerateSilhouette(const silhouetteParameters : TGLSilhouetteParameters): TGLSilhouette; var Connectivity: TGLConnectivity; sil: TGLSilhouette; ShadowSlices: integer; i: integer; p: array [0 .. 3] of TVector3f; PiDivSlices: Single; a1, a2: Single; c1, c2: TVector3f; cosa1, cosa2, sina1, sina2: Single; HalfHeight: Single; ShadowTopRadius: Single; begin Connectivity := TGLConnectivity.Create(true); ShadowSlices := FSlices div 1; if FSlices < 5 then FSlices := 5; PiDivSlices := 2 * pi / ShadowSlices; a1 := 0; // Is this a speed improvement or just a waste of code? HalfHeight := FHeight / 2; MakeVector(c1, 0, -HalfHeight, 0); MakeVector(c2, 0, HalfHeight, 0); ShadowTopRadius := GetTopRadius; for i := 0 to ShadowSlices - 1 do begin a2 := a1 + PiDivSlices; // Is this a speed improvement or just a waste of code? cosa1 := cos(a1); cosa2 := cos(a2); sina1 := sin(a1); sina2 := sin(a2); // Generate the four "corners"; // Bottom corners MakeVector(p[0], FBottomRadius * sina2, -HalfHeight, FBottomRadius * cosa2); MakeVector(p[1], FBottomRadius * sina1, -HalfHeight, FBottomRadius * cosa1); // Top corners MakeVector(p[2], ShadowTopRadius * sina1, HalfHeight, ShadowTopRadius * cosa1); MakeVector(p[3], ShadowTopRadius * sina2, HalfHeight, ShadowTopRadius * cosa2); // This should be optimized to use AddIndexedFace, because this method // searches for each of the vertices and adds them or re-uses them. // Skin Connectivity.AddFace(p[2], p[1], p[0]); Connectivity.AddFace(p[3], p[2], p[0]); // Sides / caps Connectivity.AddFace(c1, p[0], p[1]); Connectivity.AddFace(p[2], p[3], c2); a1 := a1 + PiDivSlices; end; sil := nil; Connectivity.CreateSilhouette(silhouetteParameters, sil, False); Result := sil; Connectivity.Free; end; // ------------------ // ------------------ TGLCone ------------------ // ------------------ constructor TGLCone.Create(AOwner: TComponent); begin inherited Create(AOwner); FParts := [coSides, coBottom]; end; procedure TGLCone.BuildList(var rci: TGLRenderContextInfo); var quadric: PGLUquadricObj; begin gl.PushMatrix; quadric := gluNewQuadric(); SetupQuadricParams(quadric); gl.Rotated(-90, 1, 0, 0); gl.Translatef(0, 0, -FHeight * 0.5); if coSides in FParts then gluCylinder(quadric, BottomRadius, 0, Height, Slices, Stacks); if coBottom in FParts then begin // top of a disk is defined as outside SetInvertedQuadricOrientation(quadric); gluDisk(quadric, 0, BottomRadius, Slices, FLoops); end; gluDeleteQuadric(quadric); gl.PopMatrix; end; procedure TGLCone.SetParts(aValue: TGLConeParts); begin if aValue <> FParts then begin FParts := aValue; StructureChanged; end; end; procedure TGLCone.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TGLCone) then begin FParts := TGLCone(Source).FParts; end; inherited Assign(Source); end; function TGLCone.AxisAlignedDimensionsUnscaled: TGLVector; var r: Single; begin r := Abs(FBottomRadius); Result := VectorMake(r (* *Scale.DirectX *) , 0.5 * FHeight (* *Scale.DirectY *) , r (* *Scale.DirectZ *) ); end; function TGLCone.GetTopRadius: Single; begin Result := 0; end; function TGLCone.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; var ip, localRayStart, localRayVector: TGLVector; poly: array [0 .. 2] of Double; roots: TDoubleArray; minRoot: Double; d, t, hconst: Single; begin Result := False; localRayStart := AbsoluteToLocal(rayStart); localRayVector := VectorNormalize(AbsoluteToLocal(rayVector)); if coBottom in Parts then begin // bottom can only be raycast from beneath if localRayStart.Y < -FHeight * 0.5 then begin if RayCastPlaneIntersect(localRayStart, localRayVector, PointMake(0, -FHeight * 0.5, 0), YHmgVector, @ip) then begin d := VectorNorm(ip.X, ip.Z); if (d <= Sqr(BottomRadius)) then begin Result := true; if Assigned(intersectPoint) then SetVector(intersectPoint^, LocalToAbsolute(ip)); if Assigned(intersectNormal) then SetVector(intersectNormal^, VectorNegate(AbsoluteUp)); Exit; end; end; end; end; if coSides in Parts then begin hconst := -Sqr(BottomRadius) / Sqr(Height); // intersect against infinite cones (in positive and negative direction) poly[0] := Sqr(localRayStart.X) + hconst * Sqr(localRayStart.Y - 0.5 * FHeight) + Sqr(localRayStart.Z); poly[1] := 2 * (localRayStart.X * localRayVector.X + hconst * (localRayStart.Y - 0.5 * FHeight) * localRayVector.Y + localRayStart.Z* localRayVector.Z); poly[2] := Sqr(localRayVector.X) + hconst * Sqr(localRayVector.Y) + Sqr(localRayVector.Z); SetLength(roots, 0); roots := SolveQuadric(@poly); if MinPositiveCoef(roots, minRoot) then begin t := minRoot; ip := VectorCombine(localRayStart, localRayVector, 1, t); // check that intersection with infinite cone is within the range we want if (ip.Y > -FHeight * 0.5) and (ip.Y < FHeight * 0.5) then begin Result := true; if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(ip); if Assigned(intersectNormal) then begin ip.Y := hconst * (ip.Y - 0.5 * Height); ip.W := 0; NormalizeVector(ip); intersectNormal^ := LocalToAbsolute(ip); end; end; end; end; end; // ------------------ // ------------------ TGLCylinder ------------------ // ------------------ constructor TGLCylinder.Create(AOwner: TComponent); begin inherited Create(AOwner); FTopRadius := 0.5; FParts := [cySides, cyBottom, cyTop]; FAlignment := caCenter; end; procedure TGLCylinder.BuildList(var rci: TGLRenderContextInfo); var quadric: PGLUquadricObj; begin gl.PushMatrix; quadric := gluNewQuadric; SetupQuadricParams(quadric); gl.Rotatef(-90, 1, 0, 0); case Alignment of caTop: gl.Translatef(0, 0, -FHeight); caBottom: ; else // caCenter gl.Translatef(0, 0, -FHeight * 0.5); end; if cySides in FParts then gluCylinder(quadric, FBottomRadius, FTopRadius, FHeight, FSlices, FStacks); if cyTop in FParts then begin gl.PushMatrix; gl.Translatef(0, 0, FHeight); gluDisk(Quadric, 0, FTopRadius, FSlices, FLoops); gl.PopMatrix; end; if cyBottom in FParts then begin // swap quadric orientation because top of a disk is defined as outside SetInvertedQuadricOrientation(quadric); gluDisk(quadric, 0, FBottomRadius, FSlices, FLoops); end; gluDeleteQuadric(Quadric); gl.PopMatrix; end; procedure TGLCylinder.SetTopRadius(const aValue: Single); begin if aValue <> FTopRadius then begin FTopRadius := aValue; StructureChanged; end; end; function TGLCylinder.GetTopRadius: Single; begin Result := FTopRadius; end; procedure TGLCylinder.SetParts(aValue: TGLCylinderParts); begin if aValue <> FParts then begin FParts := aValue; StructureChanged; end; end; procedure TGLCylinder.SetAlignment(val: TGLCylinderAlignment); begin if val <> FAlignment then begin FAlignment := val; StructureChanged; end; end; procedure TGLCylinder.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TGLCylinder) then begin FParts := TGLCylinder(Source).FParts; FTopRadius := TGLCylinder(Source).FTopRadius; end; inherited Assign(Source); end; function TGLCylinder.AxisAlignedDimensionsUnscaled: TGLVector; var r, r1: Single; begin r := Abs(FBottomRadius); r1 := Abs(FTopRadius); if r1 > r then r := r1; Result := VectorMake(r, 0.5 * FHeight, r); // ScaleVector(Result, Scale.AsVector); end; function TGLCylinder.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; const cOne: Single = 1; var locRayStart, locRayVector, ip: TGLVector; poly: array [0 .. 2] of Double; roots: TDoubleArray; minRoot: Double; t, tr2, invRayVector1, hTop, hBottom: Single; tPlaneMin, tPlaneMax: Single; begin Result := False; locRayStart := AbsoluteToLocal(rayStart); locRayVector := AbsoluteToLocal(rayVector); case Alignment of caTop: begin hTop := 0; hBottom := -Height; end; caBottom: begin hTop := Height; hBottom := 0; end; else // caCenter hTop := Height * 0.5; hBottom := -hTop; end; if locRayVector.Y = 0 then begin // intersect if ray shot through the top/bottom planes if (locRayStart.X > hTop) or (locRayStart.X < hBottom) then Exit; tPlaneMin := -1E99; tPlaneMax := 1E99; end else begin invRayVector1 := cOne / locRayVector.Y; tr2 := Sqr(TopRadius); // compute intersection with topPlane t := (hTop - locRayStart.Y) * invRayVector1; if (t > 0) and (cyTop in Parts) then begin ip.X := locRayStart.X + t * locRayVector.X; ip.Z := locRayStart.Z + t * locRayVector.Z; if Sqr(ip.X) + Sqr(ip.Z) <= tr2 then begin // intersect with top plane if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(VectorMake(ip.X, hTop, ip.Z, 1)); if Assigned(intersectNormal) then intersectNormal^ := LocalToAbsolute(YHmgVector); Result := true; end; end; tPlaneMin := t; tPlaneMax := t; // compute intersection with bottomPlane t := (hBottom - locRayStart.Y) * invRayVector1; if (t > 0) and (cyBottom in Parts) then begin ip.X := locRayStart.X + t * locRayVector.X; ip.Z := locRayStart.Z + t * locRayVector.Z; if (t < tPlaneMin) or (not(cyTop in Parts)) then begin if Sqr(ip.X) + Sqr(ip.Z) <= tr2 then begin // intersect with top plane if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(VectorMake(ip.X, hBottom, ip.Z, 1)); if Assigned(intersectNormal) then intersectNormal^ := LocalToAbsolute(VectorNegate(YHmgVector)); Result := true; end; end; end; if t < tPlaneMin then tPlaneMin := t; if t > tPlaneMax then tPlaneMax := t; end; if cySides in Parts then begin // intersect against cylinder infinite cylinder poly[0] := Sqr(locRayStart.X) + Sqr(locRayStart.Z) - Sqr(TopRadius); poly[1] := 2 * (locRayStart.X * locRayVector.X + locRayStart.Z * locRayVector.Z); poly[2] := Sqr(locRayVector.X) + Sqr(locRayVector.Z); roots := SolveQuadric(@poly); if MinPositiveCoef(roots, minRoot) then begin t := minRoot; if (t >= tPlaneMin) and (t < tPlaneMax) then begin if Assigned(intersectPoint) or Assigned(intersectNormal) then begin ip := VectorCombine(locRayStart, locRayVector, 1, t); if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(ip); if Assigned(intersectNormal) then begin ip.Y := 0; ip.W := 0; intersectNormal^ := LocalToAbsolute(ip); end; end; Result := true; end; end; end else SetLength(roots, 0); end; procedure TGLCylinder.Align(const startPoint, endPoint: TGLVector); var dir: TAffineVector; begin AbsolutePosition := startPoint; VectorSubtract(endPoint, startPoint, dir); if Parent <> nil then dir := Parent.AbsoluteToLocal(dir); Up.AsAffineVector := dir; Height := VectorLength(dir); Lift(Height * 0.5); Alignment := caCenter; end; procedure TGLCylinder.Align(const startObj, endObj: TGLBaseSceneObject); begin Align(startObj.AbsolutePosition, endObj.AbsolutePosition); end; procedure TGLCylinder.Align(const startPoint, endPoint: TAffineVector); begin Align(PointMake(startPoint), PointMake(endPoint)); end; // ------------------ // ------------------ TGLCapsule ------------------ // ------------------ constructor TGLCapsule.Create(AOwner: TComponent); begin inherited Create(AOwner); FHeight := 1; FRadius := 0.5; FSlices := 4; FStacks := 4; FParts := [cySides, cyBottom, cyTop]; FAlignment := caCenter; end; procedure TGLCapsule.BuildList(var rci: TGLRenderContextInfo); var i, j, n: integer; start_nx2: Single; start_ny2: Single; tmp, nx, ny, nz, start_nx, start_ny, a, ca, sa, l: Single; nx2, ny2, nz2: Single; begin gl.PushMatrix; gl.Rotatef(-90, 0, 0, 1); case Alignment of caTop: gl.Translatef(0, 0, FHeight + 1); caBottom: gl.Translatef(0, 0, -FHeight); else // caCenter gl.Translatef(0, 0, 0.5); end; n := FSlices * FStacks; l := FHeight; l := l * 0.5; a := (pi * 2.0) / n; sa := sin(a); ca := cos(a); ny := 0; nz := 1; if cySides in FParts then begin gl.Begin_(GL_TRIANGLE_STRIP); for i := 0 to n do begin gl.Normal3d(ny, nz, 0); gl.TexCoord2f(i / n, 1); gl.Vertex3d(ny * FRadius, nz * FRadius, l - 0.5); gl.Normal3d(ny, nz, 0); gl.TexCoord2f(i / n, 0); gl.Vertex3d(ny * FRadius, nz * FRadius, -l - 0.5); tmp := ca * ny - sa * nz; nz := sa * ny + ca * nz; ny := tmp; end; gl.End_(); end; if cyTop in FParts then begin start_nx := 0; start_ny := 1; for j := 0 to (n div FStacks) do begin start_nx2 := ca * start_nx + sa * start_ny; start_ny2 := -sa * start_nx + ca * start_ny; nx := start_nx; ny := start_ny; nz := 0; nx2 := start_nx2; ny2 := start_ny2; nz2 := 0; gl.PushMatrix; gl.Translatef(0, 0, -0.5); gl.Begin_(GL_TRIANGLE_STRIP); for i := 0 to n do begin gl.Normal3d(ny2, nz2, nx2); gl.TexCoord2f(i / n, j / n); gl.Vertex3d(ny2 * FRadius, nz2 * FRadius, l + nx2 * FRadius); gl.Normal3d(ny, nz, nx); gl.TexCoord2f(i / n, (j - 1) / n); gl.Vertex3d(ny * FRadius, nz * FRadius, l + nx * FRadius); tmp := ca * ny - sa * nz; nz := sa * ny + ca * nz; ny := tmp; tmp := ca * ny2 - sa * nz2; nz2 := sa * ny2 + ca * nz2; ny2 := tmp; end; gl.End_(); gl.PopMatrix; start_nx := start_nx2; start_ny := start_ny2; end; end; if cyBottom in FParts then begin start_nx := 0; start_ny := 1; for j := 0 to (n div FStacks) do begin start_nx2 := ca * start_nx - sa * start_ny; start_ny2 := sa * start_nx + ca * start_ny; nx := start_nx; ny := start_ny; nz := 0; nx2 := start_nx2; ny2 := start_ny2; nz2 := 0; gl.PushMatrix; gl.Translatef(0, 0, -0.5); gl.Begin_(GL_TRIANGLE_STRIP); for i := 0 to n do begin gl.Normal3d(ny, nz, nx); gl.TexCoord2f(i / n, (j - 1) / n); gl.Vertex3d(ny * FRadius, nz * FRadius, -l + nx * FRadius); gl.Normal3d(ny2, nz2, nx2); gl.TexCoord2f(i / n, j / n); gl.Vertex3d(ny2 * FRadius, nz2 * FRadius, -l + nx2 * FRadius); tmp := ca * ny - sa * nz; nz := sa * ny + ca * nz; ny := tmp; tmp := ca * ny2 - sa * nz2; nz2 := sa * ny2 + ca * nz2; ny2 := tmp; end; gl.End_(); gl.PopMatrix; start_nx := start_nx2; start_ny := start_ny2; end; end; gl.PopMatrix; end; procedure TGLCapsule.SetHeight(const aValue: Single); begin if aValue <> FHeight then begin FHeight := aValue; StructureChanged; end; end; procedure TGLCapsule.SetRadius(const aValue: Single); begin if aValue <> FRadius then begin FRadius := aValue; StructureChanged; end; end; procedure TGLCapsule.SetSlices(const aValue: integer); begin if aValue <> FSlices then begin FSlices := aValue; StructureChanged; end; end; procedure TGLCapsule.SetStacks(const aValue: integer); begin if aValue <> FStacks then begin FStacks := aValue; StructureChanged; end; end; procedure TGLCapsule.SetParts(aValue: TGLCylinderParts); begin if aValue <> FParts then begin FParts := aValue; StructureChanged; end; end; procedure TGLCapsule.SetAlignment(val: TGLCylinderAlignment); begin if val <> FAlignment then begin FAlignment := val; StructureChanged; end; end; procedure TGLCapsule.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TGLCapsule) then begin FParts := TGLCapsule(Source).FParts; FRadius := TGLCapsule(Source).FRadius; end; inherited Assign(Source); end; function TGLCapsule.AxisAlignedDimensionsUnscaled: TGLVector; var r, r1: Single; begin r := Abs(FRadius); r1 := Abs(FRadius); if r1 > r then r := r1; Result := VectorMake(r, 0.5 * FHeight, r); // ScaleVector(Result, Scale.AsVector); end; function TGLCapsule.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; const cOne: Single = 1; var locRayStart, locRayVector, ip: TGLVector; poly: array [0 .. 2] of Double; roots: TDoubleArray; minRoot: Double; t, tr2, invRayVector1, hTop, hBottom: Single; tPlaneMin, tPlaneMax: Single; begin Result := False; locRayStart := AbsoluteToLocal(rayStart); locRayVector := AbsoluteToLocal(rayVector); case Alignment of caTop: begin hTop := 0; hBottom := -FHeight; end; caBottom: begin hTop := FHeight; hBottom := 0; end; else // caCenter hTop := FHeight * 0.5; hBottom := -hTop; end; if locRayVector.Y = 0 then begin // intersect if ray shot through the top/bottom planes if (locRayStart.X > hTop) or (locRayStart.X < hBottom) then Exit; tPlaneMin := -1E99; tPlaneMax := 1E99; end else begin invRayVector1 := cOne / locRayVector.Y; tr2 := Sqr(Radius); // compute intersection with topPlane t := (hTop - locRayStart.Y) * invRayVector1; if (t > 0) and (cyTop in Parts) then begin ip.X := locRayStart.X + t * locRayVector.X; ip.Z := locRayStart.Z + t * locRayVector.Z; if Sqr(ip.X) + Sqr(ip.Z) <= tr2 then begin // intersect with top plane if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(VectorMake(ip.X, hTop, ip.Z, 1)); if Assigned(intersectNormal) then intersectNormal^ := LocalToAbsolute(YHmgVector); Result := true; end; end; tPlaneMin := t; tPlaneMax := t; // compute intersection with bottomPlane t := (hBottom - locRayStart.Y) * invRayVector1; if (t > 0) and (cyBottom in Parts) then begin ip.X := locRayStart.X + t * locRayVector.X; ip.Z := locRayStart.Z + t * locRayVector.Z; if (t < tPlaneMin) or (not(cyTop in Parts)) then begin if Sqr(ip.X) + Sqr(ip.Z) <= tr2 then begin // intersect with top plane if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(VectorMake(ip.X, hBottom, ip.Z, 1)); if Assigned(intersectNormal) then intersectNormal^ := LocalToAbsolute(VectorNegate(YHmgVector)); Result := true; end; end; end; if t < tPlaneMin then tPlaneMin := t; if t > tPlaneMax then tPlaneMax := t; end; if cySides in Parts then begin // intersect against cylinder infinite cylinder poly[0] := Sqr(locRayStart.X) + Sqr(locRayStart.Z) - Sqr(Radius); poly[1] := 2 * (locRayStart.X * locRayVector.X + locRayStart.Z * locRayVector.Z); poly[2] := Sqr(locRayVector.X) + Sqr(locRayVector.Z); roots := SolveQuadric(@poly); if MinPositiveCoef(roots, minRoot) then begin t := minRoot; if (t >= tPlaneMin) and (t < tPlaneMax) then begin if Assigned(intersectPoint) or Assigned(intersectNormal) then begin ip := VectorCombine(locRayStart, locRayVector, 1, t); if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(ip); if Assigned(intersectNormal) then begin ip.Y := 0; ip.W := 0; intersectNormal^ := LocalToAbsolute(ip); end; end; Result := true; end; end; end else SetLength(roots, 0); end; procedure TGLCapsule.Align(const startPoint, endPoint: TGLVector); var dir: TAffineVector; begin AbsolutePosition := startPoint; VectorSubtract(endPoint, startPoint, dir); if Parent <> nil then dir := Parent.AbsoluteToLocal(dir); Up.AsAffineVector := dir; FHeight := VectorLength(dir); Lift(FHeight * 0.5); Alignment := caCenter; end; procedure TGLCapsule.Align(const startObj, endObj: TGLBaseSceneObject); begin Align(startObj.AbsolutePosition, endObj.AbsolutePosition); end; procedure TGLCapsule.Align(const startPoint, endPoint: TAffineVector); begin Align(PointMake(startPoint), PointMake(endPoint)); end; // ------------------ // ------------------ TGLAnnulus ------------------ // ------------------ constructor TGLAnnulus.Create(AOwner: TComponent); begin inherited Create(AOwner); FBottomInnerRadius := 0.3; FTopInnerRadius := 0.3; FTopRadius := 0.5; FParts := [anInnerSides, anOuterSides, anBottom, anTop]; end; procedure TGLAnnulus.SetBottomInnerRadius(const aValue: Single); begin if aValue <> FBottomInnerRadius then begin FBottomInnerRadius := aValue; StructureChanged; end; end; procedure TGLAnnulus.SetTopRadius(const aValue: Single); begin if aValue <> FTopRadius then begin FTopRadius := aValue; StructureChanged; end; end; procedure TGLAnnulus.SetTopInnerRadius(const aValue: Single); begin if aValue <> FTopInnerRadius then begin FTopInnerRadius := aValue; StructureChanged; end; end; procedure TGLAnnulus.SetParts(aValue: TGLAnnulusParts); begin if aValue <> FParts then begin FParts := aValue; StructureChanged; end; end; procedure TGLAnnulus.BuildList(var rci: TGLRenderContextInfo); var quadric: PGLUquadricObj; begin gl.PushMatrix; quadric := gluNewQuadric; SetupQuadricParams(quadric); gl.Rotatef(-90, 1, 0, 0); gl.Translatef(0, 0, -FHeight * 0.5); if anOuterSides in FParts then gluCylinder(quadric, FBottomRadius, FTopRadius, FHeight, FSlices, FStacks); if anTop in FParts then begin gl.PushMatrix; gl.Translatef(0, 0, FHeight); gluDisk(quadric, FTopInnerRadius, FTopRadius, FSlices, FLoops); gl.PopMatrix; end; if [anBottom, anInnerSides] * FParts <> [] then begin // swap quadric orientation because top of a disk is defined as outside SetInvertedQuadricOrientation(quadric); if anBottom in FParts then gluDisk(quadric, FBottomInnerRadius, FBottomRadius, FSlices, FLoops); if anInnerSides in FParts then gluCylinder(quadric, FBottomInnerRadius, FTopInnerRadius, FHeight, FSlices, FStacks); end; gluDeleteQuadric(quadric); gl.PopMatrix; end; procedure TGLAnnulus.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TGLAnnulus) then begin FParts := TGLAnnulus(Source).FParts; FTopRadius := TGLAnnulus(Source).FTopRadius; FTopInnerRadius := TGLAnnulus(Source).FTopInnerRadius; FBottomRadius := TGLAnnulus(Source).FBottomRadius; FBottomInnerRadius := TGLAnnulus(Source).FBottomInnerRadius; end; inherited Assign(Source); end; function TGLAnnulus.AxisAlignedDimensionsUnscaled: TGLVector; var r, r1: Single; begin r := Abs(FBottomRadius); r1 := Abs(FTopRadius); if r1 > r then r := r1; Result := VectorMake(r, 0.5 * FHeight, r); end; function TGLAnnulus.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint, intersectNormal: PGLVector): Boolean; const cOne: Single = 1; var locRayStart, locRayVector, ip: TGLVector; poly: array [0 .. 2] of Double; t, tr2, invRayVector1: Single; tPlaneMin, tPlaneMax: Single; tir2, d2: Single; Root: Double; roots, tmpRoots: TDoubleArray; FirstIntersected: Boolean; h1, h2, hTop, hBot: Single; Draw1, Draw2: Boolean; begin Result := False; FirstIntersected := False; SetLength(tmpRoots, 0); locRayStart := AbsoluteToLocal(rayStart); locRayVector := AbsoluteToLocal(rayVector); hTop := Height * 0.5; hBot := -hTop; if locRayVector.Y < 0 then begin // Sort the planes according to the direction of view h1 := hTop; // Height of the 1st plane h2 := hBot; // Height of the 2nd plane Draw1 := (anTop in Parts); // 1st "cap" Must be drawn? Draw2 := (anBottom in Parts); end else begin h1 := hBot; h2 := hTop; Draw1 := (anBottom in Parts); Draw2 := (anTop in Parts); end; // if if locRayVector.Y = 0 then begin // intersect if ray shot through the top/bottom planes if (locRayStart.X > hTop) or (locRayStart.X < hBot) then Exit; tPlaneMin := -1E99; tPlaneMax := 1E99; end else begin invRayVector1 := cOne / locRayVector.Y; tr2 := Sqr(TopRadius); tir2 := Sqr(TopInnerRadius); FirstIntersected := False; // compute intersection with first plane t := (h1 - locRayStart.Y) * invRayVector1; if (t > 0) and Draw1 then begin ip.X := locRayStart.X + t * locRayVector.X; ip.Z := locRayStart.Z + t * locRayVector.Z; d2 := Sqr(ip.X) + Sqr(ip.Z); if (d2 <= tr2) and (d2 >= tir2) then begin // intersect with top plane FirstIntersected := true; if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(VectorMake(ip.X, h1, ip.Z, 1)); if Assigned(intersectNormal) then intersectNormal^ := LocalToAbsolute(YHmgVector); Result := true; end; end; tPlaneMin := t; tPlaneMax := t; // compute intersection with second plane t := (h2 - locRayStart.Y) * invRayVector1; if (t > 0) and Draw2 then begin ip.X := locRayStart.X + t * locRayVector.X; ip.Z := locRayStart.Z + t * locRayVector.Z; d2 := Sqr(ip.X) + Sqr(ip.Z); if (t < tPlaneMin) or (not FirstIntersected) then begin if (d2 <= tr2) and (d2 >= tir2) then begin // intersect with top plane if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(VectorMake(ip.X, h2, ip.Z, 1)); if Assigned(intersectNormal) then intersectNormal^ := LocalToAbsolute(VectorNegate(YHmgVector)); Result := true; end; end; end; if t < tPlaneMin then begin tPlaneMin := t; end; // if if t > tPlaneMax then tPlaneMax := t; end; try SetLength(roots, 4); roots[0] := -1; roots[1] := -1; roots[2] := -1; roots[3] := -1; // By default, side is behind rayStart // Compute roots for outer cylinder if anOuterSides in Parts then begin // intersect against infinite cylinder, will be cut by tPlaneMine and tPlaneMax poly[0] := Sqr(locRayStart.X) + Sqr(locRayStart.Z) - Sqr(TopRadius); poly[1] := 2 * (locRayStart.X * locRayVector.X + locRayStart.Z * locRayVector.Z); poly[2] := Sqr(locRayVector.X) + Sqr(locRayVector.Z); tmpRoots := SolveQuadric(@poly); // Intersect coordinates on rayVector (rayStart=0) if ( High(tmpRoots) >= 0) and // Does root exist? ((tmpRoots[0] > tPlaneMin) and not FirstIntersected) and // In the annulus and not masked by first cap ((tmpRoots[0] < tPlaneMax)) { // In the annulus } then roots[0] := tmpRoots[0]; if ( High(tmpRoots) >= 1) and ((tmpRoots[1] > tPlaneMin) and not FirstIntersected) and ((tmpRoots[1] < tPlaneMax)) then roots[1] := tmpRoots[1]; end; // if // Compute roots for inner cylinder if anInnerSides in Parts then begin // intersect against infinite cylinder poly[0] := Sqr(locRayStart.X) + Sqr(locRayStart.Z) - Sqr(TopInnerRadius); poly[1] := 2 * (locRayStart.X * locRayVector.X + locRayStart.Z * locRayVector.Z); poly[2] := Sqr(locRayVector.X) + Sqr(locRayVector.Z); tmpRoots := SolveQuadric(@poly); if ( High(tmpRoots) >= 0) and ((tmpRoots[0] > tPlaneMin) and not FirstIntersected) and ((tmpRoots[0] < tPlaneMax)) then roots[2] := tmpRoots[0]; if ( High(tmpRoots) >= 1) and ((tmpRoots[1] > tPlaneMin) and not FirstIntersected) and ((tmpRoots[1] < tPlaneMax)) then roots[3] := tmpRoots[1]; end; // if // Find the first intersection point and compute its coordinates and normal if MinPositiveCoef(roots, Root) then begin t := Root; if (t >= tPlaneMin) and (t < tPlaneMax) then begin if Assigned(intersectPoint) or Assigned(intersectNormal) then begin ip := VectorCombine(locRayStart, locRayVector, 1, t); if Assigned(intersectPoint) then intersectPoint^ := LocalToAbsolute(ip); if Assigned(intersectNormal) then begin ip.Y := 0; ip.W := 0; intersectNormal^ := LocalToAbsolute(ip); end; end; Result := true; end; end; finally roots := nil; tmpRoots := nil; end; // finally end; // ------------------ // ------------------ TGLTorus ------------------ // ------------------ constructor TGLTorus.Create(AOwner: TComponent); begin inherited Create(AOwner); FRings := 25; FSides := 15; FMinorRadius := 0.1; FMajorRadius := 0.4; FStartAngle := 0.0; FStopAngle := 360.0; FParts := [toSides, toStartDisk, toStopDisk]; end; procedure TGLTorus.BuildList(var rci: TGLRenderContextInfo); procedure EmitVertex(ptr: PGLVertexRec; L1, L2: integer); begin XGL.TexCoord2fv(@ptr^.TexCoord); begin gl.Normal3fv(@ptr^.Normal); if L1 > -1 then gl.VertexAttrib3fv(L1, @ptr.Tangent); if L2 > -1 then gl.VertexAttrib3fv(L2, @ptr.Binormal); gl.Vertex3fv(@ptr^.Position); end; end; var i, j: integer; Theta, Phi, Theta1, cosPhi, sinPhi, dist: Single; cosTheta1, sinTheta1: Single; ringDelta, sideDelta: Single; ringDir: TAffineVector; iFact, jFact: Single; pVertex: PGLVertexRec; TanLoc, BinLoc: Integer; MeshSize: integer; MeshIndex: integer; Vertex: TGLVertexRec; begin if FMesh = nil then begin MeshSize := 0; MeshIndex := 0; if toStartDisk in FParts then MeshSize := MeshSize + 1; if toStopDisk in FParts then MeshSize := MeshSize + 1; if toSides in FParts then MeshSize := MeshSize + Integer(FRings) + 1; SetLength(FMesh, MeshSize); // handle texture generation ringDelta := ((FStopAngle - FStartAngle) / 360) * c2PI / FRings; sideDelta := c2PI / FSides; iFact := 1 / FRings; jFact := 1 / FSides; if toSides in FParts then begin Theta := DegToRadian(FStartAngle) - ringDelta; for i := FRings downto 0 do begin SetLength(FMesh[i], FSides + 1); Theta1 := Theta + ringDelta; SinCosine(Theta1, sinTheta1, cosTheta1); Phi := 0; for j := FSides downto 0 do begin Phi := Phi + sideDelta; SinCosine(Phi, sinPhi, cosPhi); dist := FMajorRadius + FMinorRadius * cosPhi; FMesh[i][j].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, FMinorRadius * sinPhi); ringDir := FMesh[i][j].Position; ringDir.Z := 0.0; NormalizeVector(ringDir); FMesh[i][j].Normal := Vector3fMake(cosTheta1 * cosPhi, -sinTheta1 * cosPhi, sinPhi); FMesh[i][j].Tangent := VectorCrossProduct(ZVector, ringDir); FMesh[i][j].Binormal := VectorCrossProduct(FMesh[i][j].Normal, FMesh[i][j].Tangent); FMesh[i][j].TexCoord := Vector2fMake(i * iFact, j * jFact); end; Theta := Theta1; end; MeshIndex := FRings + 1; end; if toStartDisk in FParts then begin SetLength(FMesh[MeshIndex], FSides + 1); Theta1 := DegToRadian(FStartAngle); SinCosine(Theta1, sinTheta1, cosTheta1); if toSides in FParts then begin for j := FSides downto 0 do begin FMesh[MeshIndex][j].Position := FMesh[MeshIndex - 1][j].Position; FMesh[MeshIndex][j].Normal := FMesh[MeshIndex - 1][j].Tangent; FMesh[MeshIndex][j].Tangent := FMesh[MeshIndex - 1][j].Position; FMesh[MeshIndex][j].Tangent.Z := 0; FMesh[MeshIndex][j].Binormal := ZVector; FMesh[MeshIndex][j].TexCoord := FMesh[MeshIndex - 1][j].TexCoord; FMesh[MeshIndex][j].TexCoord.X := 0; end; end else begin Phi := 0; for j := FSides downto 0 do begin Phi := Phi + sideDelta; SinCosine(Phi, sinPhi, cosPhi); dist := FMajorRadius + FMinorRadius * cosPhi; FMesh[MeshIndex][j].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, FMinorRadius * sinPhi); ringDir := FMesh[MeshIndex][j].Position; ringDir.Z := 0.0; NormalizeVector(ringDir); FMesh[MeshIndex][j].Normal := VectorCrossProduct(ZVector, ringDir); FMesh[MeshIndex][j].Tangent := ringDir; FMesh[MeshIndex][j].Binormal := ZVector; FMesh[MeshIndex][j].TexCoord := Vector2fMake(0, j * jFact); end; end; Vertex.Position := Vector3fMake(cosTheta1 * FMajorRadius, -sinTheta1 * FMajorRadius, 0); Vertex.Normal := FMesh[MeshIndex][0].Normal; Vertex.Tangent := FMesh[MeshIndex][0].Tangent; Vertex.Binormal := FMesh[MeshIndex][0].Binormal; Vertex.TexCoord := Vector2fMake(1, 1); MeshIndex := MeshIndex + 1; end; if toStopDisk in FParts then begin SetLength(FMesh[MeshIndex], FSides + 1); Theta1 := DegToRadian(FStopAngle); SinCosine(Theta1, sinTheta1, cosTheta1); if toSides in FParts then begin for j := FSides downto 0 do begin FMesh[MeshIndex][j].Position := FMesh[0][j].Position; FMesh[MeshIndex][j].Normal := VectorNegate(FMesh[0][j].Tangent); FMesh[MeshIndex][j].Tangent := FMesh[0][j].Position; FMesh[MeshIndex][j].Tangent.Z := 0; FMesh[MeshIndex][j].Binormal := VectorNegate(ZVector); FMesh[MeshIndex][j].TexCoord := FMesh[0][j].TexCoord; FMesh[MeshIndex][j].TexCoord.X := 1; end; end else begin Phi := 0; for j := FSides downto 0 do begin Phi := Phi + sideDelta; SinCosine(Phi, sinPhi, cosPhi); dist := FMajorRadius + FMinorRadius * cosPhi; FMesh[MeshIndex][j].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, FMinorRadius * sinPhi); ringDir := FMesh[MeshIndex][j].Position; ringDir.Z := 0.0; NormalizeVector(ringDir); FMesh[MeshIndex][j].Normal := VectorCrossProduct(ringDir, ZVector); FMesh[MeshIndex][j].Tangent := ringDir; FMesh[MeshIndex][j].Binormal := VectorNegate(ZVector); FMesh[MeshIndex][j].TexCoord := Vector2fMake(1, j * jFact); end; end; Vertex.Position := Vector3fMake(cosTheta1 * FMajorRadius, -sinTheta1 * FMajorRadius, 0); Vertex.Normal := FMesh[MeshIndex][0].Normal; Vertex.Tangent := FMesh[MeshIndex][0].Tangent; Vertex.Binormal := FMesh[MeshIndex][0].Binormal; Vertex.TexCoord := Vector2fMake(0, 0); end; end; begin if GL.ARB_shader_objects and (rci.GLStates.CurrentProgram > 0) then begin TanLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(TangentAttributeName)); BinLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(BinormalAttributeName)); end else begin TanLoc := -1; BinLoc := TanLoc; end; MeshIndex := 0; if toSides in FParts then begin gl.Begin_(GL_TRIANGLES); for i := FRings - 1 downto 0 do for j := FSides - 1 downto 0 do begin pVertex := @FMesh[i][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i + 1][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i + 1][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i + 1][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; MeshIndex := FRings + 1; end; if toStartDisk in FParts then begin gl.Begin_(GL_TRIANGLE_FAN); pVertex := @Vertex; EmitVertex(pVertex, TanLoc, BinLoc); for j := 0 to FSides do begin pVertex := @FMesh[MeshIndex][j]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; MeshIndex := MeshIndex + 1; end; if toStopDisk in FParts then begin gl.Begin_(GL_TRIANGLE_FAN); pVertex := @Vertex; EmitVertex(pVertex, TanLoc, BinLoc); for j := FSides downto 0 do begin pVertex := @FMesh[MeshIndex][j]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; end; end; end; procedure TGLTorus.SetMajorRadius(const aValue: Single); begin if FMajorRadius <> aValue then begin FMajorRadius := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLTorus.SetMinorRadius(const aValue: Single); begin if FMinorRadius <> aValue then begin FMinorRadius := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLTorus.SetRings(aValue: Cardinal); begin if FRings <> aValue then begin FRings := aValue; if FRings < 2 then FRings := 2; FMesh := nil; StructureChanged; end; end; procedure TGLTorus.SetSides(aValue: Cardinal); begin if FSides <> aValue then begin FSides := aValue; if FSides < 3 then FSides := 3; FMesh := nil; StructureChanged; end; end; procedure TGLTorus.SetStartAngle(const aValue: Single); begin if FStartAngle <> aValue then begin FStartAngle := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLTorus.SetStopAngle(const aValue: Single); begin if FStopAngle <> aValue then begin FStopAngle := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLTorus.SetParts(aValue: TGLTorusParts); begin if aValue <> FParts then begin FParts := aValue; StructureChanged; end; end; function TGLTorus.AxisAlignedDimensionsUnscaled: TGLVector; var r, r1: Single; begin r := Abs(FMajorRadius); r1 := Abs(FMinorRadius); Result := VectorMake(r + r1, r + r1, r1); // Danb end; function TGLTorus.RayCastIntersect(const rayStart, rayVector: TGLVector; intersectPoint: PGLVector = nil; intersectNormal: PGLVector = nil): Boolean; var i: integer; fRo2, fRi2, fDE, fVal, r, nearest: Double; polynom: array [0 .. 4] of Double; polyRoots: TDoubleArray; localStart, localVector: TGLVector; vi, vc: TGLVector; begin // compute coefficients of quartic polynomial fRo2 := Sqr(MajorRadius); fRi2 := Sqr(MinorRadius); localStart := AbsoluteToLocal(rayStart); localVector := AbsoluteToLocal(rayVector); NormalizeVector(localVector); fDE := VectorDotProduct(localStart, localVector); fVal := VectorNorm(localStart) - (fRo2 + fRi2); polynom[0] := Sqr(fVal) - 4.0 * fRo2 * (fRi2 - Sqr(localStart.Z)); polynom[1] := 4.0 * fDE * fVal + 8.0 * fRo2 * localVector.Z * localStart.Z; polynom[2] := 2.0 * fVal + 4.0 * Sqr(fDE) + 4.0 * fRo2 * Sqr(localVector.Z); polynom[3] := 4.0 * fDE; polynom[4] := 1; // solve the quartic polyRoots := SolveQuartic(@polynom[0]); // search for closest point Result := (Length(polyRoots) > 0); if Result then begin nearest := 1E20; for i := 0 to High(polyRoots) do begin r := polyRoots[i]; if (r > 0) and (r < nearest) then begin nearest := r; Result := true; end; end; vi := VectorCombine(localStart, localVector, 1, nearest); if Assigned(intersectPoint) then SetVector(intersectPoint^, LocalToAbsolute(vi)); if Assigned(intersectNormal) then begin // project vi on local torus plane vc.X := vi.X; vc.Y := vi.Y; vc.Z := 0; // project vc on MajorRadius circle ScaleVector(vc, MajorRadius / (VectorLength(vc) + 0.000001)); // calculate circle to intersect vector (gives normal); SubtractVector(vi, vc); // return to absolute coordinates and normalize vi.W := 0; SetVector(intersectNormal^, LocalToAbsolute(vi)); end; end; end; // ------------------ // ------------------ TGLArrowLine ------------------ // ------------------ constructor TGLArrowLine.Create(AOwner: TComponent); begin inherited; FTopRadius := 0.1; BottomRadius := 0.1; fTopArrowHeadRadius := 0.2; fTopArrowHeadHeight := 0.5; fBottomArrowHeadRadius := 0.2; fBottomArrowHeadHeight := 0.5; FHeadStackingStyle := ahssStacked; (* by default there is not much point having the top of the line (cylinder) showing as it is coincidental with the Toparrowhead bottom. Note I've defaulted to "vector" type arrows (arrow head on top only *) FParts := [alLine, alTopArrow]; end; procedure TGLArrowLine.SetTopRadius(const aValue: Single); begin if aValue <> FTopRadius then begin FTopRadius := aValue; StructureChanged; end; end; procedure TGLArrowLine.SetTopArrowHeadHeight(const aValue: Single); begin if aValue <> fTopArrowHeadHeight then begin fTopArrowHeadHeight := aValue; StructureChanged; end; end; procedure TGLArrowLine.SetTopArrowHeadRadius(const aValue: Single); begin if aValue <> fTopArrowHeadRadius then begin fTopArrowHeadRadius := aValue; StructureChanged; end; end; procedure TGLArrowLine.SetBottomArrowHeadHeight(const aValue: Single); begin if aValue <> fBottomArrowHeadHeight then begin fBottomArrowHeadHeight := aValue; StructureChanged; end; end; procedure TGLArrowLine.SetBottomArrowHeadRadius(const aValue: Single); begin if aValue <> fBottomArrowHeadRadius then begin fBottomArrowHeadRadius := aValue; StructureChanged; end; end; procedure TGLArrowLine.SetParts(aValue: TGLArrowLineParts); begin if aValue <> FParts then begin FParts := aValue; StructureChanged; end; end; procedure TGLArrowLine.SetHeadStackingStyle(const val: TGLArrowHeadStyle); begin if val <> FHeadStackingStyle then begin FHeadStackingStyle := val; StructureChanged; end; end; procedure TGLArrowLine.BuildList(var rci: TGLRenderContextInfo); var quadric: PGLUquadricObj; cylHeight, cylOffset, headInfluence: Single; begin case HeadStackingStyle of ahssCentered: headInfluence := 0.5; ahssIncluded: headInfluence := 1; else // ahssStacked headInfluence := 0; end; cylHeight := Height; cylOffset := -FHeight * 0.5; // create a new quadric quadric := gluNewQuadric; SetupQuadricParams(quadric); // does the top arrow part - the cone if alTopArrow in Parts then begin cylHeight := cylHeight - TopArrowHeadHeight * headInfluence; gl.PushMatrix; gl.Translatef(0, 0, Height * 0.5 - TopArrowHeadHeight * headInfluence); gluCylinder(quadric, fTopArrowHeadRadius, 0, fTopArrowHeadHeight, Slices, Stacks); // top of a disk is defined as outside SetInvertedQuadricOrientation(quadric); if alLine in Parts then gluDisk(quadric, FTopRadius, fTopArrowHeadRadius, Slices, FLoops) else gluDisk(quadric, 0, fTopArrowHeadRadius, Slices, FLoops); gl.PopMatrix; end; // does the bottom arrow part - another cone if alBottomArrow in Parts then begin cylHeight := cylHeight - BottomArrowHeadHeight * headInfluence; cylOffset := cylOffset + BottomArrowHeadHeight * headInfluence; gl.PushMatrix; // make the bottom arrow point in the other direction gl.Rotatef(180, 1, 0, 0); gl.Translatef(0, 0, Height * 0.5 - BottomArrowHeadHeight * headInfluence); SetNormalQuadricOrientation(quadric); gluCylinder(quadric, fBottomArrowHeadRadius, 0, fBottomArrowHeadHeight, Slices, Stacks); // top of a disk is defined as outside SetInvertedQuadricOrientation(quadric); if alLine in Parts then gluDisk(quadric, FBottomRadius, fBottomArrowHeadRadius, Slices, FLoops) else gluDisk(quadric, 0, fBottomArrowHeadRadius, Slices, FLoops); gl.PopMatrix; end; // does the cylinder that makes the line if (cylHeight > 0) and (alLine in Parts) then begin gl.PushMatrix; gl.Translatef(0, 0, cylOffset); SetNormalQuadricOrientation(quadric); gluCylinder(quadric, FBottomRadius, FTopRadius, cylHeight, FSlices, FStacks); if not(alTopArrow in Parts) then begin gl.PushMatrix; gl.Translatef(0, 0, cylHeight); gluDisk(quadric, 0, FTopRadius, FSlices, FLoops); gl.PopMatrix; end; if not(alBottomArrow in Parts) then begin // swap quadric orientation because top of a disk is defined as outside SetInvertedQuadricOrientation(quadric); gluDisk(quadric, 0, FBottomRadius, FSlices, FLoops); end; gl.PopMatrix; end; gluDeleteQuadric(quadric); end; procedure TGLArrowLine.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TGLArrowLine) then begin FParts := TGLArrowLine(Source).FParts; FTopRadius := TGLArrowLine(Source).FTopRadius; fTopArrowHeadHeight := TGLArrowLine(Source).fTopArrowHeadHeight; fTopArrowHeadRadius := TGLArrowLine(Source).fTopArrowHeadRadius; fBottomArrowHeadHeight := TGLArrowLine(Source).fBottomArrowHeadHeight; fBottomArrowHeadRadius := TGLArrowLine(Source).fBottomArrowHeadRadius; FHeadStackingStyle := TGLArrowLine(Source).FHeadStackingStyle; end; inherited Assign(Source); end; // ------------------ // ------------------ TGLArrowArc ------------------ // ------------------ constructor TGLArrowArc.Create(AOwner: TComponent); begin inherited; FStacks := 16; fArcRadius := 0.5; FStartAngle := 0; FStopAngle := 360; FTopRadius := 0.1; BottomRadius := 0.1; fTopArrowHeadRadius := 0.2; fTopArrowHeadHeight := 0.5; fBottomArrowHeadRadius := 0.2; fBottomArrowHeadHeight := 0.5; FHeadStackingStyle := ahssStacked; FParts := [aaArc, aaTopArrow]; end; procedure TGLArrowArc.SetArcRadius(const aValue: Single); begin if fArcRadius <> aValue then begin fArcRadius := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.SetStartAngle(const aValue: Single); begin if FStartAngle <> aValue then begin FStartAngle := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.SetStopAngle(const aValue: Single); begin if FStopAngle <> aValue then begin FStopAngle := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.SetTopRadius(const aValue: Single); begin if aValue <> FTopRadius then begin FTopRadius := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.SetTopArrowHeadHeight(const aValue: Single); begin if aValue <> fTopArrowHeadHeight then begin fTopArrowHeadHeight := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.SetTopArrowHeadRadius(const aValue: Single); begin if aValue <> fTopArrowHeadRadius then begin fTopArrowHeadRadius := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.SetBottomArrowHeadHeight(const aValue: Single); begin if aValue <> fBottomArrowHeadHeight then begin fBottomArrowHeadHeight := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.SetBottomArrowHeadRadius(const aValue: Single); begin if aValue <> fBottomArrowHeadRadius then begin fBottomArrowHeadRadius := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.SetParts(aValue: TGLArrowArcParts); begin if aValue <> FParts then begin FParts := aValue; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.SetHeadStackingStyle(const val: TGLArrowHeadStyle); begin if val <> FHeadStackingStyle then begin FHeadStackingStyle := val; FMesh := nil; StructureChanged; end; end; procedure TGLArrowArc.BuildList(var rci: TGLRenderContextInfo); procedure EmitVertex(ptr: PGLVertexRec; L1, L2: integer); begin XGL.TexCoord2fv(@ptr^.TexCoord); gl.Normal3fv(@ptr^.Normal); if L1 > -1 then gl.VertexAttrib3fv(L1, @ptr.Tangent); if L2 > -1 then gl.VertexAttrib3fv(L2, @ptr.Binormal); gl.Vertex3fv(@ptr^.Position); end; var i, j: integer; Theta, Phi, Theta1, cosPhi, sinPhi, dist: Single; cosTheta1, sinTheta1: Single; ringDelta, sideDelta: Single; ringDir: TAffineVector; iFact, jFact: Single; pVertex: PGLVertexRec; TanLoc, BinLoc: Integer; MeshSize: integer; MeshIndex: integer; ConeCenter: TGLVertexRec; StartOffset, StopOffset: Single; begin if FMesh = nil then begin MeshIndex := 0; MeshSize := 0; // Check Parts if aaArc in FParts then MeshSize := MeshSize + FStacks + 1; if aaTopArrow in FParts then MeshSize := MeshSize + 3 else MeshSize := MeshSize + 1; if aaBottomArrow in FParts then MeshSize := MeshSize + 3 else MeshSize := MeshSize + 1; // Allocate Mesh SetLength(FMesh, MeshSize); case FHeadStackingStyle of ahssStacked: begin StartOffset := 0; StopOffset := 0; end; ahssCentered: begin if aaBottomArrow in Parts then StartOffset := RadToDeg(ArcTan(0.5 * fBottomArrowHeadHeight / fArcRadius)) else StartOffset :=0; if aaTopArrow in Parts then StopOffset := RadToDeg(ArcTan(0.5 * fTopArrowHeadHeight / fArcRadius)) else StopOffset :=0; end ; ahssIncluded: begin if aaBottomArrow in Parts then StartOffset := RadToDeg(ArcTan(fBottomArrowHeadHeight / fArcRadius)) else StartOffset :=0; if aaTopArrow in Parts then StopOffset := RadToDeg(ArcTan(fTopArrowHeadHeight / fArcRadius)) else StopOffset :=0; end ; else StartOffset := 0; StopOffset := 0; end; // handle texture generation ringDelta := (((FStopAngle - StopOffset) - (FStartAngle + StartOffset)) / 360) * c2PI / FStacks; sideDelta := c2PI / FSlices; iFact := 1 / FStacks; jFact := 1 / FSlices; if aaArc in FParts then begin Theta := DegToRadian(FStartAngle + StartOffset) - ringDelta; for i := FStacks downto 0 do begin SetLength(FMesh[i], FSlices + 1); Theta1 := Theta + ringDelta; SinCosine(Theta1, sinTheta1, cosTheta1); Phi := 0; for j := FSlices downto 0 do begin Phi := Phi + sideDelta; SinCosine(Phi, sinPhi, cosPhi); dist := fArcRadius + Lerp(FTopRadius, FBottomRadius, i * iFact) * cosPhi; FMesh[i][j].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, Lerp(FTopRadius, FBottomRadius, i * iFact) * sinPhi); ringDir := FMesh[i][j].Position; ringDir.Z := 0.0; NormalizeVector(ringDir); FMesh[i][j].Normal := Vector3fMake(cosTheta1 * cosPhi, -sinTheta1 * cosPhi, sinPhi); FMesh[i][j].Tangent := VectorCrossProduct(ZVector, ringDir); FMesh[i][j].Binormal := VectorCrossProduct(FMesh[i][j].Normal, FMesh[i][j].Tangent); FMesh[i][j].TexCoord := Vector2fMake(i * iFact, j * jFact); end; Theta := Theta1; end; MeshIndex := FStacks + 1; begin if GL.ARB_shader_objects and (rci.GLStates.CurrentProgram > 0) then begin TanLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(TangentAttributeName)); BinLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(BinormalAttributeName)); end else begin TanLoc := -1; BinLoc := TanLoc; end; gl.Begin_(GL_TRIANGLES); for i := FStacks - 1 downto 0 do for j := FSlices - 1 downto 0 do begin pVertex := @FMesh[i][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i + 1][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i + 1][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i + 1][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[i][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; end; end; // Build Arrow or start cap if aaBottomArrow in FParts then begin SetLength(FMesh[MeshIndex], FSlices + 1); SetLength(FMesh[MeshIndex + 1], FSlices + 1); SetLength(FMesh[MeshIndex + 2], FSlices + 1); Theta1 := DegToRadian(FStartAngle + StartOffset); SinCosine(Theta1, sinTheta1, cosTheta1); ConeCenter.Position := Vector3fMake(cosTheta1 * fArcRadius, -sinTheta1 * fArcRadius, 0); Phi := 0; for j := FSlices downto 0 do begin Phi := Phi + sideDelta; SinCosine(Phi, sinPhi, cosPhi); dist := fArcRadius + fBottomArrowHeadRadius * cosPhi; // Cap FMesh[MeshIndex][J].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, fBottomArrowHeadRadius * sinPhi); ringDir := FMesh[MeshIndex][j].Position; ringDir.Z := 0.0; NormalizeVector(ringDir); FMesh[MeshIndex][j].Normal := VectorCrossProduct(ringDir, ZVector); FMesh[MeshIndex][j].Tangent := ringDir; FMesh[MeshIndex][j].Binormal := ZVector; FMesh[MeshIndex][j].TexCoord := Vector2fMake(1, j * jFact); // Cone FMesh[MeshIndex+1][j].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, fBottomArrowHeadRadius * sinPhi); FMesh[MeshIndex+2][j].Position := VectorAdd(ConeCenter.Position, Vector3fMake(sinTheta1 * fBottomArrowHeadHeight, cosTheta1 * fBottomArrowHeadHeight, 0)); FMesh[MeshIndex + 1][j].Tangent := VectorNormalize(VectorSubtract(FMesh[MeshIndex + 1][j].Position, FMesh[MeshIndex + 2][j].Position)); FMesh[MeshIndex + 2][j].Tangent := FMesh[MeshIndex + 1][j].Tangent; FMesh[MeshIndex + 1][j].Binormal := Vector3fMake(cosTheta1 * -sinPhi, sinTheta1 * sinPhi, cosPhi); FMesh[MeshIndex + 2][j].Binormal := FMesh[MeshIndex + 1][j].Binormal; FMesh[MeshIndex + 1][j].Normal := VectorCrossProduct(FMesh[MeshIndex + 1][j].Binormal, FMesh[MeshIndex + 1][j].Tangent); FMesh[MeshIndex + 2][j].Normal := FMesh[MeshIndex + 1][j].Normal; FMesh[MeshIndex + 1][j].TexCoord := Vector2fMake(0, j * jFact); FMesh[MeshIndex + 2][j].TexCoord := Vector2fMake(1, j * jFact); end; ConeCenter.Normal := FMesh[MeshIndex][0].Normal; ConeCenter.Tangent := FMesh[MeshIndex][0].Tangent; ConeCenter.Binormal := FMesh[MeshIndex][0].Binormal; ConeCenter.TexCoord := Vector2fMake(0, 0); begin if GL.ARB_shader_objects and (rci.GLStates.CurrentProgram > 0) then begin TanLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(TangentAttributeName)); BinLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(BinormalAttributeName)); end else begin TanLoc := -1; BinLoc := TanLoc; end; gl.Begin_(GL_TRIANGLE_FAN); pVertex := @ConeCenter; EmitVertex(pVertex, TanLoc, BinLoc); for j := FSlices downto 0 do begin pVertex := @FMesh[MeshIndex][j]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; gl.Begin_(GL_TRIANGLES); for j := FSlices - 1 downto 0 do begin pVertex := @FMesh[MeshIndex + 1][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 1][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 2][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 2][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 2][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 1][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; end; MeshIndex := MeshIndex + 3; end else begin SetLength(FMesh[MeshIndex], FSlices + 1); Theta1 := DegToRadian(FStartAngle); SinCosine(Theta1, sinTheta1, cosTheta1); Phi := 0; for j := FSlices downto 0 do begin Phi := Phi + sideDelta; SinCosine(Phi, sinPhi, cosPhi); dist := fArcRadius + fBottomRadius * cosPhi; FMesh[MeshIndex][j].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, FBottomRadius * sinPhi); ringDir := FMesh[MeshIndex][j].Position; ringDir.Z := 0.0; NormalizeVector(ringDir); FMesh[MeshIndex][j].Normal := VectorCrossProduct(ZVector, ringDir); FMesh[MeshIndex][j].Tangent := ringDir; FMesh[MeshIndex][j].Binormal := ZVector; FMesh[MeshIndex][j].TexCoord := Vector2fMake(0, j * jFact); end; ConeCenter.Position := Vector3fMake(cosTheta1 * fArcRadius, -sinTheta1 * fArcRadius, 0); ConeCenter.Normal := FMesh[MeshIndex][0].Normal; ConeCenter.Tangent := FMesh[MeshIndex][0].Tangent; ConeCenter.Binormal := FMesh[MeshIndex][0].Binormal; ConeCenter.TexCoord := Vector2fMake(1, 1); begin if GL.ARB_shader_objects and (rci.GLStates.CurrentProgram > 0) then begin TanLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(TangentAttributeName)); BinLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(BinormalAttributeName)); end else begin TanLoc := -1; BinLoc := TanLoc; end; gl.Begin_(GL_TRIANGLE_FAN); pVertex := @ConeCenter; EmitVertex(pVertex, TanLoc, BinLoc); for j := 0 to FSlices do begin pVertex := @FMesh[MeshIndex][j]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; end; MeshIndex := MeshIndex + 1; end; if aaTopArrow in FParts then begin SetLength(FMesh[MeshIndex], FSlices + 1); SetLength(FMesh[MeshIndex + 1], FSlices + 1); SetLength(FMesh[MeshIndex + 2], FSlices + 1); Theta1 := DegToRadian(FStopAngle - StopOffset); SinCosine(Theta1, sinTheta1, cosTheta1); ConeCenter.Position := Vector3fMake(cosTheta1 * fArcRadius, -sinTheta1 * fArcRadius, 0); Phi := 0; for j := FSlices downto 0 do begin Phi := Phi + sideDelta; SinCosine(Phi, sinPhi, cosPhi); dist := fArcRadius + fTopArrowHeadRadius * cosPhi; // Cap FMesh[MeshIndex][j].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, fTopArrowHeadRadius * sinPhi); ringDir := FMesh[MeshIndex][j].Position; ringDir.Z := 0.0; NormalizeVector(ringDir); FMesh[MeshIndex][j].Normal := VectorCrossProduct(ZVector, ringDir); FMesh[MeshIndex][j].Tangent := ringDir; FMesh[MeshIndex][j].Binormal := ZVector; FMesh[MeshIndex][j].TexCoord := Vector2fMake(0, j * jFact); // Cone FMesh[MeshIndex + 1][j].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, fTopArrowHeadRadius * sinPhi); FMesh[MeshIndex + 2][j].Position := VectorSubtract(ConeCenter.Position, Vector3fMake(sinTheta1 * fTopArrowHeadHeight, cosTheta1 * fTopArrowHeadHeight, 0)); FMesh[MeshIndex + 1][j].Tangent := VectorNormalize(VectorSubtract(FMesh[MeshIndex + 2][j].Position, FMesh[MeshIndex + 1][j].Position)); FMesh[MeshIndex + 2][j].Tangent := FMesh[MeshIndex + 1][j].Tangent; FMesh[MeshIndex + 1][j].Binormal := Vector3fMake(cosTheta1 * -sinPhi, sinTheta1 * sinPhi, cosPhi); FMesh[MeshIndex + 2][j].Binormal := FMesh[MeshIndex + 1][j].Binormal; FMesh[MeshIndex + 1][j].Normal := VectorCrossProduct(FMesh[MeshIndex + 1][j].Binormal, FMesh[MeshIndex + 1][j].Tangent); FMesh[MeshIndex + 2][j].Normal := FMesh[MeshIndex + 1][j].Normal; FMesh[MeshIndex + 1][j].TexCoord := Vector2fMake(1, j * jFact); FMesh[MeshIndex + 2][j].TexCoord := Vector2fMake(0, j * jFact); end; ConeCenter.Normal := FMesh[MeshIndex][0].Normal; ConeCenter.Tangent := FMesh[MeshIndex][0].Tangent; ConeCenter.Binormal := FMesh[MeshIndex][0].Binormal; ConeCenter.TexCoord := Vector2fMake(1, 1); begin if GL.ARB_shader_objects and (rci.GLStates.CurrentProgram > 0) then begin TanLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(TangentAttributeName)); BinLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(BinormalAttributeName)); end else begin TanLoc := -1; BinLoc := TanLoc; end; gl.Begin_(GL_TRIANGLE_FAN); pVertex := @ConeCenter; EmitVertex(pVertex, TanLoc, BinLoc); for j := 0 to FSlices do begin pVertex := @FMesh[MeshIndex][j]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; gl.Begin_(GL_TRIANGLES); for j := FSlices - 1 downto 0 do begin pVertex := @FMesh[MeshIndex + 2][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 2][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 1][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 1][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 1][j]; EmitVertex(pVertex, TanLoc, BinLoc); pVertex := @FMesh[MeshIndex + 2][j + 1]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; end; end else begin SetLength(FMesh[MeshIndex], FSlices + 1); Theta1 := DegToRadian(FStopAngle); SinCosine(Theta1, sinTheta1, cosTheta1); Phi := 0; for j := FSlices downto 0 do begin Phi := Phi + sideDelta; SinCosine(Phi, sinPhi, cosPhi); dist := fArcRadius + fTopRadius * cosPhi; FMesh[MeshIndex][j].Position := Vector3fMake(cosTheta1 * dist, -sinTheta1 * dist, fTopRadius * sinPhi); ringDir := FMesh[MeshIndex][j].Position; ringDir.Z := 0.0; NormalizeVector(ringDir); FMesh[MeshIndex][j].Normal := VectorCrossProduct(ringDir, ZVector); FMesh[MeshIndex][j].Tangent := ringDir; FMesh[MeshIndex][j].Binormal := VectorNegate(ZVector); FMesh[MeshIndex][j].TexCoord := Vector2fMake(1, j * jFact); end; ConeCenter.Position := Vector3fMake(cosTheta1 * fArcRadius, -sinTheta1 * fArcRadius, 0); ConeCenter.Normal := FMesh[MeshIndex][0].Normal; ConeCenter.Tangent := FMesh[MeshIndex][0].Tangent; ConeCenter.Binormal := FMesh[MeshIndex][0].Binormal; ConeCenter.TexCoord := Vector2fMake(0, 0); begin if GL.ARB_shader_objects and (rci.GLStates.CurrentProgram > 0) then begin TanLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(TangentAttributeName)); BinLoc := gl.GetAttribLocation(rci.GLStates.CurrentProgram, PAnsiChar(BinormalAttributeName)); end else begin TanLoc := -1; BinLoc := TanLoc; end; gl.Begin_(GL_TRIANGLE_FAN); pVertex := @ConeCenter; EmitVertex(pVertex, TanLoc, BinLoc); for j := FSlices downto 0 do begin pVertex := @FMesh[MeshIndex][j]; EmitVertex(pVertex, TanLoc, BinLoc); end; gl.End_; end; end; end; end; procedure TGLArrowArc.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TGLArrowLine) then begin FStartAngle := TGLArrowArc(Source).FStartAngle; FStopAngle := TGLArrowArc(Source).FStopAngle; fArcRadius := TGLArrowArc(Source).fArcRadius; FParts := TGLArrowArc(Source).FParts; FTopRadius := TGLArrowArc(Source).FTopRadius; fTopArrowHeadHeight := TGLArrowArc(Source).fTopArrowHeadHeight; fTopArrowHeadRadius := TGLArrowArc(Source).fTopArrowHeadRadius; fBottomArrowHeadHeight := TGLArrowArc(Source).fBottomArrowHeadHeight; fBottomArrowHeadRadius := TGLArrowArc(Source).fBottomArrowHeadRadius; FHeadStackingStyle := TGLArrowArc(Source).FHeadStackingStyle; end; inherited Assign(Source); end; // ------------------ // ------------------ TGLFrustrum ------------------ // ------------------ constructor TGLFrustrum.Create(AOwner: TComponent); begin inherited Create(AOwner); FApexHeight := 1; FBaseWidth := 1; FBaseDepth := 1; FHeight := 0.5; FParts := cAllFrustrumParts; FNormalDirection := ndOutside; end; procedure TGLFrustrum.BuildList(var rci: TGLRenderContextInfo); var HBW, HBD: Single; // half of width, half of depth at base HTW, HTD: Single; // half of width, half of depth at top of frustrum HFH: Single; // half of height, for align to center Sign: Single; // +1 or -1 angle: Single; // in radians ASin, ACos: Single; begin if FNormalDirection = ndInside then Sign := -1 else Sign := 1; HBW := FBaseWidth * 0.5; HBD := FBaseDepth * 0.5; HTW := HBW * (FApexHeight - FHeight) / FApexHeight; HTD := HBD * (FApexHeight - FHeight) / FApexHeight; HFH := FHeight * 0.5; gl.Begin_(GL_QUADS); if [fpFront, fpBack] * FParts <> [] then begin angle := ArcTan(FApexHeight / HBD); // angle of front plane with bottom plane SinCosine(angle, ASin, ACos); if fpFront in FParts then begin gl.Normal3f(0, Sign * ACos, Sign * ASin); XGL.TexCoord2fv(@XYTexPoint); gl.Vertex3f(HTW, HFH, HTD); XGL.TexCoord2fv(@YTexPoint); gl.Vertex3f(-HTW, HFH, HTD); XGL.TexCoord2fv(@NullTexPoint); gl.Vertex3f(-HBW, -HFH, HBD); XGL.TexCoord2fv(@XTexPoint); gl.Vertex3f(HBW, -HFH, HBD); end; if fpBack in FParts then begin gl.Normal3f(0, Sign * ACos, -Sign * ASin); XGL.TexCoord2fv(@YTexPoint); gl.Vertex3f(HTW, HFH, -HTD); XGL.TexCoord2fv(@NullTexPoint); gl.Vertex3f(HBW, -HFH, -HBD); XGL.TexCoord2fv(@XTexPoint); gl.Vertex3f(-HBW, -HFH, -HBD); XGL.TexCoord2fv(@XYTexPoint); gl.Vertex3f(-HTW, HFH, -HTD); end; end; if [fpLeft, fpRight] * FParts <> [] then begin angle := ArcTan(FApexHeight / HBW); // angle of side plane with bottom plane SinCosine(angle, ASin, ACos); if fpLeft in FParts then begin gl.Normal3f(-Sign * ASin, Sign * ACos, 0); XGL.TexCoord2fv(@XYTexPoint); gl.Vertex3f(-HTW, HFH, HTD); XGL.TexCoord2fv(@YTexPoint); gl.Vertex3f(-HTW, HFH, -HTD); XGL.TexCoord2fv(@NullTexPoint); gl.Vertex3f(-HBW, -HFH, -HBD); XGL.TexCoord2fv(@XTexPoint); gl.Vertex3f(-HBW, -HFH, HBD); end; if fpRight in FParts then begin gl.Normal3f(Sign * ASin, Sign * ACos, 0); XGL.TexCoord2fv(@YTexPoint); gl.Vertex3f(HTW, HFH, HTD); XGL.TexCoord2fv(@NullTexPoint); gl.Vertex3f(HBW, -HFH, HBD); XGL.TexCoord2fv(@XTexPoint); gl.Vertex3f(HBW, -HFH, -HBD); XGL.TexCoord2fv(@XYTexPoint); gl.Vertex3f(HTW, HFH, -HTD); end; end; if (fpTop in FParts) and (FHeight < FApexHeight) then begin gl.Normal3f(0, Sign, 0); XGL.TexCoord2fv(@YTexPoint); gl.Vertex3f(-HTW, HFH, -HTD); XGL.TexCoord2fv(@NullTexPoint); gl.Vertex3f(-HTW, HFH, HTD); XGL.TexCoord2fv(@XTexPoint); gl.Vertex3f(HTW, HFH, HTD); XGL.TexCoord2fv(@XYTexPoint); gl.Vertex3f(HTW, HFH, -HTD); end; if fpBottom in FParts then begin gl.Normal3f(0, -Sign, 0); XGL.TexCoord2fv(@NullTexPoint); gl.Vertex3f(-HBW, -HFH, -HBD); XGL.TexCoord2fv(@XTexPoint); gl.Vertex3f(HBW, -HFH, -HBD); XGL.TexCoord2fv(@XYTexPoint); gl.Vertex3f(HBW, -HFH, HBD); XGL.TexCoord2fv(@YTexPoint); gl.Vertex3f(-HBW, -HFH, HBD); end; gl.End_; end; procedure TGLFrustrum.SetApexHeight(const aValue: Single); begin if (aValue <> FApexHeight) and (aValue >= 0) then begin FApexHeight := aValue; if FHeight > aValue then FHeight := aValue; StructureChanged; end; end; procedure TGLFrustrum.SetBaseDepth(const aValue: Single); begin if (aValue <> FBaseDepth) and (aValue >= 0) then begin FBaseDepth := aValue; StructureChanged; end; end; procedure TGLFrustrum.SetBaseWidth(const aValue: Single); begin if (aValue <> FBaseWidth) and (aValue >= 0) then begin FBaseWidth := aValue; StructureChanged; end; end; procedure TGLFrustrum.SetHeight(const aValue: Single); begin if (aValue <> FHeight) and (aValue >= 0) then begin FHeight := aValue; if FApexHeight < aValue then FApexHeight := aValue; StructureChanged; end; end; procedure TGLFrustrum.SetParts(aValue: TGLFrustrumParts); begin if aValue <> FParts then begin FParts := aValue; StructureChanged; end; end; procedure TGLFrustrum.SetNormalDirection(aValue: TGLNormalDirection); begin if aValue <> FNormalDirection then begin FNormalDirection := aValue; StructureChanged; end; end; procedure TGLFrustrum.Assign(Source: TPersistent); begin if Assigned(Source) and (Source is TGLFrustrum) then begin FApexHeight := TGLFrustrum(Source).FApexHeight; FBaseDepth := TGLFrustrum(Source).FBaseDepth; FBaseWidth := TGLFrustrum(Source).FBaseWidth; FHeight := TGLFrustrum(Source).FHeight; FParts := TGLFrustrum(Source).FParts; FNormalDirection := TGLFrustrum(Source).FNormalDirection; end; inherited Assign(Source); end; function TGLFrustrum.TopDepth: Single; begin Result := FBaseDepth * (FApexHeight - FHeight) / FApexHeight; end; function TGLFrustrum.TopWidth: Single; begin Result := FBaseWidth * (FApexHeight - FHeight) / FApexHeight; end; procedure TGLFrustrum.DefineProperties(Filer: TFiler); begin inherited; Filer.DefineBinaryProperty('FrustrumSize', ReadData, WriteData, (FApexHeight <> 1) or (FBaseDepth <> 1) or (FBaseWidth <> 1) or (FHeight <> 0.5)); end; procedure TGLFrustrum.ReadData(Stream: TStream); begin with Stream do begin Read(FApexHeight, SizeOf(FApexHeight)); Read(FBaseDepth, SizeOf(FBaseDepth)); Read(FBaseWidth, SizeOf(FBaseWidth)); Read(FHeight, SizeOf(FHeight)); end; end; procedure TGLFrustrum.WriteData(Stream: TStream); begin with Stream do begin Write(FApexHeight, SizeOf(FApexHeight)); Write(FBaseDepth, SizeOf(FBaseDepth)); Write(FBaseWidth, SizeOf(FBaseWidth)); Write(FHeight, SizeOf(FHeight)); end; end; function TGLFrustrum.AxisAlignedBoundingBoxUnscaled: TAABB; var aabb: TAABB; child: TGLBaseSceneObject; i: integer; begin SetAABB(Result, AxisAlignedDimensionsUnscaled); OffsetAABB(Result, VectorMake(0, FHeight * 0.5, 0)); // not tested for child objects for i := 0 to Count - 1 do begin child := TGLBaseSceneObject(Children[i]); aabb := child.AxisAlignedBoundingBoxUnscaled; AABBTransform(aabb, child.Matrix^); AddAABB(Result, aabb); end; end; function TGLFrustrum.AxisAlignedDimensionsUnscaled: TGLVector; begin Result.X := FBaseWidth * 0.5; Result.Y := FHeight * 0.5; Result.Z := FBaseDepth * 0.5; Result.W := 0; end; // ------------------ // ------------------ TGLPolygon ------------------ // ------------------ constructor TGLPolygon.Create(AOwner: TComponent); begin inherited Create(AOwner); FParts := [ppTop, ppBottom]; end; destructor TGLPolygon.Destroy; begin inherited Destroy; end; procedure TGLPolygon.SetParts(const val: TGLPolygonParts); begin if FParts <> val then begin FParts := val; StructureChanged; end; end; procedure TGLPolygon.Assign(Source: TPersistent); begin if Source is TGLPolygon then begin FParts := TGLPolygon(Source).FParts; end; inherited Assign(Source); end; procedure TGLPolygon.BuildList(var rci: TGLRenderContextInfo); var Normal: TAffineVector; pNorm: PAffineVector; begin if (Nodes.Count > 1) then begin Normal := Nodes.Normal; if VectorIsNull(Normal) then pNorm := nil else pNorm := @Normal; if ppTop in FParts then begin if SplineMode = lsmLines then Nodes.RenderTesselatedPolygon(true, pNorm, 1) else Nodes.RenderTesselatedPolygon(true, pNorm, Division); end; // tessellate bottom polygon if ppBottom in FParts then begin if Assigned(pNorm) then NegateVector(Normal); if SplineMode = lsmLines then Nodes.RenderTesselatedPolygon(true, pNorm, 1, true) else Nodes.RenderTesselatedPolygon(true, pNorm, Division, true); end; end; end; //------------------------------------------------------------- // ------------------ // ------------------ TGLTeapot ------------------ // ------------------ constructor TGLTeapot.Create(AOwner: TComponent); begin inherited Create(AOwner); FGrid := 5; end; function TGLTeapot.AxisAlignedDimensionsUnscaled: TGLVector; begin SetVector(Result, 0.55, 0.25, 0.35); end; procedure TGLTeapot.BuildList(var rci: TGLRenderContextInfo); const PatchData: array[0..9, 0..15] of Integer = ((102, 103, 104, 105, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15), // rim (12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27), // body (24, 25, 26, 27, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40), // body (96, 96, 96, 96, 97, 98, 99, 100, 101, 101, 101, 101, 0, 1, 2, 3), // lid (0, 1, 2, 3, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117), // lid (118, 118, 118, 118, 124, 122, 119, 121, 123, 126, 125, 120, 40, 39, 38, 37), // bottom (41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56), // handle (53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 28, 65, 66, 67), // handle (68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83), // spout (80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95)); // spout CPData: array[0..126, 0..2] of Single = ((0.2, 0, 2.7), (0.2, -0.112, 2.7), (0.112, -0.2, 2.7), (0, -0.2, 2.7), (1.3375, 0, 2.53125), (1.3375, -0.749, 2.53125), (0.749, -1.3375, 2.53125), (0, -1.3375, 2.53125), (1.4375, 0, 2.53125), (1.4375, -0.805, 2.53125), (0.805, -1.4375, 2.53125), (0, -1.4375, 2.53125), (1.5, 0, 2.4), (1.5, -0.84, 2.4), (0.84, -1.5, 2.4), (0, -1.5, 2.4), (1.75, 0, 1.875), (1.75, -0.98, 1.875), (0.98, -1.75, 1.875), (0, -1.75, 1.875), (2, 0, 1.35), (2, -1.12, 1.35), (1.12, -2, 1.35), (0, -2, 1.35), (2, 0, 0.9), (2, -1.12, 0.9), (1.12, -2, 0.9), (0, -2, 0.9), (-2, 0, 0.9), (2, 0, 0.45), (2, -1.12, 0.45), (1.12, -2, 0.45), (0, -2, 0.45), (1.5, 0, 0.225), (1.5, -0.84, 0.225), (0.84, -1.5, 0.225), (0, -1.5, 0.225), (1.5, 0, 0.15), (1.5, -0.84, 0.15), (0.84, -1.5, 0.15), (0, -1.5, 0.15), (-1.6, 0, 2.025), (-1.6, -0.3, 2.025), (-1.5, -0.3, 2.25), (-1.5, 0, 2.25), (-2.3, 0, 2.025), (-2.3, -0.3, 2.025), (-2.5, -0.3, 2.25), (-2.5, 0, 2.25), (-2.7, 0, 2.025), (-2.7, -0.3, 2.025), (-3, -0.3, 2.25), (-3, 0, 2.25), (-2.7, 0, 1.8), (-2.7, -0.3, 1.8), (-3, -0.3, 1.8), (-3, 0, 1.8), (-2.7, 0, 1.575), (-2.7, -0.3, 1.575), (-3, -0.3, 1.35), (-3, 0, 1.35), (-2.5, 0, 1.125), (-2.5, -0.3, 1.125), (-2.65, -0.3, 0.9375), (-2.65, 0, 0.9375), (-2, -0.3, 0.9), (-1.9, -0.3, 0.6), (-1.9, 0, 0.6), (1.7, 0, 1.425), (1.7, -0.66, 1.425), (1.7, -0.66, 0.6), (1.7, 0, 0.6), (2.6, 0, 1.425), (2.6, -0.66, 1.425), (3.1, -0.66, 0.825), (3.1, 0, 0.825), (2.3, 0, 2.1), (2.3, -0.25, 2.1), (2.4, -0.25, 2.025), (2.4, 0, 2.025), (2.7, 0, 2.4), (2.7, -0.25, 2.4), (3.3, -0.25, 2.4), (3.3, 0, 2.4), (2.8, 0, 2.475), (2.8, -0.25, 2.475), (3.525, -0.25, 2.49375), (3.525, 0, 2.49375), (2.9, 0, 2.475), (2.9, -0.15, 2.475), (3.45, -0.15, 2.5125), (3.45, 0, 2.5125), (2.8, 0, 2.4), (2.8, -0.15, 2.4), (3.2, 0.15, 2.4), (3.2, 0, 2.4), (0, 0, 3.15), (0.8, 0, 3.15), (0.8, -0.45, 3.15), (0.45, -0.8, 3.15), (0, -0.8, 3.15), (0, 0, 2.85), (1.4, 0, 2.4), (1.4, -0.784, 2.4), (0.784, -1.4, 2.4), (0, -1.4, 2.4), (0.4, 0, 2.55), (0.4, -0.224, 2.55), (0.224, -0.4, 2.55), (0, -0.4, 2.55), (1.3, 0, 2.55), (1.3, -0.728, 2.55), (0.728, -1.3, 2.55), (0, -1.3, 2.55), (1.3, 0, 2.4), (1.3, -0.728, 2.4), (0.728, -1.3, 2.4), (0, -1.3, 2.4), (0, 0, 0), (1.425, -0.798, 0), (1.5, 0, 0.075), (1.425, 0, 0), (0.798, -1.425, 0), (0, -1.5, 0.075), (0, -1.425, 0), (1.5, -0.84, 0.075), (0.84, -1.5, 0.075)); Tex: array[0..1, 0..1, 0..1] of Single = (((0, 0), (1, 0)), ((0, 1), (1, 1))); var P, Q, R, S: array[0..3, 0..3, 0..2] of Single; I, J, K, L, GRD: Integer; begin if FGrid < 2 then FGrid := 2; GRD := FGrid; rci.GLStates.InvertGLFrontFace; gl.Enable(GL_AUTO_NORMAL); gl.Enable(GL_MAP2_VERTEX_3); gl.Enable(GL_MAP2_TEXTURE_COORD_2); for I := 0 to 9 do begin for J := 0 to 3 do begin for K := 0 to 3 do begin for L := 0 to 2 do begin P[J, K, L] := CPData[PatchData[I, J * 4 + K], L]; Q[J, K, L] := CPData[PatchData[I, J * 4 + (3 - K)], L]; if L = 1 then Q[J, K, L] := -Q[J, K, L]; if I < 6 then begin R[J, K, L] := CPData[PatchData[I, J * 4 + (3 - K)], L]; if L = 0 then R[J, K, L] := -R[J, K, L]; S[J, K, L] := CPData[PatchData[I, J * 4 + K], L]; if L < 2 then S[J, K, L] := -S[J, K, L]; end; end; end; end; gl.MapGrid2f(GRD, 0, 1, GRD, 0, 1); gl.Map2f(GL_MAP2_TEXTURE_COORD_2, 0, 1, 2, 2, 0, 1, 4, 2, @Tex[0, 0, 0]); gl.Map2f(GL_MAP2_VERTEX_3, 0, 1, 3, 4, 0, 1, 12, 4, @P[0, 0, 0]); gl.EvalMesh2(GL_FILL, 0, GRD, 0, GRD); gl.Map2f(GL_MAP2_VERTEX_3, 0, 1, 3, 4, 0, 1, 12, 4, @Q[0, 0, 0]); gl.EvalMesh2(GL_FILL, 0, GRD, 0, GRD); if I < 6 then begin gl.Map2f(GL_MAP2_VERTEX_3, 0, 1, 3, 4, 0, 1, 12, 4, @R[0, 0, 0]); gl.EvalMesh2(GL_FILL, 0, GRD, 0, GRD); gl.Map2f(GL_MAP2_VERTEX_3, 0, 1, 3, 4, 0, 1, 12, 4, @S[0, 0, 0]); gl.EvalMesh2(GL_FILL, 0, GRD, 0, GRD); end; end; gl.Disable(GL_AUTO_NORMAL); gl.Disable(GL_MAP2_VERTEX_3); gl.Disable(GL_MAP2_TEXTURE_COORD_2); rci.GLStates.InvertGLFrontFace; end; procedure TGLTeapot.DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); const M: TGLMatrix = ( X:(X:0.150000005960464; Y:0; Z:0; W:0); Y:(X:0; Y:-6.55670850946422e-09; Z:-0.150000005960464; W:0); Z:(X:0; Y:0.150000005960464; Z:-6.55670850946422e-09; W:0); W:(X:0; Y:1.63917712736605e-09; Z:0.0375000014901161; W:1)); begin // start rendering self if ARenderSelf then begin with ARci.PipelineTransformation do SetModelMatrix(MatrixMultiply(M, ModelMatrix^)); if ARci.ignoreMaterials then if (osDirectDraw in ObjectStyle) or ARci.amalgamating then BuildList(ARci) else ARci.GLStates.CallList(GetHandle(ARci)) else begin Material.Apply(ARci); repeat if (osDirectDraw in ObjectStyle) or ARci.amalgamating then BuildList(ARci) else ARci.GLStates.CallList(GetHandle(ARci)); until not Material.UnApply(ARci); end; end; // start rendering children (if any) if ARenderChildren then Self.RenderChildren(0, Count - 1, ARci); end; // ------------------------------------------------------------- initialization // ------------------------------------------------------------- RegisterClasses([TGLDodecahedron, TGLIcosahedron, TGLHexahedron, TGLOctahedron, TGLTetrahedron]); RegisterClasses([TGLCylinder, TGLCone, TGLTorus, TGLDisk, TGLArrowLine, TGLAnnulus, TGLFrustrum, TGLPolygon, TGLCapsule, TGLArrowArc, TGLTeapot]); end.