1060 lines
33 KiB
ObjectPascal
1060 lines
33 KiB
ObjectPascal
unit TestChartControl;
|
|
|
|
interface
|
|
|
|
uses
|
|
System.SysUtils,
|
|
System.Types,
|
|
System.UITypes,
|
|
System.Classes,
|
|
System.Variants,
|
|
System.Generics.Collections,
|
|
System.Math,
|
|
System.UIConsts,
|
|
System.TimeSpan,
|
|
FMX.Types,
|
|
FMX.Controls,
|
|
FMX.Forms,
|
|
FMX.Graphics,
|
|
FMX.Dialogs,
|
|
FMX.Objects,
|
|
Myc.Signals,
|
|
Myc.Futures,
|
|
Myc.Trade.DataPoint,
|
|
Myc.Signals.FMX;
|
|
|
|
type
|
|
TPointD = record
|
|
public
|
|
X: Double;
|
|
Y: Double;
|
|
constructor Create(AX, AY: Double);
|
|
procedure Offset(DX, DY: Double);
|
|
end;
|
|
|
|
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;
|
|
procedure Offset(DX, DY: Double);
|
|
procedure ExpandBy(const pt: TPointD);
|
|
property Width: Double read GetWidth;
|
|
property Height: Double read GetHeight;
|
|
end;
|
|
|
|
TRangeD = record
|
|
A: Double;
|
|
B: Double;
|
|
public
|
|
constructor Create(const AA, AB: Double);
|
|
end;
|
|
|
|
TChartZoomMode = (czmXY, czmXOnly);
|
|
TChart = class; // Forward declaration
|
|
|
|
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;
|
|
function GetBounds: TFuture<TRectD>; virtual; abstract;
|
|
function GetYBoundsForXRange(const XRange: TRangeD): TFuture<TRangeD>; virtual; abstract;
|
|
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;
|
|
|
|
TChartSeriesAdapter<T> = class abstract(TChartSeries)
|
|
private
|
|
FDataSeries: TFuture<TDataSeries<T>>;
|
|
protected
|
|
procedure SetDataSeries(const Value: TFuture<TDataSeries<T>>); virtual;
|
|
function DataToPoint(const DataPoint: TDataPoint<T>): TPointD; virtual; abstract;
|
|
public
|
|
constructor Create(Collection: TCollection); override;
|
|
property DataSeries: TFuture<TDataSeries<T>> read FDataSeries write SetDataSeries;
|
|
end;
|
|
|
|
// A generic series to plot a TDataSeries<Single>
|
|
TChartLineSeries = class(TChartSeriesAdapter<Double>)
|
|
private
|
|
FBounds: TFuture<TRectD>;
|
|
protected
|
|
procedure SetDataSeries(const Value: TFuture<TDataSeries<Double>>); override;
|
|
function DataToPoint(const DataPoint: TDataPoint<Double>): TPointD; override;
|
|
public
|
|
constructor Create(Collection: TCollection); override;
|
|
function GetBounds: TFuture<TRectD>; override;
|
|
function GetYBoundsForXRange(const XRange: TRangeD): TFuture<TRangeD>; override;
|
|
procedure Draw(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF); override;
|
|
end;
|
|
|
|
TChartOhlcSeries = class(TChartSeriesAdapter<TOhlcItem>)
|
|
private
|
|
FUpColor: TAlphaColor;
|
|
FDownColor: TAlphaColor;
|
|
FCandleWidth: Double;
|
|
FTimeInterval: TFuture<Double>;
|
|
FBounds: TFuture<TRectD>;
|
|
protected
|
|
procedure SetDataSeries(const Value: TFuture<TDataSeries<TOhlcItem>>); override;
|
|
function DataToPoint(const DataPoint: TDataPoint<TOhlcItem>): TPointD; override;
|
|
public
|
|
constructor Create(Collection: TCollection); override;
|
|
function GetBounds: TFuture<TRectD>; override;
|
|
function GetYBoundsForXRange(const XRange: TRangeD): TFuture<TRangeD>; 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;
|
|
property CandleWidth: Double read FCandleWidth write FCandleWidth;
|
|
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;
|
|
|
|
TChart = class(TControl)
|
|
private
|
|
FSeries: TChartSeriesCollection;
|
|
FAxisColor: TAlphaColor;
|
|
FGridColor: TAlphaColor;
|
|
FPadding: Single;
|
|
FDataBounds: TFuture<TRectD>;
|
|
FYRange: TFuture<TRangeD>;
|
|
FDataView: TRectD;
|
|
FBoundsValid: Boolean;
|
|
FIsPanning: Boolean;
|
|
FPanStartPoint: TPointF;
|
|
FZoomMode: TChartZoomMode;
|
|
procedure SetSeries(const Value: TChartSeriesCollection);
|
|
procedure SetAxisColor(const Value: TAlphaColor);
|
|
procedure SetGridColor(const Value: TAlphaColor);
|
|
procedure SetPadding(const Value: Single);
|
|
procedure RecalcDataBounds;
|
|
protected
|
|
procedure Paint; override;
|
|
procedure DrawAxes(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF);
|
|
procedure DrawGrid(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF);
|
|
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
|
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
|
|
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
|
procedure MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); override;
|
|
procedure DblClick; override;
|
|
procedure InvalidateDataBounds;
|
|
procedure InvalidateYRange;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure BeforeDestruction; override;
|
|
procedure ResetView;
|
|
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;
|
|
property ZoomMode: TChartZoomMode read FZoomMode write FZoomMode;
|
|
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;
|
|
|
|
procedure TPointD.Offset(DX, DY: Double);
|
|
begin
|
|
X := X + DX;
|
|
Y := Y + DY;
|
|
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;
|
|
|
|
procedure TRectD.ExpandBy(const pt: TPointD);
|
|
begin
|
|
if pt.X < Left then
|
|
Left := pt.X;
|
|
if pt.X > Right then
|
|
Right := pt.X;
|
|
if pt.Y < Top then
|
|
Top := pt.Y;
|
|
if pt.Y > Bottom then
|
|
Bottom := pt.Y;
|
|
end;
|
|
|
|
procedure TRectD.Offset(DX, DY: Double);
|
|
begin
|
|
Left := Left + DX;
|
|
Right := Right + DX;
|
|
Top := Top + DY;
|
|
Bottom := Bottom + DY;
|
|
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;
|
|
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);
|
|
end;
|
|
|
|
procedure TChartSeriesAdapter<T>.SetDataSeries(const Value: TFuture<TDataSeries<T>>);
|
|
begin
|
|
FDataSeries := Value;
|
|
if Assigned(Collection) then
|
|
Changed(False);
|
|
end;
|
|
|
|
{ TChartLineSeries }
|
|
|
|
constructor TChartLineSeries.Create(Collection: TCollection);
|
|
begin
|
|
inherited Create(Collection);
|
|
Self.Color := TAlphaColors.Green;
|
|
Self.Thickness := 1;
|
|
end;
|
|
|
|
procedure TChartLineSeries.SetDataSeries(const Value: TFuture<TDataSeries<Double>>);
|
|
begin
|
|
// Future<Array of Points> -> Future<Bounds Rectangle>
|
|
FBounds :=
|
|
Value.Chain<TRectD>(
|
|
function(const Data: TDataSeries<Double>): TRectD
|
|
begin
|
|
if Data.Count = 0 then
|
|
Exit(TRectD.Create(0, 0, 0, 0));
|
|
|
|
Result := TRectD.Create(Data[0].Time, Data[0].Data, Data[0].Time, Data[0].Data);
|
|
for var i := 1 to Data.Count - 1 do
|
|
Result.ExpandBy(TPointD.Create(Data[i].Time, Data[i].Data));
|
|
end
|
|
);
|
|
|
|
inherited SetDataSeries(Value);
|
|
end;
|
|
|
|
function TChartLineSeries.DataToPoint(const DataPoint: TDataPoint<Double>): TPointD;
|
|
begin
|
|
Result.X := DataPoint.Time;
|
|
Result.Y := DataPoint.Data;
|
|
end;
|
|
|
|
function TChartLineSeries.GetBounds: TFuture<TRectD>;
|
|
begin
|
|
Result := FBounds;
|
|
end;
|
|
|
|
function TChartLineSeries.GetYBoundsForXRange(const XRange: TRangeD): TFuture<TRangeD>;
|
|
begin
|
|
Result :=
|
|
DataSeries.Chain<TRangeD>(
|
|
function(const Data: TDataSeries<Double>): TRangeD
|
|
begin
|
|
Result.A := Infinity;
|
|
Result.B := NegInfinity;
|
|
|
|
var n := Data.IndexOf(XRange.A);
|
|
for var i := n to Data.Count - 1 do
|
|
begin
|
|
var dp := Data[i];
|
|
var pt := TPointD.Create(dp.Time, dp.Data);
|
|
// if (pt.X >= XRange.A) and (pt.X <= XRange.B) then
|
|
// begin
|
|
// Result.A := System.Math.Min(Result.A, pt.Y);
|
|
// Result.B := System.Math.Max(Result.B, pt.Y);
|
|
// end;
|
|
if pt.X > XRange.B then
|
|
break;
|
|
Result.A := System.Math.Min(Result.A, pt.Y);
|
|
Result.B := System.Math.Max(Result.B, pt.Y);
|
|
end;
|
|
if IsInfinite(Result.A) then
|
|
begin
|
|
Result.A := 0;
|
|
Result.B := -1;
|
|
end;
|
|
end
|
|
);
|
|
end;
|
|
|
|
procedure TChartLineSeries.Draw(const ACanvas: TCanvas; const ADataRect: TRectD; const ACanvasRect: TRectF);
|
|
var
|
|
scaleX, scaleY: Double;
|
|
transformedPt1, transformedPt2: TPointF;
|
|
j: Integer;
|
|
begin
|
|
if not DataSeries.Done.IsSet then
|
|
exit;
|
|
var points := DataSeries.Value;
|
|
|
|
if points.Count < 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;
|
|
|
|
var dp1 := points[0];
|
|
var dp2 := dp1;
|
|
for j := 1 to points.Count - 1 do
|
|
begin
|
|
dp2 := points[j];
|
|
|
|
transformedPt1.X := ACanvasRect.Left + (dp1.Time - ADataRect.Left) * scaleX;
|
|
transformedPt1.Y := ACanvasRect.Bottom - (dp1.Data - ADataRect.Top) * scaleY;
|
|
transformedPt2.X := ACanvasRect.Left + (dp2.Time - ADataRect.Left) * scaleX;
|
|
transformedPt2.Y := ACanvasRect.Bottom - (dp2.Data - ADataRect.Top) * scaleY;
|
|
|
|
ACanvas.DrawLine(transformedPt1, transformedPt2, 1);
|
|
dp1 := dp2;
|
|
end;
|
|
end;
|
|
|
|
{ TChartOhlcSeries }
|
|
|
|
constructor TChartOhlcSeries.Create(Collection: TCollection);
|
|
begin
|
|
inherited Create(Collection);
|
|
FUpColor := TAlphaColors.Green;
|
|
FDownColor := TAlphaColors.Red;
|
|
FCandleWidth := 0.8;
|
|
FTimeInterval := TFuture<Double>.Construct(1.0);
|
|
end;
|
|
|
|
procedure TChartOhlcSeries.SetDataSeries(const Value: TFuture<TDataSeries<TOhlcItem>>);
|
|
begin
|
|
FTimeInterval :=
|
|
Value.Chain<Double>(
|
|
function(const DataSeries: TDataSeries<TOhlcItem>): Double
|
|
var
|
|
i: Int64;
|
|
diff: Double;
|
|
begin
|
|
Result := 1.0;
|
|
if DataSeries.Count < 2 then
|
|
Exit;
|
|
|
|
Result := MaxDouble;
|
|
for i := 0 to DataSeries.Count - 2 do
|
|
begin
|
|
diff := Abs(DataSeries[i].Time - DataSeries[i + 1].Time);
|
|
if (diff > 1E-9) and (diff < Result) then
|
|
Result := diff;
|
|
end;
|
|
|
|
if (Result = MaxDouble) then
|
|
Result := 1.0;
|
|
end
|
|
);
|
|
|
|
FBounds :=
|
|
Value.Chain<TRectD>(
|
|
function(const DataSeries: TDataSeries<TOhlcItem>): TRectD
|
|
var
|
|
i: Int64;
|
|
begin
|
|
if (DataSeries.Count = 0) then
|
|
Exit(TRectD.Create(0, 0, 0, 0));
|
|
|
|
Result := TRectD.Create(DataSeries[0].Time, DataSeries[0].Data.High, DataSeries[0].Time, DataSeries[0].Data.Low);
|
|
for i := 0 to DataSeries.Count - 1 do
|
|
begin
|
|
Result.ExpandBy(TPointD.Create(DataSeries[i].Time, DataSeries[i].Data.High));
|
|
Result.ExpandBy(TPointD.Create(DataSeries[i].Time, DataSeries[i].Data.Low));
|
|
end;
|
|
end
|
|
);
|
|
|
|
inherited SetDataSeries(Value);
|
|
end;
|
|
|
|
function TChartOhlcSeries.DataToPoint(const DataPoint: TDataPoint<TOhlcItem>): TPointD;
|
|
begin
|
|
Result.X := DataPoint.Time;
|
|
Result.Y := DataPoint.Data.Close;
|
|
end;
|
|
|
|
function TChartOhlcSeries.GetBounds: TFuture<TRectD>;
|
|
begin
|
|
Result := FBounds;
|
|
end;
|
|
|
|
function TChartOhlcSeries.GetYBoundsForXRange(const XRange: TRangeD): TFuture<TRangeD>;
|
|
begin
|
|
Result :=
|
|
DataSeries.Chain<TRangeD>(
|
|
function(const Data: TDataSeries<TOhlcItem>): TRangeD
|
|
var
|
|
i: Int64;
|
|
dataPoint: TDataPoint<TOhlcItem>;
|
|
begin
|
|
Result.A := Infinity;
|
|
Result.B := NegInfinity;
|
|
|
|
var n := Data.IndexOf(XRange.A);
|
|
|
|
if n >= 0 then
|
|
for i := 1 to Data.Count - 2 do
|
|
begin
|
|
dataPoint := Data[i];
|
|
var t := Double(dataPoint.Time);
|
|
var t2 := Double(Data[i + 1].Time);
|
|
|
|
if ((t >= XRange.A) and (t <= XRange.B)) or ((t2 >= XRange.A) and (t2 <= XRange.B)) then
|
|
begin
|
|
Result.A := System.Math.Min(Result.A, dataPoint.Data.Low);
|
|
Result.B := System.Math.Max(Result.B, dataPoint.Data.High);
|
|
end;
|
|
end;
|
|
if IsInfinite(Result.A) then
|
|
begin
|
|
Result.A := 0;
|
|
Result.B := -1;
|
|
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, pixelCandleWidth, pixelCandleIntervalWidth: Single;
|
|
y_high, y_low, y_open, y_close: Single;
|
|
body: TRectF;
|
|
data: TDataSeries<TOhlcItem>;
|
|
timeInterval: Double;
|
|
begin
|
|
if (not DataSeries.Done.IsSet) or (not FTimeInterval.Done.IsSet) then
|
|
exit;
|
|
data := DataSeries.Value;
|
|
timeInterval := FTimeInterval.Value;
|
|
|
|
if (data.Count = 0) or (ADataRect.Width <= 0) or (ADataRect.Height <= 0) then
|
|
Exit;
|
|
|
|
scaleX := ACanvasRect.Width / ADataRect.Width;
|
|
scaleY := ACanvasRect.Height / ADataRect.Height;
|
|
|
|
pixelCandleIntervalWidth := timeInterval * scaleX;
|
|
pixelCandleWidth := System.Math.Max(1.0, FCandleWidth * pixelCandleIntervalWidth);
|
|
|
|
for i := data.Count - 1 downto 0 do
|
|
begin
|
|
dataPoint := data[i];
|
|
|
|
if ((dataPoint.Time + timeInterval) < ADataRect.Left) or ((dataPoint.Time - timeInterval) > ADataRect.Right) then
|
|
continue;
|
|
|
|
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 - pixelCandleWidth / 2, y_open, x_center + pixelCandleWidth / 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.InvalidateDataBounds;
|
|
end;
|
|
|
|
{ TChart }
|
|
|
|
constructor TChart.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FSeries := TChartSeriesCollection.Create(Self);
|
|
FAxisColor := TAlphaColors.Black;
|
|
FGridColor := TAlphaColors.Lightgray;
|
|
FPadding := 30;
|
|
FIsPanning := False;
|
|
FBoundsValid := False;
|
|
FZoomMode := TChartZoomMode.czmXOnly;
|
|
// Initialize futures with default empty values
|
|
FDataBounds := TFuture<TRectD>.Construct(TRectD.Create(0, 0, 0, 0));
|
|
FDataView := TRectD.Create(0, 0, 0, 0);
|
|
end;
|
|
|
|
destructor TChart.Destroy;
|
|
begin
|
|
FSeries.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TChart.BeforeDestruction;
|
|
begin
|
|
FYRange.WaitFor;
|
|
FDataBounds.WaitFor;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TChart.InvalidateDataBounds;
|
|
begin
|
|
if FBoundsValid then
|
|
InvalidateYRange;
|
|
FBoundsValid := False;
|
|
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TChart.ResetView;
|
|
begin
|
|
if not FBoundsValid then
|
|
RecalcDataBounds;
|
|
|
|
// The view is reset to the full data bounds.
|
|
FDataView := FDataBounds.WaitFor;
|
|
InvalidateYRange;
|
|
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TChart.DblClick;
|
|
begin
|
|
inherited;
|
|
ResetView;
|
|
end;
|
|
|
|
procedure TChart.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
|
begin
|
|
inherited;
|
|
if Button = TMouseButton.mbLeft then
|
|
begin
|
|
FIsPanning := True;
|
|
FPanStartPoint := TPointF.Create(X, Y);
|
|
Cursor := crHandPoint;
|
|
end;
|
|
end;
|
|
|
|
procedure TChart.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
|
begin
|
|
inherited;
|
|
if FIsPanning and (Button = TMouseButton.mbLeft) then
|
|
begin
|
|
FIsPanning := False;
|
|
Cursor := crDefault;
|
|
end;
|
|
end;
|
|
|
|
procedure TChart.MouseMove(Shift: TShiftState; X, Y: Single);
|
|
var
|
|
canvasRect: TRectF;
|
|
currentPoint, delta: TPointF;
|
|
dataPerPixelX, dataPerPixelY: Double;
|
|
dataShift: TPointD;
|
|
begin
|
|
inherited;
|
|
if not FIsPanning then
|
|
Exit;
|
|
|
|
canvasRect := Self.LocalRect;
|
|
canvasRect.Inflate(-FPadding, -FPadding);
|
|
|
|
if (canvasRect.Width < 1) or (canvasRect.Height < 1) or (FDataView.Width <= 0) or (FDataView.Height <= 0) then
|
|
Exit;
|
|
|
|
currentPoint := TPointF.Create(X, Y);
|
|
delta := TPointF.Create(currentPoint.X - FPanStartPoint.X, currentPoint.Y - FPanStartPoint.Y);
|
|
|
|
if (delta.X = 0) and (delta.Y = 0) then
|
|
Exit;
|
|
|
|
dataPerPixelX := FDataView.Width / canvasRect.Width;
|
|
dataPerPixelY := FDataView.Height / canvasRect.Height;
|
|
dataShift.X := delta.X * dataPerPixelX;
|
|
dataShift.Y := -delta.Y * dataPerPixelY;
|
|
|
|
FDataView.Offset(-dataShift.X, -dataShift.Y);
|
|
FPanStartPoint := currentPoint;
|
|
|
|
InvalidateYRange;
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TChart.MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean);
|
|
var
|
|
zoomFactor: Double;
|
|
canvasRect: TRectF;
|
|
mouseScreenPos: TPointF;
|
|
focalPoint: TPointD;
|
|
newWidth, newHeight: Double;
|
|
leftRatio, topRatio: Double;
|
|
begin
|
|
inherited;
|
|
if WheelDelta = 0 then
|
|
Exit;
|
|
|
|
canvasRect := Self.LocalRect;
|
|
canvasRect.Inflate(-FPadding, -FPadding);
|
|
if (canvasRect.Width < 1) or (canvasRect.Height < 1) or (FDataView.Width <= 0) then
|
|
Exit;
|
|
|
|
if WheelDelta > 0 then
|
|
zoomFactor := 1 / 1.25
|
|
else
|
|
zoomFactor := 1.25;
|
|
|
|
mouseScreenPos := Self.ScreenToLocal(Screen.MousePos);
|
|
if not PtInRect(canvasRect, mouseScreenPos) then
|
|
Exit;
|
|
|
|
leftRatio := (mouseScreenPos.X - canvasRect.Left) / canvasRect.Width;
|
|
focalPoint.X := FDataView.Left + FDataView.Width * leftRatio;
|
|
newWidth := FDataView.Width * zoomFactor;
|
|
FDataView.Left := focalPoint.X - newWidth * leftRatio;
|
|
FDataView.Right := FDataView.Left + newWidth;
|
|
|
|
case FZoomMode of
|
|
czmXY:
|
|
begin
|
|
if (FDataView.Height <= 0) then
|
|
Exit;
|
|
topRatio := (canvasRect.Bottom - mouseScreenPos.Y) / canvasRect.Height;
|
|
focalPoint.Y := FDataView.Top + FDataView.Height * topRatio;
|
|
newHeight := FDataView.Height * zoomFactor;
|
|
FDataView.Top := focalPoint.Y - newHeight * topRatio;
|
|
FDataView.Bottom := FDataView.Top + newHeight;
|
|
end;
|
|
czmXOnly:
|
|
begin
|
|
// The scaling is done, now we chain the auto-scaling for the Y-axis.
|
|
// We create a new future for the view and then call AutoScaleY.
|
|
if FYRange.Done.IsSet then
|
|
if FYRange.Value.A <= FYRange.Value.B then
|
|
begin
|
|
FDataView.Top := FYRange.Value.A;
|
|
FDataView.Bottom := FYRange.Value.B;
|
|
end;
|
|
InvalidateYRange;
|
|
Repaint;
|
|
Handled := True;
|
|
Exit; // Exit because AutoScaleY will trigger its own repaint.
|
|
end;
|
|
end;
|
|
|
|
// For czmXY, we update the view future directly.
|
|
Repaint;
|
|
Handled := True;
|
|
end;
|
|
|
|
procedure TChart.Paint;
|
|
var
|
|
canvasRect: TRectF;
|
|
series: TCollectionItem;
|
|
begin
|
|
inherited;
|
|
Canvas.Fill.Color := TAlphaColors.White;
|
|
Canvas.FillRect(LocalRect, 1);
|
|
|
|
if not FBoundsValid then
|
|
begin
|
|
RecalcDataBounds;
|
|
ResetView;
|
|
end;
|
|
|
|
if FSeries.Count = 0 then
|
|
Exit;
|
|
|
|
if (FDataView.Width <= 0) or (FDataView.Height <= 0) then
|
|
Exit;
|
|
|
|
canvasRect := Self.LocalRect;
|
|
canvasRect.Inflate(-FPadding, -FPadding);
|
|
if (canvasRect.Width < 1) or (canvasRect.Height < 1) then
|
|
Exit;
|
|
|
|
DrawGrid(Canvas, FDataView, canvasRect);
|
|
DrawAxes(Canvas, FDataView, canvasRect);
|
|
|
|
for series in FSeries do
|
|
begin
|
|
(series as TChartSeries).Draw(Canvas, FDataView, canvasRect);
|
|
end;
|
|
end;
|
|
|
|
procedure TChart.RecalcDataBounds;
|
|
var
|
|
series: TCollectionItem;
|
|
boundFutures: TList<TFuture<TRectD>>;
|
|
begin
|
|
boundFutures := TList<TFuture<TRectD>>.Create;
|
|
try
|
|
for series in FSeries do
|
|
boundFutures.Add((series as TChartSeries).GetBounds);
|
|
|
|
FDataBounds :=
|
|
TFuture
|
|
.FromArray<TRectD>(boundFutures.ToArray)
|
|
.Chain<TRectD>(
|
|
function(const Rects: TArray<TRectD>): TRectD
|
|
var
|
|
minPt, maxPt: TPointD;
|
|
begin
|
|
if Length(Rects) = 0 then
|
|
Exit(TRectD.Create(0, 0, 0, 0));
|
|
|
|
minPt := TPointD.Create(Infinity, Infinity);
|
|
maxPt := TPointD.Create(NegInfinity, NegInfinity);
|
|
|
|
for var rect in Rects do
|
|
begin
|
|
minPt.X := System.Math.Min(minPt.X, rect.Left);
|
|
minPt.Y := System.Math.Min(minPt.Y, rect.Top);
|
|
maxPt.X := System.Math.Max(maxPt.X, rect.Right);
|
|
maxPt.Y := System.Math.Max(maxPt.Y, rect.Bottom);
|
|
end;
|
|
|
|
if IsInfinite(minPt.X) then
|
|
Exit(TRectD.Create(0, 0, 0, 0));
|
|
|
|
if (minPt.X = maxPt.X) then
|
|
begin
|
|
maxPt.X := minPt.X + 1;
|
|
end;
|
|
if (minPt.Y = maxPt.Y) then
|
|
begin
|
|
maxPt.Y := minPt.Y + 1;
|
|
minPt.Y := minPt.Y - 1;
|
|
end;
|
|
Result := TRectD.Create(minPt.X, minPt.Y, maxPt.X, maxPt.Y);
|
|
end);
|
|
finally
|
|
boundFutures.Free;
|
|
end;
|
|
|
|
FBoundsValid := True;
|
|
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.InvalidateYRange;
|
|
var
|
|
Arr: TArray<TFuture<TRangeD>>;
|
|
begin
|
|
SetLength(Arr, FSeries.Count);
|
|
for var i := 0 to High(Arr) do
|
|
Arr[i] := (FSeries[i] as TChartSeries).GetYBoundsForXRange(TRangeD.Create(FDataView.Left, FDataView.Right));
|
|
|
|
var yBounds := TFuture.FromArray<TRangeD>(Arr);
|
|
|
|
FYRange :=
|
|
yBounds.Chain<TRangeD>(
|
|
function(const Ranges: TArray<TRangeD>): TRangeD
|
|
var
|
|
yRange: Double;
|
|
begin
|
|
Result.A := Infinity;
|
|
Result.B := NegInfinity;
|
|
for var range in Ranges do
|
|
if range.A <= range.B then
|
|
begin
|
|
Result.A := System.Math.Min(Result.A, range.A);
|
|
Result.B := System.Math.Max(Result.B, range.B);
|
|
end;
|
|
|
|
if IsInfinite(Result.A) then
|
|
begin
|
|
// No data in view, use previous view's Y-range or default
|
|
Result.A := 0;
|
|
Result.B := -1;
|
|
exit;
|
|
end;
|
|
|
|
yRange := Result.B - Result.A;
|
|
if yRange = 0 then
|
|
yRange := Abs(Result.A * 0.1);
|
|
|
|
Result.A := Result.A - yRange * 0.05;
|
|
Result.B := Result.B + yRange * 0.05;
|
|
end
|
|
);
|
|
end;
|
|
|
|
procedure TChart.SetSeries(const Value: TChartSeriesCollection);
|
|
begin
|
|
FSeries.Assign(Value);
|
|
InvalidateDataBounds;
|
|
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;
|
|
|
|
{ TTestChartForm }
|
|
|
|
procedure TTestChartForm.FormCreate(Sender: TObject);
|
|
var
|
|
askSeries, bidSeries: TChartLineSeries;
|
|
ohlc: TChartOhlcSeries;
|
|
askBidSeries: TFuture<TDataSeries<TAskBidItem>>;
|
|
askData, bidData: TFuture<TDataSeries<Double>>;
|
|
begin
|
|
FChart := TChart.Create(Self);
|
|
FChart.Parent := Self;
|
|
FChart.Align := TAlignLayout.Client;
|
|
|
|
askBidSeries :=
|
|
TFuture<TDataSeries<TAskBidItem>>.Construct(
|
|
function: TDataSeries<TAskBidItem>
|
|
var
|
|
askBidDataPointList: TArray<TDataPoint<TAskBidItem>>;
|
|
lastPrice: Double;
|
|
currentTime: TDateTime;
|
|
i: Integer;
|
|
const
|
|
cnt = 200000;
|
|
begin
|
|
SetLength(askBidDataPointList, cnt);
|
|
lastPrice := 100.0;
|
|
currentTime := Now;
|
|
for i := 0 to cnt - 1 do
|
|
begin
|
|
lastPrice := lastPrice + (Random - 0.495) * 0.1;
|
|
currentTime := currentTime + TTimeSpan.FromMilliseconds(500 + (Random(500) - 250));
|
|
askBidDataPointList[i] :=
|
|
TDataPoint<TAskBidItem>.Create(currentTime, TAskBidItem.Create(lastPrice, lastPrice * 0.9998));
|
|
end;
|
|
Result := TDataSeries<TAskBidItem>.CreateDataSeries(cnt, askBidDataPointList);
|
|
end
|
|
);
|
|
|
|
askData :=
|
|
askBidSeries.Chain<TDataSeries<Double>>(
|
|
function(const AskBid: TDataSeries<TAskBidItem>): TDataSeries<Double>
|
|
begin
|
|
Result := AskBid.Convert<Double>(function(const Val: TDataPoint<TAskBidItem>): Double begin Result := Val.Data.Ask end);
|
|
end
|
|
);
|
|
|
|
bidData :=
|
|
askBidSeries.Chain<TDataSeries<Double>>(
|
|
function(const AskBid: TDataSeries<TAskBidItem>): TDataSeries<Double>
|
|
begin
|
|
Result := AskBid.Convert<Double>(function(const Val: TDataPoint<TAskBidItem>): Double begin Result := Val.Data.Bid end);
|
|
end
|
|
);
|
|
|
|
askSeries := TChartLineSeries.Create(FChart.Series);
|
|
askSeries.DataSeries := askData;
|
|
askSeries.Color := TAlphaColors.Blue;
|
|
askSeries.Thickness := 1;
|
|
|
|
bidSeries := TChartLineSeries.Create(FChart.Series);
|
|
bidSeries.DataSeries := bidData;
|
|
bidSeries.Color := TAlphaColors.Red;
|
|
bidSeries.Thickness := 1;
|
|
|
|
ohlc := TChartOhlcSeries.Create(FChart.Series);
|
|
ohlc.DataSeries :=
|
|
askData.Chain<TDataSeries<TOhlcItem>>(
|
|
function(const Data: TDataSeries<Double>): TDataSeries<TOhlcItem> begin Result := Data.ToOhlc(TTimeSpan.FromMinutes(15)); end
|
|
);
|
|
ohlc.Color := TAlphaColors.Black;
|
|
ohlc.Thickness := 1;
|
|
end;
|
|
|
|
constructor TRangeD.Create(const AA, AB: Double);
|
|
begin
|
|
A := AA;
|
|
B := AB;
|
|
end;
|
|
|
|
end.
|