Visual AST editing with drag'n'drop 1s Version
This commit is contained in:
Michael Schimmel
@@ -3,302 +3,484 @@ unit Myc.Fmx.AstEditor.Workspace;
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.SysUtils,
|
||||
System.Types,
|
||||
System.UITypes,
|
||||
System.Math,
|
||||
System.Math.Vectors,
|
||||
System.Generics.Collections,
|
||||
FMX.Types,
|
||||
FMX.Controls,
|
||||
FMX.Graphics,
|
||||
FMX.Objects,
|
||||
Myc.Ast.Nodes;
|
||||
|
||||
const
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
cExecPinColor = TAlphaColors.Lightgreen;
|
||||
FMX.Graphics,
|
||||
FMX.Forms,
|
||||
Myc.Fmx.AstEditor.Layout;
|
||||
|
||||
type
|
||||
TPinConnection = record
|
||||
OutputPin: TControl;
|
||||
InputPin: TControl;
|
||||
constructor Create(AOutputPin, AInputPin: TControl);
|
||||
end;
|
||||
TOnPaintConnectionsEvent = procedure(ASender: TObject; ACanvas: TCanvas) of object;
|
||||
|
||||
TAstWorkspace = class(TStyledControl)
|
||||
TOnDragDropEvent = procedure(ASource, ATarget: TControl; AIndex: Integer) of object;
|
||||
|
||||
TAstWorld = class(TControl)
|
||||
private
|
||||
FConnections: TArray<TPinConnection>;
|
||||
FPanning: TSizeF;
|
||||
FIsPanning: Boolean;
|
||||
FLastPanPos: TPointF;
|
||||
FZoom: Single;
|
||||
FOnPaintConnections: TOnPaintConnectionsEvent;
|
||||
// VISUAL: Drop Marker State
|
||||
FShowDropMarker: Boolean;
|
||||
FDropP1, FDropP2: TPointF;
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure DoDeleteChildren; override;
|
||||
procedure AfterPaint; override; // <--- HIER: Für Zeichnen ÜBER den Kindern
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
procedure InvalidateConnections;
|
||||
property OnPaintConnections: TOnPaintConnectionsEvent read FOnPaintConnections write FOnPaintConnections;
|
||||
end;
|
||||
|
||||
TWorkspace = class(TControl)
|
||||
private
|
||||
const
|
||||
MinZoom = 0.1;
|
||||
MaxZoom = 5.0;
|
||||
ZoomStep = 0.1;
|
||||
private
|
||||
FRootLayer: TAstWorld;
|
||||
FIsPanning: Boolean;
|
||||
FLastMousePos: TPointF;
|
||||
|
||||
FIsDraggingNode: Boolean;
|
||||
FDragSource: TControl;
|
||||
FDragVisual: TControl;
|
||||
FDragOffset: TPointF;
|
||||
|
||||
FCurrentDropTarget: TControl;
|
||||
FCurrentDropIndex: Integer;
|
||||
|
||||
FOnNodeDragDrop: TOnDragDropEvent;
|
||||
|
||||
function GetZoom: Single;
|
||||
procedure SetZoom(const Value: Single);
|
||||
function GetContentOffset: TPointF;
|
||||
procedure SetContentOffset(const Value: TPointF);
|
||||
function GetOnPaintConnections: TOnPaintConnectionsEvent;
|
||||
procedure SetOnPaintConnections(const Value: TOnPaintConnectionsEvent);
|
||||
|
||||
procedure StopDrag;
|
||||
procedure UpdateDropMarker(const ScreenPos: TPointF);
|
||||
protected
|
||||
procedure Loaded; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); override;
|
||||
procedure DblClick; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
procedure Build(const RootNode: IAstNode; const Position: TPointF);
|
||||
function GetChildrenMatrix(var Matrix: TMatrix; var Simple: Boolean): Boolean; override;
|
||||
function Zoom(Factor: Single): Boolean;
|
||||
destructor Destroy; override;
|
||||
|
||||
// Neue Public Methoden, damit Nodes das Panning steuern können
|
||||
procedure ExternalMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
procedure ExternalMouseMove(Shift: TShiftState; X, Y: Single);
|
||||
procedure ExternalMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
function ScreenToWorld(const APoint: TPointF): TPointF;
|
||||
procedure BeginDragNode(ASource: TControl);
|
||||
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property ClipChildren default True;
|
||||
property Cursor default crDefault;
|
||||
property DragMode default TDragMode.dmManual;
|
||||
property Enabled;
|
||||
property Height;
|
||||
property HelpContext;
|
||||
property HelpKeyword;
|
||||
property HelpType;
|
||||
property Hint;
|
||||
property HitTest default True;
|
||||
property Locked;
|
||||
property Margins;
|
||||
property Opacity;
|
||||
property Padding;
|
||||
property PopupMenu;
|
||||
property Position;
|
||||
property RotationAngle;
|
||||
property RotationCenter;
|
||||
property Scale;
|
||||
property Size;
|
||||
property StyleLookup;
|
||||
property Visible;
|
||||
property Width;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property World: TAstWorld read FRootLayer;
|
||||
property Zoom: Single read GetZoom write SetZoom;
|
||||
property ContentOffset: TPointF read GetContentOffset write SetContentOffset;
|
||||
property OnPaintConnections: TOnPaintConnectionsEvent read GetOnPaintConnections write SetOnPaintConnections;
|
||||
|
||||
property OnNodeDragDrop: TOnDragDropEvent read FOnNodeDragDrop write FOnNodeDragDrop;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
System.Math,
|
||||
FMX.Platform,
|
||||
Myc.Fmx.AstEditor,
|
||||
Myc.Fmx.AstEditor.Visualizer;
|
||||
{ TAstWorld }
|
||||
|
||||
{ TPinConnection }
|
||||
|
||||
constructor TPinConnection.Create(AOutputPin, AInputPin: TControl);
|
||||
begin
|
||||
OutputPin := AOutputPin;
|
||||
InputPin := AInputPin;
|
||||
end;
|
||||
|
||||
{ TAstWorkspace }
|
||||
|
||||
constructor TAstWorkspace.Create(AOwner: TComponent);
|
||||
constructor TAstWorld.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
FZoom := 1.0;
|
||||
// Standard-Eigenschaften für einen Arbeitsbereich
|
||||
ClipChildren := True;
|
||||
HitTest := True;
|
||||
HitTest := False;
|
||||
Locked := True;
|
||||
Stored := False;
|
||||
ClipChildren := False;
|
||||
Width := 100;
|
||||
Height := 100;
|
||||
FShowDropMarker := False;
|
||||
end;
|
||||
|
||||
procedure TAstWorkspace.Build(const RootNode: IAstNode; const Position: TPointF);
|
||||
procedure TAstWorld.Paint;
|
||||
begin
|
||||
inherited;
|
||||
if (csDesigning in ComponentState) then
|
||||
DrawDesignBorder;
|
||||
|
||||
// Connections should be BEHIND the nodes, so Paint is the correct place.
|
||||
if Assigned(FOnPaintConnections) then
|
||||
FOnPaintConnections(Self, Canvas);
|
||||
end;
|
||||
|
||||
procedure TAstWorld.AfterPaint;
|
||||
var
|
||||
visu: IAstVisualizer;
|
||||
node: TAstViewNode;
|
||||
ScaleFactor: Single;
|
||||
Radius: Single;
|
||||
Thickness: Single;
|
||||
begin
|
||||
// Löscht alle bestehenden visuellen Knoten
|
||||
DeleteChildren;
|
||||
FConnections := nil;
|
||||
inherited;
|
||||
|
||||
if not Assigned(RootNode) then
|
||||
Exit;
|
||||
|
||||
// Erstellt den Visualizer mit dem Workspace als Kontext
|
||||
visu := TAstVisualizer.Create(Self, Self, 0);
|
||||
node := visu.CallAccept(RootNode);
|
||||
if Assigned(node) then
|
||||
// --- DRAW DROP MARKER (IN FRONT OF NODES) ---
|
||||
if FShowDropMarker then
|
||||
begin
|
||||
node.Position.Point := Position;
|
||||
// Calculate visual sizes inversely proportional to zoom
|
||||
if Scale.X > 0 then
|
||||
ScaleFactor := 1 / Scale.X
|
||||
else
|
||||
ScaleFactor := 1;
|
||||
|
||||
Thickness := 3 * ScaleFactor;
|
||||
Radius := 4 * ScaleFactor;
|
||||
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Color := TAlphaColors.Red;
|
||||
Canvas.Stroke.Thickness := Thickness;
|
||||
Canvas.Stroke.Cap := TStrokeCap.Round;
|
||||
|
||||
// Draw Line
|
||||
Canvas.DrawLine(FDropP1, FDropP2, 1.0);
|
||||
|
||||
// Draw Circles at ends
|
||||
Canvas.Fill.Kind := TBrushKind.Solid;
|
||||
Canvas.Fill.Color := TAlphaColors.Red;
|
||||
|
||||
Canvas.FillEllipse(TRectF.Create(FDropP1.X - Radius, FDropP1.Y - Radius, FDropP1.X + Radius, FDropP1.Y + Radius), 1.0);
|
||||
Canvas.FillEllipse(TRectF.Create(FDropP2.X - Radius, FDropP2.Y - Radius, FDropP2.X + Radius, FDropP2.Y + Radius), 1.0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAstWorkspace.DoDeleteChildren;
|
||||
procedure TAstWorld.InvalidateConnections;
|
||||
begin
|
||||
FConnections := nil;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TAstWorkspace.GetChildrenMatrix(var Matrix: TMatrix; var Simple: Boolean): Boolean;
|
||||
begin
|
||||
Matrix := TMatrix.CreateScaling(FZoom, FZoom) * TMatrix.CreateTranslation(FPanning.cx, FPanning.cy);
|
||||
Simple := (FZoom = 1.0) and (FPanning.cx = 0) and (FPanning.cy = 0);
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
// --- Interne Event Handler ---
|
||||
|
||||
procedure TAstWorkspace.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
ExternalMouseDown(Button, Shift, X, Y);
|
||||
end;
|
||||
|
||||
procedure TAstWorkspace.MouseMove(Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
ExternalMouseMove(Shift, X, Y);
|
||||
end;
|
||||
|
||||
procedure TAstWorkspace.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
ExternalMouseUp(Button, Shift, X, Y);
|
||||
end;
|
||||
|
||||
// --- Externe Steuerung für Nodes ---
|
||||
|
||||
procedure TAstWorkspace.ExternalMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
if (Button = TMouseButton.mbLeft) then
|
||||
begin
|
||||
Capture;
|
||||
FIsPanning := True;
|
||||
FLastPanPos := TPointF.Create(X, Y);
|
||||
Cursor := crHandPoint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAstWorkspace.ExternalMouseMove(Shift: TShiftState; X, Y: Single);
|
||||
var
|
||||
delta: TPointF;
|
||||
begin
|
||||
if FIsPanning then
|
||||
begin
|
||||
delta := TPointF.Create(X - FLastPanPos.X, Y - FLastPanPos.Y);
|
||||
FPanning.cx := FPanning.cx + delta.X;
|
||||
FPanning.cy := FPanning.cy + delta.Y;
|
||||
FLastPanPos := TPointF.Create(X, Y);
|
||||
RecalcAbsolute;
|
||||
RecalcUpdateRect;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAstWorkspace.ExternalMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
if (Button = TMouseButton.mbLeft) and (FIsPanning) then
|
||||
begin
|
||||
ReleaseCapture;
|
||||
FIsPanning := False;
|
||||
Cursor := crDefault;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAstWorkspace.MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
Handled := Zoom(IfThen(WheelDelta > 0, FZoom * 1.1, FZoom / 1.1));
|
||||
end;
|
||||
|
||||
procedure TAstWorkspace.DblClick;
|
||||
begin
|
||||
inherited;
|
||||
// Reset Zoom/Pan on double click
|
||||
FZoom := 1.0;
|
||||
FPanning := TSizeF.Create(0, 0);
|
||||
RecalcAbsolute;
|
||||
RecalcUpdateRect;
|
||||
Repaint;
|
||||
end;
|
||||
|
||||
procedure TAstWorkspace.Paint;
|
||||
{ TWorkspace }
|
||||
|
||||
constructor TWorkspace.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
ClipChildren := True;
|
||||
HitTest := True;
|
||||
|
||||
FRootLayer := TAstWorld.Create(Self);
|
||||
FRootLayer.Parent := Self;
|
||||
FRootLayer.SetBounds(0, 0, 100, 100);
|
||||
FRootLayer.Scale.Point := TPointF.Create(1, 1);
|
||||
end;
|
||||
|
||||
destructor TWorkspace.Destroy;
|
||||
begin
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TWorkspace.Loaded;
|
||||
begin
|
||||
inherited;
|
||||
if FRootLayer <> nil then
|
||||
FRootLayer.BringToFront;
|
||||
end;
|
||||
|
||||
function TWorkspace.ScreenToWorld(const APoint: TPointF): TPointF;
|
||||
begin
|
||||
Result := ScreenToLocal(APoint);
|
||||
Result := FRootLayer.AbsoluteToLocal(LocalToAbsolute(Result));
|
||||
end;
|
||||
|
||||
procedure TWorkspace.BeginDragNode(ASource: TControl);
|
||||
var
|
||||
connection: TPinConnection;
|
||||
startPoint, endPoint, pinCenter: TPointF;
|
||||
path: TPathData;
|
||||
controlPoint1, controlPoint2: TPointF;
|
||||
controlOffset: Single;
|
||||
absoluteStart, absoluteEnd: TPointF;
|
||||
str: string;
|
||||
Snapshot: TBitmap;
|
||||
DragImg: TImage;
|
||||
MouseWorld: TPointF;
|
||||
AbsPos, WorldPos: TPointF;
|
||||
begin
|
||||
if FIsDraggingNode or FIsPanning then
|
||||
Exit;
|
||||
|
||||
FIsDraggingNode := True;
|
||||
FDragSource := ASource;
|
||||
Root.Captured := Self;
|
||||
|
||||
Snapshot := ASource.MakeScreenshot;
|
||||
|
||||
DragImg := TImage.Create(nil);
|
||||
DragImg.Parent := FRootLayer;
|
||||
DragImg.Bitmap := Snapshot;
|
||||
DragImg.WrapMode := TImageWrapMode.Stretch;
|
||||
DragImg.HitTest := False;
|
||||
DragImg.Opacity := 0.7;
|
||||
DragImg.BringToFront;
|
||||
|
||||
AbsPos := ASource.LocalToAbsolute(TPointF.Zero);
|
||||
WorldPos := FRootLayer.AbsoluteToLocal(AbsPos);
|
||||
|
||||
DragImg.SetBounds(WorldPos.X, WorldPos.Y, ASource.Width, ASource.Height);
|
||||
FDragVisual := DragImg;
|
||||
|
||||
MouseWorld := ScreenToWorld(Screen.MousePos);
|
||||
FDragOffset := MouseWorld - WorldPos;
|
||||
|
||||
ASource.Opacity := 0.4;
|
||||
end;
|
||||
|
||||
procedure TWorkspace.UpdateDropMarker(const ScreenPos: TPointF);
|
||||
var
|
||||
Obj: IControl;
|
||||
TargetCtrl: TControl;
|
||||
TargetLocalPos: TPointF;
|
||||
IsHorizontal: Boolean;
|
||||
InsertAfter: Boolean;
|
||||
PTL, PBR: TPointF;
|
||||
P1, P2: TPointF;
|
||||
SourceParent: TControl;
|
||||
TargetContainer: TAutoFitControl;
|
||||
begin
|
||||
FRootLayer.FShowDropMarker := False;
|
||||
FCurrentDropTarget := nil;
|
||||
FCurrentDropIndex := -1;
|
||||
|
||||
if FDragSource = nil then
|
||||
Exit;
|
||||
|
||||
if not (FDragSource.Parent is TControl) then
|
||||
Exit;
|
||||
SourceParent := TControl(FDragSource.Parent);
|
||||
|
||||
// 1. Find Drop Target
|
||||
Obj := ObjectAtPoint(ScreenPos);
|
||||
if (Obj = nil) or not (Obj.GetObject is TControl) then
|
||||
Exit;
|
||||
|
||||
TargetCtrl := TControl(Obj.GetObject);
|
||||
|
||||
// 2. Walk up hierarchy
|
||||
while (TargetCtrl <> nil) and (TargetCtrl.Parent <> SourceParent) do
|
||||
begin
|
||||
TargetCtrl := TargetCtrl.ParentControl;
|
||||
if TargetCtrl = FRootLayer then
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if TargetCtrl = nil then
|
||||
Exit;
|
||||
if TargetCtrl = FDragSource then
|
||||
Exit;
|
||||
|
||||
FCurrentDropTarget := TargetCtrl;
|
||||
|
||||
// 3. Determine Geometry using TAutoFitControl info
|
||||
TargetLocalPos := TargetCtrl.AbsoluteToLocal(ScreenPos);
|
||||
|
||||
IsHorizontal := True; // Default fallback
|
||||
|
||||
if SourceParent is TAutoFitControl then
|
||||
begin
|
||||
TargetContainer := TAutoFitControl(SourceParent);
|
||||
|
||||
if TargetContainer.Orientation = TLayoutOrientation.loHorizontal then
|
||||
IsHorizontal := True
|
||||
else
|
||||
IsHorizontal := False;
|
||||
end;
|
||||
|
||||
// Split logic
|
||||
if IsHorizontal then
|
||||
InsertAfter := TargetLocalPos.X > (TargetCtrl.Width / 2)
|
||||
else
|
||||
InsertAfter := TargetLocalPos.Y > (TargetCtrl.Height / 2);
|
||||
|
||||
// 4. Calculate Index
|
||||
if InsertAfter then
|
||||
FCurrentDropIndex := TargetCtrl.Index + 1
|
||||
else
|
||||
FCurrentDropIndex := TargetCtrl.Index;
|
||||
|
||||
// 5. Calculate Marker Visuals
|
||||
var AbsTL := TargetCtrl.LocalToAbsolute(TPointF.Zero);
|
||||
var AbsBR := TargetCtrl.LocalToAbsolute(TPointF.Create(TargetCtrl.Width, TargetCtrl.Height));
|
||||
|
||||
PTL := FRootLayer.AbsoluteToLocal(AbsTL);
|
||||
PBR := FRootLayer.AbsoluteToLocal(AbsBR);
|
||||
|
||||
if IsHorizontal then
|
||||
begin
|
||||
// Vertical Line
|
||||
var XPos := PTL.X;
|
||||
if InsertAfter then
|
||||
XPos := PBR.X;
|
||||
|
||||
if InsertAfter then
|
||||
XPos := XPos + 2
|
||||
else
|
||||
XPos := XPos - 2;
|
||||
|
||||
P1 := TPointF.Create(XPos, PTL.Y);
|
||||
P2 := TPointF.Create(XPos, PBR.Y);
|
||||
end
|
||||
else
|
||||
begin
|
||||
// Horizontal Line
|
||||
var YPos := PTL.Y;
|
||||
if InsertAfter then
|
||||
YPos := PBR.Y;
|
||||
|
||||
if InsertAfter then
|
||||
YPos := YPos + 2
|
||||
else
|
||||
YPos := YPos - 2;
|
||||
|
||||
P1 := TPointF.Create(PTL.X, YPos);
|
||||
P2 := TPointF.Create(PBR.X, YPos);
|
||||
end;
|
||||
|
||||
FRootLayer.FDropP1 := P1;
|
||||
FRootLayer.FDropP2 := P2;
|
||||
FRootLayer.FShowDropMarker := True;
|
||||
end;
|
||||
|
||||
procedure TWorkspace.StopDrag;
|
||||
begin
|
||||
if not FIsDraggingNode then
|
||||
Exit;
|
||||
|
||||
if Assigned(FDragVisual) then
|
||||
begin
|
||||
FDragVisual.Parent := nil;
|
||||
FDragVisual.Free;
|
||||
FDragVisual := nil;
|
||||
end;
|
||||
|
||||
if Assigned(FDragSource) then
|
||||
FDragSource.Opacity := 1.0;
|
||||
|
||||
FRootLayer.FShowDropMarker := False;
|
||||
FRootLayer.Repaint;
|
||||
|
||||
if Assigned(FOnNodeDragDrop) and Assigned(FCurrentDropTarget) and (FCurrentDropIndex >= 0) then
|
||||
FOnNodeDragDrop(FDragSource, FCurrentDropTarget, FCurrentDropIndex);
|
||||
|
||||
FIsDraggingNode := False;
|
||||
FDragSource := nil;
|
||||
FCurrentDropTarget := nil;
|
||||
Root.Captured := nil;
|
||||
end;
|
||||
|
||||
procedure TWorkspace.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if not FIsDraggingNode and (Button in [TMouseButton.mbLeft, TMouseButton.mbMiddle]) then
|
||||
begin
|
||||
FIsPanning := True;
|
||||
FLastMousePos := TPointF.Create(X, Y);
|
||||
Root.Captured := Self;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TWorkspace.MouseMove(Shift: TShiftState; X, Y: Single);
|
||||
var
|
||||
LCurrentPos: TPointF;
|
||||
LDelta: TPointF;
|
||||
LWorldPos: TPointF;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Thickness := 2;
|
||||
|
||||
for connection in FConnections do
|
||||
if FIsDraggingNode then
|
||||
begin
|
||||
// Safety check if pins are still valid/visible
|
||||
if (connection.OutputPin = nil)
|
||||
or (connection.InputPin = nil)
|
||||
or (connection.OutputPin.Root <> Self.Root)
|
||||
or (connection.InputPin.Root <> Self.Root) then
|
||||
continue;
|
||||
|
||||
pinCenter := TPointF.Create(connection.OutputPin.Width / 2, connection.OutputPin.Height / 2);
|
||||
absoluteStart := connection.OutputPin.LocalToAbsolute(pinCenter);
|
||||
|
||||
pinCenter := TPointF.Create(connection.InputPin.Width / 2, connection.InputPin.Height / 2);
|
||||
absoluteEnd := connection.InputPin.LocalToAbsolute(pinCenter);
|
||||
|
||||
startPoint := AbsoluteToLocal(absoluteStart);
|
||||
endPoint := AbsoluteToLocal(absoluteEnd);
|
||||
|
||||
str := connection.InputPin.TagString;
|
||||
if Pos('data', str) = 0 then
|
||||
Canvas.Stroke.Color := cExecPinColor
|
||||
else
|
||||
Canvas.Stroke.Color := cDataPinColor;
|
||||
|
||||
path := TPathData.Create;
|
||||
try
|
||||
controlOffset := Max(25, 0.5 * endPoint.Distance(startPoint));
|
||||
controlPoint1 := TPointF.Create(startPoint.X + controlOffset, startPoint.Y);
|
||||
controlPoint2 := TPointF.Create(endPoint.X - controlOffset, endPoint.Y);
|
||||
path.MoveTo(startPoint);
|
||||
path.CurveTo(controlPoint1, controlPoint2, endPoint);
|
||||
Canvas.DrawPath(path, 1.0);
|
||||
finally
|
||||
path.Free;
|
||||
if Assigned(FDragVisual) then
|
||||
begin
|
||||
LWorldPos := ScreenToWorld(Screen.MousePos);
|
||||
FDragVisual.Position.Point := LWorldPos - FDragOffset;
|
||||
end;
|
||||
|
||||
UpdateDropMarker(Screen.MousePos);
|
||||
|
||||
FRootLayer.Repaint;
|
||||
end
|
||||
else if FIsPanning then
|
||||
begin
|
||||
LCurrentPos := TPointF.Create(X, Y);
|
||||
LDelta := LCurrentPos - FLastMousePos;
|
||||
|
||||
FRootLayer.Position.Point := FRootLayer.Position.Point + LDelta;
|
||||
|
||||
FLastMousePos := LCurrentPos;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TAstWorkspace.Zoom(Factor: Single): Boolean;
|
||||
var
|
||||
mouseService: IFMXMouseService;
|
||||
mousePos: TPointF;
|
||||
procedure TWorkspace.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
Result := TPlatformServices.Current.SupportsPlatformService(IFMXMouseService, mouseService);
|
||||
if Result then
|
||||
inherited;
|
||||
if FIsDraggingNode then
|
||||
begin
|
||||
mousePos := ScreenToLocal(mouseService.GetMousePos);
|
||||
Factor := Max(0.2, Min(3.0, Factor));
|
||||
|
||||
// Adjust panning to zoom towards mouse position
|
||||
FPanning.cx := mousePos.X * (1 - Factor / FZoom) + FPanning.cx * (Factor / FZoom);
|
||||
FPanning.cy := mousePos.Y * (1 - Factor / FZoom) + FPanning.cy * (Factor / FZoom);
|
||||
|
||||
FZoom := Factor;
|
||||
|
||||
RecalcAbsolute;
|
||||
RecalcUpdateRect;
|
||||
Repaint;
|
||||
StopDrag;
|
||||
end
|
||||
else if FIsPanning then
|
||||
begin
|
||||
FIsPanning := False;
|
||||
Root.Captured := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TWorkspace.MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean);
|
||||
var
|
||||
LOldZoom, LNewZoom: Single;
|
||||
LScaleRatio: Single;
|
||||
LMousePosLocal: TPointF;
|
||||
LOffset: TPointF;
|
||||
begin
|
||||
LOldZoom := Zoom;
|
||||
|
||||
if WheelDelta > 0 then
|
||||
LNewZoom := LOldZoom + ZoomStep
|
||||
else
|
||||
LNewZoom := LOldZoom - ZoomStep;
|
||||
|
||||
LNewZoom := EnsureRange(LNewZoom, MinZoom, MaxZoom);
|
||||
|
||||
if not SameValue(LNewZoom, LOldZoom, TEpsilon.Vector) then
|
||||
begin
|
||||
LMousePosLocal := ScreenToLocal(Screen.MousePos);
|
||||
LOffset := LMousePosLocal - FRootLayer.Position.Point;
|
||||
LScaleRatio := LNewZoom / LOldZoom;
|
||||
|
||||
FRootLayer.Position.Point := LMousePosLocal - (LOffset * LScaleRatio);
|
||||
SetZoom(LNewZoom);
|
||||
end;
|
||||
Handled := True;
|
||||
|
||||
if not Handled then
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TWorkspace.GetZoom: Single;
|
||||
begin
|
||||
Result := FRootLayer.Scale.X;
|
||||
end;
|
||||
|
||||
procedure TWorkspace.SetZoom(const Value: Single);
|
||||
begin
|
||||
FRootLayer.Scale.Point := TPointF.Create(Value, Value);
|
||||
end;
|
||||
|
||||
function TWorkspace.GetContentOffset: TPointF;
|
||||
begin
|
||||
Result := FRootLayer.Position.Point;
|
||||
end;
|
||||
|
||||
procedure TWorkspace.SetContentOffset(const Value: TPointF);
|
||||
begin
|
||||
FRootLayer.Position.Point := Value;
|
||||
end;
|
||||
|
||||
function TWorkspace.GetOnPaintConnections: TOnPaintConnectionsEvent;
|
||||
begin
|
||||
Result := FRootLayer.OnPaintConnections;
|
||||
end;
|
||||
|
||||
procedure TWorkspace.SetOnPaintConnections(const Value: TOnPaintConnectionsEvent);
|
||||
begin
|
||||
FRootLayer.OnPaintConnections := Value;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Reference in New Issue
Block a user