Ast Playground 1. visualization
This commit is contained in:
Michael Schimmel
@@ -7,7 +7,9 @@ uses
|
||||
Myc.Ast.Evaluator in '..\Src\AST\Myc.Ast.Evaluator.pas',
|
||||
Myc.Ast.Printer in '..\Src\AST\Myc.Ast.Printer.pas',
|
||||
Myc.Ast.Nodes in '..\Src\AST\Myc.Ast.Nodes.pas',
|
||||
Myc.Ast.Scope in '..\Src\AST\Myc.Ast.Scope.pas';
|
||||
Myc.Ast.Scope in '..\Src\AST\Myc.Ast.Scope.pas',
|
||||
DraggablePanel in 'DraggablePanel.pas',
|
||||
Myc.Ast.Visualizer in 'Myc.Ast.Visualizer.pas';
|
||||
|
||||
{$R *.res}
|
||||
|
||||
|
||||
@@ -139,6 +139,8 @@
|
||||
<DCCReference Include="..\Src\AST\Myc.Ast.Printer.pas"/>
|
||||
<DCCReference Include="..\Src\AST\Myc.Ast.Nodes.pas"/>
|
||||
<DCCReference Include="..\Src\AST\Myc.Ast.Scope.pas"/>
|
||||
<DCCReference Include="DraggablePanel.pas"/>
|
||||
<DCCReference Include="Myc.Ast.Visualizer.pas"/>
|
||||
<BuildConfiguration Include="Base">
|
||||
<Key>Base</Key>
|
||||
</BuildConfiguration>
|
||||
|
||||
@@ -0,0 +1,264 @@
|
||||
unit DraggablePanel;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.UITypes,
|
||||
System.Types,
|
||||
FMX.Types,
|
||||
FMX.Controls,
|
||||
FMX.StdCtrls,
|
||||
FMX.Graphics,
|
||||
FMX.Objects;
|
||||
|
||||
type
|
||||
/// <summary>
|
||||
/// A panel that can contain other controls and can be moved by dragging its background.
|
||||
/// It custom-paints its own border and title.
|
||||
/// </summary>
|
||||
TAuraNode = class(TStyledControl)
|
||||
private
|
||||
// Flag to indicate if the control is currently being dragged.
|
||||
FIsDragging: Boolean;
|
||||
// Stores the mouse coordinates at the beginning of the drag operation.
|
||||
FDownPos: TPointF;
|
||||
// Properties for the custom-drawn border.
|
||||
FBorderColor: TAlphaColor;
|
||||
FBorderWidth: Single;
|
||||
FBorderRadius: Single;
|
||||
// Properties for the title
|
||||
FTitle: string;
|
||||
FTitleFont: TFont;
|
||||
FTitleFontColor: TAlphaColor;
|
||||
|
||||
procedure SetBorderColor(const Value: TAlphaColor);
|
||||
procedure SetBorderWidth(const Value: Single);
|
||||
procedure SetBorderRadius(const Value: Single);
|
||||
procedure SetTitle(const Value: string);
|
||||
procedure SetTitleFont(const Value: TFont);
|
||||
procedure SetTitleFontColor(const Value: TAlphaColor);
|
||||
procedure TitleFontChanged(Sender: TObject);
|
||||
protected
|
||||
procedure Paint; 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;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
// Custom border properties
|
||||
property BorderColor: TAlphaColor read FBorderColor write SetBorderColor;
|
||||
property BorderWidth: Single read FBorderWidth write SetBorderWidth;
|
||||
property BorderRadius: Single read FBorderRadius write SetBorderRadius;
|
||||
|
||||
// Title properties
|
||||
property Title: string read FTitle write SetTitle;
|
||||
property TitleFont: TFont read FTitleFont write SetTitleFont;
|
||||
property TitleFontColor: TAlphaColor read FTitleFontColor write SetTitleFontColor;
|
||||
|
||||
// Standard control properties
|
||||
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
|
||||
|
||||
{ TAuraNode }
|
||||
|
||||
constructor TAuraNode.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FIsDragging := False;
|
||||
|
||||
// Default border settings
|
||||
FBorderColor := TAlphaColors.Gray;
|
||||
FBorderWidth := 1;
|
||||
FBorderRadius := 0; // Sharp corners by default
|
||||
|
||||
// Default title settings
|
||||
FTitle := 'Node';
|
||||
FTitleFont := TFont.Create;
|
||||
FTitleFont.Family := 'Segoe UI';
|
||||
FTitleFont.Size := 11;
|
||||
FTitleFont.Style := [TFontStyle.fsBold];
|
||||
FTitleFont.OnChanged := TitleFontChanged;
|
||||
FTitleFontColor := TAlphaColors.Black;
|
||||
|
||||
Width := 80;
|
||||
Height := 45;
|
||||
|
||||
// The panel must be able to receive mouse events.
|
||||
HitTest := True;
|
||||
// Clip children to the panel's bounds.
|
||||
ClipChildren := True;
|
||||
end;
|
||||
|
||||
destructor TAuraNode.Destroy;
|
||||
begin
|
||||
FTitleFont.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBorderColor(const Value: TAlphaColor);
|
||||
begin
|
||||
if FBorderColor <> Value then
|
||||
begin
|
||||
FBorderColor := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBorderWidth(const Value: Single);
|
||||
begin
|
||||
if FBorderWidth <> Value then
|
||||
begin
|
||||
FBorderWidth := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBorderRadius(const Value: Single);
|
||||
begin
|
||||
if FBorderRadius <> Value then
|
||||
begin
|
||||
FBorderRadius := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetTitle(const Value: string);
|
||||
begin
|
||||
if FTitle <> Value then
|
||||
begin
|
||||
FTitle := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetTitleFont(const Value: TFont);
|
||||
begin
|
||||
FTitleFont.Assign(Value);
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetTitleFontColor(const Value: TAlphaColor);
|
||||
begin
|
||||
if FTitleFontColor <> Value then
|
||||
begin
|
||||
FTitleFontColor := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.TitleFontChanged(Sender: TObject);
|
||||
begin
|
||||
Repaint;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.Paint;
|
||||
var
|
||||
LRect, LTitleRect: TRectF;
|
||||
begin
|
||||
inherited; // Allow styled painting to occur first (if any)
|
||||
|
||||
// Custom painting for the border
|
||||
if (FBorderWidth > 0) and (FBorderColor <> TAlphaColors.Null) then
|
||||
begin
|
||||
LRect := TRectF.Create(0, 0, Width, Height);
|
||||
// Inflate inwards so the border is fully visible within the control's bounds
|
||||
LRect.Inflate(-FBorderWidth / 2, -FBorderWidth / 2);
|
||||
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Color := FBorderColor;
|
||||
Canvas.Stroke.Thickness := FBorderWidth;
|
||||
|
||||
// Use DrawRoundRect to support both sharp and rounded corners
|
||||
Canvas.DrawRect(LRect, FBorderRadius, FBorderRadius, AllCorners, 1.0, TCornerType.Round);
|
||||
end;
|
||||
|
||||
// Draw the title
|
||||
if not FTitle.IsEmpty then
|
||||
begin
|
||||
// Define the rectangle for the title at the top of the control
|
||||
LTitleRect := TRectF.Create(0, FBorderWidth, Width, FBorderWidth + FTitleFont.Size * 1.8);
|
||||
|
||||
Canvas.Font.Assign(FTitleFont);
|
||||
Canvas.Fill.Color := FTitleFontColor;
|
||||
|
||||
// Draw the text centered horizontally and vertically within the title rectangle
|
||||
Canvas.FillText(LTitleRect, FTitle, False, 1.0, [], TTextAlign.Center, TTextAlign.Center);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = TMouseButton.mbLeft) then
|
||||
begin
|
||||
if (ObjectAtPoint(LocalToScreen(TPointF.Create(X, Y))) = Self as IControl) then
|
||||
begin
|
||||
FIsDragging := True;
|
||||
FDownPos := TPointF.Create(X, Y);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.MouseMove(Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if FIsDragging then
|
||||
begin
|
||||
var deltaX := X - FDownPos.X;
|
||||
var deltaY := Y - FDownPos.Y;
|
||||
|
||||
Position.X := Position.X + deltaX;
|
||||
Position.Y := Position.Y + deltaY;
|
||||
|
||||
if ParentControl <> nil then
|
||||
ParentControl.Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = TMouseButton.mbLeft) and (FIsDragging) then
|
||||
begin
|
||||
FIsDragging := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
+30
-10
@@ -2,7 +2,7 @@ object Form1: TForm1
|
||||
Left = 0
|
||||
Top = 0
|
||||
Caption = 'Form1'
|
||||
ClientHeight = 638
|
||||
ClientHeight = 883
|
||||
ClientWidth = 925
|
||||
FormFactor.Width = 320
|
||||
FormFactor.Height = 480
|
||||
@@ -10,9 +10,9 @@ object Form1: TForm1
|
||||
OnCreate = FormCreate
|
||||
DesignerMasterStyle = 0
|
||||
object Panel1: TPanel
|
||||
Align = Left
|
||||
Size.Width = 137.000000000000000000
|
||||
Size.Height = 638.000000000000000000
|
||||
Align = MostLeft
|
||||
Size.Width = 129.000000000000000000
|
||||
Size.Height = 883.000000000000000000
|
||||
Size.PlatformDefault = False
|
||||
TabOrder = 1
|
||||
object Test1Button: TButton
|
||||
@@ -89,24 +89,44 @@ object Form1: TForm1
|
||||
OnClick = DoTriggerButtonClick
|
||||
object DoTrigger2Button: TButton
|
||||
Position.Y = 30.000000000000000000
|
||||
TabOrder = 8
|
||||
TabOrder = 5
|
||||
Text = 'Trigger2'
|
||||
TextSettings.Trimming = None
|
||||
OnClick = DoTrigger2ButtonClick
|
||||
end
|
||||
end
|
||||
object ClearButton: TButton
|
||||
Position.X = 24.000000000000000000
|
||||
Position.Y = 432.000000000000000000
|
||||
Size.Width = 80.000000000000000000
|
||||
Size.Height = 22.000000000000000000
|
||||
Size.PlatformDefault = False
|
||||
TabOrder = 11
|
||||
Text = 'Clear'
|
||||
TextSettings.Trimming = None
|
||||
OnClick = ClearButtonClick
|
||||
end
|
||||
end
|
||||
object Panel2: TPanel
|
||||
Align = Client
|
||||
Size.Width = 796.000000000000000000
|
||||
Size.Height = 616.000000000000000000
|
||||
Size.PlatformDefault = False
|
||||
TabOrder = 3
|
||||
end
|
||||
object Memo1: TMemo
|
||||
Touch.InteractiveGestures = [Pan, LongTap, DoubleTap]
|
||||
DataDetectorTypes = []
|
||||
StyledSettings = [Size, Style, FontColor]
|
||||
TextSettings.Font.Family = 'Consolas'
|
||||
Align = Client
|
||||
Size.Width = 788.000000000000000000
|
||||
Size.Height = 638.000000000000000000
|
||||
Align = Bottom
|
||||
Position.X = 129.000000000000000000
|
||||
Position.Y = 616.000000000000000000
|
||||
Size.Width = 796.000000000000000000
|
||||
Size.Height = 267.000000000000000000
|
||||
Size.PlatformDefault = False
|
||||
TabOrder = 2
|
||||
Viewport.Width = 784.000000000000000000
|
||||
Viewport.Height = 634.000000000000000000
|
||||
Viewport.Width = 792.000000000000000000
|
||||
Viewport.Height = 263.000000000000000000
|
||||
end
|
||||
end
|
||||
|
||||
+53
-16
@@ -8,6 +8,7 @@ uses
|
||||
System.UITypes,
|
||||
System.Classes,
|
||||
System.Variants,
|
||||
System.Generics.Collections,
|
||||
FMX.Types,
|
||||
FMX.Controls,
|
||||
FMX.Forms,
|
||||
@@ -18,11 +19,15 @@ uses
|
||||
FMX.ScrollBox,
|
||||
FMX.Memo,
|
||||
FMX.Controls.Presentation,
|
||||
DraggablePanel,
|
||||
Myc.Ast.Visualizer,
|
||||
Myc.Data.POD,
|
||||
Myc.Ast.Nodes,
|
||||
Myc.Ast,
|
||||
Myc.Ast.Evaluator,
|
||||
Myc.Ast.Printer; // Added for TExecutionScope
|
||||
Myc.Ast.Printer,
|
||||
FMX.Layouts,
|
||||
FMX.Objects; // Added for TExecutionScope
|
||||
|
||||
type
|
||||
TForm1 = class(TForm)
|
||||
@@ -38,6 +43,9 @@ type
|
||||
CrerateTriggerExampleButton: TButton;
|
||||
DoTriggerButton: TButton;
|
||||
DoTrigger2Button: TButton;
|
||||
Panel2: TPanel;
|
||||
ClearButton: TButton;
|
||||
procedure ClearButtonClick(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure CrerateTriggerExampleButtonClick(Sender: TObject);
|
||||
procedure DebugButtonClick(Sender: TObject);
|
||||
@@ -52,6 +60,8 @@ type
|
||||
// Stores the last AST generated by Test1 or Test2 button clicks.
|
||||
FLastAst: IAstNode;
|
||||
FGScope: IExecutionScope;
|
||||
FWorkspace: TAuraWorkspace;
|
||||
procedure WorkspaceMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
@@ -67,8 +77,20 @@ uses
|
||||
|
||||
{$R *.fmx}
|
||||
|
||||
procedure TForm1.ClearButtonClick(Sender: TObject);
|
||||
begin
|
||||
FWorkspace.DeleteChildren;
|
||||
FWorkspace.Repaint;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
FWorkspace := TAuraWorkspace.Create(Panel2);
|
||||
FWorkspace.Parent := Panel2;
|
||||
FWorkspace.Align := TAlignLayout.Client;
|
||||
|
||||
FWorkspace.OnMouseDown := WorkspaceMouseDown;
|
||||
|
||||
FGScope := T_ExecutionScope.Create(nil);
|
||||
end;
|
||||
|
||||
@@ -371,7 +393,6 @@ end;
|
||||
|
||||
procedure TForm1.CrerateTriggerExampleButtonClick(Sender: TObject);
|
||||
var
|
||||
lambdaAst: ILambdaExpressionNode;
|
||||
visitor: IAstVisitor;
|
||||
closureValue: TAstValue;
|
||||
begin
|
||||
@@ -384,26 +405,33 @@ begin
|
||||
Memo1.Lines.Clear;
|
||||
Memo1.Lines.Add('--- Creating Trigger Blueprint ---');
|
||||
|
||||
// 1. Initialize the variable 'X' to 0 directly in the scope.
|
||||
FGScope.SetValue('X', TAstValue.FromScalar(TScalar.FromInt64(0)));
|
||||
|
||||
// 2. Create a lambda that takes the summand as an argument.
|
||||
// AST for: (summand) => { X = X + summand; }
|
||||
// Using the new Assignment node to modify 'X' in its parent scope.
|
||||
lambdaAst :=
|
||||
TAst.LambdaExpr(
|
||||
[TAst.Identifier('summand')],
|
||||
TAst.Assign(TAst.Identifier('X'), TAst.BinaryExpr(TAst.Identifier('X'), boAdd, TAst.Identifier('summand')))
|
||||
var blk :=
|
||||
TAst.Block(
|
||||
[
|
||||
TAst.VarDecl(TAst.Identifier('X'), TAst.Constant(TScalar.FromInt64(0))),
|
||||
TAst.VarDecl(
|
||||
TAst.Identifier('tickHandler'),
|
||||
TAst.LambdaExpr(
|
||||
[TAst.Identifier('summand')],
|
||||
TAst.Assign(TAst.Identifier('X'), TAst.BinaryExpr(TAst.Identifier('X'), boAdd, TAst.Identifier('summand')))
|
||||
)
|
||||
)
|
||||
]
|
||||
);
|
||||
|
||||
// 3. Evaluate the lambda to create a closure and store it in the scope.
|
||||
// lambdaAst :=
|
||||
// TAst.LambdaExpr(
|
||||
// [TAst.Identifier('summand')],
|
||||
// TAst.Assign(TAst.Identifier('X'), TAst.BinaryExpr(TAst.Identifier('X'), boAdd, TAst.Identifier('summand')))
|
||||
// );
|
||||
|
||||
// Evaluate the lambda to create a closure and store it in the scope.
|
||||
// The closure captures the scope where 'X' is defined.
|
||||
visitor := TEvaluatorVisitor.Create(FGScope);
|
||||
closureValue := lambdaAst.Accept(visitor);
|
||||
FGScope.SetValue('tickHandler', closureValue);
|
||||
blk.Accept(visitor);
|
||||
|
||||
// FLastAst is not used for this parameterized example.
|
||||
FLastAst := lambdaAst;
|
||||
FLastAst := blk;
|
||||
|
||||
Memo1.Lines.Add('Variable "X" initialized to 0 in persistent scope.');
|
||||
Memo1.Lines.Add('Blueprint function "tickHandler(summand)" created.');
|
||||
@@ -470,4 +498,13 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.WorkspaceMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
if Button <> TMouseButton.mbMiddle then
|
||||
exit;
|
||||
|
||||
if FLastAst <> nil then
|
||||
FWorkspace.BuildTree(FLastAst, TPointF.Create(X, Y));
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,711 @@
|
||||
unit Myc.Ast.Visualizer;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.UITypes,
|
||||
System.Types,
|
||||
System.Generics.Collections,
|
||||
FMX.Types,
|
||||
FMX.Controls,
|
||||
FMX.Objects,
|
||||
FMX.Graphics,
|
||||
Myc.Ast.Nodes,
|
||||
DraggablePanel;
|
||||
|
||||
type
|
||||
// Record to store a connection between two pins
|
||||
TPinConnection = record
|
||||
OutputPin: TControl;
|
||||
InputPin: TControl;
|
||||
constructor Create(AOutputPin, AInputPin: TControl);
|
||||
end;
|
||||
|
||||
// Defines the shape of a pin.
|
||||
TPinShape = (psCircle, psTriangle);
|
||||
// Defines the horizontal alignment of a pin on a node.
|
||||
TPinAlignment = (paLeft, paRight);
|
||||
|
||||
TAuraWorkspace = class;
|
||||
|
||||
TAstToAuraNodeVisitor = class(TInterfacedObject, IAstVisitor)
|
||||
private
|
||||
FWorkspace: TAuraWorkspace;
|
||||
FParentControl: TControl;
|
||||
FCurrentPos: TPointF;
|
||||
FSpacing: TPointF;
|
||||
FLastNode: TAuraNode;
|
||||
FConnections: TList<TPinConnection>;
|
||||
function CreateNodeControl(const ATitle, ADetails: string): TAuraNode;
|
||||
function CreatePin(
|
||||
AParentNode: TAuraNode;
|
||||
AShape: TPinShape;
|
||||
AAlignment: TPinAlignment;
|
||||
AColor: TAlphaColor;
|
||||
const ATag: string;
|
||||
AOffsetY: Single = 0
|
||||
): TControl;
|
||||
function FindPinByTag(AParentNode: TAuraNode; const ATag: string): TControl;
|
||||
function ConnectPins(InputPin: TControl; OutputNode: TAuraNode; const Tag: string): TControl;
|
||||
public
|
||||
constructor Create(
|
||||
AWorkspace: TAuraWorkspace;
|
||||
AParentControl: TControl;
|
||||
const AStartPosition: TPointF;
|
||||
AConnections: TList<TPinConnection>
|
||||
);
|
||||
// Public access to the collected connections
|
||||
property Connections: TList<TPinConnection> read FConnections;
|
||||
|
||||
{ IAstVisitor }
|
||||
function VisitConstant(const Node: IConstantNode): TAstValue;
|
||||
function VisitIdentifier(const Node: IIdentifierNode): TAstValue;
|
||||
function VisitBinaryExpression(const Node: IBinaryExpressionNode): TAstValue;
|
||||
function VisitUnaryExpression(const Node: IUnaryExpressionNode): TAstValue;
|
||||
function VisitIfExpression(const Node: IIfExpressionNode): TAstValue;
|
||||
function VisitLambdaExpression(const Node: ILambdaExpressionNode): TAstValue;
|
||||
function VisitFunctionCall(const Node: IFunctionCallNode): TAstValue;
|
||||
function VisitBlockExpression(const Node: IBlockExpressionNode): TAstValue;
|
||||
function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TAstValue;
|
||||
function VisitAssignment(const Node: IAssignmentNode): TAstValue;
|
||||
end;
|
||||
|
||||
TAuraWorkspace = class(TStyledControl)
|
||||
private
|
||||
FConnections: TArray<TPinConnection>;
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure DoDeleteChildren; override;
|
||||
public
|
||||
procedure BuildTree(const Root: IAstNode; const Position: TPointF);
|
||||
|
||||
published
|
||||
// Standard control properties
|
||||
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;
|
||||
|
||||
{ TPinConnection }
|
||||
|
||||
constructor TPinConnection.Create(AOutputPin, AInputPin: TControl);
|
||||
begin
|
||||
OutputPin := AOutputPin;
|
||||
InputPin := AInputPin;
|
||||
end;
|
||||
|
||||
{ TAstToAuraNodeVisitor }
|
||||
|
||||
constructor TAstToAuraNodeVisitor.Create(
|
||||
AWorkspace: TAuraWorkspace;
|
||||
AParentControl: TControl;
|
||||
const AStartPosition: TPointF;
|
||||
AConnections: TList<TPinConnection>
|
||||
);
|
||||
begin
|
||||
inherited Create;
|
||||
FWorkspace := AWorkspace;
|
||||
FParentControl := AParentControl;
|
||||
FCurrentPos := AStartPosition;
|
||||
FSpacing := TPointF.Create(20, 10); // Horizontal indent, Vertical spacing
|
||||
FConnections := AConnections;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.ConnectPins(InputPin: TControl; OutputNode: TAuraNode; const Tag: string): TControl;
|
||||
begin
|
||||
Result := FindPinByTag(OutputNode, Tag);
|
||||
if Assigned(Result) then
|
||||
FConnections.Add(TPinConnection.Create(Result, InputPin));
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.CreateNodeControl(const ATitle, ADetails: string): TAuraNode;
|
||||
const
|
||||
// Horizontal padding on each side of the title to ensure text and pins are fully visible.
|
||||
cHorizontalPadding = 25;
|
||||
var
|
||||
LFullTitle: string;
|
||||
LTextWidth: Single;
|
||||
LNewWidth: Single;
|
||||
LMeasureCanvas: TCanvas;
|
||||
begin
|
||||
Result := TAuraNode.Create(FParentControl);
|
||||
Result.Parent := FParentControl;
|
||||
|
||||
// Build the full title string first
|
||||
LFullTitle := ATitle;
|
||||
if not ADetails.IsEmpty then
|
||||
LFullTitle := LFullTitle + ': ' + ADetails;
|
||||
Result.Title := LFullTitle;
|
||||
|
||||
Result.Position.Point := FCurrentPos;
|
||||
|
||||
// Adjust the width so that the text and pins are completely visible.
|
||||
LMeasureCanvas := TCanvasManager.MeasureCanvas;
|
||||
if Assigned(LMeasureCanvas) then
|
||||
begin
|
||||
LMeasureCanvas.Font.Assign(Result.TitleFont);
|
||||
LTextWidth := LMeasureCanvas.TextWidth(Result.Title);
|
||||
LNewWidth := LTextWidth + (2 * cHorizontalPadding);
|
||||
// Ensure the new width is not smaller than the default width of the node.
|
||||
Result.Width := Max(Result.Width, LNewWidth);
|
||||
end;
|
||||
|
||||
// Advance vertical position for the next node
|
||||
FCurrentPos.Y := FCurrentPos.Y + Result.Height + FSpacing.Y;
|
||||
|
||||
FLastNode := Result;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.CreatePin(
|
||||
AParentNode: TAuraNode;
|
||||
AShape: TPinShape;
|
||||
AAlignment: TPinAlignment;
|
||||
AColor: TAlphaColor;
|
||||
const ATag: string;
|
||||
AOffsetY: Single
|
||||
): TControl;
|
||||
const
|
||||
cPinSize = 10;
|
||||
var
|
||||
LPosX, LPosY: Single;
|
||||
begin
|
||||
// Calculate vertical position (centered + offset)
|
||||
LPosY := (AParentNode.Height / 2) - (cPinSize / 2) + AOffsetY;
|
||||
|
||||
// Calculate horizontal position
|
||||
if (AAlignment = paLeft) then
|
||||
LPosX := 0
|
||||
else // paRight
|
||||
LPosX := AParentNode.Width - cPinSize;
|
||||
|
||||
// Create the shape
|
||||
case AShape of
|
||||
psCircle:
|
||||
begin
|
||||
var LCircle := TEllipse.Create(AParentNode);
|
||||
LCircle.Fill.Color := AColor;
|
||||
LCircle.Stroke.Kind := TBrushKind.None;
|
||||
Result := LCircle;
|
||||
end;
|
||||
psTriangle:
|
||||
begin
|
||||
var LTriangle := TPath.Create(AParentNode);
|
||||
LTriangle.Data.Data := Format('M 0 0 L %d %d L 0 %d Z', [cPinSize, cPinSize div 2, cPinSize]);
|
||||
LTriangle.Fill.Color := AColor;
|
||||
LTriangle.Stroke.Kind := TBrushKind.None;
|
||||
Result := LTriangle;
|
||||
end;
|
||||
else
|
||||
Result := nil;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
// Common properties
|
||||
Result.Parent := AParentNode;
|
||||
Result.SetBounds(LPosX, LPosY, cPinSize, cPinSize);
|
||||
Result.HitTest := False;
|
||||
|
||||
// Use TagString to identify the control as a pin and describe its function.
|
||||
Result.TagString := ATag;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.FindPinByTag(AParentNode: TAuraNode; const ATag: string): TControl;
|
||||
var
|
||||
LControl: TControl;
|
||||
begin
|
||||
Result := nil;
|
||||
if not Assigned(AParentNode) then
|
||||
Exit;
|
||||
|
||||
for LControl in AParentNode.Controls do
|
||||
begin
|
||||
if (LControl.TagString = ATag) then
|
||||
begin
|
||||
Result := LControl;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitAssignment(const Node: IAssignmentNode): TAstValue;
|
||||
const
|
||||
cExecPinColor = TAlphaColors.Lightgreen;
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
var
|
||||
LAssignmentNode, LValueNode: TAuraNode;
|
||||
LInputPin: TControl;
|
||||
LStartPosition: TPointF;
|
||||
begin
|
||||
LStartPosition := FCurrentPos;
|
||||
|
||||
// Visit the value expression first
|
||||
Node.Value.Accept(Self);
|
||||
LValueNode := FLastNode;
|
||||
|
||||
// Reposition for the assignment node
|
||||
FCurrentPos.X := LValueNode.Position.X + LValueNode.Width + FSpacing.X;
|
||||
FCurrentPos.Y := LValueNode.Position.Y;
|
||||
|
||||
// Create the assignment node and its pins
|
||||
LAssignmentNode := CreateNodeControl('Assignment', Node.Identifier.Name);
|
||||
CreatePin(LAssignmentNode, psTriangle, paLeft, cExecPinColor, 'Pin.Exec.In', -8);
|
||||
CreatePin(LAssignmentNode, psTriangle, paRight, cExecPinColor, 'Pin.Exec.Out');
|
||||
LInputPin := CreatePin(LAssignmentNode, psCircle, paLeft, cDataPinColor, 'Pin.Data.In', 8);
|
||||
|
||||
// Connect the value to the assignment
|
||||
ConnectPins(LInputPin, LValueNode, 'Pin.Data.Out');
|
||||
|
||||
// Finalize visitor state
|
||||
FCurrentPos.X := LStartPosition.X;
|
||||
FCurrentPos.Y := Max(LValueNode.Position.Y + LValueNode.Height, LAssignmentNode.Position.Y + LAssignmentNode.Height) + FSpacing.Y;
|
||||
FLastNode := LAssignmentNode;
|
||||
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitBinaryExpression(const Node: IBinaryExpressionNode): TAstValue;
|
||||
const
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
cDefaultHeight = 45;
|
||||
var
|
||||
LBinaryExprNode, LLeftNode, LRightNode: TAuraNode;
|
||||
LInputPin1, LInputPin2: TControl;
|
||||
LStartPosition: TPointF;
|
||||
LRightEndY, LMaxChildWidth: Single;
|
||||
begin
|
||||
LStartPosition := FCurrentPos;
|
||||
|
||||
// First, visit the child nodes to create their visual representation
|
||||
// Left branch
|
||||
Node.Left.Accept(Self);
|
||||
LLeftNode := FLastNode;
|
||||
|
||||
// Right branch starts below the left branch
|
||||
Node.Right.Accept(Self);
|
||||
LRightNode := FLastNode;
|
||||
LRightEndY := FCurrentPos.Y;
|
||||
|
||||
// Now, create the node for the binary operation itself
|
||||
LMaxChildWidth := Max(LLeftNode.Position.X + LLeftNode.Width, LRightNode.Position.X + LRightNode.Width);
|
||||
FCurrentPos.X := LMaxChildWidth + FSpacing.X;
|
||||
|
||||
// Vertically center the binary expression node between its children
|
||||
var LTotalChildHeight := LRightEndY - LStartPosition.Y;
|
||||
var LNodeCenterY := LStartPosition.Y + (LTotalChildHeight / 2);
|
||||
FCurrentPos.Y := LNodeCenterY - (cDefaultHeight / 2);
|
||||
|
||||
LBinaryExprNode := CreateNodeControl(Node.Operator.ToString, '');
|
||||
|
||||
// Create pins for the binary expression node
|
||||
LInputPin1 := CreatePin(LBinaryExprNode, psCircle, paLeft, cDataPinColor, 'Pin.Data.In.1', -8);
|
||||
LInputPin2 := CreatePin(LBinaryExprNode, psCircle, paLeft, cDataPinColor, 'Pin.Data.In.2', 8);
|
||||
CreatePin(LBinaryExprNode, psCircle, paRight, cDataPinColor, 'Pin.Data.Out', 0);
|
||||
|
||||
// Connect the output of the left child to the first input of the binary node
|
||||
ConnectPins(LInputPin1, LLeftNode, 'Pin.Data.Out');
|
||||
|
||||
// Connect the output of the right child to the second input of the binary node
|
||||
ConnectPins(LInputPin2, LRightNode, 'Pin.Data.Out');
|
||||
|
||||
// Finalize visitor state for the next node at this level
|
||||
FCurrentPos.X := LStartPosition.X;
|
||||
FCurrentPos.Y := Max(LRightEndY, LBinaryExprNode.Position.Y + LBinaryExprNode.Height + FSpacing.Y);
|
||||
FLastNode := LBinaryExprNode;
|
||||
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitBlockExpression(const Node: IBlockExpressionNode): TAstValue;
|
||||
var
|
||||
Expression: IExpressionNode;
|
||||
LBlockNode: TAuraNode;
|
||||
LChildVisitor: IAstVisitor;
|
||||
LChildStartPos: TPointF;
|
||||
LMaxRight: Single;
|
||||
LMaxBottom: Single;
|
||||
LControl: TControl;
|
||||
begin
|
||||
// A block node visually encloses all its child nodes.
|
||||
// Create the container node for the block. Its size will be adjusted later.
|
||||
LBlockNode := TAuraNode.Create(FParentControl);
|
||||
LBlockNode.Parent := FParentControl;
|
||||
LBlockNode.Title := 'Block';
|
||||
LBlockNode.Position.Point := FCurrentPos;
|
||||
|
||||
// Create a new visitor for the child nodes. The children will be parented
|
||||
// to LBlockNode and positioned relative to it, starting below the title.
|
||||
LChildStartPos := TPointF.Create(FSpacing.X, FSpacing.Y + LBlockNode.TitleFont.Size * 1.8);
|
||||
LChildVisitor := TAstToAuraNodeVisitor.Create(FWorkspace, LBlockNode, LChildStartPos, FConnections);
|
||||
|
||||
// Visit all expressions within the block using the new visitor.
|
||||
for Expression in Node.Expressions do
|
||||
begin
|
||||
Expression.Accept(LChildVisitor);
|
||||
end;
|
||||
|
||||
// Adjust the size of the block node to encompass all its children.
|
||||
LMaxRight := 0;
|
||||
LMaxBottom := 0;
|
||||
for LControl in LBlockNode.Controls do
|
||||
begin
|
||||
if (LControl is TAuraNode) then
|
||||
begin
|
||||
LMaxRight := Max(LMaxRight, LControl.Position.X + LControl.Width);
|
||||
LMaxBottom := Max(LMaxBottom, LControl.Position.Y + LControl.Height);
|
||||
end;
|
||||
end;
|
||||
|
||||
// Set the final size with some internal padding.
|
||||
LBlockNode.Width := Max(LBlockNode.Width, LMaxRight + FSpacing.X);
|
||||
LBlockNode.Height := Max(LBlockNode.Height, LMaxBottom + FSpacing.Y);
|
||||
|
||||
// Update the current Y position of the main visitor to be below the now correctly sized block node.
|
||||
FCurrentPos.Y := LBlockNode.Position.Y + LBlockNode.Height + FSpacing.Y;
|
||||
FLastNode := LBlockNode;
|
||||
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitConstant(const Node: IConstantNode): TAstValue;
|
||||
const
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
var
|
||||
LConstantNode: TAuraNode;
|
||||
begin
|
||||
// A constant has a data output pin.
|
||||
// Data outputs are round and on the right side of the box.
|
||||
LConstantNode := CreateNodeControl('Constant', Node.Value.ToString);
|
||||
CreatePin(LConstantNode, psCircle, paRight, cDataPinColor, 'Pin.Data.Out', 0);
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitFunctionCall(const Node: IFunctionCallNode): TAstValue;
|
||||
var
|
||||
Arg: IExpressionNode;
|
||||
begin
|
||||
CreateNodeControl('FunctionCall', '');
|
||||
FCurrentPos.X := FCurrentPos.X + FSpacing.X;
|
||||
try
|
||||
// Callee
|
||||
CreateNodeControl('Callee', '');
|
||||
FCurrentPos.X := FCurrentPos.X + FSpacing.X;
|
||||
try
|
||||
Node.Callee.Accept(Self);
|
||||
finally
|
||||
FCurrentPos.X := FCurrentPos.X - FSpacing.X;
|
||||
end;
|
||||
|
||||
// Arguments
|
||||
if Node.Arguments.Count > 0 then
|
||||
begin
|
||||
CreateNodeControl('Arguments', '');
|
||||
FCurrentPos.X := FCurrentPos.X + FSpacing.X;
|
||||
try
|
||||
for Arg in Node.Arguments do
|
||||
Arg.Accept(Self);
|
||||
finally
|
||||
FCurrentPos.X := FCurrentPos.X - FSpacing.X;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
FCurrentPos.X := FCurrentPos.X - FSpacing.X;
|
||||
end;
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitIdentifier(const Node: IIdentifierNode): TAstValue;
|
||||
const
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
begin
|
||||
CreateNodeControl('Identifier', Node.Name);
|
||||
// Add a data output pin on the right side.
|
||||
CreatePin(FLastNode, psCircle, paRight, cDataPinColor, 'Pin.Data.Out');
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitIfExpression(const Node: IIfExpressionNode): TAstValue;
|
||||
const
|
||||
cExecPinColor = TAlphaColors.Lightgreen;
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
cDefaultHeight = 60; // Taller to accommodate more pins
|
||||
var
|
||||
LIfNode, LConditionNode, LThenNode, LElseNode: TAuraNode;
|
||||
LConditionInputPin, LThenOutputPin, LElseOutputPin: TControl;
|
||||
LStartPosition: TPointF;
|
||||
LConditionEndY, LThenEndY, LElseEndY, LMaxChildWidth: Single;
|
||||
begin
|
||||
LStartPosition := FCurrentPos;
|
||||
|
||||
// Place the input node for the condition to the left of the 'If' node.
|
||||
Node.Condition.Accept(Self);
|
||||
LConditionNode := FLastNode;
|
||||
LConditionEndY := FCurrentPos.Y;
|
||||
|
||||
// Position and create the 'If' node to the right of the condition's subtree.
|
||||
LMaxChildWidth := LConditionNode.Position.X + LConditionNode.Width;
|
||||
FCurrentPos.X := LMaxChildWidth + FSpacing.X;
|
||||
FCurrentPos.Y := LStartPosition.Y + (LConditionNode.Position.Y + LConditionNode.Height / 2) - LStartPosition.Y - (cDefaultHeight / 2);
|
||||
|
||||
LIfNode := CreateNodeControl('If', '');
|
||||
LIfNode.Height := cDefaultHeight;
|
||||
CreatePin(LIfNode, psTriangle, paLeft, cExecPinColor, 'Pin.Exec.In', -12);
|
||||
LConditionInputPin := CreatePin(LIfNode, psCircle, paLeft, cDataPinColor, 'Pin.Data.In.Condition', 12);
|
||||
LThenOutputPin := CreatePin(LIfNode, psTriangle, paRight, cExecPinColor, 'Pin.Exec.Out.Then', -12);
|
||||
if Assigned(Node.ElseBranch) then
|
||||
LElseOutputPin := CreatePin(LIfNode, psTriangle, paRight, cExecPinColor, 'Pin.Exec.Out.Else', 12)
|
||||
else
|
||||
LElseOutputPin := nil;
|
||||
|
||||
// Connect the condition's output to the 'If' node's data input.
|
||||
ConnectPins(LConditionInputPin, LConditionNode, 'Pin.Data.Out');
|
||||
|
||||
// Visit the 'Then' and 'Else' execution branches, placing them to the right of the 'If' node.
|
||||
var LBranchStartX := LIfNode.Position.X + LIfNode.Width + FSpacing.X;
|
||||
|
||||
// Then branch
|
||||
FCurrentPos.X := LBranchStartX;
|
||||
FCurrentPos.Y := LStartPosition.Y;
|
||||
Node.ThenBranch.Accept(Self);
|
||||
LThenNode := FLastNode;
|
||||
LThenEndY := FCurrentPos.Y;
|
||||
// ConnectPins(FindPinByTag(LThenNode, 'Pin.Exec.In'), LIfNode, 'Pin.Exec.Out.Then');
|
||||
|
||||
// Else branch (if it exists)
|
||||
LElseEndY := LThenEndY;
|
||||
if Assigned(Node.ElseBranch) then
|
||||
begin
|
||||
FCurrentPos.X := LBranchStartX;
|
||||
FCurrentPos.Y := LThenEndY;
|
||||
Node.ElseBranch.Accept(Self);
|
||||
LElseNode := FLastNode;
|
||||
LElseEndY := FCurrentPos.Y;
|
||||
// ConnectPins(FindPinByTag(LElseNode, 'Pin.Exec.In'), LIfNode, 'Pin.Exec.Out.Else');
|
||||
end;
|
||||
|
||||
// Finalize visitor state.
|
||||
FCurrentPos.X := LStartPosition.X;
|
||||
FCurrentPos.Y := Max(LConditionEndY, LElseEndY);
|
||||
FLastNode := LIfNode;
|
||||
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitLambdaExpression(const Node: ILambdaExpressionNode): TAstValue;
|
||||
const
|
||||
cExecPinColor = TAlphaColors.Lightgreen;
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
var
|
||||
ParamStr: String;
|
||||
LLambdaNode: TAuraNode;
|
||||
LChildVisitor: IAstVisitor;
|
||||
LChildStartPos: TPointF;
|
||||
LMaxRight, LMaxBottom: Single;
|
||||
LControl: TControl;
|
||||
i: Integer;
|
||||
begin
|
||||
// Prepare the parameter string for the title
|
||||
ParamStr := '(';
|
||||
if Length(Node.Parameters) > 0 then
|
||||
begin
|
||||
ParamStr := ParamStr + Node.Parameters[0].Name;
|
||||
for i := 1 to High(Node.Parameters) do
|
||||
ParamStr := ParamStr + ', ' + Node.Parameters[i].Name;
|
||||
end;
|
||||
ParamStr := ParamStr + ')';
|
||||
|
||||
// Create the container node for the lambda. Its size will be adjusted later.
|
||||
LLambdaNode := CreateNodeControl('Lambda', ParamStr);
|
||||
|
||||
// Create a new visitor for the child nodes (the lambda body).
|
||||
// The children will be parented to LLambdaNode and positioned relative to it.
|
||||
LChildStartPos := TPointF.Create(FSpacing.X, FSpacing.Y + LLambdaNode.TitleFont.Size * 1.8);
|
||||
LChildVisitor := TAstToAuraNodeVisitor.Create(FWorkspace, LLambdaNode, LChildStartPos, FConnections);
|
||||
|
||||
// Visit the body expression using the new visitor.
|
||||
Node.Body.Accept(LChildVisitor);
|
||||
|
||||
// Adjust the size of the lambda node to encompass its body.
|
||||
LMaxRight := 0;
|
||||
LMaxBottom := 0;
|
||||
for LControl in LLambdaNode.Controls do
|
||||
begin
|
||||
if (LControl is TAuraNode) then
|
||||
begin
|
||||
LMaxRight := Max(LMaxRight, LControl.Position.X + LControl.Width);
|
||||
LMaxBottom := Max(LMaxBottom, LControl.Position.Y + LControl.Height);
|
||||
end;
|
||||
end;
|
||||
|
||||
// Set the final size with some internal padding.
|
||||
LLambdaNode.Width := Max(LLambdaNode.Width, LMaxRight + FSpacing.X);
|
||||
LLambdaNode.Height := Max(LLambdaNode.Height, LMaxBottom + FSpacing.Y);
|
||||
|
||||
// Add a data output pin for the resulting closure.
|
||||
CreatePin(LLambdaNode, psCircle, paRight, cDataPinColor, 'Pin.Data.Out');
|
||||
|
||||
// Update the current Y position of the main visitor to be below the now correctly sized lambda node.
|
||||
FCurrentPos.Y := LLambdaNode.Position.Y + LLambdaNode.Height + FSpacing.Y;
|
||||
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitUnaryExpression(const Node: IUnaryExpressionNode): TAstValue;
|
||||
begin
|
||||
CreateNodeControl('UnaryExpr', Node.Operator.ToString);
|
||||
FCurrentPos.X := FCurrentPos.X + FSpacing.X;
|
||||
try
|
||||
Node.Right.Accept(Self);
|
||||
finally
|
||||
FCurrentPos.X := FCurrentPos.X - FSpacing.X;
|
||||
end;
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
function TAstToAuraNodeVisitor.VisitVariableDeclaration(const Node: IVariableDeclarationNode): TAstValue;
|
||||
const
|
||||
cExecPinColor = TAlphaColors.Lightgreen;
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
cInitializerTreeWidth = 150;
|
||||
var
|
||||
LVarDeclNode, LInitializerNode: TAuraNode;
|
||||
LStartPosition: TPointF;
|
||||
LInitializerEndY, LVarDeclNodeEndY: Single;
|
||||
LInputPin: TControl;
|
||||
begin
|
||||
LStartPosition := FCurrentPos;
|
||||
LInitializerEndY := LStartPosition.Y;
|
||||
LInitializerNode := nil;
|
||||
|
||||
if Assigned(Node.Initializer) then
|
||||
begin
|
||||
Node.Initializer.Accept(Self);
|
||||
|
||||
LInitializerNode := FLastNode;
|
||||
LInitializerEndY := FCurrentPos.Y;
|
||||
FCurrentPos.X := LStartPosition.X + cInitializerTreeWidth + FSpacing.X;
|
||||
FCurrentPos.Y := LStartPosition.Y;
|
||||
end;
|
||||
|
||||
LVarDeclNode := CreateNodeControl('VarDecl', Node.Identifier.Name);
|
||||
LVarDeclNodeEndY := FCurrentPos.Y;
|
||||
|
||||
CreatePin(LVarDeclNode, psTriangle, paLeft, cExecPinColor, 'Pin.Exec.In', -8);
|
||||
CreatePin(LVarDeclNode, psTriangle, paRight, cExecPinColor, 'Pin.Exec.Out', -8);
|
||||
|
||||
if Assigned(Node.Initializer) then
|
||||
begin
|
||||
LInputPin := CreatePin(LVarDeclNode, psCircle, paLeft, cDataPinColor, 'Pin.Data.In', 8);
|
||||
ConnectPins(LInputPin, LInitializerNode, 'Pin.Data.Out');
|
||||
|
||||
FCurrentPos.Y := Max(LInitializerEndY, LVarDeclNodeEndY);
|
||||
FCurrentPos.X := LStartPosition.X;
|
||||
end;
|
||||
FLastNode := LVarDeclNode;
|
||||
|
||||
Result := TAstValue.Void;
|
||||
end;
|
||||
|
||||
{ TAuraWorkspace }
|
||||
|
||||
procedure TAuraWorkspace.BuildTree(const Root: IAstNode; const Position: TPointF);
|
||||
begin
|
||||
var Connections := TList<TPinConnection>.Create;
|
||||
try
|
||||
Root.Accept(TAstToAuraNodeVisitor.Create(Self, Self, Position, Connections));
|
||||
FConnections := FConnections + Connections.ToArray;
|
||||
finally
|
||||
Connections.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.DoDeleteChildren;
|
||||
begin
|
||||
FConnections := nil;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.Paint;
|
||||
var
|
||||
LConnection: TPinConnection;
|
||||
LStartPoint, LEndPoint, LPinCenter: TPointF;
|
||||
LPath: TPathData;
|
||||
LControlPoint1, LControlPoint2: TPointF;
|
||||
LDeltaX, LControlOffset: Single;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Color := TAlphaColors.Dodgerblue;
|
||||
Canvas.Stroke.Thickness := 2;
|
||||
|
||||
// Gehe durch alle gespeicherten Verbindungen und zeichne sie
|
||||
for LConnection in FConnections do
|
||||
begin
|
||||
// Hole die absoluten Koordinaten der Pin-Mittelpunkte
|
||||
LPinCenter := TPointF.Create(LConnection.OutputPin.Width / 2, LConnection.OutputPin.Height / 2);
|
||||
var LAbsoluteStart := LConnection.OutputPin.LocalToAbsolute(LPinCenter);
|
||||
|
||||
LPinCenter := TPointF.Create(LConnection.InputPin.Width / 2, LConnection.InputPin.Height / 2);
|
||||
var LAbsoluteEnd := LConnection.InputPin.LocalToAbsolute(LPinCenter);
|
||||
|
||||
// Rechne sie in die lokalen Koordinaten der PaintBox um
|
||||
LStartPoint := AbsoluteToLocal(LAbsoluteStart);
|
||||
LEndPoint := AbsoluteToLocal(LAbsoluteEnd);
|
||||
|
||||
// Draw a Bezier curve with horizontal tangents at start and end points.
|
||||
LPath := TPathData.Create;
|
||||
try
|
||||
LDeltaX := LEndPoint.X - LStartPoint.X;
|
||||
LControlOffset := Max(50, Abs(LDeltaX) / 2);
|
||||
|
||||
LControlPoint1 := TPointF.Create(LStartPoint.X + LControlOffset, LStartPoint.Y);
|
||||
LControlPoint2 := TPointF.Create(LEndPoint.X - LControlOffset, LEndPoint.Y);
|
||||
|
||||
LPath.MoveTo(LStartPoint);
|
||||
LPath.CurveTo(LControlPoint1, LControlPoint2, LEndPoint);
|
||||
|
||||
Canvas.DrawPath(LPath, 1.0);
|
||||
finally
|
||||
LPath.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -201,14 +201,14 @@ uses
|
||||
System.Classes;
|
||||
|
||||
type
|
||||
// Private interface to encapsulate a string value for reference counting.
|
||||
IAstTextValue = interface(IInterface)
|
||||
// Private interface to encapsulate a non scalar value for reference counting.
|
||||
IAstValue<T> = interface
|
||||
function GetValue: string;
|
||||
property Value: string read GetValue;
|
||||
end;
|
||||
|
||||
// Implementation of the text value interface.
|
||||
TAstTextValue = class(TInterfacedObject, IAstTextValue)
|
||||
TAstValue<T> = class(TInterfacedObject, IAstValue<T>)
|
||||
private
|
||||
FValue: string;
|
||||
function GetValue: string;
|
||||
@@ -216,15 +216,15 @@ type
|
||||
constructor Create(const AValue: string);
|
||||
end;
|
||||
|
||||
{ TAstTextValue }
|
||||
{ TAstValue }
|
||||
|
||||
constructor TAstTextValue.Create(const AValue: string);
|
||||
constructor TAstValue<T>.Create(const AValue: string);
|
||||
begin
|
||||
inherited Create;
|
||||
FValue := AValue;
|
||||
end;
|
||||
|
||||
function TAstTextValue.GetValue: string;
|
||||
function TAstValue<T>.GetValue: string;
|
||||
begin
|
||||
Result := FValue;
|
||||
end;
|
||||
@@ -255,7 +255,7 @@ function TAstValue.AsText: String;
|
||||
begin
|
||||
if (FKind <> avkText) then
|
||||
raise EInvalidCast.Create('Cannot read value as Text.');
|
||||
Result := IAstTextValue(FInterface).Value;
|
||||
Result := IAstValue<String>(FInterface).Value;
|
||||
end;
|
||||
|
||||
class function TAstValue.FromClosure(const AValue: IEvaluatorClosure): TAstValue;
|
||||
@@ -275,7 +275,7 @@ end;
|
||||
class function TAstValue.FromText(const AValue: String): TAstValue;
|
||||
begin
|
||||
Result.FKind := avkText;
|
||||
Result.FInterface := TAstTextValue.Create(AValue);
|
||||
Result.FInterface := TAstValue<String>.Create(AValue);
|
||||
Result.FScalar := Default(TScalar);
|
||||
end;
|
||||
|
||||
|
||||
+147
-266
@@ -8,7 +8,7 @@ uses
|
||||
Myc.Data.Series;
|
||||
|
||||
type
|
||||
// POD: Plain old data (...that fits into 128 bits)
|
||||
// POD: Plain old data (...that fits into 64 bits)
|
||||
|
||||
TScalarKind = (
|
||||
skInteger,
|
||||
@@ -26,9 +26,9 @@ type
|
||||
skDecimal
|
||||
);
|
||||
|
||||
TScalarBytes = array[0..15] of Byte;
|
||||
TScalarPChar = array[0..7] of Char;
|
||||
TScalarString = String[15];
|
||||
TScalarBytes = array[0..7] of Byte;
|
||||
TScalarPChar = array[0..3] of Char;
|
||||
TScalarString = String[7];
|
||||
|
||||
TScalarValue = record
|
||||
public
|
||||
@@ -49,54 +49,29 @@ type
|
||||
class function FromBytes(const AValue: TScalarBytes): TScalarValue; static; inline;
|
||||
class function FromDecimal(AValue: TDecimal): TScalarValue; static; inline;
|
||||
|
||||
function GetAsInteger: Integer; inline;
|
||||
function GetAsInt64: Int64; inline;
|
||||
function GetAsUInt64: UInt64; inline;
|
||||
function GetAsSingle: Single; inline;
|
||||
function GetAsDouble: Double; inline;
|
||||
function GetAsDateTime: TDateTime; inline;
|
||||
function GetAsTimestamp: TTimestamp; inline;
|
||||
function GetAsBoolean: Boolean; inline;
|
||||
function GetAsChar: Char; inline;
|
||||
function GetAsPChar: PChar; inline;
|
||||
function GetAsString: ShortString; inline;
|
||||
function GetAsBytes: TScalarBytes; inline;
|
||||
function GetAsDecimal: TDecimal; inline;
|
||||
|
||||
property AsInteger: Integer read GetAsInteger;
|
||||
property AsInt64: Int64 read GetAsInt64;
|
||||
property AsUInt64: UInt64 read GetAsUInt64;
|
||||
property AsSingle: Single read GetAsSingle;
|
||||
property AsDouble: Double read GetAsDouble;
|
||||
property AsDateTime: TDateTime read GetAsDateTime;
|
||||
property AsTimestamp: TTimestamp read GetAsTimestamp;
|
||||
property AsBoolean: Boolean read GetAsBoolean;
|
||||
property AsChar: Char read GetAsChar;
|
||||
property AsPChar: PChar read GetAsPChar;
|
||||
property AsString: ShortString read GetAsString;
|
||||
property AsBytes: TScalarBytes read GetAsBytes;
|
||||
property AsDecimal: TDecimal read GetAsDecimal;
|
||||
|
||||
strict private
|
||||
// Direct field access for performance.
|
||||
case TScalarKind of
|
||||
skInteger: (FInteger: Integer);
|
||||
skInt64: (FInt64: Int64);
|
||||
skUInt64: (FUInt64: UInt64);
|
||||
skSingle: (FSingle: Single);
|
||||
skDouble: (FDouble: Double);
|
||||
skDateTime: (FDateTime: TDateTime);
|
||||
skTimestamp: (FTimestamp: TTimestamp);
|
||||
skBoolean: (FBoolean: Boolean);
|
||||
skChar: (FChar: Char);
|
||||
skPChar: (FPChar: TScalarPChar);
|
||||
skString: (FString: String[15]);
|
||||
skBytes: (FBytes: TScalarBytes);
|
||||
skDecimal: (FDecimal: TDecimal);
|
||||
skInteger: (AsInteger: Integer);
|
||||
skInt64: (AsInt64: Int64);
|
||||
skUInt64: (AsUInt64: UInt64);
|
||||
skSingle: (AsSingle: Single);
|
||||
skDouble: (AsDouble: Double);
|
||||
skDateTime: (AsDateTime: TDateTime);
|
||||
skTimestamp: (AsTimestamp: TTimestamp);
|
||||
skBoolean: (AsBoolean: Boolean);
|
||||
skChar: (AsChar: Char);
|
||||
skPChar: (AsPChar: TScalarPChar);
|
||||
skString: (AsString: String[7]);
|
||||
skBytes: (AsBytes: TScalarBytes);
|
||||
skDecimal: (AsDecimal: TDecimal);
|
||||
end;
|
||||
|
||||
// A scalar value with a type identifier.
|
||||
TScalar = record
|
||||
public
|
||||
Kind: TScalarKind;
|
||||
Value: TScalarValue;
|
||||
|
||||
// Creates a new scalar from a kind and a value.
|
||||
constructor Create(AKind: TScalarKind; const AValue: TScalarValue);
|
||||
|
||||
@@ -113,19 +88,9 @@ type
|
||||
class function FromPChar(const AValue: TScalarPChar): TScalar; static; inline;
|
||||
class function FromString(const AValue: String): TScalar; static; inline;
|
||||
class function FromBytes(const AValue: TScalarBytes): TScalar; static; inline;
|
||||
class function FromDecimal(AValue: TDecimal): TScalar; static; inline;
|
||||
|
||||
function GetKind: TScalarKind; inline;
|
||||
function GetValue: TScalarValue; inline;
|
||||
class function FromDecimal(const AValue: TDecimal): TScalar; static; inline;
|
||||
|
||||
function ToString: String;
|
||||
|
||||
property Kind: TScalarKind read GetKind;
|
||||
property Value: TScalarValue read GetValue;
|
||||
|
||||
strict private
|
||||
FKind: TScalarKind;
|
||||
FValue: TScalarValue;
|
||||
end;
|
||||
|
||||
// Basic data structures using the scalar type (these are not POD of course)
|
||||
@@ -133,51 +98,23 @@ type
|
||||
// An array of scalar values of the same kind.
|
||||
TScalarArray = record
|
||||
public
|
||||
Kind: TScalarKind;
|
||||
Items: TArray<TScalarValue>;
|
||||
|
||||
// Creates a new scalar array.
|
||||
constructor Create(AKind: TScalarKind; const AItems: TArray<TScalarValue>);
|
||||
|
||||
function GetKind: TScalarKind; inline;
|
||||
function GetItems: TArray<TScalarValue>; inline;
|
||||
|
||||
property Kind: TScalarKind read GetKind;
|
||||
property Items: TArray<TScalarValue> read GetItems;
|
||||
|
||||
strict private
|
||||
FKind: TScalarKind;
|
||||
FItems: TArray<TScalarValue>;
|
||||
end;
|
||||
|
||||
TScalarTuple = TArray<TScalar>;
|
||||
|
||||
// A field definition for a scalar record.
|
||||
TScalarRecordField = record
|
||||
public
|
||||
// Creates a new record field definition.
|
||||
Name: String;
|
||||
Kind: TScalarKind;
|
||||
constructor Create(const AName: String; AKind: TScalarKind);
|
||||
|
||||
function GetName: String; inline;
|
||||
function GetKind: TScalarKind; inline;
|
||||
|
||||
property Name: String read GetName;
|
||||
property Kind: TScalarKind read GetKind;
|
||||
|
||||
strict private
|
||||
FName: String;
|
||||
FKind: TScalarKind;
|
||||
end;
|
||||
|
||||
// A collection of field definitions that describe a scalar record.
|
||||
TScalarRecordDefinition = record
|
||||
public
|
||||
// Creates a new record definition.
|
||||
constructor Create(const AFields: TArray<TScalarRecordField>);
|
||||
|
||||
function GetFields: TArray<TScalarRecordField>; inline;
|
||||
property Fields: TArray<TScalarRecordField> read GetFields;
|
||||
|
||||
strict private
|
||||
FFields: TArray<TScalarRecordField>;
|
||||
end;
|
||||
TScalarRecordDefinition = TArray<TScalarRecordField>;
|
||||
|
||||
// A record of scalar values, based on a definition.
|
||||
TScalarRecord = record
|
||||
@@ -215,272 +152,213 @@ type
|
||||
FItems: TSeries<TScalarValue>;
|
||||
end;
|
||||
|
||||
// A time series of scalar records, optimized for memory and access speed.
|
||||
TScalarRecordSeries = record
|
||||
private
|
||||
FDef: TScalarRecordDefinition;
|
||||
FArray: TChunkArray<TScalarValue>;
|
||||
FTotalCount: Int64;
|
||||
function GetDef: TScalarRecordDefinition; inline;
|
||||
function GetItems(Idx: Integer): TScalarRecord;
|
||||
public
|
||||
constructor Create(const ADef: TScalarRecordDefinition);
|
||||
procedure Add(const Item: TScalarRecord; Lookback: Int64 = -1);
|
||||
property Def: TScalarRecordDefinition read GetDef;
|
||||
property Items[Idx: Integer]: TScalarRecord read GetItems; default;
|
||||
property TotalCount: Int64 read FTotalCount;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TScalarValue }
|
||||
|
||||
class function TScalarValue.FromBoolean(AValue: Boolean): TScalarValue;
|
||||
begin
|
||||
Result.FBoolean := AValue;
|
||||
Result.AsBoolean := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromBytes(const AValue: TScalarBytes): TScalarValue;
|
||||
begin
|
||||
Result.FBytes := AValue;
|
||||
Result.AsBytes := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromChar(AValue: Char): TScalarValue;
|
||||
begin
|
||||
Result.FChar := AValue;
|
||||
Result.AsChar := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromDateTime(AValue: TDateTime): TScalarValue;
|
||||
begin
|
||||
Result.FDateTime := AValue;
|
||||
Result.AsDateTime := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromDecimal(AValue: TDecimal): TScalarValue;
|
||||
begin
|
||||
Result.FDecimal := AValue;
|
||||
Result.AsDecimal := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromDouble(AValue: Double): TScalarValue;
|
||||
begin
|
||||
Result.FDouble := AValue;
|
||||
Result.AsDouble := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromInt64(AValue: Int64): TScalarValue;
|
||||
begin
|
||||
Result.FInt64 := AValue;
|
||||
Result.AsInt64 := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromInteger(AValue: Integer): TScalarValue;
|
||||
begin
|
||||
Result.FInteger := AValue;
|
||||
Result.AsInteger := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromPChar(const AValue: String): TScalarValue;
|
||||
var
|
||||
len, i: Integer;
|
||||
begin
|
||||
FillChar(Result.FPChar, SizeOf(Result.FPChar), #0);
|
||||
FillChar(Result.AsPChar, SizeOf(Result.AsPChar), #0);
|
||||
len := Length(AValue);
|
||||
if (len > 0) then
|
||||
begin
|
||||
if (len > Length(Result.FPChar)) then
|
||||
len := Length(Result.FPChar);
|
||||
if (len > Length(Result.AsPChar)) then
|
||||
len := Length(Result.AsPChar);
|
||||
for i := 0 to len - 1 do
|
||||
Result.FPChar[i] := AValue[i + 1];
|
||||
Result.AsPChar[i] := AValue[i + 1];
|
||||
end;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromPChar(const AValue: TScalarPChar): TScalarValue;
|
||||
begin
|
||||
Result.FPChar := AValue;
|
||||
Result.AsPChar := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromSingle(AValue: Single): TScalarValue;
|
||||
begin
|
||||
Result.FSingle := AValue;
|
||||
Result.AsSingle := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromString(const AValue: String): TScalarValue;
|
||||
begin
|
||||
Result.FString := ShortString(AValue);
|
||||
Result.AsString := ShortString(AValue);
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromString(const AValue: TScalarString): TScalarValue;
|
||||
begin
|
||||
Result.FString := AValue;
|
||||
Result.AsString := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromTimestamp(AValue: TTimestamp): TScalarValue;
|
||||
begin
|
||||
Result.FTimestamp := AValue;
|
||||
Result.AsTimestamp := AValue;
|
||||
end;
|
||||
|
||||
class function TScalarValue.FromUInt64(AValue: UInt64): TScalarValue;
|
||||
begin
|
||||
Result.FUInt64 := AValue;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsBoolean: Boolean;
|
||||
begin
|
||||
Result := FBoolean;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsBytes: TScalarBytes;
|
||||
begin
|
||||
Result := FBytes;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsChar: Char;
|
||||
begin
|
||||
Result := FChar;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsDateTime: TDateTime;
|
||||
begin
|
||||
Result := FDateTime;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsDecimal: TDecimal;
|
||||
begin
|
||||
Result := FDecimal;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsDouble: Double;
|
||||
begin
|
||||
Result := FDouble;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsInt64: Int64;
|
||||
begin
|
||||
Result := FInt64;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsInteger: Integer;
|
||||
begin
|
||||
Result := FInteger;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsPChar: PChar;
|
||||
begin
|
||||
Result := @FPChar;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsSingle: Single;
|
||||
begin
|
||||
Result := FSingle;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsString: ShortString;
|
||||
begin
|
||||
Result := FString;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsTimestamp: TTimestamp;
|
||||
begin
|
||||
Result := FTimestamp;
|
||||
end;
|
||||
|
||||
function TScalarValue.GetAsUInt64: UInt64;
|
||||
begin
|
||||
Result := FUInt64;
|
||||
Result.AsUInt64 := AValue;
|
||||
end;
|
||||
|
||||
{ TScalar }
|
||||
|
||||
constructor TScalar.Create(AKind: TScalarKind; const AValue: TScalarValue);
|
||||
begin
|
||||
FKind := AKind;
|
||||
FValue := AValue;
|
||||
Kind := AKind;
|
||||
Value := AValue;
|
||||
end;
|
||||
|
||||
class function TScalar.FromBoolean(AValue: Boolean): TScalar;
|
||||
begin
|
||||
Result.FKind := skBoolean;
|
||||
Result.FValue := TScalarValue.FromBoolean(AValue);
|
||||
Result.Kind := skBoolean;
|
||||
Result.Value := TScalarValue.FromBoolean(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromBytes(const AValue: TScalarBytes): TScalar;
|
||||
begin
|
||||
Result.FKind := skBytes;
|
||||
Result.FValue := TScalarValue.FromBytes(AValue);
|
||||
Result.Kind := skBytes;
|
||||
Result.Value := TScalarValue.FromBytes(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromChar(AValue: Char): TScalar;
|
||||
begin
|
||||
Result.FKind := skChar;
|
||||
Result.FValue := TScalarValue.FromChar(AValue);
|
||||
Result.Kind := skChar;
|
||||
Result.Value := TScalarValue.FromChar(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromDateTime(AValue: TDateTime): TScalar;
|
||||
begin
|
||||
Result.FKind := skDateTime;
|
||||
Result.FValue := TScalarValue.FromDateTime(AValue);
|
||||
Result.Kind := skDateTime;
|
||||
Result.Value := TScalarValue.FromDateTime(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromDecimal(AValue: TDecimal): TScalar;
|
||||
class function TScalar.FromDecimal(const AValue: TDecimal): TScalar;
|
||||
begin
|
||||
Result.FKind := skDecimal;
|
||||
Result.FValue := TScalarValue.FromDecimal(AValue);
|
||||
Result.Kind := skDecimal;
|
||||
Result.Value := TScalarValue.FromDecimal(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromDouble(AValue: Double): TScalar;
|
||||
begin
|
||||
Result.FKind := skDouble;
|
||||
Result.FValue := TScalarValue.FromDouble(AValue);
|
||||
Result.Kind := skDouble;
|
||||
Result.Value := TScalarValue.FromDouble(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromInt64(AValue: Int64): TScalar;
|
||||
begin
|
||||
Result.FKind := skInt64;
|
||||
Result.FValue := TScalarValue.FromInt64(AValue);
|
||||
Result.Kind := skInt64;
|
||||
Result.Value := TScalarValue.FromInt64(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromInteger(AValue: Integer): TScalar;
|
||||
begin
|
||||
Result.FKind := skInteger;
|
||||
Result.FValue := TScalarValue.FromInteger(AValue);
|
||||
Result.Kind := skInteger;
|
||||
Result.Value := TScalarValue.FromInteger(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromPChar(const AValue: TScalarPChar): TScalar;
|
||||
begin
|
||||
Result.FKind := skPChar;
|
||||
Result.FValue := TScalarValue.FromPChar(AValue);
|
||||
Result.Kind := skPChar;
|
||||
Result.Value := TScalarValue.FromPChar(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromSingle(AValue: Single): TScalar;
|
||||
begin
|
||||
Result.FKind := skSingle;
|
||||
Result.FValue := TScalarValue.FromSingle(AValue);
|
||||
Result.Kind := skSingle;
|
||||
Result.Value := TScalarValue.FromSingle(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromString(const AValue: String): TScalar;
|
||||
begin
|
||||
Result.FKind := skString;
|
||||
Result.FValue := TScalarValue.FromString(AValue);
|
||||
Result.Kind := skString;
|
||||
Result.Value := TScalarValue.FromString(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromTimestamp(AValue: TTimestamp): TScalar;
|
||||
begin
|
||||
Result.FKind := skTimestamp;
|
||||
Result.FValue := TScalarValue.FromTimestamp(AValue);
|
||||
Result.Kind := skTimestamp;
|
||||
Result.Value := TScalarValue.FromTimestamp(AValue);
|
||||
end;
|
||||
|
||||
class function TScalar.FromUInt64(AValue: UInt64): TScalar;
|
||||
begin
|
||||
Result.FKind := skUInt64;
|
||||
Result.FValue := TScalarValue.FromUInt64(AValue);
|
||||
end;
|
||||
|
||||
function TScalar.GetKind: TScalarKind;
|
||||
begin
|
||||
Result := FKind;
|
||||
end;
|
||||
|
||||
function TScalar.GetValue: TScalarValue;
|
||||
begin
|
||||
Result := FValue;
|
||||
Result.Kind := skUInt64;
|
||||
Result.Value := TScalarValue.FromUInt64(AValue);
|
||||
end;
|
||||
|
||||
function TScalar.ToString: String;
|
||||
begin
|
||||
case FKind of
|
||||
skInteger: Result := IntToStr(FValue.AsInteger);
|
||||
skInt64: Result := IntToStr(FValue.AsInt64);
|
||||
skUInt64: Result := UIntToStr(FValue.AsUInt64);
|
||||
skSingle: Result := FloatToStr(FValue.AsSingle);
|
||||
skDouble: Result := FloatToStr(FValue.AsDouble);
|
||||
skDateTime: Result := DateTimeToStr(FValue.AsDateTime);
|
||||
skTimestamp: Result := FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz', TimeStampToDateTime(FValue.AsTimestamp));
|
||||
skBoolean: Result := BoolToStr(FValue.AsBoolean, True);
|
||||
skChar: Result := '''' + FValue.AsChar + '''';
|
||||
skPChar: Result := FValue.AsPChar; // Already null-terminated
|
||||
skString: Result := '''' + string(FValue.AsString) + '''';
|
||||
case Kind of
|
||||
skInteger: Result := IntToStr(Value.AsInteger);
|
||||
skInt64: Result := IntToStr(Value.AsInt64);
|
||||
skUInt64: Result := UIntToStr(Value.AsUInt64);
|
||||
skSingle: Result := FloatToStr(Value.AsSingle);
|
||||
skDouble: Result := FloatToStr(Value.AsDouble);
|
||||
skDateTime: Result := DateTimeToStr(Value.AsDateTime);
|
||||
skTimestamp: Result := FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz', TimeStampToDateTime(Value.AsTimestamp));
|
||||
skBoolean: Result := BoolToStr(Value.AsBoolean, True);
|
||||
skChar: Result := '''' + Value.AsChar + '''';
|
||||
skPChar: Result := PChar(@Value.AsPChar); // Needs explicit cast/pointer
|
||||
skString: Result := '''' + string(Value.AsString) + '''';
|
||||
skBytes: Result := '(Bytes)';
|
||||
skDecimal: Result := FloatToStr(Double(FValue.AsDecimal));
|
||||
skDecimal: Result := FloatToStr(Double(Value.AsDecimal));
|
||||
else
|
||||
Result := '[Unknown Scalar]';
|
||||
end;
|
||||
@@ -490,55 +368,23 @@ end;
|
||||
|
||||
constructor TScalarArray.Create(AKind: TScalarKind; const AItems: TArray<TScalarValue>);
|
||||
begin
|
||||
FKind := AKind;
|
||||
FItems := AItems;
|
||||
end;
|
||||
|
||||
function TScalarArray.GetKind: TScalarKind;
|
||||
begin
|
||||
Result := FKind;
|
||||
end;
|
||||
|
||||
function TScalarArray.GetItems: TArray<TScalarValue>;
|
||||
begin
|
||||
Result := FItems;
|
||||
Kind := AKind;
|
||||
Items := AItems;
|
||||
end;
|
||||
|
||||
{ TScalarRecordField }
|
||||
|
||||
constructor TScalarRecordField.Create(const AName: String; AKind: TScalarKind);
|
||||
begin
|
||||
FName := AName;
|
||||
FKind := AKind;
|
||||
end;
|
||||
|
||||
function TScalarRecordField.GetName: String;
|
||||
begin
|
||||
Result := FName;
|
||||
end;
|
||||
|
||||
function TScalarRecordField.GetKind: TScalarKind;
|
||||
begin
|
||||
Result := FKind;
|
||||
end;
|
||||
|
||||
{ TScalarRecordDefinition }
|
||||
|
||||
constructor TScalarRecordDefinition.Create(const AFields: TArray<TScalarRecordField>);
|
||||
begin
|
||||
FFields := AFields;
|
||||
end;
|
||||
|
||||
function TScalarRecordDefinition.GetFields: TArray<TScalarRecordField>;
|
||||
begin
|
||||
Result := FFields;
|
||||
Name := AName;
|
||||
Kind := AKind;
|
||||
end;
|
||||
|
||||
{ TScalarRecord }
|
||||
|
||||
constructor TScalarRecord.Create(const ADef: TScalarRecordDefinition; const AFields: TArray<TScalarValue>);
|
||||
begin
|
||||
Assert(Length(ADef.Fields) = Length(AFields), 'Field definition and value count must match.');
|
||||
Assert(Length(ADef) = Length(AFields), 'Field definition and value count must match.');
|
||||
FDef := ADef;
|
||||
FFields := AFields;
|
||||
end;
|
||||
@@ -559,9 +405,9 @@ var
|
||||
fieldDef: TScalarRecordField;
|
||||
begin
|
||||
// Find the index of the field by name (case-insensitive)
|
||||
for i := 0 to Length(FDef.Fields) - 1 do
|
||||
for i := 0 to Length(FDef) - 1 do
|
||||
begin
|
||||
fieldDef := FDef.Fields[i];
|
||||
fieldDef := FDef[i];
|
||||
if (CompareText(fieldDef.Name, Name) = 0) then
|
||||
begin
|
||||
// Found it. Construct the TScalar result from the kind and value.
|
||||
@@ -592,7 +438,42 @@ begin
|
||||
Result := FItems;
|
||||
end;
|
||||
|
||||
{ TScalarRecordSeries }
|
||||
|
||||
// Implements a time series of scalar records using a chunk array for efficient storage.
|
||||
// Each record's fields are stored sequentially in the TChunkArray.
|
||||
|
||||
constructor TScalarRecordSeries.Create(const ADef: TScalarRecordDefinition);
|
||||
begin
|
||||
Assert(Length(ADef) > 0);
|
||||
FDef := ADef;
|
||||
FArray := Default(TChunkArray<TScalarValue>);
|
||||
FTotalCount := 0;
|
||||
end;
|
||||
|
||||
procedure TScalarRecordSeries.Add(const Item: TScalarRecord; Lookback: Int64 = -1);
|
||||
begin
|
||||
FArray.Add(Item.Fields, Length(FDef) * Lookback);
|
||||
inc(FTotalCount);
|
||||
end;
|
||||
|
||||
function TScalarRecordSeries.GetDef: TScalarRecordDefinition;
|
||||
begin
|
||||
Result := FDef;
|
||||
end;
|
||||
|
||||
function TScalarRecordSeries.GetItems(Idx: Integer): TScalarRecord;
|
||||
var
|
||||
values: TArray<TScalarValue>;
|
||||
fieldCount: Integer;
|
||||
begin
|
||||
fieldCount := Length(FDef);
|
||||
SetLength(values, fieldCount);
|
||||
Move(FArray.ItemRef[(FArray.Count - fieldCount) - (Idx * fieldCount)]^, values[0], sizeof(TScalarValue) * fieldCount);
|
||||
Result.Create(FDef, values);
|
||||
end;
|
||||
|
||||
initialization
|
||||
Assert(sizeof(TScalarValue) = 16);
|
||||
Assert(sizeof(TScalarValue) = 8);
|
||||
|
||||
end.
|
||||
|
||||
+19
-10
@@ -4,16 +4,19 @@ interface
|
||||
|
||||
type
|
||||
TChunkArray<T> = record
|
||||
type
|
||||
PT = ^T;
|
||||
private
|
||||
const
|
||||
ChunkSize = 1024;
|
||||
type
|
||||
TChunk = TArray<T>;
|
||||
TChunk = array of T;
|
||||
private
|
||||
FChunks: TArray<TChunk>;
|
||||
FOffset: Integer;
|
||||
FCount: Integer;
|
||||
function GetItems(Idx: Integer): T; inline;
|
||||
function GetItemRef(Idx: Integer): PT; inline;
|
||||
|
||||
public
|
||||
constructor Create(const AChunks: TArray<TChunk>; ACount: Integer; AOffset: Integer);
|
||||
@@ -32,6 +35,7 @@ type
|
||||
|
||||
property Count: Integer read FCount;
|
||||
property Items[Idx: Integer]: T read GetItems; default;
|
||||
property ItemRef[Idx: Integer]: PT read GetItemRef;
|
||||
end;
|
||||
|
||||
// A series where the last added item has index 0.
|
||||
@@ -274,9 +278,7 @@ end;
|
||||
|
||||
function TChunkArray<T>.GetItems(Idx: Integer): T;
|
||||
begin
|
||||
// Convert logical index to physical index inside chunks
|
||||
var physicalIdx := Idx + FOffset;
|
||||
Result := FChunks[physicalIdx div ChunkSize][physicalIdx mod ChunkSize];
|
||||
Result := GetItemRef(Idx)^;
|
||||
end;
|
||||
|
||||
function TChunkArray<T>.Copy(MaxCount: Integer): TChunkArray<T>;
|
||||
@@ -341,6 +343,13 @@ begin
|
||||
Result.FCount := effectiveCount;
|
||||
end;
|
||||
|
||||
function TChunkArray<T>.GetItemRef(Idx: Integer): PT;
|
||||
begin
|
||||
Assert((Idx >= 0) and (Idx < FCount));
|
||||
var physicalIdx := Idx + FOffset;
|
||||
Result := @FChunks[physicalIdx div ChunkSize][physicalIdx mod ChunkSize];
|
||||
end;
|
||||
|
||||
class operator TChunkArray<T>.Initialize(out Dest: TChunkArray<T>);
|
||||
begin
|
||||
Dest.FOffset := 0;
|
||||
@@ -349,6 +358,12 @@ end;
|
||||
|
||||
{ TSeries<T> }
|
||||
|
||||
constructor TSeries<T>.Create(const AArray: TChunkArray<T>; ATotalCount: Int64);
|
||||
begin
|
||||
FArray := AArray;
|
||||
FTotalCount := ATotalCount;
|
||||
end;
|
||||
|
||||
procedure TSeries<T>.Add(const Data: T; Lookback: Int64);
|
||||
begin
|
||||
FArray.Add(Data, Lookback);
|
||||
@@ -361,12 +376,6 @@ begin
|
||||
inc(FTotalCount, Length(Data));
|
||||
end;
|
||||
|
||||
constructor TSeries<T>.Create(const AArray: TChunkArray<T>; ATotalCount: Int64);
|
||||
begin
|
||||
FArray := AArray;
|
||||
FTotalCount := ATotalCount;
|
||||
end;
|
||||
|
||||
function TSeries<T>.Copy(Lookback: Integer): TSeries<T>;
|
||||
begin
|
||||
// Create a copy of the underlying chunk array, optionally truncating it.
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
unit Myc.Trade.Indicators_V2;
|
||||
unit Myc.Trade.Indicators_V2 deprecated;
|
||||
|
||||
interface
|
||||
|
||||
@@ -377,7 +377,7 @@ begin
|
||||
begin
|
||||
shortName := rttiType.Name;
|
||||
end;
|
||||
|
||||
{
|
||||
// Create the main factory procedure. This is a double-nested anonymous method
|
||||
// that wraps the template's specific factory and worker functions.
|
||||
factoryProc :=
|
||||
@@ -419,7 +419,7 @@ begin
|
||||
Result := DataValueFromTValue(resultAsTValue);
|
||||
end;
|
||||
end;
|
||||
|
||||
}
|
||||
// Create the final factory instance with all type handles and extracted metadata.
|
||||
Result := TGenericIndicatorFactory.Create(factoryProc, shortName, name, hint, paramsDataType, argsDataType, resultDataType);
|
||||
end;
|
||||
@@ -452,7 +452,7 @@ begin
|
||||
var paramsAsTValue := TValue.From<TParams>(Params);
|
||||
var paramsAsDataValue := DataValueFromTValue(paramsAsTValue);
|
||||
var cIndicator := FFactoryProc(paramsAsDataValue);
|
||||
|
||||
{
|
||||
Result :=
|
||||
function(const Args: TArgs): TResult
|
||||
begin
|
||||
@@ -461,7 +461,7 @@ begin
|
||||
var resultAsDataValue := cIndicator(argsAsDataValue);
|
||||
var resultAsTValue := resultAsDataValue.AsTValue;
|
||||
Result := resultAsTValue.AsType<TResult>;
|
||||
end;
|
||||
end;}
|
||||
end;
|
||||
|
||||
{ TIndicatorRegistry.TItem }
|
||||
@@ -481,7 +481,7 @@ begin
|
||||
var paramsAsTValue := TValue.From<TParams>(Params);
|
||||
var paramsAsDataValue := DataValueFromTValue(paramsAsTValue);
|
||||
var cIndicator := FFactory.CreateIndicator(paramsAsDataValue);
|
||||
|
||||
{
|
||||
// Return a wrapper that handles the conversion for args and result.
|
||||
Result :=
|
||||
function(const Args: TArgs): TResult
|
||||
@@ -491,7 +491,7 @@ begin
|
||||
var resultAsDataValue := cIndicator(argsAsDataValue);
|
||||
var resultAsTValue := resultAsDataValue.AsTValue;
|
||||
Result := resultAsTValue.AsType<TResult>;
|
||||
end;
|
||||
end;}
|
||||
end;
|
||||
|
||||
{ TIndicatorRegistry }
|
||||
|
||||
+54
-12
@@ -50,6 +50,9 @@ type
|
||||
procedure TestScalarRecordAndDefinition;
|
||||
[Test]
|
||||
procedure TestScalarSeries;
|
||||
|
||||
[Test]
|
||||
procedure TestScalarRecordSeries;
|
||||
end;
|
||||
|
||||
implementation
|
||||
@@ -117,7 +120,7 @@ begin
|
||||
skString:
|
||||
begin
|
||||
scalar := TScalar.FromString(AValueStr);
|
||||
s := Copy(AValueStr, 1, 15); // ShortString truncates to 15 chars
|
||||
s := Copy(AValueStr, 1, 7); // ShortString truncates to 7 chars
|
||||
Assert.AreEqual(AExpectedKind, scalar.Kind, 'Kind should be skString');
|
||||
Assert.AreEqual(s, string(scalar.Value.AsString), 'Value mismatch for AsString');
|
||||
end;
|
||||
@@ -223,23 +226,21 @@ var
|
||||
begin
|
||||
// 1. Create a definition
|
||||
recDef :=
|
||||
TScalarRecordDefinition.Create(
|
||||
[
|
||||
TScalarRecordField.Create('ID', skInt64),
|
||||
TScalarRecordField.Create('Name', skString),
|
||||
TScalarRecordField.Create('Price', skDecimal)
|
||||
]
|
||||
);
|
||||
Assert.AreEqual(Int64(3), Length(recDef.Fields), 'Record definition field count mismatch');
|
||||
Assert.AreEqual('Name', recDef.Fields[1].Name, 'Record definition field name mismatch');
|
||||
[
|
||||
TScalarRecordField.Create('ID', skInt64),
|
||||
TScalarRecordField.Create('Name', skString),
|
||||
TScalarRecordField.Create('Price', skDecimal)
|
||||
];
|
||||
Assert.AreEqual(Int64(3), Length(recDef), 'Record definition field count mismatch');
|
||||
Assert.AreEqual('Name', recDef[1].Name, 'Record definition field name mismatch');
|
||||
|
||||
// 2. Create a matching set of values
|
||||
values := [TScalar.FromInt64(99).Value, TScalar.FromString('ProductX').Value, TScalar.FromDecimal(TDecimal.Create(1995, 2)).Value];
|
||||
values := [TScalar.FromInt64(99).Value, TScalar.FromString('Product').Value, TScalar.FromDecimal(TDecimal.Create(1995, 2)).Value];
|
||||
|
||||
// 3. Create the record
|
||||
rec := TScalarRecord.Create(recDef, values);
|
||||
Assert.AreEqual(Int64(3), Length(rec.Fields), 'Record field count mismatch');
|
||||
Assert.AreEqual('ProductX', string(rec.Fields[1].AsString), 'Record field value mismatch');
|
||||
Assert.AreEqual('Product', string(rec.Fields[1].AsString), 'Record field value mismatch');
|
||||
Assert.AreEqual(TDecimal.Create(1995, 2), rec.Fields[2].AsDecimal, 'Record decimal field value mismatch');
|
||||
|
||||
// 4. Test assertion for mismatched field count
|
||||
@@ -277,6 +278,47 @@ begin
|
||||
Assert.AreEqual(101.5, scalarSeries.Items[3].AsDouble, 1E-12, 'Series item [3] mismatch');
|
||||
end;
|
||||
|
||||
procedure TTestPOD.TestScalarRecordSeries;
|
||||
var
|
||||
recDef: TScalarRecordDefinition;
|
||||
series: TScalarRecordSeries;
|
||||
rec1, rec2, rec3: TScalarRecord;
|
||||
retrievedRec: TScalarRecord;
|
||||
begin
|
||||
// 1. Define the structure of the records in the series
|
||||
recDef := [TScalarRecordField.Create('ID', skInt64), TScalarRecordField.Create('Price', skDecimal)];
|
||||
|
||||
// 2. Create the series with the definition
|
||||
series := TScalarRecordSeries.Create(recDef);
|
||||
Assert.AreEqual(Int64(0), series.TotalCount, 'Initial series should be empty');
|
||||
|
||||
// 3. Create some records
|
||||
rec1 := TScalarRecord.Create(recDef, [TScalarValue.FromInt64(1), TScalarValue.FromDecimal(TDecimal.Create(100, 2))]);
|
||||
rec2 := TScalarRecord.Create(recDef, [TScalarValue.FromInt64(2), TScalarValue.FromDecimal(TDecimal.Create(101, 2))]);
|
||||
rec3 := TScalarRecord.Create(recDef, [TScalarValue.FromInt64(3), TScalarValue.FromDecimal(TDecimal.Create(102, 2))]);
|
||||
|
||||
// 4. Add records to the series
|
||||
series.Add(rec1);
|
||||
series.Add(rec2);
|
||||
series.Add(rec3);
|
||||
|
||||
// 5. Verify the state of the series
|
||||
Assert.AreEqual(Int64(3), series.TotalCount, 'Series total count mismatch after adding items');
|
||||
|
||||
// 6. Check items. Index 0 is the last added item.
|
||||
retrievedRec := series.Items[0]; // Should be rec3
|
||||
Assert.AreEqual(skInt64, retrievedRec['ID'].Kind, 'Item[0] ID kind mismatch');
|
||||
Assert.AreEqual(Int64(3), retrievedRec['ID'].Value.AsInt64, 'Item[0] ID value mismatch');
|
||||
Assert.AreEqual(TDecimal.Create(102, 2), retrievedRec['Price'].Value.AsDecimal, 'Item[0] Price value mismatch');
|
||||
|
||||
retrievedRec := series.Items[1]; // Should be rec2
|
||||
Assert.AreEqual(Int64(2), retrievedRec.Items['ID'].Value.AsInt64, 'Item[1] ID value mismatch');
|
||||
|
||||
retrievedRec := series.Items[2]; // Should be rec1
|
||||
Assert.AreEqual(Int64(1), retrievedRec.Items['ID'].Value.AsInt64, 'Item[2] ID value mismatch');
|
||||
Assert.AreEqual(TDecimal.Create(100, 2), retrievedRec.Items['Price'].Value.AsDecimal, 'Item[2] Price value mismatch');
|
||||
end;
|
||||
|
||||
initialization
|
||||
FormatSettings.DecimalSeparator := '.';
|
||||
TDUnitX.RegisterTestFixture(TTestPOD);
|
||||
|
||||
Reference in New Issue
Block a user