Files
MycLib/ASTPlayground/MainForm.pas
T
2025-12-14 17:47:07 +01:00

1270 lines
43 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,
FMX.Layouts,
FMX.Objects,
FMX.DialogService,
FMX.ListView.Types,
FMX.ListView.Appearances,
FMX.ListView.Adapters.Base,
FMX.ListView,
FMX.ListBox,
// Myc Units
Myc.Data.Scalar,
Myc.Data.Value,
Myc.Ast.Nodes,
Myc.Ast.Scope,
Myc.Ast,
Myc.Ast.Visitor,
Myc.Data.Decimal,
Myc.Ast.Script,
Myc.Ast.Types,
Myc.Ast.Environment,
Myc.Ast.RTL,
Myc.Ast.Compiler.Macros,
// Editor Units
Myc.Fmx.AstEditor;
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;
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;
CompilerStageBox: TComboBox;
procedure InnerLambdaButtonClick(Sender: TObject);
procedure ClearButtonClick(Sender: TObject);
procedure CompilerStageBoxChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure CreateTriggerExampleButtonClick(Sender: TObject);
procedure DebugBoxChange(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 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;
FCurrCompiled: ILambdaExpressionNode;
FCurrExec: TCompiledFunction;
FEnvironment: TAstEnvironment;
FAstEditor: TAstEditor; // Die Komponente (Facade)
FScriptUpdate: Boolean;
FTriggerTest: TAstEnvironment;
procedure AstEditorMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
// Helper function to encapsulate the Compile -> Evaluate pattern
function ExecuteAst(const ANode: IAstNode): TDataValue;
procedure UpdateScript;
procedure ShowVizualization;
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,
Myc.Trade.Broker,
System.Diagnostics, // For TStopwatch
System.TimeSpan,
Myc.Ast.Json, // For TAstJson serialization
System.IOUtils, // For TFile
Myc.Ast.Dumper; // Needed for DumpButtonClick
{$R *.fmx}
procedure TForm1.FormCreate(Sender: TObject);
begin
// 1. Initialize Environment
FEnvironment := TAstEnvironment.Construct(TAst.CreateScope(nil));
// 2. Initialize AST Editor Component
// This replaces the manual Workspace + Controller setup.
// The Editor encapsulates logic for Navigation, Zoom, Drag&Drop, Undo/Redo.
FAstEditor := TAstEditor.Create(Self);
FAstEditor.Parent := Panel2;
FAstEditor.Align := TAlignLayout.Client;
// Wire up events exposed by the component
FAstEditor.OnMouseDown := AstEditorMouseDown;
// Initialize the logic backend of the editor
FAstEditor.Init(FEnvironment);
// 3. Register the SMA factory into the environment
var RegFunc :=
procedure(const Scope: IExecutionScope)
var
smaAst: IAstNode;
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.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('sum'), TAst.Identifier('val')])
),
TAst.Assign(
TAst.Identifier('count'),
TAst.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('count'), TAst.Constant(1)])
),
TAst.Assign(
TAst.Identifier('sum'),
TAst.TernaryExpr(
TAst.FunctionCall(TAst.Identifier('>'), [TAst.Identifier('count'), TAst.Identifier('len')]),
TAst.FunctionCall(
TAst.Identifier('-'),
[
TAst.Identifier('sum'),
TAst.Indexer(TAst.Identifier('series'), TAst.Identifier('len'))
]
),
TAst.Identifier('sum')
)
),
TAst.FunctionCall(
TAst.Identifier('/'),
[
TAst.Identifier('sum'),
TAst.TernaryExpr(
TAst.FunctionCall(
TAst.Identifier('<'),
[TAst.Identifier('count'), TAst.Identifier('len')]
),
TAst.Identifier('count'),
TAst.Identifier('len')
)
]
)
]
)
)
]
)
);
var smaFactory := FEnvironment.Run(smaAst);
Scope.Define('CreateSMA', smaFactory);
Scope.Define(
'print',
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
);
Scope.Define(
'timestamp',
function(const Args: TArray<TDataValue>): TDataValue
begin
Result := TStopwatch.GetTimeStamp div TTimeSpan.TicksPerMillisecond;
end
);
end;
RegFunc(FEnvironment.RootScope);
FEnvironment.MacroRegistry.Define(
TAstScript
.Parse(
'''
(defmacro stopwatch [body]
`(do
(def start-time (timestamp))
(def result ~body)
(print "(calculated in " (- (timestamp) start-time) " ms)" )
result
))
''')
.AsMacroDefinition
);
CompilerStageBox.BringToFront;
ClearButtonClick(Self);
end;
procedure TForm1.ShowVizualization;
begin
if FCurrUnboundAst = nil then
exit;
// Use the Editor Component to build, validate and show the UI
FAstEditor.SetRoot(FCurrUnboundAst);
end;
// Simplified ExecuteAst using TEnvironment and handling errors gracefully
function TForm1.ExecuteAst(const ANode: IAstNode): TDataValue;
begin
FCurrUnboundAst := ANode;
FCurrExec := Default(TCompiledFunction);
if DebugBox.IsChecked then
FEnvironment.SetDebugMode(Memo1.Lines, ShowScopeBox.IsChecked)
else
FEnvironment.SetStandardMode;
try
// Use Compile directly. Errors will be raised as ECompilationFailed.
// We catch them to print to log, but allow flow to continue so UI can be updated.
FCurrCompiled := FEnvironment.Compile(ANode);
FCurrExec := FEnvironment.Link(FCurrCompiled);
if Assigned(FCurrExec.Func) then
begin
Memo1.Lines.Add(
Format('Compiled. Signature: %s, IsPure=%s', [FCurrExec.StaticType.ToString, BoolToStr(FCurrExec.IsPure, true)])
);
end;
Result := FCurrExec.Func([]);
except
on E: ECompilationFailed do
begin
Memo1.Lines.BeginUpdate;
try
Memo1.Lines.Clear;
Memo1.Lines.Add(E.Message);
Memo1.Lines.Add('');
for var err in E.Errors do
Memo1.Lines.Add(err.ToString);
finally
Memo1.Lines.EndUpdate;
end;
// Return void so caller doesn't crash, but UI will show red nodes via ShowVizualization
Result := TDataValue.Void;
end;
on E: Exception do
begin
FCurrExec.Func := nil;
Memo1.Lines.Add('--- RUNTIME ERROR ---');
Memo1.Lines.Add(E.ClassName + ': ' + E.Message);
Result := TDataValue.Void;
end;
end;
end;
procedure TForm1.InnerLambdaButtonClick(Sender: TObject);
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Nested Lambda & Upvalue Mutation Test ---');
var 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.FunctionCall(
TAst.Identifier('+'),
[TAst.Identifier('x'), 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'), []))
]
);
var resultValue := ExecuteAst(mainBlock);
if (resultValue.Kind = vkScalar) and (resultValue.AsScalar.Kind = TScalar.TKind.Ordinal) then
begin
var resInt := resultValue.AsScalar.Value.AsInt64;
Memo1.Lines.Add(Format('Actual Result: %d', [resInt]));
if resInt = 15 then
Memo1.Lines.Add('SUCCESS: Deeply nested closure modified captured variable correctly.')
else
Memo1.Lines.Add(Format('FAILURE: Upvalue logic broken. Expected 15, got %d.', [resInt]));
end
else
Memo1.Lines.Add('FAILURE: Result is not an integer scalar.');
UpdateScript;
end;
procedure TForm1.ClearButtonClick(Sender: TObject);
begin
// Clear content of component
FAstEditor.SetRoot(nil);
end;
procedure TForm1.CompilerStageBoxChange(Sender: TObject);
begin
ShowVizualization;
end;
procedure TForm1.CreateTriggerExampleButtonClick(Sender: TObject);
var
blk: IAstNode;
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.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('X'), TAst.Identifier('summand')])
)
)
)
]
);
FTriggerTest := FEnvironment.CreateEnvironment;
FTriggerTest.Define('X', TAst.Constant(0));
FTriggerTest.Define(
'tickHandler',
TAst.LambdaExpr(
[TAst.Identifier('summand')],
TAst.Assign(TAst.Identifier('X'), TAst.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('X'), TAst.Identifier('summand')]))
)
);
Memo1.Lines.Add('Variable "X" and function "tickHandler" defined in persistent scope.');
Memo1.Lines.Add('Click "Do Trigger" to execute.');
UpdateScript;
end;
procedure TForm1.DebugBoxChange(Sender: TObject);
begin
if DebugBox.IsChecked then
FEnvironment.SetDebugMode(Memo1.Lines, ShowScopeBox.IsChecked)
else
FEnvironment.SetStandardMode;
end;
procedure TForm1.DoTriggerButtonClick(Sender: TObject);
var
callAst: IAstNode;
begin
callAst := TAst.FunctionCall(TAst.Identifier('tickHandler'), [TAst.Constant(1)]);
var X := FTriggerTest.Run(callAst);
Memo1.Lines.Add(Format('Tick(1)! New value of X: %s', [X.ToString]));
UpdateScript;
end;
procedure TForm1.DoTrigger2ButtonClick(Sender: TObject);
var
callAst: IAstNode;
begin
callAst := TAst.FunctionCall(TAst.Identifier('tickHandler'), [TAst.Constant(2)]);
var X := FTriggerTest.Run(callAst);
Memo1.Lines.Add(Format('Tick(2)! New value of X: %s', [X.ToString]));
UpdateScript;
end;
procedure TForm1.ExternalFuncButtonClick(Sender: TObject);
var
callAst: IAstNode;
resultValue: TDataValue;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Calling external Delphi function from AST ---');
FEnvironment.RootScope.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);
Memo1.Lines.Add(Format('Result from delphiAdd(100, 123): %s', [resultValue.ToString]));
UpdateScript;
end;
procedure TForm1.FailingUpvalueButtonClick(Sender: TObject);
var
resultValue: TDataValue;
begin
FCurrUnboundAst :=
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.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('a'), 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'), [])
]
);
UpdateScript;
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Executing Corrected Upvalue Test ---');
resultValue := ExecuteAst(FCurrUnboundAst);
if resultValue.Kind <> vkVoid then
begin
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.');
end;
Memo1.Lines.Add('Please check the new dump.');
UpdateScript;
end;
procedure TForm1.FibonacciButtonClick(Sender: TObject);
var
result: TDataValue;
sw: TStopwatch;
begin
Memo1.Lines.Clear;
FCurrUnboundAst :=
TAstScript.Parse(
'''
(do
(def fib)
(assign fib (fn [n]
(? (< n 2)
n
(+ (fib (- n 1)) (fib (- n 2)))
)
))
)
'''
);
var TestEnv := FEnvironment.CreateEnvironment;
TestEnv.Define('fib', FCurrUnboundAst);
Memo1.Lines.Add('--- Naive recursive fib with AST---');
FCurrCompiled := TestEnv.Compile(TAst.FunctionCall(TAst.Identifier('fib'), [TAst.Constant(25)]));
var fibExec := TestEnv.Link(FCurrCompiled).Func;
sw := TStopwatch.StartNew;
result := fibExec([]);
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)---');
var memoizeTest := TestEnv.CreateEnvironment;
memoizeTest.Define('fib', TAstScript.Parse('(Memoize fib)'));
var memoizeExec := memoizeTest.Link(memoizeTest.Compile(TAstScript.Parse('(fib 25)'))).Func;
sw := TStopwatch.StartNew;
result := memoizeExec([]);
sw.Stop;
Memo1.Lines.Add(Format('Result 1st call: fib(25) %s (calculated in %d ms)', [result.ToString, sw.ElapsedMilliseconds]));
sw := TStopwatch.StartNew;
result := memoizeExec([]);
sw.Stop;
Memo1.Lines.Add(Format('Result 2nd call: fib(25) %s (calculated in %d ms)', [result.ToString, sw.ElapsedMilliseconds]));
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
FCurrUnboundAst := TAstScript.Parse(ScriptMemo.Lines.Text);
try
// We invoke ExecuteAst here to trigger the validation/compilation logic
// and show the result in the log.
var result := ExecuteAst(FCurrUnboundAst);
Memo1.Lines.Add(Format('Script executed. Final result: %s', [result.ToString]));
finally
// Trigger visualization update via Component
ShowVizualization;
end;
except
on E: Exception do
Memo1.Lines.Add(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 Exception.Create('Invalid JSON format.');
try
FCurrUnboundAst := converter.Deserialize(jsonObj);
// Run the full pipeline via environment
FCurrCompiled := FEnvironment.Compile(FCurrUnboundAst);
FCurrExec := FEnvironment.Link(FCurrCompiled);
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
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.OHLCButtonClick(Sender: TObject);
const
numRecs = 1000;
lookback = 50;
smaSlowLength = 20;
smaFastLength = 10;
var
values: TArray<TScalar.TValue>;
recordValue: TScalarRecord;
setupAst: IAstNode;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add(Format('--- Simulating O(1) SMA Crossover Strategy for %d ticks ---', [numRecs]));
var sw := TStopwatch.StartNew;
setupAst :=
TAstScript.Parse(
'''
(do
(def smaFast (CreateSMA 10))
(def smaSlow (CreateSMA 20))
(fn [ohlcv]
(do
(def closeSeries (:Close ohlcv))
(def currentClose (get closeSeries 0))
(def valSmaFast (smaFast closeSeries currentClose))
(def valSmaSlow (smaSlow closeSeries currentClose))
(? (> valSmaFast valSmaSlow) 1 -1)
)
)
)
'''
);
FCurrUnboundAst := setupAst;
UpdateScript;
Application.ProcessMessages;
var env := FEnvironment.CreateEnvironment;
env.Define('maCrossStrategy', setupAst);
var seriesAddress := env.RootScope.Define('current_series', TDataValue.Void);
var callExec := env.Link(env.Compile(TAst.FunctionCall(TAst.Identifier('maCrossStrategy'), [TAst.Identifier('current_series')]))).Func;
// 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
env.RootScope[seriesAddress] := series;
var resultValue := callExec([]);
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.UpdateScript;
begin
PrintScript(FCurrUnboundAst);
// Clear and redraw via Component
FAstEditor.SetRoot(FCurrUnboundAst);
end;
procedure TForm1.AstEditorMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
// Nur zur Demo: Wir knnten hier klicken, um etwas im Memo zu loggen
if Button = TMouseButton.mbMiddle then
ShowVizualization;
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
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
if rootNode.Kind = akBlockExpression then
begin
for var expr in rootNode.AsBlockExpression.Expressions do
begin
if (expr.Kind = akVariableDeclaration) then
begin
var decl := expr.AsVariableDeclaration;
definitions.Add(decl.Target.AsIdentifier.Name, decl.Initializer);
end
else if expr.Kind = akMacroDefinition then
begin
var macroDef := expr.AsMacroDefinition;
definitions.Add(macroDef.Name.Name, macroDef);
end;
end;
end
else if rootNode.Kind = akVariableDeclaration then
begin
var decl := rootNode.AsVariableDeclaration;
definitions.Add(decl.Target.AsIdentifier.Name, decl.Initializer);
end
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;
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
converter := TJsonAstConverter.Create;
updatedCount := 0;
for var pair in definitions do
begin
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));
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]));
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.LoadUserLibButtonClick(Sender: TObject);
var
jsonString: string;
jsonObj: TJSONObject;
pair: TJSONPair;
funcAst: IAstNode;
funcValue: TDataValue;
converter: IJsonAstConverter;
addr: TResolvedAddress;
begin
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)]));
RTLListView.Items.BeginUpdate;
try
for pair in jsonObj do
begin
if not (pair.JsonValue is TJSONObject) then
continue;
funcAst := converter.Deserialize(pair.JsonValue as TJSONObject);
addr := FEnvironment.RootScope.Resolve(pair.JsonString.Value);
if addr.Kind = akUnresolved then
begin
if funcAst.Kind = akMacroDefinition then
begin
FEnvironment.MacroRegistry.Define(funcAst.AsMacroDefinition);
Memo1.Lines.Add(Format('Defined macro "%s"', [pair.JsonString.Value]));
end
else
begin
funcValue := ExecuteAst(funcAst);
FEnvironment.RootScope.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]));
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.RecursionButtonClick(Sender: TObject);
begin
TailCallButtenClick(Sender);
end;
procedure TForm1.SeriesTestButtonClick(Sender: TObject);
var
ast: IAstNode;
resultValue: TDataValue;
series: IWriteableScalarRecordSeries;
recordDef: IScalarRecordDefinition;
i: Integer;
values: TArray<TScalar.TValue>;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- Series Test ---');
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;
var testEnv := FEnvironment.CreateEnvironment;
testEnv.RootScope.Define('ohlcvSeries', TDataValue.FromRecordSeries(series));
ast :=
TAst.LambdaExpr(
[],
TAst.Block(
[
TAst.VarDecl(
TAst.Identifier('closeColumn'),
TAst.FunctionCall(TAst.Keyword('Close'), [TAst.Identifier('ohlcvSeries')])
),
TAst.Indexer(TAst.Identifier('closeColumn'), TAst.Constant(1))
]
)
);
var callAst := TAst.FunctionCall(ast, []);
resultValue := testEnv.Run(callAst);
Memo1.Lines.Add(Format('Result of script: %s', [resultValue.ToString]));
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.FunctionCall(TAst.Identifier('>'), [TAst.Identifier('n'), TAst.Constant(0)]),
TAst.Recur([TAst.FunctionCall(TAst.Identifier('-'), [TAst.Identifier('n'), TAst.Constant(1)])]),
TAst.Constant(0)
)
)
),
TAst.FunctionCall(TAst.Identifier('countDown'), [TAst.Constant(RecursionDepth)])
]
);
result := ExecuteAst(root);
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.Test1ButtonClick(Sender: TObject);
begin
FCurrUnboundAst := TAstScript.Parse('(do (print txt))');
FCurrCompiled := FEnvironment.Compile(FCurrUnboundAst, [TAst.Identifier('txt')]);
var fn := FEnvironment.Link(FCurrCompiled).Func;
fn(['Hello World']);
FEnvironment.RootScope.Define('fn', fn);
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.FunctionCall(TAst.Identifier('fn'), [TAst.Constant('xyz')]),
TAst.VarDecl(
TAst.Identifier('createStrategyInstance'),
TAst.LambdaExpr(
[TAst.Identifier('offset')],
TAst.Block(
[
TAst.VarDecl(TAst.Identifier('baseValue'), TAst.Constant(100)),
TAst.FunctionCall(TAst.Identifier('+'), [TAst.Identifier('baseValue'), TAst.Identifier('offset')])
]
)
)
),
TAst.FunctionCall(TAst.Identifier('createStrategyInstance'), [TAst.Constant(20)]),
TAst.FunctionCall(TAst.Identifier('createStrategyInstance'), [TAst.Constant(55)])
]
);
result := ExecuteAst(root);
sw.Stop;
Memo1.Lines.Add(Format('Result of the final expression: %s (calculated in %d ms)', [result.ToString, sw.ElapsedMilliseconds]));
UpdateScript;
end;
procedure TForm1.ToJSONButtonClick(Sender: TObject);
var
jsonObj: TJSONObject;
converter: IJsonAstConverter;
begin
Memo1.Lines.Clear;
if not Assigned(FCurrExec.Func) then
begin
Memo1.Lines.Add('No *compiled* AST has been generated yet. Click a test button first.');
exit;
end;
try
converter := TJsonAstConverter.Create;
jsonObj := converter.Serialize(FCurrUnboundAst);
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);
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('--- AST Dump ---');
if FCurrCompiled = nil then
begin
Memo1.Lines.Add('No compiled AST available.');
exit;
end;
// Dump the raw unbound AST first
TAstDumper.Dump(FCurrCompiled, Memo1.Lines);
end;
initialization
TAst.RegisterLibrary(RegisterBroker);
end.