Visual AST editing with drag'n'drop 1s Version
This commit is contained in:
File diff suppressed because one or more lines are too long
@@ -30,7 +30,8 @@ uses
|
||||
Myc.Fmx.AstEditor.Visualizer in '..\Src\AST\Myc.Fmx.AstEditor.Visualizer.pas',
|
||||
Myc.Fmx.AstEditor.Workspace in '..\Src\AST\Myc.Fmx.AstEditor.Workspace.pas',
|
||||
Myc.Fmx.AstEditor.Controller in '..\Src\AST\Myc.Fmx.AstEditor.Controller.pas',
|
||||
Myc.Fmx.AstEditor in '..\Src\AST\Myc.Fmx.AstEditor.pas';
|
||||
Myc.Fmx.AstEditor in '..\Src\AST\Myc.Fmx.AstEditor.pas',
|
||||
Myc.Fmx.AstEditor.Layout in '..\Src\AST\Myc.Fmx.AstEditor.Layout.pas';
|
||||
|
||||
{$R *.res}
|
||||
|
||||
|
||||
@@ -161,6 +161,7 @@
|
||||
<DCCReference Include="..\Src\AST\Myc.Fmx.AstEditor.Workspace.pas"/>
|
||||
<DCCReference Include="..\Src\AST\Myc.Fmx.AstEditor.Controller.pas"/>
|
||||
<DCCReference Include="..\Src\AST\Myc.Fmx.AstEditor.pas"/>
|
||||
<DCCReference Include="..\Src\AST\Myc.Fmx.AstEditor.Layout.pas"/>
|
||||
<BuildConfiguration Include="Base">
|
||||
<Key>Base</Key>
|
||||
</BuildConfiguration>
|
||||
|
||||
@@ -119,7 +119,7 @@ type
|
||||
FCurrUnboundAst: IAstNode;
|
||||
FCurrExec: TCompiledFunction;
|
||||
FEnvironment: TAstEnvironment;
|
||||
FWorkspace: TAstWorkspace;
|
||||
FWorkspace: TWorkspace; // Changed to TWorkspace
|
||||
FController: TAstEditorController; // The UI Controller
|
||||
FScriptUpdate: Boolean;
|
||||
FTriggerTest: TAstEnvironment;
|
||||
@@ -159,13 +159,15 @@ begin
|
||||
FEnvironment := TAstEnvironment.Construct(TAst.CreateScope(nil));
|
||||
|
||||
// 2. Initialize Workspace
|
||||
FWorkspace := TAstWorkspace.Create(Panel2);
|
||||
// TWorkspace is now a simple viewport control
|
||||
FWorkspace := TWorkspace.Create(Panel2);
|
||||
FWorkspace.Parent := Panel2;
|
||||
FWorkspace.Align := TAlignLayout.Client;
|
||||
FWorkspace.ClipChildren := true;
|
||||
FWorkspace.OnMouseDown := WorkspaceMouseDown;
|
||||
|
||||
// 3. Initialize Controller (connects Env and Workspace)
|
||||
// The Controller will manage the nodes inside FWorkspace.World
|
||||
FController := TAstEditorController.Create(FEnvironment, FWorkspace);
|
||||
|
||||
// 4. Register the SMA factory into the environment
|
||||
@@ -295,6 +297,7 @@ begin
|
||||
exit;
|
||||
|
||||
// Use the Controller to build, validate and show the UI
|
||||
// The controller internally clears FWorkspace.World and adds nodes there.
|
||||
FController.SetRoot(FCurrUnboundAst);
|
||||
end;
|
||||
|
||||
@@ -419,8 +422,9 @@ end;
|
||||
|
||||
procedure TForm1.ClearButtonClick(Sender: TObject);
|
||||
begin
|
||||
FWorkspace.DeleteChildren;
|
||||
FWorkspace.Repaint;
|
||||
// Clear content of world (not workspace itself, as it has the root layer)
|
||||
FWorkspace.World.DeleteChildren;
|
||||
FWorkspace.World.Repaint;
|
||||
end;
|
||||
|
||||
procedure TForm1.CompilerStageBoxChange(Sender: TObject);
|
||||
@@ -886,8 +890,8 @@ procedure TForm1.UpdateScript;
|
||||
begin
|
||||
PrintScript(FCurrUnboundAst);
|
||||
|
||||
FWorkspace.DeleteChildren;
|
||||
ShowVizualization(14, 14);
|
||||
// Clear and redraw via Controller
|
||||
FController.SetRoot(FCurrUnboundAst);
|
||||
end;
|
||||
|
||||
procedure TForm1.WorkspaceMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
@@ -897,9 +901,6 @@ begin
|
||||
ShowVizualization(X, Y);
|
||||
end;
|
||||
|
||||
// ... Copy of the rest of the file logic (Save, Load, Dump, etc.) ...
|
||||
// To ensure completeness, here are the remaining methods:
|
||||
|
||||
procedure TForm1.SaveUserLibButtonClick(Sender: TObject);
|
||||
var
|
||||
rootNode: IAstNode;
|
||||
|
||||
@@ -6,7 +6,9 @@ uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.Types,
|
||||
System.Math.Vectors,
|
||||
System.Generics.Collections,
|
||||
FMX.Types,
|
||||
FMX.Controls,
|
||||
Myc.Ast,
|
||||
Myc.Ast.Nodes,
|
||||
@@ -24,13 +26,11 @@ type
|
||||
type
|
||||
TNodeMap = TDictionary<IAstIdentity, TAstViewNode>;
|
||||
|
||||
// Visitor to propagate Type Information from TypedAST to Visual Nodes
|
||||
TTypePropagator = class(TAstVisitor)
|
||||
private
|
||||
FMap: TNodeMap;
|
||||
procedure ApplyType(const Node: IAstNode);
|
||||
protected
|
||||
// Central hook: Called for every node during traversal
|
||||
procedure Accept(const Node: IAstNode); override;
|
||||
public
|
||||
constructor Create(AMap: TNodeMap);
|
||||
@@ -38,7 +38,7 @@ type
|
||||
|
||||
private
|
||||
FEnv: TAstEnvironment;
|
||||
FWorkspace: TAstWorkspace;
|
||||
FWorkspace: TWorkspace;
|
||||
FNodeMap: TNodeMap;
|
||||
FRootViewNode: TAstViewNode;
|
||||
|
||||
@@ -46,9 +46,13 @@ type
|
||||
procedure ClearVisuals;
|
||||
procedure ApplyErrors(const Log: ICompilerLog);
|
||||
procedure ApplyTypes(const TypedAst: IAstNode);
|
||||
procedure RootResized(Sender: TObject);
|
||||
|
||||
// This signature MUST match TOnDragDropEvent in Myc.Fmx.AstEditor.Workspace
|
||||
procedure HandleNodeDragDrop(ASource, ATarget: TControl; AIndex: Integer);
|
||||
|
||||
public
|
||||
constructor Create(const AEnv: TAstEnvironment; AWorkspace: TAstWorkspace);
|
||||
constructor Create(const AEnv: TAstEnvironment; AWorkspace: TWorkspace);
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure ValidateAndShow;
|
||||
@@ -58,39 +62,119 @@ type
|
||||
implementation
|
||||
|
||||
uses
|
||||
Myc.Data.Value;
|
||||
Myc.Data.Value,
|
||||
Myc.Fmx.AstEditor.Visualizer;
|
||||
|
||||
{ TAstEditorController }
|
||||
|
||||
constructor TAstEditorController.Create(const AEnv: TAstEnvironment; AWorkspace: TAstWorkspace);
|
||||
constructor TAstEditorController.Create(const AEnv: TAstEnvironment; AWorkspace: TWorkspace);
|
||||
begin
|
||||
inherited Create;
|
||||
FEnv := AEnv;
|
||||
FWorkspace := AWorkspace;
|
||||
// Connect the event
|
||||
FWorkspace.OnNodeDragDrop := HandleNodeDragDrop;
|
||||
FNodeMap := TNodeMap.Create;
|
||||
end;
|
||||
|
||||
destructor TAstEditorController.Destroy;
|
||||
begin
|
||||
SetRoot(nil);
|
||||
FNodeMap.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TAstEditorController.SetRoot(const AstNode: IAstNode);
|
||||
procedure TAstEditorController.HandleNodeDragDrop(ASource, ATarget: TControl; AIndex: Integer);
|
||||
var
|
||||
SourceParent: TControl;
|
||||
ContainerOwner: TAstViewNode;
|
||||
Reorderable: IReorderable;
|
||||
SourceIdx, TargetIdx: Integer;
|
||||
NewAst: IAstNode;
|
||||
begin
|
||||
FWorkspace.DeleteChildren;
|
||||
FWorkspace.Build(AstNode, TPointF.Create(50, 50));
|
||||
// Validation
|
||||
if (ASource = nil) or (AIndex < 0) then
|
||||
Exit;
|
||||
if not (ASource is TAstViewNode) then
|
||||
Exit;
|
||||
|
||||
if FWorkspace.ChildrenCount > 0 then
|
||||
// Explicit cast to TControl to avoid TFmxObject incompatibility
|
||||
if not (ASource.Parent is TControl) then
|
||||
Exit;
|
||||
SourceParent := TControl(ASource.Parent);
|
||||
|
||||
// We need to find the ViewNode responsible for this container that implements IReorderable.
|
||||
ContainerOwner := nil;
|
||||
|
||||
// 1. Check if the direct parent is the ViewNode (Direct list handler scenario)
|
||||
// TNodeListHandler adds items directly to the ViewNode, so SourceParent IS the ViewNode.
|
||||
if (SourceParent is TAstViewNode) then
|
||||
begin
|
||||
for var i := 0 to FWorkspace.ChildrenCount - 1 do
|
||||
if FWorkspace.Children[i] is TAstViewNode then
|
||||
begin
|
||||
FRootViewNode := TAstViewNode(FWorkspace.Children[i]);
|
||||
break;
|
||||
end;
|
||||
ContainerOwner := TAstViewNode(SourceParent);
|
||||
// Only keep it if it actually supports reordering
|
||||
if not Supports(ContainerOwner.Handler, IReorderable, Reorderable) then
|
||||
ContainerOwner := nil;
|
||||
end;
|
||||
|
||||
// 2. Fallback: Check grandparent (Intermediate container scenario)
|
||||
// Used when items are wrapped in an intermediate TAutoFitControl (e.g. by AddExpr).
|
||||
if (ContainerOwner = nil) and (SourceParent.Parent is TAstViewNode) then
|
||||
begin
|
||||
ContainerOwner := TAstViewNode(SourceParent.Parent);
|
||||
if not Supports(ContainerOwner.Handler, IReorderable, Reorderable) then
|
||||
ContainerOwner := nil;
|
||||
end;
|
||||
|
||||
// Execute Move
|
||||
if (ContainerOwner <> nil) and (Reorderable <> nil) then
|
||||
begin
|
||||
if Reorderable.CanDrag(ASource) then
|
||||
begin
|
||||
SourceIdx := ASource.Index;
|
||||
TargetIdx := AIndex;
|
||||
|
||||
if SourceIdx <> TargetIdx then
|
||||
begin
|
||||
// A. Update internal state in the Handler (modifies FChildNodes list)
|
||||
Reorderable.MoveChild(SourceIdx, TargetIdx);
|
||||
|
||||
// B. Rebuild UI Logic
|
||||
// Since the handler's internal list is now reordered, CreateAst
|
||||
// will produce a new AST with the correct order.
|
||||
NewAst := FRootViewNode.CreateAst;
|
||||
|
||||
// C. Full UI Refresh
|
||||
// ValidateAndShow only annotates. SetRoot destroys the old visual tree
|
||||
// and builds a new one from the freshly generated AST.
|
||||
SetRoot(NewAst);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAstEditorController.SetRoot(const AstNode: IAstNode);
|
||||
var
|
||||
Visualizer: IAstVisualizer;
|
||||
begin
|
||||
FWorkspace.World.DeleteChildren;
|
||||
if Assigned(FRootViewNode) then
|
||||
FRootViewNode.OnResized := nil;
|
||||
FRootViewNode := nil;
|
||||
|
||||
if not Assigned(AstNode) then
|
||||
Exit;
|
||||
|
||||
Visualizer := TAstVisualizer.Create(FWorkspace, FWorkspace.World, 0);
|
||||
FRootViewNode := Visualizer.CallAccept(AstNode);
|
||||
|
||||
if Assigned(FRootViewNode) then
|
||||
begin
|
||||
FWorkspace.World.Size := FRootViewNode.Size;
|
||||
FRootViewNode.OnResized := RootResized;
|
||||
FRootViewNode.Position.Point := TPointF.Create(50, 50);
|
||||
end;
|
||||
|
||||
if Assigned(FRootViewNode) then
|
||||
ValidateAndShow;
|
||||
end;
|
||||
|
||||
@@ -109,9 +193,6 @@ begin
|
||||
if child is TAstViewNode then
|
||||
begin
|
||||
viewNode := TAstViewNode(child);
|
||||
// Register Identity -> ViewNode
|
||||
// Note: ReconstructAst updates the Node property of the ViewNode,
|
||||
// so we must ensure we use the identity from the *logical* node held by the view.
|
||||
if Assigned(viewNode.Node) and Assigned(viewNode.Node.Identity) then
|
||||
begin
|
||||
FNodeMap.AddOrSetValue(viewNode.Node.Identity, viewNode);
|
||||
@@ -162,13 +243,17 @@ begin
|
||||
|
||||
propagator := TTypePropagator.Create(FNodeMap);
|
||||
try
|
||||
// Start traversal. The overload Accept(Node) will be called.
|
||||
propagator.Accept(TypedAst);
|
||||
finally
|
||||
propagator.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAstEditorController.RootResized(Sender: TObject);
|
||||
begin
|
||||
FWorkspace.World.Size := FRootViewNode.Size;
|
||||
end;
|
||||
|
||||
procedure TAstEditorController.ValidateAndShow;
|
||||
var
|
||||
logicalAst: IAstNode;
|
||||
@@ -176,26 +261,18 @@ begin
|
||||
if not Assigned(FRootViewNode) then
|
||||
Exit;
|
||||
|
||||
// 1. Reconstruct Logical AST from UI
|
||||
// This updates the .Node property on ViewNodes with fresh Identities (if configured) or reuses them.
|
||||
logicalAst := FRootViewNode.CreateAst;
|
||||
|
||||
// 2. Rebuild Mapping based on the new logical nodes
|
||||
FNodeMap.Clear;
|
||||
CollectNodes(FWorkspace);
|
||||
CollectNodes(FWorkspace.World);
|
||||
|
||||
// 3. Clear visuals
|
||||
ClearVisuals;
|
||||
|
||||
// 4. Compile
|
||||
try
|
||||
// To get type info, we re-bind/check manually as Compile doesn't return the TypedAST.
|
||||
var log := TCompilerLog.Create as ICompilerLog;
|
||||
|
||||
// We need to expand macros first to match the structure Compile used
|
||||
var expanded := FEnv.ExpandMacros(logicalAst);
|
||||
var typedAst := FEnv.Bind(expanded, [], log);
|
||||
|
||||
var specAst := FEnv.Specialize(typedAst);
|
||||
|
||||
ApplyTypes(specAst);
|
||||
@@ -214,7 +291,7 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
FWorkspace.Repaint;
|
||||
FWorkspace.World.Repaint;
|
||||
end;
|
||||
|
||||
{ TAstEditorController.TTypePropagator }
|
||||
@@ -247,11 +324,7 @@ procedure TAstEditorController.TTypePropagator.Accept(const Node: IAstNode);
|
||||
begin
|
||||
if Node = nil then
|
||||
Exit;
|
||||
|
||||
// 1. Apply side effect
|
||||
ApplyType(Node);
|
||||
|
||||
// 2. Continue traversal (Standard TAstVisitor logic calls VisitXY which calls Accept for children)
|
||||
Node.Accept(Self);
|
||||
end;
|
||||
|
||||
|
||||
@@ -17,12 +17,13 @@ uses
|
||||
Myc.Ast,
|
||||
Myc.Ast.Nodes,
|
||||
Myc.Ast.Identities,
|
||||
Myc.Fmx.AstEditor.Layout,
|
||||
Myc.Fmx.AstEditor;
|
||||
|
||||
type
|
||||
// --- Abstract List Base ---
|
||||
// Handles layout, brackets (from Identity), and child iteration
|
||||
TNodeListHandler<T: IAstNode> = class(TBaseNodeHandler<INodeList<T>>)
|
||||
// Now implements IReorderable to support drag & drop reordering
|
||||
TNodeListHandler<T: IAstNode> = class(TBaseNodeHandler<INodeList<T>>, IReorderable)
|
||||
protected
|
||||
FChildNodes: TList<TAstViewNode>;
|
||||
function GetOrientation: TLayoutOrientation; virtual; abstract;
|
||||
@@ -32,6 +33,10 @@ type
|
||||
destructor Destroy; override;
|
||||
procedure BuildUI(OwnerNode: TAstViewNode); override;
|
||||
function ReconstructAst(OwnerNode: TAstViewNode): IAstNode; override; abstract;
|
||||
|
||||
// IReorderable Implementation
|
||||
function CanDrag(Child: TControl): Boolean;
|
||||
procedure MoveChild(SourceIndex, TargetIndex: Integer);
|
||||
end;
|
||||
|
||||
// --- Concrete List Handlers ---
|
||||
@@ -352,6 +357,38 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
// IReorderable Implementation
|
||||
|
||||
function TNodeListHandler<T>.CanDrag(Child: TControl): Boolean;
|
||||
begin
|
||||
// Allow dragging only if the child is one of our managed ViewNodes
|
||||
Result := (Child is TAstViewNode) and FChildNodes.Contains(TAstViewNode(Child));
|
||||
end;
|
||||
|
||||
procedure TNodeListHandler<T>.MoveChild(SourceIndex, TargetIndex: Integer);
|
||||
var
|
||||
item: TAstViewNode;
|
||||
begin
|
||||
if (SourceIndex < 0) or (SourceIndex >= FChildNodes.Count) then
|
||||
Exit;
|
||||
if (TargetIndex < 0) or (TargetIndex > FChildNodes.Count) then
|
||||
Exit;
|
||||
|
||||
// Adjust target index if moving downwards (since removing source shifts indices)
|
||||
if SourceIndex < TargetIndex then
|
||||
Dec(TargetIndex);
|
||||
|
||||
if SourceIndex = TargetIndex then
|
||||
Exit;
|
||||
|
||||
item := FChildNodes[SourceIndex];
|
||||
FChildNodes.Delete(SourceIndex);
|
||||
FChildNodes.Insert(TargetIndex, item);
|
||||
|
||||
// The visual order update will happen upon the next ReconstructAst -> Compile -> BuildUI cycle
|
||||
// triggered by the controller.
|
||||
end;
|
||||
|
||||
{ TParameterListHandler }
|
||||
|
||||
function TParameterListHandler.GetOrientation: TLayoutOrientation;
|
||||
|
||||
@@ -0,0 +1,280 @@
|
||||
unit Myc.Fmx.AstEditor.Layout;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.Types,
|
||||
System.Math,
|
||||
System.Math.Vectors,
|
||||
System.Generics.Collections,
|
||||
FMX.Types,
|
||||
FMX.Controls;
|
||||
|
||||
type
|
||||
TLayoutOrientation = (loVertical, loHorizontal);
|
||||
TLayoutAlignment = (laCenter, laFlush);
|
||||
|
||||
TAutoFitControl = class(TControl)
|
||||
private
|
||||
FUpdatingOwnSize: Boolean;
|
||||
FNeedRecalcSize: Boolean;
|
||||
FOrientation: TLayoutOrientation;
|
||||
FAlignment: TLayoutAlignment;
|
||||
procedure RecalcOwnSize;
|
||||
procedure SetOrientation(const Value: TLayoutOrientation);
|
||||
procedure SetAlignment(const Value: TLayoutAlignment);
|
||||
protected
|
||||
procedure ParentContentChanged; override;
|
||||
procedure PaddingChanged; override;
|
||||
procedure ChangeChildren; override;
|
||||
procedure Loaded; override;
|
||||
procedure DoEndUpdate; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
function GetInsertionIndex(const P: TPointF; ItemClass: TClass = nil): Integer;
|
||||
|
||||
published
|
||||
property Padding;
|
||||
property Orientation: TLayoutOrientation read FOrientation write SetOrientation default TLayoutOrientation.loHorizontal;
|
||||
property Alignment: TLayoutAlignment read FAlignment write SetAlignment default TLayoutAlignment.laCenter;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TAutoFitControl }
|
||||
|
||||
constructor TAutoFitControl.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
HitTest := True;
|
||||
FOrientation := TLayoutOrientation.loHorizontal;
|
||||
FAlignment := TLayoutAlignment.laCenter;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.SetAlignment(const Value: TLayoutAlignment);
|
||||
begin
|
||||
if FAlignment <> Value then
|
||||
begin
|
||||
FAlignment := Value;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.SetOrientation(const Value: TLayoutOrientation);
|
||||
begin
|
||||
if FOrientation <> Value then
|
||||
begin
|
||||
FOrientation := Value;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TAutoFitControl.GetInsertionIndex(const P: TPointF; ItemClass: TClass = nil): Integer;
|
||||
var
|
||||
i: Integer;
|
||||
child: TControl;
|
||||
center: Single;
|
||||
relevantChildren: TList<TControl>;
|
||||
begin
|
||||
relevantChildren := TList<TControl>.Create;
|
||||
try
|
||||
for i := 0 to ChildrenCount - 1 do
|
||||
begin
|
||||
if Children[i] is TControl then
|
||||
begin
|
||||
child := TControl(Children[i]);
|
||||
if child.Visible and (child.Align = TAlignLayout.None) then
|
||||
begin
|
||||
if (ItemClass = nil) or (child.InheritsFrom(ItemClass)) then
|
||||
relevantChildren.Add(child);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
Result := relevantChildren.Count;
|
||||
|
||||
for i := 0 to relevantChildren.Count - 1 do
|
||||
begin
|
||||
child := relevantChildren[i];
|
||||
|
||||
if FOrientation = TLayoutOrientation.loVertical then
|
||||
begin
|
||||
// Fix: Robustere Erkennung. Wenn P.Y kleiner als Mitte ist -> Insert
|
||||
center := child.Position.Y + (child.Height / 2);
|
||||
if P.Y < center then
|
||||
Exit(i);
|
||||
end
|
||||
else
|
||||
begin
|
||||
center := child.Position.X + (child.Width / 2);
|
||||
if P.X < center then
|
||||
Exit(i);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
relevantChildren.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.RecalcOwnSize;
|
||||
var
|
||||
i: Integer;
|
||||
child: TControl;
|
||||
childrenToLayout: TList<TControl>;
|
||||
currentX, currentY: Single;
|
||||
requiredWidth, requiredHeight: Single;
|
||||
childWidthWithMargins, childHeightWithMargins: Single;
|
||||
hasVisibleChild: Boolean;
|
||||
begin
|
||||
if FUpdatingOwnSize then
|
||||
exit;
|
||||
if IsUpdating then
|
||||
begin
|
||||
FNeedRecalcSize := True;
|
||||
exit;
|
||||
end;
|
||||
|
||||
FUpdatingOwnSize := True;
|
||||
childrenToLayout := nil;
|
||||
try
|
||||
requiredWidth := Padding.Left + Padding.Right;
|
||||
requiredHeight := Padding.Top + Padding.Bottom;
|
||||
currentX := Padding.Left;
|
||||
currentY := Padding.Top;
|
||||
hasVisibleChild := False;
|
||||
|
||||
childrenToLayout := TList<TControl>.Create;
|
||||
for i := 0 to ChildrenCount - 1 do
|
||||
begin
|
||||
if Children[i] is TControl then
|
||||
begin
|
||||
child := TControl(Children[i]);
|
||||
if child.Visible and (child.Align = TAlignLayout.None) then
|
||||
begin
|
||||
childrenToLayout.Add(child);
|
||||
hasVisibleChild := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
if hasVisibleChild then
|
||||
begin
|
||||
if FOrientation = TLayoutOrientation.loVertical then
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.Y := currentY + child.Margins.Top;
|
||||
currentY := child.Position.Y + child.Height + child.Margins.Bottom;
|
||||
|
||||
childWidthWithMargins := Padding.Left + child.Margins.Left + child.Width + child.Margins.Right + Padding.Right;
|
||||
requiredWidth := System.Math.Max(requiredWidth, childWidthWithMargins);
|
||||
end;
|
||||
requiredHeight := currentY + Padding.Bottom;
|
||||
|
||||
if FAlignment = TLayoutAlignment.laFlush then
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.X := Padding.Left + child.Margins.Left;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
var contentWidth := requiredWidth - Padding.Left - Padding.Right;
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
var childTotalWidth := child.Width + child.Margins.Left + child.Margins.Right;
|
||||
var childX := Padding.Left + ((contentWidth - childTotalWidth) / 2) + child.Margins.Left;
|
||||
child.Position.X := childX;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.X := currentX + child.Margins.Left;
|
||||
currentX := child.Position.X + child.Width + child.Margins.Right;
|
||||
|
||||
childHeightWithMargins := Padding.Top + child.Margins.Top + child.Height + child.Margins.Bottom + Padding.Bottom;
|
||||
requiredHeight := System.Math.Max(requiredHeight, childHeightWithMargins);
|
||||
end;
|
||||
requiredWidth := currentX + Padding.Right;
|
||||
|
||||
if FAlignment = TLayoutAlignment.laFlush then
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.Y := Padding.Top + child.Margins.Top;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
var contentHeight := requiredHeight - Padding.Top - Padding.Bottom;
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
var childTotalHeight := child.Height + child.Margins.Top + child.Margins.Bottom;
|
||||
var childY := Padding.Top + ((contentHeight - childTotalHeight) / 2) + child.Margins.Top;
|
||||
child.Position.Y := childY;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
requiredWidth := Padding.Left + Padding.Right;
|
||||
requiredHeight := Padding.Top + Padding.Bottom;
|
||||
end;
|
||||
|
||||
requiredWidth := System.Math.Max(0, requiredWidth);
|
||||
requiredHeight := System.Math.Max(0, requiredHeight);
|
||||
|
||||
if not SameValue(requiredWidth, Width, TEpsilon.Position) or not SameValue(requiredHeight, Height, TEpsilon.Position) then
|
||||
begin
|
||||
FSize.SetSizeWithoutNotification(TSizeF.Create(requiredWidth, requiredHeight));
|
||||
HandleSizeChanged;
|
||||
end;
|
||||
|
||||
finally
|
||||
childrenToLayout.Free;
|
||||
FUpdatingOwnSize := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.Loaded;
|
||||
begin
|
||||
inherited Loaded;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.ChangeChildren;
|
||||
begin
|
||||
inherited ChangeChildren;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.PaddingChanged;
|
||||
begin
|
||||
inherited PaddingChanged;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.ParentContentChanged;
|
||||
begin
|
||||
inherited ParentContentChanged;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.DoEndUpdate;
|
||||
begin
|
||||
inherited;
|
||||
if FNeedRecalcSize then
|
||||
begin
|
||||
FNeedRecalcSize := False;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -19,11 +19,11 @@ type
|
||||
private
|
||||
FExprDepth: Integer;
|
||||
FParentControl: TControl;
|
||||
FWorkspace: TAstWorkspace;
|
||||
FWorkspace: TWorkspace; // Changed from TAstWorkspace to TWorkspace
|
||||
function CallAccept(const Node: IAstNode): TAstViewNode;
|
||||
function GetExprDepth: Integer;
|
||||
function GetParentControl: TControl;
|
||||
function GetWorkspace: TAstWorkspace;
|
||||
function GetWorkspace: TWorkspace; // Changed signature
|
||||
procedure SetExprDepth(const Value: Integer);
|
||||
procedure SetParentControl(const Value: TControl);
|
||||
protected
|
||||
@@ -61,21 +61,21 @@ type
|
||||
function VisitNop(const Node: INopNode): TAstViewNode; override;
|
||||
|
||||
public
|
||||
constructor Create(AWorkspace: TAstWorkspace; AParentControl: TControl; AExprDepth: Integer);
|
||||
constructor Create(AWorkspace: TWorkspace; AParentControl: TControl; AExprDepth: Integer);
|
||||
destructor Destroy; override;
|
||||
|
||||
function Clone(ParentControl: TControl; ExprDepth: Integer): IAstVisualizer;
|
||||
|
||||
property ExprDepth: Integer read GetExprDepth write SetExprDepth;
|
||||
property ParentControl: TControl read GetParentControl write SetParentControl;
|
||||
property Workspace: TAstWorkspace read GetWorkspace;
|
||||
property Workspace: TWorkspace read GetWorkspace;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TAstVisualizer }
|
||||
|
||||
constructor TAstVisualizer.Create(AWorkspace: TAstWorkspace; AParentControl: TControl; AExprDepth: Integer);
|
||||
constructor TAstVisualizer.Create(AWorkspace: TWorkspace; AParentControl: TControl; AExprDepth: Integer);
|
||||
begin
|
||||
inherited Create;
|
||||
FWorkspace := AWorkspace;
|
||||
@@ -122,7 +122,7 @@ begin
|
||||
Result := FParentControl;
|
||||
end;
|
||||
|
||||
function TAstVisualizer.GetWorkspace: TAstWorkspace;
|
||||
function TAstVisualizer.GetWorkspace: TWorkspace;
|
||||
begin
|
||||
Result := FWorkspace;
|
||||
end;
|
||||
|
||||
@@ -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;
|
||||
end;
|
||||
end;
|
||||
// Calculate visual sizes inversely proportional to zoom
|
||||
if Scale.X > 0 then
|
||||
ScaleFactor := 1 / Scale.X
|
||||
else
|
||||
ScaleFactor := 1;
|
||||
|
||||
procedure TAstWorkspace.DoDeleteChildren;
|
||||
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;
|
||||
var
|
||||
connection: TPinConnection;
|
||||
startPoint, endPoint, pinCenter: TPointF;
|
||||
path: TPathData;
|
||||
controlPoint1, controlPoint2: TPointF;
|
||||
controlOffset: Single;
|
||||
absoluteStart, absoluteEnd: TPointF;
|
||||
str: string;
|
||||
begin
|
||||
inherited;
|
||||
Thickness := 3 * ScaleFactor;
|
||||
Radius := 4 * ScaleFactor;
|
||||
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Thickness := 2;
|
||||
Canvas.Stroke.Color := TAlphaColors.Red;
|
||||
Canvas.Stroke.Thickness := Thickness;
|
||||
Canvas.Stroke.Cap := TStrokeCap.Round;
|
||||
|
||||
for connection in FConnections do
|
||||
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;
|
||||
// Draw Line
|
||||
Canvas.DrawLine(FDropP1, FDropP2, 1.0);
|
||||
|
||||
pinCenter := TPointF.Create(connection.OutputPin.Width / 2, connection.OutputPin.Height / 2);
|
||||
absoluteStart := connection.OutputPin.LocalToAbsolute(pinCenter);
|
||||
// Draw Circles at ends
|
||||
Canvas.Fill.Kind := TBrushKind.Solid;
|
||||
Canvas.Fill.Color := TAlphaColors.Red;
|
||||
|
||||
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;
|
||||
end;
|
||||
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;
|
||||
|
||||
function TAstWorkspace.Zoom(Factor: Single): Boolean;
|
||||
var
|
||||
mouseService: IFMXMouseService;
|
||||
mousePos: TPointF;
|
||||
procedure TAstWorld.InvalidateConnections;
|
||||
begin
|
||||
Result := TPlatformServices.Current.SupportsPlatformService(IFMXMouseService, mouseService);
|
||||
if Result 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;
|
||||
end;
|
||||
|
||||
{ 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
|
||||
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;
|
||||
|
||||
if FIsDraggingNode then
|
||||
begin
|
||||
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;
|
||||
|
||||
procedure TWorkspace.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if FIsDraggingNode then
|
||||
begin
|
||||
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.
|
||||
|
||||
+44
-267
@@ -17,7 +17,8 @@ uses
|
||||
FMX.Graphics,
|
||||
FMX.StdCtrls,
|
||||
Myc.Ast.Nodes,
|
||||
Myc.Fmx.AstEditor.Workspace;
|
||||
Myc.Fmx.AstEditor.Workspace,
|
||||
Myc.Fmx.AstEditor.Layout;
|
||||
|
||||
const
|
||||
cNodePadding = 10;
|
||||
@@ -25,9 +26,10 @@ const
|
||||
cTitleBottomPadding = 4;
|
||||
cMinNodeWidth = 10;
|
||||
cMinNodeHeight = 10;
|
||||
cDragGutterWidth = 20; // Width of the trigger zone for dragging
|
||||
|
||||
type
|
||||
TAstViewNode = class; // Forward declaration
|
||||
TAstViewNode = class;
|
||||
|
||||
IAstViewNodeHandler = interface
|
||||
function GetAstNode: IAstNode;
|
||||
@@ -36,11 +38,17 @@ type
|
||||
property Node: IAstNode read GetAstNode;
|
||||
end;
|
||||
|
||||
IReorderable = interface
|
||||
['{9FA7C504-D327-4E00-A5FE-DD2876886212}']
|
||||
function CanDrag(Child: TControl): Boolean;
|
||||
procedure MoveChild(SourceIndex, TargetIndex: Integer);
|
||||
end;
|
||||
|
||||
IAstVisualizer = interface
|
||||
{$region 'private'}
|
||||
function GetExprDepth: Integer;
|
||||
function GetParentControl: TControl;
|
||||
function GetWorkspace: TAstWorkspace;
|
||||
function GetWorkspace: TWorkspace;
|
||||
{$endregion}
|
||||
|
||||
function Clone(ParentControl: TControl; ExprDepth: Integer): IAstVisualizer;
|
||||
@@ -48,34 +56,7 @@ type
|
||||
|
||||
property ExprDepth: Integer read GetExprDepth;
|
||||
property ParentControl: TControl read GetParentControl;
|
||||
property Workspace: TAstWorkspace read GetWorkspace;
|
||||
end;
|
||||
|
||||
TLayoutOrientation = (loVertical, loHorizontal);
|
||||
TLayoutAlignment = (laCenter, laFlush);
|
||||
|
||||
TAutoFitControl = class(TStyledControl)
|
||||
private
|
||||
FUpdatingOwnSize: Boolean;
|
||||
FNeedRecalcSize: Boolean;
|
||||
FOrientation: TLayoutOrientation;
|
||||
FAlignment: TLayoutAlignment;
|
||||
procedure RecalcOwnSize;
|
||||
procedure SetOrientation(const Value: TLayoutOrientation);
|
||||
procedure SetAlignment(const Value: TLayoutAlignment);
|
||||
protected
|
||||
procedure ParentContentChanged; override;
|
||||
procedure PaddingChanged; override;
|
||||
procedure ChangeChildren; override;
|
||||
procedure Loaded; override;
|
||||
procedure DoEndUpdate; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
|
||||
published
|
||||
property Padding;
|
||||
property Orientation: TLayoutOrientation read FOrientation write SetOrientation default TLayoutOrientation.loHorizontal;
|
||||
property Alignment: TLayoutAlignment read FAlignment write SetAlignment default TLayoutAlignment.laCenter;
|
||||
property Workspace: TWorkspace read GetWorkspace;
|
||||
end;
|
||||
|
||||
TAstViewNode = class(TAutoFitControl)
|
||||
@@ -106,7 +87,6 @@ type
|
||||
procedure Paint; override;
|
||||
procedure SetupNode;
|
||||
|
||||
// Overrides for interaction
|
||||
procedure DoMouseEnter; override;
|
||||
procedure DoMouseLeave; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
||||
@@ -127,6 +107,7 @@ type
|
||||
|
||||
property Visualizer: IAstVisualizer read FVisualizer;
|
||||
property Node: IAstNode read GetNode;
|
||||
property Handler: IAstViewNodeHandler read FHandler;
|
||||
|
||||
property ErrorMessage: string read FErrorMessage write SetErrorMessage;
|
||||
property TypeInfoText: string read FTypeInfoText write SetTypeInfoText;
|
||||
@@ -184,193 +165,6 @@ implementation
|
||||
uses
|
||||
Myc.Ast;
|
||||
|
||||
{ TAutoFitControl }
|
||||
|
||||
constructor TAutoFitControl.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
HitTest := True;
|
||||
FOrientation := TLayoutOrientation.loHorizontal;
|
||||
FAlignment := TLayoutAlignment.laCenter;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.SetAlignment(const Value: TLayoutAlignment);
|
||||
begin
|
||||
if FAlignment <> Value then
|
||||
begin
|
||||
FAlignment := Value;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.SetOrientation(const Value: TLayoutOrientation);
|
||||
begin
|
||||
if FOrientation <> Value then
|
||||
begin
|
||||
FOrientation := Value;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.RecalcOwnSize;
|
||||
var
|
||||
i: Integer;
|
||||
child: TControl;
|
||||
childrenToLayout: TList<TControl>;
|
||||
currentX, currentY: Single;
|
||||
requiredWidth, requiredHeight: Single;
|
||||
childWidthWithMargins, childHeightWithMargins: Single;
|
||||
hasVisibleChild: Boolean;
|
||||
begin
|
||||
if FUpdatingOwnSize then
|
||||
exit;
|
||||
if IsUpdating then
|
||||
begin
|
||||
FNeedRecalcSize := True;
|
||||
exit;
|
||||
end;
|
||||
|
||||
FUpdatingOwnSize := True;
|
||||
childrenToLayout := nil;
|
||||
try
|
||||
requiredWidth := Padding.Left + Padding.Right;
|
||||
requiredHeight := Padding.Top + Padding.Bottom;
|
||||
currentX := Padding.Left;
|
||||
currentY := Padding.Top;
|
||||
hasVisibleChild := False;
|
||||
|
||||
childrenToLayout := TList<TControl>.Create;
|
||||
for i := 0 to ChildrenCount - 1 do
|
||||
begin
|
||||
if Children[i] is TControl then
|
||||
begin
|
||||
child := TControl(Children[i]);
|
||||
if child.Visible and (child.Align = TAlignLayout.None) then
|
||||
begin
|
||||
childrenToLayout.Add(child);
|
||||
hasVisibleChild := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
if hasVisibleChild then
|
||||
begin
|
||||
if FOrientation = TLayoutOrientation.loVertical then
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.Y := currentY + child.Margins.Top;
|
||||
currentY := child.Position.Y + child.Height + child.Margins.Bottom;
|
||||
|
||||
childWidthWithMargins := Padding.Left + child.Margins.Left + child.Width + child.Margins.Right + Padding.Right;
|
||||
requiredWidth := System.Math.Max(requiredWidth, childWidthWithMargins);
|
||||
end;
|
||||
requiredHeight := currentY + Padding.Bottom;
|
||||
|
||||
if FAlignment = TLayoutAlignment.laFlush then
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.X := Padding.Left + child.Margins.Left;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
var contentWidth := requiredWidth - Padding.Left - Padding.Right;
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
var childTotalWidth := child.Width + child.Margins.Left + child.Margins.Right;
|
||||
var childX := Padding.Left + ((contentWidth - childTotalWidth) / 2) + child.Margins.Left;
|
||||
child.Position.X := childX;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.X := currentX + child.Margins.Left;
|
||||
currentX := child.Position.X + child.Width + child.Margins.Right;
|
||||
|
||||
childHeightWithMargins := Padding.Top + child.Margins.Top + child.Height + child.Margins.Bottom + Padding.Bottom;
|
||||
requiredHeight := System.Math.Max(requiredHeight, childHeightWithMargins);
|
||||
end;
|
||||
requiredWidth := currentX + Padding.Right;
|
||||
|
||||
if FAlignment = TLayoutAlignment.laFlush then
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.Y := Padding.Top + child.Margins.Top;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
var contentHeight := requiredHeight - Padding.Top - Padding.Bottom;
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
var childTotalHeight := child.Height + child.Margins.Top + child.Margins.Bottom;
|
||||
var childY := Padding.Top + ((contentHeight - childTotalHeight) / 2) + child.Margins.Top;
|
||||
child.Position.Y := childY;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
requiredWidth := Padding.Left + Padding.Right;
|
||||
requiredHeight := Padding.Top + Padding.Bottom;
|
||||
end;
|
||||
|
||||
requiredWidth := System.Math.Max(0, requiredWidth);
|
||||
requiredHeight := System.Math.Max(0, requiredHeight);
|
||||
|
||||
if not SameValue(requiredWidth, Width, TEpsilon.Position) or not SameValue(requiredHeight, Height, TEpsilon.Position) then
|
||||
begin
|
||||
FSize.SetSizeWithoutNotification(TSizeF.Create(requiredWidth, requiredHeight));
|
||||
HandleSizeChanged;
|
||||
end;
|
||||
|
||||
finally
|
||||
childrenToLayout.Free;
|
||||
FUpdatingOwnSize := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.Loaded;
|
||||
begin
|
||||
inherited Loaded;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.ChangeChildren;
|
||||
begin
|
||||
inherited ChangeChildren;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.PaddingChanged;
|
||||
begin
|
||||
inherited PaddingChanged;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.ParentContentChanged;
|
||||
begin
|
||||
inherited ParentContentChanged;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.DoEndUpdate;
|
||||
begin
|
||||
inherited;
|
||||
if FNeedRecalcSize then
|
||||
begin
|
||||
FNeedRecalcSize := False;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TAstViewNode }
|
||||
|
||||
constructor TAstViewNode.Create(const AVisualizer: IAstVisualizer; const AHandler: IAstViewNodeHandler);
|
||||
@@ -392,7 +186,6 @@ begin
|
||||
Width := cMinNodeWidth;
|
||||
Height := cMinNodeHeight;
|
||||
|
||||
// HitTest muss True sein für Hover-Effekte (IsMouseOver)
|
||||
HitTest := True;
|
||||
ClipChildren := True;
|
||||
|
||||
@@ -419,8 +212,6 @@ end;
|
||||
procedure TAstViewNode.DoMouseEnter;
|
||||
begin
|
||||
inherited;
|
||||
// Wir müssen neu zeichnen, da sich IsMouseOver geändert hat,
|
||||
// FMX triggert Paint nicht automatisch bei Hover.
|
||||
Repaint;
|
||||
end;
|
||||
|
||||
@@ -431,43 +222,43 @@ begin
|
||||
end;
|
||||
|
||||
procedure TAstViewNode.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
var
|
||||
pt: TPointF;
|
||||
const
|
||||
cHeaderHeight = 30; // Defined height for header drag area
|
||||
begin
|
||||
inherited;
|
||||
// Panning-Weiterleitung an den Workspace
|
||||
// Check for Drag Start.
|
||||
// Condition: Left Click AND we are part of a container (list)
|
||||
if (Button = TMouseButton.mbLeft) and (Parent is TAutoFitControl) then
|
||||
begin
|
||||
// Hit-Test: Either Gutter (Left) OR Header area (Top)
|
||||
if (X < cDragGutterWidth) or (Y < cHeaderHeight) then
|
||||
begin
|
||||
if Assigned(FVisualizer.Workspace) then
|
||||
begin
|
||||
pt := LocalToAbsolute(TPointF.Create(X, Y));
|
||||
pt := FVisualizer.Workspace.AbsoluteToLocal(pt);
|
||||
FVisualizer.Workspace.ExternalMouseDown(Button, Shift, pt.X, pt.Y);
|
||||
FVisualizer.Workspace.BeginDragNode(Self);
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TAstViewNode.MouseMove(Shift: TShiftState; X, Y: Single);
|
||||
var
|
||||
pt: TPointF;
|
||||
const
|
||||
cHeaderHeight = 30;
|
||||
begin
|
||||
// Cursor Logic (Hover Feedback)
|
||||
if (Parent is TAutoFitControl) and ((X < cDragGutterWidth) or (Y < cHeaderHeight)) then
|
||||
Cursor := crSizeAll
|
||||
else
|
||||
Cursor := crDefault;
|
||||
|
||||
inherited;
|
||||
if Assigned(FVisualizer.Workspace) then
|
||||
begin
|
||||
pt := LocalToAbsolute(TPointF.Create(X, Y));
|
||||
pt := FVisualizer.Workspace.AbsoluteToLocal(pt);
|
||||
FVisualizer.Workspace.ExternalMouseMove(Shift, pt.X, pt.Y);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAstViewNode.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
var
|
||||
pt: TPointF;
|
||||
begin
|
||||
inherited;
|
||||
if Assigned(FVisualizer.Workspace) then
|
||||
begin
|
||||
pt := LocalToAbsolute(TPointF.Create(X, Y));
|
||||
pt := FVisualizer.Workspace.AbsoluteToLocal(pt);
|
||||
FVisualizer.Workspace.ExternalMouseUp(Button, Shift, pt.X, pt.Y);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TAstViewNode.AddContainer(Parent: TControl; Orientation: TLayoutOrientation; Alignment: TLayoutAlignment): TAutoFitControl;
|
||||
@@ -547,7 +338,6 @@ begin
|
||||
begin
|
||||
FTypeInfoText := Value;
|
||||
UpdateVisualState;
|
||||
// Type Info usually doesn't change painting, just hint
|
||||
end;
|
||||
end;
|
||||
|
||||
@@ -585,16 +375,12 @@ begin
|
||||
if Assigned(Node) then
|
||||
begin
|
||||
case Node.Kind of
|
||||
// Lists and Blocks should generally not be highlighted as a whole on hover
|
||||
// because they are containers for other selectable items.
|
||||
akBlockExpression, akParameterList, akArgumentList, akExpressionList, akRecordFieldList: shouldIgnoreHover := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
// Determine hover state: active only if mouse is over AND it is not a container type
|
||||
isHovering := IsMouseOver and (not shouldIgnoreHover);
|
||||
|
||||
// 1. Set base values
|
||||
if FFrameless then
|
||||
begin
|
||||
effBorderColor := FBorderColor;
|
||||
@@ -608,20 +394,13 @@ begin
|
||||
effDash := TStrokeDash.Solid;
|
||||
end;
|
||||
|
||||
// 2. Hover state (overrides base, makes frameless nodes visible)
|
||||
if isHovering then
|
||||
begin
|
||||
// Bright white for strong contrast against dark background
|
||||
effBorderColor := TAlphaColors.White;
|
||||
|
||||
// Make border slightly thicker for a "pop" effect
|
||||
effBorderWidth := Max(2.0, FBorderWidth + 1.0);
|
||||
|
||||
// Always solid line when hovering, even if originally frameless
|
||||
effDash := TStrokeDash.Solid;
|
||||
end;
|
||||
|
||||
// 3. Error state (dominates everything)
|
||||
if FErrorMessage <> '' then
|
||||
begin
|
||||
effBorderColor := TAlphaColors.Red;
|
||||
@@ -629,19 +408,13 @@ begin
|
||||
effDash := TStrokeDash.Solid;
|
||||
end;
|
||||
|
||||
// --- Drawing ---
|
||||
|
||||
// Fill background
|
||||
Canvas.Fill.Kind := TBrushKind.Solid;
|
||||
Canvas.Fill.Color := FBackgroundColor;
|
||||
|
||||
if FFrameless and (FErrorMessage = '') and (not isHovering) then
|
||||
begin
|
||||
// Special case: Inactive, frameless node (e.g., simple constant)
|
||||
// Draw only background, no border
|
||||
Canvas.FillRect(TRectF.Create(0, 0, Width, Height), 0, 0, [], 1.0);
|
||||
|
||||
// Draw border only if explicit width is set (e.g. debugging)
|
||||
if FBorderWidth > 0 then
|
||||
begin
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
@@ -653,16 +426,12 @@ begin
|
||||
end
|
||||
else
|
||||
begin
|
||||
// Standard case: Node with border (or hovered frameless node)
|
||||
|
||||
rect := TRectF.Create(0, 0, Width, Height);
|
||||
// Adjust to avoid clipping the border
|
||||
if (effBorderWidth > 0) then
|
||||
rect.Inflate(-effBorderWidth / 2, -effBorderWidth / 2);
|
||||
|
||||
Canvas.FillRect(rect, FBorderRadius, FBorderRadius, AllCorners, 1.0, TCornerType.Round);
|
||||
|
||||
// Draw border
|
||||
if (effBorderWidth > 0) and (effBorderColor <> TAlphaColors.Null) then
|
||||
begin
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
@@ -672,6 +441,14 @@ begin
|
||||
Canvas.DrawRect(rect, FBorderRadius, FBorderRadius, AllCorners, 1.0, TCornerType.Round);
|
||||
end;
|
||||
end;
|
||||
|
||||
if isHovering and (Parent is TAutoFitControl) then
|
||||
begin
|
||||
Canvas.Fill.Color := TAlphaColors.DimGray;
|
||||
Canvas.FillEllipse(TRectF.Create(4, 6, 8, 10), 1.0);
|
||||
Canvas.FillEllipse(TRectF.Create(4, 12, 8, 16), 1.0);
|
||||
Canvas.FillEllipse(TRectF.Create(4, 18, 8, 22), 1.0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAstViewNode.SetBorderColor(const Value: TAlphaColor);
|
||||
|
||||
Reference in New Issue
Block a user