← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/tachart/tachartutils.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/tachart/tachartutils.pas
42
42
  EListenerError = class(EChartError);
43
43
  EDrawDataError = class(EChartError);
44
44
 
 
45
  // Like TColor, but avoiding dependency on Graphics.
 
46
  TChartColor = -$7FFFFFFF-1..$7FFFFFFF;
 
47
 
45
48
  TDoublePoint = record
46
49
    X, Y: Double;
47
50
  end;
62
65
 
63
66
  TPointDistFunc = function (const A, B: TPoint): Integer;
64
67
 
 
68
  TTransformFunc = function (A: Double): Double of object;
 
69
 
65
70
  TAxisScale = (asIncreasing, asDecreasing, asLogIncreasing, asLogDecreasing);
66
71
 
 
72
  TOverrideColor = (ocBrush, ocPen);
 
73
  TOverrideColors = set of TOverrideColor;
 
74
 
67
75
  TSeriesMarksStyle = (
68
76
    smsCustom,         { user-defined }
69
77
    smsNone,           { no labels }
81
89
    FStart, FEnd: Double;
82
90
  end;
83
91
 
 
92
  TPointBoolArr = array [Boolean] of Integer;
 
93
  TDoublePointBoolArr = array [Boolean] of Double;
 
94
 
84
95
  { TIntervalList }
85
96
 
86
97
  TIntervalList = class
94
105
    procedure SetEpsilon(AValue: Double);
95
106
    procedure SetOnChange(AValue: TNotifyEvent);
96
107
  public
 
108
    procedure Assign(ASource: TIntervalList);
97
109
    constructor Create;
98
110
  public
99
111
    procedure AddPoint(APoint: Double); inline;
112
124
 
113
125
  { TIndexedComponent }
114
126
 
115
 
  TIndexedComponent = class (TComponent)
116
 
  protected
 
127
  TIndexedComponent = class(TComponent)
 
128
  strict protected
117
129
    function GetIndex: Integer; virtual; abstract;
118
130
    procedure SetIndex(AValue: Integer); virtual; abstract;
119
131
  public
 
132
    procedure ChangeNamePrefix(const AOld, ANew: String; var AFailed: String);
 
133
 
120
134
    property Index: Integer read GetIndex write SetIndex;
121
135
  end;
122
136
 
 
137
  TShowMessageProc = procedure (const AMsg: String);
 
138
 
 
139
  {$IFNDEF fpdoc} // Workaround for issue #18549.
 
140
  generic TTypedFPListEnumerator<T> = class(TFPListEnumerator)
 
141
  {$ELSE}
 
142
  TTypedFPListEnumerator = class(TFPListEnumerator)
 
143
  {$ENDIF}
 
144
    function GetCurrent: T;
 
145
    property Current: T read GetCurrent;
 
146
  end;
 
147
 
 
148
  { TIndexedComponentList }
 
149
 
 
150
  TIndexedComponentList = class(TFPList)
 
151
  public
 
152
    procedure ChangeNamePrefix(const AOld, ANew: String);
 
153
  end;
 
154
 
123
155
  TBroadcaster = class;
124
156
 
125
157
  { TListener }
134
166
    constructor Create(ARef: PPointer; AOnNotify: TNotifyEvent);
135
167
    destructor Destroy; override;
136
168
    procedure Forget; virtual;
137
 
    procedure Notify(ASender: TObject); virtual;
 
169
    procedure Notify(ASender: TObject);
138
170
    property IsListening: Boolean read GetIsListening;
 
171
    property OnNotify: TNotifyEvent read FOnNotify write FOnNotify;
139
172
  end;
140
173
 
141
174
  { TBroadcaster }
142
175
 
143
176
  TBroadcaster = class(TFPList)
 
177
  private
 
178
    FLocked: Boolean;
144
179
  public
145
180
    destructor Destroy; override;
146
181
  public
147
182
    procedure Broadcast(ASender: TObject);
148
183
    procedure Subscribe(AListener: TListener);
149
184
    procedure Unsubscribe(AListener: TListener);
 
185
  public
 
186
    property Locked: Boolean read FLocked write FLocked;
150
187
  end;
151
188
 
152
189
  { TDrawDataItem }
179
216
    function Find(AChart, AOwner: TObject): TDrawDataItem;
180
217
  end;
181
218
 
 
219
  // An ordered set of integers represented as a comma-separated string
 
220
  // for publushing as a single property.
 
221
  TPublishedIntegerSet = object
 
222
  strict private
 
223
    FAllSet: Boolean;
 
224
    FData: TIntegerDynArray;
 
225
    function GetAsString: String;
 
226
    function GetIsSet(AIndex: Integer): Boolean;
 
227
    procedure SetAllSet(AValue: Boolean);
 
228
    procedure SetAsString(AValue: String);
 
229
    procedure SetIsSet(AIndex: Integer; AValue: Boolean);
 
230
  public
 
231
    constructor Init;
 
232
  public
 
233
    property AllSet: Boolean read FAllSet write SetAllSet;
 
234
    function AsBooleans(ACount: Integer): TBooleanDynArray;
 
235
    property AsString: String read GetAsString write SetAsString;
 
236
    property IsSet[AIndex: Integer]: Boolean read GetIsSet write SetIsSet;
 
237
  end;
 
238
 
182
239
const
 
240
  PUB_INT_SET_ALL = '';
 
241
  PUB_INT_SET_EMPTY = '-';
183
242
  // 0-value, 1-percent, 2-label, 3-total, 4-xvalue
184
243
  SERIES_MARK_FORMATS: array [TSeriesMarksStyle] of String = (
185
244
    '', '',
202
261
 
203
262
function BoundsSize(ALeft, ATop: Integer; ASize: TSize): TRect; inline;
204
263
 
205
 
function DoublePoint(AX, AY: Double): TDoublePoint; inline;
206
 
function DoubleRect(AX1, AY1, AX2, AY2: Double): TDoubleRect; inline;
207
264
function DoubleInterval(AStart, AEnd: Double): TDoubleInterval; inline;
208
265
 
209
 
procedure EnsureOrder(var A, B: Integer); overload; inline;
210
 
procedure EnsureOrder(var A, B: Double); overload; inline;
211
 
 
212
266
procedure Exchange(var A, B: Integer); overload; inline;
213
267
procedure Exchange(var A, B: Double); overload; inline;
214
268
procedure Exchange(var A, B: TDoublePoint); overload; inline;
215
269
procedure Exchange(var A, B: String); overload; inline;
216
270
 
217
 
procedure ExpandRange(var ALo, AHi: Double; ACoeff: Double); inline;
218
 
procedure ExpandRect(var ARect: TDoubleRect; const APoint: TDoublePoint); inline;
219
 
procedure ExpandRect(var ARect: TRect; const APoint: TPoint); inline;
220
 
procedure ExpandRect(
221
 
  var ARect: TRect; const ACenter: TPoint; ARadius: Integer;
222
 
  AAngle1, AAngle2: Double); inline;
223
 
 
224
 
function GetIntervals(AMin, AMax: Double; AInverted: Boolean): TDoubleDynArray;
 
271
function FormatIfNotEmpty(AFormat, AStr: String): String; inline;
225
272
 
226
273
function InterpolateRGB(AColor1, AColor2: Integer; ACoeff: Double): Integer;
227
 
 
228
 
function IsPointOnLine(const AP, A1, A2: TPoint): Boolean; inline;
229
 
function IsPointInPolygon(
230
 
  const AP: TPoint; const APolygon: array of TPoint): Boolean;
231
 
function IsPointInRect(const AP, A1, A2: TPoint): Boolean; inline; overload;
232
 
function IsPointInRect(const AP: TPoint; const AR: TRect): Boolean; inline; overload;
233
 
function IsRectInRect(const AInner, AOuter: TRect): Boolean; inline;
234
 
function IsLineIntersectsLine(const AA, AB, AC, AD: TPoint): Boolean;
235
 
function IsPolygonIntersectsPolygon(const AP1, AP2: array of TPoint): Boolean;
236
 
function LineIntersectsRect(
237
 
  var AA, AB: TDoublePoint; const ARect: TDoubleRect): Boolean;
238
 
 
239
 
function MeasureRotatedRect(const ASize: TPoint; AAngle: Double): TSize;
240
 
 
241
 
procedure NormalizeRect(var ARect: TRect); overload;
242
 
procedure NormalizeRect(var ARect: TDoubleRect); overload;
 
274
function IntToColorHex(AColor: Integer): String; inline;
 
275
function IsEquivalent(const A1, A2: Double): Boolean; inline;
 
276
function IsNan(const APoint: TDoublePoint): Boolean; overload; inline;
 
277
function NumberOr(ANum: Double; ADefault: Double = 0.0): Double; inline;
243
278
 
244
279
function OrientToRad(AOrient: Integer): Double; inline;
245
280
 
246
 
function PointDist(const A, B: TPoint): Integer; inline;
247
 
function PointDistX(const A, B: TPoint): Integer; inline;
248
 
function PointDistY(const A, B: TPoint): Integer; inline;
249
 
 
250
 
function ProjToRect(
251
 
  const APt: TDoublePoint; const ARect: TDoubleRect): TDoublePoint;
252
 
 
253
281
function RadToDeg16(ARad: Double): Integer; inline;
254
282
function RadToOrient(ARad: Double): Integer; inline;
255
283
 
256
 
function RectIntersectsRect(
257
 
  var ARect: TDoubleRect; const AFixed: TDoubleRect): Boolean;
258
 
 
259
 
function RotatePoint(const APoint: TDoublePoint; AAngle: Double): TDoublePoint; overload;
260
 
function RotatePoint(const APoint: TPoint; AAngle: Double): TPoint; overload;
261
284
function RoundChecked(A: Double): Integer; inline;
262
285
 
263
 
function SafeInfinity: Double; inline;
264
 
function SafeInRange(AValue, ABound1, ABound2: Double): Boolean;
 
286
procedure SetPropDefaults(AObject: TPersistent; APropNames: array of String);
 
287
 
 
288
// Accept both locale-specific and default decimal separators.
 
289
function StrToFloatDefSep(const AStr: String): Double;
265
290
 
266
291
// Call this to silence 'parameter is unused' hint
267
292
procedure Unused(const A1);
270
295
procedure UpdateMinMax(AValue: Double; var AMin, AMax: Double); overload;
271
296
procedure UpdateMinMax(AValue: Integer; var AMin, AMax: Integer); overload;
272
297
 
273
 
operator +(const A: TPoint; B: TSize): TPoint; overload; inline;
274
 
operator +(const A, B: TPoint): TPoint; overload; inline;
275
 
operator +(const A, B: TDoublePoint): TDoublePoint; overload; inline;
276
 
operator -(const A: TPoint): TPoint; overload; inline;
277
 
operator -(const A, B: TPoint): TPoint; overload; inline;
278
 
operator -(const A, B: TDoublePoint): TDoublePoint; overload; inline;
279
 
operator div(const A: TPoint; ADivisor: Integer): TPoint; inline;
280
 
operator *(const A: TPoint; AMultiplier: Integer): TPoint; inline;
281
 
operator *(const A, B: TPoint): TPoint; inline;
282
 
operator *(const A, B: TDoublePoint): TDoublePoint; overload; inline;
283
 
operator /(const A, B: TDoublePoint): TDoublePoint; overload; inline;
 
298
function WeightedAverage(AX1, AX2, ACoeff: Double): Double; inline;
 
299
 
284
300
operator =(const A, B: TMethod): Boolean; overload; inline;
285
301
 
286
 
operator :=(const APoint: TPoint): TSize; inline;
287
 
operator :=(const ASize: TSize): TPoint; inline;
288
 
 
289
302
var
290
303
  DrawData: TDrawDataRegistry;
 
304
  ShowMessageProc: TShowMessageProc;
 
305
 
 
306
resourcestring
 
307
  tasFailedSubcomponentRename = 'Failed to rename components: %s';
291
308
 
292
309
implementation
293
310
 
 
311
uses
 
312
  StrUtils, TypInfo;
 
313
 
294
314
const
295
315
  ORIENTATION_UNITS_PER_DEG = 10;
296
316
 
297
 
function PointLineSide(AP, A1, A2: TPoint): TValueSign; forward;
298
 
 
299
317
function BoundsSize(ALeft, ATop: Integer; ASize: TSize): TRect; inline;
300
318
begin
301
319
  Result := Bounds(ALeft, ATop, ASize.cx, ASize.cy);
302
320
end;
303
321
 
304
 
procedure CalculateIntervals(
305
 
  AMin, AMax: Double; AxisScale: TAxisScale; out AStart, AStep: Double);
306
 
var
307
 
  extent, extentTmp, stepCount, scale, maxStepCount, m: Double;
308
 
  i: Integer;
309
 
const
310
 
  GOOD_STEPS: array [1..3] of Double = (0.2, 0.5, 1.0);
311
 
  BASE = 10;
312
 
begin
313
 
  extent := AMax - AMin;
314
 
  AStep := 1;
315
 
  AStart := AMin;
316
 
  if extent <= 0 then exit;
317
 
 
318
 
  maxStepCount := 0;
319
 
  scale := 1.0;
320
 
  for i := Low(GOOD_STEPS) to High(GOOD_STEPS) do begin
321
 
    extentTmp := extent / GOOD_STEPS[i];
322
 
    m := IntPower(BASE, Round(logn(BASE, extentTmp)));
323
 
    while extentTmp * m > BASE do
324
 
      m /= BASE;
325
 
    while extentTmp * m <= 1 do
326
 
      m *= BASE;
327
 
    stepCount := extentTmp * m;
328
 
    if stepCount > maxStepCount then begin
329
 
      maxStepCount := stepCount;
330
 
      scale := m;
331
 
      AStep := GOOD_STEPS[i] / m;
332
 
    end;
333
 
  end;
334
 
  case AxisScale of
335
 
    asIncreasing: begin
336
 
      // If 0 is in the interval, set it as a mark.
337
 
      if InRange(0, AMin, AMax) then
338
 
        AStart := 0
339
 
      else
340
 
        AStart := Round((AMin - AStep) * scale) / scale;
341
 
      while AStart > AMin do AStart -= AStep;
342
 
    end;
343
 
    asDecreasing: begin
344
 
      // If 0 is in the interval, set it as a mark.
345
 
      if InRange(0, AMin, AMax) then
346
 
        AStart := 0
347
 
      else
348
 
        AStart := Round((AMax + AStep) * scale) / scale;
349
 
      while AStart < AMax do AStart += AStep;
350
 
    end;
351
 
    asLogIncreasing: begin
352
 
      // FIXME: asLogIncreasing is still not implemented.
353
 
      // The following is the same code for asIncreasing;
354
 
      // If 0 is in the interval, set it as a mark.
355
 
      if InRange(0, AMin, AMax) then
356
 
        AStart := 0
357
 
      else
358
 
        AStart := Round((AMin - AStep) * scale) / scale;
359
 
      while AStart > AMin do AStart -= AStep;
360
 
    end;
361
 
    asLogDecreasing: begin
362
 
      // FIXME: asLogDecreasing is still not implemented.
363
 
      // The following is the same code for asIncreasing;
364
 
      // If 0 is in the interval, set it as a mark.
365
 
      if InRange(0, AMin, AMax) then
366
 
        AStart := 0
367
 
      else
368
 
        AStart := Round((AMax + AStep) * scale) / scale;
369
 
      while AStart < AMax do AStart += AStep;
370
 
    end;
371
 
  end; {case AxisScale}
372
 
end;
373
 
 
374
 
function DoublePoint(AX, AY: Double): TDoublePoint; inline;
375
 
begin
376
 
  Result.X := AX;
377
 
  Result.Y := AY;
378
 
end;
379
 
 
380
 
function DoubleRect(AX1, AY1, AX2, AY2: Double): TDoubleRect; inline;
381
 
begin
382
 
  Result.a.X := AX1;
383
 
  Result.a.Y := AY1;
384
 
  Result.b.X := AX2;
385
 
  Result.b.Y := AY2;
386
 
end;
387
 
 
388
322
function DoubleInterval(AStart, AEnd: Double): TDoubleInterval;
389
323
begin
390
324
  Result.FStart := AStart;
391
325
  Result.FEnd := AEnd;
392
326
end;
393
327
 
394
 
procedure EnsureOrder(var A, B: Integer); overload; inline;
395
 
begin
396
 
  if A > B then
397
 
    Exchange(A, B);
398
 
end;
399
 
 
400
 
procedure EnsureOrder(var A, B: Double); overload; inline;
401
 
begin
402
 
  if A > B then
403
 
    Exchange(A, B);
404
 
end;
405
 
 
406
328
procedure Exchange(var A, B: Integer);
407
329
var
408
330
  t: Integer;
439
361
  B := t;
440
362
end;
441
363
 
442
 
procedure ExpandRange(var ALo, AHi: Double; ACoeff: Double);
443
 
var
444
 
  d: Double;
445
 
begin
446
 
  d := AHi - ALo;
447
 
  ALo -= d * ACoeff;
448
 
  AHi += d * ACoeff;
449
 
end;
450
 
 
451
 
procedure ExpandRect(var ARect: TDoubleRect; const APoint: TDoublePoint);
452
 
begin
453
 
  NormalizeRect(ARect);
454
 
  UpdateMinMax(APoint.X, ARect.a.X, ARect.b.X);
455
 
  UpdateMinMax(APoint.Y, ARect.a.Y, ARect.b.Y);
456
 
end;
457
 
 
458
 
procedure ExpandRect(var ARect: TRect; const APoint: TPoint);
459
 
begin
460
 
  NormalizeRect(ARect);
461
 
  UpdateMinMax(APoint.X, ARect.Left, ARect.Right);
462
 
  UpdateMinMax(APoint.Y, ARect.Top, ARect.Bottom);
463
 
end;
464
 
 
465
 
procedure ExpandRect(
466
 
  var ARect: TRect; const ACenter: TPoint; ARadius: Integer;
467
 
  AAngle1, AAngle2: Double);
468
 
var
469
 
  p: TPoint;
470
 
  i, j: Integer;
471
 
begin
472
 
  p := Point(ARadius, 0);
473
 
  EnsureOrder(AAngle1, AAngle2);
474
 
  ExpandRect(ARect, RotatePoint(p, AAngle1) + ACenter);
475
 
  ExpandRect(ARect, RotatePoint(p, AAngle2) + ACenter);
476
 
  j := Floor(AAngle1 / Pi * 2);
477
 
  for i := j to j + 4 do
478
 
    if InRange(Pi / 2 * i, AAngle1, AAngle2) then
479
 
      ExpandRect(ARect, RotatePoint(p, Pi / 2 * i) + ACenter);
480
 
end;
481
 
 
482
 
function GetIntervals(AMin, AMax: Double; AInverted: Boolean): TDoubleDynArray;
483
 
const
484
 
  INV_TO_SCALE: array [Boolean] of TAxisScale = (asIncreasing, asDecreasing);
485
 
  K = 1e-10;
486
 
var
487
 
  start, step, m, m1: Double;
488
 
  markCount: Integer;
489
 
begin
490
 
  CalculateIntervals(AMin, AMax, INV_TO_SCALE[AInverted], start, step);
491
 
  AMin -= step * K;
492
 
  AMax += step * K;
493
 
  if AInverted then
494
 
    step := - step;
495
 
  m := start;
496
 
  markCount := 0;
497
 
  while true do begin
498
 
    if InRange(m, AMin, AMax) then
499
 
      Inc(markCount)
500
 
    else if markCount > 0 then
501
 
      break;
502
 
    m1 := m + step;
503
 
    if m1 = m then break;
504
 
    m := m1;
505
 
  end;
506
 
  SetLength(Result, markCount);
507
 
  m := start;
508
 
  markCount := 0;
509
 
  while true do begin
510
 
    if Abs(m / step) < K then
511
 
      m := 0;
512
 
    if InRange(m, AMin, AMax) then begin
513
 
      Result[markCount] := m;
514
 
      Inc(markCount);
515
 
    end
516
 
    else if markCount > 0 then
517
 
      break;
518
 
    m1 := m + step;
519
 
    if m1 = m then break;
520
 
    m := m1;
521
 
  end;
 
364
function FormatIfNotEmpty(AFormat, AStr: String): String;
 
365
begin
 
366
  if AStr = '' then
 
367
    Result := ''
 
368
  else
 
369
    Result := Format(AFormat, [AStr]);
522
370
end;
523
371
 
524
372
function InterpolateRGB(AColor1, AColor2: Integer; ACoeff: Double): Integer;
535
383
    r[i] := Round(c1[i]  + (c2[i] - c1[i]) * ACoeff);
536
384
end;
537
385
 
538
 
function IsPointOnLine(const AP, A1, A2: TPoint): Boolean;
539
 
begin
540
 
  Result := IsPointInRect(AP, A1, A2) and (PointLineSide(AP, A1, A2) = 0);
541
 
end;
542
 
 
543
 
function IsPointInPolygon(
544
 
  const AP: TPoint; const APolygon: array of TPoint): Boolean;
545
 
var
546
 
  i, count: Integer;
547
 
  p1, p2: TPoint;
548
 
  s1, s2: TValueSign;
549
 
begin
550
 
  if Length(APolygon) = 0 then exit(false);
551
 
  p1 := APolygon[High(APolygon)];
552
 
  for i := 0 to High(APolygon) do begin
553
 
    p2 := APolygon[i];
554
 
    if IsPointOnLine(AP, p1, p2) then exit(true);
555
 
    p1 := p2;
556
 
  end;
557
 
  count := 0;
558
 
  p1 := APolygon[High(APolygon)];
559
 
  for i := 0 to High(APolygon) do begin
560
 
    p2 := APolygon[i];
561
 
    s1 := Sign(p1.Y - AP.Y);
562
 
    s2 := Sign(p2.Y - AP.Y);
563
 
    case s1 * s2 of
564
 
      -1: count += Ord(PointLineSide(AP, p1, p2) = Sign(p1.Y - p2.Y));
565
 
      0: if s1 + s2 = 1 then begin
566
 
        if s1 = 0 then
567
 
          count += Ord(p1.X >= AP.X)
568
 
        else
569
 
          count += Ord(p2.X >= AP.X)
570
 
      end;
571
 
    end;
572
 
    p1 := p2;
573
 
  end;
574
 
  Result := count mod 2 = 1;
575
 
end;
576
 
 
577
 
function IsPointInRect(const AP, A1, A2: TPoint): Boolean;
578
 
begin
579
 
  Result := SafeInRange(AP.X, A1.X, A2.X) and SafeInRange(AP.Y, A1.Y, A2.Y);
580
 
end;
581
 
 
582
 
function IsPointInRect(const AP: TPoint; const AR: TRect): Boolean;
583
 
begin
584
 
  Result :=
585
 
    SafeInRange(AP.X, AR.Left, AR.Right) and
586
 
    SafeInRange(AP.Y, AR.Top, AR.Bottom);
587
 
end;
588
 
 
589
 
function IsRectInRect(const AInner, AOuter: TRect): Boolean;
590
 
begin
591
 
  Result :=
592
 
    IsPointInRect(AInner.TopLeft, AOuter) and
593
 
    IsPointInRect(AInner.BottomRight, AOuter);
594
 
end;
595
 
 
596
 
function IsLineIntersectsLine(const AA, AB, AC, AD: TPoint): Boolean;
597
 
var
598
 
  sa, sb, sc, sd: TValueSign;
599
 
begin
600
 
  sa := PointLineSide(AA, AC, AD);
601
 
  sb := PointLineSide(AB, AC, AD);
602
 
  if (sa = 0) and (sb = 0) then
603
 
    // All points are on the same infinite line.
604
 
    Result :=
605
 
      IsPointInRect(AA, AC, AD) or IsPointInRect(AB, AC, AD) or
606
 
      IsPointInRect(AC, AA, AB) or IsPointInRect(AD, AA, AB)
607
 
  else begin
608
 
    sc := PointLineSide(AC, AA, AB);
609
 
    sd := PointLineSide(AD, AA, AB);
610
 
    Result := (sa * sb <= 0) and (sc * sd <= 0);
611
 
  end;
612
 
end;
613
 
 
614
 
function IsPolygonIntersectsPolygon(const AP1, AP2: array of TPoint): Boolean;
615
 
var
616
 
  i, j: Integer;
617
 
  p1, p2: TPoint;
618
 
begin
619
 
  if (Length(AP1) = 0) or (Length(AP2) = 0) then exit(false);
620
 
  if IsPointInPolygon(AP1[0], AP2) or IsPointInPolygon(AP2[0], AP1) then
621
 
    exit(true);
622
 
  for i := 0 to High(AP1) do begin
623
 
    p1 := AP1[i];
624
 
    p2 := AP1[(i + 1) mod Length(AP1)];
625
 
    for j := 0 to High(AP2) do
626
 
      if IsLineIntersectsLine(p1, p2, AP2[j], AP2[(j + 1) mod Length(AP2)]) then
627
 
        exit(true);
628
 
  end;
629
 
  Result := false;
630
 
end;
631
 
 
632
 
function LineIntersectsRect(
633
 
  var AA, AB: TDoublePoint; const ARect: TDoubleRect): Boolean;
634
 
var
635
 
  dx, dy: Double;
636
 
 
637
 
  procedure AdjustX(var AP: TDoublePoint; ANewX: Double); inline;
638
 
  begin
639
 
    AP.Y += dy / dx * (ANewX - AP.X);
640
 
    AP.X := ANewX;
641
 
  end;
642
 
 
643
 
  procedure AdjustY(var AP: TDoublePoint; ANewY: Double); inline;
644
 
  begin
645
 
    AP.X += dx / dy * (ANewY - AP.Y);
646
 
    AP.Y := ANewY;
647
 
  end;
648
 
 
649
 
begin
650
 
  dx := AB.X - AA.X;
651
 
  dy := AB.Y - AA.Y;
652
 
  case CASE_OF_TWO[AA.X < ARect.a.X, AB.X < ARect.a.X] of
653
 
    cotFirst: AdjustX(AA, ARect.a.X);
654
 
    cotSecond: AdjustX(AB, ARect.a.X);
655
 
    cotBoth: exit(false);
656
 
  end;
657
 
  case CASE_OF_TWO[AA.X > ARect.b.X, AB.X > ARect.b.X] of
658
 
    cotFirst: AdjustX(AA, ARect.b.X);
659
 
    cotSecond: AdjustX(AB, ARect.b.X);
660
 
    cotBoth: exit(false);
661
 
  end;
662
 
  case CASE_OF_TWO[AA.Y < ARect.a.Y, AB.Y < ARect.a.Y] of
663
 
    cotFirst: AdjustY(AA, ARect.a.Y);
664
 
    cotSecond: AdjustY(AB, ARect.a.Y);
665
 
    cotBoth: exit(false);
666
 
  end;
667
 
  case CASE_OF_TWO[AA.Y > ARect.b.Y, AB.Y > ARect.b.Y] of
668
 
    cotFirst: AdjustY(AA, ARect.b.Y);
669
 
    cotSecond: AdjustY(AB, ARect.b.Y);
670
 
    cotBoth: exit(false);
671
 
  end;
672
 
  Result := true;
673
 
end;
674
 
 
675
 
function MeasureRotatedRect(const ASize: TPoint; AAngle: Double): TSize;
676
 
var
677
 
  pt1, pt2: TPoint;
678
 
begin
679
 
  pt1 := RotatePoint(ASize, AAngle);
680
 
  pt2 := RotatePoint(Point(ASize.X, -ASize.Y), AAngle);
681
 
  Result.cx := Max(Abs(pt1.X), Abs(pt2.X));
682
 
  Result.cy := Max(Abs(pt1.Y), Abs(pt2.Y));
683
 
end;
684
 
 
685
 
procedure NormalizeRect(var ARect: TRect);
686
 
begin
687
 
  with ARect do begin
688
 
    EnsureOrder(Left, Right);
689
 
    EnsureOrder(Top, Bottom);
690
 
  end;
691
 
end;
692
 
 
693
 
procedure NormalizeRect(var ARect: TDoubleRect); overload;
694
 
begin
695
 
  with ARect do begin
696
 
    EnsureOrder(a.X, b.X);
697
 
    EnsureOrder(a.Y, b.Y);
698
 
  end;
 
386
function IntToColorHex(AColor: Integer): String;
 
387
begin
 
388
  if AColor = clTAColor then
 
389
    Result := '?'
 
390
  else
 
391
    Result := '$' + IntToHex(AColor, 6);
 
392
end;
 
393
 
 
394
function IsEquivalent(const A1, A2: Double): Boolean;
 
395
begin
 
396
  Result := CompareDWord(A1, A2, SizeOf(A1) div SizeOf(DWord)) = 0;
 
397
end;
 
398
 
 
399
function IsNan(const APoint: TDoublePoint): Boolean;
 
400
begin
 
401
  Result := IsNan(APoint.X) or IsNan(APoint.Y);
 
402
end;
 
403
 
 
404
function NumberOr(ANum: Double; ADefault: Double): Double;
 
405
begin
 
406
  Result := IfThen(IsNan(ANum), ADefault, ANum);
699
407
end;
700
408
 
701
409
function OrientToRad(AOrient: Integer): Double;
703
411
  Result := DegToRad(AOrient / ORIENTATION_UNITS_PER_DEG);
704
412
end;
705
413
 
706
 
function PointDist(const A, B: TPoint): Integer;
707
 
begin
708
 
  Result := Min(Sqr(Int64(A.X) - B.X) + Sqr(Int64(A.Y) - B.Y), MaxInt);
709
 
end;
710
 
 
711
 
function PointDistX(const A, B: TPoint): Integer;
712
 
begin
713
 
  Result := Min(Abs(Int64(A.X) - B.X), MaxInt);
714
 
end;
715
 
 
716
 
function PointDistY(const A, B: TPoint): Integer; inline;
717
 
begin
718
 
  Result := Min(Abs(Int64(A.Y) - B.Y), MaxInt);
719
 
end;
720
 
 
721
 
function PointLineSide(AP, A1, A2: TPoint): TValueSign;
722
 
var
723
 
  a1x, a1y: Int64;
724
 
begin
725
 
  a1x := A1.X;
726
 
  a1y := A1.Y;
727
 
  Result := Sign((AP.X - a1x) * (A2.Y - a1y) - (AP.Y - a1y) * (A2.X - a1x));
728
 
end;
729
 
 
730
 
function ProjToRect(
731
 
  const APt: TDoublePoint; const ARect: TDoubleRect): TDoublePoint;
732
 
begin
733
 
  Result.X := EnsureRange(APt.X, ARect.a.X, ARect.b.X);
734
 
  Result.Y := EnsureRange(APt.Y, ARect.a.Y, ARect.b.Y);
735
 
end;
736
 
 
737
414
function RadToDeg16(ARad: Double): Integer;
738
415
begin
739
416
  Result := Round(RadToDeg(ARad) * 16);
744
421
  Result := Round(RadToDeg(ARad)) * ORIENTATION_UNITS_PER_DEG;
745
422
end;
746
423
 
747
 
function RectIntersectsRect(
748
 
  var ARect: TDoubleRect; const AFixed: TDoubleRect): Boolean;
749
 
 
750
 
  function RangesIntersect(L1, R1, L2, R2: Double; out L, R: Double): Boolean;
751
 
  begin
752
 
    EnsureOrder(L1, R1);
753
 
    EnsureOrder(L2, R2);
754
 
    L := Max(L1, L2);
755
 
    R := Min(R1, R2);
756
 
    Result := L <= R;
757
 
  end;
758
 
 
759
 
begin
760
 
  with ARect do
761
 
    Result :=
762
 
      RangesIntersect(a.X, b.X, AFixed.a.X, AFixed.b.X, a.X, b.X) and
763
 
      RangesIntersect(a.Y, b.Y, AFixed.a.Y, AFixed.b.Y, a.Y, b.Y);
764
 
end;
765
 
 
766
 
function RotatePoint(const APoint: TDoublePoint; AAngle: Double): TDoublePoint;
767
 
var
768
 
  sa, ca: Extended;
769
 
begin
770
 
  SinCos(AAngle, sa, ca);
771
 
  Result.X := ca * APoint.X - sa * APoint.Y;
772
 
  Result.Y := sa * APoint.X + ca * APoint.Y;
773
 
end;
774
 
 
775
 
function RotatePoint(const APoint: TPoint; AAngle: Double): TPoint;
776
 
var
777
 
  sa, ca: Extended;
778
 
begin
779
 
  SinCos(AAngle, sa, ca);
780
 
  Result.X := Round(ca * APoint.X - sa * APoint.Y);
781
 
  Result.Y := Round(sa * APoint.X + ca * APoint.Y);
782
 
end;
783
 
 
784
424
function RoundChecked(A: Double): Integer;
785
425
begin
786
426
  Result := Round(EnsureRange(A, -MaxInt, MaxInt));
787
427
end;
788
428
 
789
 
function SafeInfinity: Double;
 
429
procedure SetPropDefaults(AObject: TPersistent; APropNames: array of String);
 
430
var
 
431
  n: String;
 
432
  p: PPropInfo;
790
433
begin
791
 
  {$IFOPT R+}{$DEFINE RangeChecking}{$ELSE}{$UNDEF RangeChecking}{$ENDIF}
792
 
  {$IFOPT Q+}{$DEFINE OverflowChecking}{$ELSE}{$UNDEF OverflowChecking}{$ENDIF}
793
 
  {$R-}{$Q-}
794
 
  Result := Infinity;
795
 
  {$IFDEF OverflowChecking}{$Q+}{$ENDIF}{$IFDEF RangeChecking}{$R+}{$ENDIF}
 
434
  for n in APropNames do begin
 
435
    p := GetPropInfo(AObject, n);
 
436
    SetOrdProp(AObject, p, p^.Default);
 
437
  end;
796
438
end;
797
439
 
798
 
function SafeInRange(AValue, ABound1, ABound2: Double): Boolean;
 
440
var
 
441
  DefSeparatorSettings: TFormatSettings;
 
442
 
 
443
function StrToFloatDefSep(const AStr: String): Double;
799
444
begin
800
 
  EnsureOrder(ABound1, ABound2);
801
 
  Result := InRange(AValue, ABound1, ABound2);
 
445
  if
 
446
    not TryStrToFloat(AStr, Result, DefSeparatorSettings) and
 
447
    not TryStrToFloat(AStr, Result)
 
448
  then
 
449
    Result := 0.0;
802
450
end;
803
451
 
804
452
{$HINTS OFF}
813
461
 
814
462
procedure UpdateMinMax(AValue: Double; var AMin, AMax: Double);
815
463
begin
 
464
  if IsNan(AValue) then exit;
816
465
  if AValue < AMin then
817
466
    AMin := AValue;
818
467
  if AValue > AMax then
827
476
    AMax := AValue;
828
477
end;
829
478
 
830
 
operator + (const A: TPoint; B: TSize): TPoint;
831
 
begin
832
 
  Result.X := A.X + B.cx;
833
 
  Result.Y := A.Y + B.cy;
834
 
end;
835
 
 
836
 
operator + (const A, B: TPoint): TPoint;
837
 
begin
838
 
  Result.X := A.X + B.X;
839
 
  Result.Y := A.Y + B.Y;
840
 
end;
841
 
 
842
 
operator + (const A, B: TDoublePoint): TDoublePoint;
843
 
begin
844
 
  Result.X := A.X + B.X;
845
 
  Result.Y := A.Y + B.Y;
846
 
end;
847
 
 
848
 
operator - (const A: TPoint): TPoint;
849
 
begin
850
 
  Result.X := - A.X;
851
 
  Result.Y := - A.Y;
852
 
end;
853
 
 
854
 
operator - (const A, B: TPoint): TPoint;
855
 
begin
856
 
  Result.X := A.X - B.X;
857
 
  Result.Y := A.Y - B.Y;
858
 
end;
859
 
 
860
 
operator - (const A, B: TDoublePoint): TDoublePoint;
861
 
begin
862
 
  Result.X := A.X - B.X;
863
 
  Result.Y := A.Y - B.Y;
864
 
end;
865
 
 
866
 
operator div(const A: TPoint; ADivisor: Integer): TPoint;
867
 
begin
868
 
  Result.X := A.X div ADivisor;
869
 
  Result.Y := A.Y div ADivisor;
870
 
end;
871
 
 
872
 
operator * (const A: TPoint; AMultiplier: Integer): TPoint;
873
 
begin
874
 
  Result.X := A.X * AMultiplier;
875
 
  Result.Y := A.Y * AMultiplier;
876
 
end;
877
 
 
878
 
operator * (const A, B: TPoint): TPoint;
879
 
begin
880
 
  Result.X := A.X * B.X;
881
 
  Result.Y := A.Y * B.Y;
882
 
end;
883
 
 
884
 
operator * (const A, B: TDoublePoint): TDoublePoint;
885
 
begin
886
 
  Result.X := A.X * B.X;
887
 
  Result.Y := A.Y * B.Y;
888
 
end;
889
 
 
890
 
operator / (const A, B: TDoublePoint): TDoublePoint;
891
 
begin
892
 
  Result.X := A.X / B.X;
893
 
  Result.Y := A.Y / B.Y;
 
479
function WeightedAverage(AX1, AX2, ACoeff: Double): Double;
 
480
begin
 
481
  Result := AX1 * (1 - ACoeff) + AX2 * ACoeff;
894
482
end;
895
483
 
896
484
operator = (const A, B: TMethod): Boolean;
898
486
  Result := (A.Code = B.Code) and (A.Data = B.Data);
899
487
end;
900
488
 
901
 
operator := (const APoint: TPoint): TSize;
902
 
begin
903
 
  Result.cx := APoint.X;
904
 
  Result.cy := APoint.Y;
905
 
end;
906
 
 
907
 
operator := (const ASize: TSize): TPoint;
908
 
begin
909
 
  Result.X := ASize.cx;
910
 
  Result.Y := ASize.cy;
 
489
{ TTypedFPListEnumerator }
 
490
 
 
491
function TTypedFPListEnumerator.GetCurrent: T;
 
492
begin
 
493
  Result := T(inherited GetCurrent);
 
494
end;
 
495
 
 
496
{ TIndexedComponentList }
 
497
 
 
498
procedure TIndexedComponentList.ChangeNamePrefix(
 
499
  const AOld, ANew: String);
 
500
var
 
501
  failed: String;
 
502
  i: Integer;
 
503
begin
 
504
  failed := '';
 
505
  for i := 0 to Count - 1 do
 
506
    TIndexedComponent(Items[i]).ChangeNamePrefix(AOld, ANew, failed);
 
507
  if (failed <> '') and Assigned(ShowMessageProc) then
 
508
    ShowMessageProc(Format(tasFailedSubcomponentRename, [failed]));
 
509
end;
 
510
 
 
511
{ TIndexedComponent }
 
512
 
 
513
procedure TIndexedComponent.ChangeNamePrefix(
 
514
  const AOld, ANew: String; var AFailed: String);
 
515
begin
 
516
  if AnsiStartsStr(AOld, Name) then
 
517
    try
 
518
      Name := ANew + Copy(Name, Length(AOld) + 1, Length(Name));
 
519
    except on EComponentError do
 
520
      AFailed += IfThen(AFailed = '', '', ', ') + Name;
 
521
    end;
911
522
end;
912
523
 
913
524
{ TIntervalList }
947
558
  Changed;
948
559
end;
949
560
 
 
561
procedure TIntervalList.Assign(ASource: TIntervalList);
 
562
begin
 
563
  FEpsilon := ASource.FEpsilon;
 
564
  FIntervals := Copy(ASource.FIntervals);
 
565
end;
 
566
 
950
567
procedure TIntervalList.Changed;
951
568
begin
952
569
  if Assigned(FOnChange) then
1038
655
procedure TListener.Forget;
1039
656
begin
1040
657
  FBroadcaster := nil;
1041
 
  FRef^ := nil;
 
658
  if FRef <> nil then
 
659
    FRef^ := nil;
1042
660
end;
1043
661
 
1044
662
function TListener.GetIsListening: Boolean;
1048
666
 
1049
667
procedure TListener.Notify(ASender: TObject);
1050
668
begin
1051
 
  FOnNotify(ASender)
 
669
  if Assigned(FOnNotify) then
 
670
    FOnNotify(ASender)
1052
671
end;
1053
672
 
1054
673
{ TBroadcaster }
1055
674
 
1056
675
procedure TBroadcaster.Broadcast(ASender: TObject);
1057
676
var
1058
 
  i: Integer;
 
677
  p: Pointer;
1059
678
begin
1060
 
  for i := 0 to Count - 1 do
1061
 
    TListener(Items[i]).Notify(ASender);
 
679
  if Locked then exit;
 
680
  for p in Self do
 
681
    TListener(p).Notify(ASender);
1062
682
end;
1063
683
 
1064
684
destructor TBroadcaster.Destroy;
1065
685
var
1066
 
  i: Integer;
 
686
  p: Pointer;
1067
687
begin
1068
 
  for i := 0 to Count - 1 do
1069
 
    TListener(Items[i]).Forget;
 
688
  for p in Self do
 
689
    TListener(p).Forget;
1070
690
  inherited;
1071
691
end;
1072
692
 
1160
780
  Result := nil;
1161
781
end;
1162
782
 
 
783
{ TPublishedIntegerSet }
 
784
 
 
785
function TPublishedIntegerSet.AsBooleans(ACount: Integer): TBooleanDynArray;
 
786
var
 
787
  i: Integer;
 
788
begin
 
789
  SetLength(Result, ACount);
 
790
  if ACount = 0 then exit;
 
791
  if AllSet then
 
792
    FillChar(Result[0], Length(Result), true)
 
793
  else
 
794
    for i in FData do
 
795
      if InRange(i, 0, High(Result)) then
 
796
        Result[i] := true;
 
797
end;
 
798
 
 
799
function TPublishedIntegerSet.GetAsString: String;
 
800
var
 
801
  i: Integer;
 
802
begin
 
803
  if AllSet then
 
804
    Result := PUB_INT_SET_ALL
 
805
  else if Length(FData) = 0 then
 
806
    Result := PUB_INT_SET_EMPTY
 
807
  else begin
 
808
    Result := IntToStr(FData[0]);
 
809
    for i := 1 to High(FData) do
 
810
      Result += ',' + IntToStr(FData[i]);
 
811
  end;
 
812
end;
 
813
 
 
814
function TPublishedIntegerSet.GetIsSet(AIndex: Integer): Boolean;
 
815
var
 
816
  i: Integer;
 
817
begin
 
818
  Result := true;
 
819
  if AllSet then exit;
 
820
  for i in FData do
 
821
    if i = AIndex then exit;
 
822
  Result := false;
 
823
end;
 
824
 
 
825
constructor TPublishedIntegerSet.Init;
 
826
begin
 
827
  FAllSet := true;
 
828
end;
 
829
 
 
830
procedure TPublishedIntegerSet.SetAllSet(AValue: Boolean);
 
831
begin
 
832
  if FAllSet = AValue then exit;
 
833
  FAllSet := AValue;
 
834
  if FAllSet then
 
835
    SetLength(FData, 0);
 
836
end;
 
837
 
 
838
procedure TPublishedIntegerSet.SetAsString(AValue: String);
 
839
var
 
840
  sl: TStringList;
 
841
  i, p: Integer;
 
842
  s: String;
 
843
begin
 
844
  AllSet := AValue = PUB_INT_SET_ALL;
 
845
  if AllSet then exit;
 
846
  sl := TStringList.Create;
 
847
  try
 
848
    sl.CommaText := AValue;
 
849
    SetLength(FData, sl.Count);
 
850
    i := 0;
 
851
    for s in sl do
 
852
      if TryStrToInt(s, p) then begin
 
853
        FData[i] := p;
 
854
        i += 1;
 
855
      end;
 
856
  finally
 
857
    sl.Free;
 
858
  end;
 
859
  SetLength(FData, i);
 
860
end;
 
861
 
 
862
procedure TPublishedIntegerSet.SetIsSet(AIndex: Integer; AValue: Boolean);
 
863
var
 
864
  i, j: Integer;
 
865
begin
 
866
  if AllSet or (IsSet[AIndex] = AValue) then exit;
 
867
  if AValue then begin
 
868
    SetLength(FData, Length(FData) + 1);
 
869
    FData[High(FData)] := AIndex;
 
870
  end
 
871
  else begin
 
872
    j := 0;
 
873
    for i := 0 to High(FData) do
 
874
      if FData[i] <> AIndex then begin
 
875
        FData[j] := FData[i];
 
876
        j += 1;
 
877
      end;
 
878
    SetLength(FData, j);
 
879
  end;
 
880
end;
 
881
 
1163
882
initialization
1164
883
 
1165
884
  DrawData := TDrawDataRegistry.Create;
 
885
  DefSeparatorSettings := DefaultFormatSettings;
 
886
  DefSeparatorSettings.DecimalSeparator := '.';
1166
887
 
1167
888
finalization
1168
889