MycLib/ASTPlayground/Myc.Fmx.AstEditor.Workspace.pas

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.Binding;

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 RootNode: IAstNode; const RootScope: IExecutionScope; 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 RootNode: IAstNode;
    const RootScope: IExecutionScope;
    const Position: TPointF;
    AMode: TVisualizationMode
);
var
    connections: TList<TPinConnection>;
    rootDescriptor: IScopeDescriptor;
begin
    connections := TList<TPinConnection>.Create;
    try
        // Create the scope descriptor from the execution scope provided by the binder.
        rootDescriptor := TAstBinder.CreateDescriptor(RootScope);
        RootNode.Accept(TAstToAuraNodeVisitor.Create(Self, Self, Position, connections, nil, AMode, nil, nil, rootDescriptor));
        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.