Files
MycLib/ASTPlayground/MainForm.pas
T
2025-11-05 18:13:43 +01:00

1364 lines
50 KiB
ObjectPascal

unit MainForm;
interface
uses
System.SysUtils,
System.Types,
System.TypInfo,
System.UITypes,
System.Classes,
System.Variants,
System.Generics.Collections,
System.Math,
System.JSON,
FMX.Types,
FMX.Controls,
FMX.Forms,
FMX.Graphics,
FMX.Dialogs,
FMX.Memo.Types,
FMX.StdCtrls,
FMX.ScrollBox,
FMX.Memo,
FMX.Controls.Presentation,
Myc.Data.Scalar,
Myc.Data.Value,
Myc.Ast.Nodes,
Myc.Ast.Scope,
Myc.Ast,
Myc.Ast.Visitor,
Myc.Ast.Evaluator,
Myc.Ast.Dumper,
Myc.Data.Decimal,
Myc.Ast.Binding,
Myc.Ast.RTL,
Myc.Ast.Script,
FMX.Layouts,
FMX.Objects,
Myc.Ast.Debugger,
Myc.Fmx.AstEditor.Node,
Myc.Fmx.AstEditor.Workspace,
Myc.Ast.MacroExpander,
Myc.Ast.TypeChecker,
Myc.Ast.Lowering,
Myc.Ast.Compiler.TCO,
FMX.DialogService,
FMX.ListView.Types,
FMX.ListView.Appearances,
FMX.ListView.Adapters.Base,
FMX.ListView;
type
// A test record
TOHLCV = record
Timestamp: TDateTime;
Open: Double;
High: Double;
Low: Double;
Close: Double;
Volume: Int64;
end;
TForm1 = class(TForm)
Panel1: TPanel;
Memo1: TMemo;
Test1Button: TButton;
Test2Button: TButton;
PrettyPrintButton: TButton;
RecursionButton: TButton;
ShowScopeBox: TCheckBox;
FibonacciButton: TButton;
CrerateTriggerExampleButton: TButton;
DoTriggerButton: TButton;
DoTrigger2Button: TButton;
Panel2: TPanel;
ClearButton: TButton;
SeriesTestButton: TButton;
OHLCButton: TButton;
DebugBox: TCheckBox;
FromJSONButton: TButton;
ToJSONButton: TButton;
ExternalFuncButton: TButton;
InnerLambdaButton: TButton;
DumpButton: TButton;
FailingUpvalueButton: TButton;
TailCallButten: TButton;
Splitter1: TSplitter;
Splitter2: TSplitter;
ScriptMemo: TMemo;
LoadUserLibButton: TButton;
SaveUserLibButton: TButton;
RTLListView: TListView;
procedure InnerLambdaButtonClick(Sender: TObject);
procedure ClearButtonClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure CreateTriggerExampleButtonClick(Sender: TObject);
procedure DoTrigger2ButtonClick(Sender: TObject);
procedure DoTriggerButtonClick(Sender: TObject);
procedure DumpButtonClick(Sender: TObject);
procedure ExternalFuncButtonClick(Sender: TObject);
procedure FailingUpvalueButtonClick(Sender: TObject);
procedure FibonacciButtonClick(Sender: TObject);
procedure FlowOnlyBoxChange(Sender: TObject);
procedure OHLCButtonClick(Sender: TObject);
procedure PrettyPrintButtonClick(Sender: TObject);
procedure RecursionButtonClick(Sender: TObject);
procedure SeriesTestButtonClick(Sender: TObject);
procedure Test1ButtonClick(Sender: TObject);
procedure Test2ButtonClick(Sender: TObject);
procedure FromJSONButtonClick(Sender: TObject);
procedure ScriptMemoChange(Sender: TObject);
procedure TailCallButtenClick(Sender: TObject);
procedure ToJSONButtonClick(Sender: TObject);
procedure SaveUserLibButtonClick(Sender: TObject);
procedure LoadUserLibButtonClick(Sender: TObject);
procedure RTLListViewChange(Sender: TObject);
private
FCurrUnboundAst: IAstNode;
FCurrAst: IAstNode;
FCurrDesc: IScopeDescriptor;
FGScope: IExecutionScope;
FWorkspace: TAuraWorkspace;
FTriggerScope: IExecutionScope;
FScriptUpdate: Boolean;
procedure WorkspaceMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
function CreateEvaluator(const Scope: IExecutionScope): IEvaluatorVisitor;
// Helper function to encapsulate the compilation pipeline
function CompileAst(const ANode: IAstNode; const AParentScope: IExecutionScope; out ADescriptor: IScopeDescriptor): IAstNode;
// Helper function to encapsulate the Compile -> Evaluate pattern
function ExecuteAst(const ANode: IAstNode; const AParentScope: IExecutionScope): TDataValue;
procedure UpdateScript;
procedure ShowVizualization(X, Y: Single);
procedure PrintScript(const Node: IAstNode);
public
{ Public declarations }
end;
const
UserLibName = 'T:\Myc\ASTPlayground\UserLib.json';
var
Form1: TForm1;
implementation
uses
Myc.Data.Scalar.JSON,
System.Diagnostics, // For TStopwatch
Myc.Ast.Json, // For TAstJson serialization
Myc.Ast.Types, // Needed for TTypeRules
System.IOUtils; // For TFile
{$R *.fmx}
procedure TForm1.InnerLambdaButtonClick(Sender: TObject);
var
mainBlock: IAstNode;
resultValue: TDataValue;
begin
mainBlock :=
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('outer'),
TAst.LambdaExpr(
[],
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('x'), TAst.Constant(10)),
TAst.VarDecl(
TAst.Identifier('inner'),
TAst.LambdaExpr(
[],
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('innermost'),
TAst.LambdaExpr(
[],
TAst.Assign(
TAst.Identifier('x'),
TAst.BinaryExpr(TAst.Identifier('x'), TScalar.TBinaryOp.Add, TAst.Constant(5))
)
)
),
TAst.FunctionCall(TAst.Identifier('innermost'), [])
]
)
)
),
TAst.FunctionCall(TAst.Identifier('inner'), []),
TAst.Identifier('x')
]
)
)
),
TAst.VarDecl(TAst.Identifier('finalResult'), TAst.FunctionCall(TAst.Identifier('outer'), []))
]
);
resultValue := ExecuteAst(mainBlock, FGScope);
Assert(TScalar.FromInt64(15) = resultValue.AsScalar, 'The final result should be 15, but is ' + resultValue.AsScalar.ToString);
UpdateScript;
end;
procedure TForm1.ClearButtonClick(Sender: TObject);
begin
FWorkspace.DeleteChildren;
FWorkspace.Repaint;
FGScope := TAst.CreateScope(nil);
end;
function TForm1.CompileAst(const ANode: IAstNode; const AParentScope: IExecutionScope; out ADescriptor: IScopeDescriptor): IAstNode;
var
expandedAst, boundAst, typedAst, loweredAst: IAstNode;
begin
// Step 1: Expand macros (Phase 1)
expandedAst := TMacroExpander.ExpandMacros(AParentScope, ANode, CreateEvaluator);
// Step 2: Bind names and addresses (Phase 2)
boundAst := TAstBinder.Bind(AParentScope, expandedAst, ADescriptor);
// Step 3: Check and infer types (Phase 3)
typedAst := TTypeChecker.CheckTypes(boundAst, ADescriptor);
// Step 4: Lowering / Canonicalization (Phase 4)
loweredAst := TAstLowerer.Lower(typedAst);
// Step 5: Tail Call Optimization (Phase 5)
Result := TAstTCO.Optimize(loweredAst);
end;
function TForm1.ExecuteAst(const ANode: IAstNode; const AParentScope: IExecutionScope): TDataValue;
var
descriptor: IScopeDescriptor;
evalScope: IExecutionScope;
visitor: IEvaluatorVisitor;
compiledAst: IAstNode;
begin
FCurrUnboundAst := ANode;
// Call the helper function for the full 4-stage pipeline
compiledAst := CompileAst(ANode, AParentScope, descriptor);
// Store the final bound AST for visualization and debugging.
FCurrAst := compiledAst; // <-- Store the fully compiled AST
FCurrDesc := descriptor;
// Create the final scope and evaluator for runtime execution.
evalScope := descriptor.CreateScope(AParentScope);
visitor := CreateEvaluator(evalScope);
Result := visitor.Execute(compiledAst);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FWorkspace := TAuraWorkspace.Create(Panel2);
FWorkspace.Parent := Panel2;
FWorkspace.Align := TAlignLayout.Client;
FWorkspace.ClipChildren := true;
FWorkspace.OnMouseDown := WorkspaceMouseDown;
TAst.RegisterLibrary(
procedure(const Scope: IExecutionScope)
var
smaAst, typedAst: IAstNode;
smaDescriptor: IScopeDescriptor;
smaScope: IExecutionScope;
smaVisitor: IEvaluatorVisitor;
begin
smaAst :=
TAst.LambdaExpr(
[TAst.Identifier('len')],
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('sum'), TAst.Constant(0.0)),
TAst.VarDecl(TAst.Identifier('count'), TAst.Constant(0)),
TAst.LambdaExpr(
[TAst.Identifier('series'), TAst.Identifier('val')],
TAst.Block(
[
TAst.Assign(
TAst.Identifier('sum'),
TAst.BinaryExpr(TAst.Identifier('sum'), TScalar.TBinaryOp.Add, TAst.Identifier('val'))
),
TAst.Assign(
TAst.Identifier('count'),
TAst.BinaryExpr(TAst.Identifier('count'), TScalar.TBinaryOp.Add, TAst.Constant(1))
),
TAst.Assign(
TAst.Identifier('sum'),
TAst.TernaryExpr(
TAst.BinaryExpr(
TAst.Identifier('count'),
TScalar.TBinaryOp.Greater,
TAst.Identifier('len')
),
TAst.BinaryExpr(
TAst.Identifier('sum'),
TScalar.TBinaryOp.Subtract,
TAst.Indexer(TAst.Identifier('series'), TAst.Identifier('len'))
),
TAst.Identifier('sum')
)
),
TAst.BinaryExpr(
TAst.Identifier('sum'),
TScalar.TBinaryOp.Divide,
TAst.TernaryExpr(
TAst.BinaryExpr(TAst.Identifier('count'), TScalar.TBinaryOp.Less, TAst.Identifier('len')),
TAst.Identifier('count'),
TAst.Identifier('len')
)
)
]
)
)
]
)
);
// Run the full pipeline
typedAst := CompileAst(smaAst, Scope, smaDescriptor);
smaScope := smaDescriptor.CreateScope(Scope);
smaVisitor := CreateEvaluator(smaScope);
// Execute the typed AST to define the function
smaVisitor.Execute(typedAst);
Scope.Define(
'print',
TDataValue(
function(const Args: TArray<TDataValue>): TDataValue
var
str: TStringBuilder;
begin
str := TStringBuilder.Create;
try
for var i := 0 to High(Args) do
begin
if Args[i].Kind = vkText then
str.Append(Args[i].AsText)
else
str.Append(Args[i].ToString);
end;
Memo1.Lines.Add(str.ToString);
finally
str.Free;
end;
end
)
);
end
);
ClearButtonClick(Self);
end;
procedure TForm1.LoadUserLibButtonClick(Sender: TObject);
var
jsonString: string;
jsonObj: TJSONObject;
pair: TJSONPair;
funcAst: IAstNode;
funcValue: TDataValue;
converter: IJsonAstConverter;
begin
// Load definitions from JSON and populate the global scope.
if not TFile.Exists(UserLibName) then
begin
Memo1.Lines.Add(Format('Library file "%s" not found.', [UserLibName]));
exit;
end;
try
converter := TJsonAstConverter.Create;
jsonString := TFile.ReadAllText(UserLibName);
jsonObj := TJSONObject.ParseJSONValue(jsonString) as TJSONObject;
if not Assigned(jsonObj) then
raise Exception.Create('Invalid JSON format for library file.');
try
Memo1.Lines.Add(Format('--- Loading User Library from %s ---', [ExtractFileName(UserLibName)]));
var scopeDescr := FGScope.CreateDescriptor;
// Populate the list view with loaded functions and macros.
RTLListView.Items.BeginUpdate;
try
for pair in jsonObj do
begin
if not (pair.JsonValue is TJSONObject) then
continue;
// First, deserialize the AST node from JSON.
funcAst := converter.Deserialize(pair.JsonValue as TJSONObject);
var sym := scopeDescr.FindSymbol(pair.JsonString.Value);
if sym.Address.Kind = akUnresolved then
begin
// Distinguish between loading a macro and loading a function.
if funcAst.Kind = akMacroDefinition then
begin
// Macros are stored as raw AST nodes in the scope.
FGScope.Define(pair.JsonString.Value, TDataValue.FromIntf<IAstNode>(funcAst));
Memo1.Lines.Add(Format('Defined macro "%s"', [pair.JsonString.Value]));
end
else
begin
// Functions (lambdas) must be executed to create a callable closure.
funcValue := ExecuteAst(funcAst, FGScope);
FGScope.Define(pair.JsonString.Value, funcValue);
Memo1.Lines.Add(Format('Defined function "%s"', [pair.JsonString.Value]));
end;
end
else
Memo1.Lines.Add(Format('Symbol "%s" already defined', [pair.JsonString.Value]));
// Add the new function/macro to the RTL list view.
RTLListView.Items.Add.Text := pair.JsonString.Value;
end;
finally
RTLListView.Items.EndUpdate;
end;
finally
jsonObj.Free;
end;
except
on E: Exception do
Memo1.Lines.Add('Error loading library: ' + E.Message);
end;
end;
procedure TForm1.SaveUserLibButtonClick(Sender: TObject);
var
rootNode: IAstNode;
definitions: TDictionary<string, IAstNode>;
jsonLib: TJSONObject;
converter: IJsonAstConverter;
jsonString: string;
updatedCount: Integer;
addedList: TList<String>;
begin
// Extract definitions from the current script and merge them into the JSON library.
try
rootNode := TAstScript.Parse(ScriptMemo.Lines.Text);
if not Assigned(rootNode) then
raise Exception.Create('Script is empty or invalid.');
definitions := TDictionary<string, IAstNode>.Create;
try
// Check if the root is a block and extract top-level definitions
if rootNode.Kind = akBlockExpression then
begin
for var expr in rootNode.AsBlockExpression.Expressions do
begin
// Use interface 'is' check
if (expr.Kind = akVariableDeclaration) then
begin
var decl := expr.AsVariableDeclaration;
definitions.Add(decl.Identifier.Name, decl.Initializer);
end
// Handle macro definitions inside the block
else if expr.Kind = akMacroDefinition then
begin
var macroDef := expr.AsMacroDefinition;
// Store the entire macro definition node for serialization.
definitions.Add(macroDef.Name.Name, macroDef);
end;
end;
end
// Use interface 'is' check
else if rootNode.Kind = akVariableDeclaration then // Handle single definition
begin
var decl := rootNode.AsVariableDeclaration;
definitions.Add(decl.Identifier.Name, decl.Initializer);
end
// Handle a single macro definition
else if rootNode.Kind = akMacroDefinition then
begin
var macroDef := rootNode.AsMacroDefinition;
definitions.Add(macroDef.Name.Name, macroDef);
end;
if definitions.Count = 0 then
begin
Memo1.Lines.Add('No top-level "(def ...)" or "(defmacro ...)" definitions found in the script to save.');
exit;
end;
// Load existing library file or create a new JSON object if it doesn't exist
jsonLib := nil;
if TFile.Exists(UserLibName) then
begin
jsonString := TFile.ReadAllText(UserLibName);
if not jsonString.IsEmpty then
jsonLib := TJSONObject.ParseJSONValue(jsonString) as TJSONObject;
end;
if not Assigned(jsonLib) then
jsonLib := TJSONObject.Create;
addedList := TList<String>.Create;
try
// Serialize and merge the definitions from the script into the JSON object
converter := TJsonAstConverter.Create;
updatedCount := 0;
for var pair in definitions do
begin
// Track if we are adding or updating a function/macro
if jsonLib.Values[pair.Key] <> nil then
begin
Inc(updatedCount);
jsonLib.RemovePair(pair.Key);
end
else
addedList.Add(pair.Key);
jsonLib.AddPair(pair.Key, converter.Serialize(pair.Value));
end;
TFile.WriteAllText(UserLibName, jsonLib.Format(4));
// Provide more detailed feedback to the user
Memo1.Lines.Add(Format('--- Library "%s" updated ---', [ExtractFileName(UserLibName)]));
if updatedCount > 0 then
Memo1.Lines.Add(Format('%d existing definitions updated.', [updatedCount]));
if addedList.Count > 0 then
begin
Memo1.Lines.Add(Format('%d new definitions added:', [addedList.Count]));
// Add the new item to the RTL list view.
RTLListView.Items.BeginUpdate;
try
for var n in addedList do
begin
Memo1.Lines.Add(n);
RTLListView.Items.Add.Text := n;
end;
finally
RTLListView.Items.EndUpdate;
end;
end;
finally
jsonLib.Free;
addedList.Free;
end;
finally
definitions.Free;
end;
except
on E: Exception do
Memo1.Lines.Add('Error saving library: ' + E.Message);
end;
end;
procedure TForm1.FromJSONButtonClick(Sender: TObject);
var
jsonString: string;
jsonObj: TJSONObject;
converter: IJsonAstConverter;
begin
Memo1.Lines.BeginUpdate;
try
jsonString := Memo1.Lines.Text;
Memo1.Lines.Clear;
if jsonString.IsEmpty then
begin
Memo1.Lines.Add('Memo is empty. Please paste an AST JSON string.');
exit;
end;
try
converter := TJsonAstConverter.Create;
jsonObj := TJSONObject.ParseJSONValue(jsonString) as TJSONObject;
if not Assigned(jsonObj) then
raise EJSONParseException.Create('Invalid JSON format.');
try
var unboundAst := converter.Deserialize(jsonObj);
// Run the full pipeline
FCurrAst := CompileAst(unboundAst, FGScope, FCurrDesc);
Memo1.Lines.Add('AST deserialized and bound successfully from JSON.');
Memo1.Lines.Add('You can now visualize it (Middle Mouse Click) or pretty-print it.');
finally
jsonObj.Free;
end;
except
on E: Exception do
begin
FCurrAst := nil;
FCurrDesc := nil;
Memo1.Lines.Add('Error deserializing AST from JSON:');
Memo1.Lines.Add(E.Message);
Memo1.Lines.Add('--- Original JSON ---');
Memo1.Lines.Text := Memo1.Lines.Text + sLineBreak + jsonString;
end;
end;
finally
Memo1.Lines.EndUpdate;
end;
UpdateScript;
end;
procedure TForm1.ToJSONButtonClick(Sender: TObject);
var
jsonObj: TJSONObject;
converter: IJsonAstConverter;
begin
Memo1.Lines.Clear;
if not Assigned(FCurrAst) then
begin
Memo1.Lines.Add('No AST available to serialize. Please generate one first.');
exit;
end;
try
converter := TJsonAstConverter.Create;
jsonObj := converter.Serialize(FCurrAst);
try
Memo1.Lines.Text := jsonObj.Format(4);
finally
jsonObj.Free;
end;
except
on E: Exception do
begin
Memo1.Lines.Add('Error serializing AST to JSON:');
Memo1.Lines.Add(E.Message);
end;
end;
end;
procedure TForm1.DumpButtonClick(Sender: TObject);
var
typedNode: IAstNode;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- AST Dump ---');
if not Assigned(FCurrUnboundAst) then
begin
Memo1.Lines.Add('No AST has been generated yet. Click a test button first.');
exit;
end;
// Re-run the full pipeline for the dump
typedNode := CompileAst(FCurrUnboundAst, FGScope, FCurrDesc);
TAstDumper.Dump(typedNode, Memo1.Lines);
end;
procedure TForm1.FibonacciButtonClick(Sender: TObject);
var
root, fibAst, typedAst: IAstNode;
result: TDataValue;
sw: TStopwatch;
fibScope: IExecutionScope;
visitor: IEvaluatorVisitor;
desc: IScopeDescriptor;
begin
fibAst :=
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('fib')),
TAst.Assign(
TAst.Identifier('fib'),
TAst.LambdaExpr(
[TAst.Identifier('n')],
TAst.TernaryExpr(
TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.Less, TAst.Constant(2)),
TAst.Identifier('n'),
TAst.BinaryExpr(
TAst.FunctionCall(
TAst.Identifier('fib'),
[TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.Subtract, TAst.Constant(1))]
),
TScalar.TBinaryOp.Add,
TAst.FunctionCall(
TAst.Identifier('fib'),
[TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.Subtract, TAst.Constant(2))]
)
)
)
)
)
]
);
// Run the full pipeline
typedAst := CompileAst(fibAst, FGScope, desc);
fibScope := desc.CreateScope(FGScope);
visitor := CreateEvaluator(fibScope);
visitor.Execute(typedAst);
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Naive recursive fib with AST---');
sw := TStopwatch.StartNew;
root := TAst.FunctionCall(TAst.Identifier('fib'), [TAst.Constant(25)]);
result := ExecuteAst(root, fibScope);
sw.Stop;
Memo1.Lines.Add(Format('Result: fib(25) %s (calculated in %d ms)', [result.ToString, sw.ElapsedMilliseconds]));
Memo1.Lines.Add('');
Memo1.Lines.Add('--- Memoized naive fib with AST (using global fib)---');
sw := TStopwatch.StartNew;
root :=
TAst.Block(
[
TAst.Assign(TAst.Identifier('fib'), TAst.FunctionCall(TAst.Identifier('Memoize'), [TAst.Identifier('fib')])),
TAst.FunctionCall(TAst.Identifier('fib'), [TAst.Constant(25)])
]
);
result := ExecuteAst(root, fibScope);
sw.Stop;
Memo1.Lines.Add(Format('Result: fib(25) %s (calculated in %d ms)', [result.ToString, sw.ElapsedMilliseconds]));
UpdateScript;
end;
procedure TForm1.PrettyPrintButtonClick(Sender: TObject);
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- AST Pretty Print ---');
if not Assigned(FCurrAst) then
begin
Memo1.Lines.Add('No AST has been generated yet.');
exit;
end;
Memo1.Lines.Add(TAstScript.Print(FCurrAst));
end;
procedure TForm1.RecursionButtonClick(Sender: TObject);
var
root: IAstNode;
result: TDataValue;
sw: TStopwatch;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Tail-Recursive factorial(20) ---');
sw := TStopwatch.StartNew;
// Rewritten to be tail-recursive to use 'recur'
root :=
TAst.Block(
[
// Define the tail-recursive helper function
TAst.VarDecl(
TAst.Identifier('fact_iter'),
TAst.LambdaExpr(
[TAst.Identifier('n'), TAst.Identifier('acc')],
TAst.TernaryExpr(
TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.LessOrEqual, TAst.Constant(1)),
TAst.Identifier('acc'), // Base case: return the accumulator
TAst.Recur( // Tail-recursive step
[
TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.Subtract, TAst.Constant(1)),
TAst.BinaryExpr(TAst.Identifier('acc'), TScalar.TBinaryOp.Multiply, TAst.Identifier('n'))
]
)
)
)
),
// Define the public-facing factorial function
TAst.VarDecl(
TAst.Identifier('factorial'),
TAst.LambdaExpr(
[TAst.Identifier('n')],
TAst.FunctionCall(TAst.Identifier('fact_iter'), [TAst.Identifier('n'), TAst.Constant(1)])
)
),
// Call the main function
TAst.FunctionCall(TAst.Identifier('factorial'), [TAst.Constant(20)])
]
);
// Execute with FGScope as parent.
result := ExecuteAst(root, FGScope);
sw.Stop;
Memo1.Lines.Add(Format('Result: %s (calculated in %d ms)', [result.ToString, sw.ElapsedMilliseconds]));
UpdateScript;
end;
procedure TForm1.SeriesTestButtonClick(Sender: TObject);
var
ast, callAst: IAstNode;
resultValue: TDataValue;
series: TScalarRecordSeries;
recordDef: IScalarRecordDefinition;
i: Integer;
scope: IExecutionScope;
values: TArray<TScalar.TValue>;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Series Test ---');
scope := TAst.CreateScope(FGScope);
recordDef := TRttiAstHelper.JsonToRecordDefinition(TRttiAstHelper.RecordDefinitionToJson<TOHLCV>);
series := TScalarRecordSeries.Create(recordDef);
SetLength(values, 6);
for i := 0 to 4 do
begin
values[0].AsInt64 := Round((Now + i) * 24 * 60 * 60 * 1000);
values[1].AsDouble := 100.0 + i;
values[2].AsDouble := 105.0 + i;
values[3].AsDouble := 98.0 + i;
values[4].AsDouble := 102.0 + i;
values[5].AsInt64 := 10000 * (i + 1);
series.Add(TScalarRecord.Create(recordDef, values));
end;
scope.Define('ohlcvSeries', TDataValue.FromRecordSeries(series));
ast :=
TAst.LambdaExpr(
[],
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('closeColumn'),
TAst.FunctionCall(TAst.Keyword('Close'), [TAst.Identifier('ohlcvSeries')])
// TAst.MemberAccess(TAst.Identifier('ohlcvSeries'), TAst.Identifier('Close'))
),
TAst.Indexer(TAst.Identifier('closeColumn'), TAst.Constant(1))
]
)
);
callAst := TAst.FunctionCall(ast, []);
resultValue := ExecuteAst(callAst, scope);
Memo1.Lines.Add(Format('Result of script: %s', [resultValue.ToString]));
UpdateScript;
end;
procedure TForm1.Test1ButtonClick(Sender: TObject);
begin
FCurrUnboundAst :=
TAst.Block(
[
TAst.LambdaExpr(
[],
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('a'), TAst.Nop),
TAst.VarDecl(
TAst.Identifier('b'),
TAst.BinaryExpr(TAst.Identifier('a'), TScalar.TBinaryOp.Multiply, TAst.Constant(2))
),
TAst.BinaryExpr(TAst.Identifier('a'), TScalar.TBinaryOp.Add, TAst.Identifier('b'))
]
)
)
]
);
UpdateScript;
end;
procedure TForm1.Test2ButtonClick(Sender: TObject);
var
root: IAstNode;
result: TDataValue;
sw: TStopwatch;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Factory Pattern Demo ---');
sw := TStopwatch.StartNew;
root :=
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('createStrategyInstance'),
TAst.LambdaExpr(
[TAst.Identifier('offset')],
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('baseValue'), TAst.Constant(100)),
TAst.BinaryExpr(TAst.Identifier('baseValue'), TScalar.TBinaryOp.Add, TAst.Identifier('offset'))
]
)
)
),
TAst.FunctionCall(TAst.Identifier('createStrategyInstance'), [TAst.Constant(20)]),
TAst.FunctionCall(TAst.Identifier('createStrategyInstance'), [TAst.Constant(55)])
]
);
result := ExecuteAst(root, FGScope);
sw.Stop;
Memo1.Lines.Add(Format('Result of the final expression: %s (calculated in %d ms)', [result.ToString, sw.ElapsedMilliseconds]));
UpdateScript;
end;
procedure TForm1.WorkspaceMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
if Button <> TMouseButton.mbMiddle then
exit;
ShowVizualization(X, Y);
end;
procedure TForm1.OHLCButtonClick(Sender: TObject);
const
numRecs = 1000;
lookback = 50;
smaSlowLength = 20;
smaFastLength = 10;
var
scope: IExecutionScope;
values: TArray<TScalar.TValue>;
recordValue: TScalarRecord;
setupAst, boundCallAst, callAst, typedAst: IAstNode;
setupDescriptor, callDescriptor: IScopeDescriptor;
seriesAddress: TResolvedSymbol; // Use TResolvedSymbol
begin
Memo1.Lines.Clear;
Memo1.Lines.Add(Format('--- Simulating O(1) SMA Crossover Strategy for %d ticks ---', [numRecs]));
var sw := TStopwatch.StartNew;
setupAst :=
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('smaFast'), TAst.FunctionCall(TAst.Identifier('CreateSMA'), [TAst.Constant(smaFastLength)])),
TAst.VarDecl(TAst.Identifier('smaSlow'), TAst.FunctionCall(TAst.Identifier('CreateSMA'), [TAst.Constant(smaSlowLength)])),
TAst.VarDecl(
TAst.Identifier('maCrossStrategy'),
TAst.LambdaExpr(
[TAst.Identifier('ohlcv')],
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('closeSeries'),
TAst.MemberAccess(TAst.Identifier('ohlcv'), TAst.Keyword('Close'))
),
TAst.VarDecl(
TAst.Identifier('currentClose'),
TAst.Indexer(TAst.Identifier('closeSeries'), TAst.Constant(0))
),
TAst.VarDecl(
TAst.Identifier('valSmaFast'),
TAst.FunctionCall(
TAst.Identifier('smaFast'),
[TAst.Identifier('closeSeries'), TAst.Identifier('currentClose')]
)
),
TAst.VarDecl(
TAst.Identifier('valSmaSlow'),
TAst.FunctionCall(
TAst.Identifier('smaSlow'),
[TAst.Identifier('closeSeries'), TAst.Identifier('currentClose')]
)
),
TAst.TernaryExpr(
TAst.BinaryExpr(
TAst.Identifier('valSmaFast'),
TScalar.TBinaryOp.Greater,
TAst.Identifier('valSmaSlow')
),
TAst.Constant(1),
TAst.Constant(-1)
)
]
)
)
)
]
);
// 1. Compile and execute the setup script.
typedAst := CompileAst(setupAst, FGScope, setupDescriptor);
scope := setupDescriptor.CreateScope(FGScope);
var setupVisitor := CreateEvaluator(scope);
setupVisitor.Execute(typedAst);
// 2. Prepare for the simulation loop
scope.Define('current_series', TDataValue.Void);
var currentSeriesIdent := TAst.Identifier('current_series');
callAst := TAst.FunctionCall(TAst.Identifier('maCrossStrategy'), [currentSeriesIdent]);
// 3. Re-compile the call AST within the now-populated scope to resolve the new variable.
boundCallAst := CompileAst(callAst, scope, callDescriptor);
// 4. Get the address of 'current_series' from the new descriptor.
seriesAddress := callDescriptor.FindSymbol('current_series');
// Check seriesAddress.Address.Kind instead of seriesAddress.Kind
if seriesAddress.Address.Kind = akUnresolved then
raise Exception.Create('Could not resolve current_series address.');
// 5. Create the final scope and visitor for the simulation loop.
var loopScope := callDescriptor.CreateScope(scope);
var visitor := CreateEvaluator(loopScope);
// 6. Simulation Loop
Memo1.Lines.Clear;
Memo1.Lines.Add('Starting simulation...');
Application.ProcessMessages;
var lastClose := 1000.0;
Randomize;
var recDef := TRttiAstHelper.JsonToRecordDefinition(TRttiAstHelper.RecordDefinitionToJson<TOHLCV>);
var series := TDataValue.FromRecordSeries(TScalarRecordSeries.Create(recDef));
var nw := Now;
var ohlcvRec: TOHLCV;
for var i := 1 to numRecs do
begin
ohlcvRec.Timestamp := nw + (i / (24 * 60));
ohlcvRec.Open := lastClose + (Random * 0.05);
ohlcvRec.Close := lastClose + (Random - 0.49) * 2;
ohlcvRec.High := Max(ohlcvRec.Open, ohlcvRec.Close) + Random;
ohlcvRec.Low := Min(ohlcvRec.Open, ohlcvRec.Close) - Random;
ohlcvRec.Volume := RandomRange(1000, 50000);
lastClose := ohlcvRec.Close;
SetLength(values, 6);
values[0].AsDouble := ohlcvRec.Timestamp;
values[1].AsDouble := ohlcvRec.Open;
values[2].AsDouble := ohlcvRec.High;
values[3].AsDouble := ohlcvRec.Low;
values[4].AsDouble := ohlcvRec.Close;
values[5].AsInt64 := ohlcvRec.Volume;
recordValue := TScalarRecord.Create(recDef, values);
series.AsRecordSeries.Add(recordValue, lookback);
if series.AsRecordSeries.TotalCount >= smaSlowLength then
begin
// Use seriesAddress.Address instead of seriesAddress
loopScope[seriesAddress.Address] := series;
var resultValue := visitor.Execute(boundCallAst);
if i mod 50 = 0 then
begin
Memo1.Lines.Add(Format('Tick %d/%d: Close = %.2f, Signal = %s', [i, numRecs, ohlcvRec.Close, resultValue.ToString]));
Application.ProcessMessages;
end;
end;
end;
sw.Stop;
Memo1.Lines.Add('--- Simulation Finished ---');
Memo1.Lines.Add(Format('Total time: %d ms', [sw.ElapsedMilliseconds]));
UpdateScript;
end;
procedure TForm1.TailCallButtenClick(Sender: TObject);
const
RecursionDepth = 1000000;
var
root: IAstNode;
result: TDataValue;
sw: TStopwatch;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add(Format('--- Testing TCO with recursion depth of %d ---', [RecursionDepth]));
Application.ProcessMessages;
sw := TStopwatch.StartNew;
root :=
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('countDown'),
TAst.LambdaExpr(
[TAst.Identifier('n')],
TAst.IfExpr(
TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.Greater, TAst.Constant(0)),
TAst.Recur([TAst.BinaryExpr(TAst.Identifier('n'), TScalar.TBinaryOp.Subtract, TAst.Constant(1))]),
TAst.Constant(0)
)
)
),
TAst.FunctionCall(TAst.Identifier('countDown'), [TAst.Constant(RecursionDepth)])
]
);
result := ExecuteAst(root, FGScope);
sw.Stop;
Memo1.Lines.Add(Format('Result: %s', [result.ToString]));
Memo1.Lines.Add(Format('Execution finished in %d ms without stack overflow.', [sw.ElapsedMilliseconds]));
UpdateScript;
end;
procedure TForm1.CreateTriggerExampleButtonClick(Sender: TObject);
var
blk: IAstNode;
visitor: IEvaluatorVisitor;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Creating Trigger Blueprint ---');
blk :=
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('X'), TAst.Constant(0)),
TAst.VarDecl(
TAst.Identifier('tickHandler'),
TAst.LambdaExpr(
[TAst.Identifier('summand')],
TAst.Assign(
TAst.Identifier('X'),
TAst.BinaryExpr(TAst.Identifier('X'), TScalar.TBinaryOp.Add, TAst.Identifier('summand'))
)
)
)
]
);
// Run the pipeline
FCurrAst := CompileAst(blk, FGScope, FCurrDesc);
FTriggerScope := FCurrDesc.CreateScope(FGScope);
visitor := CreateEvaluator(FTriggerScope);
visitor.Execute(FCurrAst);
Memo1.Lines.Add('Variable "X" and function "tickHandler" defined in persistent scope.');
Memo1.Lines.Add('Click "Do Trigger" to execute.');
UpdateScript;
end;
function TForm1.CreateEvaluator(const Scope: IExecutionScope): IEvaluatorVisitor;
begin
if DebugBox.IsChecked then
Result := TDebugEvaluatorVisitor.Create(Scope, Memo1.Lines, ShowScopeBox.IsChecked)
else
Result := TEvaluatorVisitor.Create(Scope);
end;
procedure TForm1.DoTriggerButtonClick(Sender: TObject);
var
callAst: IFunctionCallNode;
begin
callAst := TAst.FunctionCall(TAst.Identifier('tickHandler'), [TAst.Constant(1)]);
var X := ExecuteAst(callAst, FTriggerScope);
Memo1.Lines.Add(Format('Tick(1)! New value of X: %s', [X.ToString]));
UpdateScript;
end;
procedure TForm1.DoTrigger2ButtonClick(Sender: TObject);
var
callAst: IFunctionCallNode;
begin
callAst := TAst.FunctionCall(TAst.Identifier('tickHandler'), [TAst.Constant(2)]);
var X := ExecuteAst(callAst, FTriggerScope);
Memo1.Lines.Add(Format('Tick(2)! New value of X: %s', [X.ToString]));
UpdateScript;
end;
procedure TForm1.ExternalFuncButtonClick(Sender: TObject);
var
scope: IExecutionScope;
callAst: IAstNode;
resultValue: TDataValue;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Calling external Delphi function from AST ---');
scope := TAst.CreateScope(FGScope);
scope.Define(
'delphiAdd',
function(const ArgNodes: TArray<TDataValue>): TDataValue
var
val1, val2: Int64;
begin
if Length(ArgNodes) <> 2 then
raise Exception.Create('delphiAdd requires exactly 2 arguments.');
val1 := ArgNodes[0].AsScalar.Value.AsInt64;
val2 := ArgNodes[1].AsScalar.Value.AsInt64;
Result := TScalar.FromInt64(val1 + val2);
end
);
callAst := TAst.FunctionCall(TAst.Identifier('delphiAdd'), [TAst.Constant(100), TAst.Constant(123)]);
resultValue := ExecuteAst(callAst, scope);
Memo1.Lines.Add(Format('Result from delphiAdd(100, 123): %s', [resultValue.ToString]));
UpdateScript;
end;
procedure TForm1.FailingUpvalueButtonClick(Sender: TObject);
var
mainBlock: IAstNode;
resultValue: TDataValue;
begin
mainBlock :=
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('a'), TAst.Constant(10)),
TAst.VarDecl(
TAst.Identifier('modifier'),
TAst.LambdaExpr(
[], // Outer modifier shell
TAst.LambdaExpr(
[], // Inner closure that is returned
TAst.Assign(
TAst.Identifier('a'),
TAst.BinaryExpr(TAst.Identifier('a'), TScalar.TBinaryOp.Add, TAst.Constant(5))
)
)
)
),
TAst.VarDecl(TAst.Identifier('reader'), TAst.LambdaExpr([], TAst.Identifier('a'))),
TAst.VarDecl(TAst.Identifier('innermost_closure'), TAst.FunctionCall(TAst.Identifier('modifier'), [])),
TAst.FunctionCall(TAst.Identifier('innermost_closure'), []),
TAst.FunctionCall(TAst.Identifier('reader'), [])
]
);
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Executing Corrected Upvalue Test ---');
resultValue := ExecuteAst(mainBlock, FGScope);
var res := resultValue.AsScalar.Value.AsInt64;
if res = 15 then
Memo1.Lines.Add('SUCCESS: The result is 15.')
else
Memo1.Lines.Add(Format('FAILURE: Expected 15, but got %s.', [resultValue.ToString]));
Assert(TScalar.FromInt64(15) = resultValue.AsScalar, 'The final result should be 15.');
Memo1.Lines.Add('Please check the new dump.');
UpdateScript;
end;
procedure TForm1.FlowOnlyBoxChange(Sender: TObject);
begin
UpdateScript;
end;
procedure TForm1.PrintScript(const Node: IAstNode);
begin
try
FScriptUpdate := true;
try
if Assigned(Node) then
ScriptMemo.Lines.Text := TAstScript.Print(Node)
else
ScriptMemo.Lines.Clear;
finally
FScriptUpdate := false;
end;
except
on E: Exception do
ScriptMemo.Lines.Add(E.Message);
end;
end;
procedure TForm1.RTLListViewChange(Sender: TObject);
var
itemName: string;
jsonString: string;
jsonLib, jsonObj: TJSONObject;
converter: IJsonAstConverter;
AItem: TListViewItem;
begin
if RTLListView.ItemIndex < 0 then
exit;
AItem := RTLListView.Items[RTLListView.ItemIndex];
itemName := AItem.Text;
Memo1.Lines.Clear;
Memo1.Lines.Add(Format('Loading "%s" from library...', [itemName]));
if not TFile.Exists(UserLibName) then
begin
Memo1.Lines.Add(Format('Library file "%s" not found.', [UserLibName]));
exit;
end;
jsonLib := nil;
try
try
jsonString := TFile.ReadAllText(UserLibName);
jsonLib := TJSONObject.ParseJSONValue(jsonString) as TJSONObject;
if not Assigned(jsonLib) then
raise Exception.Create('Invalid JSON library format.');
var jsonValue := jsonLib.GetValue(itemName);
if not Assigned(jsonValue) or not (jsonValue is TJSONObject) then
raise Exception.Create(Format('Definition for "%s" not found in library.', [itemName]));
jsonObj := jsonValue as TJSONObject;
converter := TJsonAstConverter.Create;
FCurrUnboundAst := converter.Deserialize(jsonObj); // <-- Store unbound AST
// Update the UI
UpdateScript; // This will print to ScriptMemo and show visualization
Memo1.Lines.Add(Format('"%s" loaded into script editor and workspace.', [itemName]));
except
on E: Exception do
begin
Memo1.Lines.Add('Error: ' + E.Message);
end;
end;
finally
if Assigned(jsonLib) then
jsonLib.Free;
end;
end;
procedure TForm1.ScriptMemoChange(Sender: TObject);
begin
if FScriptUpdate then
exit;
Memo1.Lines.Clear;
try
try
// Execute the entire script block when it changes
var result := ExecuteAst(TAstScript.Parse(ScriptMemo.Lines.Text), FGScope);
Memo1.Lines.Add(Format('Script executed. Final result: %s', [result.ToString]));
finally
ShowVizualization(14, 14);
end;
except
on E: Exception do
Memo1.Lines.Add(E.Message);
end;
end;
procedure TForm1.UpdateScript;
begin
PrintScript(FCurrUnboundAst);
FWorkspace.DeleteChildren;
ShowVizualization(14, 14);
end;
procedure TForm1.ShowVizualization(X, Y: Single);
begin
FWorkspace.DeleteChildren;
FWorkspace.Build(FCurrUnboundAst, TPointF.Create(X, Y));
//
// if FCurrAst <> nil then
// begin
// FWorkspace.Build(FCurrAst, TPointF.Create(X, Y));
// end
// else if FCurrUnboundAst <> nil then
// begin
// FWorkspace.Build(FCurrUnboundAst, TPointF.Create(X, Y));
// end;
end;
end.