Ast editor unit refactoring
This commit is contained in:
Michael Schimmel
@@ -0,0 +1,248 @@
|
||||
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,
|
||||
Myc.Ast.Nodes,
|
||||
Myc.Ast.Scope,
|
||||
Myc.Ast.Compiler.Binder;
|
||||
|
||||
const
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
cExecPinColor = TAlphaColors.Lightgreen;
|
||||
|
||||
type
|
||||
TPinConnection = record
|
||||
OutputPin: TControl;
|
||||
InputPin: TControl;
|
||||
constructor Create(AOutputPin, AInputPin: TControl);
|
||||
end;
|
||||
|
||||
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 Build(const RootNode: IAstNode; const Position: TPointF);
|
||||
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.Core,
|
||||
Myc.Fmx.AstEditor.Visualizer;
|
||||
|
||||
{ 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.Build(const RootNode: IAstNode; const Position: TPointF);
|
||||
begin
|
||||
var visu := TAstVisualizer.Create(Self, Self, 0) as IAstVisualizer;
|
||||
var node := visu.CallAccept(RootNode);
|
||||
|
||||
if Assigned(node) then
|
||||
node.Position.Point := Position;
|
||||
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