← Back to branch summary

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

« back to all changes in this revision

Viewing changes to components/fpvectorial/fpvectorial.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/fpvectorial/fpvectorial.pas
 
1
{
 
2
fpvectorial.pas
 
3
 
 
4
Vector graphics document
 
5
 
 
6
License: The same modified LGPL as the Free Pascal RTL
 
7
         See the file COPYING.modifiedLGPL for more details
 
8
 
 
9
AUTHORS: Felipe Monteiro de Carvalho
 
10
         Pedro Sol Pegorini L de Lima
 
11
}
 
12
unit fpvectorial;
 
13
 
 
14
{$ifdef fpc}
 
15
  {$mode delphi}
 
16
{$endif}
 
17
 
 
18
{$define USE_LCL_CANVAS}
 
19
 
 
20
interface
 
21
 
 
22
uses
 
23
  Classes, SysUtils, Math,
 
24
  // FCL-Image
 
25
  fpcanvas, fpimage
 
26
  // LCL
 
27
  {$ifdef USE_LCL_CANVAS}
 
28
  , Graphics, LCLIntf, LCLType
 
29
  {$endif}
 
30
  ;
 
31
 
 
32
type
 
33
  TvVectorialFormat = (
 
34
    { Multi-purpose document formats }
 
35
    vfPDF, vfSVG, vfCorelDrawCDR, vfWindowsMetafileWMF,
 
36
    { CAD formats }
 
37
    vfDXF,
 
38
    { Geospatial formats }
 
39
    vfLAS,
 
40
    { Printing formats }
 
41
    vfPostScript, vfEncapsulatedPostScript,
 
42
    { GCode formats }
 
43
    vfGCodeAvisoCNCPrototipoV5, vfGCodeAvisoCNCPrototipoV6,
 
44
    { Other formats }
 
45
    vfRAW
 
46
    );
 
47
 
 
48
const
 
49
  { Default extensions }
 
50
  { Multi-purpose document formats }
 
51
  STR_PDF_EXTENSION = '.pdf';
 
52
  STR_POSTSCRIPT_EXTENSION = '.ps';
 
53
  STR_SVG_EXTENSION = '.svg';
 
54
  STR_CORELDRAW_EXTENSION = '.cdr';
 
55
  STR_WINMETAFILE_EXTENSION = '.wmf';
 
56
  STR_AUTOCAD_EXCHANGE_EXTENSION = '.dxf';
 
57
  STR_ENCAPSULATEDPOSTSCRIPT_EXTENSION = '.eps';
 
58
  STR_LAS_EXTENSION = '.las';
 
59
  STR_RAW_EXTENSION = '.raw';
 
60
 
 
61
type
 
62
  TvCustomVectorialWriter = class;
 
63
  TvCustomVectorialReader = class;
 
64
  TvVectorialPage = class;
 
65
 
 
66
  { Pen, Brush and Font }
 
67
 
 
68
  TvPen = record
 
69
    Color: TFPColor;
 
70
    Style: TFPPenStyle;
 
71
    Width: Integer;
 
72
  end;
 
73
 
 
74
  TvBrush = record
 
75
    Color: TFPColor;
 
76
    Style: TFPBrushStyle;
 
77
  end;
 
78
 
 
79
  TvFont = record
 
80
    Color: TFPColor;
 
81
    Size: integer;
 
82
    Name: utf8string;
 
83
    {@@
 
84
      Font orientation is measured in degrees and uses the
 
85
      same direction as the LCL TFont.orientation, which is counter-clockwise.
 
86
      Zero is the normal, horizontal, orientation, directed to the right.
 
87
    }
 
88
    Orientation: Double;
 
89
  end;
 
90
 
 
91
  { Coordinates and polyline segments }
 
92
 
 
93
  T3DPoint = record
 
94
    X, Y, Z: Double;
 
95
  end;
 
96
 
 
97
  P3DPoint = ^T3DPoint;
 
98
 
 
99
  TSegmentType = (
 
100
    st2DLine, st2DLineWithPen, st2DBezier,
 
101
    st3DLine, st3DBezier, stMoveTo);
 
102
 
 
103
  {@@
 
104
    The coordinates in fpvectorial are given in millimiters and
 
105
    the starting point is in the bottom-left corner of the document.
 
106
    The X grows to the right and the Y grows to the top.
 
107
  }
 
108
  { TPathSegment }
 
109
 
 
110
  TPathSegment = class
 
111
  public
 
112
    SegmentType: TSegmentType;
 
113
    // Fields for linking the list
 
114
    Previous: TPathSegment;
 
115
    Next: TPathSegment;
 
116
  end;
 
117
 
 
118
  {@@
 
119
    In a 2D segment, the X and Y coordinates represent usually the
 
120
    final point of the segment, being that it starts where the previous
 
121
    segment ends. The exception is for the first segment of all, which simply
 
122
    holds the starting point for the drawing and should always be of the type
 
123
    stMoveTo.
 
124
  }
 
125
  T2DSegment = class(TPathSegment)
 
126
  public
 
127
    X, Y: Double;
 
128
  end;
 
129
 
 
130
  T2DSegmentWithPen = class(T2DSegment)
 
131
  public
 
132
    Pen: TvPen;
 
133
  end;
 
134
 
 
135
  {@@
 
136
    In Bezier segments, we remain using the X and Y coordinates for the ending point.
 
137
    The starting point is where the previous segment ended, so that the intermediary
 
138
    bezier control points are [X2, Y2] and [X3, Y3].
 
139
  }
 
140
  T2DBezierSegment = class(T2DSegment)
 
141
  public
 
142
    X2, Y2: Double;
 
143
    X3, Y3: Double;
 
144
  end;
 
145
 
 
146
  T3DSegment = class(TPathSegment)
 
147
  public
 
148
    {@@
 
149
      Coordinates of the end of the segment.
 
150
      For the first segment, this is the starting point.
 
151
    }
 
152
    X, Y, Z: Double;
 
153
  end;
 
154
 
 
155
  T3DBezierSegment = class(T3DSegment)
 
156
  public
 
157
    X2, Y2, Z2: Double;
 
158
    X3, Y3, Z3: Double;
 
159
  end;
 
160
 
 
161
  TvFindEntityResult = (vfrNotFound, vfrFound, vfrSubpartFound);
 
162
 
 
163
  { Now all elements }
 
164
 
 
165
  {@@
 
166
    All elements should derive from TvEntity, regardless of whatever properties
 
167
    they might contain.
 
168
  }
 
169
 
 
170
  { TvEntity }
 
171
 
 
172
  TvEntity = class
 
173
  public
 
174
    X, Y, Z: Double;
 
175
    constructor Create; virtual;
 
176
    procedure CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double); virtual;
 
177
    procedure ExpandBoundingBox(var ALeft, ATop, ARight, ABottom: Double);
 
178
    {@@ ASubpart is only valid if this routine returns vfrSubpartFound }
 
179
    function TryToSelect(APos: TPoint; var ASubpart: Cardinal): TvFindEntityResult; virtual;
 
180
    procedure Move(ADeltaX, ADeltaY: Integer); virtual;
 
181
    procedure MoveSubpart(ADeltaX, ADeltaY: Integer; ASubpart: Cardinal); virtual;
 
182
    procedure Render(ADest: TFPCustomCanvas; ADestX: Integer = 0;
 
183
      ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); virtual;
 
184
    function GetNormalizedPos(APage: TvVectorialPage; ANewMin, ANewMax: Double): T3DPoint;
 
185
  end;
 
186
 
 
187
  { TvEntityWithPen }
 
188
 
 
189
  TvEntityWithPen = class(TvEntity)
 
190
  public
 
191
    {@@ The global Pen for the entire entity. In the case of paths, individual
 
192
        elements might be able to override this setting. }
 
193
    Pen: TvPen;
 
194
    constructor Create; override;
 
195
  end;
 
196
 
 
197
  { TvEntityWithPenAndBrush }
 
198
 
 
199
  TvEntityWithPenAndBrush = class(TvEntityWithPen)
 
200
  public
 
201
    {@@ The global Brush for the entire entity. In the case of paths, individual
 
202
        elements might be able to override this setting. }
 
203
    Brush: TvBrush;
 
204
    constructor Create; override;
 
205
  end;
 
206
 
 
207
  TvClipMode = (vcmNonzeroWindingRule, vcmEvenOddRule);
 
208
 
 
209
  TPath = class(TvEntityWithPenAndBrush)
 
210
  public
 
211
    Len: Integer;
 
212
    Points: TPathSegment;   // Beginning of the double-linked list
 
213
    PointsEnd: TPathSegment;// End of the double-linked list
 
214
    CurPoint: TPathSegment; // Used in PrepareForSequentialReading and Next
 
215
    ClipPath: TPath;
 
216
    ClipMode: TvClipMode;
 
217
    procedure Assign(ASource: TPath);
 
218
    procedure PrepareForSequentialReading;
 
219
    function Next(): TPathSegment;
 
220
    procedure CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double); override;
 
221
    procedure AppendSegment(ASegment: TPathSegment);
 
222
  end;
 
223
 
 
224
  {@@
 
225
    TvText represents a text entity.
 
226
  }
 
227
 
 
228
  { TvText }
 
229
 
 
230
  TvText = class(TvEntityWithPenAndBrush)
 
231
  public
 
232
    Value: TStringList;
 
233
    Font: TvFont;
 
234
    constructor Create; override;
 
235
    destructor Destroy; override;
 
236
    function TryToSelect(APos: TPoint; var ASubpart: Cardinal): TvFindEntityResult; override;
 
237
  end;
 
238
 
 
239
  {@@
 
240
  }
 
241
  TvCircle = class(TvEntityWithPenAndBrush)
 
242
  public
 
243
    Radius: Double;
 
244
  end;
 
245
 
 
246
  {@@
 
247
  }
 
248
  TvCircularArc = class(TvEntityWithPenAndBrush)
 
249
  public
 
250
    Radius: Double;
 
251
    {@@ The Angle is measured in degrees in relation to the positive X axis }
 
252
    StartAngle, EndAngle: Double;
 
253
  end;
 
254
 
 
255
  {@@
 
256
  }
 
257
 
 
258
  { TvEllipse }
 
259
 
 
260
  TvEllipse = class(TvEntityWithPenAndBrush)
 
261
  public
 
262
    // Mandatory fields
 
263
    HorzHalfAxis: Double; // This half-axis is the horizontal one when Angle=0
 
264
    VertHalfAxis: Double; // This half-axis is the vertical one when Angle=0
 
265
    {@@ The Angle is measured in degrees in relation to the positive X axis }
 
266
    Angle: Double;
 
267
    procedure CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double); override;
 
268
    procedure Render(ADest: TFPCustomCanvas; ADestX: Integer = 0;
 
269
      ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); override;
 
270
  end;
 
271
 
 
272
  {@@
 
273
   The brush has no effect in this class
 
274
 
 
275
   DimensionLeft ---text--- DimensionRight
 
276
                 |        |
 
277
                 |        | BaseRight
 
278
                 |
 
279
                 | BaseLeft
 
280
  }
 
281
 
 
282
  { TvAlignedDimension }
 
283
 
 
284
  TvAlignedDimension = class(TvEntityWithPenAndBrush)
 
285
  public
 
286
    // Mandatory fields
 
287
    BaseLeft, BaseRight, DimensionLeft, DimensionRight: T3DPoint;
 
288
  end;
 
289
 
 
290
  {@@
 
291
   Vectorial images can contain raster images inside them and this entity
 
292
   represents this.
 
293
 
 
294
   If the Width and Height differ from the same data in the image, then
 
295
   the raster image will be stretched.
 
296
 
 
297
   Note that TFPCustomImage does not implement a storage, so the property
 
298
   RasterImage should be filled with either a FPImage.TFPMemoryImage or with
 
299
   a TLazIntfImage. The property RasterImage might be nil.
 
300
  }
 
301
 
 
302
  { TvRasterImage }
 
303
 
 
304
  TvRasterImage = class(TvEntity)
 
305
  public
 
306
    RasterImage: TFPCustomImage;
 
307
    Top, Left, Width, Height: Double;
 
308
    procedure InitializeWithConvertionOf3DPointsToHeightMap(APage: TvVectorialPage; AWidth, AHeight: Integer);
 
309
  end;
 
310
 
 
311
  { TvPoint }
 
312
 
 
313
  TvPoint = class(TvEntityWithPen)
 
314
  public
 
315
  end;
 
316
 
 
317
  TvProgressEvent = procedure (APercentage: Byte) of object;
 
318
 
 
319
  { TvVectorialDocument }
 
320
 
 
321
  TvVectorialDocument = class
 
322
  private
 
323
    FOnProgress: TvProgressEvent;
 
324
    FPages: TFPList;
 
325
    FCurrentPageIndex: Integer;
 
326
    function CreateVectorialWriter(AFormat: TvVectorialFormat): TvCustomVectorialWriter;
 
327
    function CreateVectorialReader(AFormat: TvVectorialFormat): TvCustomVectorialReader;
 
328
  public
 
329
    Width, Height: Double; // in millimeters
 
330
    Name: string;
 
331
    // User-Interface information
 
332
    ZoomLevel: Double; // 1 = 100%
 
333
    { Selection fields }
 
334
    SelectedvElement: TvEntity;
 
335
    { Base methods }
 
336
    constructor Create; virtual;
 
337
    destructor Destroy; override;
 
338
    procedure Assign(ASource: TvVectorialDocument);
 
339
    procedure AssignTo(ADest: TvVectorialDocument);
 
340
    procedure WriteToFile(AFileName: string; AFormat: TvVectorialFormat); overload;
 
341
    procedure WriteToFile(AFileName: string); overload;
 
342
    procedure WriteToStream(AStream: TStream; AFormat: TvVectorialFormat);
 
343
    procedure WriteToStrings(AStrings: TStrings; AFormat: TvVectorialFormat);
 
344
    procedure ReadFromFile(AFileName: string; AFormat: TvVectorialFormat); overload;
 
345
    procedure ReadFromFile(AFileName: string); overload;
 
346
    procedure ReadFromStream(AStream: TStream; AFormat: TvVectorialFormat);
 
347
    procedure ReadFromStrings(AStrings: TStrings; AFormat: TvVectorialFormat);
 
348
    class function GetFormatFromExtension(AFileName: string): TvVectorialFormat;
 
349
    function  GetDetailedFileFormat(): string;
 
350
    procedure GuessDocumentSize();
 
351
    procedure GuessGoodZoomLevel(AScreenSize: Integer = 500);
 
352
    { Page methods }
 
353
    function GetPage(AIndex: Integer): TvVectorialPage;
 
354
    function GetPageCount: Integer;
 
355
    function GetCurrentPage: TvVectorialPage;
 
356
    procedure SetCurrentPage(AIndex: Integer);
 
357
    function AddPage(): TvVectorialPage;
 
358
    { Data removing methods }
 
359
    procedure Clear; virtual;
 
360
    { Events }
 
361
    property OnProgress: TvProgressEvent read FOnProgress write FOnprogress;
 
362
  end;
 
363
 
 
364
  { TvVectorialPage }
 
365
 
 
366
  TvVectorialPage = class
 
367
  private
 
368
    FEntities: TFPList; // of TvEntity
 
369
    FTmpPath: TPath;
 
370
    FTmpText: TvText;
 
371
    //procedure RemoveCallback(data, arg: pointer);
 
372
    procedure ClearTmpPath();
 
373
    procedure AppendSegmentToTmpPath(ASegment: TPathSegment);
 
374
    procedure CallbackDeleteEntity(data,arg:pointer);
 
375
  public
 
376
    // Document size for page-based documents
 
377
    Width, Height: Double; // in millimeters
 
378
    // Document size for other documents
 
379
    MinX, MinY, MinZ, MaxX, MaxY, MaxZ: Double;
 
380
    Owner: TvVectorialDocument;
 
381
    { Base methods }
 
382
    constructor Create(AOwner: TvVectorialDocument); virtual;
 
383
    destructor Destroy; override;
 
384
    procedure Assign(ASource: TvVectorialPage);
 
385
    { Data reading methods }
 
386
    function  GetEntity(ANum: Cardinal): TvEntity;
 
387
    function  GetEntitiesCount: Integer;
 
388
    function  FindAndSelectEntity(Pos: TPoint): TvFindEntityResult;
 
389
    { Data removing methods }
 
390
    procedure Clear; virtual;
 
391
    function  DeleteEntity(AIndex: Cardinal): Boolean;
 
392
    function  RemoveEntity(AEntity: TvEntity; AFreeAfterRemove: Boolean = True): Boolean;
 
393
    { Data writing methods }
 
394
    function AddEntity(AEntity: TvEntity): Integer;
 
395
    procedure AddPathCopyMem(APath: TPath);
 
396
    procedure StartPath(AX, AY: Double); overload;
 
397
    procedure StartPath(); overload;
 
398
    procedure AddMoveToPath(AX, AY: Double);
 
399
    procedure AddLineToPath(AX, AY: Double); overload;
 
400
    procedure AddLineToPath(AX, AY: Double; AColor: TFPColor); overload;
 
401
    procedure AddLineToPath(AX, AY, AZ: Double); overload;
 
402
    procedure GetCurrentPathPenPos(var AX, AY: Double);
 
403
    procedure AddBezierToPath(AX1, AY1, AX2, AY2, AX3, AY3: Double); overload;
 
404
    procedure AddBezierToPath(AX1, AY1, AZ1, AX2, AY2, AZ2, AX3, AY3, AZ3: Double); overload;
 
405
    procedure SetBrushColor(AColor: TFPColor);
 
406
    procedure SetBrushStyle(AStyle: TFPBrushStyle);
 
407
    procedure SetPenColor(AColor: TFPColor);
 
408
    procedure SetPenStyle(AStyle: TFPPenStyle);
 
409
    procedure SetPenWidth(AWidth: Integer);
 
410
    procedure SetClipPath(AClipPath: TPath; AClipMode: TvClipMode);
 
411
    procedure EndPath();
 
412
    procedure AddText(AX, AY, AZ: Double; FontName: string; FontSize: integer; AText: utf8string); overload;
 
413
    procedure AddText(AX, AY: Double; AStr: utf8string); overload;
 
414
    procedure AddText(AX, AY, AZ: Double; AStr: utf8string); overload;
 
415
    procedure AddCircle(ACenterX, ACenterY, ARadius: Double);
 
416
    procedure AddCircularArc(ACenterX, ACenterY, ARadius, AStartAngle, AEndAngle: Double; AColor: TFPColor);
 
417
    procedure AddEllipse(CenterX, CenterY, HorzHalfAxis, VertHalfAxis, Angle: Double);
 
418
    // Dimensions
 
419
    procedure AddAlignedDimension(BaseLeft, BaseRight, DimLeft, DimRight: T3DPoint);
 
420
    //
 
421
    function AddPoint(AX, AY, AZ: Double): TvPoint;
 
422
  end;
 
423
 
 
424
  {@@ TvVectorialReader class reference type }
 
425
 
 
426
  TvVectorialReaderClass = class of TvCustomVectorialReader;
 
427
 
 
428
  { TvCustomVectorialReader }
 
429
 
 
430
  TvCustomVectorialReader = class
 
431
  public
 
432
    { General reading methods }
 
433
    constructor Create; virtual;
 
434
    procedure ReadFromFile(AFileName: string; AData: TvVectorialDocument); virtual;
 
435
    procedure ReadFromStream(AStream: TStream; AData: TvVectorialDocument); virtual;
 
436
    procedure ReadFromStrings(AStrings: TStrings; AData: TvVectorialDocument); virtual;
 
437
  end;
 
438
 
 
439
  {@@ TvVectorialWriter class reference type }
 
440
 
 
441
  TvVectorialWriterClass = class of TvCustomVectorialWriter;
 
442
 
 
443
  {@@ TvCustomVectorialWriter }
 
444
 
 
445
  { TvCustomVectorialWriter }
 
446
 
 
447
  TvCustomVectorialWriter = class
 
448
  public
 
449
    { General writing methods }
 
450
    constructor Create; virtual;
 
451
    procedure WriteToFile(AFileName: string; AData: TvVectorialDocument); virtual;
 
452
    procedure WriteToStream(AStream: TStream; AData: TvVectorialDocument); virtual;
 
453
    procedure WriteToStrings(AStrings: TStrings; AData: TvVectorialDocument); virtual;
 
454
  end;
 
455
 
 
456
  {@@ List of registered formats }
 
457
 
 
458
  TvVectorialFormatData = record
 
459
    ReaderClass: TvVectorialReaderClass;
 
460
    WriterClass: TvVectorialWriterClass;
 
461
    ReaderRegistered: Boolean;
 
462
    WriterRegistered: Boolean;
 
463
    Format: TvVectorialFormat;
 
464
  end;
 
465
 
 
466
var
 
467
  GvVectorialFormats: array of TvVectorialFormatData;
 
468
 
 
469
procedure RegisterVectorialReader(
 
470
  AReaderClass: TvVectorialReaderClass;
 
471
  AFormat: TvVectorialFormat);
 
472
procedure RegisterVectorialWriter(
 
473
  AWriterClass: TvVectorialWriterClass;
 
474
  AFormat: TvVectorialFormat);
 
475
function Make2DPoint(AX, AY: Double): T3DPoint;
 
476
 
 
477
implementation
 
478
 
 
479
uses fpvutils;
 
480
 
 
481
const
 
482
  Str_Error_Nil_Path = ' The program attempted to add a segment before creating a path';
 
483
 
 
484
{@@
 
485
  Registers a new reader for a format
 
486
}
 
487
procedure RegisterVectorialReader(
 
488
  AReaderClass: TvVectorialReaderClass;
 
489
  AFormat: TvVectorialFormat);
 
490
var
 
491
  i, len: Integer;
 
492
  FormatInTheList: Boolean;
 
493
begin
 
494
  len := Length(GvVectorialFormats);
 
495
  FormatInTheList := False;
 
496
 
 
497
  { First search for the format in the list }
 
498
  for i := 0 to len - 1 do
 
499
  begin
 
500
    if GvVectorialFormats[i].Format = AFormat then
 
501
    begin
 
502
      if GvVectorialFormats[i].ReaderRegistered then
 
503
       raise Exception.Create('RegisterVectorialReader: Reader class for format ' {+ AFormat} + ' already registered.');
 
504
 
 
505
      GvVectorialFormats[i].ReaderRegistered := True;
 
506
      GvVectorialFormats[i].ReaderClass := AReaderClass;
 
507
 
 
508
      FormatInTheList := True;
 
509
      Break;
 
510
    end;
 
511
  end;
 
512
 
 
513
  { If not already in the list, then add it }
 
514
  if not FormatInTheList then
 
515
  begin
 
516
    SetLength(GvVectorialFormats, len + 1);
 
517
 
 
518
    GvVectorialFormats[len].ReaderClass := AReaderClass;
 
519
    GvVectorialFormats[len].WriterClass := nil;
 
520
    GvVectorialFormats[len].ReaderRegistered := True;
 
521
    GvVectorialFormats[len].WriterRegistered := False;
 
522
    GvVectorialFormats[len].Format := AFormat;
 
523
  end;
 
524
end;
 
525
 
 
526
{@@
 
527
  Registers a new writer for a format
 
528
}
 
529
procedure RegisterVectorialWriter(
 
530
  AWriterClass: TvVectorialWriterClass;
 
531
  AFormat: TvVectorialFormat);
 
532
var
 
533
  i, len: Integer;
 
534
  FormatInTheList: Boolean;
 
535
begin
 
536
  len := Length(GvVectorialFormats);
 
537
  FormatInTheList := False;
 
538
 
 
539
  { First search for the format in the list }
 
540
  for i := 0 to len - 1 do
 
541
  begin
 
542
    if GvVectorialFormats[i].Format = AFormat then
 
543
    begin
 
544
      if GvVectorialFormats[i].WriterRegistered then
 
545
       raise Exception.Create('RegisterVectorialWriter: Writer class for format ' + {AFormat +} ' already registered.');
 
546
 
 
547
      GvVectorialFormats[i].WriterRegistered := True;
 
548
      GvVectorialFormats[i].WriterClass := AWriterClass;
 
549
 
 
550
      FormatInTheList := True;
 
551
      Break;
 
552
    end;
 
553
  end;
 
554
 
 
555
  { If not already in the list, then add it }
 
556
  if not FormatInTheList then
 
557
  begin
 
558
    SetLength(GvVectorialFormats, len + 1);
 
559
 
 
560
    GvVectorialFormats[len].ReaderClass := nil;
 
561
    GvVectorialFormats[len].WriterClass := AWriterClass;
 
562
    GvVectorialFormats[len].ReaderRegistered := False;
 
563
    GvVectorialFormats[len].WriterRegistered := True;
 
564
    GvVectorialFormats[len].Format := AFormat;
 
565
  end;
 
566
end;
 
567
 
 
568
function Make2DPoint(AX, AY: Double): T3DPoint;
 
569
begin
 
570
  Result.X := AX;
 
571
  Result.Y := AY;
 
572
  Result.Z := 0;
 
573
end;
 
574
 
 
575
{ TvRasterImage }
 
576
 
 
577
procedure TvRasterImage.InitializeWithConvertionOf3DPointsToHeightMap(APage: TvVectorialPage; AWidth, AHeight: Integer);
 
578
var
 
579
  lEntity: TvEntity;
 
580
  i: Integer;
 
581
  lPos: TPoint;
 
582
  lValue: TFPColor;
 
583
  PreviousValue: Word;
 
584
  PreviousCount: Integer;
 
585
begin
 
586
  // First setup the map and initialize it
 
587
  if RasterImage <> nil then RasterImage.Free;
 
588
  RasterImage := TFPMemoryImage.create(AWidth, AHeight);
 
589
 
 
590
  // Now go through all points and attempt to fit them to our grid
 
591
  for i := 0 to APage.GetEntitiesCount - 1 do
 
592
  begin
 
593
    lEntity := APage.GetEntity(i);
 
594
    if lEntity is TvPoint then
 
595
    begin
 
596
      lPos.X := Round((lEntity.X - APage.MinX) * AWidth / (APage.MaxX - APage.MinX));
 
597
      lPos.Y := Round((lEntity.Y - APage.MinY) * AHeight / (APage.MaxY - APage.MinY));
 
598
 
 
599
      if lPos.X >= AWidth then lPos.X := AWidth-1;
 
600
      if lPos.Y >= AHeight then lPos.Y := AHeight-1;
 
601
      if lPos.X < 0 then lPos.X := 0;
 
602
      if lPos.Y < 0 then lPos.Y := 0;
 
603
 
 
604
      // Calculate the height of this point
 
605
      PreviousValue := lValue.Red;
 
606
      lValue.Red := Round((lEntity.Z - APage.MinZ) * $FFFF / (APage.MaxZ - APage.MinZ));
 
607
 
 
608
      // And apply it as a fraction of the total number of points which fall in this square
 
609
      // we store the number of points in the Alpha channel
 
610
      PreviousCount := lValue.Alpha div $100;
 
611
      lValue.Red := Round((PreviousCount * PreviousValue + lValue.Red) / (PreviousCount + 1));
 
612
 
 
613
      lValue.Green := lValue.Red;
 
614
      lValue.Blue := lValue.Red;
 
615
      lValue.Alpha := lValue.Alpha + $100;
 
616
      //lValue.alpha:=;
 
617
      RasterImage.Colors[lPos.X, lPos.Y] := lValue;
 
618
    end;
 
619
  end;
 
620
end;
 
621
 
 
622
constructor TvEntityWithPen.Create;
 
623
begin
 
624
  inherited Create;
 
625
  Pen.Style := psSolid;
 
626
  Pen.Color := colBlack;
 
627
end;
 
628
 
 
629
{ TvEntityWithPenAndBrush }
 
630
 
 
631
constructor TvEntityWithPenAndBrush.Create;
 
632
begin
 
633
  inherited Create;
 
634
  Brush.Style := bsClear;
 
635
  Brush.Color := colBlue;
 
636
end;
 
637
 
 
638
{ TvVectorialPage }
 
639
 
 
640
procedure TvVectorialPage.ClearTmpPath;
 
641
var
 
642
  segment, oldsegment: TPathSegment;
 
643
begin
 
644
  FTmpPath.Points := nil;
 
645
  FTmpPath.PointsEnd := nil;
 
646
  FTmpPath.Len := 0;
 
647
  FTmpPath.Brush.Color := colBlue;
 
648
  FTmpPath.Brush.Style := bsClear;
 
649
  FTmpPath.Pen.Color := colBlack;
 
650
  FTmpPath.Pen.Style := psSolid;
 
651
  FTmpPath.Pen.Width := 1;
 
652
end;
 
653
 
 
654
procedure TvVectorialPage.AppendSegmentToTmpPath(ASegment: TPathSegment);
 
655
begin
 
656
  FTmpPath.AppendSegment(ASegment);
 
657
end;
 
658
 
 
659
procedure TvVectorialPage.CallbackDeleteEntity(data, arg: pointer);
 
660
begin
 
661
  if (data <> nil) then
 
662
    TvEntity(data).Free;
 
663
end;
 
664
 
 
665
constructor TvVectorialPage.Create(AOwner: TvVectorialDocument);
 
666
begin
 
667
  inherited Create;
 
668
 
 
669
  FEntities := TFPList.Create;
 
670
  FTmpPath := TPath.Create;
 
671
  Owner := AOwner;
 
672
end;
 
673
 
 
674
destructor TvVectorialPage.Destroy;
 
675
begin
 
676
  Clear;
 
677
 
 
678
  FEntities.Free;
 
679
 
 
680
  inherited Destroy;
 
681
end;
 
682
 
 
683
procedure TvVectorialPage.Assign(ASource: TvVectorialPage);
 
684
var
 
685
  i: Integer;
 
686
begin
 
687
  Clear;
 
688
 
 
689
  for i := 0 to ASource.GetEntitiesCount - 1 do
 
690
    Self.AddEntity(ASource.GetEntity(i));
 
691
end;
 
692
 
 
693
function TvVectorialPage.GetEntity(ANum: Cardinal): TvEntity;
 
694
begin
 
695
  if ANum >= FEntities.Count then raise Exception.Create('TvVectorialDocument.GetEntity: Entity number out of bounds');
 
696
 
 
697
  Result := TvEntity(FEntities.Items[ANum]);
 
698
 
 
699
  if Result = nil then raise Exception.Create('TvVectorialDocument.GetEntity: Invalid Entity number');
 
700
end;
 
701
 
 
702
function TvVectorialPage.GetEntitiesCount: Integer;
 
703
begin
 
704
  Result := FEntities.Count;
 
705
end;
 
706
 
 
707
function TvVectorialPage.FindAndSelectEntity(Pos: TPoint): TvFindEntityResult;
 
708
var
 
709
  lEntity: TvEntity;
 
710
  i: Integer;
 
711
  lSubpart: Cardinal;
 
712
begin
 
713
  Result := vfrNotFound;
 
714
 
 
715
  for i := 0 to GetEntitiesCount() - 1 do
 
716
  begin
 
717
    lEntity := GetEntity(i);
 
718
 
 
719
    Result := lEntity.TryToSelect(Pos, lSubpart);
 
720
 
 
721
    if Result <> vfrNotFound then
 
722
    begin
 
723
      Owner.SelectedvElement := lEntity;
 
724
      Exit;
 
725
    end;
 
726
  end;
 
727
end;
 
728
 
 
729
procedure TvVectorialPage.Clear;
 
730
begin
 
731
  FEntities.ForEachCall(CallbackDeleteEntity, nil);
 
732
  FEntities.Clear();
 
733
end;
 
734
 
 
735
{@@
 
736
  Returns if the entity was really deleted or false if there is no entity with this index
 
737
}
 
738
function TvVectorialPage.DeleteEntity(AIndex: Cardinal): Boolean;
 
739
var
 
740
  lEntity: TvEntity;
 
741
begin
 
742
  Result := False;
 
743
  if AIndex >= GetEntitiesCount() then Exit;;
 
744
  lEntity := GetEntity(AIndex);
 
745
  if lEntity = nil then Exit;
 
746
  FEntities.Delete(AIndex);
 
747
  lEntity.Free;
 
748
  Result := True;
 
749
end;
 
750
 
 
751
function TvVectorialPage.RemoveEntity(AEntity: TvEntity; AFreeAfterRemove: Boolean = True): Boolean;
 
752
begin
 
753
  Result := False;
 
754
  if AEntity = nil then Exit;
 
755
  FEntities.Remove(AEntity);
 
756
  if AFreeAfterRemove then AEntity.Free;
 
757
  Result := True;
 
758
end;
 
759
 
 
760
{@@
 
761
  Adds an entity to the document and returns it's current index
 
762
}
 
763
function TvVectorialPage.AddEntity(AEntity: TvEntity): Integer;
 
764
begin
 
765
  Result := FEntities.Count;
 
766
  FEntities.Add(Pointer(AEntity));
 
767
end;
 
768
 
 
769
procedure TvVectorialPage.AddPathCopyMem(APath: TPath);
 
770
var
 
771
  lPath: TPath;
 
772
  Len: Integer;
 
773
begin
 
774
  lPath := TPath.Create;
 
775
  lPath.Assign(APath);
 
776
  AddEntity(lPath);
 
777
  //WriteLn(':>TvVectorialDocument.AddPath 1 Len = ', Len);
 
778
end;
 
779
 
 
780
{@@
 
781
  Starts writing a Path in multiple steps.
 
782
  Should be followed by zero or more calls to AddPointToPath
 
783
  and by a call to EndPath to effectively add the data.
 
784
 
 
785
  @see    EndPath, AddPointToPath
 
786
}
 
787
procedure TvVectorialPage.StartPath(AX, AY: Double);
 
788
var
 
789
  segment: T2DSegment;
 
790
begin
 
791
  ClearTmpPath();
 
792
 
 
793
  FTmpPath.Len := 1;
 
794
  segment := T2DSegment.Create;
 
795
  segment.SegmentType := stMoveTo;
 
796
  segment.X := AX;
 
797
  segment.Y := AY;
 
798
 
 
799
  FTmpPath.Points := segment;
 
800
  FTmpPath.PointsEnd := segment;
 
801
end;
 
802
 
 
803
procedure TvVectorialPage.StartPath;
 
804
begin
 
805
  ClearTmpPath();
 
806
end;
 
807
 
 
808
procedure TvVectorialPage.AddMoveToPath(AX, AY: Double);
 
809
var
 
810
  segment: T2DSegment;
 
811
begin
 
812
  segment := T2DSegment.Create;
 
813
  segment.SegmentType := stMoveTo;
 
814
  segment.X := AX;
 
815
  segment.Y := AY;
 
816
 
 
817
  AppendSegmentToTmpPath(segment);
 
818
end;
 
819
 
 
820
{@@
 
821
  Adds one more point to the end of a Path being
 
822
  writing in multiple steps.
 
823
 
 
824
  Does nothing if not called between StartPath and EndPath.
 
825
 
 
826
  Can be called multiple times to add multiple points.
 
827
 
 
828
  @see    StartPath, EndPath
 
829
}
 
830
procedure TvVectorialPage.AddLineToPath(AX, AY: Double);
 
831
var
 
832
  segment: T2DSegment;
 
833
begin
 
834
  segment := T2DSegment.Create;
 
835
  segment.SegmentType := st2DLine;
 
836
  segment.X := AX;
 
837
  segment.Y := AY;
 
838
 
 
839
  AppendSegmentToTmpPath(segment);
 
840
end;
 
841
 
 
842
procedure TvVectorialPage.AddLineToPath(AX, AY: Double; AColor: TFPColor);
 
843
var
 
844
  segment: T2DSegmentWithPen;
 
845
begin
 
846
  segment := T2DSegmentWithPen.Create;
 
847
  segment.SegmentType := st2DLineWithPen;
 
848
  segment.X := AX;
 
849
  segment.Y := AY;
 
850
  segment.Pen.Color := AColor;
 
851
 
 
852
  AppendSegmentToTmpPath(segment);
 
853
end;
 
854
 
 
855
procedure TvVectorialPage.AddLineToPath(AX, AY, AZ: Double);
 
856
var
 
857
  segment: T3DSegment;
 
858
begin
 
859
  segment := T3DSegment.Create;
 
860
  segment.SegmentType := st3DLine;
 
861
  segment.X := AX;
 
862
  segment.Y := AY;
 
863
  segment.Z := AZ;
 
864
 
 
865
  AppendSegmentToTmpPath(segment);
 
866
end;
 
867
 
 
868
{@@
 
869
  Gets the current Pen Pos in the temporary path
 
870
}
 
871
procedure TvVectorialPage.GetCurrentPathPenPos(var AX, AY: Double);
 
872
begin
 
873
  // Check if we are the first segment in the tmp path
 
874
  if FTmpPath.PointsEnd = nil then raise Exception.Create('[TvVectorialDocument.GetCurrentPathPenPos] One cannot obtain the Pen Pos if there are no segments in the temporary path');
 
875
 
 
876
  AX := T2DSegment(FTmpPath.PointsEnd).X;
 
877
  AY := T2DSegment(FTmpPath.PointsEnd).Y;
 
878
end;
 
879
 
 
880
{@@
 
881
  Adds a bezier element to the path. It starts where the previous element ended
 
882
  and it goes throw the control points [AX1, AY1] and [AX2, AY2] and ends
 
883
  in [AX3, AY3].
 
884
}
 
885
procedure TvVectorialPage.AddBezierToPath(AX1, AY1, AX2, AY2, AX3, AY3: Double);
 
886
var
 
887
  segment: T2DBezierSegment;
 
888
begin
 
889
  segment := T2DBezierSegment.Create;
 
890
  segment.SegmentType := st2DBezier;
 
891
  segment.X := AX3;
 
892
  segment.Y := AY3;
 
893
  segment.X2 := AX1;
 
894
  segment.Y2 := AY1;
 
895
  segment.X3 := AX2;
 
896
  segment.Y3 := AY2;
 
897
 
 
898
  AppendSegmentToTmpPath(segment);
 
899
end;
 
900
 
 
901
procedure TvVectorialPage.AddBezierToPath(AX1, AY1, AZ1, AX2, AY2, AZ2, AX3, AY3, AZ3: Double);
 
902
var
 
903
  segment: T3DBezierSegment;
 
904
begin
 
905
  segment := T3DBezierSegment.Create;
 
906
  segment.SegmentType := st3DBezier;
 
907
  segment.X := AX3;
 
908
  segment.Y := AY3;
 
909
  segment.Z := AZ3;
 
910
  segment.X2 := AX1;
 
911
  segment.Y2 := AY1;
 
912
  segment.Z2 := AZ1;
 
913
  segment.X3 := AX2;
 
914
  segment.Y3 := AY2;
 
915
  segment.Z3 := AZ2;
 
916
 
 
917
  AppendSegmentToTmpPath(segment);
 
918
end;
 
919
 
 
920
procedure TvVectorialPage.SetBrushColor(AColor: TFPColor);
 
921
begin
 
922
  FTmPPath.Brush.Color := AColor;
 
923
end;
 
924
 
 
925
procedure TvVectorialPage.SetBrushStyle(AStyle: TFPBrushStyle);
 
926
begin
 
927
  FTmPPath.Brush.Style := AStyle;
 
928
end;
 
929
 
 
930
procedure TvVectorialPage.SetPenColor(AColor: TFPColor);
 
931
begin
 
932
  FTmPPath.Pen.Color := AColor;
 
933
end;
 
934
 
 
935
procedure TvVectorialPage.SetPenStyle(AStyle: TFPPenStyle);
 
936
begin
 
937
  FTmPPath.Pen.Style := AStyle;
 
938
end;
 
939
 
 
940
procedure TvVectorialPage.SetPenWidth(AWidth: Integer);
 
941
begin
 
942
  FTmPPath.Pen.Width := AWidth;
 
943
end;
 
944
 
 
945
procedure TvVectorialPage.SetClipPath(AClipPath: TPath; AClipMode: TvClipMode);
 
946
begin
 
947
  FTmPPath.ClipPath := AClipPath;
 
948
  FTmPPath.ClipMode := AClipMode;
 
949
end;
 
950
 
 
951
{@@
 
952
  Finishes writing a Path, which was created in multiple
 
953
  steps using StartPath and AddPointToPath,
 
954
  to the document.
 
955
 
 
956
  Does nothing if there wasn't a previous correspondent call to
 
957
  StartPath.
 
958
 
 
959
  @see    StartPath, AddPointToPath
 
960
}
 
961
procedure TvVectorialPage.EndPath;
 
962
begin
 
963
  if FTmPPath.Len = 0 then Exit;
 
964
  AddPathCopyMem(FTmPPath);
 
965
  ClearTmpPath();
 
966
end;
 
967
 
 
968
procedure TvVectorialPage.AddText(AX, AY, AZ: Double; FontName: string;
 
969
  FontSize: integer; AText: utf8string);
 
970
var
 
971
  lText: TvText;
 
972
begin
 
973
  lText := TvText.Create;
 
974
  lText.Value.Text := AText;
 
975
  lText.X := AX;
 
976
  lText.Y := AY;
 
977
  lText.Z := AZ;
 
978
  lText.Font.Name := FontName;
 
979
  lText.Font.Size := FontSize;
 
980
  AddEntity(lText);
 
981
end;
 
982
 
 
983
procedure TvVectorialPage.AddText(AX, AY: Double; AStr: utf8string);
 
984
begin
 
985
  AddText(AX, AY, 0, '', 10, AStr);
 
986
end;
 
987
 
 
988
procedure TvVectorialPage.AddText(AX, AY, AZ: Double; AStr: utf8string);
 
989
begin
 
990
  AddText(AX, AY, AZ, '', 10, AStr);
 
991
end;
 
992
 
 
993
procedure TvVectorialPage.AddCircle(ACenterX, ACenterY, ARadius: Double);
 
994
var
 
995
  lCircle: TvCircle;
 
996
begin
 
997
  lCircle := TvCircle.Create;
 
998
  lCircle.X := ACenterX;
 
999
  lCircle.Y := ACenterY;
 
1000
  lCircle.Radius := ARadius;
 
1001
  AddEntity(lCircle);
 
1002
end;
 
1003
 
 
1004
procedure TvVectorialPage.AddCircularArc(ACenterX, ACenterY, ARadius,
 
1005
  AStartAngle, AEndAngle: Double; AColor: TFPColor);
 
1006
var
 
1007
  lCircularArc: TvCircularArc;
 
1008
begin
 
1009
  lCircularArc := TvCircularArc.Create;
 
1010
  lCircularArc.X := ACenterX;
 
1011
  lCircularArc.Y := ACenterY;
 
1012
  lCircularArc.Radius := ARadius;
 
1013
  lCircularArc.StartAngle := AStartAngle;
 
1014
  lCircularArc.EndAngle := AEndAngle;
 
1015
  lCircularArc.Pen.Color := AColor;
 
1016
  AddEntity(lCircularArc);
 
1017
end;
 
1018
 
 
1019
procedure TvVectorialPage.AddEllipse(CenterX, CenterY, HorzHalfAxis,
 
1020
  VertHalfAxis, Angle: Double);
 
1021
var
 
1022
  lEllipse: TvEllipse;
 
1023
begin
 
1024
  lEllipse := TvEllipse.Create;
 
1025
  lEllipse.X := CenterX;
 
1026
  lEllipse.Y := CenterY;
 
1027
  lEllipse.HorzHalfAxis := HorzHalfAxis;
 
1028
  lEllipse.VertHalfAxis := VertHalfAxis;
 
1029
  lEllipse.Angle := Angle;
 
1030
  AddEntity(lEllipse);
 
1031
end;
 
1032
 
 
1033
 
 
1034
procedure TvVectorialPage.AddAlignedDimension(BaseLeft, BaseRight, DimLeft,
 
1035
  DimRight: T3DPoint);
 
1036
var
 
1037
  lDim: TvAlignedDimension;
 
1038
begin
 
1039
  lDim := TvAlignedDimension.Create;
 
1040
  lDim.BaseLeft := BaseLeft;
 
1041
  lDim.BaseRight := BaseRight;
 
1042
  lDim.DimensionLeft := DimLeft;
 
1043
  lDim.DimensionRight := DimRight;
 
1044
  AddEntity(lDim);
 
1045
end;
 
1046
 
 
1047
function TvVectorialPage.AddPoint(AX, AY, AZ: Double): TvPoint;
 
1048
var
 
1049
  lPoint: TvPoint;
 
1050
begin
 
1051
  lPoint := TvPoint.Create;
 
1052
  lPoint.X := AX;
 
1053
  lPoint.Y := AY;
 
1054
  lPoint.Z := AZ;
 
1055
  AddEntity(lPoint);
 
1056
  Result := lPoint;
 
1057
end;
 
1058
 
 
1059
{ TvText }
 
1060
 
 
1061
constructor TvText.Create;
 
1062
begin
 
1063
  inherited Create;
 
1064
  Value := TStringList.Create;
 
1065
end;
 
1066
 
 
1067
destructor TvText.Destroy;
 
1068
begin
 
1069
  Value.Free;
 
1070
  inherited Destroy;
 
1071
end;
 
1072
 
 
1073
function TvText.TryToSelect(APos: TPoint; var ASubpart: Cardinal): TvFindEntityResult;
 
1074
var
 
1075
  lProximityFactor: Integer;
 
1076
begin
 
1077
  lProximityFactor := 5;
 
1078
  if (APos.X > X - lProximityFactor) and (APos.X < X + lProximityFactor)
 
1079
    and (APos.Y > Y - lProximityFactor) and (APos.Y < Y + lProximityFactor) then
 
1080
    Result := vfrFound
 
1081
  else Result := vfrNotFound;
 
1082
end;
 
1083
 
 
1084
{ TvEntity }
 
1085
 
 
1086
constructor TvEntity.Create;
 
1087
begin
 
1088
end;
 
1089
 
 
1090
procedure TvEntity.CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double);
 
1091
begin
 
1092
  ALeft := 0;
 
1093
  ATop := 0;
 
1094
  ARight := 0;
 
1095
  ABottom := 0;
 
1096
end;
 
1097
 
 
1098
procedure TvEntity.ExpandBoundingBox(var ALeft, ATop, ARight, ABottom: Double);
 
1099
var
 
1100
  lLeft, lTop, lRight, lBottom: Double;
 
1101
begin
 
1102
  CalculateBoundingBox(lLeft, lTop, lRight, lBottom);
 
1103
  if lLeft < ALeft then ALeft := lLeft;
 
1104
  if lTop < ATop then ATop := lTop;
 
1105
  if lRight > ARight then ARight := lRight;
 
1106
  if lBottom > ABottom then ABottom := lBottom;
 
1107
end;
 
1108
 
 
1109
function TvEntity.TryToSelect(APos: TPoint; var ASubpart: Cardinal): TvFindEntityResult;
 
1110
begin
 
1111
  Result := vfrNotFound;
 
1112
end;
 
1113
 
 
1114
procedure TvEntity.Move(ADeltaX, ADeltaY: Integer);
 
1115
begin
 
1116
  X := X + ADeltaX;
 
1117
  Y := Y + ADeltaY;
 
1118
end;
 
1119
 
 
1120
procedure TvEntity.MoveSubpart(ADeltaX, ADeltaY: Integer;
 
1121
  ASubpart: Cardinal);
 
1122
begin
 
1123
 
 
1124
end;
 
1125
 
 
1126
procedure TvEntity.Render(ADest: TFPCustomCanvas; ADestX: Integer;
 
1127
  ADestY: Integer; AMulX: Double; AMulY: Double);
 
1128
begin
 
1129
 
 
1130
end;
 
1131
 
 
1132
function TvEntity.GetNormalizedPos(APage: TvVectorialPage; ANewMin,
 
1133
  ANewMax: Double): T3DPoint;
 
1134
begin
 
1135
  Result.X := (X - APage.MinX) * (ANewMax - ANewMin) / (APage.MaxX - APage.MinX) + ANewMin;
 
1136
  Result.Y := (Y - APage.MinY) * (ANewMax - ANewMin) / (APage.MaxY - APage.MinY) + ANewMin;
 
1137
  Result.Z := (Z - APage.MinZ) * (ANewMax - ANewMin) / (APage.MaxZ - APage.MinZ) + ANewMin;
 
1138
end;
 
1139
 
 
1140
{ TvEllipse }
 
1141
 
 
1142
procedure TvEllipse.CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double);
 
1143
var
 
1144
  t, tmp: Double;
 
1145
begin
 
1146
  // First do the trivial
 
1147
  ALeft := X - HorzHalfAxis;
 
1148
  ARight := X + HorzHalfAxis;
 
1149
  ATop := Y - VertHalfAxis;
 
1150
  ABottom := Y + VertHalfAxis;
 
1151
  {
 
1152
    To calculate the bounding rectangle we can do this:
 
1153
 
 
1154
    Ellipse equations:You could try using the parametrized equations for an ellipse rotated at an arbitrary angle:
 
1155
 
 
1156
    x = CenterX + MajorHalfAxis*cos(t)*cos(Angle) - MinorHalfAxis*sin(t)*sin(Angle)
 
1157
    y = CenterY + MinorHalfAxis*sin(t)*cos(Angle) + MajorHalfAxis*cos(t)*sin(Angle)
 
1158
 
 
1159
    You can then differentiate and solve for gradient = 0:
 
1160
    0 = dx/dt = -MajorHalfAxis*sin(t)*cos(Angle) - MinorHalfAxis*cos(t)*sin(Angle)
 
1161
    =>
 
1162
    tan(t) = -MinorHalfAxis*tan(Angle)/MajorHalfAxis
 
1163
    =>
 
1164
    t = cotang(-MinorHalfAxis*tan(Angle)/MajorHalfAxis)
 
1165
 
 
1166
    On the other axis:
 
1167
 
 
1168
    0 = dy/dt = b*cos(t)*cos(phi) - a*sin(t)*sin(phi)
 
1169
    =>
 
1170
    tan(t) = b*cot(phi)/a
 
1171
  }
 
1172
  if Angle <> 0.0 then
 
1173
  begin
 
1174
    t := cotan(-VertHalfAxis*tan(Angle)/HorzHalfAxis);
 
1175
    tmp := X + HorzHalfAxis*cos(t)*cos(Angle) - VertHalfAxis*sin(t)*sin(Angle);
 
1176
    ARight := Round(tmp);
 
1177
  end;
 
1178
end;
 
1179
 
 
1180
procedure TvEllipse.Render(ADest: TFPCustomCanvas; ADestX: Integer;
 
1181
  ADestY: Integer; AMulX: Double; AMulY: Double);
 
1182
 
 
1183
  function CoordToCanvasX(ACoord: Double): Integer;
 
1184
  begin
 
1185
    Result := Round(ADestX + AmulX * ACoord);
 
1186
  end;
 
1187
 
 
1188
  function CoordToCanvasY(ACoord: Double): Integer;
 
1189
  begin
 
1190
    Result := Round(ADestY + AmulY * ACoord);
 
1191
  end;
 
1192
 
 
1193
var
 
1194
  PointList: array[0..6] of TPoint;
 
1195
  f: TPoint;
 
1196
  dk, x1, x2, y1, y2: Integer;
 
1197
  fx1, fy1, fx2, fy2: Double;
 
1198
  {$ifdef USE_LCL_CANVAS}
 
1199
  ALCLDest: TCanvas absolute ADest;
 
1200
  {$endif}
 
1201
begin
 
1202
  CalculateBoundingBox(fx1, fy1, fx2, fy2);
 
1203
  x1 := CoordToCanvasX(fx1);
 
1204
  x2 := CoordToCanvasX(fx2);
 
1205
  y1 := CoordToCanvasY(fy1);
 
1206
  y2 := CoordToCanvasY(fy2);
 
1207
 
 
1208
  {$ifdef USE_LCL_CANVAS}
 
1209
  if Angle <> 0 then
 
1210
  begin
 
1211
    dk := Round(0.654 * Abs(y2-y1));
 
1212
    f.x := Round(X);
 
1213
    f.y := Round(Y - 1);
 
1214
    PointList[0] := Rotate2DPoint(Point(x1, f.y), f, Angle) ;  // Startpoint
 
1215
    PointList[1] := Rotate2DPoint(Point(x1,  f.y - dk), f, Angle);
 
1216
    //Controlpoint of Startpoint first part
 
1217
    PointList[2] := Rotate2DPoint(Point(x2- 1,  f.y - dk), f, Angle);
 
1218
    //Controlpoint of secondpoint first part
 
1219
    PointList[3] := Rotate2DPoint(Point(x2 -1 , f.y), f, Angle);
 
1220
    // Firstpoint of secondpart
 
1221
    PointList[4] := Rotate2DPoint(Point(x2-1 , f.y + dk), f, Angle);
 
1222
    // Controllpoint of secondpart firstpoint
 
1223
    PointList[5] := Rotate2DPoint(Point(x1, f.y +  dk), f, Angle);
 
1224
    // Conrollpoint of secondpart endpoint
 
1225
    PointList[6] := PointList[0];   // Endpoint of
 
1226
     // Back to the startpoint
 
1227
    ALCLDest.PolyBezier(Pointlist[0]);
 
1228
  end
 
1229
  else
 
1230
  {$endif}
 
1231
  begin
 
1232
    ADest.Pen.Style := psSolid;
 
1233
    ADest.Pen.FPColor := colBlack;
 
1234
    ADest.Ellipse(x1, y1, x2, y2);
 
1235
  end;
 
1236
end;
 
1237
 
 
1238
{ TsWorksheet }
 
1239
 
 
1240
{@@
 
1241
  Constructor.
 
1242
}
 
1243
constructor TvVectorialDocument.Create;
 
1244
begin
 
1245
  inherited Create;
 
1246
 
 
1247
  FPages := TFPList.Create;
 
1248
  FCurrentPageIndex := -1;
 
1249
end;
 
1250
 
 
1251
{@@
 
1252
  Destructor.
 
1253
}
 
1254
destructor TvVectorialDocument.Destroy;
 
1255
begin
 
1256
  Clear;
 
1257
 
 
1258
  FPages.Free;
 
1259
 
 
1260
  inherited Destroy;
 
1261
end;
 
1262
 
 
1263
procedure TvVectorialDocument.Assign(ASource: TvVectorialDocument);
 
1264
//var
 
1265
//  i: Integer;
 
1266
begin
 
1267
//  Clear;
 
1268
//
 
1269
//  for i := 0 to ASource.GetEntitiesCount - 1 do
 
1270
//    Self.AddEntity(ASource.GetEntity(i));
 
1271
end;
 
1272
 
 
1273
procedure TvVectorialDocument.AssignTo(ADest: TvVectorialDocument);
 
1274
begin
 
1275
  ADest.Assign(Self);
 
1276
end;
 
1277
 
 
1278
{@@
 
1279
  Convenience method which creates the correct
 
1280
  writer object for a given vector graphics document format.
 
1281
}
 
1282
function TvVectorialDocument.CreateVectorialWriter(AFormat: TvVectorialFormat): TvCustomVectorialWriter;
 
1283
var
 
1284
  i: Integer;
 
1285
begin
 
1286
  Result := nil;
 
1287
 
 
1288
  for i := 0 to Length(GvVectorialFormats) - 1 do
 
1289
    if GvVectorialFormats[i].Format = AFormat then
 
1290
    begin
 
1291
      if GvVectorialFormats[i].WriterClass <> nil then
 
1292
        Result := GvVectorialFormats[i].WriterClass.Create;
 
1293
 
 
1294
      Break;
 
1295
    end;
 
1296
 
 
1297
  if Result = nil then raise Exception.Create('Unsupported vector graphics format.');
 
1298
end;
 
1299
 
 
1300
{@@
 
1301
  Convenience method which creates the correct
 
1302
  reader object for a given vector graphics document format.
 
1303
}
 
1304
function TvVectorialDocument.CreateVectorialReader(AFormat: TvVectorialFormat): TvCustomVectorialReader;
 
1305
var
 
1306
  i: Integer;
 
1307
begin
 
1308
  Result := nil;
 
1309
 
 
1310
  for i := 0 to Length(GvVectorialFormats) - 1 do
 
1311
    if GvVectorialFormats[i].Format = AFormat then
 
1312
    begin
 
1313
      if GvVectorialFormats[i].ReaderClass <> nil then
 
1314
        Result := GvVectorialFormats[i].ReaderClass.Create;
 
1315
 
 
1316
      Break;
 
1317
    end;
 
1318
 
 
1319
  if Result = nil then raise Exception.Create('Unsupported vector graphics format.');
 
1320
end;
 
1321
 
 
1322
{@@
 
1323
  Writes the document to a file.
 
1324
 
 
1325
  If the file doesn't exist, it will be created.
 
1326
}
 
1327
procedure TvVectorialDocument.WriteToFile(AFileName: string; AFormat: TvVectorialFormat);
 
1328
var
 
1329
  AWriter: TvCustomVectorialWriter;
 
1330
begin
 
1331
  AWriter := CreateVectorialWriter(AFormat);
 
1332
 
 
1333
  try
 
1334
    AWriter.WriteToFile(AFileName, Self);
 
1335
  finally
 
1336
    AWriter.Free;
 
1337
  end;
 
1338
end;
 
1339
 
 
1340
procedure TvVectorialDocument.WriteToFile(AFileName: string);
 
1341
var
 
1342
  lFormat: TvVectorialFormat;
 
1343
begin
 
1344
  lFormat := GetFormatFromExtension(ExtractFileExt(AFileName));
 
1345
  WriteToFile(AFileName, lFormat);
 
1346
end;
 
1347
 
 
1348
{@@
 
1349
  Writes the document to a stream
 
1350
}
 
1351
procedure TvVectorialDocument.WriteToStream(AStream: TStream; AFormat: TvVectorialFormat);
 
1352
var
 
1353
  AWriter: TvCustomVectorialWriter;
 
1354
begin
 
1355
  AWriter := CreateVectorialWriter(AFormat);
 
1356
 
 
1357
  try
 
1358
    AWriter.WriteToStream(AStream, Self);
 
1359
  finally
 
1360
    AWriter.Free;
 
1361
  end;
 
1362
end;
 
1363
 
 
1364
procedure TvVectorialDocument.WriteToStrings(AStrings: TStrings;
 
1365
  AFormat: TvVectorialFormat);
 
1366
var
 
1367
  AWriter: TvCustomVectorialWriter;
 
1368
begin
 
1369
  AWriter := CreateVectorialWriter(AFormat);
 
1370
 
 
1371
  try
 
1372
    AWriter.WriteToStrings(AStrings, Self);
 
1373
  finally
 
1374
    AWriter.Free;
 
1375
  end;
 
1376
end;
 
1377
 
 
1378
{@@
 
1379
  Reads the document from a file.
 
1380
 
 
1381
  Any current contents in this object will be removed.
 
1382
}
 
1383
procedure TvVectorialDocument.ReadFromFile(AFileName: string;
 
1384
  AFormat: TvVectorialFormat);
 
1385
var
 
1386
  AReader: TvCustomVectorialReader;
 
1387
begin
 
1388
  Self.Clear;
 
1389
 
 
1390
  AReader := CreateVectorialReader(AFormat);
 
1391
  try
 
1392
    AReader.ReadFromFile(AFileName, Self);
 
1393
  finally
 
1394
    AReader.Free;
 
1395
  end;
 
1396
end;
 
1397
 
 
1398
{@@
 
1399
  Reads the document from a file.  A variant that auto-detects the format from the extension and other factors.
 
1400
}
 
1401
procedure TvVectorialDocument.ReadFromFile(AFileName: string);
 
1402
var
 
1403
  lFormat: TvVectorialFormat;
 
1404
begin
 
1405
  lFormat := GetFormatFromExtension(ExtractFileExt(AFileName));
 
1406
  ReadFromFile(AFileName, lFormat);
 
1407
end;
 
1408
 
 
1409
{@@
 
1410
  Reads the document from a stream.
 
1411
 
 
1412
  Any current contents in this object will be removed.
 
1413
}
 
1414
procedure TvVectorialDocument.ReadFromStream(AStream: TStream;
 
1415
  AFormat: TvVectorialFormat);
 
1416
var
 
1417
  AReader: TvCustomVectorialReader;
 
1418
begin
 
1419
  Self.Clear;
 
1420
 
 
1421
  AReader := CreateVectorialReader(AFormat);
 
1422
  try
 
1423
    AReader.ReadFromStream(AStream, Self);
 
1424
  finally
 
1425
    AReader.Free;
 
1426
  end;
 
1427
end;
 
1428
 
 
1429
procedure TvVectorialDocument.ReadFromStrings(AStrings: TStrings;
 
1430
  AFormat: TvVectorialFormat);
 
1431
var
 
1432
  AReader: TvCustomVectorialReader;
 
1433
begin
 
1434
  Self.Clear;
 
1435
 
 
1436
  AReader := CreateVectorialReader(AFormat);
 
1437
  try
 
1438
    AReader.ReadFromStrings(AStrings, Self);
 
1439
  finally
 
1440
    AReader.Free;
 
1441
  end;
 
1442
end;
 
1443
 
 
1444
class function TvVectorialDocument.GetFormatFromExtension(AFileName: string
 
1445
  ): TvVectorialFormat;
 
1446
var
 
1447
  lExt: string;
 
1448
begin
 
1449
  lExt := ExtractFileExt(AFileName);
 
1450
  if AnsiCompareText(lExt, STR_PDF_EXTENSION) = 0 then Result := vfPDF
 
1451
  else if AnsiCompareText(lExt, STR_POSTSCRIPT_EXTENSION) = 0 then Result := vfPostScript
 
1452
  else if AnsiCompareText(lExt, STR_SVG_EXTENSION) = 0 then Result := vfSVG
 
1453
  else if AnsiCompareText(lExt, STR_CORELDRAW_EXTENSION) = 0 then Result := vfCorelDrawCDR
 
1454
  else if AnsiCompareText(lExt, STR_WINMETAFILE_EXTENSION) = 0 then Result := vfWindowsMetafileWMF
 
1455
  else if AnsiCompareText(lExt, STR_AUTOCAD_EXCHANGE_EXTENSION) = 0 then Result := vfDXF
 
1456
  else if AnsiCompareText(lExt, STR_ENCAPSULATEDPOSTSCRIPT_EXTENSION) = 0 then Result := vfEncapsulatedPostScript
 
1457
  else if AnsiCompareText(lExt, STR_LAS_EXTENSION) = 0 then Result := vfLAS
 
1458
  else if AnsiCompareText(lExt, STR_RAW_EXTENSION) = 0 then Result := vfRAW
 
1459
  else
 
1460
    raise Exception.Create('TvVectorialDocument.GetFormatFromExtension: The extension (' + lExt + ') doesn''t match any supported formats.');
 
1461
end;
 
1462
 
 
1463
function  TvVectorialDocument.GetDetailedFileFormat(): string;
 
1464
begin
 
1465
 
 
1466
end;
 
1467
 
 
1468
procedure TvVectorialDocument.GuessDocumentSize();
 
1469
var
 
1470
  i, j: Integer;
 
1471
  lEntity: TvEntity;
 
1472
  lLeft, lTop, lRight, lBottom: Double;
 
1473
  CurPage: TvVectorialPage;
 
1474
begin
 
1475
  lLeft := 0;
 
1476
  lTop := 0;
 
1477
  lRight := 0;
 
1478
  lBottom := 0;
 
1479
 
 
1480
  for j := 0 to GetPageCount()-1 do
 
1481
  begin
 
1482
    CurPage := GetPage(j);
 
1483
    for i := 0 to CurPage.GetEntitiesCount() - 1 do
 
1484
    begin
 
1485
      lEntity := CurPage.GetEntity(I);
 
1486
      lEntity.ExpandBoundingBox(lLeft, lTop, lRight, lBottom);
 
1487
    end;
 
1488
  end;
 
1489
 
 
1490
  Width := lRight - lLeft;
 
1491
  Height := lBottom - lTop;
 
1492
end;
 
1493
 
 
1494
procedure TvVectorialDocument.GuessGoodZoomLevel(AScreenSize: Integer);
 
1495
begin
 
1496
  ZoomLevel := AScreenSize / Height;
 
1497
end;
 
1498
 
 
1499
function TvVectorialDocument.GetPage(AIndex: Integer): TvVectorialPage;
 
1500
begin
 
1501
  Result := TvVectorialPage(FPages.Items[AIndex]);
 
1502
end;
 
1503
 
 
1504
function TvVectorialDocument.GetPageCount: Integer;
 
1505
begin
 
1506
  Result := FPages.Count;
 
1507
end;
 
1508
 
 
1509
function TvVectorialDocument.GetCurrentPage: TvVectorialPage;
 
1510
begin
 
1511
  if FCurrentPageIndex >= 0 then
 
1512
    Result := GetPage(FCurrentPageIndex)
 
1513
  else
 
1514
    Result := nil;
 
1515
end;
 
1516
 
 
1517
procedure TvVectorialDocument.SetCurrentPage(AIndex: Integer);
 
1518
begin
 
1519
  FCurrentPageIndex := AIndex;
 
1520
end;
 
1521
 
 
1522
function TvVectorialDocument.AddPage: TvVectorialPage;
 
1523
begin
 
1524
  Result := TvVectorialPage.Create(Self);
 
1525
  FPages.Add(Result);
 
1526
  if FCurrentPageIndex < 0 then FCurrentPageIndex := FPages.Count-1;
 
1527
end;
 
1528
 
 
1529
{@@
 
1530
  Clears all data in the document
 
1531
}
 
1532
procedure TvVectorialDocument.Clear;
 
1533
begin
 
1534
end;
 
1535
 
 
1536
{ TvCustomVectorialReader }
 
1537
 
 
1538
constructor TvCustomVectorialReader.Create;
 
1539
begin
 
1540
  inherited Create;
 
1541
end;
 
1542
 
 
1543
procedure TvCustomVectorialReader.ReadFromFile(AFileName: string; AData: TvVectorialDocument);
 
1544
var
 
1545
  FileStream: TFileStream;
 
1546
begin
 
1547
  FileStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
 
1548
  try
 
1549
    ReadFromStream(FileStream, AData);
 
1550
  finally
 
1551
    FileStream.Free;
 
1552
  end;
 
1553
end;
 
1554
 
 
1555
procedure TvCustomVectorialReader.ReadFromStream(AStream: TStream;
 
1556
  AData: TvVectorialDocument);
 
1557
var
 
1558
  AStringStream: TStringStream;
 
1559
  AStrings: TStringList;
 
1560
begin
 
1561
  AStringStream := TStringStream.Create('');
 
1562
  AStrings := TStringList.Create;
 
1563
  try
 
1564
    AStringStream.CopyFrom(AStream, AStream.Size);
 
1565
    AStringStream.Seek(0, soFromBeginning);
 
1566
    AStrings.Text := AStringStream.DataString;
 
1567
    ReadFromStrings(AStrings, AData);
 
1568
  finally
 
1569
    AStringStream.Free;
 
1570
    AStrings.Free;
 
1571
  end;
 
1572
end;
 
1573
 
 
1574
procedure TvCustomVectorialReader.ReadFromStrings(AStrings: TStrings;
 
1575
  AData: TvVectorialDocument);
 
1576
var
 
1577
  AStringStream: TStringStream;
 
1578
begin
 
1579
  AStringStream := TStringStream.Create('');
 
1580
  try
 
1581
    AStringStream.WriteString(AStrings.Text);
 
1582
    AStringStream.Seek(0, soFromBeginning);
 
1583
    ReadFromStream(AStringStream, AData);
 
1584
  finally
 
1585
    AStringStream.Free;
 
1586
  end;
 
1587
end;
 
1588
 
 
1589
{ TsCustomSpreadWriter }
 
1590
 
 
1591
constructor TvCustomVectorialWriter.Create;
 
1592
begin
 
1593
  inherited Create;
 
1594
end;
 
1595
 
 
1596
{@@
 
1597
  Default file writting method.
 
1598
 
 
1599
  Opens the file and calls WriteToStream
 
1600
 
 
1601
  @param  AFileName The output file name.
 
1602
                   If the file already exists it will be replaced.
 
1603
  @param  AData     The Workbook to be saved.
 
1604
 
 
1605
  @see    TsWorkbook
 
1606
}
 
1607
procedure TvCustomVectorialWriter.WriteToFile(AFileName: string; AData: TvVectorialDocument);
 
1608
var
 
1609
  OutputFile: TFileStream;
 
1610
begin
 
1611
  OutputFile := TFileStream.Create(AFileName, fmCreate or fmOpenWrite);
 
1612
  try
 
1613
    WriteToStream(OutputFile, AData);
 
1614
  finally
 
1615
    OutputFile.Free;
 
1616
  end;
 
1617
end;
 
1618
 
 
1619
{@@
 
1620
  The default stream writer just uses WriteToStrings
 
1621
}
 
1622
procedure TvCustomVectorialWriter.WriteToStream(AStream: TStream;
 
1623
  AData: TvVectorialDocument);
 
1624
var
 
1625
  lStringList: TStringList;
 
1626
begin
 
1627
  lStringList := TStringList.Create;
 
1628
  try
 
1629
    WriteToStrings(lStringList, AData);
 
1630
    lStringList.SaveToStream(AStream);
 
1631
  finally
 
1632
    lStringList.Free;
 
1633
  end;
 
1634
end;
 
1635
 
 
1636
procedure TvCustomVectorialWriter.WriteToStrings(AStrings: TStrings;
 
1637
  AData: TvVectorialDocument);
 
1638
begin
 
1639
 
 
1640
end;
 
1641
 
 
1642
{ TPath }
 
1643
 
 
1644
procedure TPath.Assign(ASource: TPath);
 
1645
begin
 
1646
  Len := ASource.Len;
 
1647
  Points := ASource.Points;
 
1648
  PointsEnd := ASource.PointsEnd;
 
1649
  CurPoint := ASource.CurPoint;
 
1650
  Pen := ASource.Pen;
 
1651
  Brush := ASource.Brush;
 
1652
  ClipPath := ASource.ClipPath;
 
1653
  ClipMode := ASource.ClipMode;
 
1654
end;
 
1655
 
 
1656
procedure TPath.PrepareForSequentialReading;
 
1657
begin
 
1658
  CurPoint := nil;
 
1659
end;
 
1660
 
 
1661
function TPath.Next(): TPathSegment;
 
1662
begin
 
1663
  if CurPoint = nil then Result := Points
 
1664
  else Result := CurPoint.Next;
 
1665
 
 
1666
  CurPoint := Result;
 
1667
end;
 
1668
 
 
1669
procedure TPath.CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double);
 
1670
var
 
1671
  lSegment: TPathSegment;
 
1672
  l2DSegment: T2DSegment;
 
1673
  lFirstValue: Boolean = True;
 
1674
begin
 
1675
  inherited CalculateBoundingBox(ALeft, ATop, ARight, ABottom);
 
1676
 
 
1677
  PrepareForSequentialReading();
 
1678
  lSegment := Next();
 
1679
  while lSegment <> nil do
 
1680
  begin
 
1681
    if lSegment is T2DSegment then
 
1682
    begin
 
1683
      l2DSegment := T2DSegment(lSegment);
 
1684
      if lFirstValue then
 
1685
      begin
 
1686
        ALeft := l2DSegment.X;
 
1687
        ATop := l2DSegment.Y;
 
1688
        ARight := l2DSegment.X;
 
1689
        ABottom := l2DSegment.Y;
 
1690
        lFirstValue := False;
 
1691
      end
 
1692
      else
 
1693
      begin
 
1694
        if l2DSegment.X < ALeft then ALeft := l2DSegment.X;
 
1695
        if l2DSegment.Y < ATop then ATop := l2DSegment.Y;
 
1696
        if l2DSegment.X > ARight then ARight := l2DSegment.X;
 
1697
        if l2DSegment.Y > ABottom then ABottom := l2DSegment.Y;
 
1698
      end;
 
1699
    end;
 
1700
 
 
1701
    lSegment := Next();
 
1702
  end;
 
1703
end;
 
1704
 
 
1705
procedure TPath.AppendSegment(ASegment: TPathSegment);
 
1706
var
 
1707
  L: Integer;
 
1708
begin
 
1709
  // Check if we are the first segment in the tmp path
 
1710
  if PointsEnd = nil then
 
1711
  begin
 
1712
    if Len <> 0 then
 
1713
      Exception.Create('[TPath.AppendSegment] Assertion failed Len <> 0 with PointsEnd = nil');
 
1714
 
 
1715
    Points := ASegment;
 
1716
    PointsEnd := ASegment;
 
1717
    Len := 1;
 
1718
    Exit;
 
1719
  end;
 
1720
 
 
1721
  L := Len;
 
1722
  Inc(Len);
 
1723
 
 
1724
  // Adds the element to the end of the list
 
1725
  PointsEnd.Next := ASegment;
 
1726
  ASegment.Previous := PointsEnd;
 
1727
  PointsEnd := ASegment;
 
1728
end;
 
1729
 
 
1730
finalization
 
1731
 
 
1732
  SetLength(GvVectorialFormats, 0);
 
1733
 
 
1734
end.
 
1735