tachartutils.pas 25 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
{
 /***************************************************************************
                               TAChartUtils.pas
                               ----------------
              Component Library Standard Graph Utiliity Functions


 ***************************************************************************/

 *****************************************************************************
11
12
  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
13
14
 *****************************************************************************

15
  Authors: Luнs Rodrigues, Philippe Martinole, Alexander Klenin
16

17
18
19
20
}

unit TAChartUtils;

ask's avatar
ask committed
21
{$H+}
22
23
24
{$IF FPC_FULLVERSION<20700}
{$OPTIMIZATION NOSTACKFRAME}
{$ENDIF}
25
26
27
28

interface

uses
ask's avatar
ask committed
29
  Classes, Math, Types, SysUtils;
30
31

const
32
  CHART_COMPONENT_IDE_PAGE = 'Chart';
ask's avatar
ask committed
33
  PERCENT = 0.01;
34
  clTAColor = $20000000; // = clDefault, but avoiding dependency on Graphics
35
  DEFAULT_FONT_SIZE = 10;
36
37

type
38
  EChartError = class(Exception);
ask's avatar
ask committed
39
  EChartIntervalError = class(EChartError);
40
  EListenerError = class(EChartError);
41
  EDrawDataError = class(EChartError);
42

43
44
45
  // Like TColor, but avoiding dependency on Graphics.
  TChartColor = -$7FFFFFFF-1..$7FFFFFFF;

46
47
48
49
50
51
  // dto with TFontStyle
  TChartFontStyle = (cfsBold, cfsItalic, cfsUnderline, cfsStrikeout);
  TChartFontStyles = set of TChartFontStyle;

  TChartTextFormat = (tfNormal, tfHTML);

52
53
54
55
  TDoublePoint = record
    X, Y: Double;
  end;

ask's avatar
ask committed
56
  TDoubleRect = record
ask's avatar
ask committed
57
58
59
60
61
62
63
  case Integer of
    0: (
      a, b: TDoublePoint;
    );
    1: (
      coords: array [1..4] of Double;
    );
ask's avatar
ask committed
64
65
  end;

66
  TPointArray = array of TPoint;
67
  TDoublePointArray = array of TDoublepoint;
68

69
70
  TChartDistance = 0..MaxInt;

71
72
  TPercent = 0..100;

73
74
  TPointDistFunc = function (const A, B: TPoint): Integer;

75
  TTransformFunc = function (A: Double): Double of object;
76
77
  TImageToGraphFunc = function (AX: Integer): Double of object;
  TGraphToImageFunc = function (AX: Double): Integer of object;
78

79
  TChartUnits = (cuPercent, cuAxis, cuGraph, cuPixel);
ask's avatar
ask committed
80

81
82
83
  TOverrideColor = (ocBrush, ocPen);
  TOverrideColors = set of TOverrideColor;

84
85
  TSeriesMarksStyle = (
    smsCustom,         { user-defined }
86
    smsNone,           { no labels }
87
88
89
90
91
92
93
94
95
96
    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 }

ask's avatar
ask committed
97
98
99
100
  TDoubleInterval = record
    FStart, FEnd: Double;
  end;

ask's avatar
ask committed
101
102
103
  TPointBoolArr = array [Boolean] of Integer;
  TDoublePointBoolArr = array [Boolean] of Double;

wp's avatar
wp committed
104
  TNearestPointTarget = (
105
106
107
108
    nptPoint,   // Look for the nearest point at (x, y)
    nptXList,   // Check additional x values in XList
    nptYList,   // Check additional y values in YList
    nptCustom   // Depends on series type (e.g., TBarSeries --> click inside bar.)
wp's avatar
wp committed
109
110
  );

111
112
  TNearestPointTargets = set of TNearestPointTarget;

ask's avatar
ask committed
113
114
115
116
117
118
119
120
121
122
123
124
125
  { 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
126
    procedure Assign(ASource: TIntervalList);
ask's avatar
ask committed
127
128
129
    constructor Create;
  public
    procedure AddPoint(APoint: Double); inline;
130
    procedure AddRange(AStart, AEnd: Double);
ask's avatar
ask committed
131
132
133
134
135
136
137
138
139
140
    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;

141
142
  TCaseOfTwo = (cotNone, cotFirst, cotSecond, cotBoth);

143
144
  { TIndexedComponent }

145
  TIndexedComponent = class(TComponent)
146
  strict protected
147
148
149
    function GetIndex: Integer; virtual; abstract;
    procedure SetIndex(AValue: Integer); virtual; abstract;
  public
150
151
    procedure ChangeNamePrefix(const AOld, ANew: String; var AFailed: String);

152
153
154
    property Index: Integer read GetIndex write SetIndex;
  end;

155
156
  TShowMessageProc = procedure (const AMsg: String);

157
158
159
160
161
162
163
164
165
  {$IFNDEF fpdoc} // Workaround for issue #18549.
  generic TTypedFPListEnumerator<T> = class(TFPListEnumerator)
  {$ELSE}
  TTypedFPListEnumerator = class(TFPListEnumerator)
  {$ENDIF}
    function GetCurrent: T;
    property Current: T read GetCurrent;
  end;

166
167
168
169
170
171
172
  { TIndexedComponentList }

  TIndexedComponentList = class(TFPList)
  public
    procedure ChangeNamePrefix(const AOld, ANew: String);
  end;

173
174
  TBroadcaster = class;

175
176
177
178
  { TListener }

  TListener = class
  private
179
180
181
182
    FBroadcaster: TBroadcaster;
    FOnNotify: TNotifyEvent;
    FRef: PPointer;
    function GetIsListening: Boolean;
183
  public
184
185
    constructor Create(ARef: PPointer; AOnNotify: TNotifyEvent);
    destructor Destroy; override;
186
    procedure Forget; virtual;
ask's avatar
ask committed
187
    procedure Notify(ASender: TObject);
188
    property IsListening: Boolean read GetIsListening;
ask's avatar
ask committed
189
    property OnNotify: TNotifyEvent read FOnNotify write FOnNotify;
190
191
192
193
194
  end;

  { TBroadcaster }

  TBroadcaster = class(TFPList)
195
196
  private
    FLocked: Boolean;
197
198
199
  public
    destructor Destroy; override;
  public
200
    procedure Broadcast(ASender: TObject);
201
202
    procedure Subscribe(AListener: TListener);
    procedure Unsubscribe(AListener: TListener);
203
204
  public
    property Locked: Boolean read FLocked write FLocked;
205
206
  end;

207
208
209
210
211
212
213
  { TDrawDataItem }

  TDrawDataItem = class
  private
    FChart: TObject;
    FOwner: TObject;
  public
214
    constructor Create(AChart, AOwner: TObject);
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
    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;

237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
  // An ordered set of integers represented as a comma-separated string
  // for publushing as a single property.
  TPublishedIntegerSet = object
  strict private
    FAllSet: Boolean;
    FData: TIntegerDynArray;
    function GetAsString: String;
    function GetIsSet(AIndex: Integer): Boolean;
    procedure SetAllSet(AValue: Boolean);
    procedure SetAsString(AValue: String);
    procedure SetIsSet(AIndex: Integer; AValue: Boolean);
  public
    constructor Init;
  public
    property AllSet: Boolean read FAllSet write SetAllSet;
252
    function AsBooleans(ACount: Integer): TBooleanDynArray;
253
254
255
256
    property AsString: String read GetAsString write SetAsString;
    property IsSet[AIndex: Integer]: Boolean read GetIsSet write SetIsSet;
  end;

257
  // A limited capacity stack to store 'undo'-like history.
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
  generic THistory<TElem> = class
  strict private
    FCount: Cardinal;
    FData: array of TElem;

    function GetCapacity: Cardinal; inline;
    function GetItem(AIndex: Integer): TElem;
    procedure SetCapacity(AValue: Cardinal);
    procedure DeleteOld(ACount: Integer);
  public
    procedure Add(const AItem: TElem);
    function Pop: TElem; inline;

    property Capacity: Cardinal read GetCapacity write SetCapacity;
    property Count: Cardinal read FCount;
    property Item[AIndex: Integer]: TElem read GetItem; default;
  end;

wp's avatar
wp committed
276
277
278
279
  PStr = ^String;  // PString is declared in system and in objpas!

  TClassRegistryItem = class
    FClass: TClass;
280
281
282
283
    FCaption: String;
    FCaptionPtr: PStr;
    constructor Create(AClass: TClass; const ACaption: String);
    constructor CreateRes(AClass: TClass; ACaptionPtr: PStr);
wp's avatar
wp committed
284
285
286
287
288
289
290
291
292
293
294
  end;

  TClassRegistry = class(TFPList)
  public
    destructor Destroy; override;
    procedure Clear;
    function GetCaption(AIndex: Integer): String;
    function GetClass(AIndex: Integer): TClass;
    function IndexOfClass(AClass: TClass): Integer;
  end;

295
const
296
297
  PUB_INT_SET_ALL = '';
  PUB_INT_SET_EMPTY = '-';
298
299
  // 0-value, 1-percent, 2-label, 3-total, 4-xvalue
  SERIES_MARK_FORMATS: array [TSeriesMarksStyle] of String = (
300
    '', '',
301
    '%0:.9g', // smsValue
302
303
304
    '%1:.2f%%', // smsPercent
    '%2:s', // smsLabel
    '%2:s %1:.2f%%', // smsLabelPercent
305
    '%2:s %0:.9g', // smsLabelValue
306
307
    '%2:s', // smsLegend: not sure what it means, left for Delphi compatibility
    '%1:.2f%% of %3:g', // smsPercentTotal
308
    '%2:s %1:.2f%% of %3:g', // smsLabelPercentTotal
309
    '%4:.9g' // smsXValue
310
  );
ask's avatar
ask committed
311
  ZeroDoublePoint: TDoublePoint = (X: 0; Y: 0);
ask's avatar
ask committed
312
  ZeroRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
313
  EmptyDoubleRect: TDoubleRect = (coords: (0, 0, 0, 0));
314
315
  EmptyExtent: TDoubleRect =
    (coords: (Infinity, Infinity, NegInfinity, NegInfinity));
316
317
  CASE_OF_TWO: array [Boolean, Boolean] of TCaseOfTwo =
    ((cotNone, cotSecond), (cotFirst, cotBoth));
318
  ORIENTATION_UNITS_PER_DEG = 10;
319

320
321
function BoundsSize(ALeft, ATop: Integer; ASize: TSize): TRect; inline;

322
function Deg16ToRad(ADeg16: Integer): Double; inline;
323
function DoubleInterval(AStart, AEnd: Double): TDoubleInterval; inline;
324

325
326
327
328
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;
329

330
331
function FormatIfNotEmpty(AFormat, AStr: String): String; inline;

ask's avatar
ask committed
332
function IfThen(ACond: Boolean; ATrue, AFalse: TObject): TObject; overload;
333
function InterpolateRGB(AColor1, AColor2: Integer; ACoeff: Double): Integer;
334
function IntToColorHex(AColor: Integer): String; inline;
335
function IsEquivalent(const A1, A2: Double): Boolean; inline;
336
function IsNan(const APoint: TDoublePoint): Boolean; overload; inline;
ask's avatar
ask committed
337
function NumberOr(ANum: Double; ADefault: Double = 0.0): Double; inline;
338

339
340
function OrientToRad(AOrient: Integer): Double; inline;

341
function RadToDeg16(ARad: Double): Integer; inline;
342
function RadToOrient(ARad: Double): Integer; inline;
343

344
345
function RoundChecked(A: Double): Integer; inline;

346
347
procedure SetPropDefaults(AObject: TPersistent; APropNames: array of String);

ask's avatar
ask committed
348
349
350
function Split(
  AString: String; ADest: TStrings = nil; ADelimiter: Char = '|'): TStrings;

351
352
353
// Accept both locale-specific and default decimal separators.
function StrToFloatDefSep(const AStr: String): Double;

354
355
356
// Call this to silence 'parameter is unused' hint
procedure Unused(const A1);
procedure Unused(const A1, A2);
wp's avatar
wp committed
357
procedure Unused(const A1, A2, A3);
358

359
360
procedure UpdateMinMax(AValue: Double; var AMin, AMax: Double); overload;
procedure UpdateMinMax(AValue: Integer; var AMin, AMax: Integer); overload;
ask's avatar
ask committed
361

362
363
function WeightedAverage(AX1, AX2, ACoeff: Double): Double; inline;

364
operator =(const A, B: TMethod): Boolean; overload; inline;
365

366
367
var
  DrawData: TDrawDataRegistry;
368
369
  ShowMessageProc: TShowMessageProc;

370

371
372
implementation

373
uses
374
  StrUtils, TypInfo, TAChartStrConsts;
375

376
377
378
379
380
function BoundsSize(ALeft, ATop: Integer; ASize: TSize): TRect; inline;
begin
  Result := Bounds(ALeft, ATop, ASize.cx, ASize.cy);
end;

381
382
383
384
385
function Deg16ToRad(ADeg16: Integer): Double;
begin
  Result := DegToRad(ADeg16 / 16);
end;

386
387
388
389
390
391
function DoubleInterval(AStart, AEnd: Double): TDoubleInterval;
begin
  Result.FStart := AStart;
  Result.FEnd := AEnd;
end;

392
procedure Exchange(var A, B: Integer);
393
394
395
396
397
398
399
400
var
  t: Integer;
begin
  t := A;
  A := B;
  B := t;
end;

401
procedure Exchange(var A, B: Double);
402
403
404
405
406
407
408
409
var
  t: Double;
begin
  t := A;
  A := B;
  B := t;
end;

410
411
412
413
414
415
416
417
418
procedure Exchange(var A, B: TDoublePoint);
var
  t: TDoublePoint;
begin
  t := A;
  A := B;
  B := t;
end;

419
procedure Exchange(var A, B: String);
420
421
422
423
424
425
426
427
var
  t: String;
begin
  t := A;
  A := B;
  B := t;
end;

428
429
430
431
432
433
434
435
function FormatIfNotEmpty(AFormat, AStr: String): String;
begin
  if AStr = '' then
    Result := ''
  else
    Result := Format(AFormat, [AStr]);
end;

ask's avatar
ask committed
436
437
438
439
440
441
442
443
function IfThen(ACond: Boolean; ATrue, AFalse: TObject): TObject;
begin
  if ACond then
    Result := ATrue
  else
    Result := AFalse;
end;

444
445
446
447
448
449
450
451
452
453
454
455
456
457
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;

458
459
460
461
462
463
464
465
function IntToColorHex(AColor: Integer): String;
begin
  if AColor = clTAColor then
    Result := '?'
  else
    Result := '$' + IntToHex(AColor, 6);
end;

466
467
468
469
470
function IsEquivalent(const A1, A2: Double): Boolean;
begin
  Result := CompareDWord(A1, A2, SizeOf(A1) div SizeOf(DWord)) = 0;
end;

471
472
473
474
475
function IsNan(const APoint: TDoublePoint): Boolean;
begin
  Result := IsNan(APoint.X) or IsNan(APoint.Y);
end;

ask's avatar
ask committed
476
477
478
479
480
function NumberOr(ANum: Double; ADefault: Double): Double;
begin
  Result := IfThen(IsNan(ANum), ADefault, ANum);
end;

481
482
483
484
485
function OrientToRad(AOrient: Integer): Double;
begin
  Result := DegToRad(AOrient / ORIENTATION_UNITS_PER_DEG);
end;

486
487
488
489
490
function RadToDeg16(ARad: Double): Integer;
begin
  Result := Round(RadToDeg(ARad) * 16);
end;

491
492
493
494
495
function RadToOrient(ARad: Double): Integer;
begin
  Result := Round(RadToDeg(ARad)) * ORIENTATION_UNITS_PER_DEG;
end;

496
497
498
499
500
function RoundChecked(A: Double): Integer;
begin
  Result := Round(EnsureRange(A, -MaxInt, MaxInt));
end;

501
502
503
504
505
506
507
508
509
510
511
procedure SetPropDefaults(AObject: TPersistent; APropNames: array of String);
var
  n: String;
  p: PPropInfo;
begin
  for n in APropNames do begin
    p := GetPropInfo(AObject, n);
    SetOrdProp(AObject, p, p^.Default);
  end;
end;

512
513
514
var
  DefSeparatorSettings: TFormatSettings;

ask's avatar
ask committed
515
516
517
518
519
520
521
522
523
524
function Split(AString: String; ADest: TStrings; ADelimiter: Char): TStrings;
begin
  Result := ADest;
  if Result = nil then
    Result := TStringList.Create;
  Result.Delimiter := ADelimiter;
  Result.StrictDelimiter := true;
  Result.DelimitedText := AString;
end;

525
526
527
528
529
530
531
532
533
function StrToFloatDefSep(const AStr: String): Double;
begin
  if
    not TryStrToFloat(AStr, Result, DefSeparatorSettings) and
    not TryStrToFloat(AStr, Result)
  then
    Result := 0.0;
end;

534
{$PUSH}{$HINTS OFF}
535
536
537
538
539
540
541
procedure Unused(const A1);
begin
end;

procedure Unused(const A1, A2);
begin
end;
wp's avatar
wp committed
542
543
544
545

procedure Unused(const A1, A2, A3);
begin
end;
546
{$POP}
547

ask's avatar
ask committed
548
549
procedure UpdateMinMax(AValue: Double; var AMin, AMax: Double);
begin
550
  if IsNan(AValue) then exit;
ask's avatar
ask committed
551
  if AValue < AMin then
552
553
    AMin := AValue;
  if AValue > AMax then
ask's avatar
ask committed
554
555
556
    AMax := AValue;
end;

557
558
559
560
561
562
563
564
procedure UpdateMinMax(AValue: Integer; var AMin, AMax: Integer);
begin
  if AValue < AMin then
    AMin := AValue;
  if AValue > AMax then
    AMax := AValue;
end;

565
566
567
568
569
function WeightedAverage(AX1, AX2, ACoeff: Double): Double;
begin
  Result := AX1 * (1 - ACoeff) + AX2 * ACoeff;
end;

570
571
572
573
574
operator = (const A, B: TMethod): Boolean;
begin
  Result := (A.Code = B.Code) and (A.Data = B.Data);
end;

575
576
577
578
579
580
581
582
583
584
585
586
587
588
{ THistory }

procedure THistory.Add(const AItem: TElem);
begin
  if Capacity = 0 then exit;
  if FCount = Capacity then
    DeleteOld(1);
  FData[FCount] := AItem;
  FCount += 1;
end;

procedure THistory.DeleteOld(ACount: Integer);
begin
  FCount -= ACount;
589
  Move(FData[ACount], FData[0], SizeInt(FCount) * SizeOf(FData[0]));
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
end;

function THistory.GetCapacity: Cardinal;
begin
  Result := Length(FData);
end;

function THistory.GetItem(AIndex: Integer): TElem;
begin
  if AIndex < 0 then
    AIndex += Integer(FCount);
  Result := FData[AIndex];
end;

function THistory.Pop: TElem;
begin
  Result := GetItem(-1);
  FCount -= 1;
end;

procedure THistory.SetCapacity(AValue: Cardinal);
begin
  if Capacity = AValue then exit;
  if AValue < FCount then
    DeleteOld(FCount - AValue);
  SetLength(FData, AValue);
end;

618
619
620
621
622
623
624
{ TTypedFPListEnumerator }

function TTypedFPListEnumerator.GetCurrent: T;
begin
  Result := T(inherited GetCurrent);
end;

625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
{ 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;

ask's avatar
ask committed
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
{ 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
668
    i += 1;
ask's avatar
ask committed
669
670
671
  if i <= High(FIntervals) then
    AStart := Min(AStart, FIntervals[i].FStart);
  j := High(FIntervals);
ask's avatar
ask committed
672
  while (j >= 0) and (FIntervals[j].FStart > AEnd) do
673
    j -= 1;
ask's avatar
ask committed
674
675
676
677
678
679
680
681
682
  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);
683
    for k := High(FIntervals) downto i + 1 do
ask's avatar
ask committed
684
685
      FIntervals[k] := FIntervals[k - 1];
  end;
686
  FIntervals[i] := DoubleInterval(AStart, AEnd);
ask's avatar
ask committed
687
688
689
  Changed;
end;

690
691
692
693
694
695
procedure TIntervalList.Assign(ASource: TIntervalList);
begin
  FEpsilon := ASource.FEpsilon;
  FIntervals := Copy(ASource.FIntervals);
end;

ask's avatar
ask committed
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
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
765
  if TMethod(FOnChange) = TMethod(AValue) then exit;
ask's avatar
ask committed
766
767
768
  FOnChange := AValue;
end;

769
770
{ TListener }

771
772
773
constructor TListener.Create(ARef: PPointer; AOnNotify: TNotifyEvent);
begin
  FOnNotify := AOnNotify;
774
  FRef := ARef;
775
776
777
778
779
780
781
782
783
end;

destructor TListener.Destroy;
begin
  if IsListening then
    FBroadcaster.Unsubscribe(Self);
  inherited;
end;

784
785
procedure TListener.Forget;
begin
786
  FBroadcaster := nil;
787
788
  if FRef <> nil then
    FRef^ := nil;
789
790
791
792
793
794
795
796
797
end;

function TListener.GetIsListening: Boolean;
begin
  Result := FBroadcaster <> nil;
end;

procedure TListener.Notify(ASender: TObject);
begin
ask's avatar
ask committed
798
799
  if Assigned(FOnNotify) then
    FOnNotify(ASender)
800
801
802
803
end;

{ TBroadcaster }

804
procedure TBroadcaster.Broadcast(ASender: TObject);
805
var
806
  p: Pointer;
807
begin
808
  if Locked then exit;
809
810
  for p in Self do
    TListener(p).Notify(ASender);
811
812
813
814
end;

destructor TBroadcaster.Destroy;
var
815
  p: Pointer;
816
begin
817
818
  for p in Self do
    TListener(p).Forget;
819
  inherited;
820
821
822
823
824
825
826
827
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');
828
  AListener.FBroadcaster := Self;
829
830
831
832
833
834
835
836
837
  Add(AListener);
end;

procedure TBroadcaster.Unsubscribe(AListener: TListener);
var
  i: Integer;
begin
  if not AListener.IsListening then
    raise EListenerError.Create('Listener not subscribed');
838
  AListener.Forget;
839
840
841
842
843
844
  i := IndexOf(AListener);
  if i < 0 then
    raise EListenerError.Create('Listener not found');
  Delete(i);
end;

845
846
847
848
849
850
851
852
{ TDrawDataItem }

constructor TDrawDataItem.Create(AChart, AOwner: TObject);
begin
  FChart := AChart;
  FOwner := AOwner;
end;

853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
{ 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;

912
913
{ TPublishedIntegerSet }

914
function TPublishedIntegerSet.AsBooleans(ACount: Integer): TBooleanDynArray;
915
916
917
var
  i: Integer;
begin
918
919
920
921
922
923
924
925
  SetLength(Result, ACount);
  if ACount = 0 then exit;
  if AllSet then
    FillChar(Result[0], Length(Result), true)
  else
    for i in FData do
      if InRange(i, 0, High(Result)) then
        Result[i] := true;
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
end;

function TPublishedIntegerSet.GetAsString: String;
var
  i: Integer;
begin
  if AllSet then
    Result := PUB_INT_SET_ALL
  else if Length(FData) = 0 then
    Result := PUB_INT_SET_EMPTY
  else begin
    Result := IntToStr(FData[0]);
    for i := 1 to High(FData) do
      Result += ',' + IntToStr(FData[i]);
  end;
end;

function TPublishedIntegerSet.GetIsSet(AIndex: Integer): Boolean;
var
  i: Integer;
begin
  Result := true;
  if AllSet then exit;
  for i in FData do
    if i = AIndex then exit;
  Result := false;
end;

constructor TPublishedIntegerSet.Init;
begin
  FAllSet := true;
end;

procedure TPublishedIntegerSet.SetAllSet(AValue: Boolean);
begin
  if FAllSet = AValue then exit;
  FAllSet := AValue;
  if FAllSet then
    SetLength(FData, 0);
end;

procedure TPublishedIntegerSet.SetAsString(AValue: String);
var
  sl: TStringList;
  i, p: Integer;
  s: String;
begin
  AllSet := AValue = PUB_INT_SET_ALL;
  if AllSet then exit;
  sl := TStringList.Create;
  try
    sl.CommaText := AValue;
    SetLength(FData, sl.Count);
    i := 0;
    for s in sl do
      if TryStrToInt(s, p) then begin
        FData[i] := p;
        i += 1;
      end;
  finally
    sl.Free;
  end;
  SetLength(FData, i);
end;

procedure TPublishedIntegerSet.SetIsSet(AIndex: Integer; AValue: Boolean);
var
  i, j: Integer;
begin
  if AllSet or (IsSet[AIndex] = AValue) then exit;
  if AValue then begin
    SetLength(FData, Length(FData) + 1);
    FData[High(FData)] := AIndex;
  end
  else begin
    j := 0;
    for i := 0 to High(FData) do
      if FData[i] <> AIndex then begin
        FData[j] := FData[i];
        j += 1;
      end;
    SetLength(FData, j);
  end;
end;

wp's avatar
wp committed
1011
1012
1013

{ TClassRegistryItem }

1014
constructor TClassRegistryItem.Create(AClass: TClass; const ACaption: String);
wp's avatar
wp committed
1015
1016
1017
1018
1019
begin
  FClass := AClass;
  FCaption := ACaption;
end;

1020
1021
1022
1023
1024
1025
1026
constructor TClassRegistryItem.CreateRes(AClass: TClass; ACaptionPtr: PStr);
begin
  FClass := AClass;
  FCaptionPtr := ACaptionPtr;
  if FCaptionPtr <> nil then FCaption := ACaptionPtr^;
end;

wp's avatar
wp committed
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046

{ TClassRegistry }

destructor TClassRegistry.Destroy;
begin
  Clear;
  inherited;
end;

procedure TClassRegistry.Clear;
var
  i: Integer;
begin
  for i:= Count-1 downto 0 do
    TObject(Items[i]).Free;
  inherited;
end;

function TClassRegistry.GetCaption(AIndex: Integer): String;
var
1047
  item: TClassRegistryItem;
wp's avatar
wp committed
1048
begin
1049
1050
1051
1052
  item := TClassRegistryItem(Items[AIndex]);
  if item.FCaptionPtr <> nil then
    Result := item.FCaptionPtr^ else
    Result := item.FCaption;
wp's avatar
wp committed
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
end;

function TClassRegistry.GetClass(AIndex: Integer): TClass;
begin
  Result := TClassRegistryItem(Items[AIndex]).FClass;
end;

function TClassRegistry.IndexOfClass(AClass: TClass): Integer;
begin
  for Result := 0 to Count-1 do
    if TClassRegistryItem(Items[Result]).FClass = AClass then
      exit;
  Result := -1;
end;


1069
1070
1071
initialization

  DrawData := TDrawDataRegistry.Create;
1072
1073
  DefSeparatorSettings := DefaultFormatSettings;
  DefSeparatorSettings.DecimalSeparator := '.';
1074
1075
1076
1077
1078

finalization

  FreeAndNil(DrawData);

1079
end.