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

Chart Panning+Zooming

Browse Source
This commit is contained in:
Michael Schimmel
2025-07-12 16:58:34 +02:00
parent 4727db1a01
commit 1b0f93c633
3 changed files with 380 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files
AuraTrader/AuraTrader.dproj
+1 -1
View File
@@ -4,7 +4,7 @@
<ProjectVersion>20.3</ProjectVersion>
<FrameworkType>FMX</FrameworkType>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config>
<Config Condition="'$(Config)'==''">Release</Config>
<Platform Condition="'$(Platform)'==''">Win64</Platform>
<ProjectName Condition="'$(ProjectName)'==''">AuraTrader</ProjectName>
<TargetedPlatforms>3</TargetedPlatforms>
AuraTrader/MainForm.pas
+1 -1
View File
@@ -165,7 +165,7 @@ begin
var chart := TMycChart.Create(Self);
AlignControl( chart );
chart.Height := Layout.ChildrenRect.Width*9/16;
chart.Lookback.Value := 1000;
chart.Lookback.Value := 50000;
/////
AuraTrader/Myc.Fmx.Chart.pas
+378 -83
View File
@@ -14,6 +14,7 @@ uses
FMX.Types,
FMX.Controls,
FMX.Graphics,
FMX.Forms,
Myc.Trade.DataPoint,
Myc.Signals,
Myc.Lazy;
@@ -22,32 +23,41 @@ type
TCandleStyle = (csCandleStick, csHiLoBar);
TMycChart = class(TStyledControl)
type
TSeries = class abstract(TObject)
private
FOwner: TMycChart;
function GetMainSeries: TSeries;
protected
function GetCount: Int64; virtual; abstract;
function GetValueRange(StartIndex, Count: Int64; out Min, Max: Double): Boolean; virtual; abstract;
function Update: Boolean; virtual; abstract;
procedure Paint(const ACanvas: TCanvas; Lookback: Int64; const AXForm, AYForm: TFunc<Double, Single>); virtual; abstract;
public type
TSeries = class abstract(TObject)
private
FOwner: TMycChart;
function GetMainSeries: TSeries;
protected
function GetCount: Int64; virtual; abstract;
function GetValueRange(StartIndex, Count: Int64; out Min, Max: Double): Boolean; virtual; abstract;
function Update: Boolean; virtual; abstract;
// The signature is changed to support viewport painting
procedure Paint(const ACanvas: TCanvas; StartIndex, Count: Int64; const AXForm, AYForm: TFunc<Double, Single>); virtual; abstract;
property MainSeries: TSeries read GetMainSeries;
public
constructor Create(AOwner: TMycChart);
property Count: Int64 read GetCount;
property Owner: TMycChart read FOwner;
end;
property MainSeries: TSeries read GetMainSeries;
public
constructor Create(AOwner: TMycChart);
property Count: Int64 read GetCount;
property Owner: TMycChart read FOwner;
end;
private
FSeriesList: TList<TSeries>;
FLookback: TWriteable<Int64>;
FIdleSubscrId: TMessageSubscriptionId;
protected
private
FSeriesList: TList<TSeries>;
FLookback: TWriteable<Int64>;
FIdleSubscrId: TMessageSubscriptionId;
FViewStartIndex: Int64;
FViewCount: Int64;
FIsDragging: Boolean;
FDragStartPoint: TPointF;
FJumpButtonRect: TRectF;
FJumpButtonHot: Boolean;
FJumpButtonPressed: Boolean; protected
procedure Paint; override;
procedure DoIdle;
procedure MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); override;
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;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
@@ -120,8 +130,8 @@ type
FDownColor: TAlphaColor;
FStyle: TCandleStyle;
protected
function GetValueRange(StartIndex, Count: Int64; out Min, Max: Double): Boolean; override;
procedure Paint(const ACanvas: TCanvas; Lookback: Int64; const AXForm, AYForm: TFunc<Double, Single>); override;
function GetValueRange(StartIndex, Count: Int64; out MinValue, MaxValue: Double): Boolean; override;
procedure Paint(const ACanvas: TCanvas; StartIndex, Count: Int64; const AXForm, AYForm: TFunc<Double, Single>); override;
public
constructor Create(
AOwner: TMycChart;
@@ -137,8 +147,8 @@ type
FLineColor: TAlphaColor;
FLineWidth: Single;
protected
function GetValueRange(StartIndex, Count: Int64; out Min, Max: Double): Boolean; override;
procedure Paint(const ACanvas: TCanvas; Lookback: Int64; const AXForm, AYForm: TFunc<Double, Single>); override;
function GetValueRange(StartIndex, Count: Int64; out MinValue, MaxValue: Double): Boolean; override;
procedure Paint(const ACanvas: TCanvas; StartIndex, Count: Int64; const AXForm, AYForm: TFunc<Double, Single>); override;
public
constructor Create(
AOwner: TMycChart;
@@ -159,7 +169,7 @@ end;
function TMycChart.TSeries.GetMainSeries: TSeries;
begin
Result := nil;
if Owner.FSeriesList.Count > 0 then
if (Owner.FSeriesList.Count > 0) then
Result := Owner.FSeriesList[0];
end;
@@ -170,7 +180,10 @@ begin
inherited Create(AOwner);
FSeriesList := TObjectList<TSeries>.Create(true);
FLookback := TWriteable<Int64>.CreateWriteable( 100 );
FLookback := TWriteable<Int64>.CreateWriteable( 1000 ); // Load more data for panning
FViewStartIndex := 0;
FViewCount := 100; // Show 100 items by default
FIsDragging := false;
FIdleSubscrId :=
TMessageManager
@@ -212,13 +225,219 @@ begin
end;
procedure TMycChart.DoIdle;
var
doRepaint: Boolean;
mainSeries: TSeries;
isLiveView: Boolean;
prevCount, newCount, newCandles: Int64;
begin
var doRepaint := false;
if (FSeriesList.Count = 0) then
begin
exit;
end;
mainSeries := FSeriesList[0];
if (mainSeries = nil) then
begin
exit;
end;
// Remember state before update
isLiveView := (FViewStartIndex = 0);
prevCount := mainSeries.Count;
// Check all series for updates
doRepaint := false;
for var series in FSeriesList do
begin
if series.Update then
begin
doRepaint := true;
end;
end;
if doRepaint then
begin
newCount := mainSeries.Count;
newCandles := newCount - prevCount;
// Adjust viewport only if user was not watching the live data
if (not isLiveView) and (newCandles > 0) then
begin
FViewStartIndex := FViewStartIndex + newCandles;
end;
// If the view was live, it implicitly stays at StartIndex = 0, showing the new data.
Repaint;
end;
end;
procedure TMycChart.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
// Check for button press first
if (Button = TMouseButton.mbLeft) and (FViewStartIndex > 0) and FJumpButtonRect.Contains(PointF(X, Y)) then
begin
FJumpButtonPressed := true;
Repaint;
exit; // Prevent chart dragging
end;
inherited MouseDown(Button, Shift, X, Y);
if (Button = TMouseButton.mbLeft) then
begin
FIsDragging := true;
FDragStartPoint := TPointF.Create(X, Y);
end;
end;
procedure TMycChart.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
// Check if a button press was active
if FJumpButtonPressed then
begin
FJumpButtonPressed := false;
// If mouse is released over the button, trigger the action
if (FViewStartIndex > 0) and FJumpButtonRect.Contains(PointF(X, Y)) then
begin
FViewStartIndex := 0; // Jump to the latest candle
end;
Repaint;
exit;
end;
inherited MouseUp(Button, Shift, X, Y);
if (Button = TMouseButton.mbLeft) then
begin
FIsDragging := false;
end;
end;
procedure TMycChart.MouseMove(Shift: TShiftState; X, Y: Single);
var
isHot: Boolean;
dx: Single;
indexDelta: Int64;
mainSeries: TSeries;
maxIndex: Int64;
begin
// Update button hot state
if (FViewStartIndex > 0) then
begin
isHot := FJumpButtonRect.Contains(PointF(X, Y));
if (isHot <> FJumpButtonHot) then
begin
FJumpButtonHot := isHot;
Repaint;
end;
end
else
begin
// Ensure hot state is off when button is not visible
if FJumpButtonHot then
begin
FJumpButtonHot := false;
Repaint;
end;
end;
// Panning logic
inherited MouseMove(Shift, X, Y);
if FIsDragging then
begin
dx := X - FDragStartPoint.X;
if Abs(dx) < 2 then // Threshold to avoid jitter
begin
exit;
end;
if (FSeriesList.Count = 0) or (FViewCount <= 0) then
begin
exit;
end;
indexDelta := Round(dx / (Self.Width / FViewCount));
// To move content left (natural), view must shift to newer data (lower index).
// Drag left (dx < 0) -> FViewStartIndex must decrease.
// The formula for that is FViewStartIndex := FViewStartIndex + indexDelta; -> StartIndex + (negative) = decrease.
FViewStartIndex := FViewStartIndex + indexDelta;
// Clamp values
mainSeries := FSeriesList[0];
maxIndex := 0;
if (mainSeries <> nil) then
begin
maxIndex := mainSeries.Count - FViewCount;
end;
if (maxIndex < 0) then
begin
maxIndex := 0;
end;
if (FViewStartIndex < 0) then FViewStartIndex := 0;
if (FViewStartIndex > maxIndex) then FViewStartIndex := maxIndex;
FDragStartPoint := TPointF.Create(X, Y);
Repaint;
end;
end;
procedure TMycChart.MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean);
var
mousePos: TPointF;
anchorIndex: Double;
zoomFactor: Double;
newViewCount: Int64;
ratio: Double;
mainSeries: TSeries;
begin
Handled := true;
if (FSeriesList.Count = 0) then
begin
exit;
end;
mainSeries := FSeriesList[0];
if (mainSeries = nil) or (mainSeries.Count = 0) or (Self.Width <= 0) then
begin
exit;
end;
mousePos := Self.ScreenToLocal(Screen.MousePos);
// Correctly calculate the anchor index for a right-to-left axis
anchorIndex := FViewStartIndex + ((Self.Width - mousePos.X) / Self.Width) * FViewCount;
if (WheelDelta > 0) then
zoomFactor := 0.8 // Zoom In
else
zoomFactor := 1.25; // Zoom Out
newViewCount := Round(FViewCount * zoomFactor);
// Clamp zoom level
if (newViewCount < 10) then newViewCount := 10;
if (newViewCount > mainSeries.Count) then newViewCount := mainSeries.Count;
if (newViewCount = FViewCount) then exit;
// Adjust start index to keep anchor point stable
if (FViewCount > 0) then
ratio := (anchorIndex - FViewStartIndex) / FViewCount
else
ratio := 0;
FViewStartIndex := Round(anchorIndex - (ratio * newViewCount));
FViewCount := newViewCount;
// Clamp start index
if (FViewStartIndex < 0) then FViewStartIndex := 0;
if (FViewStartIndex + FViewCount > mainSeries.Count) then
begin
FViewStartIndex := mainSeries.Count - FViewCount;
end;
Repaint;
end;
procedure TMycChart.Paint;
@@ -229,12 +448,14 @@ var
rangeInitialized: Boolean;
xTransform: TFunc<Double, Single>;
yTransform: TFunc<Double, Single>;
isButtonVisible: Boolean;
buttonColor: TAlphaColor;
path: TPathData;
begin
inherited;
rect := Self.LocalRect;
var lookback := FLookback.Value;
if (FSeriesList.Count = 0) or (lookback <= 1) then
if (FSeriesList.Count = 0) or (FViewCount <= 1) then
begin
Canvas.Fill.Color := TAlphaColors.Gray;
Canvas.FillText(rect, 'No Data', false, 1, [], TTextAlign.Center, TTextAlign.Center);
@@ -243,9 +464,10 @@ begin
rangeInitialized := false;
// Determine value range for the visible viewport only
for series in FSeriesList do
begin
if series.GetValueRange(0, lookback, seriesMin, seriesMax) then
if series.GetValueRange(FViewStartIndex, FViewCount, seriesMin, seriesMax) then
begin
if not rangeInitialized then
begin
@@ -271,18 +493,75 @@ begin
if (globalMax - globalMin) = 0 then
exit;
xTransform := function(index: Double): Single begin Result := rect.Right - (index / (lookback - 1)) * rect.Width; end;
// Transform maps an index from the viewport to a screen coordinate
xTransform := function(index: Double): Single
begin
if (FViewCount <= 1) then
begin
Result := rect.Left + rect.Width / 2;
exit;
end;
Result := rect.Right - (((index - FViewStartIndex) / (FViewCount - 1)) * rect.Width);
end;
yTransform :=
function(value: Double): Single begin Result := rect.Top + (1 - (value - globalMin) / (globalMax - globalMin)) * rect.Height; end;
// var T :=
// TMatrix.CreateTranslation(rect.Left, rect.Top + rect.Height*globalMax / (globalMax - globalMin)) *
// TMatrix.CreateScaling(rect.Width / (FLookback - 1), -rect.Height / (globalMax - globalMin));
function(value: Double): Single
begin
Result := rect.Top + (1 - (value - globalMin) / (globalMax - globalMin)) * rect.Height;
end;
for series in FSeriesList do
begin
series.Paint(Self.Canvas, lookback, xTransform, yTransform);
series.Paint(Self.Canvas, FViewStartIndex, FViewCount, xTransform, yTransform);
end;
// --- Draw the "jump to latest" button ---
isButtonVisible := (FViewStartIndex > 0);
FJumpButtonHot := FJumpButtonHot and isButtonVisible;
if isButtonVisible then
begin
// Define button position and size
FJumpButtonRect := TRectF.Create(Self.Width - 44, Self.Height - 44, Self.Width - 10, Self.Height - 10);
// Determine color based on state
if FJumpButtonPressed then
buttonColor := $FF707070 // Pressed color
else if FJumpButtonHot then
buttonColor := $FF505050 // Hover color
else
buttonColor := $FF303030; // Default color
// Draw button background
Canvas.Fill.Color := buttonColor;
Canvas.FillRect(FJumpButtonRect, 4, 4, AllCorners, 0.7);
// Draw an icon (e.g., a "fast forward" double arrow)
Canvas.Stroke.Color := TAlphaColors.White;
Canvas.Stroke.Thickness := 1.5;
path := TPathData.Create;
try
var cx := FJumpButtonRect.CenterPoint.X;
var cy := FJumpButtonRect.CenterPoint.Y;
// First arrow
path.MoveTo(PointF(cx - 5, cy - 6));
path.LineTo(PointF(cx, cy));
path.LineTo(PointF(cx - 5, cy + 6));
// Second arrow
path.MoveTo(PointF(cx + 2, cy - 6));
path.LineTo(PointF(cx + 7, cy));
path.LineTo(PointF(cx + 2, cy + 6));
Canvas.DrawPath(path, 1);
finally
path.Free;
end;
end
else
begin
// Reset button state when not visible
FJumpButtonRect := TRectF.Empty;
FJumpButtonPressed := false;
end;
end;
@@ -330,43 +609,47 @@ begin
FStyle := AStyle;
end;
function TChartOhlcSeries.GetValueRange(StartIndex, Count: Int64; out Min, Max: Double): Boolean;
function TChartOhlcSeries.GetValueRange(StartIndex, Count: Int64; out MinValue, MaxValue: Double): Boolean;
var
i: Int64;
lastIndex: Int64;
begin
Result := GetCount > 0;
if not Result then
Exit;
Min := MaxDouble;
Max := -MaxDouble;
for i := StartIndex to System.Math.Min(GetCount - 1, StartIndex + Count - 1) do
MinValue := MaxDouble;
MaxValue := -MaxDouble;
lastIndex := Min(GetCount - 1, StartIndex + Count - 1);
for i := StartIndex to lastIndex do
begin
var dp := Data.Items[i];
Min := System.Math.Min(Min, dp.Data.Low);
Max := System.Math.Max(Max, dp.Data.High);
MinValue := Min(MinValue, dp.Data.Low);
MaxValue := Max(MaxValue, dp.Data.High);
end;
Result := (Min <> MaxDouble);
Result := (MinValue <> MaxDouble);
end;
procedure TChartOhlcSeries.Paint(const ACanvas: TCanvas; Lookback: Int64; const AXForm, AYForm: TFunc<Double, Single>);
procedure TChartOhlcSeries.Paint(const ACanvas: TCanvas; StartIndex, Count: Int64; const AXForm, AYForm: TFunc<Double, Single>);
var
i, displayCount: Int64;
i: Int64;
lastIndex: Int64;
x, candleWidth: Single;
yOpen, yHigh, yLow, yClose: Single;
item: TDataPoint<TOhlcItem>;
isUp: boolean;
begin
displayCount := System.Math.Min(Data.Count, Lookback);
if displayCount <= 0 then
if (Count <= 0) then
Exit;
if displayCount > 1 then
candleWidth := Max(2, 0.8 * Abs((AXForm(1) - AXForm(0))))
if (Count > 1) then
candleWidth := Max(2, 0.8 * Abs((AXForm(StartIndex + 1) - AXForm(StartIndex))))
else
candleWidth := 10;
for i := 0 to displayCount - 1 do
lastIndex := Min(Data.Count - 1, StartIndex + Count - 1);
for i := StartIndex to lastIndex do
begin
item := Data.Items[i];
x := AXForm(i);
@@ -384,7 +667,7 @@ begin
ACanvas.DrawLine(TPointF.Create(x, yHigh), TPointF.Create(x, yLow), 1);
if FStyle = csCandleStick then
if (FStyle = csCandleStick) then
begin
ACanvas.Fill.Color := ACanvas.Stroke.Color;
if isUp then
@@ -409,55 +692,67 @@ begin
FLineWidth := ALineWidth;
end;
function TChartLineSeries.GetValueRange(StartIndex, Count: Int64; out Min, Max: Double): Boolean;
function TChartLineSeries.GetValueRange(StartIndex, Count: Int64; out MinValue, MaxValue: Double): Boolean;
var
i: Int64;
lastIndex: Int64;
begin
Result := GetCount > 0;
if not Result then
Exit;
Min := MaxDouble;
Max := -MaxDouble;
for i := StartIndex to System.Math.Min(Data.Count - 1, StartIndex + Count - 1) do
MinValue := MaxDouble;
MaxValue := -MaxDouble;
lastIndex := Min(Data.Count - 1, StartIndex + Count - 1);
for i := StartIndex to lastIndex do
begin
var v := Data.Items[i];
if not IsNaN(v) then
begin
Min := System.Math.Min(Min, v);
Max := System.Math.Max(Max, v);
MinValue := Min(MinValue, v);
MaxValue := Max(MaxValue, v);
end;
end;
Result := (Min <> MaxDouble);
Result := (MinValue <> MaxDouble);
end;
procedure TChartLineSeries.Paint(const ACanvas: TCanvas; Lookback: Int64; const AXForm, AYForm: TFunc<Double, Single>);
procedure TChartLineSeries.Paint(const ACanvas: TCanvas; StartIndex, Count: Int64; const AXForm, AYForm: TFunc<Double, Single>);
var
points: TPathData;
i, n: Int64;
lastIndex: Int64;
begin
if not Assigned(MainSeries) or (Data.Count = 0) or (MainSeries.Count = 0) then
if (Data.Count = 0) or (Count < 2) then
Exit;
var points := TPathData.Create;
lastIndex := Min(Data.Count - 1, StartIndex + Count - 1);
points := TPathData.Create;
try
// Skip warmup data
n := StartIndex;
while (n <= lastIndex) and (IsNaN(Data[n])) do
begin
inc(n);
end;
var displayCount := System.Math.Min(Data.Count, Lookback);
if displayCount < 2 then
Exit;
// Skip warmup data
var n := 0;
while IsNaN(Data[n]) do
begin
inc(n);
if n >= displaycount - 2 then
if (n > lastIndex) then
exit;
points.MoveTo(TPointF.Create(AXForm(n), AYForm(Data[n])));
for i := n + 1 to lastIndex do
begin
if not IsNaN(Data[i]) then
begin
points.LineTo(TPointF.Create(AXForm(i), AYForm(Data[i])));
end;
end;
ACanvas.Stroke.Color := FLineColor;
ACanvas.Stroke.Thickness := FLineWidth;
ACanvas.DrawPath(points, 1);
finally
points.Free;
end;
points.MoveTo(TPointF.Create(AXForm(n), AYForm(Data[n])));
for var i := n to displayCount - 1 do
points.LineTo(TPointF.Create(AXForm(i), AYForm(Data[i])));
ACanvas.Stroke.Color := FLineColor;
ACanvas.Stroke.Thickness := FLineWidth;
ACanvas.DrawPath(points, 1);
end;
{ TChartSeriesReceiver<T> }