lazarus/components/tachart/tacustomsource.pas
2012-01-20 11:37:38 +00:00

881 lines
22 KiB
ObjectPascal

{
*****************************************************************************
* *
* 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: Alexander Klenin
}
unit TACustomSource;
{$mode objfpc}{$H+}
interface
uses
Classes, Types, TAChartUtils;
type
TAxisIntervalParamOption = (
aipGraphCoords,
aipUseCount, aipUseMaxLength, aipUseMinLength, aipUseNiceSteps);
const
DEF_INTERVAL_STEPS = '0.2|0.5|1.0';
DEF_INTERVAL_OPTIONS = [aipUseMaxLength, aipUseMinLength, aipUseNiceSteps];
type
TAxisIntervalParamOptions = set of TAxisIntervalParamOption;
TChartAxisIntervalParams = class(TPersistent)
strict private
FCount: Integer;
FMaxLength: Integer;
FMinLength: Integer;
FNiceSteps: String;
FOptions: TAxisIntervalParamOptions;
FOwner: TPersistent;
FStepValues: TDoubleDynArray;
FTolerance: Cardinal;
function NiceStepsIsStored: Boolean;
procedure ParseNiceSteps;
procedure SetCount(AValue: Integer);
procedure SetMaxLength(AValue: Integer);
procedure SetMinLength(AValue: Integer);
procedure SetNiceSteps(const AValue: String);
procedure SetOptions(AValue: TAxisIntervalParamOptions);
procedure SetTolerance(AValue: Cardinal);
strict protected
procedure Changed; virtual;
protected
function GetOwner: TPersistent; override;
public
procedure Assign(ASource: TPersistent); override;
constructor Create(AOwner: TPersistent);
property StepValues: TDoubleDynArray read FStepValues;
published
property Count: Integer read FCount write SetCount default 5;
property MaxLength: Integer read FMaxLength write SetMaxLength default 50;
property MinLength: Integer read FMinLength write SetMinLength default 10;
property NiceSteps: String
read FNiceSteps write SetNiceSteps stored NiceStepsIsStored;
property Options: TAxisIntervalParamOptions
read FOptions write SetOptions default DEF_INTERVAL_OPTIONS;
property Tolerance: Cardinal read FTolerance write SetTolerance default 0;
end;
type
EBufferError = class(EChartError);
EEditableSourceRequired = class(EChartError);
EYCountError = class(EChartError);
TChartValueText = record
FText: String;
FValue: Double;
end;
PChartValueText = ^TChartValueText;
TChartValueTextArray = array of TChartValueText;
{ TChartDataItem }
TChartDataItem = object
X, Y: Double;
Color: TChartColor;
Text: String;
YList: TDoubleDynArray;
function GetY(AIndex: Integer): Double;
procedure SetY(AValue: Double);
procedure MultiplyY(ACoeff: Double);
function Point: TDoublePoint; inline;
end;
PChartDataItem = ^TChartDataItem;
TGraphToImageFunc = function (AX: Double): Integer of object;
TIntegerTransformFunc = function (AX: Integer): Integer of object;
TValuesInRangeParams = object
FAxisToGraph: TTransformFunc;
FFormat: String;
FGraphToAxis: TTransformFunc;
FGraphToImage: TGraphToImageFunc;
FIntervals: TChartAxisIntervalParams;
FMin, FMax: Double;
FMinStep: Double;
FScale: TIntegerTransformFunc;
FUseY: Boolean;
function CountToStep(ACount: Integer): Double; inline;
function IsAcceptableStep(AStep: Integer): Boolean; inline;
function ToImage(AX: Double): Integer; inline;
end;
TCustomChartSource = class;
TCustomChartSourceEnumerator = class
strict private
FSource: TCustomChartSource;
FIndex: Integer;
public
constructor Create(ASource: TCustomChartSource);
function GetCurrent: PChartDataItem;
function MoveNext: Boolean;
procedure Reset;
property Current: PChartDataItem read GetCurrent;
end;
TCustomChartSource = class(TComponent)
strict private
FBroadcaster: TBroadcaster;
FUpdateCount: Integer;
procedure SortValuesInRange(
var AValues: TChartValueTextArray; AStart, AEnd: Integer);
strict protected
FExtent: TDoubleRect;
FExtentIsValid: Boolean;
FValuesTotal: Double;
FValuesTotalIsValid: Boolean;
FYCount: Cardinal;
function GetCount: Integer; virtual; abstract;
function GetItem(AIndex: Integer): PChartDataItem; virtual; abstract;
procedure InvalidateCaches;
procedure Notify;
procedure SetYCount(AValue: Cardinal); virtual; abstract;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
public
procedure AfterDraw; virtual;
procedure BeforeDraw; virtual;
procedure BeginUpdate;
procedure EndUpdate; virtual;
function IsUpdating: Boolean; inline;
public
class procedure CheckFormat(const AFormat: String);
function Extent: TDoubleRect;
function ExtentCumulative: TDoubleRect;
function ExtentList: TDoubleRect;
procedure FindBounds(AXMin, AXMax: Double; out ALB, AUB: Integer);
function FormatItem(
const AFormat: String; AIndex, AYIndex: Integer): String;
function GetEnumerator: TCustomChartSourceEnumerator;
function IsSorted: Boolean; virtual;
procedure ValuesInRange(
AParams: TValuesInRangeParams; var AValues: TChartValueTextArray); virtual;
function ValuesTotal: Double; virtual;
function XOfMax: Double;
function XOfMin: Double;
property Broadcaster: TBroadcaster read FBroadcaster;
property Count: Integer read GetCount;
property Item[AIndex: Integer]: PChartDataItem read GetItem; default;
property YCount: Cardinal read FYCount write SetYCount default 1;
end;
{ TChartSourceBuffer }
TChartSourceBuffer = class
strict private
FBuf: array of TChartDataItem;
FCount: Cardinal;
FStart: Cardinal;
FSum: TChartDataItem;
procedure AddValue(const AItem: TChartDataItem);
function EndIndex: Cardinal; inline;
function GetCapacity: Cardinal; inline;
procedure SetCapacity(AValue: Cardinal); inline;
public
procedure AddFirst(const AItem: TChartDataItem);
procedure AddLast(const AItem: TChartDataItem);
procedure Clear; inline;
function GetPtr(AOffset: Cardinal): PChartDataItem; overload;
procedure GetSum(var AItem: TChartDataItem);
procedure RemoveFirst;
procedure RemoveLast;
procedure RemoveValue(const AItem: TChartDataItem);
property Capacity: Cardinal read GetCapacity write SetCapacity;
end;
procedure SetDataItemDefaults(var AItem: TChartDataItem);
implementation
uses
Math, StrUtils, SysUtils, TAMath;
function CompareChartValueTextPtr(AItem1, AItem2: Pointer): Integer;
begin
Result := CompareValue(
PChartValueText(AItem1)^.FValue,
PChartValueText(AItem2)^.FValue);
end;
function IsValueTextsSorted(
const AValues: TChartValueTextArray; AStart, AEnd: Integer): Boolean;
var
i: Integer;
begin
for i := AStart to AEnd - 1 do
if AValues[i].FValue > AValues[i + 1].FValue then exit(false);
Result := true;
end;
procedure SetDataItemDefaults(var AItem: TChartDataItem);
var
i: Integer;
begin
AItem.X := 0;
AItem.Y := 0;
AItem.Color := clTAColor;
AItem.Text := '';
for i := 0 to High(AItem.YList) do
AItem.YList[i] := 0;
end;
{ TValuesInRangeParams }
function TValuesInRangeParams.CountToStep(ACount: Integer): Double;
begin
Result := Power(10, Floor(Log10((FMax - FMin) / ACount)));
end;
function TValuesInRangeParams.IsAcceptableStep(AStep: Integer): Boolean;
begin
with FIntervals do
Result := not (
(aipUseMinLength in Options) and (AStep < FScale(MinLength)) or
(aipUseMaxLength in Options) and (AStep > FScale(MaxLength)));
end;
function TValuesInRangeParams.ToImage(AX: Double): Integer;
begin
if not (aipGraphCoords in FIntervals.Options) then
AX := FAxisToGraph(AX);
Result := FGraphToImage(AX);
end;
{ TChartAxisIntervalParams }
procedure TChartAxisIntervalParams.Assign(ASource: TPersistent);
begin
if ASource is TChartAxisIntervalParams then
with TChartAxisIntervalParams(ASource) do begin
Self.FCount := Count;
Self.FMaxLength := MaxLength;
Self.FMinLength := MinLength;
Self.FNiceSteps := NiceSteps;
Self.FOptions := Options;
end
else
inherited Assign(ASource);
end;
procedure TChartAxisIntervalParams.Changed;
begin
if not (FOwner is TCustomChartSource) then exit;
with FOwner as TCustomChartSource do begin
BeginUpdate;
EndUpdate;
end;
end;
constructor TChartAxisIntervalParams.Create(AOwner: TPersistent);
begin
FOwner := AOwner;
SetPropDefaults(Self, ['Count', 'MaxLength', 'MinLength', 'Options']);
FNiceSteps := DEF_INTERVAL_STEPS;
ParseNiceSteps;
end;
function TChartAxisIntervalParams.GetOwner: TPersistent;
begin
Result := FOwner;
end;
function TChartAxisIntervalParams.NiceStepsIsStored: Boolean;
begin
Result := NiceSteps <> DEF_INTERVAL_STEPS;
end;
procedure TChartAxisIntervalParams.ParseNiceSteps;
var
parts: TStringList;
i: Integer;
begin
parts := TStringList.Create;
try
parts.Delimiter := '|';
parts.StrictDelimiter := true;
parts.DelimitedText := IfThen(NiceSteps = '', DEF_INTERVAL_STEPS, NiceSteps);
SetLength(FStepValues, parts.Count);
for i := 0 to parts.Count - 1 do
FStepValues[i] := StrToFloatDefSep(parts[i]);
finally
parts.Free;
end;
end;
procedure TChartAxisIntervalParams.SetCount(AValue: Integer);
begin
if FCount = AValue then exit;
FCount := AValue;
Changed;
end;
procedure TChartAxisIntervalParams.SetMaxLength(AValue: Integer);
begin
if FMaxLength = AValue then exit;
FMaxLength := AValue;
Changed;
end;
procedure TChartAxisIntervalParams.SetMinLength(AValue: Integer);
begin
if FMinLength = AValue then exit;
FMinLength := AValue;
Changed;
end;
procedure TChartAxisIntervalParams.SetNiceSteps(const AValue: String);
begin
if FNiceSteps = AValue then exit;
FNiceSteps := AValue;
ParseNiceSteps;
Changed;
end;
procedure TChartAxisIntervalParams.SetOptions(
AValue: TAxisIntervalParamOptions);
begin
if FOptions = AValue then exit;
FOptions := AValue;
Changed;
end;
procedure TChartAxisIntervalParams.SetTolerance(AValue: Cardinal);
begin
if FTolerance = AValue then exit;
FTolerance := AValue;
Changed;
end;
{ TChartDataItem }
function TChartDataItem.GetY(AIndex: Integer): Double;
begin
AIndex := EnsureRange(AIndex, 0, Length(YList));
if AIndex = 0 then
Result := Y
else
Result := YList[AIndex - 1];
end;
procedure TChartDataItem.MultiplyY(ACoeff: Double);
var
i: Integer;
begin
Y *= ACoeff;
for i := 0 to High(YList) do
YList[i] *= ACoeff;
end;
function TChartDataItem.Point: TDoublePoint;
begin
Result.X := X;
Result.Y := Y;
end;
procedure TChartDataItem.SetY(AValue: Double);
var
i: Integer;
begin
Y := AValue;
for i := 0 to High(YList) do
YList[i] := AValue;
end;
{ TChartSourceBuffer }
procedure TChartSourceBuffer.AddFirst(const AItem: TChartDataItem);
begin
if Capacity = 0 then
raise EBufferError.Create('');
FStart := (FStart + Cardinal(High(FBuf))) mod Capacity;
if FCount = Capacity then
RemoveValue(FBuf[FStart])
else
FCount += 1;
FBuf[FStart] := AItem;
AddValue(AItem);
end;
procedure TChartSourceBuffer.AddLast(const AItem: TChartDataItem);
begin
if Capacity > 0 then
if FCount = Capacity then begin
RemoveValue(FBuf[FStart]);
FBuf[FStart] := AItem;
FStart := (FStart + 1) mod Capacity;
end
else begin
FCount += 1;
FBuf[EndIndex] := AItem;
end;
AddValue(AItem);
end;
procedure TChartSourceBuffer.AddValue(const AItem: TChartDataItem);
var
i, oldLen: Integer;
begin
with FSum do begin
Y += AItem.Y;
oldLen := Length(YList);
SetLength(YList, Max(Length(AItem.YList), oldLen));
for i := oldLen to High(YList) do
YList[i] := 0;
for i := 0 to Min(High(YList), High(AItem.YList)) do
YList[i] += AItem.YList[i];
end;
end;
procedure TChartSourceBuffer.Clear;
begin
FCount := 0;
FStart := 0;
FSum.Y := 0;
FSum.YList := nil;
end;
function TChartSourceBuffer.EndIndex: Cardinal;
begin
Result := (FStart + Cardinal(FCount - 1)) mod Capacity;
end;
function TChartSourceBuffer.GetCapacity: Cardinal;
begin
Result := Length(FBuf);
end;
function TChartSourceBuffer.GetPtr(AOffset: Cardinal): PChartDataItem;
begin
if AOffset >= FCount then
raise EBufferError.Create('AOffset');
Result := @FBuf[(FStart + AOffset + Capacity) mod Capacity];
end;
procedure TChartSourceBuffer.GetSum(var AItem: TChartDataItem);
begin
AItem.Y := FSum.Y;
AItem.YList := Copy(FSum.YList);
end;
procedure TChartSourceBuffer.RemoveFirst;
begin
if FCount = 0 then
raise EBufferError.Create('Empty');
RemoveValue(FBuf[FStart]);
FCount -= 1;
FStart := (FStart + 1) mod Capacity;
end;
procedure TChartSourceBuffer.RemoveLast;
begin
if FCount = 0 then
raise EBufferError.Create('Empty');
RemoveValue(FBuf[EndIndex]);
FCount -= 1;
end;
procedure TChartSourceBuffer.RemoveValue(const AItem: TChartDataItem);
var
i: Integer;
begin
with AItem do begin
FSum.Y -= Y;
for i := 0 to Min(High(FSum.YList), High(YList)) do
FSum.YList[i] -= YList[i];
end;
end;
procedure TChartSourceBuffer.SetCapacity(AValue: Cardinal);
begin
if AValue = Capacity then exit;
SetLength(FBuf, AValue);
Clear;
end;
{ TCustomChartSourceEnumerator }
constructor TCustomChartSourceEnumerator.Create(ASource: TCustomChartSource);
begin
FSource := ASource;
FIndex := -1;
end;
function TCustomChartSourceEnumerator.GetCurrent: PChartDataItem;
begin
Result := FSource[FIndex];
end;
function TCustomChartSourceEnumerator.MoveNext: Boolean;
begin
FIndex += 1;
Result := FIndex < FSource.Count;
end;
procedure TCustomChartSourceEnumerator.Reset;
begin
FIndex := 0;
end;
{ TCustomChartSource }
procedure TCustomChartSource.AfterDraw;
begin
// empty
end;
procedure TCustomChartSource.BeforeDraw;
begin
// empty
end;
procedure TCustomChartSource.BeginUpdate;
begin
Inc(FUpdateCount);
end;
class procedure TCustomChartSource.CheckFormat(const AFormat: String);
begin
Format(AFormat, [0.0, 0.0, '', 0.0, 0.0]);
end;
constructor TCustomChartSource.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBroadcaster := TBroadcaster.Create;
FYCount := 1;
end;
destructor TCustomChartSource.Destroy;
begin
FreeAndNil(FBroadcaster);
inherited;
end;
procedure TCustomChartSource.EndUpdate;
begin
Dec(FUpdateCount);
if FUpdateCount > 0 then exit;
// Values can be set directly between BeginUpdate and EndUpdate.
InvalidateCaches;
Notify;
end;
function TCustomChartSource.Extent: TDoubleRect;
var
i: Integer;
begin
if FExtentIsValid then exit(FExtent);
FExtent := EmptyExtent;
for i := 0 to Count - 1 do
with Item[i]^ do begin
UpdateMinMax(X, FExtent.a.X, FExtent.b.X);
UpdateMinMax(Y, FExtent.a.Y, FExtent.b.Y);
end;
FExtentIsValid := true;
Result := FExtent;
end;
function TCustomChartSource.ExtentCumulative: TDoubleRect;
var
h: Double;
i, j: Integer;
begin
Result := Extent;
if YCount < 2 then exit;
for i := 0 to Count - 1 do begin
h := NumberOr(Item[i]^.Y);
for j := 0 to YCount - 2 do begin
h += NumberOr(Item[i]^.YList[j]);
// If some of Y values are negative, h may be non-monotonic.
UpdateMinMax(h, Result.a.Y, Result.b.Y);
end;
end;
end;
function TCustomChartSource.ExtentList: TDoubleRect;
var
i, j: Integer;
begin
Result := Extent;
for i := 0 to Count - 1 do
with Item[i]^ do
for j := 0 to High(YList) do
UpdateMinMax(YList[j], Result.a.Y, Result.b.Y);
end;
procedure TCustomChartSource.FindBounds(
AXMin, AXMax: Double; out ALB, AUB: Integer);
function FindLB(X: Double; L, R: Integer): Integer;
begin
while L <= R do begin
Result := (R - L) div 2 + L;
if Item[Result]^.X < X then
L := Result + 1
else
R := Result - 1;
end;
Result := L;
end;
function FindUB(X: Double; L, R: Integer): Integer;
begin
while L <= R do begin
Result := (R - L) div 2 + L;
if Item[Result]^.X <= X then
L := Result + 1
else
R := Result - 1;
end;
Result := R;
end;
begin
EnsureOrder(AXMin, AXMax);
if IsSorted then begin
ALB := FindLB(AXMin, 0, Count - 1);
AUB := FindUB(AXMax, 0, Count - 1);
end
else begin
ALB := 0;
while (ALB < Count) and (IsNan(Item[ALB]^.X) or (Item[ALB]^.X < AXMin)) do
Inc(ALB);
AUB := Count - 1;
while (AUB >= 0) and (IsNan(Item[AUB]^.X) or (Item[AUB]^.X > AXMax)) do
Dec(AUB);
end;
end;
function TCustomChartSource.FormatItem(
const AFormat: String; AIndex, AYIndex: Integer): String;
const
TO_PERCENT = 100;
var
total, percent, vy: Double;
begin
total := ValuesTotal;
if total = 0 then
percent := 0
else
percent := TO_PERCENT / total;
with Item[AIndex]^ do begin
vy := GetY(AYIndex);
Result := Format(AFormat, [vy, vy * percent, Text, total, X]);
end;
end;
function TCustomChartSource.GetEnumerator: TCustomChartSourceEnumerator;
begin
Result := TCustomChartSourceEnumerator.Create(Self);
end;
procedure TCustomChartSource.InvalidateCaches;
begin
FExtentIsValid := false;
FValuesTotalIsValid := false;
end;
function TCustomChartSource.IsSorted: Boolean;
begin
Result := false;
end;
function TCustomChartSource.IsUpdating: Boolean; inline;
begin
Result := FUpdateCount > 0;
end;
procedure TCustomChartSource.Notify;
begin
if not IsUpdating then
FBroadcaster.Broadcast(Self);
end;
procedure TCustomChartSource.SortValuesInRange(
var AValues: TChartValueTextArray; AStart, AEnd: Integer);
var
i, j, next: Integer;
lst: TFPList;
p: PChartValueText;
tmp: TChartValueText;
begin
lst := TFPList.Create;
try
lst.Count := AEnd - AStart + 1;
for i := AStart to AEnd do
lst[i - AStart] := @AValues[i];
lst.Sort(@CompareChartValueTextPtr);
for i := AStart to AEnd do begin
if lst[i - AStart] = nil then continue;
j := i;
tmp := AValues[j];
while true do begin
p := PChartValueText(lst[j - AStart]);
lst[j - AStart] := nil;
{$HINTS OFF} // Work around the fpc bug #19582.
next := (PtrUInt(p) - PtrUInt(@AValues[0])) div SizeOf(p^);
{$HINTS ON}
if next = i then break;
AValues[j] := p^;
j := next;
end;
AValues[j] := tmp;
end;
finally
lst.Free;
end;
end;
procedure TCustomChartSource.ValuesInRange(
AParams: TValuesInRangeParams; var AValues: TChartValueTextArray);
procedure Put(
out ADest: TChartValueText; AValue: Double; AIndex: Integer); inline;
begin
ADest.FValue := AValue;
ADest.FText := FormatItem(AParams.FFormat, AIndex, 0);
end;
var
prevImagePos: Integer = MaxInt;
function IsTooClose(AValue: Double): Boolean;
var
imagePos: Integer;
begin
with AParams do
if aipUseMinLength in FIntervals.Options then begin
imagePos := ToImage(AValue);
Result := Abs(imagePos - prevImagePos) < FScale(FIntervals.MinLength);
end;
if not Result then
prevImagePos := imagePos;
end;
var
i, j, cnt, start: Integer;
v: Double;
lo, hi: TChartValueText;
begin
// Select all values in a given range, plus lower and upper bound values.
// Proceed through the (possibly unsorted) data source in a single pass.
start := Length(AValues);
SetLength(AValues, start + Count + 2);
cnt := start;
lo.FValue := NegInfinity;
hi.FValue := SafeInfinity;
AValues[start].FValue := SafeNan;
for i := 0 to Count - 1 do begin
with Item[I]^ do
v := IfThen(AParams.FUseY, Y, X);
if IsNan(v) then continue;
if v < AParams.FMin then begin
if v > lo.FValue then
Put(lo, v, i);
end
else if v > AParams.FMax then begin
if v < hi.FValue then
Put(hi, v, i);
end
else begin
if (aipUseMinLength in AParams.FIntervals.Options) and IsTooClose(v) then
continue;
if not IsInfinite(lo.FValue) and (cnt = start) then
cnt += 1;
Put(AValues[cnt], v, i);
cnt += 1;
end;
end;
if not IsInfinite(lo.FValue) then begin
if not IsNan(AValues[start].FValue) then begin
// The lower bound value occured after the first in-range value,
// so we did not reserve space for it. Hopefully rare case.
for i := cnt downto start + 1 do
AValues[i] := AValues[i - 1];
cnt += 1;
end;
AValues[start] := lo;
if cnt = start then
cnt += 1;
end;
if not IsInfinite(hi.FValue) then begin
AValues[cnt] := hi;
cnt += 1;
end;
SetLength(AValues, cnt);
if IsSorted or IsValueTextsSorted(AValues, start, cnt - 1) then exit;
SortValuesInRange(AValues, start, cnt - 1);
if aipUseMinLength in AParams.FIntervals.Options then begin
prevImagePos := MaxInt;
j := start;
for i := start to cnt - 1 do begin
v := AValues[i].FValue;
if InRange(v, AParams.FMin, AParams.FMax) and IsTooClose(v) then continue;
AValues[j] := AValues[i];
j += 1;
end;
SetLength(AValues, j);
end;
end;
function TCustomChartSource.ValuesTotal: Double;
var
i: Integer;
begin
if FValuesTotalIsValid then exit(FValuesTotal);
FValuesTotal := 0;
for i := 0 to Count - 1 do
FValuesTotal += Item[i]^.Y;
FValuesTotalIsValid := true;
Result := FValuesTotal;
end;
function TCustomChartSource.XOfMax: Double;
var
i: Integer;
begin
for i := 0 to Count - 1 do
with Item[i]^ do
if Y = Extent.b.Y then exit(X);
Result := 0.0;
end;
function TCustomChartSource.XOfMin: Double;
var
i: Integer;
begin
for i := 0 to Count - 1 do
with Item[i]^ do
if Y = Extent.a.Y then exit(X);
Result := 0.0;
end;
end.