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 to a TChart. TChartSeriesAdapter = class abstract(TChartSeries) private FDataSeries: TDataSeries; protected procedure SetDataSeries(const Value: TDataSeries); 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): TPointD; virtual; abstract; public constructor Create(Collection: TCollection); override; property DataSeries: TDataSeries read FDataSeries write SetDataSeries; end; TDataSourceField = (dsfAsk, dsfBid); // Concrete series implementation for displaying TDataSeries. TChartAskBidSeries = class(TChartSeriesAdapter) private FDataSourceField: TDataSourceField; FCachedPoints: TArray; FCacheValid: Boolean; procedure SetDataSourceField(const Value: TDataSourceField); procedure EnsureCacheIsValid; protected procedure SetDataSeries(const Value: TDataSeries); override; function DataToPoint(const DataPoint: TDataPoint): 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 as candlesticks. TChartOhlcSeries = class(TChartSeriesAdapter) private FUpColor: TAlphaColor; FDownColor: TAlphaColor; protected // This function is not used for OHLC drawing but must be implemented. function DataToPoint(const DataPoint: TDataPoint): 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 } constructor TChartSeriesAdapter.Create(Collection: TCollection); begin inherited Create(Collection); FDataSeries := TDataSeries.Null; end; procedure TChartSeriesAdapter.SetDataSeries(const Value: TDataSeries); 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); begin inherited SetDataSeries(Value); FCacheValid := False; end; function TChartAskBidSeries.DataToPoint(const DataPoint: TDataPoint): 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): 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; 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; 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; askBidData: TDataSeries; ohlcDataPoints: array of TDataPoint; askBidDataPoints: array of TDataPoint; 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.CreateWriteable(NUM_POINTS); askBidData := TDataSeries.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.Create(startTime + i, ohlcItem); // Derive Ask/Bid data from OHLC close price askBidDataPoints[i] := TDataPoint.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.