Brummel/MycLib
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects 1 Releases Wiki Activity

Chart Control V1

Browse Source
This commit is contained in:
Michael Schimmel
2025-07-02 14:49:33 +02:00
parent b453236b1e
commit 58ce84e567
11 changed files with 1746 additions and 256 deletions
Download Patch File Download Diff File Expand all files Collapse all files
AuraTrader/AuraTrader.dpr
+4 -1
View File
@@ -8,12 +8,15 @@ uses
Myc.Trade.Core.DataPoint in '..\Src\Myc.Trade.Core.DataPoint.pas',
Myc.Trade.Ticker in '..\Src\Myc.Trade.Ticker.pas',
Myc.Aura.Module in '..\Src\Myc.Aura.Module.pas',
Myc.Aura.Parameter in '..\Src\Myc.Aura.Parameter.pas';
Myc.Aura.Parameter in '..\Src\Myc.Aura.Parameter.pas',
TestModule in 'TestModule.pas',
TestChartControl in 'TestChartControl.pas' {TestChartForm};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TTestChartForm, TestChartForm);
Application.Run;
end.
AuraTrader/AuraTrader.dproj
+12 -1
View File
@@ -4,7 +4,7 @@
<ProjectVersion>20.3</ProjectVersion>
<FrameworkType>FMX</FrameworkType>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Release</Config>
<Config Condition="'$(Config)'==''">Debug</Config>
<Platform Condition="'$(Platform)'==''">Win64</Platform>
<ProjectName Condition="'$(ProjectName)'==''">AuraTrader</ProjectName>
<TargetedPlatforms>3</TargetedPlatforms>
@@ -137,6 +137,11 @@
<DCCReference Include="..\Src\Myc.Trade.Ticker.pas"/>
<DCCReference Include="..\Src\Myc.Aura.Module.pas"/>
<DCCReference Include="..\Src\Myc.Aura.Parameter.pas"/>
<DCCReference Include="TestModule.pas"/>
<DCCReference Include="TestChartControl.pas">
<Form>TestChartForm</Form>
<FormType>fmx</FormType>
</DCCReference>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
@@ -180,6 +185,12 @@
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="Win64\Debug\AuraTrader.rsm" Configuration="Debug" Class="DebugSymbols">
<Platform Name="Win64">
<RemoteName>AuraTrader.rsm</RemoteName>
<Overwrite>true</Overwrite>
</Platform>
</DeployFile>
<DeployFile LocalName="Win64\Release\AuraTrader.exe" Configuration="Release" Class="ProjectOutput">
<Platform Name="Win64">
<RemoteName>AuraTrader.exe</RemoteName>
AuraTrader/MainForm.fmx
+175 -84
View File
@@ -10,109 +10,200 @@ object Form1: TForm1
OnCreate = FormCreate
OnDestroy = FormDestroy
DesignerMasterStyle = 0
object Panel1: TPanel
object MainPanel: TPanel
Align = Client
Size.Width = 796.00000000000000000
Size.Height = 616.00000000000000000
Size.Height = 712.00000000000000000
Size.PlatformDefault = False
TabOrder = 2
object Layout: TFlowLayout
Align = Client
Size.Width = 627.00000000000000000
Size.Height = 616.00000000000000000
Size.PlatformDefault = False
TabOrder = 1
Justify = Left
JustifyLastLine = Left
FlowDirection = LeftToRight
HorizontalGap = 2.00000000000000000
VerticalGap = 2.00000000000000000
OnResized = LayoutResized
end
object SymbolsComboBox: TComboBox
Anchors = [akTop, akRight]
Position.X = 608.00000000000000000
Position.Y = 16.00000000000000000
Size.Width = 177.00000000000000000
Size.Height = 22.00000000000000000
Size.PlatformDefault = False
TabOrder = 5
end
object RandomBox: TCheckBox
Anchors = [akTop, akRight]
Position.X = 609.00000000000000000
Position.Y = 46.00000000000000000
TabOrder = 2
Text = 'Random'
end
object LoadButton: TButton
Anchors = [akTop, akRight]
Position.X = 641.00000000000000000
Position.Y = 86.00000000000000000
Size.Width = 47.00000000000000000
Size.Height = 22.00000000000000000
Size.PlatformDefault = False
TabOrder = 6
Text = 'Load'
TextSettings.Trimming = None
OnClick = LoadButtonClick
end
object RandomButton: TButton
Anchors = [akTop, akRight]
Position.X = 705.00000000000000000
Position.Y = 86.00000000000000000
TabOrder = 3
Text = 'Random'
TextSettings.Trimming = None
OnClick = RandomButtonClick
end
object ChartButton: TButton
Anchors = [akTop, akRight]
Position.X = 665.00000000000000000
Position.Y = 130.00000000000000000
TabOrder = 8
Text = 'ChartButton'
TextSettings.Trimming = None
OnClick = ChartButtonClick
end
object StopButton: TButton
Anchors = [akTop, akRight]
Position.X = 665.00000000000000000
Position.Y = 160.00000000000000000
TabOrder = 10
Text = 'StopButton'
TextSettings.Trimming = None
OnClick = StopButtonClick
end
object TreeView1: TTreeView
Align = Left
Size.Width = 161.00000000000000000
Size.Height = 616.00000000000000000
Size.PlatformDefault = False
TabOrder = 0
Viewport.Width = 157.00000000000000000
Viewport.Height = 612.00000000000000000
end
object Splitter1: TSplitter
Align = Left
Cursor = crHSplit
MinSize = 20.00000000000000000
Position.X = 161.00000000000000000
Position.X = 169.00000000000000000
Size.Width = 8.00000000000000000
Size.Height = 616.00000000000000000
Size.Height = 712.00000000000000000
Size.PlatformDefault = False
end
object WorkspacePanel: TPanel
Align = Client
Size.Width = 619.00000000000000000
Size.Height = 712.00000000000000000
Size.PlatformDefault = False
TabOrder = 3
object TabControl: TTabControl
Align = Client
Size.Width = 619.00000000000000000
Size.Height = 672.00000000000000000
Size.PlatformDefault = False
TabIndex = 0
TabOrder = 10
TabPosition = PlatformDefault
end
object ToolBar: TToolBar
Size.Width = 619.00000000000000000
Size.Height = 40.00000000000000000
Size.PlatformDefault = False
TabOrder = 3
object AddWorkspaceButton: TSpeedButton
Action = AddWorkspaceAction
Align = FitLeft
ImageIndex = -1
Size.Width = 145.45458984375000000
Size.Height = 40.00000000000000000
Size.PlatformDefault = False
Text = 'Add'
TextSettings.Trimming = None
end
object TestButton: TSpeedButton
Action = TestAction
Align = FitLeft
ImageIndex = -1
Position.X = 145.45458984375000000
Size.Width = 145.45454406738280000
Size.Height = 40.00000000000000000
Size.PlatformDefault = False
TextSettings.Trimming = None
object TestPopup: TPopup
PlacementTarget = TestButton
Size.Width = 400.00000000000000000
Size.Height = 400.00000000000000000
Size.PlatformDefault = False
TabOrder = 7
object FlowLayout1: TFlowLayout
Position.X = 224.00000000000000000
Position.Y = 167.00000000000000000
TabOrder = 4
Justify = Left
JustifyLastLine = Left
FlowDirection = LeftToRight
object RandomBox: TCheckBox
Anchors = [akTop, akRight]
TabOrder = 1
Text = 'Random'
end
object LoadButton: TButton
Anchors = [akTop, akRight]
Position.Y = 19.00000000000000000
Size.Width = 47.00000000000000000
Size.Height = 22.00000000000000000
Size.PlatformDefault = False
TabOrder = 5
Text = 'Load'
TextSettings.Trimming = None
OnClick = LoadButtonClick
end
object RandomButton: TButton
Anchors = [akTop, akRight]
Position.Y = 41.00000000000000000
TabOrder = 2
Text = 'Random'
TextSettings.Trimming = None
OnClick = RandomButtonClick
end
object StopButton: TButton
Anchors = [akTop, akRight]
Position.Y = 63.00000000000000000
TabOrder = 8
Text = 'StopButton'
TextSettings.Trimming = None
OnClick = StopButtonClick
end
object ChartButton: TButton
Anchors = [akTop, akRight]
Position.Y = 85.00000000000000000
TabOrder = 7
Text = 'ChartButton'
TextSettings.Trimming = None
OnClick = ChartButtonClick
end
object SymbolsComboBox: TComboBox
Anchors = [akTop, akRight]
Position.Y = 107.00000000000000000
Size.Width = 177.00000000000000000
Size.Height = 22.00000000000000000
Size.PlatformDefault = False
TabOrder = 4
end
end
end
end
object SpeedButton1: TSpeedButton
Position.X = 376.00000000000000000
Position.Y = 8.00000000000000000
Text = 'SpeedButton1'
TextSettings.Trimming = None
OnClick = SpeedButton1Click
end
end
end
object ObjectsPanel: TPanel
Align = Left
Size.Width = 169.00000000000000000
Size.Height = 712.00000000000000000
Size.PlatformDefault = False
TabOrder = 4
object ObjectsTabControl: TTabControl
Align = Client
Size.Width = 169.00000000000000000
Size.Height = 712.00000000000000000
Size.PlatformDefault = False
TabIndex = 0
TabOrder = 0
TabPosition = Bottom
Sizes = (
169s
686s)
object ModulesTabItem: TTabItem
CustomIcon = <
item
end>
TextSettings.Trimming = None
IsSelected = True
Size.Width = 66.00000000000000000
Size.Height = 26.00000000000000000
Size.PlatformDefault = False
StyleLookup = ''
TabOrder = 0
Text = 'Modules'
object TreeView: TTreeView
Align = Client
Size.Width = 169.00000000000000000
Size.Height = 686.00000000000000000
Size.PlatformDefault = False
TabOrder = 0
OnDblClick = TreeViewDblClick
AllowDrag = True
Viewport.Width = 165.00000000000000000
Viewport.Height = 682.00000000000000000
end
end
end
end
end
object LogMemo: TMemo
Touch.InteractiveGestures = [Pan, LongTap, DoubleTap]
DataDetectorTypes = []
Align = Bottom
Position.Y = 616.00000000000000000
Position.Y = 712.00000000000000000
Size.Width = 796.00000000000000000
Size.Height = 224.00000000000000000
Size.Height = 128.00000000000000000
Size.PlatformDefault = False
TabOrder = 1
Viewport.Width = 792.00000000000000000
Viewport.Height = 220.00000000000000000
Viewport.Height = 124.00000000000000000
end
object ActionList: TActionList
Left = 209
Top = 32
object AddWorkspaceAction: TAction
Text = 'Add Workspace'
OnExecute = AddWorkspaceActionExecute
end
object TestAction: TAction
Text = 'Test...'
Checked = True
OnExecute = TestActionExecute
end
end
end
AuraTrader/MainForm.pas
+164 -11
View File
@@ -10,6 +10,7 @@ uses
System.Variants,
System.DateUtils,
System.Generics.Collections,
System.Rtti,
FMX.Types,
FMX.Controls,
FMX.Forms,
@@ -33,24 +34,44 @@ uses
Myc.Lazy,
Myc.Signals.FMX,
Myc.TaskManager,
Myc.Aura.Module,
FMX.ListBox,
FMX.Layouts,
FMX.MultiView,
FMX.TreeView;
FMX.TreeView,
FMX.TabControl,
FMX.Menus,
System.ImageList,
FMX.ImgList,
System.Actions,
FMX.ActnList,
TestChartControl;
type
TForm1 = class(TForm)
LogMemo: TMemo;
Panel1: TPanel;
Layout: TFlowLayout;
MainPanel: TPanel;
SymbolsComboBox: TComboBox;
RandomBox: TCheckBox;
LoadButton: TButton;
RandomButton: TButton;
ChartButton: TButton;
StopButton: TButton;
TreeView1: TTreeView;
Splitter1: TSplitter;
ActionList: TActionList;
AddWorkspaceAction: TAction;
WorkspacePanel: TPanel;
TabControl: TTabControl;
ToolBar: TToolBar;
AddWorkspaceButton: TSpeedButton;
ObjectsPanel: TPanel;
ObjectsTabControl: TTabControl;
ModulesTabItem: TTabItem;
TreeView: TTreeView;
TestButton: TSpeedButton;
TestAction: TAction;
SpeedButton1: TSpeedButton;
TestPopup: TPopup;
FlowLayout1: TFlowLayout;
procedure RandomButtonClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
@@ -58,6 +79,10 @@ type
procedure ChartButtonClick(Sender: TObject);
procedure StopButtonClick(Sender: TObject);
procedure LayoutResized(Sender: TObject);
procedure TreeViewDblClick(Sender: TObject);
procedure AddWorkspaceActionExecute(Sender: TObject);
procedure TestActionExecute(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
const
cnt = 20;
@@ -75,10 +100,13 @@ type
FRandom: TList<TRndItem>;
FTerminate: TEvent;
FLoadDone: TState;
FApplication: IAuraApplication;
FModulesItem: TTreeViewItem;
function SelectedSymbol: String;
function SelectedStream: IDataStream<TAskBidItem>;
public
{ Public declarations }
procedure NewWorkspace;
function CurrLayout: TFlowLayout;
published
property OnEvent: TNotifyEvent read FOnEvent write FOnEvent;
end;
@@ -88,15 +116,99 @@ var
implementation
uses
TestModule;
{$R *.fmx}
procedure TForm1.NewWorkspace;
begin
var ws: IAuraWorkspace := TMycAuraWorkspace.Create('New workspace', tmTesting);
FApplication.Workspaces.Insert(-1, ws);
var tab := TabControl.Add;
tab.Text := ws.Caption;
tab.Tag := NativeInt(ws);
var tabBtn := TSpeedButton.Create(Self);
tabBtn.Parent := tab;
tabBtn.Align := TAlignLayout.Right;
var scrollbox := TVertScrollBox.Create(Self);
scrollbox.Parent := tab;
scrollbox.Align := TAlignLayout.Client;
var flow := TFlowLayout.Create(Self);
flow.Parent := tab;
flow.Align := TAlignLayout.Client;
tab.ProcessSignal(ws.Name.Changed, procedure begin tab.Text := ws.Caption; end);
end;
procedure TForm1.StopButtonClick(Sender: TObject);
begin
FTerminate.Notify;
end;
procedure TForm1.TreeViewDblClick(Sender: TObject);
begin
var addnew := false;
var sel := TreeView.Selected as TTreeViewItem;
var parent := sel.ParentItem;
if parent = nil then
exit;
if parent = FModulesItem then
begin
if (TabControl.ActiveTab <> nil) and (TabControl.ActiveTab.Tag <> 0) then
begin
var ws := IAuraWorkspace(TabControl.ActiveTab.Tag);
var module := FApplication.Modules[sel.TagString];
if (ws <> nil) and (module <> nil) then
module.SetupWorkspace(ws);
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FApplication := TMycAuraApplication.Create;
FModulesItem := TTreeViewItem.Create(Self);
FModulesItem.Text := 'Modules';
const modName = 'Test_Module';
FApplication.RegisterModule(modName, TTestModule.Create('Test-Module', 1));
TreeView.AddObject(FModulesItem);
FModulesItem.ProcessSignal(
FApplication.ModuleNames.Changed,
procedure
begin
FModulesItem.BeginUpdate;
try
while FModulesItem.Count > 0 do
FModulesItem[0].Free;
var mods := FApplication.ModuleNames.Value;
for var i := 0 to High(mods) do
begin
var ModItem := TTreeViewItem.Create(Self);
ModItem.Text := mods[i];
ModItem.DragMode := TDragMode.dmAutomatic;
ModItem.Text := 'Module-' + mods[i];
ModItem.TagString := mods[i];
FModulesItem.AddObject(ModItem);
end;
FModulesItem.ExpandAll;
finally
FModulesItem.EndUpdate;
end;
end
);
FTerminate := TEvent.CreateEvent;
FRandom := TList<TRndItem>.Create;
@@ -130,6 +242,8 @@ begin
end;
end
);
NewWorkspace;
end;
procedure TForm1.FormDestroy(Sender: TObject);
@@ -149,6 +263,9 @@ procedure TForm1.LoadButtonClick(Sender: TObject);
begin
if SymbolsComboBox.ItemIndex < 0 then
exit;
var Layout := CurrLayout;
if Layout = nil then
exit;
var Stream := FServer.CreateStream(FSymbols.WaitFor[SymbolsComboBox.ItemIndex]);
var Data := TDataStreamProvider.Create<TAskBidItem>(30000, 10000, Stream);
@@ -181,6 +298,10 @@ end;
procedure TForm1.RandomButtonClick(Sender: TObject);
begin
var Layout := CurrLayout;
if Layout = nil then
exit;
var rnd: TRndItem;
rnd.Stream := FServer.CreateStream(FSymbols.WaitFor[Random(Length(FSymbols.WaitFor))]);
@@ -221,8 +342,22 @@ begin
Proc(FRandom.Count - 1);
end;
procedure TForm1.TestActionExecute(Sender: TObject);
begin
TestPopup.IsOpen := TestAction.Checked;
end;
procedure TForm1.AddWorkspaceActionExecute(Sender: TObject);
begin
NewWorkspace;
end;
procedure TForm1.ChartButtonClick(Sender: TObject);
begin
var Layout := CurrLayout;
if Layout = nil then
exit;
var Symbol := SelectedSymbol;
if Symbol = '' then
exit;
@@ -283,12 +418,25 @@ begin
);
end;
function TForm1.SelectedStream: IDataStream<TAskBidItem>;
function TForm1.CurrLayout: TFlowLayout;
begin
var sym := SelectedSymbol;
if sym = '' then
if TabControl.ActiveTab = nil then
exit(nil);
Result := FServer.CreateStream(sym);
var Res: TFlowLayout := nil;
TabControl.ActiveTab.EnumControls(
function(Control: TControl): TEnumControlsResult
begin
Result := TEnumControlsResult.Continue;
if Control is TFlowLayout then
begin
Res := Control as TFlowLayout;
Result := TEnumControlsResult.Stop;
end;
end
);
Result := Res;
end;
function TForm1.SelectedSymbol: String;
@@ -300,4 +448,9 @@ begin
Result := FSymbols.WaitFor[SymbolsComboBox.ItemIndex];
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
TestChartForm.Visible := true;
end;
end.
AuraTrader/TestChartControl.fmx
+12
View File
@@ -0,0 +1,12 @@
object TestChartForm: TTestChartForm
Left = 0
Top = 0
Caption = 'Chart Test'
ClientHeight = 480
ClientWidth = 640
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
end
AuraTrader/TestChartControl.pas
+698
View File
@@ -0,0 +1,698 @@
unit TestChartControl;
interface
uses
System.SysUtils,
System.Types,
System.UITypes,
System.Classes,
System.Variants,
System.Generics.Collections,
System.Math,
System.UIConsts, // For AlphaColors
FMX.Types,
FMX.Controls,
FMX.Forms,
FMX.Graphics,
FMX.Dialogs,
FMX.Objects,
Myc.Trade.DataPoint;
type
// Declared for testing, will be moved to external unit
TOhlcItem = record
Open, High, Low, Close: Double;
end;
// Custom high-precision point type using Double.
TPointD = record
public
X: Double;
Y: Double;
constructor Create(AX, AY: Double);
end;
// Custom high-precision rectangle type using Double.
TRectD = record
private
function GetHeight: Double;
function GetWidth: Double;
public
Left, Top, Right, Bottom: Double;
constructor Create(const ALeft, ATop, ARight, ABottom: Double); overload;
constructor Create(const ATopLeft, ABottomRight: TPointD); overload;
property Width: Double read GetWidth;
property Height: Double read GetHeight;
end;
TChart = class; // Forward declaration
// Abstract base class for a single series in a chart.
TChartSeries = class abstract(TCollectionItem)
private
FColor: TAlphaColor;
FThickness: Single;
procedure SetColor(const Value: TAlphaColor);
procedure SetThickness(const Value: Single);
protected
function GetChart: TChart;
public
constructor Create(Collection: TCollection); override;
// Calculates the bounding box for this series.
procedure GetBounds(var MinPoint, MaxPoint: TPointD); virtual; abstract;
// Draws the series on the canvas.
procedure Draw(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF); virtual; abstract;
published
property Color: TAlphaColor read FColor write SetColor;
property Thickness: Single read FThickness write SetThickness;
end;
// Generic, abstract adapter to connect a TDataSeries<T> to a TChart.
TChartSeriesAdapter<T> = class abstract(TChartSeries)
private
FDataSeries: TDataSeries<T>;
protected
procedure SetDataSeries(const Value: TDataSeries<T>); virtual;
// Converts a data point from the source series to a high-precision visual point for the chart.
// May not be applicable for all series types (e.g., OHLC).
function DataToPoint(const DataPoint: TDataPoint<T>): TPointD; virtual; abstract;
public
constructor Create(Collection: TCollection); override;
property DataSeries: TDataSeries<T> read FDataSeries write SetDataSeries;
end;
TDataSourceField = (dsfAsk, dsfBid);
// Concrete series implementation for displaying TDataSeries<TAskBidItem>.
TChartAskBidSeries = class(TChartSeriesAdapter<TAskBidItem>)
private
FDataSourceField: TDataSourceField;
FCachedPoints: TArray<TPointD>;
FCacheValid: Boolean;
procedure SetDataSourceField(const Value: TDataSourceField);
procedure EnsureCacheIsValid;
protected
procedure SetDataSeries(const Value: TDataSeries<TAskBidItem>); override;
function DataToPoint(const DataPoint: TDataPoint<TAskBidItem>): TPointD; override;
public
constructor Create(Collection: TCollection); override;
procedure GetBounds(var MinPoint, MaxPoint: TPointD); override;
procedure Draw(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF); override;
published
property DataSourceField: TDataSourceField read FDataSourceField write SetDataSourceField;
end;
// Concrete series implementation for displaying TDataSeries<TOhlcItem> as candlesticks.
TChartOhlcSeries = class(TChartSeriesAdapter<TOhlcItem>)
private
FUpColor: TAlphaColor;
FDownColor: TAlphaColor;
protected
// This function is not used for OHLC drawing but must be implemented.
function DataToPoint(const DataPoint: TDataPoint<TOhlcItem>): TPointD; override;
public
constructor Create(Collection: TCollection); override;
procedure GetBounds(var MinPoint, MaxPoint: TPointD); override;
procedure Draw(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF); override;
published
property UpColor: TAlphaColor read FUpColor write FUpColor;
property DownColor: TAlphaColor read FDownColor write FDownColor;
end;
TChartSeriesCollection = class(TCollection)
private
[weak]
FOwner: TChart;
function GetItem(Index: Integer): TChartSeries;
procedure SetItem(Index: Integer; const Value: TChartSeries);
protected
function GetOwner: TPersistent; override;
procedure Update(Item: TCollectionItem); override;
public
constructor Create(AOwner: TChart);
property Items[Index: Integer]: TChartSeries read GetItem write SetItem; default;
end;
// A control for displaying charts.
TChart = class(TControl)
private
FSeries: TChartSeriesCollection;
FAxisColor: TAlphaColor;
FGridColor: TAlphaColor;
FPadding: Single;
procedure SetSeries(const Value: TChartSeriesCollection);
procedure SetAxisColor(const Value: TAlphaColor);
procedure SetGridColor(const Value: TAlphaColor);
procedure SetPadding(const Value: Single);
protected
procedure Paint; override;
procedure RecalcDataBounds(out MinPoint, MaxPoint: TPointD);
procedure DrawAxes(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF);
procedure DrawGrid(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Repaint;
published
property Align;
property Anchors;
property Series: TChartSeriesCollection read FSeries write SetSeries;
property AxisColor: TAlphaColor read FAxisColor write SetAxisColor;
property GridColor: TAlphaColor read FGridColor write SetGridColor;
property Padding: Single read FPadding write SetPadding;
end;
TTestChartForm = class(TForm)
procedure FormCreate(Sender: TObject);
private
FChart: TChart;
public
end;
var
TestChartForm: TTestChartForm;
implementation
{$R *.fmx}
{ TPointD }
constructor TPointD.Create(AX, AY: Double);
begin
X := AX;
Y := AY;
end;
{ TRectD }
constructor TRectD.Create(const ALeft, ATop, ARight, ABottom: Double);
begin
Left := ALeft;
Top := ATop;
Right := ARight;
Bottom := ABottom;
end;
constructor TRectD.Create(const ATopLeft, ABottomRight: TPointD);
begin
Left := ATopLeft.X;
Top := ATopLeft.Y;
Right := ABottomRight.X;
Bottom := ABottomRight.Y;
end;
function TRectD.GetHeight: Double;
begin
Result := Bottom - Top;
end;
function TRectD.GetWidth: Double;
begin
Result := Right - Left;
end;
{ TChartSeries }
constructor TChartSeries.Create(Collection: TCollection);
begin
inherited Create(Collection);
FColor := TAlphaColors.Black; // Default color for wicks in OHLC
FThickness := 1;
end;
function TChartSeries.GetChart: TChart;
begin
Result := (Collection as TChartSeriesCollection).GetOwner as TChart;
end;
procedure TChartSeries.SetColor(const Value: TAlphaColor);
begin
if (FColor <> Value) then
begin
FColor := Value;
if Assigned(Collection) then
Changed(False);
end;
end;
procedure TChartSeries.SetThickness(const Value: Single);
begin
if (FThickness <> Value) then
begin
FThickness := Value;
if Assigned(Collection) then
Changed(False);
end;
end;
{ TChartSeriesAdapter<T> }
constructor TChartSeriesAdapter<T>.Create(Collection: TCollection);
begin
inherited Create(Collection);
FDataSeries := TDataSeries<T>.Null;
end;
procedure TChartSeriesAdapter<T>.SetDataSeries(const Value: TDataSeries<T>);
begin
FDataSeries := Value;
if Assigned(Collection) then
Changed(False);
end;
{ TChartAskBidSeries }
constructor TChartAskBidSeries.Create(Collection: TCollection);
begin
inherited Create(Collection);
Self.Color := TAlphaColors.Blue; // Override default for line charts
Self.Thickness := 2;
FDataSourceField := dsfAsk;
FCacheValid := False;
end;
procedure TChartAskBidSeries.EnsureCacheIsValid;
var
i: Int64;
pointCount: Int64;
begin
if FCacheValid then
Exit;
pointCount := DataSeries.Count;
SetLength(FCachedPoints, pointCount);
if (pointCount > 0) then
begin
for i := 0 to pointCount - 1 do
begin
FCachedPoints[i] := DataToPoint(DataSeries[pointCount - 1 - i]);
end;
end;
FCacheValid := True;
end;
procedure TChartAskBidSeries.GetBounds(var MinPoint, MaxPoint: TPointD);
var
pt: TPointD;
isFirst: Boolean;
begin
EnsureCacheIsValid;
if (Length(FCachedPoints) = 0) then
Exit;
isFirst := (MinPoint.X = MaxPoint.X) and (MinPoint.Y = MaxPoint.Y);
if isFirst then
begin
MinPoint := FCachedPoints[0];
MaxPoint := FCachedPoints[0];
end;
for pt in FCachedPoints do
begin
MinPoint.X := Min(MinPoint.X, pt.X);
MinPoint.Y := Min(MinPoint.Y, pt.Y);
MaxPoint.X := Max(MaxPoint.X, pt.X);
MaxPoint.Y := Max(MaxPoint.Y, pt.Y);
end;
end;
procedure TChartAskBidSeries.Draw(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF);
var
scaleX, scaleY: Double;
pt1, pt2: TPointD;
transformedPt1, transformedPt2: TPointF;
j: Integer;
begin
EnsureCacheIsValid;
if Length(FCachedPoints) < 2 then
Exit;
if (ADataRect.Width <= 0) or (ADataRect.Height <= 0) then
Exit;
scaleX := ACanvasRect.Width / ADataRect.Width;
scaleY := ACanvasRect.Height / ADataRect.Height;
ACanvas.Stroke.Kind := TBrushKind.Solid;
ACanvas.Stroke.Color := Self.Color;
ACanvas.Stroke.Thickness := Self.Thickness;
pt1 := FCachedPoints[0];
for j := 1 to High(FCachedPoints) do
begin
pt2 := FCachedPoints[j];
transformedPt1.X := ACanvasRect.Left + (pt1.X - ADataRect.Left) * scaleX;
transformedPt1.Y := ACanvasRect.Bottom - (pt1.Y - ADataRect.Top) * scaleY;
transformedPt2.X := ACanvasRect.Left + (pt2.X - ADataRect.Left) * scaleX;
transformedPt2.Y := ACanvasRect.Bottom - (pt2.Y - ADataRect.Top) * scaleY;
ACanvas.DrawLine(transformedPt1, transformedPt2, 1);
pt1 := pt2;
end;
end;
procedure TChartAskBidSeries.SetDataSeries(const Value: TDataSeries<TAskBidItem>);
begin
inherited SetDataSeries(Value);
FCacheValid := False;
end;
function TChartAskBidSeries.DataToPoint(const DataPoint: TDataPoint<TAskBidItem>): TPointD;
begin
Result.X := DataPoint.Time;
case FDataSourceField of
dsfAsk: Result.Y := DataPoint.Data.Ask;
dsfBid: Result.Y := DataPoint.Data.Bid;
else
Result.Y := 0;
end;
end;
procedure TChartAskBidSeries.SetDataSourceField(const Value: TDataSourceField);
begin
if (FDataSourceField <> Value) then
begin
FDataSourceField := Value;
FCacheValid := False;
if Assigned(Collection) then
Changed(False);
end;
end;
{ TChartOhlcSeries }
constructor TChartOhlcSeries.Create(Collection: TCollection);
begin
inherited Create(Collection);
FUpColor := TAlphaColors.Green;
FDownColor := TAlphaColors.Red;
end;
function TChartOhlcSeries.DataToPoint(const DataPoint: TDataPoint<TOhlcItem>): TPointD;
begin
// Not used for OHLC series drawing, but must be implemented for the abstract parent.
Result.X := DataPoint.Time;
Result.Y := DataPoint.Data.Close;
end;
procedure TChartOhlcSeries.GetBounds(var MinPoint, MaxPoint: TPointD);
var
isFirst: Boolean;
i: Int64;
dataPoint: TDataPoint<TOhlcItem>;
begin
if (DataSeries.Count = 0) then
Exit;
isFirst := (MinPoint.X > MaxPoint.X); // A more robust check for an uninitialized state
for i := 0 to DataSeries.Count - 1 do
begin
dataPoint := DataSeries[i];
if isFirst then
begin
MinPoint.X := dataPoint.Time;
MaxPoint.X := dataPoint.Time;
MinPoint.Y := dataPoint.Data.Low;
MaxPoint.Y := dataPoint.Data.High;
isFirst := False;
end
else
begin
MinPoint.X := Min(MinPoint.X, dataPoint.Time);
MaxPoint.X := Max(MaxPoint.X, dataPoint.Time);
MinPoint.Y := Min(MinPoint.Y, dataPoint.Data.Low);
MaxPoint.Y := Max(MaxPoint.Y, dataPoint.Data.High);
end;
end;
end;
procedure TChartOhlcSeries.Draw(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF);
var
scaleX, scaleY: Double;
i: Int64;
dataPoint: TDataPoint<TOhlcItem>;
x_center, candleWidth: Single;
y_high, y_low, y_open, y_close: Single;
body: TRectF;
begin
if (DataSeries.Count = 0) or (ADataRect.Width <= 0) or (ADataRect.Height <= 0) then
Exit;
scaleX := ACanvasRect.Width / ADataRect.Width;
scaleY := ACanvasRect.Height / ADataRect.Height;
candleWidth := Max(3.0, (ACanvasRect.Width / DataSeries.Count) * 0.8);
for i := 0 to DataSeries.Count - 1 do
begin
dataPoint := DataSeries[i];
x_center := ACanvasRect.Left + (dataPoint.Time - ADataRect.Left) * scaleX;
y_high := ACanvasRect.Bottom - (dataPoint.Data.High - ADataRect.Top) * scaleY;
y_low := ACanvasRect.Bottom - (dataPoint.Data.Low - ADataRect.Top) * scaleY;
y_open := ACanvasRect.Bottom - (dataPoint.Data.Open - ADataRect.Top) * scaleY;
y_close := ACanvasRect.Bottom - (dataPoint.Data.Close - ADataRect.Top) * scaleY;
ACanvas.Stroke.Color := Self.Color;
ACanvas.Stroke.Thickness := Self.Thickness;
ACanvas.DrawLine(TPointF.Create(x_center, y_high), TPointF.Create(x_center, y_low), 1.0);
if (dataPoint.Data.Close >= dataPoint.Data.Open) then
ACanvas.Fill.Color := FUpColor
else
ACanvas.Fill.Color := FDownColor;
body := TRectF.Create(x_center - candleWidth / 2, y_open, x_center + candleWidth / 2, y_close);
NormalizeRect(body);
ACanvas.FillRect(body, 0, 0, [], 1.0);
end;
end;
{ TChartSeriesCollection }
constructor TChartSeriesCollection.Create(AOwner: TChart);
begin
inherited Create(TChartSeries);
FOwner := AOwner;
end;
function TChartSeriesCollection.GetItem(Index: Integer): TChartSeries;
begin
Result := TChartSeries(inherited GetItem(Index));
end;
function TChartSeriesCollection.GetOwner: TPersistent;
begin
Result := FOwner;
end;
procedure TChartSeriesCollection.SetItem(Index: Integer; const Value: TChartSeries);
begin
inherited SetItem(Index, Value);
end;
procedure TChartSeriesCollection.Update(Item: TCollectionItem);
begin
inherited;
if Assigned(FOwner) then
FOwner.Repaint;
end;
{ TChart }
constructor TChart.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSeries := TChartSeriesCollection.Create(Self);
FAxisColor := TAlphaColors.Black;
FGridColor := TAlphaColors.Lightgray;
FPadding := 30;
end;
destructor TChart.Destroy;
begin
FSeries.Free;
inherited Destroy;
end;
procedure TChart.Paint;
var
minPt, maxPt: TPointD;
dataRect: TRectD;
canvasRect: TRectF;
series: TCollectionItem;
hasData: Boolean;
begin
inherited;
Canvas.Fill.Color := TAlphaColors.White;
Canvas.FillRect(LocalRect, 1);
if (FSeries.Count = 0) then
Exit;
RecalcDataBounds(minPt, maxPt);
hasData := (minPt.X < maxPt.X) and (minPt.Y < maxPt.Y);
if not hasData then
Exit;
dataRect := TRectD.Create(minPt, maxPt);
canvasRect := Self.LocalRect;
canvasRect.Inflate(-FPadding, -FPadding);
if (canvasRect.Width < 1) or (canvasRect.Height < 1) then
Exit;
DrawGrid(Canvas, dataRect, canvasRect);
DrawAxes(Canvas, dataRect, canvasRect);
for series in FSeries do
begin
(series as TChartSeries).Draw(Canvas, dataRect, canvasRect);
end;
end;
procedure TChart.RecalcDataBounds(out MinPoint, MaxPoint: TPointD);
var
series: TCollectionItem;
begin
MinPoint := TPointD.Create(Infinity, Infinity);
MaxPoint := TPointD.Create(NegInfinity, NegInfinity);
for series in FSeries do
begin
(series as TChartSeries).GetBounds(MinPoint, MaxPoint);
end;
end;
procedure TChart.DrawAxes(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF);
begin
ACanvas.Stroke.Kind := TBrushKind.Solid;
ACanvas.Stroke.Color := FAxisColor;
ACanvas.Stroke.Thickness := 1;
ACanvas.DrawLine(TPointF.Create(ACanvasRect.Left, ACanvasRect.Bottom), TPointF.Create(ACanvasRect.Right, ACanvasRect.Bottom), 1);
ACanvas.DrawLine(TPointF.Create(ACanvasRect.Left, ACanvasRect.Top), TPointF.Create(ACanvasRect.Left, ACanvasRect.Bottom), 1);
end;
procedure TChart.DrawGrid(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF);
var
i: Integer;
x, y: Single;
const
GridLines = 5;
begin
ACanvas.Stroke.Kind := TBrushKind.Solid;
ACanvas.Stroke.Color := FGridColor;
ACanvas.Stroke.Thickness := 1;
ACanvas.Stroke.Dash := TStrokeDash.Dot;
for i := 1 to GridLines do
begin
x := ACanvasRect.Left + i * ACanvasRect.Width / GridLines;
ACanvas.DrawLine(TPointF.Create(x, ACanvasRect.Top), TPointF.Create(x, ACanvasRect.Bottom), 1);
end;
for i := 0 to GridLines - 1 do
begin
y := ACanvasRect.Bottom - i * ACanvasRect.Height / GridLines;
ACanvas.DrawLine(TPointF.Create(ACanvasRect.Left, y), TPointF.Create(ACanvasRect.Right, y), 1);
end;
ACanvas.Stroke.Dash := TStrokeDash.Solid;
end;
procedure TChart.SetSeries(const Value: TChartSeriesCollection);
begin
FSeries.Assign(Value);
end;
procedure TChart.SetAxisColor(const Value: TAlphaColor);
begin
if (FAxisColor <> Value) then
begin
FAxisColor := Value;
Repaint;
end;
end;
procedure TChart.SetGridColor(const Value: TAlphaColor);
begin
if (FGridColor <> Value) then
begin
FGridColor := Value;
Repaint;
end;
end;
procedure TChart.SetPadding(const Value: Single);
begin
if (FPadding <> Value) then
begin
FPadding := Value;
Repaint;
end;
end;
procedure TChart.Repaint;
begin
inherited;
end;
{ TTestChartForm }
procedure TTestChartForm.FormCreate(Sender: TObject);
var
ohlcSeries: TChartOhlcSeries;
askSeries, bidSeries: TChartAskBidSeries;
i: Integer;
ohlcData: TDataSeries<TOhlcItem>;
askBidData: TDataSeries<TAskBidItem>;
ohlcDataPoints: array of TDataPoint<TOhlcItem>;
askBidDataPoints: array of TDataPoint<TAskBidItem>;
startTime: TDateTime;
lastClose, o, h, l, c: Double;
ohlcItem: TOhlcItem;
const
NUM_POINTS = 50;
begin
FChart := TChart.Create(Self);
FChart.Parent := Self;
FChart.Align := TAlignLayout.Client;
// 1. Create OHLC Data
ohlcData := TDataSeries<TOhlcItem>.CreateWriteable(NUM_POINTS);
askBidData := TDataSeries<TAskBidItem>.CreateWriteable(NUM_POINTS);
startTime := Now;
SetLength(ohlcDataPoints, NUM_POINTS);
SetLength(askBidDataPoints, NUM_POINTS);
lastClose := 100;
for i := 0 to NUM_POINTS - 1 do
begin
o := lastClose + (Random - 0.5) * 2;
h := o + Random * 3;
l := o - Random * 3;
c := l + Random * (h - l);
lastClose := c;
ohlcItem.Open := o;
ohlcItem.High := h;
ohlcItem.Low := l;
ohlcItem.Close := c;
ohlcDataPoints[i] := TDataPoint<TOhlcItem>.Create(startTime + i, ohlcItem);
// Derive Ask/Bid data from OHLC close price
askBidDataPoints[i] :=
TDataPoint<TAskBidItem>.Create(
startTime + i,
TAskBidItem.Create(c, c * 0.995) // Ask = Close, Bid = Close - 0.5% spread
);
end;
ohlcData.Add(ohlcDataPoints);
askBidData.Add(askBidDataPoints);
// 2. Create and add OHLC Series
ohlcSeries := TChartOhlcSeries.Create(FChart.Series);
ohlcSeries.DataSeries := ohlcData;
// 3. Create and add Ask/Bid Line Series
askSeries := TChartAskBidSeries.Create(FChart.Series);
askSeries.DataSeries := askBidData;
askSeries.DataSourceField := dsfAsk;
askSeries.Color := TAlphaColors.Blue;
askSeries.Thickness := 2;
bidSeries := TChartAskBidSeries.Create(FChart.Series);
bidSeries.DataSeries := askBidData;
bidSeries.DataSourceField := dsfBid;
bidSeries.Color := TAlphaColors.Orange;
bidSeries.Thickness := 2;
end;
end.
AuraTrader/TestModule.pas
+30
View File
@@ -0,0 +1,30 @@
unit TestModule;
interface
uses
Myc.Aura.Module;
type
TTestModule = class( TMycAuraNode, IAuraModule )
private
FId: Integer;
public
constructor Create(const AName: string; AId: Integer);
procedure SetupWorkspace(const Workspace: IAuraWorkspace);
end;
implementation
constructor TTestModule.Create(const AName: string; AId: Integer);
begin
inherited Create(AName);
FId := AId;
end;
procedure TTestModule.SetupWorkspace(const Workspace: IAuraWorkspace);
begin
end;
end.
Src/Myc.Aura.Module.pas
+509 -91
View File
@@ -12,144 +12,144 @@ optimizations, and conducting statistical robustness analysis via Monte Carlo si
#### `IAuraObject`
Base interface for all Aura objects, providing a common `Name` property for identification.
* `Name`: A writeable string representing the object's name.
* `Name`: A writeable string representing the object's name.
#### `TAuraArray<T: IAuraObject>`
A record providing a mutable, observable array-like collection for `IAuraObject` instances. It wraps a `TWriteable<TArray<T>>` and offers basic array manipulation methods.
* `Items`: A writeable array of `IAuraObject` instances.
* `Insert(Idx: Integer; const Item: T)`: Inserts an item at a specified index.
* `Delete(Idx: Integer)`: Deletes an item at a specified index.
* `IndexOf(const Item: T)`: Returns the index of a given item.
* `Items`: A writeable array of `IAuraObject` instances.
* `Insert(Idx: Integer; const Item: T)`: Inserts an item at a specified index.
* `Delete(Idx: Integer)`: Deletes an item at a specified index.
* `IndexOf(const Item: T)`: Returns the index of a given item.
#### `IAuraLiveObject`
Extends `IAuraObject` for entities that are dynamically produced and actively executing operations, providing logging capabilities and a running status.
* `Log`: A `TStrings` object for logging events and status messages.
* `IsRunning`: Indicates whether the object is currently active.
* `Log`: A `TStrings` object for logging events and status messages.
* `IsRunning`: Indicates whether the object is currently active.
#### `IAuraNode`
Extends `IAuraObject` for objects that can be part of a hierarchical structure and can be serialized.
* `Caption`: A human-readable representation of the object's name.
* `Serialize(const Write: TJsonWriter)`: Serializes the object's state to a JSON writer.
* `Caption`: A human-readable representation of the object's name.
* `Serialize(const Write: TJsonWriter)`: Serializes the object's state to a JSON writer.
#### `IAuraChilds<T: IAuraNode>`
A generic interface for `IAuraNode`s that can have child nodes, enabling hierarchical organization within the Aura system.
* `Items`: A `TAuraArray` containing the child nodes.
* `Items`: A `TAuraArray` containing the child nodes.
#### `TAuraParameterDef`
Defines the metadata for a single strategy parameter, including its name, type, and default value.
* `Name`: The name of the parameter.
* `ParamType`: The data type of the parameter (e.g., integer, float, string, UTC time).
* `DefaultValue`: The default value for the parameter, stored as a `TAuraParameterValue`.
* `Name`: The name of the parameter.
* `ParamType`: The data type of the parameter (e.g., integer, float, string, UTC time).
* `DefaultValue`: The default value for the parameter, stored as a `TAuraParameterValue`.
#### `TAuraParameterRecordDef`
Represents a collection of `TAuraParameterDef` records, defining all parameters for a specific strategy. This is an alias for `TArray<TAuraParameterDef>`.
#### `IAuraBot`
An interface representing an instance that executes a trading strategy with given parameters over a specified time period.
* `PnL`: A mutable data series representing the Profit and Loss (PnL) curve of the bot's execution.
* `PnL`: A mutable data series representing the Profit and Loss (PnL) curve of the bot's execution.
#### `IAuraStrategy`
Defines a trading strategy, providing methods to create `IAuraBot` instances and specifying its parameter structure.
* `CreateBot(const Parameters: TArray<TAuraParameterValue>; StartTime, EndTime: TDateTime)`: Creates and returns an `IAuraBot` instance configured with the given parameters and time range.
* `ParameterRecordDef`: Defines the set of parameters expected by this strategy.
* `CreateBot(const Parameters: TArray<TAuraParameterValue>; StartTime, EndTime: TDateTime)`: Creates and returns an `IAuraBot` instance configured with the given parameters and time range.
* `ParameterRecordDef`: Defines the set of parameters expected by this strategy.
#### `TAuraTradePerformance`
A record encapsulating key performance metrics from a backtest or optimization run.
* `PnL`: Total Profit and Loss.
* `SharpeRatio`: Risk-adjusted return.
* `MaxDrawdown`: Maximum peak-to-trough decline.
* `ProfitFactor`: Ratio of gross profits to gross losses.
* `CalmarRatio`: Annualized return divided by the maximum drawdown.
* `WinRate`: Percentage of winning trades.
* `PnL`: Total Profit and Loss.
* `SharpeRatio`: Risk-adjusted return.
* `MaxDrawdown`: Maximum peak-to-trough decline.
* `ProfitFactor`: Ratio of gross profits to gross losses.
* `CalmarRatio`: Annualized return divided by the maximum drawdown.
* `WinRate`: Percentage of winning trades.
#### `TAuraMonteCarloResult`
Stores the results of a Monte Carlo simulation, providing a probabilistic distribution of `TAuraTradePerformance` outcomes.
* `Percentile`: An array of `TAuraTradePerformance` records, sorted by PnL and distributed into 10% percentiles, allowing for statistical risk assessment.
* `Percentile`: An array of `TAuraTradePerformance` records, sorted by PnL and distributed into 10% percentiles, allowing for statistical risk assessment.
#### `IAuraTradeResult`
Represents the comprehensive outcome of a trade simulation (e.g., from a backtest or optimization), including performance metrics, trade details, and the ability to perform Monte Carlo analysis.
* `Performance`: The `TAuraTradePerformance` metrics for this result.
* `Trades`: A `TDataSeries<Double>` representing the PnLs of individual trades, serving as the basis for Monte Carlo simulation.
* `CalcMonteCarloSimulation(Steps: Integer)`: Asynchronously performs a Monte Carlo simulation on the `Trades` data, returning a `TFuture` that resolves to a `TAuraMonteCarloResult`.
* `Performance`: The `TAuraTradePerformance` metrics for this result.
* `Trades`: A `TDataSeries<Double>` representing the PnLs of individual trades, serving as the basis for Monte Carlo simulation.
* `CalcMonteCarloSimulation(Steps: Integer)`: Asynchronously performs a Monte Carlo simulation on the `Trades` data, returning a `TFuture` that resolves to a `TAuraMonteCarloResult`.
#### `TAuraTimeRange`
A record defining a specific time window with a start and end date/time.
* `StartTime`: The start of the time range.
* `EndTime`: The end of the time range.
* `StartTime`: The start of the time range.
* `EndTime`: The end of the time range.
#### `IAuraBacktest`
An interface for executing a single backtest of a trading strategy.
* `BacktestResult`: A `TFuture` that resolves to the `IAuraTradeResult` of this backtest.
* `Bot`: The `IAuraBot` instance executing the backtest.
* `Parameters`: The specific parameters used for this backtest.
* `Strategy`: The `IAuraStrategy` being backtested.
* `TimeRange`: The historical time window over which the backtest is conducted.
* `BacktestResult`: A `TFuture` that resolves to the `IAuraTradeResult` of this backtest.
* `Bot`: The `IAuraBot` instance executing the backtest.
* `Parameters`: The specific parameters used for this backtest.
* `Strategy`: The `IAuraStrategy` being backtested.
* `TimeRange`: The historical time window over which the backtest is conducted.
#### `IAuraParameterOptimization`
Represents a single optimization slot (window) within a Walk-Forward Optimization process. It manages the execution of multiple in-sample backtests to find optimal parameters, followed by an out-of-sample test.
* `InSampleTests`: A mutable array of `IAuraBacktest` instances representing the backtests run during the in-sample optimization phase. New tests are added, and less optimal ones may be removed.
* `OutOfSampleTest`: A mutable `IAuraBacktest` representing the test run with the best-fit parameters from the in-sample optimization on the subsequent out-of-sample data.
* `InSampleTests`: A mutable array of `IAuraBacktest` instances representing the backtests run during the in-sample optimization phase. New tests are added, and less optimal ones may be removed.
* `OutOfSampleTest`: A mutable `IAuraBacktest` representing the test run with the best-fit parameters from the in-sample optimization on the subsequent out-of-sample data.
#### `IAuraWalkForwardOptimizer`
Orchestrates the entire Walk-Forward Optimization (WFO) process, coordinating multiple `IAuraParameterOptimization` slots sequentially to test strategy adaptability across various market phases.
* `OptimizationResult`: A `TFuture` that resolves to the aggregated `IAuraTradeResult` representing the combined performance of all out-of-sample tests.
* `Slot`: An array of `IAuraParameterOptimization` instances, each representing a distinct optimization window.
* `OptimizationResult`: A `TFuture` that resolves to the aggregated `IAuraTradeResult` representing the combined performance of all out-of-sample tests.
* `Slot`: An array of `IAuraParameterOptimization` instances, each representing a distinct optimization window.
#### `IAuraParameterNode`
Represents a single configurable parameter for optimization algorithms, allowing its value to be set and observed.
* `Value`: A mutable `TAuraParameterValue` representing the parameter's current setting.
* `Value`: A mutable `TAuraParameterValue` representing the parameter's current setting.
#### `IAuraParameterList`
An alias for `IAuraChilds<IAuraParameterNode>`, providing a structured way to manage collections of `IAuraParameterNode`s.
#### `IAuraStudy`
Base interface for all types of strategy analysis studies (e.g., single backtests, parameter optimizations, WFOs).
* `EventLog`: A `TStrings` object for logging events specific to the study.
* `Strategy`: The `IAuraStrategy` that is the subject of the study.
* `EventLog`: A `TStrings` object for logging events specific to the study.
* `Strategy`: The `IAuraStrategy` that is the subject of the study.
#### `TAuraParameterRange`
Defines the allowed range for a strategy parameter during optimization.
* `MinValue`: The minimum allowed value for the parameter, as a `TAuraParameterValue`.
* `MaxValue`: The maximum allowed value for the parameter, as a `TAuraParameterValue`.
* `MinValue`: The minimum allowed value for the parameter, as a `TAuraParameterValue`.
* `MaxValue`: The maximum allowed value for the parameter, as a `TAuraParameterValue`.
#### `IAuraBacktestStudy`
A specialized `IAuraStudy` for setting up and initiating a single backtest.
* `TimeRange`: The `TAuraTimeRange` for the backtest.
* `Start`: Initiates and returns an `IAuraBacktest` instance.
* `TimeRange`: The `TAuraTimeRange` for the backtest.
* `Start`: Initiates and returns an `IAuraBacktest` instance.
#### `IAuraParameterOptimizationStudy`
A specialized `IAuraStudy` for configuring and initiating a parameter optimization process (e.g., using genetic algorithms) over a specific time range.
* `Parameters`: An `IAuraChilds` collection of `IAuraParameterNode`s defining the configuration parameters for the optimization algorithm itself (e.g., max generations, population size).
* `TimeRange`: The `TAuraTimeRange` for the optimization.
* `Start`: Initiates and returns an `IAuraParameterOptimization` instance.
* `Parameters`: An `IAuraChilds` collection of `IAuraParameterNode`s defining the configuration parameters for the optimization algorithm itself (e.g., max generations, population size).
* `TimeRange`: The `TAuraTimeRange` for the optimization.
* `Start`: Initiates and returns an `IAuraParameterOptimization` instance.
#### `IAuraWFOStudy`
A specialized `IAuraStudy` for configuring and initiating a Walk-Forward Optimization process.
* `ParameterRange[Idx: Integer]`: A writeable `TAuraParameterRange` defining the search space for each strategy parameter during the optimization phases.
* `NumSlots`: A writeable integer indicating the number of time windows (slots) for the WFO.
* `Start`: Initiates and returns an `IAuraWalkForwardOptimizer` instance.
* `ParameterRange[Idx: Integer]`: A writeable `TAuraParameterRange` defining the search space for each strategy parameter during the optimization phases.
* `NumSlots`: A writeable integer indicating the number of time windows (slots) for the WFO.
* `Start`: Initiates and returns an `IAuraWalkForwardOptimizer` instance.
#### `IAuraTradingMode`
An enumeration defining different operational modes for a trading environment.
* `tmTesting`: Mode for historical backtesting.
* `tmSim`: Mode for simulated live trading (paper trading).
* `tmLive`: Mode for actual live trading.
* `tmTesting`: Mode for historical backtesting.
* `tmSim`: Mode for simulated live trading (paper trading).
* `tmLive`: Mode for actual live trading.
#### `IAuraWorkspace`
Represents the scope of a complete testing and trading environment, containing various studies and managing the overall trading mode.
* `WalkForwardAnalysis`: An `IAuraChilds` collection of `IAuraWFOStudy` instances.
* `Backtests`: An `IAuraChilds` collection of `IAuraBacktestStudy` instances.
* `ParameterOptimizations`: An `IAuraChilds` collection of `IAuraParameterOptimizationStudy` instances.
* `TradingMode`: A writeable `IAuraTradingMode` indicating the current operational mode.
* `WalkForwardAnalysis`: An `IAuraChilds` collection of `IAuraWFOStudy` instances.
* `Backtests`: An `IAuraChilds` collection of `IAuraBacktestStudy` instances.
* `ParameterOptimizations`: An `IAuraChilds` collection of `IAuraParameterOptimizationStudy` instances.
* `TradingMode`: A writeable `IAuraTradingMode` indicating the current operational mode.
#### `IAuraStrategyFactory`
#### `IAuraModule`
An interface for creating instances of `IAuraStrategy`. Used for managing available strategy types.
* `CreateStrategy`: Creates and returns a new `IAuraStrategy` instance.
* `CreateStrategy`: Creates and returns a new `IAuraStrategy` instance.
#### `IAuraApplication`
The application-level singleton, serving as the root for serialization and providing access to all defined strategies and workspaces.
* `Strategies`: An `IAuraChilds` collection of `IAuraStrategyFactory` instances.
* `Workspaces`: An `IAuraChilds` collection of `IAuraWorkspace` instances.
* `Strategies`: An `IAuraChilds` collection of `IAuraModule` instances.
* `Workspaces`: An `IAuraChilds` collection of `IAuraWorkspace` instances.
---
*)
@@ -161,6 +161,7 @@ interface
uses
System.JSON.Writers,
System.Classes,
System.Generics.Collections,
Myc.Signals,
Myc.Futures,
Myc.Lazy,
@@ -179,6 +180,7 @@ type
FArray: TWriteable<TArray<T>>;
function GetItems: TWriteable<TArray<T>>;
public
class operator Initialize(out Dest: TAuraArray<T>);
procedure Insert(Idx: Integer; const Item: T);
procedure Delete(Idx: Integer);
function IndexOf(const Item: T): Integer;
@@ -200,10 +202,28 @@ type
property Caption: string read GetCaption;
end;
IAuraChilds<T: IAuraNode> = interface(IAuraNode)
function GetItems: TAuraArray<T>;
IAuraChilds<T> = interface(IAuraNode)
function GetItems: TWriteable<TArray<T>>;
procedure Insert(Idx: Integer; const Item: T);
procedure Delete(Idx: Integer);
function IndexOf(const Item: T): Integer;
// Nodes to add as childs in hierarchical representation
property Items: TAuraArray<T> read GetItems;
property Items: TWriteable<TArray<T>> read GetItems;
end;
TAuraChilds<T> = record
private
FChilds: IAuraChilds<T>;
function GetCaption: string;
public
constructor Create(const AChilds: IAuraChilds<T>);
class operator Implicit(const A: IAuraChilds<T>): TAuraChilds<T>; overload;
class operator Implicit(const A: TAuraChilds<T>): IAuraChilds<T>; overload;
procedure Serialize(const Write: TJsonWriter);
procedure Insert(Idx: Integer; const Item: T);
procedure Delete(Idx: Integer);
function IndexOf(const Item: T): Integer;
property Caption: string read GetCaption;
end;
TAuraParameterDef = record
@@ -346,57 +366,227 @@ type
property NumSlots: TWriteable<Integer> read GetNumSlots;
end;
IAuraTradingMode = (tmTesting, tmSim, tmLive);
TAuraTradingMode = (tmTesting, tmSim, tmLive);
// Repesents the scope of a workspace
IAuraWorkspace = interface(IAuraNode)
function GetWalkForwardAnalysis: IAuraChilds<IAuraWFOStudy>;
function GetBacktests: IAuraChilds<IAuraBacktestStudy>;
function GetParameterOptimizations: IAuraChilds<IAuraParameterOptimizationStudy>;
function GetTradingMode: TWriteable<IAuraTradingMode>;
property WalkForwardAnalysis: IAuraChilds<IAuraWFOStudy> read GetWalkForwardAnalysis;
property Backtests: IAuraChilds<IAuraBacktestStudy> read GetBacktests;
property ParameterOptimizations: IAuraChilds<IAuraParameterOptimizationStudy> read GetParameterOptimizations;
property TradingMode: TWriteable<IAuraTradingMode> read GetTradingMode;
['{8485F7E7-F097-4CB8-8186-A6C9AE0048AF}']
// function GetWalkForwardAnalysis: IAuraChilds<IAuraWFOStudy>;
// function GetBacktests: IAuraChilds<IAuraBacktestStudy>;
// function GetParameterOptimizations: IAuraChilds<IAuraParameterOptimizationStudy>;
// function GetWalkForwardAnalysis: IAuraChilds<IAuraWFOStudy>;
// function GetBacktests: IAuraChilds<IAuraBacktestStudy>;
// function GetParameterOptimizations: IAuraChilds<IAuraParameterOptimizationStudy>;
// property WalkForwardAnalysis: IAuraChilds<IAuraWFOStudy> read GetWalkForwardAnalysis;
// property Backtests: IAuraChilds<IAuraBacktestStudy> read GetBacktests;
// property ParameterOptimizations: IAuraChilds<IAuraParameterOptimizationStudy> read GetParameterOptimizations;
// property WalkForwardAnalysis: IAuraChilds<IAuraWFOStudy> read GetWalkForwardAnalysis;
// property Backtests: IAuraChilds<IAuraBacktestStudy> read GetBacktests;
// property ParameterOptimizations: IAuraChilds<IAuraParameterOptimizationStudy> read GetParameterOptimizations;
function GetTradingMode: TWriteable<TAuraTradingMode>;
function GetStudies: TAuraArray<IAuraStudy>;
property TradingMode: TWriteable<TAuraTradingMode> read GetTradingMode;
property Studies: TAuraArray<IAuraStudy> read GetStudies;
end;
IAuraStrategyFactory = interface(IAuraNode)
function CreateStrategy: IAuraStrategy;
IAuraModule = interface
procedure SetupWorkspace(const Workspace: IAuraWorkspace);
end;
// Application singleton, the root for serialization
IAuraApplication = interface(IAuraNode)
function GetStrategies: IAuraChilds<IAuraStrategyFactory>;
function GetModuleNames: TMutable<TArray<String>>;
function GetModules(const Name: String): IAuraModule;
function GetWorkspaces: IAuraChilds<IAuraWorkspace>;
property Strategies: IAuraChilds<IAuraStrategyFactory> read GetStrategies;
procedure RegisterModule(const Name: String; const Module: IAuraModule);
property ModuleNames: TMutable<TArray<String>> read GetModuleNames;
property Modules[const Name: String]: IAuraModule read GetModules;
property Workspaces: IAuraChilds<IAuraWorkspace> read GetWorkspaces;
end;
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////
///////////////////////////////////////////////////////////////////////////////////////////////////////////////////
// Generic implementation for a collection of child nodes.
TMycAuraObject = class(TInterfacedObject, IAuraObject)
private
FName: TWriteable<String>;
function GetName: TWriteable<String>;
procedure Serialize(const Write: TJsonWriter);
public
constructor Create(const AName: string);
end;
// Generic implementation for a collection of child nodes.
TMycAuraNode = class(TInterfacedObject, IAuraNode)
private
FName: TWriteable<String>;
function GetName: TWriteable<String>;
protected
function GetCaption: string; virtual;
procedure Serialize(const Write: TJsonWriter);
public
constructor Create(const AName: string);
end;
// Generic implementation for a collection of child nodes.
TMycAuraChilds<T: IAuraNode> = class(TInterfacedObject, IAuraChilds<T>)
private
FName: TWriteable<String>;
FItems: TWriteable<TArray<T>>;
function GetCaption: string;
function GetItems: TWriteable<TArray<T>>;
function GetName: TWriteable<String>;
procedure Serialize(const Write: TJsonWriter);
public
constructor Create(const AName: string);
procedure Delete(Idx: Integer);
function IndexOf(const Item: T): Integer;
procedure Insert(Idx: Integer; const Item: T);
end;
TMycAuraWorkspace = class(TMycAuraNode, IAuraWorkspace)
private
FTradingMode: TWriteable<TAuraTradingMode>;
FStudies: TAuraArray<IAuraStudy>;
function GetStudies: TAuraArray<IAuraStudy>;
function GetTradingMode: TWriteable<TAuraTradingMode>;
protected
function GetCaption: string; override;
public
constructor Create(const AName: string; TradingMode: TAuraTradingMode);
end;
TMycAuraApplication = class(TInterfacedObject, IAuraApplication)
private
FName: TWriteable<String>;
FModules: TDictionary<String, IAuraModule>;
FModulesChanged: TEvent;
FModuleNames: TMutable<TArray<String>>;
FWorkspaces: TAuraChilds<IAuraWorkspace>;
function GetCaption: string;
function GetName: TWriteable<String>;
function GetModuleNames: TMutable<TArray<String>>;
function GetModules(const Name: String): IAuraModule;
function GetWorkspaces: IAuraChilds<IAuraWorkspace>;
procedure Serialize(const Write: TJsonWriter);
public
constructor Create;
procedure RegisterModule(const Name: String; const Module: IAuraModule);
end;
implementation
uses
System.Generics.Collections;
{ TMycAuraObject }
constructor TMycAuraObject.Create(const AName: string);
begin
inherited Create;
FName := TWriteable<String>.CreateWriteable;
FName.Value := AName;
end;
function TMycAuraObject.GetName: TWriteable<String>;
begin
Result := FName;
end;
procedure TMycAuraObject.Serialize(const Write: TJsonWriter);
begin
Write.WriteStartObject;
Write.WritePropertyName('Name');
Write.WriteValue(FName.Value);
Write.WriteEndObject;
end;
{ TMycAuraNode }
constructor TMycAuraNode.Create(const AName: string);
begin
inherited Create;
FName := TWriteable<String>.CreateWriteable;
FName.Value := AName;
end;
function TMycAuraNode.GetCaption: string;
begin
Result := FName.Value;
end;
function TMycAuraNode.GetName: TWriteable<String>;
begin
Result := FName;
end;
procedure TMycAuraNode.Serialize(const Write: TJsonWriter);
begin
Write.WriteStartObject;
inherited;
Write.WriteEndObject;
end;
{ TAuraArray<T> }
class operator TAuraArray<T>.Initialize(out Dest: TAuraArray<T>);
begin
Dest.FArray := TWriteable<TArray<T>>.CreateWriteable;
end;
procedure TAuraArray<T>.Delete(Idx: Integer);
var
oldArray: TArray<T>;
newArray: TArray<T>;
oldCount: Integer;
begin
if Idx < 0 then
oldArray := FArray.Value;
oldCount := Length(oldArray);
if (Idx < 0) or (Idx >= oldCount) then
exit;
var Arr: TArray<T>;
SetLength(Arr, Length(FArray.Value) - 1);
TArray.Copy<T>(FArray.Value, Arr, 0, 0, Idx - 1);
TArray.Copy<T>(FArray.Value, Arr, Idx + 1, Idx, High(Arr) - Idx);
FArray.Value := Arr;
SetLength(newArray, oldCount - 1);
// Copy elements before the index
if Idx > 0 then
TArray.Copy<T>(oldArray, newArray, 0, 0, Idx);
// Copy elements after the index
if Idx < oldCount - 1 then
TArray.Copy<T>(oldArray, newArray, Idx + 1, Idx, oldCount - Idx - 1);
FArray.Value := newArray;
end;
procedure TAuraArray<T>.Insert(Idx: Integer; const Item: T);
var
oldArray: TArray<T>;
newArray: TArray<T>;
oldCount: Integer;
begin
var Arr: TArray<T>;
SetLength(Arr, Length(FArray.Value) + 1);
TArray.Copy<T>(FArray.Value, Arr, 0, 0, Idx - 1);
Arr[Idx] := Item;
TArray.Copy<T>(FArray.Value, Arr, Idx, Idx + 1, High(Arr) - Idx);
FArray.Value := Arr;
oldArray := FArray.Value;
if not Assigned(oldArray) then
SetLength(oldArray, 0);
oldCount := Length(oldArray);
if Idx < 0 then
Idx := 0;
if Idx > oldCount then
Idx := oldCount;
SetLength(newArray, oldCount + 1);
// Copy elements before the index
if Idx > 0 then
TArray.Copy<T>(oldArray, newArray, 0, 0, Idx);
newArray[Idx] := Item;
// Copy elements after the index
if Idx < oldCount then
TArray.Copy<T>(oldArray, newArray, Idx, Idx + 1, oldCount - Idx);
FArray.Value := newArray;
end;
function TAuraArray<T>.GetItems: TWriteable<TArray<T>>;
@@ -409,4 +599,232 @@ begin
Result := TArray.IndexOf<T>(FArray.Value, Item);
end;
{ TMycAuraChilds<T> }
constructor TMycAuraChilds<T>.Create(const AName: string);
begin
inherited Create;
FName := TWriteable<String>.CreateWriteable(AName);
FItems := TWriteable<TArray<T>>.CreateWriteable;
end;
procedure TMycAuraChilds<T>.Delete(Idx: Integer);
var
oldArray: TArray<T>;
newArray: TArray<T>;
oldCount: Integer;
begin
oldArray := FItems.Value;
oldCount := Length(oldArray);
if (Idx < 0) or (Idx >= oldCount) then
exit;
SetLength(newArray, oldCount - 1);
// Copy elements before the index
if Idx > 0 then
TArray.Copy<T>(oldArray, newArray, 0, 0, Idx);
// Copy elements after the index
if Idx < oldCount - 1 then
TArray.Copy<T>(oldArray, newArray, Idx + 1, Idx, oldCount - Idx - 1);
FItems.Value := newArray;
end;
function TMycAuraChilds<T>.GetCaption: string;
begin
Result := FName.Value;
end;
function TMycAuraChilds<T>.GetItems: TWriteable<TArray<T>>;
begin
Result := FItems;
end;
function TMycAuraChilds<T>.GetName: TWriteable<String>;
begin
Result := FName;
end;
function TMycAuraChilds<T>.IndexOf(const Item: T): Integer;
begin
Result := TArray.IndexOf<T>(FItems.Value, Item);
end;
procedure TMycAuraChilds<T>.Insert(Idx: Integer; const Item: T);
var
oldArray: TArray<T>;
newArray: TArray<T>;
oldCount: Integer;
begin
oldArray := FItems.Value;
if not Assigned(oldArray) then
SetLength(oldArray, 0);
oldCount := Length(oldArray);
if Idx < 0 then
Idx := 0;
if Idx > oldCount then
Idx := oldCount;
SetLength(newArray, oldCount + 1);
// Copy elements before the index
if Idx > 0 then
TArray.Copy<T>(oldArray, newArray, 0, 0, Idx);
newArray[Idx] := Item;
// Copy elements after the index
if Idx < oldCount then
TArray.Copy<T>(oldArray, newArray, Idx, Idx + 1, oldCount - Idx);
FItems.Value := newArray;
end;
procedure TMycAuraChilds<T>.Serialize(const Write: TJsonWriter);
var
Item: T;
arr: TArray<T>;
begin
Write.WriteStartObject;
inherited;
Write.WritePropertyName('Items');
Write.WriteStartArray;
arr := FItems.Value;
for Item in arr do
Item.Serialize(Write);
Write.WriteEndArray;
Write.WriteEndObject;
end;
{ TMycAuraApplication }
constructor TMycAuraApplication.Create;
begin
inherited Create;
FName := TWriteable<String>.CreateWriteable('Application');
FModules := TDictionary<String, IAuraModule>.Create;
FModulesChanged := TEvent.CreateEvent;
FModuleNames :=
TMutable<TArray<String>>.Construct(FModulesChanged.Signal, function: TArray<String> begin Result := FModules.Keys.ToArray; end);
FWorkspaces := TMycAuraChilds<IAuraWorkspace>.Create('Workspaces');
end;
function TMycAuraApplication.GetCaption: string;
begin
Result := FName.Value;
end;
function TMycAuraApplication.GetName: TWriteable<String>;
begin
Result := FName;
end;
function TMycAuraApplication.GetModuleNames: TMutable<TArray<String>>;
begin
Result := FModuleNames;
end;
function TMycAuraApplication.GetModules(const Name: String): IAuraModule;
begin
if not FModules.TryGetValue(Name, Result) then
Result := nil;
end;
function TMycAuraApplication.GetWorkspaces: IAuraChilds<IAuraWorkspace>;
begin
Result := FWorkspaces;
end;
procedure TMycAuraApplication.RegisterModule(const Name: String; const Module: IAuraModule);
begin
FModules.Add(Name, Module);
FModulesChanged.Notify;
end;
procedure TMycAuraApplication.Serialize(const Write: TJsonWriter);
begin
Write.WriteStartObject;
Write.WritePropertyName('Name');
Write.WriteValue(FName.Value);
Write.WritePropertyName('Workspaces');
FWorkspaces.Serialize(Write);
Write.WriteEndObject;
end;
function CreateAuraApplication: IAuraApplication;
begin
Result := TMycAuraApplication.Create;
end;
constructor TMycAuraWorkspace.Create(const AName: string; TradingMode: TAuraTradingMode);
begin
inherited Create(AName);
FTradingMode := TWriteable<TAuraTradingMode>.CreateWriteable(TradingMode);
end;
function TMycAuraWorkspace.GetCaption: string;
begin
var mode := '';
case FTradingMode.Value of
tmTesting: mode := ' (Test)';
tmSim: mode := ' (Sim)';
tmLive: mode := ' (Live)';
end;
Result := inherited GetCaption + mode;
end;
function TMycAuraWorkspace.GetStudies: TAuraArray<IAuraStudy>;
begin
Result := FStudies;
end;
function TMycAuraWorkspace.GetTradingMode: TWriteable<TAuraTradingMode>;
begin
Result := FTradingMode;
end;
constructor TAuraChilds<T>.Create(const AChilds: IAuraChilds<T>);
begin
FChilds := AChilds;
end;
procedure TAuraChilds<T>.Delete(Idx: Integer);
begin
FChilds.Delete(Idx);
end;
function TAuraChilds<T>.GetCaption: string;
begin
Result := FChilds.Caption;
end;
function TAuraChilds<T>.IndexOf(const Item: T): Integer;
begin
Result := FChilds.IndexOf(Item);
end;
procedure TAuraChilds<T>.Insert(Idx: Integer; const Item: T);
begin
FChilds.Insert(Idx, Item);
end;
procedure TAuraChilds<T>.Serialize(const Write: TJsonWriter);
begin
FChilds.Serialize(Write);
end;
class operator TAuraChilds<T>.Implicit(const A: IAuraChilds<T>): TAuraChilds<T>;
begin
Result.Create(A);
end;
class operator TAuraChilds<T>.Implicit(const A: TAuraChilds<T>): IAuraChilds<T>;
begin
Result := A.FChilds;
end;
end.
Src/Myc.Core.Notifier.pas
+1 -2
View File
@@ -208,6 +208,7 @@ begin
exit;
Item := PItem(Tag);
Item.Receiver := nil;
if Item = FList then
FList := Item.Next;
@@ -217,8 +218,6 @@ begin
if Item.Next <> nil then
Item.Next.Prev := Item.Prev;
Item.Receiver := nil;
FreeItem(Item);
end;
Src/Myc.Lazy.pas
+7 -1
View File
@@ -63,6 +63,7 @@ type
class operator Implicit(const A: TWriteable<T>): IWriteable; overload;
class function CreateWriteable: TWriteable<T>; overload; static;
class function CreateWriteable(const Init: T): TWriteable<T>; overload; static;
function Protect: TWriteable<T>;
@@ -212,7 +213,12 @@ end;
class function TWriteable<T>.CreateWriteable: TWriteable<T>;
begin
Result := TMycWriteableMutable<T>.Create(Default(T));
Result := CreateWriteable(Default(T));
end;
class function TWriteable<T>.CreateWriteable(const Init: T): TWriteable<T>;
begin
Result := TMycWriteableMutable<T>.Create(Init);
end;
function TWriteable<T>.GetChanged: TSignal;
Src/Myc.Signals.FMX.pas
+134 -65
View File
@@ -5,145 +5,214 @@ interface
uses
System.Classes,
System.SysUtils,
System.Generics.Collections,
System.Diagnostics,
System.Messaging,
Myc.Signals;
type
TSignalComponentHelper = class helper for TComponent
type
TMsgProc = reference to procedure(out IsDone: Boolean);
TSignalSubscription = class(TComponent, TSignal.ISubscriber)
private
FSignal: TSignal;
FSigSubscr: TSignal.TSubscription;
FProc: TMsgProc;
FNotified: Integer;
FIdleSubscrId: TMessageSubscriptionId;
class var
FQueued: Integer;
FCount: Integer;
FItems: TList<TSignalSubscription>;
FIdx: Integer;
class procedure HandleSignals(Timeout: Int64);
function Notify: Boolean;
public
constructor Create(AOwner: TComponent; const ASignal: TSignal; const AProc: TMsgProc); reintroduce;
destructor Destroy; override;
end;
public
procedure ProcessSignal(const Signal: TSignal; const Proc: TMsgProc); overload;
procedure ProcessSignal(const Signal: TSignal; const Proc: TProc); overload;
function ProcessSignal(const Signal: TSignal; const Proc: TMsgProc): TComponent; overload;
function ProcessSignal(const Signal: TSignal; const Proc: TProc): TComponent; overload;
end;
TSignalSyncHelper = record helper for TSignal
function Queue(const Proc: TProc; Delay: Integer = 0): TSignal.TSubscription; overload;
function Queue(Thread: TThread; const Proc: TProc; Delay: Integer = 0): TSignal.TSubscription; overload;
end;
implementation
uses
System.Diagnostics,
System.Messaging,
FMX.Types;
{ TSignalComponentHelper.TSignalSubscription }
type
TSignalSubscriber = class(TComponent, TSignal.ISubscriber)
private
FSignal: TSignal;
FSigSubscr: TSignal.TSubscription;
FProc: TSignalComponentHelper.TMsgProc;
FNotified: Integer;
FIdleSubscrId: TMessageSubscriptionId;
FNext, FPrev: TSignalSubscriber;
class var
FQueued: Integer;
FCount: Integer;
FFirst: TSignalSubscriber;
FCurr: TSignalSubscriber;
class procedure HandleSignals(Timeout: Int64);
public
constructor Create(AOwner: TComponent; const ASignal: TSignal; const AProc: TSignalComponentHelper.TMsgProc); reintroduce;
destructor Destroy; override;
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
function Notify: Boolean;
end;
constructor TSignalComponentHelper.TSignalSubscription.Create(AOwner: TComponent; const ASignal: TSignal; const AProc: TMsgProc);
TSyncSubscriber = class(TInterfacedObject, TSignal.ISubscriber)
Thread: TThread;
Delay: Integer;
Timestamp: Int64;
Proc: TProc;
class var
Timer: TStopwatch;
function Notify: Boolean;
class constructor CreateClass;
end;
class constructor TSyncSubscriber.CreateClass;
begin
Timer := TStopwatch.StartNew;
end;
function TSyncSubscriber.Notify: Boolean;
begin
if Assigned(Proc) then
begin
var cProc := Proc;
Proc := nil;
TThread.ForceQueue(Thread, procedure begin cProc() end, Delay - (Timer.ElapsedMilliseconds - Timestamp));
end;
Result := false;
end;
{ TSignalSubscription }
constructor TSignalSubscriber.Create(AOwner: TComponent; const ASignal: TSignal; const AProc: TSignalComponentHelper.TMsgProc);
begin
inherited Create(AOwner);
FSignal := ASignal;
FProc := AProc;
FIdx := 0;
if FItems = nil then
if FFirst = nil then
begin
FItems := TList<TSignalSubscription>.Create;
FIdleSubscrId :=
TMessageManager
.DefaultManager
.SubscribeToMessage(TIdleMessage, procedure(const Sender: TObject; const M: TMessage) begin HandleSignals(50); end);
end;
FItems.Add(Self);
FPrev := nil;
if FFirst <> nil then
FNext := FFirst;
if FNext <> nil then
FNext.FPrev := Self;
FFirst := Self;
FSigSubscr := FSignal.Subscribe(Self);
end;
destructor TSignalComponentHelper.TSignalSubscription.Destroy;
destructor TSignalSubscriber.Destroy;
begin
FSigSubscr.Unsubscribe;
FItems.Remove(Self);
if FItems.Count = 0 then
if FFirst = Self then
FFirst := FNext;
if FNext <> nil then
FNext.FPrev := FPrev;
if FPrev <> nil then
FPrev.FNext := FNext;
if FFirst = nil then
begin
TMessageManager.DefaultManager.Unsubscribe(TIdleMessage, FIdleSubscrId);
FreeAndNil(FItems);
end;
inherited;
end;
class procedure TSignalComponentHelper.TSignalSubscription.HandleSignals(Timeout: Int64);
procedure TSignalSubscriber.AfterConstruction;
begin
inherited;
Notify;
end;
procedure TSignalSubscriber.BeforeDestruction;
begin
FSigSubscr.Unsubscribe;
if FCurr = Self then
FCurr := FCurr.FNext;
inherited;
end;
class procedure TSignalSubscriber.HandleSignals(Timeout: Int64);
begin
if AtomicExchange(FQueued, 0) = 0 then
exit;
var Stopwatch := TStopwatch.StartNew;
var doBreak := false;
if (FIdx = 0) or (FIdx > FItems.Count) then
FIdx := FItems.Count;
if FCurr = nil then
FCurr := FFirst;
while FIdx > 0 do
while FCurr <> nil do
begin
dec(FIdx);
var sub := FItems[FIdx];
var sub := FCurr;
FCurr := sub.FNext;
if AtomicExchange(sub.FNotified, 0) = 1 then
begin
var done := false;
try
sub.FProc(done);
finally
if done then
sub.Free;
if not (csDestroying in sub.ComponentState) then
begin
var done := false;
try
sub.FProc(done);
finally
if done then
sub.Free;
end;
end;
if AtomicDecrement(FCount) = 1 then
break;
doBreak := AtomicDecrement(FCount) = 1;
end;
if Stopwatch.ElapsedMilliseconds > Timeout then
doBreak := doBreak or (Stopwatch.ElapsedMilliseconds > Timeout);
if doBreak then
begin
AtomicExchange(FQueued, 1);
break;
end;
if FIdx = 0 then
FIdx := FItems.Count;
end;
end;
function TSignalComponentHelper.TSignalSubscription.Notify: Boolean;
function TSignalSubscriber.Notify: Boolean;
begin
if AtomicExchange(FNotified, 1) = 0 then
AtomicIncrement(FCount);
AtomicExchange(FQueued, 1);
// if AtomicExchange(FQueued, 1) = 0 then
// TThread.Queue( nil,
// procedure
// begin
// if AtomicExchange(FQueued, 0) = 1 then
// HandleSignals( 40 );
// end);
Result := true;
end;
procedure TSignalComponentHelper.ProcessSignal(const Signal: TSignal; const Proc: TProc);
function TSignalComponentHelper.ProcessSignal(const Signal: TSignal; const Proc: TProc): TComponent;
begin
var cProc: TProc := Proc;
TSignalSubscription.Create(Self, Signal, procedure(out IsDone: Boolean) begin cProc(); end);
Result := ProcessSignal(Signal, procedure(out IsDone: Boolean) begin cProc(); end);
end;
procedure TSignalComponentHelper.ProcessSignal(const Signal: TSignal; const Proc: TMsgProc);
function TSignalComponentHelper.ProcessSignal(const Signal: TSignal; const Proc: TMsgProc): TComponent;
begin
TSignalSubscription.Create(Self, Signal, Proc);
Result := TSignalSubscriber.Create(Self, Signal, Proc);
end;
{ TSignalSyncHelper }
function TSignalSyncHelper.Queue(const Proc: TProc; Delay: Integer = 0): TSignal.TSubscription;
begin
Result := Queue(nil, Proc, Delay);
end;
function TSignalSyncHelper.Queue(Thread: TThread; const Proc: TProc; Delay: Integer = 0): TSignal.TSubscription;
begin
var Subscr := TSyncSubscriber.Create;
Subscr.Thread := Thread;
Subscr.Proc := Proc;
Subscr.Delay := Delay;
Subscr.Timestamp := TSyncSubscriber.Timer.ElapsedMilliseconds;
Result := Subscribe(Subscr);
end;
end.