Making a Pipe with bend feature using Delphi Firemonkey

The cross-platform Firemonkey framework of Delphi introduced 3D support which is based on both OpenGL and DirectX.  Although it’s not as rich as GLScene (an open source Delphi 3D Components Library), for me it is a better way to deal with 3D if you are making a business application. Because it is simpler and has got a more traceable code path to review. I have used GLScene in some of my previous projects but I liked Firemonkey 3D more. Maybe this is about I am not a game programmer and only use 3D for CAD and business applications but if I would write a game application I would again prefer Firemonkey 3D instead of GLScene VCL. Anyway, if you also like Firemonkey 3D as me, you also have a problem. Firemonkey doesn’t have enough components to make a high level 3D applications. But who cares? You have a lot of ways to make your own 3D components, and I am sure in near feature there will be a lot of programmers who will publish rich components for Firemonkey on their blogs. In one of my projects I needed a pipe object, which includes an inner cylinder, and outer cylinder and two annulus on top and bottom. I could use standard cylinder object but it would not be enough for me. First reason for this was, the top and bottom would remain as circles but I needed annulus shape, secondly when I want to modify the meshes I would need my own mesh math. So I decided to make a brand new TPipe (and also TAnnulus) object, which you can also modify it with bend, twist and emboss modifiers. I liked what I have at the end, I don’t say it is the best pipe mesh on the net,  but I am sure you will not have a better one until near feature.

What is a Pipe?

A pipe in geometry is a real-world shape like cylinder. An absolute cylinder shape has not got a thickness, if you put a thinner cylinder inside a thicker one, you will simply get a pipe with thickness of radius difference. As you may have thought this object will have got special top/bottom closes. It will not be a circular disk but it will be a an annulus shape.

Annulus Geometry. Source: Wikipedia

So a pipe is in fact an extrude of an annulus. It seems there is an easy way to have a pipe in Firemonkey. Make an annulus shaped polygon, and extrude it with proper calls.  Is that easy?

How to make a Pipe in Firemonkey.

The answer is no. It is not as easy as extruding an annulus because you can’t modify the vertices of an extruded shape. For example if you want to bend your pipe to a specific angle, then you should modify the vertices. So in Firemonkey the best approach is using a meshed object which the TCube, TCylinder, etc. also use. Firemonkey has got a TCustomMesh class which you can inherit any new meshed object. Building meshes is very easy if you know the math behind it. So in my TAnnulus and TPipe I have used the TCustomMesh class as the base class, rebuild the mesh according to my own geometry and Firemonkey has done the rest.

The pipe is laid through the Y axis. So the Width and Depth defines the a,b diameters of the elliptical annulus (it is a circular when Width and Depth is equal).  The Height value defines the length of the cylindrical side on Y axis. The inner circle (or ellipse) is calculated from Width and Depth parameters using the Thickness property.

Having a Rectangular Shape

A pipe is a cylinder-like object so an annulus is circle-like one. But why don’t we try to think the overall shape as rectangular. The math is not so different so I also added the rectangular shape to my annulus and pipe.You can define if the inner, outer or both frames as rectangular or elliptical.

Having a Section On Pipe

Sometimes we may need to see the inside of a pipe by making angular sections on it. I have handled this case by adding a section feature in my pipe. You can define the section in any magnitude using the SectionAngle property and you can locate the section on top or bottom side using the SectionType property. (sctNone, sctTop, sctBottom). The section is on X,Y plane.

The Pipe Modifiers

A pipe modifier is a specific class (TPipeModifier) which takes the circular (or rectangular) X,Z sections of the pipe a TPointLayer, and modifies them according to its own math. For instance if you want to make a thicker emboss on a specific place of pipe, then the modifier will scale the layers. If you want to bend the modifier will rotate the layers. All modifying is based on the X,Z section layers. A pipe modifier will need a start position and an end position. All positions are based on 0, which means the bottom start of the pipe, on its local Y = -Height/2. The modifiers also have got a Subdivisions property. Using this property the modification density will be arranged.

The Bend Modifier

This TBendModifier class is used to bend the pipe starting on a specific position to a specific position using a specific angle and subdivisions. If the total length of the bend (EndPosition – StartPosition) is bigger the bend radius will be bigger. The bend is arranged with BendAngle. When following the / axis for bottom to top, a positive bend will mean a left side bend, while a negative bend will mean a right side bend. If you want the bend move also on Z axis you should use the TurnAngle property.

Bend Figure 1

In the above figure (1)  the pipe has a length value 8. The bend starts on 1.0 and ends on 2.5. The bend angle is 90 degrees so it is on the left. In the below figure (2) a second bend is added on the position 2.5. It ends on the position 4.It’s angle is -90, so it is a turn to right.

Bend Figure 2

Now if you want to turn the bend on Z axis we will use the TurnAngle property. In the figure below (3) the first bend has got an extra TurnAngle value of 90 with its 90 degrees bend angle, and the second is same.

The Emboss Modifier

Using the emboss modifier, you can make any part of the pipe bigger or smaller. Starting from the StartPosition and ending on EndPosition the section of the pipe is scaled with the thickness ratio of the modifier. The thickness ration is 0.1 by default. To make a smaller section use a negative value. The margins are 0.02 by default, but if you want softer ends you can use a little bigger value like 0.1 or 0.2.

The Twist Modifier

This a bonus modifier. 🙂 ) . Normally it is not a commonly used effect in business applications but you can use it to see what you can do with modifiers.

For downloading the full source code of the demo project with the FMX.MeshObjects unit which includes the TAnnulus, TPipe and modifiers, you can use this SVN link. For non-programmers the compiled Win32, Win64, MacOSX (Thanks to Firemonkey) applications are also available to download.

7 thoughts on “Making a Pipe with bend feature using Delphi Firemonkey

  1. Roberto Loppi

    Very very good, but i have very big problems to make my CAD in Firemonkey !!!!
    UV mapping don’t work like OpenGL, in TMesh->Data->VertexBuffer->TexCoord0[ works only with values between 0 and 1 othervise don’t make the correct ripetition of the texture, why ??? It’s a very big problem !!

    Reply
  2. Rick Wheeler

    This is a great tutorials, but unfortunately does not compile for Delphi XE5. Can you update the sources?
    Also, is there any tutorials around for creating custom meshes? There seems to be no TCustomMesh samples around and I’ve got no idea where to get started.
    Great work!

    Reply
  3. Simon Farmer

    I agree UV mapping doesn’t seem to work as expected. I would also like to know how to fix this?

    Reply
  4. Rick Wheeler

    Hello, I really like to get this working in Delphi XE5. I think it is only small changes required, but I cannot figure it out. Can you please help? I’d be happy to pay for your time.
    Rick.

    Reply
  5. Rick Wheeler
    Hello. Uwe Raabe has kindly updated these sources for the latest Delphi Seattle compatibility. His modifications can be viewed here: .gist table { margin-bottom: 0; } This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters Show hidden characters unit FMX.MeshObjects; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, System.RTLConsts, System.Math, System.Math.Vectors, System.UIConsts, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Controls3D, FMX.Types3D, FMX.Objects3D, FMX.Layers3D, FMX.Objects, FMX.Menus, FMX.Edit, FMX.Colors, FMX.MaterialSources, System.StrUtils, System.Generics.Collections, FMX.Ani, FMX.Materials, System.Generics.Defaults; Type TSectionType = (sctNone, sctTop, sctBottom); TFrameType = (ftEllipse, ftRectangle); TPointArray = array of TPoint3d; TDummyPointLayer = class; TPointLayer = class(TObject) private FParent: TPointLayer; FChild: TPointLayer; FContent: TPointLayer; FPosition: TPosition3d; FLocalMatrix: TMatrix3D; FRotationAngle: TPosition3d; FQuaternion: TQuaternion3D; FScale: TPosition3d; FSavedAbsoluteMatrix: TMatrix3D; FAbsMatrixNeedRefresh: Boolean; FGapLayer: Boolean; function GetLength: Integer; procedure SetPointsLength(const Value: Integer); Procedure MatrixChanged(Sender: TObject); procedure RotationChanged(Sender: TObject); virtual; function GetAbsoluteMatrix: TMatrix3D; function GetRealParent: TPointLayer; function GetRealChild: TPointLayer; function GetLayerCount: Integer; function GetFirstParent: TPointLayer; function GetDummyChild: TPointLayer; function GeAbsoluteCenter: TPoint3d; function GetLayerH: Single; protected Procedure CreateDummies; virtual; public Points: TPointArray; Constructor Create; Destructor Destroy; override; Function CreateChildAtPosition(CPos: TPoint3d; RepeatNbr: Integer): TPointLayer; Procedure AddChild(CPointLayer: TPointLayer); Function LastChild: TPointLayer; Function RemoveFirstChild: TPointLayer; Function Index: Integer; Function GetLayer(LIndex: Integer): TPointLayer; Function AbsPoint(i: Integer): TPoint3d; Function GetTotalTurn: Single; Function Content: TPointLayer; Procedure InvalidateAbsoluteMatrix; Property FirstParent: TPointLayer read GetFirstParent; Property RealParent: TPointLayer read GetRealParent; Property RealChild: TPointLayer read GetRealChild; Property DummyChild: TPointLayer read GetDummyChild; Property Length: Integer read GetLength write SetPointsLength; Property Position: TPosition3d read FPosition write FPosition; property AbsoluteMatrix: TMatrix3D read GetAbsoluteMatrix; property LocalMatrix: TMatrix3D read FLocalMatrix; Property AbsoluteCenter: TPoint3d read GeAbsoluteCenter; Property LayerH: Single read GetLayerH; Property GapLayer: Boolean read FGapLayer write FGapLayer; property RotationAngle: TPosition3d read FRotationAngle write FRotationAngle; property Scale: TPosition3d read FScale write FScale; Property LayerCount: Integer read GetLayerCount; end; TDummyPointLayer = class(TPointLayer) protected Procedure CreateDummies; override; end; TLayerList = TList<TPointLayer>; TAnnulus = class(TCustomMesh) private FSectionType: TSectionType; FSectionDegree: Integer; FInnerFrameType: TFrameType; FOuterFrameType: TFrameType; FDrawBounds: Boolean; procedure SetThickness(const Value: Single); procedure SetSubdivisionsAxes(const Value: Integer); procedure SetSectionDegree(const Value: Integer); procedure SetSectionType(const Value: TSectionType); procedure setInnerFrameType(const Value: TFrameType); procedure setOuterFrameType(const Value: TFrameType); procedure SetDrawBounds(const Value: Boolean); protected FSubdivisionsAxes: Integer; FUnitWidth: Single; FUnitHeight: Single; FThickness: Single; FRenderScale: Single; FStartAngle: Single; FTotalAngle: Single; FDistAngle: Single; InnerPoints: TPointArray; OuterPoints: TPointArray; function ExtendPointToPlane(point, Plane, PlaneNormal: TPoint3D; var Distance: Single; var nPoint: TPoint3d): Boolean; Procedure CalcPoints; virtual; Procedure GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); virtual; procedure BuildAnnulus(IPoints, OPoints: TPointArray; Back: Boolean); virtual; procedure RebuildMesh; virtual; procedure Render; override; function FixHeight: Boolean; virtual; procedure SetHeight(const Value: Single); override; procedure SetWidth(const Value: Single); override; procedure SetDepth(const Value: Single); override; public constructor Create(AOwner: TComponent); override; property Data; Property Thickness: Single read FThickness write SetThickness; Property SubdivisionsAxes: Integer read FSubdivisionsAxes write SetSubdivisionsAxes; Property SectionType: TSectionType read FSectionType write SetSectionType; Property SectionDegree: Integer read FSectionDegree write SetSectionDegree; Property InnerFrameType: TFrameType read FInnerFrameType write setInnerFrameType; Property OuterFrameType: TFrameType read FOuterFrameType write setOuterFrameType; Property RenderScale: Single read FRenderScale; Property DrawBounds: Boolean read FDrawBounds write SetDrawBounds; end; TPipe = class; TPipeModifier = class(TFMXObject) private FPipe: TPipe; FStartPosition: Single; FEndPosition: Single; FSubdivisions: Integer; FUseGap: Boolean; FFirstCenter: TPoint3d; FLastCenter: TPoint3d; FModifyMargins: Boolean; procedure SetStartPosition(const Value: Single); procedure SetEndPosition(const Value: Single); procedure SetSubdivisions(const Value: Integer); function InsertPointLayer(StartLayer: TPointLayer; LayerH: Single; UseGap: Boolean = False): TPointLayer; procedure SetModifyMargins(const Value: Boolean); protected FStartMargin: Single; FEndMargin: Single; FLayerCount: Integer; StartLayer, EndLayer, StartMLayer, EndMLayer: TPointLayer; Procedure BeginModify(StartPoints: TPointLayer); virtual; public Constructor Create(aPipe: TPipe); virtual; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); virtual; abstract; Procedure DoModify(StartPoints: TPointLayer); virtual; Procedure EndModify; virtual; published Property StartPosition: Single read FStartPosition write SetStartPosition; Property EndPosition: Single read FEndPosition write SetEndPosition; Property Subdivisions: Integer read FSubdivisions write SetSubdivisions; Property UseGap: Boolean read FUseGap write FUseGap; Property FirstCenter: TPoint3d read FFirstCenter; Property LastCenter: TPoint3d read FLastCenter; Property ModifyMargins: Boolean read FModifyMargins write SetModifyMargins; end; TBendModifier = class(TPipeModifier) private FBendAngle: Single; FTurnAngle: Single; procedure SetBendAngle(const Value: Single); procedure SetTurnAngle(const Value: Single); public Constructor Create(aPipe: TPipe); override; Destructor Destroy; override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; published Property BendAngle: Single read FBendAngle write SetBendAngle; Property TurnAngle: Single read FTurnAngle write SetTurnAngle; end; TBreakModifier = class(TBendModifier) private procedure SetEndMargin(const Value: Single); procedure SetStartMargin(const Value: Single); public Constructor Create(aPipe: TPipe); override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; Property StartMargin: Single read FStartMargin write SetStartMargin; Property EndMargin: Single read FEndMargin write SetEndMargin; end; TTwistModifier = class(TPipeModifier) private FTotalRotation: Single; procedure SetTotalRotation(const Value: Single); public Constructor Create(aPipe: TPipe); override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; published Property TotalRotation: Single read FTotalRotation write SetTotalRotation; end; TEmbossModifier = class(TPipeModifier) private FThicknessRatio: Single; procedure SetThicknessRatio(const Value: Single); public Constructor Create(aPipe: TPipe); override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; Property ThicknessRatio: Single read FThicknessRatio write SetThicknessRatio; end; TPipe = class(TAnnulus) private FModifiers: TList<TPipeModifier>; FOnZAxis: Boolean; FFirstCenter: TPoint3d; FLastCenter: TPoint3d; FScaleBeforeRender: Boolean; Procedure SortModifiers; procedure SetOnZAxis(const Value: Boolean); procedure SetScaleBeforeRender(const Value: Boolean); protected function FixHeight: Boolean; override; procedure SetHeight(const Value: Single); override; Procedure GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); override; procedure BuildSectionSurfaces(OuterSectionPoints, InnerSectionPoints: TPointArray); virtual; procedure BuildCylinder(Points: TPointArray; Back: Boolean; var SectionPoints, FirstPoints, LastPoints: TPointArray); virtual; procedure RebuildMesh; override; Procedure Render; override; Procedure ModifiersNotify(Sender: TObject; Const Item: TPipeModifier; Action: TCollectionNotification); public constructor Create(AOwner: TComponent); override; Procedure ClearModifiers; destructor Destroy; override; Property Modifiers: TList<TPipeModifier> read FModifiers; Property OnZAxis: Boolean read FOnZAxis write SetOnZAxis; Property FirstCenter: TPoint3d Read FFirstCenter; Property LastCenter: TPoint3d read FLastCenter; Property ScaleBeforeRender: Boolean read FScaleBeforeRender write SetScaleBeforeRender; end; procedure Register; implementation procedure Register; begin RegisterComponents('3D Shapes', [TAnnulus, TPipe]); end; { TPipe } procedure TAnnulus.BuildAnnulus(IPoints, OPoints: TPointArray; Back: Boolean); var FData: TMeshData; i: Integer; vertexIdx: Integer; indexIdx: Integer; begin FData := Self.Data; vertexIdx := FData.VertexBuffer.Length; indexIdx := FData.IndexBuffer.Length; FData.VertexBuffer.Length := vertexIdx + FSubdivisionsAxes * 2; for i := 0 to FSubdivisionsAxes – 1 do begin FData.VertexBuffer.Vertices[vertexIdx + i] := IPoints[i]; FData.VertexBuffer.TexCoord0[vertexIdx + i] := Pointf((IPoints[i].X + FUnitWidth / 2) / FUnitWidth, (IPoints[i].Z + FUnitHeight / 2) / FUnitHeight); FData.VertexBuffer.Vertices[vertexIdx + i + FSubdivisionsAxes] := OPoints[i]; FData.VertexBuffer.TexCoord0[vertexIdx + i + FSubdivisionsAxes] := Pointf((OPoints[i].X + FUnitWidth / 2) / FUnitWidth, (OPoints[i].Z + FUnitHeight / 2) / FUnitHeight); end; FData.IndexBuffer.Length := indexIdx + FSubdivisionsAxes * 6; if (FSectionType <> sctNone) then FData.IndexBuffer.Length := FData.IndexBuffer.Length – 6; for i := 0 to FSubdivisionsAxes – 1 do begin if (i = FSubdivisionsAxes – 1) then begin if (FSectionType = sctNone) then begin FData.IndexBuffer.Indices[indexIdx + i * 6 + 0] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + i + FSubdivisionsAxes; if Back then begin FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 0] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + i + FSubdivisionsAxes; end; end; end else begin FData.IndexBuffer.Indices[indexIdx + i * 6] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + i + FSubdivisionsAxes + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + i + FSubdivisionsAxes; if Back then begin FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 0] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + i + FSubdivisionsAxes + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + i + FSubdivisionsAxes; end; end; end; end; procedure TAnnulus.CalcPoints; var PhiSin, PhiCos: Extended; iWidth, iHeight: Single; rThickness: Single; A: Integer; Angle: Single; rPoint: TPoint3d; iPoint: TPoint3d; iDist: Single; uiWidth, uiHeight: Single; begin SetLength(OuterPoints, FSubdivisionsAxes); SetLength(InnerPoints, FSubdivisionsAxes); FUnitWidth := 1; FUnitHeight := 1; if Width > Depth then FUnitWidth := Width / Depth; if Depth > Width then FUnitHeight := Depth / Width; rThickness := FThickness * (FUnitWidth / Width); FRenderScale := Width / FUnitWidth; iWidth := 1; iHeight := 1; if (FThickness * 2 = Depth) or (FThickness * 2 = Width) then FThickness := FThickness – 0.1; if Width > Depth then iWidth := (Width – (FThickness * 2)) / (Depth – (FThickness * 2)); if Depth > Width then iHeight := (Depth – (FThickness * 2)) / (Width – (FThickness * 2)); FStartAngle := 0; FTotalAngle := 360; if FSectionType <> sctNone then FTotalAngle := 360 – FSectionDegree; if FSectionType = sctBottom then FStartAngle := -(180 – FSectionDegree) / 2; if FSectionType = sctTop then FStartAngle := 180 – (180 – FSectionDegree) / 2; FDistAngle := FTotalAngle / FSubdivisionsAxes; if FSectionType <> sctNone then FDistAngle := FTotalAngle / (FSubdivisionsAxes – 1); for A := 0 to FSubdivisionsAxes – 1 do begin Angle := DegToRad(FStartAngle) + DegToRad(FDistAngle) * A; SinCos(Angle, PhiSin, PhiCos); if FOuterFrameType = ftEllipse then begin OuterPoints[A] := Point3D(PhiCos * 0.5 * FUnitWidth, 0, PhiSin * 0.5 * FUnitHeight); end else begin rPoint := Point3D(PhiCos * 0.5 * FUnitWidth, 0, PhiSin * 0.5 * FUnitHeight); iDist := -1; iPoint := rPoint; Self.ExtendPointToPlane(rPoint, Point3D(FUnitWidth / 2, 0, 0), Point3D(-1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3D(0, 0, FUnitHeight / 2), Point3D(0, 0, -1), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3D(-FUnitWidth / 2, 0, 0), Point3D(1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3D(0, 0, -FUnitHeight / 2), Point3D(0, 0, 1), iDist, iPoint); OuterPoints[A] := iPoint; end; if FInnerFrameType = ftEllipse then begin InnerPoints[A] := Point3D(PhiCos * (0.5 – rThickness) * iWidth, 0, PhiSin * (0.5 – rThickness) * iHeight); end else begin rPoint := Point3D(PhiCos * (0.5 – rThickness) * iWidth, 0, PhiSin * (0.5 – rThickness) * iHeight); uiWidth := (0.5 – rThickness) * iWidth; uiHeight := (0.5 – rThickness) * iHeight; iDist := -1; iPoint := rPoint; Self.ExtendPointToPlane(rPoint, Point3d(uiWidth, 0, 0), Point3d(-1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3d(0, 0, uiHeight), Point3d(0, 0, -1), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3d(-uiWidth, 0, 0), Point3d(1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3d(0, 0, -uiHeight), Point3d(0, 0, 1), iDist, iPoint); InnerPoints[A] := iPoint; end; end; end; constructor TAnnulus.Create(AOwner: TComponent); begin inherited; FThickness := 0.2; FSubdivisionsAxes := 180; FSectionType := sctNone; FSectionDegree := 180; FOuterFrameType := ftEllipse; FInnerFrameType := ftEllipse; RebuildMesh; end; function TAnnulus.ExtendPointToPlane(point, Plane, PlaneNormal: TPoint3D; var Distance: Single; var nPoint: TPoint3d): Boolean; var iPoint: TPoint3d; aDist: Single; begin Result := False; if RayCastPlaneIntersect(TPoint3D.Zero, point, Plane, PlaneNormal, iPoint) then begin aDist := Sqrt(iPoint.Distance(TPoint3D.Zero)); if Distance = -1 then begin Distance := aDist; nPoint := iPoint; Result := True; end else if aDist < Distance then begin Distance := aDist; nPoint := iPoint; Result := True; end; end; end; function TAnnulus.FixHeight: Boolean; begin FHeight := 0.001; Result := True; end; procedure TAnnulus.GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); var i: Integer; begin SetLength(IPoints, Length(InnerPoints)); SetLength(OPoints, Length(OuterPoints)); for i := 0 to High(InnerPoints) do begin IPoints[i] := Point3D(InnerPoints[i].X, PosY, InnerPoints[i].Z); OPoints[i] := Point3D(OuterPoints[i].X, PosY, OuterPoints[i].Z); end; end; procedure TAnnulus.RebuildMesh; var IPoints, OPoints: TPointArray; begin CalcPoints; Data.VertexBuffer.Length := 0; Data.IndexBuffer.Length := 0; GetAnnulusPointsForPosY(-0.001, IPoints, OPoints); BuildAnnulus(IPoints, OPoints, True); GetAnnulusPointsForPosY(0.001, IPoints, OPoints); BuildAnnulus(IPoints, OPoints, False); Data.CalcFaceNormals; end; procedure TAnnulus.Render; begin Context.SetMatrix(TMatrix3D.CreateScaling(TPoint3D.Create(FRenderScale, Height, FRenderScale)) * AbsoluteMatrix); Context.DrawTriangles(Data.VertexBuffer, Data.IndexBuffer, TMaterialSource.ValidMaterial(MaterialSource), AbsoluteOpacity); if FDrawBounds then begin Context.SetMatrix(AbsoluteMatrix); Context.DrawCube(TPoint3D.Zero, Point3D(Width, 0, Depth), AbsoluteOpacity, TalphaColors.Red); end; end; procedure TAnnulus.SetDepth(const Value: Single); var FRefresh: Boolean; begin FRefresh := (Self.Depth <> Value); inherited; if FRefresh then RebuildMesh; end; procedure TAnnulus.SetDrawBounds(const Value: Boolean); begin FDrawBounds := Value; Render; end; procedure TAnnulus.SetHeight(const Value: Single); begin if not FixHeight then inherited; end; procedure TAnnulus.setInnerFrameType(const Value: TFrameType); begin FInnerFrameType := Value; RebuildMesh; end; procedure TAnnulus.setOuterFrameType(const Value: TFrameType); begin FOuterFrameType := Value; RebuildMesh; end; procedure TAnnulus.SetSectionDegree(const Value: Integer); begin FSectionDegree := Value; RebuildMesh; end; procedure TAnnulus.SetSectionType(const Value: TSectionType); begin FSectionType := Value; RebuildMesh; end; procedure TAnnulus.SetSubdivisionsAxes(const Value: Integer); begin FSubdivisionsAxes := Value; RebuildMesh; end; procedure TAnnulus.SetThickness(const Value: Single); begin FThickness := Value; RebuildMesh; end; procedure TAnnulus.SetWidth(const Value: Single); var FRefresh: Boolean; begin FRefresh := (Self.Width <> Value); inherited; if FRefresh then RebuildMesh; end; { TPipe } procedure TPipe.BuildCylinder(Points: TPointArray; Back: Boolean; var SectionPoints, FirstPoints, LastPoints: TPointArray); var FData: TMeshData; i, h, k: Integer; vertexIdx, pVertexIdx: Integer; indexIdx: Integer; hDist, hPos: Single; PhiSin, PhiCos: Extended; cntIndexInRow: Integer; cntVertexInRow: Integer; backM: Integer; Angle: Single; StartPoints: TPointLayer; EndPoints: TPointLayer; SubPoints: TPointArray; done: Boolean; PointsLen: Integer; pModifier: TPipeModifier; pLayer: TPointLayer; LayerCount: Integer; AbsStart: TPoint3d; sctIndex: Integer; begin FData := Self.Data; PointsLen := Length(Points); StartPoints := TPointLayer.Create; if FOnZAxis then StartPoints.RotationAngle.Point := Point3D(90, 90, 0); EndPoints := TPointLayer.Create; StartPoints.AddChild(EndPoints); StartPoints.Length := PointsLen; EndPoints.Length := PointsLen; StartPoints.Position.point := TPoint3D.Zero; EndPoints.Position.point := Point3D(0, Height, 0); for i := 0 to High(Points) do begin StartPoints.Points[i] := Point3D(Points[i].X, 0, Points[i].Z); EndPoints.Points[i] := Point3D(Points[i].X, 0, Points[i].Z); end; backM := 1; if Back then backM := -1; for pModifier in FModifiers do begin pModifier.DoModify(StartPoints); end; LayerCount := StartPoints.LayerCount; cntIndexInRow := PointsLen * 6; if FSectionType <> sctNone then begin cntIndexInRow := (PointsLen – 1) * 6; end; if FScaleBeforeRender then begin for i := 0 to LayerCount – 1 do begin pLayer := StartPoints.GetLayer(i); pLayer.Content.Scale.point := Point3D(pLayer.Content.Scale.point.X * FRenderScale, pLayer.Content.Scale.point.Y, pLayer.Content.Scale.point.Z * FRenderScale); end; end; AbsStart := Point3D(0, -Height / 2, 0); StartPoints.InvalidateAbsoluteMatrix; for i := 0 to LayerCount – 1 do begin vertexIdx := FData.VertexBuffer.Length; indexIdx := FData.IndexBuffer.Length; pLayer := StartPoints.GetLayer(i); FData.VertexBuffer.Length := vertexIdx + PointsLen; for k := 0 to PointsLen – 1 do begin FData.VertexBuffer.Vertices[vertexIdx + k] := pLayer.AbsPoint(k) + AbsStart; FData.VertexBuffer.TexCoord0[vertexIdx + k] := Pointf(k / (PointsLen – 1), pLayer.Position.Y / Height); end; if (FSectionType <> sctNone) and (not pLayer.GapLayer) then begin sctIndex := Length(SectionPoints); SetLength(SectionPoints, sctIndex + 2); SectionPoints[sctIndex] := pLayer.AbsPoint(PointsLen – 1) + AbsStart; SectionPoints[sctIndex + 1] := pLayer.AbsPoint(0) + AbsStart; end; if (i > 0) and (not pLayer.GapLayer) then begin FData.IndexBuffer.Length := indexIdx + cntIndexInRow; pVertexIdx := vertexIdx – PointsLen; for k := 0 to PointsLen – 1 do begin if k = PointsLen – 1 then begin if FSectionType = sctNone then begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := pVertexIdx; if Back then begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := pVertexIdx; end; end; end else begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := pVertexIdx + k + 1; if Back then begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := pVertexIdx + k + 1; end; end; end; end; end; SetLength(FirstPoints, PointsLen); SetLength(LastPoints, PointsLen); for i := 0 to StartPoints.Length – 1 do FirstPoints[i] := StartPoints.AbsPoint(i) + AbsStart; for i := 0 to EndPoints.Length – 1 do LastPoints[i] := EndPoints.AbsPoint(i) + AbsStart; FFirstCenter := StartPoints.AbsoluteCenter; FLastCenter := EndPoints.AbsoluteCenter; for pModifier in FModifiers do begin pModifier.EndModify; end; StartPoints.Free; end; procedure TPipe.BuildSectionSurfaces(OuterSectionPoints, InnerSectionPoints: TPointArray); var p1, p2: TPoint3d; i: Integer; FData: TMeshData; vertexIdx, indexIdx, vIdx: Integer; LevelCount: Integer; begin FData := Self.Data; LevelCount := System.Length(OuterSectionPoints) div 2; // left vertexIdx := FData.VertexBuffer.Length; FData.VertexBuffer.Length := vertexIdx + (LevelCount) * 2; for i := 0 to LevelCount – 1 do begin p1 := OuterSectionPoints[i * 2]; p2 := InnerSectionPoints[i * 2]; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 0] := p1; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 1] := p2; end; indexIdx := FData.IndexBuffer.Length; FData.IndexBuffer.Length := indexIdx + (LevelCount – 1) * 6; for i := 0 to LevelCount – 2 do begin vIdx := vertexIdx + i * 2 + 0; FData.IndexBuffer[indexIdx + i * 6 + 0] := vIdx + 1; FData.IndexBuffer[indexIdx + i * 6 + 1] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 2] := vIdx + 0; FData.IndexBuffer[indexIdx + i * 6 + 3] := vIdx + 3; FData.IndexBuffer[indexIdx + i * 6 + 4] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 5] := vIdx + 1; end; // right vertexIdx := FData.VertexBuffer.Length; FData.VertexBuffer.Length := vertexIdx + (LevelCount) * 2; for i := 0 to LevelCount – 1 do begin p1 := OuterSectionPoints[i * 2 + 1]; p2 := InnerSectionPoints[i * 2 + 1]; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 0] := p1; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 1] := p2; end; indexIdx := FData.IndexBuffer.Length; FData.IndexBuffer.Length := indexIdx + (LevelCount – 1) * 6; for i := 0 to LevelCount – 2 do begin vIdx := vertexIdx + i * 2 + 0; FData.IndexBuffer[indexIdx + i * 6 + 0] := vIdx + 0; FData.IndexBuffer[indexIdx + i * 6 + 1] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 2] := vIdx + 1; FData.IndexBuffer[indexIdx + i * 6 + 3] := vIdx + 1; FData.IndexBuffer[indexIdx + i * 6 + 4] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 5] := vIdx + 3; end; end; procedure TPipe.ClearModifiers; var pModifier: TPipeModifier; begin for pModifier in Self.FModifiers do pModifier.Free; FModifiers.Clear; end; constructor TPipe.Create(AOwner: TComponent); begin inherited; Self.TwoSide := True; FModifiers := TList<TPipeModifier>.Create; FModifiers.OnNotify := ModifiersNotify; FOnZAxis := False; FScaleBeforeRender := False; RebuildMesh; end; destructor TPipe.Destroy; begin ClearModifiers; FModifiers.Free; inherited; end; function TPipe.FixHeight: Boolean; begin Result := False; end; procedure TPipe.GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); var i: Integer; begin SetLength(IPoints, Length(InnerPoints)); SetLength(OPoints, Length(OuterPoints)); for i := 0 to High(InnerPoints) do begin IPoints[i] := Point3D(InnerPoints[i].X, PosY, InnerPoints[i].Z); OPoints[i] := Point3D(OuterPoints[i].X, PosY, OuterPoints[i].Z); end; end; procedure TPipe.ModifiersNotify(Sender: TObject; Const Item: TPipeModifier; Action: TCollectionNotification); begin SortModifiers; RebuildMesh; end; procedure TPipe.RebuildMesh; var OuterSectionPoints, InnerSectionPoints: TPointArray; InnerFirstPoints, InnerLastPoints, OuterFirstPoints, OuterLastPoints: TPointArray; begin if FModifiers = nil then exit; CalcPoints; Data.VertexBuffer.Length := 0; Data.IndexBuffer.Length := 0; BuildCylinder(InnerPoints, True, InnerSectionPoints, InnerFirstPoints, InnerLastPoints); BuildCylinder(OuterPoints, False, OuterSectionPoints, OuterFirstPoints, OuterLastPoints); if FSectionType <> sctNone then BuildSectionSurfaces(OuterSectionPoints, InnerSectionPoints); BuildAnnulus(InnerLastPoints, OuterLastPoints, True); BuildAnnulus(InnerFirstPoints, OuterFirstPoints, False); Data.CalcFaceNormals; end; procedure TPipe.Render; begin if not FScaleBeforeRender then Context.SetMatrix(TMatrix3D.CreateScaling(TPoint3D.Create(FRenderScale, 1, FRenderScale)) * AbsoluteMatrix); Context.DrawTriangles(Data.VertexBuffer, Data.IndexBuffer, TMaterialSource.ValidMaterial(MaterialSource), AbsoluteOpacity); end; procedure TPipe.SetHeight(const Value: Single); var FRefresh: Boolean; begin FRefresh := (Self.Height <> Value); inherited; if FRefresh then RebuildMesh; end; procedure TPipe.SetOnZAxis(const Value: Boolean); begin FOnZAxis := Value; RebuildMesh; end; procedure TPipe.SetScaleBeforeRender(const Value: Boolean); begin FScaleBeforeRender := Value; RebuildMesh; end; function CompareLevels(Item1, Item2: TPipeModifier): Integer; begin Result := 0; if TPipeModifier(Item1).StartPosition > TPipeModifier(Item2).StartPosition then begin Result := 1; end else if TPipeModifier(Item1).StartPosition < TPipeModifier(Item2).StartPosition then begin Result := -1; end; end; procedure TPipe.SortModifiers; var Comparer: IComparer<TPipeModifier>; begin Comparer := TDelegatedComparer<TPipeModifier>.Create( function(const Left, Right: TPipeModifier): Integer begin Result := Ceil(Left.StartPosition – Right.StartPosition); if (Result = 0) and (Left is TTwistModifier) then Result := 1; end); FModifiers.Sort(Comparer); end; { TPipeModifier } Function TPipeModifier.InsertPointLayer(StartLayer: TPointLayer; LayerH: Single; UseGap: Boolean = False): TPointLayer; var lParent: TPointLayer; FLayer: TPointLayer; begin Result := nil; FLayer := StartLayer; repeat if abs(LayerH – FLayer.LayerH) < 0.00001 then begin Result := FLayer; if UseGap then begin Result := Result.CreateChildAtPosition(TPoint3D.Zero, 1); Result.GapLayer := True; end; end else if (FLayer.LayerH > LayerH) then begin if assigned(FLayer.RealParent) then begin lParent := FLayer.RealParent; Result := lParent.CreateChildAtPosition(Point3D(0, LayerH – lParent.LayerH, 0), 1); if UseGap then begin Result := Result.CreateChildAtPosition(TPoint3D.Zero, 1); Result.GapLayer := True; end; end; end else if (Result = nil) and (FLayer.RealChild = nil) then begin Result := FLayer.CreateChildAtPosition(Point3D(0, LayerH – FLayer.LayerH, 0), 1); if UseGap then begin Result := Result.CreateChildAtPosition(TPoint3D.Zero, 1); Result.GapLayer := True; end; end; FLayer := FLayer.RealChild; until (Result <> nil) or (FLayer = nil); end; procedure TPipeModifier.BeginModify(StartPoints: TPointLayer); var i: Integer; FLayer: TPointLayer; mLen, dLen: Single; h1, h2, dh: Single; sCnt: Integer; tempList: TList<TPointLayer>; divCount: Integer; begin StartLayer := InsertPointLayer(StartPoints, FStartPosition, FUseGap); EndLayer := InsertPointLayer(StartPoints, FEndPosition, FUseGap); StartMLayer := nil; EndMLayer := nil; divCount := (FSubdivisions + 1); if (FStartMargin > 0) then begin StartMLayer := InsertPointLayer(StartPoints, FStartPosition + FStartMargin); divCount := divCount – 1; end; if (FEndMargin > 0) then begin EndMLayer := InsertPointLayer(StartPoints, FEndPosition – FEndMargin); divCount := divCount – 1; end; mLen := Self.EndPosition – Self.StartPosition – (FEndMargin + FStartMargin); dLen := mLen / divCount; if assigned(StartLayer) and assigned(EndLayer) then begin tempList := TList<TPointLayer>.Create; FLayer := StartLayer; if assigned(StartMLayer) then FLayer := StartMLayer; repeat tempList.Add(FLayer); FLayer := FLayer.RealChild; until (FLayer = EndLayer) or (FLayer = EndMLayer); if assigned(FLayer) then tempList.Add(FLayer); for i := 0 to tempList.Count – 2 do begin h1 := tempList[i].LayerH; h2 := tempList[i + 1].LayerH; sCnt := Round((h2 – h1) / dLen); if sCnt > 1 then begin dh := (h2 – h1) / sCnt; tempList[i].CreateChildAtPosition(Point3D(0, dh, 0), sCnt – 1); end; end; FLayerCount := EndLayer.Index – StartLayer.Index + 1; tempList.Free; end; end; constructor TPipeModifier.Create(aPipe: TPipe); begin inherited Create(aPipe); FPipe := aPipe; FSubdivisions := 10; FStartPosition := -FPipe.Height / 4; FEndPosition := FPipe.Height / 4; FStartMargin := 0; FEndMargin := 0; FModifyMargins := False; end; procedure TPipeModifier.DoModify(StartPoints: TPointLayer); var FLayer: TPointLayer; begin if (FStartPosition > FEndPosition) then exit; if (FStartPosition = FEndPosition) then exit; BeginModify(StartPoints); if (not assigned(StartLayer)) or (not assigned(EndLayer)) then raise Exception.Create('Modifier Position Indexes cant be arranged'); FLayer := StartLayer; if (not FModifyMargins) and assigned(StartMLayer) then FLayer := StartMLayer; Self.ModifySubPoints(FLayer, False); repeat FLayer := FLayer.RealChild; if assigned(FLayer) then Self.ModifySubPoints(FLayer, False); until (FLayer = nil) or ((FLayer = EndMLayer) and (not FModifyMargins)) or (FLayer = EndLayer); end; procedure TPipeModifier.EndModify; begin if assigned(StartLayer) then FFirstCenter := StartLayer.AbsoluteCenter; if assigned(EndLayer) then FLastCenter := EndLayer.AbsoluteCenter; end; procedure TPipeModifier.SetEndPosition(const Value: Single); begin FEndPosition := Value; FPipe.RebuildMesh; end; procedure TPipeModifier.SetModifyMargins(const Value: Boolean); begin FModifyMargins := Value; FPipe.RebuildMesh; end; procedure TPipeModifier.SetStartPosition(const Value: Single); begin FStartPosition := Value; FPipe.RebuildMesh; end; procedure TPipeModifier.SetSubdivisions(const Value: Integer); begin FSubdivisions := Value; FPipe.RebuildMesh; end; { TBendModifier } constructor TBendModifier.Create(aPipe: TPipe); begin inherited; FEndPosition := FPipe.Height / 4; FBendAngle := 90; FTurnAngle := 0; end; destructor TBendModifier.Destroy; begin inherited; end; procedure TBendModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); var Index: Integer; FCurrentBendAngle: Single; begin FCurrentBendAngle := (FBendAngle / (FLayerCount – 1)); Index := sPoints.Index; if sPoints = StartLayer then begin sPoints.DummyChild.RotationAngle.Z := FCurrentBendAngle / 2; sPoints.RotationAngle.Y := FTurnAngle; end else if (Index > StartLayer.Index) and (Index <= EndLayer.Index) then begin sPoints.RotationAngle.Z := FCurrentBendAngle / 2; if sPoints <> EndLayer then begin sPoints.DummyChild.RotationAngle.Z := FCurrentBendAngle / 2; end; end; end; procedure TBendModifier.SetBendAngle(const Value: Single); begin FBendAngle := Value; FPipe.RebuildMesh; end; procedure TBendModifier.SetTurnAngle(const Value: Single); begin FTurnAngle := Value; FPipe.RebuildMesh; end; { TTwistModifier } constructor TTwistModifier.Create(aPipe: TPipe); begin inherited; FTotalRotation := 45; end; procedure TTwistModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); var ya: Single; totalH, thisH: Single; cIndex, sIndex, eIndex: Integer; begin sIndex := StartLayer.Index; cIndex := sPoints.Index; eIndex := EndLayer.Index; if (cIndex > sIndex) and (cIndex <= eIndex) then begin totalH := FEndPosition – FStartPosition; thisH := sPoints.GetLayerH – FStartPosition; ya := (FTotalRotation / totalH) * thisH; sPoints.Content.RotationAngle.Y := ya; end; end; procedure TTwistModifier.SetTotalRotation(const Value: Single); begin FTotalRotation := Value; FPipe.RebuildMesh; end; { TPointLayer } function TPointLayer.AbsPoint(i: Integer): TPoint3d; var tTurn: Single; begin tTurn := GetTotalTurn; FContent.FContent.RotationAngle.Y := -tTurn; Result := Points[i] * FContent.FContent.AbsoluteMatrix; end; procedure TPointLayer.AddChild(CPointLayer: TPointLayer); var FOldChild: TPointLayer; begin FOldChild := FChild.FChild; Self.FChild.FChild := CPointLayer; CPointLayer.FParent := Self.FChild; if assigned(FOldChild) then begin CPointLayer.LastChild.AddChild(FOldChild); end; end; function TPointLayer.Content: TPointLayer; begin Result := FContent; end; constructor TPointLayer.Create; begin inherited; FLocalMatrix := TMatrix3D.Identity; FQuaternion := TQuaternion3D.Identity; FPosition := TPosition3d.Create(TPoint3D.Zero); FPosition.OnChange := MatrixChanged; FRotationAngle := TPosition3d.Create(TPoint3D.Zero); FRotationAngle.OnChange := RotationChanged; FScale := TPosition3d.Create(Point3D(1, 1, 1)); FScale.OnChange := MatrixChanged; FAbsMatrixNeedRefresh := True; FGapLayer := False; CreateDummies; end; function TPointLayer.CreateChildAtPosition(CPos: TPoint3d; RepeatNbr: Integer): TPointLayer; var i: Integer; begin Result := TPointLayer.Create; Result.Length := Self.Length; for i := 0 to Length – 1 do Result.Points[i] := Self.Points[i]; Result.Position.point := CPos; if assigned(FChild.FChild) then begin FChild.FChild.Position.point := FChild.FChild.Position.point – CPos; end; Self.AddChild(Result); RepeatNbr := RepeatNbr – 1; if RepeatNbr > 0 then Result := Result.CreateChildAtPosition(CPos, RepeatNbr); end; procedure TPointLayer.CreateDummies; var FContentContent: TPointLayer; begin FChild := TDummyPointLayer.Create; FChild.FParent := Self; FContent := TDummyPointLayer.Create; FContent.FParent := Self; FContentContent := TDummyPointLayer.Create; FContentContent.FParent := FContent; FContent.FContent := FContentContent; end; destructor TPointLayer.Destroy; begin FreeAndNil(FChild); FreeAndNil(FRotationAngle); FreeAndNil(FScale); FreeAndNil(FPosition); FreeAndNil(FContent); inherited; end; function TPointLayer.GeAbsoluteCenter: TPoint3d; var tTurn: Single; begin tTurn := GetTotalTurn; FContent.FContent.RotationAngle.Y := -tTurn; Result := TPoint3D.Zero * FContent.FContent.AbsoluteMatrix; end; function TPointLayer.GetAbsoluteMatrix: TMatrix3D; begin if not FAbsMatrixNeedRefresh then begin Result := FSavedAbsoluteMatrix; end else begin if assigned(FParent) and (FParent is TPointLayer) then Result := FLocalMatrix * TPointLayer(FParent).AbsoluteMatrix else Result := FLocalMatrix; FSavedAbsoluteMatrix := Result; FAbsMatrixNeedRefresh := False; end; end; function TPointLayer.GetDummyChild: TPointLayer; begin result := nil; if assigned(FChild) and (FChild is TDummyPointLayer) then Result := FChild; end; function TPointLayer.GetFirstParent: TPointLayer; begin Result := Self; if assigned(FParent.FParent) then begin Result := FParent.FParent.FirstParent; end; end; function TPointLayer.GetLayer(LIndex: Integer): TPointLayer; begin if LIndex = 0 then Result := Self else if assigned(FChild.FChild) and (LIndex > 0) then begin Result := FChild.FChild.GetLayer(LIndex – 1); end else Result := nil; end; function TPointLayer.GetLayerCount: Integer; begin Result := 1; if assigned(FChild.FChild) then Result := 1 + FChild.FChild.LayerCount; end; function TPointLayer.GetLayerH: Single; begin Result := Self.Position.Y; if assigned(RealParent) then Result := Result + RealParent.GetLayerH; end; function TPointLayer.GetLength: Integer; begin Result := System.Length(Points); end; function TPointLayer.GetRealChild: TPointLayer; begin Result := FChild.FChild; end; function TPointLayer.GetRealParent: TPointLayer; begin Result := nil; if assigned(FParent) then Result := FParent.FParent; end; function TPointLayer.GetTotalTurn: Single; begin Result := RotationAngle.Y; if assigned(FParent) then Result := Result + FParent.GetTotalTurn; end; function TPointLayer.Index: Integer; begin Result := 0; if assigned(FParent) and assigned(FParent.FParent) then Result := 1 + FParent.FParent.Index; end; procedure TPointLayer.InvalidateAbsoluteMatrix; begin FAbsMatrixNeedRefresh := True; if assigned(FChild) then FChild.InvalidateAbsoluteMatrix; end; function TPointLayer.LastChild: TPointLayer; begin Result := Self; if assigned(FChild.FChild) then Result := FChild.FChild.LastChild; end; procedure TPointLayer.MatrixChanged(Sender: TObject); var LeftVector, DirectionVector, UpVector: TPoint3d; RotMatrix: TMatrix3D; begin UpVector := Point3d(0, 1, 0); DirectionVector := Point3d(0, 0, 1); if (FRotationAngle.X <> 0) or (FRotationAngle.Y <> 0) or (FRotationAngle.Z <> 0) then begin RotMatrix := FQuaternion; UpVector := UpVector * RotMatrix; DirectionVector := DirectionVector * RotMatrix; end else begin FQuaternion := TQuaternion3D.Identity; end; LeftVector := UpVector.CrossProduct(DirectionVector); FLocalMatrix.M[0] := LeftVector * FScale.X; FLocalMatrix.m14 := 0; FLocalMatrix.M[1] := UpVector * FScale.Y; FLocalMatrix.m24 := 0; FLocalMatrix.M[2] := DirectionVector * FScale.Z; FLocalMatrix.m34 := 0; FLocalMatrix.m41 := FPosition.X; FLocalMatrix.m42 := FPosition.Y; FLocalMatrix.m43 := FPosition.Z; FAbsMatrixNeedRefresh := True; end; Function TPointLayer.RemoveFirstChild: TPointLayer; begin result := nil; if assigned(FChild.FChild) then begin Result := FChild.FChild; FChild.FChild := nil; if assigned(Result.FChild.FChild) then begin Self.AddChild(Result.FChild.FChild); Result.FChild.FChild := nil; end; end; end; procedure TPointLayer.RotationChanged(Sender: TObject); var q: TQuaternion3D; A: Single; begin FQuaternion := TQuaternion3D.Identity; A := DegToRad(DegNormalize(RotationAngle.X)); if A <> 0 then begin { AbsoluteRight } q := TQuaternion3D.Create(Point3D(1, 0, 0), A); FQuaternion := FQuaternion * q; end; A := DegToRad(DegNormalize(RotationAngle.Y)); if A <> 0 then begin { AbsoluteDirection } q := TQuaternion3D.Create(Point3D(0, 1, 0), A); FQuaternion := FQuaternion * q; end; A := DegToRad(DegNormalize(RotationAngle.Z)); if A <> 0 then begin { AbsoluteUp } q := TQuaternion3D.Create(Point3D(0, 0, 1), A); FQuaternion := FQuaternion * q; end; MatrixChanged(Sender); end; procedure TPointLayer.SetPointsLength(const Value: Integer); begin SetLength(Points, Value); end; { TEmbossModifier } constructor TEmbossModifier.Create(aPipe: TPipe); begin inherited; FStartMargin := 0.02; FEndMargin := 0.02; FThicknessRatio := 0.1; end; procedure TEmbossModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); begin sPoints.Content.Scale.point := Point3D(1 + FThicknessRatio, 0, 1 + FThicknessRatio); end; procedure TEmbossModifier.SetThicknessRatio(const Value: Single); begin FThicknessRatio := Value; FPipe.RebuildMesh; end; { TDummyPointLayer } procedure TDummyPointLayer.CreateDummies; begin // Do Nothing end; { TBreakModifier } constructor TBreakModifier.Create(aPipe: TPipe); begin inherited; FModifyMargins := True; end; procedure TBreakModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); var Index: Integer; FCurrentBendAngle: Single; elpR: Single; begin FCurrentBendAngle := (FBendAngle / (FLayerCount – 2)); FCurrentBendAngle := FCurrentBendAngle / 2; elpR := 1 / cos((FCurrentBendAngle) * (pi / 180)); Index := sPoints.Index; if (Index > StartLayer.Index) and (Index < EndLayer.Index) then begin sPoints.RotationAngle.Z := FCurrentBendAngle; sPoints.Content.Scale.point := Point3D(elpR, 1, 1); sPoints.DummyChild.RotationAngle.Z := FCurrentBendAngle; end; end; procedure TBreakModifier.SetEndMargin(const Value: Single); begin FEndMargin := Value; FPipe.RebuildMesh; end; procedure TBreakModifier.SetStartMargin(const Value: Single); begin FStartMargin := Value; FPipe.RebuildMesh; end; initialization RegisterFmxClasses([TPipeModifier, TBendModifier, TTwistModifier, TEmbossModifier]); end. view raw FMX.MeshObjects.pas hosted with ❤ by GitHub I’ve also made some minor changes required for XE5-XE7 which are here: .gist table { margin-bottom: 0; } This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters Show hidden characters unit FMX.MeshObjects; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, System.RTLConsts, System.Math, System.UIConsts, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Controls3D, FMX.Types3D, FMX.Objects3D, FMX.Layers3D, FMX.Objects, FMX.Menus, FMX.Edit, FMX.Colors, FMX.MaterialSources, System.StrUtils, System.Generics.Collections, FMX.Ani, FMX.Materials, System.Generics.Defaults; Type TSectionType = (sctNone, sctTop, sctBottom); TFrameType = (ftEllipse, ftRectangle); TPointArray = array of TPoint3d; TDummyPointLayer = class; TPoint3DHelper = record helper for TPoint3D public class function Zero: TPoint3D; static; end; TPointLayer = class(TObject) private FParent: TPointLayer; FChild: TPointLayer; FContent: TPointLayer; FPosition: TPosition3d; FLocalMatrix: TMatrix3D; FRotationAngle: TPosition3d; FQuaternion: TQuaternion3D; FScale: TPosition3d; FSavedAbsoluteMatrix: TMatrix3D; FAbsMatrixNeedRefresh: Boolean; FGapLayer: Boolean; function GetLength: Integer; procedure SetPointsLength(const Value: Integer); Procedure MatrixChanged(Sender: TObject); procedure RotationChanged(Sender: TObject); virtual; function GetAbsoluteMatrix: TMatrix3D; function GetRealParent: TPointLayer; function GetRealChild: TPointLayer; function GetLayerCount: Integer; function GetFirstParent: TPointLayer; function GetDummyChild: TPointLayer; function GeAbsoluteCenter: TPoint3d; function GetLayerH: Single; protected Procedure CreateDummies; virtual; public Points: TPointArray; Constructor Create; Destructor Destroy; override; Function CreateChildAtPosition(CPos: TPoint3d; RepeatNbr: Integer): TPointLayer; Procedure AddChild(CPointLayer: TPointLayer); Function LastChild: TPointLayer; Function RemoveFirstChild: TPointLayer; Function Index: Integer; Function GetLayer(LIndex: Integer): TPointLayer; Function AbsPoint(i: Integer): TPoint3d; Function GetTotalTurn: Single; Function Content: TPointLayer; Procedure InvalidateAbsoluteMatrix; Property FirstParent: TPointLayer read GetFirstParent; Property RealParent: TPointLayer read GetRealParent; Property RealChild: TPointLayer read GetRealChild; Property DummyChild: TPointLayer read GetDummyChild; Property Length: Integer read GetLength write SetPointsLength; Property Position: TPosition3d read FPosition write FPosition; property AbsoluteMatrix: TMatrix3D read GetAbsoluteMatrix; property LocalMatrix: TMatrix3D read FLocalMatrix; Property AbsoluteCenter: TPoint3d read GeAbsoluteCenter; Property LayerH: Single read GetLayerH; Property GapLayer: Boolean read FGapLayer write FGapLayer; property RotationAngle: TPosition3d read FRotationAngle write FRotationAngle; property Scale: TPosition3d read FScale write FScale; Property LayerCount: Integer read GetLayerCount; end; TDummyPointLayer = class(TPointLayer) protected Procedure CreateDummies; override; end; TLayerList = TList<TPointLayer>; TAnnulus = class(TCustomMesh) private FSectionType: TSectionType; FSectionDegree: Integer; FInnerFrameType: TFrameType; FOuterFrameType: TFrameType; FDrawBounds: Boolean; procedure SetThickness(const Value: Single); procedure SetSubdivisionsAxes(const Value: Integer); procedure SetSectionDegree(const Value: Integer); procedure SetSectionType(const Value: TSectionType); procedure setInnerFrameType(const Value: TFrameType); procedure setOuterFrameType(const Value: TFrameType); procedure SetDrawBounds(const Value: Boolean); protected FSubdivisionsAxes: Integer; FUnitWidth: Single; FUnitHeight: Single; FThickness: Single; FRenderScale: Single; FStartAngle: Single; FTotalAngle: Single; FDistAngle: Single; InnerPoints: TPointArray; OuterPoints: TPointArray; function ExtendPointToPlane(point, Plane, PlaneNormal: TPoint3D; var Distance: Single; var nPoint: TPoint3d): Boolean; Procedure CalcPoints; virtual; Procedure GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); virtual; procedure BuildAnnulus(IPoints, OPoints: TPointArray; Back: Boolean); virtual; procedure RebuildMesh; virtual; procedure Render; override; function FixHeight: Boolean; virtual; procedure SetHeight(const Value: Single); override; procedure SetWidth(const Value: Single); override; procedure SetDepth(const Value: Single); override; public constructor Create(AOwner: TComponent); override; property Data; Property Thickness: Single read FThickness write SetThickness; Property SubdivisionsAxes: Integer read FSubdivisionsAxes write SetSubdivisionsAxes; Property SectionType: TSectionType read FSectionType write SetSectionType; Property SectionDegree: Integer read FSectionDegree write SetSectionDegree; Property InnerFrameType: TFrameType read FInnerFrameType write setInnerFrameType; Property OuterFrameType: TFrameType read FOuterFrameType write setOuterFrameType; Property RenderScale: Single read FRenderScale; Property DrawBounds: Boolean read FDrawBounds write SetDrawBounds; end; TPipe = class; TPipeModifier = class(TFMXObject) private FPipe: TPipe; FStartPosition: Single; FEndPosition: Single; FSubdivisions: Integer; FUseGap: Boolean; FFirstCenter: TPoint3d; FLastCenter: TPoint3d; FModifyMargins: Boolean; procedure SetStartPosition(const Value: Single); procedure SetEndPosition(const Value: Single); procedure SetSubdivisions(const Value: Integer); function InsertPointLayer(StartLayer: TPointLayer; LayerH: Single; UseGap: Boolean = False): TPointLayer; procedure SetModifyMargins(const Value: Boolean); protected FStartMargin: Single; FEndMargin: Single; FLayerCount: Integer; StartLayer, EndLayer, StartMLayer, EndMLayer: TPointLayer; Procedure BeginModify(StartPoints: TPointLayer); virtual; public Constructor Create(aPipe: TPipe); virtual; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); virtual; abstract; Procedure DoModify(StartPoints: TPointLayer); virtual; Procedure EndModify; virtual; published Property StartPosition: Single read FStartPosition write SetStartPosition; Property EndPosition: Single read FEndPosition write SetEndPosition; Property Subdivisions: Integer read FSubdivisions write SetSubdivisions; Property UseGap: Boolean read FUseGap write FUseGap; Property FirstCenter: TPoint3d read FFirstCenter; Property LastCenter: TPoint3d read FLastCenter; Property ModifyMargins: Boolean read FModifyMargins write SetModifyMargins; end; TBendModifier = class(TPipeModifier) private FBendAngle: Single; FTurnAngle: Single; procedure SetBendAngle(const Value: Single); procedure SetTurnAngle(const Value: Single); public Constructor Create(aPipe: TPipe); override; Destructor Destroy; override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; published Property BendAngle: Single read FBendAngle write SetBendAngle; Property TurnAngle: Single read FTurnAngle write SetTurnAngle; end; TBreakModifier = class(TBendModifier) private procedure SetEndMargin(const Value: Single); procedure SetStartMargin(const Value: Single); public Constructor Create(aPipe: TPipe); override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; Property StartMargin: Single read FStartMargin write SetStartMargin; Property EndMargin: Single read FEndMargin write SetEndMargin; end; TTwistModifier = class(TPipeModifier) private FTotalRotation: Single; procedure SetTotalRotation(const Value: Single); public Constructor Create(aPipe: TPipe); override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; published Property TotalRotation: Single read FTotalRotation write SetTotalRotation; end; TEmbossModifier = class(TPipeModifier) private FThicknessRatio: Single; procedure SetThicknessRatio(const Value: Single); public Constructor Create(aPipe: TPipe); override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; Property ThicknessRatio: Single read FThicknessRatio write SetThicknessRatio; end; TPipe = class(TAnnulus) private FModifiers: TList<TPipeModifier>; FOnZAxis: Boolean; FFirstCenter: TPoint3d; FLastCenter: TPoint3d; FScaleBeforeRender: Boolean; Procedure SortModifiers; procedure SetOnZAxis(const Value: Boolean); procedure SetScaleBeforeRender(const Value: Boolean); protected function FixHeight: Boolean; override; procedure SetHeight(const Value: Single); override; Procedure GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); override; procedure BuildSectionSurfaces(OuterSectionPoints, InnerSectionPoints: TPointArray); virtual; procedure BuildCylinder(Points: TPointArray; Back: Boolean; var SectionPoints, FirstPoints, LastPoints: TPointArray); virtual; procedure RebuildMesh; override; Procedure Render; override; Procedure ModifiersNotify(Sender: TObject; Const Item: TPipeModifier; Action: TCollectionNotification); public constructor Create(AOwner: TComponent); override; Procedure ClearModifiers; destructor Destroy; override; Property Modifiers: TList<TPipeModifier> read FModifiers; Property OnZAxis: Boolean read FOnZAxis write SetOnZAxis; Property FirstCenter: TPoint3d Read FFirstCenter; Property LastCenter: TPoint3d read FLastCenter; Property ScaleBeforeRender: Boolean read FScaleBeforeRender write SetScaleBeforeRender; end; procedure Register; implementation procedure Register; begin RegisterComponents('3D Shapes', [TAnnulus, TPipe]); end; { TPoint3DHelper } class function TPoint3DHelper.Zero: TPoint3D; begin Result := Point3D(0,0,0); end; { TPipe } procedure TAnnulus.BuildAnnulus(IPoints, OPoints: TPointArray; Back: Boolean); var FData: TMeshData; i: Integer; vertexIdx: Integer; indexIdx: Integer; begin FData := Self.Data; vertexIdx := FData.VertexBuffer.Length; indexIdx := FData.IndexBuffer.Length; FData.VertexBuffer.Length := vertexIdx + FSubdivisionsAxes * 2; for i := 0 to FSubdivisionsAxes – 1 do begin FData.VertexBuffer.Vertices[vertexIdx + i] := IPoints[i]; FData.VertexBuffer.TexCoord0[vertexIdx + i] := Pointf((IPoints[i].X + FUnitWidth / 2) / FUnitWidth, (IPoints[i].Z + FUnitHeight / 2) / FUnitHeight); FData.VertexBuffer.Vertices[vertexIdx + i + FSubdivisionsAxes] := OPoints[i]; FData.VertexBuffer.TexCoord0[vertexIdx + i + FSubdivisionsAxes] := Pointf((OPoints[i].X + FUnitWidth / 2) / FUnitWidth, (OPoints[i].Z + FUnitHeight / 2) / FUnitHeight); end; FData.IndexBuffer.Length := indexIdx + FSubdivisionsAxes * 6; if (FSectionType <> sctNone) then FData.IndexBuffer.Length := FData.IndexBuffer.Length – 6; for i := 0 to FSubdivisionsAxes – 1 do begin if (i = FSubdivisionsAxes – 1) then begin if (FSectionType = sctNone) then begin FData.IndexBuffer.Indices[indexIdx + i * 6 + 0] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + i + FSubdivisionsAxes; if Back then begin FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 0] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + i + FSubdivisionsAxes; end; end; end else begin FData.IndexBuffer.Indices[indexIdx + i * 6] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + i + FSubdivisionsAxes + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + i + FSubdivisionsAxes; if Back then begin FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 0] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + i + FSubdivisionsAxes + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + i + FSubdivisionsAxes; end; end; end; end; procedure TAnnulus.CalcPoints; var PhiSin, PhiCos: Extended; iWidth, iHeight: Single; rThickness: Single; A: Integer; Angle: Single; rPoint: TPoint3d; iPoint: TPoint3d; iDist: Single; uiWidth, uiHeight: Single; begin SetLength(OuterPoints, FSubdivisionsAxes); SetLength(InnerPoints, FSubdivisionsAxes); FUnitWidth := 1; FUnitHeight := 1; if Width > Depth then FUnitWidth := Width / Depth; if Depth > Width then FUnitHeight := Depth / Width; rThickness := FThickness * (FUnitWidth / Width); FRenderScale := Width / FUnitWidth; iWidth := 1; iHeight := 1; if (FThickness * 2 = Depth) or (FThickness * 2 = Width) then FThickness := FThickness – 0.1; if Width > Depth then iWidth := (Width – (FThickness * 2)) / (Depth – (FThickness * 2)); if Depth > Width then iHeight := (Depth – (FThickness * 2)) / (Width – (FThickness * 2)); FStartAngle := 0; FTotalAngle := 360; if FSectionType <> sctNone then FTotalAngle := 360 – FSectionDegree; if FSectionType = sctBottom then FStartAngle := -(180 – FSectionDegree) / 2; if FSectionType = sctTop then FStartAngle := 180 – (180 – FSectionDegree) / 2; FDistAngle := FTotalAngle / FSubdivisionsAxes; if FSectionType <> sctNone then FDistAngle := FTotalAngle / (FSubdivisionsAxes – 1); for A := 0 to FSubdivisionsAxes – 1 do begin Angle := DegToRad(FStartAngle) + DegToRad(FDistAngle) * A; SinCos(Angle, PhiSin, PhiCos); if FOuterFrameType = ftEllipse then begin OuterPoints[A] := Point3D(PhiCos * 0.5 * FUnitWidth, 0, PhiSin * 0.5 * FUnitHeight); end else begin rPoint := Point3D(PhiCos * 0.5 * FUnitWidth, 0, PhiSin * 0.5 * FUnitHeight); iDist := -1; iPoint := rPoint; Self.ExtendPointToPlane(rPoint, Point3D(FUnitWidth / 2, 0, 0), Point3D(-1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3D(0, 0, FUnitHeight / 2), Point3D(0, 0, -1), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3D(-FUnitWidth / 2, 0, 0), Point3D(1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3D(0, 0, -FUnitHeight / 2), Point3D(0, 0, 1), iDist, iPoint); OuterPoints[A] := iPoint; end; if FInnerFrameType = ftEllipse then begin InnerPoints[A] := Point3D(PhiCos * (0.5 – rThickness) * iWidth, 0, PhiSin * (0.5 – rThickness) * iHeight); end else begin rPoint := Point3D(PhiCos * (0.5 – rThickness) * iWidth, 0, PhiSin * (0.5 – rThickness) * iHeight); uiWidth := (0.5 – rThickness) * iWidth; uiHeight := (0.5 – rThickness) * iHeight; iDist := -1; iPoint := rPoint; Self.ExtendPointToPlane(rPoint, Point3d(uiWidth, 0, 0), Point3d(-1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3d(0, 0, uiHeight), Point3d(0, 0, -1), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3d(-uiWidth, 0, 0), Point3d(1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3d(0, 0, -uiHeight), Point3d(0, 0, 1), iDist, iPoint); InnerPoints[A] := iPoint; end; end; end; constructor TAnnulus.Create(AOwner: TComponent); begin inherited; FThickness := 0.2; FSubdivisionsAxes := 180; FSectionType := sctNone; FSectionDegree := 180; FOuterFrameType := ftEllipse; FInnerFrameType := ftEllipse; RebuildMesh; end; function TAnnulus.ExtendPointToPlane(point, Plane, PlaneNormal: TPoint3D; var Distance: Single; var nPoint: TPoint3d): Boolean; var iPoint: TVector3d; aDist: Single; begin Result := False; if RayCastPlaneIntersect(TPoint3D.Zero, point, Plane, PlaneNormal, iPoint) then begin aDist := Sqrt(iPoint.Distance(TPoint3D.Zero)); if Distance = -1 then begin Distance := aDist; nPoint := iPoint.ToPoint3D; Result := True; end else if aDist < Distance then begin Distance := aDist; nPoint := iPoint.ToPoint3D; Result := True; end; end; end; function TAnnulus.FixHeight: Boolean; begin FHeight := 0.001; Result := True; end; procedure TAnnulus.GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); var i: Integer; begin SetLength(IPoints, Length(InnerPoints)); SetLength(OPoints, Length(OuterPoints)); for i := 0 to High(InnerPoints) do begin IPoints[i] := Point3D(InnerPoints[i].X, PosY, InnerPoints[i].Z); OPoints[i] := Point3D(OuterPoints[i].X, PosY, OuterPoints[i].Z); end; end; procedure TAnnulus.RebuildMesh; var IPoints, OPoints: TPointArray; begin CalcPoints; Data.VertexBuffer.Length := 0; Data.IndexBuffer.Length := 0; GetAnnulusPointsForPosY(-0.001, IPoints, OPoints); BuildAnnulus(IPoints, OPoints, True); GetAnnulusPointsForPosY(0.001, IPoints, OPoints); BuildAnnulus(IPoints, OPoints, False); Data.CalcFaceNormals; end; procedure TAnnulus.Render; begin Context.SetMatrix(TMatrix3D.CreateScaling(TPoint3D.Create(FRenderScale, Height, FRenderScale)) * AbsoluteMatrix); Context.DrawTriangles(Data.VertexBuffer, Data.IndexBuffer, TMaterialSource.ValidMaterial(MaterialSource), AbsoluteOpacity); if FDrawBounds then begin Context.SetMatrix(AbsoluteMatrix); Context.DrawCube(TPoint3D.Zero, Point3D(Width, 0, Depth), AbsoluteOpacity, TalphaColors.Red); end; end; procedure TAnnulus.SetDepth(const Value: Single); var FRefresh: Boolean; begin FRefresh := (Self.Depth <> Value); inherited; if FRefresh then RebuildMesh; end; procedure TAnnulus.SetDrawBounds(const Value: Boolean); begin FDrawBounds := Value; Render; end; procedure TAnnulus.SetHeight(const Value: Single); begin if not FixHeight then inherited; end; procedure TAnnulus.setInnerFrameType(const Value: TFrameType); begin FInnerFrameType := Value; RebuildMesh; end; procedure TAnnulus.setOuterFrameType(const Value: TFrameType); begin FOuterFrameType := Value; RebuildMesh; end; procedure TAnnulus.SetSectionDegree(const Value: Integer); begin FSectionDegree := Value; RebuildMesh; end; procedure TAnnulus.SetSectionType(const Value: TSectionType); begin FSectionType := Value; RebuildMesh; end; procedure TAnnulus.SetSubdivisionsAxes(const Value: Integer); begin FSubdivisionsAxes := Value; RebuildMesh; end; procedure TAnnulus.SetThickness(const Value: Single); begin FThickness := Value; RebuildMesh; end; procedure TAnnulus.SetWidth(const Value: Single); var FRefresh: Boolean; begin FRefresh := (Self.Width <> Value); inherited; if FRefresh then RebuildMesh; end; { TPipe } procedure TPipe.BuildCylinder(Points: TPointArray; Back: Boolean; var SectionPoints, FirstPoints, LastPoints: TPointArray); var FData: TMeshData; i, h, k: Integer; vertexIdx, pVertexIdx: Integer; indexIdx: Integer; hDist, hPos: Single; PhiSin, PhiCos: Extended; cntIndexInRow: Integer; cntVertexInRow: Integer; backM: Integer; Angle: Single; StartPoints: TPointLayer; EndPoints: TPointLayer; SubPoints: TPointArray; done: Boolean; PointsLen: Integer; pModifier: TPipeModifier; pLayer: TPointLayer; LayerCount: Integer; AbsStart: TPoint3d; sctIndex: Integer; begin FData := Self.Data; PointsLen := Length(Points); StartPoints := TPointLayer.Create; if FOnZAxis then StartPoints.RotationAngle.Point := Point3D(90, 90, 0); EndPoints := TPointLayer.Create; StartPoints.AddChild(EndPoints); StartPoints.Length := PointsLen; EndPoints.Length := PointsLen; StartPoints.Position.point := TPoint3D.Zero; EndPoints.Position.point := Point3D(0, Height, 0); for i := 0 to High(Points) do begin StartPoints.Points[i] := Point3D(Points[i].X, 0, Points[i].Z); EndPoints.Points[i] := Point3D(Points[i].X, 0, Points[i].Z); end; backM := 1; if Back then backM := -1; for pModifier in FModifiers do begin pModifier.DoModify(StartPoints); end; LayerCount := StartPoints.LayerCount; cntIndexInRow := PointsLen * 6; if FSectionType <> sctNone then begin cntIndexInRow := (PointsLen – 1) * 6; end; if FScaleBeforeRender then begin for i := 0 to LayerCount – 1 do begin pLayer := StartPoints.GetLayer(i); pLayer.Content.Scale.point := Point3D(pLayer.Content.Scale.point.X * FRenderScale, pLayer.Content.Scale.point.Y, pLayer.Content.Scale.point.Z * FRenderScale); end; end; AbsStart := Point3D(0, -Height / 2, 0); StartPoints.InvalidateAbsoluteMatrix; for i := 0 to LayerCount – 1 do begin vertexIdx := FData.VertexBuffer.Length; indexIdx := FData.IndexBuffer.Length; pLayer := StartPoints.GetLayer(i); FData.VertexBuffer.Length := vertexIdx + PointsLen; for k := 0 to PointsLen – 1 do begin FData.VertexBuffer.Vertices[vertexIdx + k] := pLayer.AbsPoint(k) + AbsStart; FData.VertexBuffer.TexCoord0[vertexIdx + k] := Pointf(k / (PointsLen – 1), pLayer.Position.Y / Height); end; if (FSectionType <> sctNone) and (not pLayer.GapLayer) then begin sctIndex := Length(SectionPoints); SetLength(SectionPoints, sctIndex + 2); SectionPoints[sctIndex] := pLayer.AbsPoint(PointsLen – 1) + AbsStart; SectionPoints[sctIndex + 1] := pLayer.AbsPoint(0) + AbsStart; end; if (i > 0) and (not pLayer.GapLayer) then begin FData.IndexBuffer.Length := indexIdx + cntIndexInRow; pVertexIdx := vertexIdx – PointsLen; for k := 0 to PointsLen – 1 do begin if k = PointsLen – 1 then begin if FSectionType = sctNone then begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := pVertexIdx; if Back then begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := pVertexIdx; end; end; end else begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := pVertexIdx + k + 1; if Back then begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := pVertexIdx + k + 1; end; end; end; end; end; SetLength(FirstPoints, PointsLen); SetLength(LastPoints, PointsLen); for i := 0 to StartPoints.Length – 1 do FirstPoints[i] := StartPoints.AbsPoint(i) + AbsStart; for i := 0 to EndPoints.Length – 1 do LastPoints[i] := EndPoints.AbsPoint(i) + AbsStart; FFirstCenter := StartPoints.AbsoluteCenter; FLastCenter := EndPoints.AbsoluteCenter; for pModifier in FModifiers do begin pModifier.EndModify; end; StartPoints.Free; end; procedure TPipe.BuildSectionSurfaces(OuterSectionPoints, InnerSectionPoints: TPointArray); var p1, p2: TPoint3d; i: Integer; FData: TMeshData; vertexIdx, indexIdx, vIdx: Integer; LevelCount: Integer; begin FData := Self.Data; LevelCount := System.Length(OuterSectionPoints) div 2; // left vertexIdx := FData.VertexBuffer.Length; FData.VertexBuffer.Length := vertexIdx + (LevelCount) * 2; for i := 0 to LevelCount – 1 do begin p1 := OuterSectionPoints[i * 2]; p2 := InnerSectionPoints[i * 2]; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 0] := p1; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 1] := p2; end; indexIdx := FData.IndexBuffer.Length; FData.IndexBuffer.Length := indexIdx + (LevelCount – 1) * 6; for i := 0 to LevelCount – 2 do begin vIdx := vertexIdx + i * 2 + 0; FData.IndexBuffer[indexIdx + i * 6 + 0] := vIdx + 1; FData.IndexBuffer[indexIdx + i * 6 + 1] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 2] := vIdx + 0; FData.IndexBuffer[indexIdx + i * 6 + 3] := vIdx + 3; FData.IndexBuffer[indexIdx + i * 6 + 4] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 5] := vIdx + 1; end; // right vertexIdx := FData.VertexBuffer.Length; FData.VertexBuffer.Length := vertexIdx + (LevelCount) * 2; for i := 0 to LevelCount – 1 do begin p1 := OuterSectionPoints[i * 2 + 1]; p2 := InnerSectionPoints[i * 2 + 1]; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 0] := p1; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 1] := p2; end; indexIdx := FData.IndexBuffer.Length; FData.IndexBuffer.Length := indexIdx + (LevelCount – 1) * 6; for i := 0 to LevelCount – 2 do begin vIdx := vertexIdx + i * 2 + 0; FData.IndexBuffer[indexIdx + i * 6 + 0] := vIdx + 0; FData.IndexBuffer[indexIdx + i * 6 + 1] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 2] := vIdx + 1; FData.IndexBuffer[indexIdx + i * 6 + 3] := vIdx + 1; FData.IndexBuffer[indexIdx + i * 6 + 4] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 5] := vIdx + 3; end; end; procedure TPipe.ClearModifiers; var pModifier: TPipeModifier; begin for pModifier in Self.FModifiers do pModifier.Free; FModifiers.Clear; end; constructor TPipe.Create(AOwner: TComponent); begin inherited; Self.TwoSide := True; FModifiers := TList<TPipeModifier>.Create; FModifiers.OnNotify := ModifiersNotify; FOnZAxis := False; FScaleBeforeRender := False; RebuildMesh; end; destructor TPipe.Destroy; begin ClearModifiers; FModifiers.Free; inherited; end; function TPipe.FixHeight: Boolean; begin Result := False; end; procedure TPipe.GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); var i: Integer; begin SetLength(IPoints, Length(InnerPoints)); SetLength(OPoints, Length(OuterPoints)); for i := 0 to High(InnerPoints) do begin IPoints[i] := Point3D(InnerPoints[i].X, PosY, InnerPoints[i].Z); OPoints[i] := Point3D(OuterPoints[i].X, PosY, OuterPoints[i].Z); end; end; procedure TPipe.ModifiersNotify(Sender: TObject; Const Item: TPipeModifier; Action: TCollectionNotification); begin SortModifiers; RebuildMesh; end; procedure TPipe.RebuildMesh; var OuterSectionPoints, InnerSectionPoints: TPointArray; InnerFirstPoints, InnerLastPoints, OuterFirstPoints, OuterLastPoints: TPointArray; begin if FModifiers = nil then exit; CalcPoints; Data.VertexBuffer.Length := 0; Data.IndexBuffer.Length := 0; BuildCylinder(InnerPoints, True, InnerSectionPoints, InnerFirstPoints, InnerLastPoints); BuildCylinder(OuterPoints, False, OuterSectionPoints, OuterFirstPoints, OuterLastPoints); if FSectionType <> sctNone then BuildSectionSurfaces(OuterSectionPoints, InnerSectionPoints); BuildAnnulus(InnerLastPoints, OuterLastPoints, True); BuildAnnulus(InnerFirstPoints, OuterFirstPoints, False); Data.CalcFaceNormals; end; procedure TPipe.Render; begin if not FScaleBeforeRender then Context.SetMatrix(TMatrix3D.CreateScaling(TPoint3D.Create(FRenderScale, 1, FRenderScale)) * AbsoluteMatrix); Context.DrawTriangles(Data.VertexBuffer, Data.IndexBuffer, TMaterialSource.ValidMaterial(MaterialSource), AbsoluteOpacity); end; procedure TPipe.SetHeight(const Value: Single); var FRefresh: Boolean; begin FRefresh := (Self.Height <> Value); inherited; if FRefresh then RebuildMesh; end; procedure TPipe.SetOnZAxis(const Value: Boolean); begin FOnZAxis := Value; RebuildMesh; end; procedure TPipe.SetScaleBeforeRender(const Value: Boolean); begin FScaleBeforeRender := Value; RebuildMesh; end; function CompareLevels(Item1, Item2: TPipeModifier): Integer; begin Result := 0; if TPipeModifier(Item1).StartPosition > TPipeModifier(Item2).StartPosition then begin Result := 1; end else if TPipeModifier(Item1).StartPosition < TPipeModifier(Item2).StartPosition then begin Result := -1; end; end; procedure TPipe.SortModifiers; var Comparer: IComparer<TPipeModifier>; begin Comparer := TDelegatedComparer<TPipeModifier>.Create( function(const Left, Right: TPipeModifier): Integer begin Result := Ceil(Left.StartPosition – Right.StartPosition); if (Result = 0) and (Left is TTwistModifier) then Result := 1; end); FModifiers.Sort(Comparer); end; { TPipeModifier } Function TPipeModifier.InsertPointLayer(StartLayer: TPointLayer; LayerH: Single; UseGap: Boolean = False): TPointLayer; var lParent: TPointLayer; FLayer: TPointLayer; begin Result := nil; FLayer := StartLayer; repeat if abs(LayerH – FLayer.LayerH) < 0.00001 then begin Result := FLayer; if UseGap then begin Result := Result.CreateChildAtPosition(TPoint3D.Zero, 1); Result.GapLayer := True; end; end else if (FLayer.LayerH > LayerH) then begin if assigned(FLayer.RealParent) then begin lParent := FLayer.RealParent; Result := lParent.CreateChildAtPosition(Point3D(0, LayerH – lParent.LayerH, 0), 1); if UseGap then begin Result := Result.CreateChildAtPosition(TPoint3D.Zero, 1); Result.GapLayer := True; end; end; end else if (Result = nil) and (FLayer.RealChild = nil) then begin Result := FLayer.CreateChildAtPosition(Point3D(0, LayerH – FLayer.LayerH, 0), 1); if UseGap then begin Result := Result.CreateChildAtPosition(TPoint3D.Zero, 1); Result.GapLayer := True; end; end; FLayer := FLayer.RealChild; until (Result <> nil) or (FLayer = nil); end; procedure TPipeModifier.BeginModify(StartPoints: TPointLayer); var i: Integer; FLayer: TPointLayer; mLen, dLen: Single; h1, h2, dh: Single; sCnt: Integer; tempList: TList<TPointLayer>; divCount: Integer; begin StartLayer := InsertPointLayer(StartPoints, FStartPosition, FUseGap); EndLayer := InsertPointLayer(StartPoints, FEndPosition, FUseGap); StartMLayer := nil; EndMLayer := nil; divCount := (FSubdivisions + 1); if (FStartMargin > 0) then begin StartMLayer := InsertPointLayer(StartPoints, FStartPosition + FStartMargin); divCount := divCount – 1; end; if (FEndMargin > 0) then begin EndMLayer := InsertPointLayer(StartPoints, FEndPosition – FEndMargin); divCount := divCount – 1; end; mLen := Self.EndPosition – Self.StartPosition – (FEndMargin + FStartMargin); dLen := mLen / divCount; if assigned(StartLayer) and assigned(EndLayer) then begin tempList := TList<TPointLayer>.Create; FLayer := StartLayer; if assigned(StartMLayer) then FLayer := StartMLayer; repeat tempList.Add(FLayer); FLayer := FLayer.RealChild; until (FLayer = EndLayer) or (FLayer = EndMLayer); if assigned(FLayer) then tempList.Add(FLayer); for i := 0 to tempList.Count – 2 do begin h1 := tempList[i].LayerH; h2 := tempList[i + 1].LayerH; sCnt := Round((h2 – h1) / dLen); if sCnt > 1 then begin dh := (h2 – h1) / sCnt; tempList[i].CreateChildAtPosition(Point3D(0, dh, 0), sCnt – 1); end; end; FLayerCount := EndLayer.Index – StartLayer.Index + 1; tempList.Free; end; end; constructor TPipeModifier.Create(aPipe: TPipe); begin inherited Create(aPipe); FPipe := aPipe; FSubdivisions := 10; FStartPosition := -FPipe.Height / 4; FEndPosition := FPipe.Height / 4; FStartMargin := 0; FEndMargin := 0; FModifyMargins := False; end; procedure TPipeModifier.DoModify(StartPoints: TPointLayer); var FLayer: TPointLayer; begin if (FStartPosition > FEndPosition) then exit; if (FStartPosition = FEndPosition) then exit; BeginModify(StartPoints); if (not assigned(StartLayer)) or (not assigned(EndLayer)) then raise Exception.Create('Modifier Position Indexes cant be arranged'); FLayer := StartLayer; if (not FModifyMargins) and assigned(StartMLayer) then FLayer := StartMLayer; Self.ModifySubPoints(FLayer, False); repeat FLayer := FLayer.RealChild; if assigned(FLayer) then Self.ModifySubPoints(FLayer, False); until (FLayer = nil) or ((FLayer = EndMLayer) and (not FModifyMargins)) or (FLayer = EndLayer); end; procedure TPipeModifier.EndModify; begin if assigned(StartLayer) then FFirstCenter := StartLayer.AbsoluteCenter; if assigned(EndLayer) then FLastCenter := EndLayer.AbsoluteCenter; end; procedure TPipeModifier.SetEndPosition(const Value: Single); begin FEndPosition := Value; FPipe.RebuildMesh; end; procedure TPipeModifier.SetModifyMargins(const Value: Boolean); begin FModifyMargins := Value; FPipe.RebuildMesh; end; procedure TPipeModifier.SetStartPosition(const Value: Single); begin FStartPosition := Value; FPipe.RebuildMesh; end; procedure TPipeModifier.SetSubdivisions(const Value: Integer); begin FSubdivisions := Value; FPipe.RebuildMesh; end; { TBendModifier } constructor TBendModifier.Create(aPipe: TPipe); begin inherited; FEndPosition := FPipe.Height / 4; FBendAngle := 90; FTurnAngle := 0; end; destructor TBendModifier.Destroy; begin inherited; end; procedure TBendModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); var Index: Integer; FCurrentBendAngle: Single; begin FCurrentBendAngle := (FBendAngle / (FLayerCount – 1)); Index := sPoints.Index; if sPoints = StartLayer then begin sPoints.DummyChild.RotationAngle.Z := FCurrentBendAngle / 2; sPoints.RotationAngle.Y := FTurnAngle; end else if (Index > StartLayer.Index) and (Index <= EndLayer.Index) then begin sPoints.RotationAngle.Z := FCurrentBendAngle / 2; if sPoints <> EndLayer then begin sPoints.DummyChild.RotationAngle.Z := FCurrentBendAngle / 2; end; end; end; procedure TBendModifier.SetBendAngle(const Value: Single); begin FBendAngle := Value; FPipe.RebuildMesh; end; procedure TBendModifier.SetTurnAngle(const Value: Single); begin FTurnAngle := Value; FPipe.RebuildMesh; end; { TTwistModifier } constructor TTwistModifier.Create(aPipe: TPipe); begin inherited; FTotalRotation := 45; end; procedure TTwistModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); var ya: Single; totalH, thisH: Single; cIndex, sIndex, eIndex: Integer; begin sIndex := StartLayer.Index; cIndex := sPoints.Index; eIndex := EndLayer.Index; if (cIndex > sIndex) and (cIndex <= eIndex) then begin totalH := FEndPosition – FStartPosition; thisH := sPoints.GetLayerH – FStartPosition; ya := (FTotalRotation / totalH) * thisH; sPoints.Content.RotationAngle.Y := ya; end; end; procedure TTwistModifier.SetTotalRotation(const Value: Single); begin FTotalRotation := Value; FPipe.RebuildMesh; end; { TPointLayer } function TPointLayer.AbsPoint(i: Integer): TPoint3d; var tTurn: Single; begin tTurn := GetTotalTurn; FContent.FContent.RotationAngle.Y := -tTurn; Result := Points[i] * FContent.FContent.AbsoluteMatrix; end; procedure TPointLayer.AddChild(CPointLayer: TPointLayer); var FOldChild: TPointLayer; begin FOldChild := FChild.FChild; Self.FChild.FChild := CPointLayer; CPointLayer.FParent := Self.FChild; if assigned(FOldChild) then begin CPointLayer.LastChild.AddChild(FOldChild); end; end; function TPointLayer.Content: TPointLayer; begin Result := FContent; end; constructor TPointLayer.Create; begin inherited; FLocalMatrix := TMatrix3D.Identity; FQuaternion := TQuaternion3D.Identity; FPosition := TPosition3d.Create(TPoint3D.Zero); FPosition.OnChange := MatrixChanged; FRotationAngle := TPosition3d.Create(TPoint3D.Zero); FRotationAngle.OnChange := RotationChanged; FScale := TPosition3d.Create(Point3D(1, 1, 1)); FScale.OnChange := MatrixChanged; FAbsMatrixNeedRefresh := True; FGapLayer := False; CreateDummies; end; function TPointLayer.CreateChildAtPosition(CPos: TPoint3d; RepeatNbr: Integer): TPointLayer; var i: Integer; begin Result := TPointLayer.Create; Result.Length := Self.Length; for i := 0 to Length – 1 do Result.Points[i] := Self.Points[i]; Result.Position.point := CPos; if assigned(FChild.FChild) then begin FChild.FChild.Position.point := FChild.FChild.Position.point – CPos; end; Self.AddChild(Result); RepeatNbr := RepeatNbr – 1; if RepeatNbr > 0 then Result := Result.CreateChildAtPosition(CPos, RepeatNbr); end; procedure TPointLayer.CreateDummies; var FContentContent: TPointLayer; begin FChild := TDummyPointLayer.Create; FChild.FParent := Self; FContent := TDummyPointLayer.Create; FContent.FParent := Self; FContentContent := TDummyPointLayer.Create; FContentContent.FParent := FContent; FContent.FContent := FContentContent; end; destructor TPointLayer.Destroy; begin FreeAndNil(FChild); FreeAndNil(FRotationAngle); FreeAndNil(FScale); FreeAndNil(FPosition); FreeAndNil(FContent); inherited; end; function TPointLayer.GeAbsoluteCenter: TPoint3d; var tTurn: Single; begin tTurn := GetTotalTurn; FContent.FContent.RotationAngle.Y := -tTurn; Result := TPoint3D.Zero * FContent.FContent.AbsoluteMatrix; end; function TPointLayer.GetAbsoluteMatrix: TMatrix3D; begin if not FAbsMatrixNeedRefresh then begin Result := FSavedAbsoluteMatrix; end else begin if assigned(FParent) and (FParent is TPointLayer) then Result := FLocalMatrix * TPointLayer(FParent).AbsoluteMatrix else Result := FLocalMatrix; FSavedAbsoluteMatrix := Result; FAbsMatrixNeedRefresh := False; end; end; function TPointLayer.GetDummyChild: TPointLayer; begin result := nil; if assigned(FChild) and (FChild is TDummyPointLayer) then Result := FChild; end; function TPointLayer.GetFirstParent: TPointLayer; begin Result := Self; if assigned(FParent.FParent) then begin Result := FParent.FParent.FirstParent; end; end; function TPointLayer.GetLayer(LIndex: Integer): TPointLayer; begin if LIndex = 0 then Result := Self else if assigned(FChild.FChild) and (LIndex > 0) then begin Result := FChild.FChild.GetLayer(LIndex – 1); end else Result := nil; end; function TPointLayer.GetLayerCount: Integer; begin Result := 1; if assigned(FChild.FChild) then Result := 1 + FChild.FChild.LayerCount; end; function TPointLayer.GetLayerH: Single; begin Result := Self.Position.Y; if assigned(RealParent) then Result := Result + RealParent.GetLayerH; end; function TPointLayer.GetLength: Integer; begin Result := System.Length(Points); end; function TPointLayer.GetRealChild: TPointLayer; begin Result := FChild.FChild; end; function TPointLayer.GetRealParent: TPointLayer; begin Result := nil; if assigned(FParent) then Result := FParent.FParent; end; function TPointLayer.GetTotalTurn: Single; begin Result := RotationAngle.Y; if assigned(FParent) then Result := Result + FParent.GetTotalTurn; end; function TPointLayer.Index: Integer; begin Result := 0; if assigned(FParent) and assigned(FParent.FParent) then Result := 1 + FParent.FParent.Index; end; procedure TPointLayer.InvalidateAbsoluteMatrix; begin FAbsMatrixNeedRefresh := True; if assigned(FChild) then FChild.InvalidateAbsoluteMatrix; end; function TPointLayer.LastChild: TPointLayer; begin Result := Self; if assigned(FChild.FChild) then Result := FChild.FChild.LastChild; end; procedure TPointLayer.MatrixChanged(Sender: TObject); var LeftVector, DirectionVector, UpVector: TPoint3d; RotMatrix: TMatrix3D; begin UpVector := Point3d(0, 1, 0); DirectionVector := Point3d(0, 0, 1); if (FRotationAngle.X <> 0) or (FRotationAngle.Y <> 0) or (FRotationAngle.Z <> 0) then begin RotMatrix := FQuaternion; UpVector := UpVector * RotMatrix; DirectionVector := DirectionVector * RotMatrix; end else begin FQuaternion := TQuaternion3D.Identity; end; LeftVector := UpVector.CrossProduct(DirectionVector); FLocalMatrix.M[0] := LeftVector * FScale.X; FLocalMatrix.m14 := 0; FLocalMatrix.M[1] := UpVector * FScale.Y; FLocalMatrix.m24 := 0; FLocalMatrix.M[2] := DirectionVector * FScale.Z; FLocalMatrix.m34 := 0; FLocalMatrix.m41 := FPosition.X; FLocalMatrix.m42 := FPosition.Y; FLocalMatrix.m43 := FPosition.Z; FAbsMatrixNeedRefresh := True; end; Function TPointLayer.RemoveFirstChild: TPointLayer; begin result := nil; if assigned(FChild.FChild) then begin Result := FChild.FChild; FChild.FChild := nil; if assigned(Result.FChild.FChild) then begin Self.AddChild(Result.FChild.FChild); Result.FChild.FChild := nil; end; end; end; procedure TPointLayer.RotationChanged(Sender: TObject); var q: TQuaternion3D; A: Single; begin FQuaternion := TQuaternion3D.Identity; A := DegToRad(DegNormalize(RotationAngle.X)); if A <> 0 then begin { AbsoluteRight } q := TQuaternion3D.Create(Point3D(1, 0, 0), A); FQuaternion := FQuaternion * q; end; A := DegToRad(DegNormalize(RotationAngle.Y)); if A <> 0 then begin { AbsoluteDirection } q := TQuaternion3D.Create(Point3D(0, 1, 0), A); FQuaternion := FQuaternion * q; end; A := DegToRad(DegNormalize(RotationAngle.Z)); if A <> 0 then begin { AbsoluteUp } q := TQuaternion3D.Create(Point3D(0, 0, 1), A); FQuaternion := FQuaternion * q; end; MatrixChanged(Sender); end; procedure TPointLayer.SetPointsLength(const Value: Integer); begin SetLength(Points, Value); end; { TEmbossModifier } constructor TEmbossModifier.Create(aPipe: TPipe); begin inherited; FStartMargin := 0.02; FEndMargin := 0.02; FThicknessRatio := 0.1; end; procedure TEmbossModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); begin sPoints.Content.Scale.point := Point3D(1 + FThicknessRatio, 0, 1 + FThicknessRatio); end; procedure TEmbossModifier.SetThicknessRatio(const Value: Single); begin FThicknessRatio := Value; FPipe.RebuildMesh; end; { TDummyPointLayer } procedure TDummyPointLayer.CreateDummies; begin // Do Nothing end; { TBreakModifier } constructor TBreakModifier.Create(aPipe: TPipe); begin inherited; FModifyMargins := True; end; procedure TBreakModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); var Index: Integer; FCurrentBendAngle: Single; elpR: Single; begin FCurrentBendAngle := (FBendAngle / (FLayerCount – 2)); FCurrentBendAngle := FCurrentBendAngle / 2; elpR := 1 / cos((FCurrentBendAngle) * (pi / 180)); Index := sPoints.Index; if (Index > StartLayer.Index) and (Index < EndLayer.Index) then begin sPoints.RotationAngle.Z := FCurrentBendAngle; sPoints.Content.Scale.point := Point3D(elpR, 1, 1); sPoints.DummyChild.RotationAngle.Z := FCurrentBendAngle; end; end; procedure TBreakModifier.SetEndMargin(const Value: Single); begin FEndMargin := Value; FPipe.RebuildMesh; end; procedure TBreakModifier.SetStartMargin(const Value: Single); begin FStartMargin := Value; FPipe.RebuildMesh; end; initialization RegisterFmxClasses([TPipeModifier, TBendModifier, TTwistModifier, TEmbossModifier]); end. view raw FMX.MeshObjects.pas hosted with ❤ by GitHub There’s been general interest from the Delphi Google plus community in having these components maintained so it would be good to get the author’s permission to do so. I also think it is worthwhile to submit the code to EMB for inclusion as a standard component. I don’t know the legalities of this since the owner is not responding to this blog, but will report back with any news.
    Reply
  6. Rick Wheeler
    WordPress seemed to remove the URL to Uwe’s code: .gist table { margin-bottom: 0; } This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters Show hidden characters unit FMX.MeshObjects; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, System.RTLConsts, System.Math, System.Math.Vectors, System.UIConsts, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Controls3D, FMX.Types3D, FMX.Objects3D, FMX.Layers3D, FMX.Objects, FMX.Menus, FMX.Edit, FMX.Colors, FMX.MaterialSources, System.StrUtils, System.Generics.Collections, FMX.Ani, FMX.Materials, System.Generics.Defaults; Type TSectionType = (sctNone, sctTop, sctBottom); TFrameType = (ftEllipse, ftRectangle); TPointArray = array of TPoint3d; TDummyPointLayer = class; TPointLayer = class(TObject) private FParent: TPointLayer; FChild: TPointLayer; FContent: TPointLayer; FPosition: TPosition3d; FLocalMatrix: TMatrix3D; FRotationAngle: TPosition3d; FQuaternion: TQuaternion3D; FScale: TPosition3d; FSavedAbsoluteMatrix: TMatrix3D; FAbsMatrixNeedRefresh: Boolean; FGapLayer: Boolean; function GetLength: Integer; procedure SetPointsLength(const Value: Integer); Procedure MatrixChanged(Sender: TObject); procedure RotationChanged(Sender: TObject); virtual; function GetAbsoluteMatrix: TMatrix3D; function GetRealParent: TPointLayer; function GetRealChild: TPointLayer; function GetLayerCount: Integer; function GetFirstParent: TPointLayer; function GetDummyChild: TPointLayer; function GeAbsoluteCenter: TPoint3d; function GetLayerH: Single; protected Procedure CreateDummies; virtual; public Points: TPointArray; Constructor Create; Destructor Destroy; override; Function CreateChildAtPosition(CPos: TPoint3d; RepeatNbr: Integer): TPointLayer; Procedure AddChild(CPointLayer: TPointLayer); Function LastChild: TPointLayer; Function RemoveFirstChild: TPointLayer; Function Index: Integer; Function GetLayer(LIndex: Integer): TPointLayer; Function AbsPoint(i: Integer): TPoint3d; Function GetTotalTurn: Single; Function Content: TPointLayer; Procedure InvalidateAbsoluteMatrix; Property FirstParent: TPointLayer read GetFirstParent; Property RealParent: TPointLayer read GetRealParent; Property RealChild: TPointLayer read GetRealChild; Property DummyChild: TPointLayer read GetDummyChild; Property Length: Integer read GetLength write SetPointsLength; Property Position: TPosition3d read FPosition write FPosition; property AbsoluteMatrix: TMatrix3D read GetAbsoluteMatrix; property LocalMatrix: TMatrix3D read FLocalMatrix; Property AbsoluteCenter: TPoint3d read GeAbsoluteCenter; Property LayerH: Single read GetLayerH; Property GapLayer: Boolean read FGapLayer write FGapLayer; property RotationAngle: TPosition3d read FRotationAngle write FRotationAngle; property Scale: TPosition3d read FScale write FScale; Property LayerCount: Integer read GetLayerCount; end; TDummyPointLayer = class(TPointLayer) protected Procedure CreateDummies; override; end; TLayerList = TList<TPointLayer>; TAnnulus = class(TCustomMesh) private FSectionType: TSectionType; FSectionDegree: Integer; FInnerFrameType: TFrameType; FOuterFrameType: TFrameType; FDrawBounds: Boolean; procedure SetThickness(const Value: Single); procedure SetSubdivisionsAxes(const Value: Integer); procedure SetSectionDegree(const Value: Integer); procedure SetSectionType(const Value: TSectionType); procedure setInnerFrameType(const Value: TFrameType); procedure setOuterFrameType(const Value: TFrameType); procedure SetDrawBounds(const Value: Boolean); protected FSubdivisionsAxes: Integer; FUnitWidth: Single; FUnitHeight: Single; FThickness: Single; FRenderScale: Single; FStartAngle: Single; FTotalAngle: Single; FDistAngle: Single; InnerPoints: TPointArray; OuterPoints: TPointArray; function ExtendPointToPlane(point, Plane, PlaneNormal: TPoint3D; var Distance: Single; var nPoint: TPoint3d): Boolean; Procedure CalcPoints; virtual; Procedure GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); virtual; procedure BuildAnnulus(IPoints, OPoints: TPointArray; Back: Boolean); virtual; procedure RebuildMesh; virtual; procedure Render; override; function FixHeight: Boolean; virtual; procedure SetHeight(const Value: Single); override; procedure SetWidth(const Value: Single); override; procedure SetDepth(const Value: Single); override; public constructor Create(AOwner: TComponent); override; property Data; Property Thickness: Single read FThickness write SetThickness; Property SubdivisionsAxes: Integer read FSubdivisionsAxes write SetSubdivisionsAxes; Property SectionType: TSectionType read FSectionType write SetSectionType; Property SectionDegree: Integer read FSectionDegree write SetSectionDegree; Property InnerFrameType: TFrameType read FInnerFrameType write setInnerFrameType; Property OuterFrameType: TFrameType read FOuterFrameType write setOuterFrameType; Property RenderScale: Single read FRenderScale; Property DrawBounds: Boolean read FDrawBounds write SetDrawBounds; end; TPipe = class; TPipeModifier = class(TFMXObject) private FPipe: TPipe; FStartPosition: Single; FEndPosition: Single; FSubdivisions: Integer; FUseGap: Boolean; FFirstCenter: TPoint3d; FLastCenter: TPoint3d; FModifyMargins: Boolean; procedure SetStartPosition(const Value: Single); procedure SetEndPosition(const Value: Single); procedure SetSubdivisions(const Value: Integer); function InsertPointLayer(StartLayer: TPointLayer; LayerH: Single; UseGap: Boolean = False): TPointLayer; procedure SetModifyMargins(const Value: Boolean); protected FStartMargin: Single; FEndMargin: Single; FLayerCount: Integer; StartLayer, EndLayer, StartMLayer, EndMLayer: TPointLayer; Procedure BeginModify(StartPoints: TPointLayer); virtual; public Constructor Create(aPipe: TPipe); virtual; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); virtual; abstract; Procedure DoModify(StartPoints: TPointLayer); virtual; Procedure EndModify; virtual; published Property StartPosition: Single read FStartPosition write SetStartPosition; Property EndPosition: Single read FEndPosition write SetEndPosition; Property Subdivisions: Integer read FSubdivisions write SetSubdivisions; Property UseGap: Boolean read FUseGap write FUseGap; Property FirstCenter: TPoint3d read FFirstCenter; Property LastCenter: TPoint3d read FLastCenter; Property ModifyMargins: Boolean read FModifyMargins write SetModifyMargins; end; TBendModifier = class(TPipeModifier) private FBendAngle: Single; FTurnAngle: Single; procedure SetBendAngle(const Value: Single); procedure SetTurnAngle(const Value: Single); public Constructor Create(aPipe: TPipe); override; Destructor Destroy; override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; published Property BendAngle: Single read FBendAngle write SetBendAngle; Property TurnAngle: Single read FTurnAngle write SetTurnAngle; end; TBreakModifier = class(TBendModifier) private procedure SetEndMargin(const Value: Single); procedure SetStartMargin(const Value: Single); public Constructor Create(aPipe: TPipe); override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; Property StartMargin: Single read FStartMargin write SetStartMargin; Property EndMargin: Single read FEndMargin write SetEndMargin; end; TTwistModifier = class(TPipeModifier) private FTotalRotation: Single; procedure SetTotalRotation(const Value: Single); public Constructor Create(aPipe: TPipe); override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; published Property TotalRotation: Single read FTotalRotation write SetTotalRotation; end; TEmbossModifier = class(TPipeModifier) private FThicknessRatio: Single; procedure SetThicknessRatio(const Value: Single); public Constructor Create(aPipe: TPipe); override; Procedure ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); override; Property ThicknessRatio: Single read FThicknessRatio write SetThicknessRatio; end; TPipe = class(TAnnulus) private FModifiers: TList<TPipeModifier>; FOnZAxis: Boolean; FFirstCenter: TPoint3d; FLastCenter: TPoint3d; FScaleBeforeRender: Boolean; Procedure SortModifiers; procedure SetOnZAxis(const Value: Boolean); procedure SetScaleBeforeRender(const Value: Boolean); protected function FixHeight: Boolean; override; procedure SetHeight(const Value: Single); override; Procedure GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); override; procedure BuildSectionSurfaces(OuterSectionPoints, InnerSectionPoints: TPointArray); virtual; procedure BuildCylinder(Points: TPointArray; Back: Boolean; var SectionPoints, FirstPoints, LastPoints: TPointArray); virtual; procedure RebuildMesh; override; Procedure Render; override; Procedure ModifiersNotify(Sender: TObject; Const Item: TPipeModifier; Action: TCollectionNotification); public constructor Create(AOwner: TComponent); override; Procedure ClearModifiers; destructor Destroy; override; Property Modifiers: TList<TPipeModifier> read FModifiers; Property OnZAxis: Boolean read FOnZAxis write SetOnZAxis; Property FirstCenter: TPoint3d Read FFirstCenter; Property LastCenter: TPoint3d read FLastCenter; Property ScaleBeforeRender: Boolean read FScaleBeforeRender write SetScaleBeforeRender; end; procedure Register; implementation procedure Register; begin RegisterComponents('3D Shapes', [TAnnulus, TPipe]); end; { TPipe } procedure TAnnulus.BuildAnnulus(IPoints, OPoints: TPointArray; Back: Boolean); var FData: TMeshData; i: Integer; vertexIdx: Integer; indexIdx: Integer; begin FData := Self.Data; vertexIdx := FData.VertexBuffer.Length; indexIdx := FData.IndexBuffer.Length; FData.VertexBuffer.Length := vertexIdx + FSubdivisionsAxes * 2; for i := 0 to FSubdivisionsAxes – 1 do begin FData.VertexBuffer.Vertices[vertexIdx + i] := IPoints[i]; FData.VertexBuffer.TexCoord0[vertexIdx + i] := Pointf((IPoints[i].X + FUnitWidth / 2) / FUnitWidth, (IPoints[i].Z + FUnitHeight / 2) / FUnitHeight); FData.VertexBuffer.Vertices[vertexIdx + i + FSubdivisionsAxes] := OPoints[i]; FData.VertexBuffer.TexCoord0[vertexIdx + i + FSubdivisionsAxes] := Pointf((OPoints[i].X + FUnitWidth / 2) / FUnitWidth, (OPoints[i].Z + FUnitHeight / 2) / FUnitHeight); end; FData.IndexBuffer.Length := indexIdx + FSubdivisionsAxes * 6; if (FSectionType <> sctNone) then FData.IndexBuffer.Length := FData.IndexBuffer.Length – 6; for i := 0 to FSubdivisionsAxes – 1 do begin if (i = FSubdivisionsAxes – 1) then begin if (FSectionType = sctNone) then begin FData.IndexBuffer.Indices[indexIdx + i * 6 + 0] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + i + FSubdivisionsAxes; if Back then begin FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 0] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + 0; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + i + FSubdivisionsAxes; end; end; end else begin FData.IndexBuffer.Indices[indexIdx + i * 6] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + i + FSubdivisionsAxes + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + i + FSubdivisionsAxes; if Back then begin FData.IndexBuffer.Indices[indexIdx + i * 6 + 2] := vertexIdx + i; FData.IndexBuffer.Indices[indexIdx + i * 6 + 1] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 0] := vertexIdx + i + FSubdivisionsAxes; FData.IndexBuffer.Indices[indexIdx + i * 6 + 5] := vertexIdx + i + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 4] := vertexIdx + i + FSubdivisionsAxes + 1; FData.IndexBuffer.Indices[indexIdx + i * 6 + 3] := vertexIdx + i + FSubdivisionsAxes; end; end; end; end; procedure TAnnulus.CalcPoints; var PhiSin, PhiCos: Extended; iWidth, iHeight: Single; rThickness: Single; A: Integer; Angle: Single; rPoint: TPoint3d; iPoint: TPoint3d; iDist: Single; uiWidth, uiHeight: Single; begin SetLength(OuterPoints, FSubdivisionsAxes); SetLength(InnerPoints, FSubdivisionsAxes); FUnitWidth := 1; FUnitHeight := 1; if Width > Depth then FUnitWidth := Width / Depth; if Depth > Width then FUnitHeight := Depth / Width; rThickness := FThickness * (FUnitWidth / Width); FRenderScale := Width / FUnitWidth; iWidth := 1; iHeight := 1; if (FThickness * 2 = Depth) or (FThickness * 2 = Width) then FThickness := FThickness – 0.1; if Width > Depth then iWidth := (Width – (FThickness * 2)) / (Depth – (FThickness * 2)); if Depth > Width then iHeight := (Depth – (FThickness * 2)) / (Width – (FThickness * 2)); FStartAngle := 0; FTotalAngle := 360; if FSectionType <> sctNone then FTotalAngle := 360 – FSectionDegree; if FSectionType = sctBottom then FStartAngle := -(180 – FSectionDegree) / 2; if FSectionType = sctTop then FStartAngle := 180 – (180 – FSectionDegree) / 2; FDistAngle := FTotalAngle / FSubdivisionsAxes; if FSectionType <> sctNone then FDistAngle := FTotalAngle / (FSubdivisionsAxes – 1); for A := 0 to FSubdivisionsAxes – 1 do begin Angle := DegToRad(FStartAngle) + DegToRad(FDistAngle) * A; SinCos(Angle, PhiSin, PhiCos); if FOuterFrameType = ftEllipse then begin OuterPoints[A] := Point3D(PhiCos * 0.5 * FUnitWidth, 0, PhiSin * 0.5 * FUnitHeight); end else begin rPoint := Point3D(PhiCos * 0.5 * FUnitWidth, 0, PhiSin * 0.5 * FUnitHeight); iDist := -1; iPoint := rPoint; Self.ExtendPointToPlane(rPoint, Point3D(FUnitWidth / 2, 0, 0), Point3D(-1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3D(0, 0, FUnitHeight / 2), Point3D(0, 0, -1), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3D(-FUnitWidth / 2, 0, 0), Point3D(1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3D(0, 0, -FUnitHeight / 2), Point3D(0, 0, 1), iDist, iPoint); OuterPoints[A] := iPoint; end; if FInnerFrameType = ftEllipse then begin InnerPoints[A] := Point3D(PhiCos * (0.5 – rThickness) * iWidth, 0, PhiSin * (0.5 – rThickness) * iHeight); end else begin rPoint := Point3D(PhiCos * (0.5 – rThickness) * iWidth, 0, PhiSin * (0.5 – rThickness) * iHeight); uiWidth := (0.5 – rThickness) * iWidth; uiHeight := (0.5 – rThickness) * iHeight; iDist := -1; iPoint := rPoint; Self.ExtendPointToPlane(rPoint, Point3d(uiWidth, 0, 0), Point3d(-1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3d(0, 0, uiHeight), Point3d(0, 0, -1), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3d(-uiWidth, 0, 0), Point3d(1, 0, 0), iDist, iPoint); Self.ExtendPointToPlane(rPoint, Point3d(0, 0, -uiHeight), Point3d(0, 0, 1), iDist, iPoint); InnerPoints[A] := iPoint; end; end; end; constructor TAnnulus.Create(AOwner: TComponent); begin inherited; FThickness := 0.2; FSubdivisionsAxes := 180; FSectionType := sctNone; FSectionDegree := 180; FOuterFrameType := ftEllipse; FInnerFrameType := ftEllipse; RebuildMesh; end; function TAnnulus.ExtendPointToPlane(point, Plane, PlaneNormal: TPoint3D; var Distance: Single; var nPoint: TPoint3d): Boolean; var iPoint: TPoint3d; aDist: Single; begin Result := False; if RayCastPlaneIntersect(TPoint3D.Zero, point, Plane, PlaneNormal, iPoint) then begin aDist := Sqrt(iPoint.Distance(TPoint3D.Zero)); if Distance = -1 then begin Distance := aDist; nPoint := iPoint; Result := True; end else if aDist < Distance then begin Distance := aDist; nPoint := iPoint; Result := True; end; end; end; function TAnnulus.FixHeight: Boolean; begin FHeight := 0.001; Result := True; end; procedure TAnnulus.GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); var i: Integer; begin SetLength(IPoints, Length(InnerPoints)); SetLength(OPoints, Length(OuterPoints)); for i := 0 to High(InnerPoints) do begin IPoints[i] := Point3D(InnerPoints[i].X, PosY, InnerPoints[i].Z); OPoints[i] := Point3D(OuterPoints[i].X, PosY, OuterPoints[i].Z); end; end; procedure TAnnulus.RebuildMesh; var IPoints, OPoints: TPointArray; begin CalcPoints; Data.VertexBuffer.Length := 0; Data.IndexBuffer.Length := 0; GetAnnulusPointsForPosY(-0.001, IPoints, OPoints); BuildAnnulus(IPoints, OPoints, True); GetAnnulusPointsForPosY(0.001, IPoints, OPoints); BuildAnnulus(IPoints, OPoints, False); Data.CalcFaceNormals; end; procedure TAnnulus.Render; begin Context.SetMatrix(TMatrix3D.CreateScaling(TPoint3D.Create(FRenderScale, Height, FRenderScale)) * AbsoluteMatrix); Context.DrawTriangles(Data.VertexBuffer, Data.IndexBuffer, TMaterialSource.ValidMaterial(MaterialSource), AbsoluteOpacity); if FDrawBounds then begin Context.SetMatrix(AbsoluteMatrix); Context.DrawCube(TPoint3D.Zero, Point3D(Width, 0, Depth), AbsoluteOpacity, TalphaColors.Red); end; end; procedure TAnnulus.SetDepth(const Value: Single); var FRefresh: Boolean; begin FRefresh := (Self.Depth <> Value); inherited; if FRefresh then RebuildMesh; end; procedure TAnnulus.SetDrawBounds(const Value: Boolean); begin FDrawBounds := Value; Render; end; procedure TAnnulus.SetHeight(const Value: Single); begin if not FixHeight then inherited; end; procedure TAnnulus.setInnerFrameType(const Value: TFrameType); begin FInnerFrameType := Value; RebuildMesh; end; procedure TAnnulus.setOuterFrameType(const Value: TFrameType); begin FOuterFrameType := Value; RebuildMesh; end; procedure TAnnulus.SetSectionDegree(const Value: Integer); begin FSectionDegree := Value; RebuildMesh; end; procedure TAnnulus.SetSectionType(const Value: TSectionType); begin FSectionType := Value; RebuildMesh; end; procedure TAnnulus.SetSubdivisionsAxes(const Value: Integer); begin FSubdivisionsAxes := Value; RebuildMesh; end; procedure TAnnulus.SetThickness(const Value: Single); begin FThickness := Value; RebuildMesh; end; procedure TAnnulus.SetWidth(const Value: Single); var FRefresh: Boolean; begin FRefresh := (Self.Width <> Value); inherited; if FRefresh then RebuildMesh; end; { TPipe } procedure TPipe.BuildCylinder(Points: TPointArray; Back: Boolean; var SectionPoints, FirstPoints, LastPoints: TPointArray); var FData: TMeshData; i, h, k: Integer; vertexIdx, pVertexIdx: Integer; indexIdx: Integer; hDist, hPos: Single; PhiSin, PhiCos: Extended; cntIndexInRow: Integer; cntVertexInRow: Integer; backM: Integer; Angle: Single; StartPoints: TPointLayer; EndPoints: TPointLayer; SubPoints: TPointArray; done: Boolean; PointsLen: Integer; pModifier: TPipeModifier; pLayer: TPointLayer; LayerCount: Integer; AbsStart: TPoint3d; sctIndex: Integer; begin FData := Self.Data; PointsLen := Length(Points); StartPoints := TPointLayer.Create; if FOnZAxis then StartPoints.RotationAngle.Point := Point3D(90, 90, 0); EndPoints := TPointLayer.Create; StartPoints.AddChild(EndPoints); StartPoints.Length := PointsLen; EndPoints.Length := PointsLen; StartPoints.Position.point := TPoint3D.Zero; EndPoints.Position.point := Point3D(0, Height, 0); for i := 0 to High(Points) do begin StartPoints.Points[i] := Point3D(Points[i].X, 0, Points[i].Z); EndPoints.Points[i] := Point3D(Points[i].X, 0, Points[i].Z); end; backM := 1; if Back then backM := -1; for pModifier in FModifiers do begin pModifier.DoModify(StartPoints); end; LayerCount := StartPoints.LayerCount; cntIndexInRow := PointsLen * 6; if FSectionType <> sctNone then begin cntIndexInRow := (PointsLen – 1) * 6; end; if FScaleBeforeRender then begin for i := 0 to LayerCount – 1 do begin pLayer := StartPoints.GetLayer(i); pLayer.Content.Scale.point := Point3D(pLayer.Content.Scale.point.X * FRenderScale, pLayer.Content.Scale.point.Y, pLayer.Content.Scale.point.Z * FRenderScale); end; end; AbsStart := Point3D(0, -Height / 2, 0); StartPoints.InvalidateAbsoluteMatrix; for i := 0 to LayerCount – 1 do begin vertexIdx := FData.VertexBuffer.Length; indexIdx := FData.IndexBuffer.Length; pLayer := StartPoints.GetLayer(i); FData.VertexBuffer.Length := vertexIdx + PointsLen; for k := 0 to PointsLen – 1 do begin FData.VertexBuffer.Vertices[vertexIdx + k] := pLayer.AbsPoint(k) + AbsStart; FData.VertexBuffer.TexCoord0[vertexIdx + k] := Pointf(k / (PointsLen – 1), pLayer.Position.Y / Height); end; if (FSectionType <> sctNone) and (not pLayer.GapLayer) then begin sctIndex := Length(SectionPoints); SetLength(SectionPoints, sctIndex + 2); SectionPoints[sctIndex] := pLayer.AbsPoint(PointsLen – 1) + AbsStart; SectionPoints[sctIndex + 1] := pLayer.AbsPoint(0) + AbsStart; end; if (i > 0) and (not pLayer.GapLayer) then begin FData.IndexBuffer.Length := indexIdx + cntIndexInRow; pVertexIdx := vertexIdx – PointsLen; for k := 0 to PointsLen – 1 do begin if k = PointsLen – 1 then begin if FSectionType = sctNone then begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := pVertexIdx; if Back then begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := vertexIdx; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := pVertexIdx; end; end; end else begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := pVertexIdx + k + 1; if Back then begin FData.IndexBuffer.Indices[indexIdx + k * 6 + 2] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 1] := vertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 0] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 5] := vertexIdx + k + 1; FData.IndexBuffer.Indices[indexIdx + k * 6 + 4] := pVertexIdx + k; FData.IndexBuffer.Indices[indexIdx + k * 6 + 3] := pVertexIdx + k + 1; end; end; end; end; end; SetLength(FirstPoints, PointsLen); SetLength(LastPoints, PointsLen); for i := 0 to StartPoints.Length – 1 do FirstPoints[i] := StartPoints.AbsPoint(i) + AbsStart; for i := 0 to EndPoints.Length – 1 do LastPoints[i] := EndPoints.AbsPoint(i) + AbsStart; FFirstCenter := StartPoints.AbsoluteCenter; FLastCenter := EndPoints.AbsoluteCenter; for pModifier in FModifiers do begin pModifier.EndModify; end; StartPoints.Free; end; procedure TPipe.BuildSectionSurfaces(OuterSectionPoints, InnerSectionPoints: TPointArray); var p1, p2: TPoint3d; i: Integer; FData: TMeshData; vertexIdx, indexIdx, vIdx: Integer; LevelCount: Integer; begin FData := Self.Data; LevelCount := System.Length(OuterSectionPoints) div 2; // left vertexIdx := FData.VertexBuffer.Length; FData.VertexBuffer.Length := vertexIdx + (LevelCount) * 2; for i := 0 to LevelCount – 1 do begin p1 := OuterSectionPoints[i * 2]; p2 := InnerSectionPoints[i * 2]; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 0] := p1; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 1] := p2; end; indexIdx := FData.IndexBuffer.Length; FData.IndexBuffer.Length := indexIdx + (LevelCount – 1) * 6; for i := 0 to LevelCount – 2 do begin vIdx := vertexIdx + i * 2 + 0; FData.IndexBuffer[indexIdx + i * 6 + 0] := vIdx + 1; FData.IndexBuffer[indexIdx + i * 6 + 1] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 2] := vIdx + 0; FData.IndexBuffer[indexIdx + i * 6 + 3] := vIdx + 3; FData.IndexBuffer[indexIdx + i * 6 + 4] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 5] := vIdx + 1; end; // right vertexIdx := FData.VertexBuffer.Length; FData.VertexBuffer.Length := vertexIdx + (LevelCount) * 2; for i := 0 to LevelCount – 1 do begin p1 := OuterSectionPoints[i * 2 + 1]; p2 := InnerSectionPoints[i * 2 + 1]; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 0] := p1; FData.VertexBuffer.Vertices[vertexIdx + i * 2 + 1] := p2; end; indexIdx := FData.IndexBuffer.Length; FData.IndexBuffer.Length := indexIdx + (LevelCount – 1) * 6; for i := 0 to LevelCount – 2 do begin vIdx := vertexIdx + i * 2 + 0; FData.IndexBuffer[indexIdx + i * 6 + 0] := vIdx + 0; FData.IndexBuffer[indexIdx + i * 6 + 1] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 2] := vIdx + 1; FData.IndexBuffer[indexIdx + i * 6 + 3] := vIdx + 1; FData.IndexBuffer[indexIdx + i * 6 + 4] := vIdx + 2; FData.IndexBuffer[indexIdx + i * 6 + 5] := vIdx + 3; end; end; procedure TPipe.ClearModifiers; var pModifier: TPipeModifier; begin for pModifier in Self.FModifiers do pModifier.Free; FModifiers.Clear; end; constructor TPipe.Create(AOwner: TComponent); begin inherited; Self.TwoSide := True; FModifiers := TList<TPipeModifier>.Create; FModifiers.OnNotify := ModifiersNotify; FOnZAxis := False; FScaleBeforeRender := False; RebuildMesh; end; destructor TPipe.Destroy; begin ClearModifiers; FModifiers.Free; inherited; end; function TPipe.FixHeight: Boolean; begin Result := False; end; procedure TPipe.GetAnnulusPointsForPosY(PosY: Single; var IPoints, OPoints: TPointArray); var i: Integer; begin SetLength(IPoints, Length(InnerPoints)); SetLength(OPoints, Length(OuterPoints)); for i := 0 to High(InnerPoints) do begin IPoints[i] := Point3D(InnerPoints[i].X, PosY, InnerPoints[i].Z); OPoints[i] := Point3D(OuterPoints[i].X, PosY, OuterPoints[i].Z); end; end; procedure TPipe.ModifiersNotify(Sender: TObject; Const Item: TPipeModifier; Action: TCollectionNotification); begin SortModifiers; RebuildMesh; end; procedure TPipe.RebuildMesh; var OuterSectionPoints, InnerSectionPoints: TPointArray; InnerFirstPoints, InnerLastPoints, OuterFirstPoints, OuterLastPoints: TPointArray; begin if FModifiers = nil then exit; CalcPoints; Data.VertexBuffer.Length := 0; Data.IndexBuffer.Length := 0; BuildCylinder(InnerPoints, True, InnerSectionPoints, InnerFirstPoints, InnerLastPoints); BuildCylinder(OuterPoints, False, OuterSectionPoints, OuterFirstPoints, OuterLastPoints); if FSectionType <> sctNone then BuildSectionSurfaces(OuterSectionPoints, InnerSectionPoints); BuildAnnulus(InnerLastPoints, OuterLastPoints, True); BuildAnnulus(InnerFirstPoints, OuterFirstPoints, False); Data.CalcFaceNormals; end; procedure TPipe.Render; begin if not FScaleBeforeRender then Context.SetMatrix(TMatrix3D.CreateScaling(TPoint3D.Create(FRenderScale, 1, FRenderScale)) * AbsoluteMatrix); Context.DrawTriangles(Data.VertexBuffer, Data.IndexBuffer, TMaterialSource.ValidMaterial(MaterialSource), AbsoluteOpacity); end; procedure TPipe.SetHeight(const Value: Single); var FRefresh: Boolean; begin FRefresh := (Self.Height <> Value); inherited; if FRefresh then RebuildMesh; end; procedure TPipe.SetOnZAxis(const Value: Boolean); begin FOnZAxis := Value; RebuildMesh; end; procedure TPipe.SetScaleBeforeRender(const Value: Boolean); begin FScaleBeforeRender := Value; RebuildMesh; end; function CompareLevels(Item1, Item2: TPipeModifier): Integer; begin Result := 0; if TPipeModifier(Item1).StartPosition > TPipeModifier(Item2).StartPosition then begin Result := 1; end else if TPipeModifier(Item1).StartPosition < TPipeModifier(Item2).StartPosition then begin Result := -1; end; end; procedure TPipe.SortModifiers; var Comparer: IComparer<TPipeModifier>; begin Comparer := TDelegatedComparer<TPipeModifier>.Create( function(const Left, Right: TPipeModifier): Integer begin Result := Ceil(Left.StartPosition – Right.StartPosition); if (Result = 0) and (Left is TTwistModifier) then Result := 1; end); FModifiers.Sort(Comparer); end; { TPipeModifier } Function TPipeModifier.InsertPointLayer(StartLayer: TPointLayer; LayerH: Single; UseGap: Boolean = False): TPointLayer; var lParent: TPointLayer; FLayer: TPointLayer; begin Result := nil; FLayer := StartLayer; repeat if abs(LayerH – FLayer.LayerH) < 0.00001 then begin Result := FLayer; if UseGap then begin Result := Result.CreateChildAtPosition(TPoint3D.Zero, 1); Result.GapLayer := True; end; end else if (FLayer.LayerH > LayerH) then begin if assigned(FLayer.RealParent) then begin lParent := FLayer.RealParent; Result := lParent.CreateChildAtPosition(Point3D(0, LayerH – lParent.LayerH, 0), 1); if UseGap then begin Result := Result.CreateChildAtPosition(TPoint3D.Zero, 1); Result.GapLayer := True; end; end; end else if (Result = nil) and (FLayer.RealChild = nil) then begin Result := FLayer.CreateChildAtPosition(Point3D(0, LayerH – FLayer.LayerH, 0), 1); if UseGap then begin Result := Result.CreateChildAtPosition(TPoint3D.Zero, 1); Result.GapLayer := True; end; end; FLayer := FLayer.RealChild; until (Result <> nil) or (FLayer = nil); end; procedure TPipeModifier.BeginModify(StartPoints: TPointLayer); var i: Integer; FLayer: TPointLayer; mLen, dLen: Single; h1, h2, dh: Single; sCnt: Integer; tempList: TList<TPointLayer>; divCount: Integer; begin StartLayer := InsertPointLayer(StartPoints, FStartPosition, FUseGap); EndLayer := InsertPointLayer(StartPoints, FEndPosition, FUseGap); StartMLayer := nil; EndMLayer := nil; divCount := (FSubdivisions + 1); if (FStartMargin > 0) then begin StartMLayer := InsertPointLayer(StartPoints, FStartPosition + FStartMargin); divCount := divCount – 1; end; if (FEndMargin > 0) then begin EndMLayer := InsertPointLayer(StartPoints, FEndPosition – FEndMargin); divCount := divCount – 1; end; mLen := Self.EndPosition – Self.StartPosition – (FEndMargin + FStartMargin); dLen := mLen / divCount; if assigned(StartLayer) and assigned(EndLayer) then begin tempList := TList<TPointLayer>.Create; FLayer := StartLayer; if assigned(StartMLayer) then FLayer := StartMLayer; repeat tempList.Add(FLayer); FLayer := FLayer.RealChild; until (FLayer = EndLayer) or (FLayer = EndMLayer); if assigned(FLayer) then tempList.Add(FLayer); for i := 0 to tempList.Count – 2 do begin h1 := tempList[i].LayerH; h2 := tempList[i + 1].LayerH; sCnt := Round((h2 – h1) / dLen); if sCnt > 1 then begin dh := (h2 – h1) / sCnt; tempList[i].CreateChildAtPosition(Point3D(0, dh, 0), sCnt – 1); end; end; FLayerCount := EndLayer.Index – StartLayer.Index + 1; tempList.Free; end; end; constructor TPipeModifier.Create(aPipe: TPipe); begin inherited Create(aPipe); FPipe := aPipe; FSubdivisions := 10; FStartPosition := -FPipe.Height / 4; FEndPosition := FPipe.Height / 4; FStartMargin := 0; FEndMargin := 0; FModifyMargins := False; end; procedure TPipeModifier.DoModify(StartPoints: TPointLayer); var FLayer: TPointLayer; begin if (FStartPosition > FEndPosition) then exit; if (FStartPosition = FEndPosition) then exit; BeginModify(StartPoints); if (not assigned(StartLayer)) or (not assigned(EndLayer)) then raise Exception.Create('Modifier Position Indexes cant be arranged'); FLayer := StartLayer; if (not FModifyMargins) and assigned(StartMLayer) then FLayer := StartMLayer; Self.ModifySubPoints(FLayer, False); repeat FLayer := FLayer.RealChild; if assigned(FLayer) then Self.ModifySubPoints(FLayer, False); until (FLayer = nil) or ((FLayer = EndMLayer) and (not FModifyMargins)) or (FLayer = EndLayer); end; procedure TPipeModifier.EndModify; begin if assigned(StartLayer) then FFirstCenter := StartLayer.AbsoluteCenter; if assigned(EndLayer) then FLastCenter := EndLayer.AbsoluteCenter; end; procedure TPipeModifier.SetEndPosition(const Value: Single); begin FEndPosition := Value; FPipe.RebuildMesh; end; procedure TPipeModifier.SetModifyMargins(const Value: Boolean); begin FModifyMargins := Value; FPipe.RebuildMesh; end; procedure TPipeModifier.SetStartPosition(const Value: Single); begin FStartPosition := Value; FPipe.RebuildMesh; end; procedure TPipeModifier.SetSubdivisions(const Value: Integer); begin FSubdivisions := Value; FPipe.RebuildMesh; end; { TBendModifier } constructor TBendModifier.Create(aPipe: TPipe); begin inherited; FEndPosition := FPipe.Height / 4; FBendAngle := 90; FTurnAngle := 0; end; destructor TBendModifier.Destroy; begin inherited; end; procedure TBendModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); var Index: Integer; FCurrentBendAngle: Single; begin FCurrentBendAngle := (FBendAngle / (FLayerCount – 1)); Index := sPoints.Index; if sPoints = StartLayer then begin sPoints.DummyChild.RotationAngle.Z := FCurrentBendAngle / 2; sPoints.RotationAngle.Y := FTurnAngle; end else if (Index > StartLayer.Index) and (Index <= EndLayer.Index) then begin sPoints.RotationAngle.Z := FCurrentBendAngle / 2; if sPoints <> EndLayer then begin sPoints.DummyChild.RotationAngle.Z := FCurrentBendAngle / 2; end; end; end; procedure TBendModifier.SetBendAngle(const Value: Single); begin FBendAngle := Value; FPipe.RebuildMesh; end; procedure TBendModifier.SetTurnAngle(const Value: Single); begin FTurnAngle := Value; FPipe.RebuildMesh; end; { TTwistModifier } constructor TTwistModifier.Create(aPipe: TPipe); begin inherited; FTotalRotation := 45; end; procedure TTwistModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); var ya: Single; totalH, thisH: Single; cIndex, sIndex, eIndex: Integer; begin sIndex := StartLayer.Index; cIndex := sPoints.Index; eIndex := EndLayer.Index; if (cIndex > sIndex) and (cIndex <= eIndex) then begin totalH := FEndPosition – FStartPosition; thisH := sPoints.GetLayerH – FStartPosition; ya := (FTotalRotation / totalH) * thisH; sPoints.Content.RotationAngle.Y := ya; end; end; procedure TTwistModifier.SetTotalRotation(const Value: Single); begin FTotalRotation := Value; FPipe.RebuildMesh; end; { TPointLayer } function TPointLayer.AbsPoint(i: Integer): TPoint3d; var tTurn: Single; begin tTurn := GetTotalTurn; FContent.FContent.RotationAngle.Y := -tTurn; Result := Points[i] * FContent.FContent.AbsoluteMatrix; end; procedure TPointLayer.AddChild(CPointLayer: TPointLayer); var FOldChild: TPointLayer; begin FOldChild := FChild.FChild; Self.FChild.FChild := CPointLayer; CPointLayer.FParent := Self.FChild; if assigned(FOldChild) then begin CPointLayer.LastChild.AddChild(FOldChild); end; end; function TPointLayer.Content: TPointLayer; begin Result := FContent; end; constructor TPointLayer.Create; begin inherited; FLocalMatrix := TMatrix3D.Identity; FQuaternion := TQuaternion3D.Identity; FPosition := TPosition3d.Create(TPoint3D.Zero); FPosition.OnChange := MatrixChanged; FRotationAngle := TPosition3d.Create(TPoint3D.Zero); FRotationAngle.OnChange := RotationChanged; FScale := TPosition3d.Create(Point3D(1, 1, 1)); FScale.OnChange := MatrixChanged; FAbsMatrixNeedRefresh := True; FGapLayer := False; CreateDummies; end; function TPointLayer.CreateChildAtPosition(CPos: TPoint3d; RepeatNbr: Integer): TPointLayer; var i: Integer; begin Result := TPointLayer.Create; Result.Length := Self.Length; for i := 0 to Length – 1 do Result.Points[i] := Self.Points[i]; Result.Position.point := CPos; if assigned(FChild.FChild) then begin FChild.FChild.Position.point := FChild.FChild.Position.point – CPos; end; Self.AddChild(Result); RepeatNbr := RepeatNbr – 1; if RepeatNbr > 0 then Result := Result.CreateChildAtPosition(CPos, RepeatNbr); end; procedure TPointLayer.CreateDummies; var FContentContent: TPointLayer; begin FChild := TDummyPointLayer.Create; FChild.FParent := Self; FContent := TDummyPointLayer.Create; FContent.FParent := Self; FContentContent := TDummyPointLayer.Create; FContentContent.FParent := FContent; FContent.FContent := FContentContent; end; destructor TPointLayer.Destroy; begin FreeAndNil(FChild); FreeAndNil(FRotationAngle); FreeAndNil(FScale); FreeAndNil(FPosition); FreeAndNil(FContent); inherited; end; function TPointLayer.GeAbsoluteCenter: TPoint3d; var tTurn: Single; begin tTurn := GetTotalTurn; FContent.FContent.RotationAngle.Y := -tTurn; Result := TPoint3D.Zero * FContent.FContent.AbsoluteMatrix; end; function TPointLayer.GetAbsoluteMatrix: TMatrix3D; begin if not FAbsMatrixNeedRefresh then begin Result := FSavedAbsoluteMatrix; end else begin if assigned(FParent) and (FParent is TPointLayer) then Result := FLocalMatrix * TPointLayer(FParent).AbsoluteMatrix else Result := FLocalMatrix; FSavedAbsoluteMatrix := Result; FAbsMatrixNeedRefresh := False; end; end; function TPointLayer.GetDummyChild: TPointLayer; begin result := nil; if assigned(FChild) and (FChild is TDummyPointLayer) then Result := FChild; end; function TPointLayer.GetFirstParent: TPointLayer; begin Result := Self; if assigned(FParent.FParent) then begin Result := FParent.FParent.FirstParent; end; end; function TPointLayer.GetLayer(LIndex: Integer): TPointLayer; begin if LIndex = 0 then Result := Self else if assigned(FChild.FChild) and (LIndex > 0) then begin Result := FChild.FChild.GetLayer(LIndex – 1); end else Result := nil; end; function TPointLayer.GetLayerCount: Integer; begin Result := 1; if assigned(FChild.FChild) then Result := 1 + FChild.FChild.LayerCount; end; function TPointLayer.GetLayerH: Single; begin Result := Self.Position.Y; if assigned(RealParent) then Result := Result + RealParent.GetLayerH; end; function TPointLayer.GetLength: Integer; begin Result := System.Length(Points); end; function TPointLayer.GetRealChild: TPointLayer; begin Result := FChild.FChild; end; function TPointLayer.GetRealParent: TPointLayer; begin Result := nil; if assigned(FParent) then Result := FParent.FParent; end; function TPointLayer.GetTotalTurn: Single; begin Result := RotationAngle.Y; if assigned(FParent) then Result := Result + FParent.GetTotalTurn; end; function TPointLayer.Index: Integer; begin Result := 0; if assigned(FParent) and assigned(FParent.FParent) then Result := 1 + FParent.FParent.Index; end; procedure TPointLayer.InvalidateAbsoluteMatrix; begin FAbsMatrixNeedRefresh := True; if assigned(FChild) then FChild.InvalidateAbsoluteMatrix; end; function TPointLayer.LastChild: TPointLayer; begin Result := Self; if assigned(FChild.FChild) then Result := FChild.FChild.LastChild; end; procedure TPointLayer.MatrixChanged(Sender: TObject); var LeftVector, DirectionVector, UpVector: TPoint3d; RotMatrix: TMatrix3D; begin UpVector := Point3d(0, 1, 0); DirectionVector := Point3d(0, 0, 1); if (FRotationAngle.X <> 0) or (FRotationAngle.Y <> 0) or (FRotationAngle.Z <> 0) then begin RotMatrix := FQuaternion; UpVector := UpVector * RotMatrix; DirectionVector := DirectionVector * RotMatrix; end else begin FQuaternion := TQuaternion3D.Identity; end; LeftVector := UpVector.CrossProduct(DirectionVector); FLocalMatrix.M[0] := LeftVector * FScale.X; FLocalMatrix.m14 := 0; FLocalMatrix.M[1] := UpVector * FScale.Y; FLocalMatrix.m24 := 0; FLocalMatrix.M[2] := DirectionVector * FScale.Z; FLocalMatrix.m34 := 0; FLocalMatrix.m41 := FPosition.X; FLocalMatrix.m42 := FPosition.Y; FLocalMatrix.m43 := FPosition.Z; FAbsMatrixNeedRefresh := True; end; Function TPointLayer.RemoveFirstChild: TPointLayer; begin result := nil; if assigned(FChild.FChild) then begin Result := FChild.FChild; FChild.FChild := nil; if assigned(Result.FChild.FChild) then begin Self.AddChild(Result.FChild.FChild); Result.FChild.FChild := nil; end; end; end; procedure TPointLayer.RotationChanged(Sender: TObject); var q: TQuaternion3D; A: Single; begin FQuaternion := TQuaternion3D.Identity; A := DegToRad(DegNormalize(RotationAngle.X)); if A <> 0 then begin { AbsoluteRight } q := TQuaternion3D.Create(Point3D(1, 0, 0), A); FQuaternion := FQuaternion * q; end; A := DegToRad(DegNormalize(RotationAngle.Y)); if A <> 0 then begin { AbsoluteDirection } q := TQuaternion3D.Create(Point3D(0, 1, 0), A); FQuaternion := FQuaternion * q; end; A := DegToRad(DegNormalize(RotationAngle.Z)); if A <> 0 then begin { AbsoluteUp } q := TQuaternion3D.Create(Point3D(0, 0, 1), A); FQuaternion := FQuaternion * q; end; MatrixChanged(Sender); end; procedure TPointLayer.SetPointsLength(const Value: Integer); begin SetLength(Points, Value); end; { TEmbossModifier } constructor TEmbossModifier.Create(aPipe: TPipe); begin inherited; FStartMargin := 0.02; FEndMargin := 0.02; FThicknessRatio := 0.1; end; procedure TEmbossModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); begin sPoints.Content.Scale.point := Point3D(1 + FThicknessRatio, 0, 1 + FThicknessRatio); end; procedure TEmbossModifier.SetThicknessRatio(const Value: Single); begin FThicknessRatio := Value; FPipe.RebuildMesh; end; { TDummyPointLayer } procedure TDummyPointLayer.CreateDummies; begin // Do Nothing end; { TBreakModifier } constructor TBreakModifier.Create(aPipe: TPipe); begin inherited; FModifyMargins := True; end; procedure TBreakModifier.ModifySubPoints(sPoints: TPointLayer; isInner: Boolean); var Index: Integer; FCurrentBendAngle: Single; elpR: Single; begin FCurrentBendAngle := (FBendAngle / (FLayerCount – 2)); FCurrentBendAngle := FCurrentBendAngle / 2; elpR := 1 / cos((FCurrentBendAngle) * (pi / 180)); Index := sPoints.Index; if (Index > StartLayer.Index) and (Index < EndLayer.Index) then begin sPoints.RotationAngle.Z := FCurrentBendAngle; sPoints.Content.Scale.point := Point3D(elpR, 1, 1); sPoints.DummyChild.RotationAngle.Z := FCurrentBendAngle; end; end; procedure TBreakModifier.SetEndMargin(const Value: Single); begin FEndMargin := Value; FPipe.RebuildMesh; end; procedure TBreakModifier.SetStartMargin(const Value: Single); begin FStartMargin := Value; FPipe.RebuildMesh; end; initialization RegisterFmxClasses([TPipeModifier, TBendModifier, TTwistModifier, TEmbossModifier]); end. view raw FMX.MeshObjects.pas hosted with ❤ by GitHub
    Reply

Leave a reply to Rick Wheeler Cancel reply