Ast control refactoring
This commit is contained in:
Michael Schimmel
@@ -0,0 +1,245 @@
|
||||
unit Myc.Fmx.AstEditor.Workspace;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.Types,
|
||||
System.UITypes,
|
||||
System.Math.Vectors,
|
||||
System.Generics.Collections,
|
||||
FMX.Types,
|
||||
FMX.Controls,
|
||||
FMX.Graphics,
|
||||
FMX.Objects,
|
||||
Myc.Ast.Nodes;
|
||||
|
||||
type
|
||||
TPinConnection = record
|
||||
OutputPin: TControl;
|
||||
InputPin: TControl;
|
||||
constructor Create(AOutputPin, AInputPin: TControl);
|
||||
end;
|
||||
|
||||
// Enum to select the visualization style.
|
||||
TVisualizationMode = (vmDetailed, vmControlFlow);
|
||||
|
||||
TAuraWorkspace = class(TStyledControl)
|
||||
private
|
||||
FConnections: TArray<TPinConnection>;
|
||||
FPanning: TSizeF;
|
||||
FIsPanning: Boolean;
|
||||
FLastPanPos: TPointF;
|
||||
FZoom: Single;
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure DoDeleteChildren; 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 BuildTree(const Root: IAstNode; const Position: TPointF; AMode: TVisualizationMode);
|
||||
function GetChildrenMatrix(var Matrix: TMatrix; var Simple: Boolean): Boolean; override;
|
||||
function Zoom(Factor: Single): Boolean;
|
||||
|
||||
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;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
System.Math,
|
||||
FMX.Platform,
|
||||
Myc.Fmx.AstEditor;
|
||||
|
||||
{ TPinConnection }
|
||||
|
||||
constructor TPinConnection.Create(AOutputPin, AInputPin: TControl);
|
||||
begin
|
||||
OutputPin := AOutputPin;
|
||||
InputPin := AInputPin;
|
||||
end;
|
||||
|
||||
{ TAuraWorkspace }
|
||||
|
||||
constructor TAuraWorkspace.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
FZoom := 1.0;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.BuildTree(const Root: IAstNode; const Position: TPointF; AMode: TVisualizationMode);
|
||||
begin
|
||||
var connections := TList<TPinConnection>.Create;
|
||||
try
|
||||
Root.Accept(TAstToAuraNodeVisitor.Create(Self, Self, Position, connections, nil, AMode));
|
||||
FConnections := FConnections + connections.ToArray;
|
||||
finally
|
||||
connections.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.DoDeleteChildren;
|
||||
begin
|
||||
FConnections := nil;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TAuraWorkspace.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;
|
||||
|
||||
procedure TAuraWorkspace.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = TMouseButton.mbLeft) and (ObjectAtPoint(LocalToScreen(TPointF.Create(X, Y))) = Self as IControl) then
|
||||
begin
|
||||
FIsPanning := True;
|
||||
FLastPanPos := TPointF.Create(X, Y);
|
||||
Cursor := crHandPoint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.MouseMove(Shift: TShiftState; X, Y: Single);
|
||||
var
|
||||
delta: TPointF;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
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 TAuraWorkspace.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = TMouseButton.mbLeft) and (FIsPanning) then
|
||||
begin
|
||||
FIsPanning := False;
|
||||
Cursor := crDefault;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
Handled := Zoom(IfThen(WheelDelta > 0, FZoom * 1.1, FZoom / 1.1));
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.DblClick;
|
||||
begin
|
||||
inherited;
|
||||
Zoom(1.0);
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.Paint;
|
||||
var
|
||||
connection: TPinConnection;
|
||||
startPoint, endPoint, pinCenter: TPointF;
|
||||
path: TPathData;
|
||||
controlPoint1, controlPoint2: TPointF;
|
||||
controlOffset: Single;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Thickness := 2;
|
||||
|
||||
for connection in FConnections do
|
||||
begin
|
||||
pinCenter := TPointF.Create(connection.OutputPin.Width / 2, connection.OutputPin.Height / 2);
|
||||
var absoluteStart := connection.OutputPin.LocalToAbsolute(pinCenter);
|
||||
|
||||
pinCenter := TPointF.Create(connection.InputPin.Width / 2, connection.InputPin.Height / 2);
|
||||
var absoluteEnd := connection.InputPin.LocalToAbsolute(pinCenter);
|
||||
|
||||
startPoint := AbsoluteToLocal(absoluteStart);
|
||||
endPoint := AbsoluteToLocal(absoluteEnd);
|
||||
|
||||
var 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;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TAuraWorkspace.Zoom(Factor: Single): Boolean;
|
||||
var
|
||||
MouseService: IFMXMouseService;
|
||||
begin
|
||||
Result := TPlatformServices.Current.SupportsPlatformService(IFMXMouseService, MouseService);
|
||||
if Result then
|
||||
begin
|
||||
var MousePos := ScreenToLocal(MouseService.GetMousePos);
|
||||
Factor := Max(0.2, Min(3.0, Factor));
|
||||
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;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user