Skip to content

Instantly share code, notes, and snippets.

@UweRaabe

UweRaabe/FMX.MeshObjects.pas

Created February 16, 2016 11:53
Show Gist options
  • Star 4 You must be signed in to star a gist
  • Fork 2 You must be signed in to fork a gist
  • Save UweRaabe/d8404c679e98edac5f1d to your computer and use it in GitHub Desktop.
Save UweRaabe/d8404c679e98edac5f1d to your computer and use it in GitHub Desktop.
Download ZIP
Raw
FMX.MeshObjects.pas
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.
@UweRaabe
Copy link
Author

Taken from DelphiScience and adapted to Delphi 10 Seattle.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment