mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-01 10:43:44 +02:00
832 lines
20 KiB
ObjectPascal
832 lines
20 KiB
ObjectPascal
{
|
|
/***************************************************************************
|
|
TAChartUtils.pas
|
|
----------------
|
|
Component Library Standard Graph Utiliity Functions
|
|
|
|
|
|
***************************************************************************/
|
|
|
|
*****************************************************************************
|
|
* *
|
|
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
|
|
* for details about the copyright. *
|
|
* *
|
|
* This program is distributed in the hope that it will be useful, *
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
*****************************************************************************
|
|
|
|
Authors: Luнs Rodrigues, Philippe Martinole, Alexander Klenin
|
|
|
|
}
|
|
|
|
unit TAChartUtils;
|
|
|
|
{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, Math, Types, SysUtils;
|
|
|
|
const
|
|
CHART_COMPONENT_IDE_PAGE = 'Chart';
|
|
PERCENT = 0.01;
|
|
clTAColor = $20000000; // = clDefault, but avoiding dependency on Graphics
|
|
|
|
type
|
|
EChartError = class(Exception);
|
|
EChartIntervalError = class(EChartError);
|
|
EListenerError = class(EChartError);
|
|
EDrawDataError = class(EChartError);
|
|
|
|
TDoublePoint = record
|
|
X, Y: Double;
|
|
end;
|
|
|
|
TDoubleRect = record
|
|
case Integer of
|
|
0: (
|
|
a, b: TDoublePoint;
|
|
);
|
|
1: (
|
|
coords: array [1..4] of Double;
|
|
);
|
|
end;
|
|
|
|
TPointArray = array of TPoint;
|
|
|
|
TChartDistance = 0..MaxInt;
|
|
|
|
TPointDistFunc = function (const A, B: TPoint): Integer;
|
|
|
|
TAxisScale = (asIncreasing, asDecreasing, asLogIncreasing, asLogDecreasing);
|
|
|
|
TSeriesMarksStyle = (
|
|
smsCustom, { user-defined }
|
|
smsNone, { no labels }
|
|
smsValue, { 1234 }
|
|
smsPercent, { 12 % }
|
|
smsLabel, { Cars }
|
|
smsLabelPercent, { Cars 12 % }
|
|
smsLabelValue, { Cars 1234 }
|
|
smsLegend, { ? }
|
|
smsPercentTotal, { 12 % of 1234 }
|
|
smsLabelPercentTotal, { Cars 12 % of 1234 }
|
|
smsXValue); { 21/6/1996 }
|
|
|
|
TDoubleInterval = record
|
|
FStart, FEnd: Double;
|
|
end;
|
|
|
|
{ TIntervalList }
|
|
|
|
TIntervalList = class
|
|
private
|
|
FEpsilon: Double;
|
|
FIntervals: array of TDoubleInterval;
|
|
FOnChange: TNotifyEvent;
|
|
procedure Changed;
|
|
function GetInterval(AIndex: Integer): TDoubleInterval;
|
|
function GetIntervalCount: Integer;
|
|
procedure SetEpsilon(AValue: Double);
|
|
procedure SetOnChange(AValue: TNotifyEvent);
|
|
public
|
|
procedure Assign(ASource: TIntervalList);
|
|
constructor Create;
|
|
public
|
|
procedure AddPoint(APoint: Double); inline;
|
|
procedure AddRange(AStart, AEnd: Double);
|
|
procedure Clear;
|
|
function Intersect(
|
|
var ALeft, ARight: Double; var AHint: Integer): Boolean;
|
|
public
|
|
property Epsilon: Double read FEpsilon write SetEpsilon;
|
|
property Interval[AIndex: Integer]: TDoubleInterval read GetInterval;
|
|
property IntervalCount: Integer read GetIntervalCount;
|
|
property OnChange: TNotifyEvent read FOnChange write SetOnChange;
|
|
end;
|
|
|
|
TCaseOfTwo = (cotNone, cotFirst, cotSecond, cotBoth);
|
|
|
|
{ TIndexedComponent }
|
|
|
|
TIndexedComponent = class(TComponent)
|
|
protected
|
|
function GetIndex: Integer; virtual; abstract;
|
|
procedure SetIndex(AValue: Integer); virtual; abstract;
|
|
public
|
|
procedure ChangeNamePrefix(const AOld, ANew: String; var AFailed: String);
|
|
|
|
property Index: Integer read GetIndex write SetIndex;
|
|
end;
|
|
|
|
TShowMessageProc = procedure (const AMsg: String);
|
|
|
|
{ TIndexedComponentList }
|
|
|
|
TIndexedComponentList = class(TFPList)
|
|
public
|
|
procedure ChangeNamePrefix(const AOld, ANew: String);
|
|
end;
|
|
|
|
TBroadcaster = class;
|
|
|
|
{ TListener }
|
|
|
|
TListener = class
|
|
private
|
|
FBroadcaster: TBroadcaster;
|
|
FOnNotify: TNotifyEvent;
|
|
FRef: PPointer;
|
|
function GetIsListening: Boolean;
|
|
public
|
|
constructor Create(ARef: PPointer; AOnNotify: TNotifyEvent);
|
|
destructor Destroy; override;
|
|
procedure Forget; virtual;
|
|
procedure Notify(ASender: TObject); virtual;
|
|
property IsListening: Boolean read GetIsListening;
|
|
end;
|
|
|
|
{ TBroadcaster }
|
|
|
|
TBroadcaster = class(TFPList)
|
|
private
|
|
FLocked: Boolean;
|
|
public
|
|
destructor Destroy; override;
|
|
public
|
|
procedure Broadcast(ASender: TObject);
|
|
procedure Subscribe(AListener: TListener);
|
|
procedure Unsubscribe(AListener: TListener);
|
|
public
|
|
property Locked: Boolean read FLocked write FLocked;
|
|
end;
|
|
|
|
{ TDrawDataItem }
|
|
|
|
TDrawDataItem = class
|
|
private
|
|
FChart: TObject;
|
|
FOwner: TObject;
|
|
public
|
|
constructor Create(AChart, AOwner: TObject);
|
|
property Chart: TObject read FChart;
|
|
property Owner: TObject read FOwner;
|
|
end;
|
|
|
|
TDrawDataItemClass = class of TDrawDataItem;
|
|
|
|
{ TDrawDataRegistry }
|
|
|
|
TDrawDataRegistry = class
|
|
private
|
|
// Probably should be replaced by more efficiend data structure.
|
|
FItems: TFPList;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
public
|
|
procedure Add(AItem: TDrawDataItem);
|
|
procedure DeleteByChart(AChart: TObject);
|
|
procedure DeleteByOwner(AOwner: TObject);
|
|
function Find(AChart, AOwner: TObject): TDrawDataItem;
|
|
end;
|
|
|
|
const
|
|
// 0-value, 1-percent, 2-label, 3-total, 4-xvalue
|
|
SERIES_MARK_FORMATS: array [TSeriesMarksStyle] of String = (
|
|
'', '',
|
|
'%0:.9g', // smsValue
|
|
'%1:.2f%%', // smsPercent
|
|
'%2:s', // smsLabel
|
|
'%2:s %1:.2f%%', // smsLabelPercent
|
|
'%2:s %0:.9g', // smsLabelValue
|
|
'%2:s', // smsLegend: not sure what it means, left for Delphi compatibility
|
|
'%1:.2f%% of %3:g', // smsPercentTotal
|
|
'%1:.2f%% of %3:g', // smsLabelPercentTotal
|
|
'%4:.9g' // smsXValue
|
|
);
|
|
ZeroDoublePoint: TDoublePoint = (X: 0; Y: 0);
|
|
EmptyDoubleRect: TDoubleRect = (coords: (0, 0, 0, 0));
|
|
EmptyExtent: TDoubleRect =
|
|
(coords: (Infinity, Infinity, NegInfinity, NegInfinity));
|
|
CASE_OF_TWO: array [Boolean, Boolean] of TCaseOfTwo =
|
|
((cotNone, cotSecond), (cotFirst, cotBoth));
|
|
|
|
function BoundsSize(ALeft, ATop: Integer; ASize: TSize): TRect; inline;
|
|
|
|
function DoubleInterval(AStart, AEnd: Double): TDoubleInterval; inline;
|
|
|
|
procedure EnsureOrder(var A, B: Integer); overload; inline;
|
|
procedure EnsureOrder(var A, B: Double); overload; inline;
|
|
|
|
procedure Exchange(var A, B: Integer); overload; inline;
|
|
procedure Exchange(var A, B: Double); overload; inline;
|
|
procedure Exchange(var A, B: TDoublePoint); overload; inline;
|
|
procedure Exchange(var A, B: String); overload; inline;
|
|
|
|
procedure ExpandRange(var ALo, AHi: Double; ACoeff: Double); inline;
|
|
|
|
function GetIntervals(AMin, AMax: Double; AInverted: Boolean): TDoubleDynArray;
|
|
|
|
function InterpolateRGB(AColor1, AColor2: Integer; ACoeff: Double): Integer;
|
|
|
|
function OrientToRad(AOrient: Integer): Double; inline;
|
|
|
|
function RadToDeg16(ARad: Double): Integer; inline;
|
|
function RadToOrient(ARad: Double): Integer; inline;
|
|
|
|
function RoundChecked(A: Double): Integer; inline;
|
|
|
|
function SafeInfinity: Double; inline;
|
|
function SafeInRange(AValue, ABound1, ABound2: Double): Boolean;
|
|
|
|
// Call this to silence 'parameter is unused' hint
|
|
procedure Unused(const A1);
|
|
procedure Unused(const A1, A2);
|
|
|
|
procedure UpdateMinMax(AValue: Double; var AMin, AMax: Double); overload;
|
|
procedure UpdateMinMax(AValue: Integer; var AMin, AMax: Integer); overload;
|
|
|
|
function WeightedAverage(AX1, AX2, ACoeff: Double): Double; inline;
|
|
|
|
operator =(const A, B: TMethod): Boolean; overload; inline;
|
|
|
|
var
|
|
DrawData: TDrawDataRegistry;
|
|
ShowMessageProc: TShowMessageProc;
|
|
|
|
resourcestring
|
|
tasFailedSubcomponentRename = 'Failed to rename components: %s';
|
|
|
|
implementation
|
|
|
|
uses
|
|
StrUtils;
|
|
|
|
const
|
|
ORIENTATION_UNITS_PER_DEG = 10;
|
|
|
|
function BoundsSize(ALeft, ATop: Integer; ASize: TSize): TRect; inline;
|
|
begin
|
|
Result := Bounds(ALeft, ATop, ASize.cx, ASize.cy);
|
|
end;
|
|
|
|
procedure CalculateIntervals(
|
|
AMin, AMax: Double; AxisScale: TAxisScale; out AStart, AStep: Double);
|
|
var
|
|
extent, extentTmp, stepCount, scale, maxStepCount, m: Double;
|
|
i: Integer;
|
|
const
|
|
GOOD_STEPS: array [1..3] of Double = (0.2, 0.5, 1.0);
|
|
BASE = 10;
|
|
begin
|
|
extent := AMax - AMin;
|
|
AStep := 1;
|
|
AStart := AMin;
|
|
if extent <= 0 then exit;
|
|
|
|
maxStepCount := 0;
|
|
scale := 1.0;
|
|
for i := Low(GOOD_STEPS) to High(GOOD_STEPS) do begin
|
|
extentTmp := extent / GOOD_STEPS[i];
|
|
m := IntPower(BASE, Round(logn(BASE, extentTmp)));
|
|
while extentTmp * m > BASE do
|
|
m /= BASE;
|
|
while extentTmp * m <= 1 do
|
|
m *= BASE;
|
|
stepCount := extentTmp * m;
|
|
if stepCount > maxStepCount then begin
|
|
maxStepCount := stepCount;
|
|
scale := m;
|
|
AStep := GOOD_STEPS[i] / m;
|
|
end;
|
|
end;
|
|
case AxisScale of
|
|
asIncreasing: begin
|
|
// If 0 is in the interval, set it as a mark.
|
|
if InRange(0, AMin, AMax) then
|
|
AStart := 0
|
|
else
|
|
AStart := Round((AMin - AStep) * scale) / scale;
|
|
while AStart > AMin do AStart -= AStep;
|
|
end;
|
|
asDecreasing: begin
|
|
// If 0 is in the interval, set it as a mark.
|
|
if InRange(0, AMin, AMax) then
|
|
AStart := 0
|
|
else
|
|
AStart := Round((AMax + AStep) * scale) / scale;
|
|
while AStart < AMax do AStart += AStep;
|
|
end;
|
|
asLogIncreasing: begin
|
|
// FIXME: asLogIncreasing is still not implemented.
|
|
// The following is the same code for asIncreasing;
|
|
// If 0 is in the interval, set it as a mark.
|
|
if InRange(0, AMin, AMax) then
|
|
AStart := 0
|
|
else
|
|
AStart := Round((AMin - AStep) * scale) / scale;
|
|
while AStart > AMin do AStart -= AStep;
|
|
end;
|
|
asLogDecreasing: begin
|
|
// FIXME: asLogDecreasing is still not implemented.
|
|
// The following is the same code for asIncreasing;
|
|
// If 0 is in the interval, set it as a mark.
|
|
if InRange(0, AMin, AMax) then
|
|
AStart := 0
|
|
else
|
|
AStart := Round((AMax + AStep) * scale) / scale;
|
|
while AStart < AMax do AStart += AStep;
|
|
end;
|
|
end; {case AxisScale}
|
|
end;
|
|
|
|
function DoubleInterval(AStart, AEnd: Double): TDoubleInterval;
|
|
begin
|
|
Result.FStart := AStart;
|
|
Result.FEnd := AEnd;
|
|
end;
|
|
|
|
procedure EnsureOrder(var A, B: Integer); overload; inline;
|
|
begin
|
|
if A > B then
|
|
Exchange(A, B);
|
|
end;
|
|
|
|
procedure EnsureOrder(var A, B: Double); overload; inline;
|
|
begin
|
|
if A > B then
|
|
Exchange(A, B);
|
|
end;
|
|
|
|
procedure Exchange(var A, B: Integer);
|
|
var
|
|
t: Integer;
|
|
begin
|
|
t := A;
|
|
A := B;
|
|
B := t;
|
|
end;
|
|
|
|
procedure Exchange(var A, B: Double);
|
|
var
|
|
t: Double;
|
|
begin
|
|
t := A;
|
|
A := B;
|
|
B := t;
|
|
end;
|
|
|
|
procedure Exchange(var A, B: TDoublePoint);
|
|
var
|
|
t: TDoublePoint;
|
|
begin
|
|
t := A;
|
|
A := B;
|
|
B := t;
|
|
end;
|
|
|
|
procedure Exchange(var A, B: String);
|
|
var
|
|
t: String;
|
|
begin
|
|
t := A;
|
|
A := B;
|
|
B := t;
|
|
end;
|
|
|
|
procedure ExpandRange(var ALo, AHi: Double; ACoeff: Double);
|
|
var
|
|
d: Double;
|
|
begin
|
|
d := AHi - ALo;
|
|
ALo -= d * ACoeff;
|
|
AHi += d * ACoeff;
|
|
end;
|
|
|
|
function GetIntervals(AMin, AMax: Double; AInverted: Boolean): TDoubleDynArray;
|
|
const
|
|
INV_TO_SCALE: array [Boolean] of TAxisScale = (asIncreasing, asDecreasing);
|
|
K = 1e-10;
|
|
var
|
|
start, step, m, m1: Double;
|
|
markCount: Integer;
|
|
begin
|
|
CalculateIntervals(AMin, AMax, INV_TO_SCALE[AInverted], start, step);
|
|
AMin -= step * K;
|
|
AMax += step * K;
|
|
if AInverted then
|
|
step := - step;
|
|
m := start;
|
|
markCount := 0;
|
|
while true do begin
|
|
if InRange(m, AMin, AMax) then
|
|
Inc(markCount)
|
|
else if markCount > 0 then
|
|
break;
|
|
m1 := m + step;
|
|
if m1 = m then break;
|
|
m := m1;
|
|
end;
|
|
SetLength(Result, markCount);
|
|
m := start;
|
|
markCount := 0;
|
|
while true do begin
|
|
if Abs(m / step) < K then
|
|
m := 0;
|
|
if InRange(m, AMin, AMax) then begin
|
|
Result[markCount] := m;
|
|
Inc(markCount);
|
|
end
|
|
else if markCount > 0 then
|
|
break;
|
|
m1 := m + step;
|
|
if m1 = m then break;
|
|
m := m1;
|
|
end;
|
|
end;
|
|
|
|
function InterpolateRGB(AColor1, AColor2: Integer; ACoeff: Double): Integer;
|
|
type
|
|
TBytes = packed array [1..4] of Byte;
|
|
var
|
|
c1: TBytes absolute AColor1;
|
|
c2: TBytes absolute AColor2;
|
|
r: TBytes absolute Result;
|
|
i: Integer;
|
|
begin
|
|
ACoeff := EnsureRange(ACoeff, 0.0, 1.0);
|
|
for i := 1 to 4 do
|
|
r[i] := Round(c1[i] + (c2[i] - c1[i]) * ACoeff);
|
|
end;
|
|
|
|
function OrientToRad(AOrient: Integer): Double;
|
|
begin
|
|
Result := DegToRad(AOrient / ORIENTATION_UNITS_PER_DEG);
|
|
end;
|
|
|
|
function RadToDeg16(ARad: Double): Integer;
|
|
begin
|
|
Result := Round(RadToDeg(ARad) * 16);
|
|
end;
|
|
|
|
function RadToOrient(ARad: Double): Integer;
|
|
begin
|
|
Result := Round(RadToDeg(ARad)) * ORIENTATION_UNITS_PER_DEG;
|
|
end;
|
|
|
|
function RoundChecked(A: Double): Integer;
|
|
begin
|
|
Result := Round(EnsureRange(A, -MaxInt, MaxInt));
|
|
end;
|
|
|
|
function SafeInfinity: Double;
|
|
begin
|
|
{$IFOPT R+}{$DEFINE RangeChecking}{$ELSE}{$UNDEF RangeChecking}{$ENDIF}
|
|
{$IFOPT Q+}{$DEFINE OverflowChecking}{$ELSE}{$UNDEF OverflowChecking}{$ENDIF}
|
|
{$R-}{$Q-}
|
|
Result := Infinity;
|
|
{$IFDEF OverflowChecking}{$Q+}{$ENDIF}{$IFDEF RangeChecking}{$R+}{$ENDIF}
|
|
end;
|
|
|
|
function SafeInRange(AValue, ABound1, ABound2: Double): Boolean;
|
|
begin
|
|
EnsureOrder(ABound1, ABound2);
|
|
Result := InRange(AValue, ABound1, ABound2);
|
|
end;
|
|
|
|
{$HINTS OFF}
|
|
procedure Unused(const A1);
|
|
begin
|
|
end;
|
|
|
|
procedure Unused(const A1, A2);
|
|
begin
|
|
end;
|
|
{$HINTS ON}
|
|
|
|
procedure UpdateMinMax(AValue: Double; var AMin, AMax: Double);
|
|
begin
|
|
if AValue < AMin then
|
|
AMin := AValue;
|
|
if AValue > AMax then
|
|
AMax := AValue;
|
|
end;
|
|
|
|
procedure UpdateMinMax(AValue: Integer; var AMin, AMax: Integer);
|
|
begin
|
|
if AValue < AMin then
|
|
AMin := AValue;
|
|
if AValue > AMax then
|
|
AMax := AValue;
|
|
end;
|
|
|
|
function WeightedAverage(AX1, AX2, ACoeff: Double): Double;
|
|
begin
|
|
Result := AX1 * (1 - ACoeff) + AX2 * ACoeff;
|
|
end;
|
|
|
|
operator = (const A, B: TMethod): Boolean;
|
|
begin
|
|
Result := (A.Code = B.Code) and (A.Data = B.Data);
|
|
end;
|
|
|
|
{ TIndexedComponentList }
|
|
|
|
procedure TIndexedComponentList.ChangeNamePrefix(
|
|
const AOld, ANew: String);
|
|
var
|
|
failed: String;
|
|
i: Integer;
|
|
begin
|
|
failed := '';
|
|
for i := 0 to Count - 1 do
|
|
TIndexedComponent(Items[i]).ChangeNamePrefix(AOld, ANew, failed);
|
|
if (failed <> '') and Assigned(ShowMessageProc) then
|
|
ShowMessageProc(Format(tasFailedSubcomponentRename, [failed]));
|
|
end;
|
|
|
|
{ TIndexedComponent }
|
|
|
|
procedure TIndexedComponent.ChangeNamePrefix(
|
|
const AOld, ANew: String; var AFailed: String);
|
|
begin
|
|
if AnsiStartsStr(AOld, Name) then
|
|
try
|
|
Name := ANew + Copy(Name, Length(AOld) + 1, Length(Name));
|
|
except on EComponentError do
|
|
AFailed += IfThen(AFailed = '', '', ', ') + Name;
|
|
end;
|
|
end;
|
|
|
|
{ TIntervalList }
|
|
|
|
procedure TIntervalList.AddPoint(APoint: Double); inline;
|
|
begin
|
|
AddRange(APoint, APoint);
|
|
end;
|
|
|
|
procedure TIntervalList.AddRange(AStart, AEnd: Double);
|
|
var
|
|
i: Integer;
|
|
j: Integer;
|
|
k: Integer;
|
|
begin
|
|
i := 0;
|
|
while (i <= High(FIntervals)) and (FIntervals[i].FEnd < AStart) do
|
|
Inc(i);
|
|
if i <= High(FIntervals) then
|
|
AStart := Min(AStart, FIntervals[i].FStart);
|
|
j := High(FIntervals);
|
|
while (j >= 0) and (FIntervals[j].FStart > AEnd) do
|
|
Dec(j);
|
|
if j >= 0 then
|
|
AEnd := Max(AEnd, FIntervals[j].FEnd);
|
|
if i < j then begin
|
|
for k := j + 1 to High(FIntervals) do
|
|
FIntervals[i + k - j] := FIntervals[j];
|
|
SetLength(FIntervals, Length(FIntervals) - j + i);
|
|
end
|
|
else if i > j then begin
|
|
SetLength(FIntervals, Length(FIntervals) + 1);
|
|
for k := High(FIntervals) downto i do
|
|
FIntervals[k] := FIntervals[k - 1];
|
|
end;
|
|
FIntervals[i] := DoubleInterval(AStart, AEnd);
|
|
Changed;
|
|
end;
|
|
|
|
procedure TIntervalList.Assign(ASource: TIntervalList);
|
|
begin
|
|
FEpsilon := ASource.FEpsilon;
|
|
FIntervals := Copy(ASource.FIntervals);
|
|
end;
|
|
|
|
procedure TIntervalList.Changed;
|
|
begin
|
|
if Assigned(FOnChange) then
|
|
FOnChange(Self);
|
|
end;
|
|
|
|
procedure TIntervalList.Clear;
|
|
begin
|
|
FIntervals := nil;
|
|
Changed;
|
|
end;
|
|
|
|
constructor TIntervalList.Create;
|
|
const
|
|
DEFAULT_EPSILON = 1e-6;
|
|
begin
|
|
FEpsilon := DEFAULT_EPSILON;
|
|
end;
|
|
|
|
function TIntervalList.GetInterval(AIndex: Integer): TDoubleInterval;
|
|
begin
|
|
Result := FIntervals[AIndex];
|
|
end;
|
|
|
|
function TIntervalList.GetIntervalCount: Integer;
|
|
begin
|
|
Result := Length(FIntervals);
|
|
end;
|
|
|
|
function TIntervalList.Intersect(
|
|
var ALeft, ARight: Double; var AHint: Integer): Boolean;
|
|
var
|
|
fi, li: Integer;
|
|
begin
|
|
Result := false;
|
|
if Length(FIntervals) = 0 then exit;
|
|
|
|
AHint := Min(High(FIntervals), AHint);
|
|
while (AHint > 0) and (FIntervals[AHint].FStart > ARight) do
|
|
Dec(AHint);
|
|
|
|
while
|
|
(AHint <= High(FIntervals)) and (FIntervals[AHint].FStart <= ARight)
|
|
do begin
|
|
if FIntervals[AHint].FEnd >= ALeft then begin
|
|
if not Result then fi := AHint;
|
|
li := AHint;
|
|
Result := true;
|
|
end;
|
|
Inc(AHint);
|
|
end;
|
|
|
|
if Result then begin
|
|
ALeft := FIntervals[fi].FStart - Epsilon;
|
|
ARight := FIntervals[li].FEnd + Epsilon;
|
|
end;
|
|
end;
|
|
|
|
procedure TIntervalList.SetEpsilon(AValue: Double);
|
|
begin
|
|
if FEpsilon = AValue then exit;
|
|
if AValue <= 0 then
|
|
raise EChartIntervalError.Create('Epsilon <= 0');
|
|
FEpsilon := AValue;
|
|
Changed;
|
|
end;
|
|
|
|
procedure TIntervalList.SetOnChange(AValue: TNotifyEvent);
|
|
begin
|
|
if TMethod(FOnChange) = TMethod(AValue) then exit;
|
|
FOnChange := AValue;
|
|
end;
|
|
|
|
{ TListener }
|
|
|
|
constructor TListener.Create(ARef: PPointer; AOnNotify: TNotifyEvent);
|
|
begin
|
|
FOnNotify := AOnNotify;
|
|
FRef := ARef;
|
|
end;
|
|
|
|
destructor TListener.Destroy;
|
|
begin
|
|
if IsListening then
|
|
FBroadcaster.Unsubscribe(Self);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TListener.Forget;
|
|
begin
|
|
FBroadcaster := nil;
|
|
FRef^ := nil;
|
|
end;
|
|
|
|
function TListener.GetIsListening: Boolean;
|
|
begin
|
|
Result := FBroadcaster <> nil;
|
|
end;
|
|
|
|
procedure TListener.Notify(ASender: TObject);
|
|
begin
|
|
FOnNotify(ASender)
|
|
end;
|
|
|
|
{ TBroadcaster }
|
|
|
|
procedure TBroadcaster.Broadcast(ASender: TObject);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if Locked then exit;
|
|
for i := 0 to Count - 1 do
|
|
TListener(Items[i]).Notify(ASender);
|
|
end;
|
|
|
|
destructor TBroadcaster.Destroy;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to Count - 1 do
|
|
TListener(Items[i]).Forget;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TBroadcaster.Subscribe(AListener: TListener);
|
|
begin
|
|
if AListener.IsListening then
|
|
raise EListenerError.Create('Listener subscribed twice');
|
|
if IndexOf(AListener) >= 0 then
|
|
raise EListenerError.Create('Duplicate listener');
|
|
AListener.FBroadcaster := Self;
|
|
Add(AListener);
|
|
end;
|
|
|
|
procedure TBroadcaster.Unsubscribe(AListener: TListener);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if not AListener.IsListening then
|
|
raise EListenerError.Create('Listener not subscribed');
|
|
AListener.Forget;
|
|
i := IndexOf(AListener);
|
|
if i < 0 then
|
|
raise EListenerError.Create('Listener not found');
|
|
Delete(i);
|
|
end;
|
|
|
|
{ TDrawDataItem }
|
|
|
|
constructor TDrawDataItem.Create(AChart, AOwner: TObject);
|
|
begin
|
|
FChart := AChart;
|
|
FOwner := AOwner;
|
|
end;
|
|
|
|
{ TDrawDataRegistry }
|
|
|
|
procedure TDrawDataRegistry.Add(AItem: TDrawDataItem);
|
|
begin
|
|
if Find(AItem.Chart, AItem.Owner) <> nil then
|
|
raise EDrawDataError.Create('Duplicate DrawData');
|
|
FItems.Add(AItem);
|
|
end;
|
|
|
|
constructor TDrawDataRegistry.Create;
|
|
begin
|
|
FItems := TFPList.Create;
|
|
end;
|
|
|
|
procedure TDrawDataRegistry.DeleteByChart(AChart: TObject);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FItems.Count - 1 do
|
|
with TDrawDataItem(FItems[i]) do
|
|
if Chart = AChart then begin
|
|
Free;
|
|
FItems[i] := nil;
|
|
end;
|
|
FItems.Pack;
|
|
end;
|
|
|
|
procedure TDrawDataRegistry.DeleteByOwner(AOwner: TObject);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FItems.Count - 1 do
|
|
with TDrawDataItem(FItems[i]) do
|
|
if Owner = AOwner then begin
|
|
Free;
|
|
FItems[i] := nil;
|
|
end;
|
|
FItems.Pack;
|
|
end;
|
|
|
|
destructor TDrawDataRegistry.Destroy;
|
|
begin
|
|
if FItems.Count > 0 then
|
|
raise EDrawDataError.Create('DrawData leak');
|
|
FreeAndNil(FItems);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TDrawDataRegistry.Find(AChart, AOwner: TObject): TDrawDataItem;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FItems.Count - 1 do begin
|
|
Result := TDrawDataItem(FItems[i]);
|
|
if (Result.Chart = AChart) and (Result.Owner = AOwner) then exit;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
initialization
|
|
|
|
DrawData := TDrawDataRegistry.Create;
|
|
|
|
finalization
|
|
|
|
FreeAndNil(DrawData);
|
|
|
|
end.
|