1 {
2 *****************************************************************************
3 See the file COPYING.modifiedLGPL.txt, included in this distribution,
4 for details about the license.
5 *****************************************************************************
6
7 Authors: Alexander Klenin
8
9 }
10 unit TADrawerFPCanvas;
11
12 {$H+}
13
14 interface
15
16 {$DEFINE USE_FTFONT}
17 {$IF (FPC_VERSION = 2) and (FPC_RELEASE <= 4) and defined(WIN64)}
18 {$UNDEF USE_FTFONT}
19 {$ENDIF}
20
21 uses
22 Classes, FPCanvas, FPImage, {$IFDEF USE_FTFONT}FTFont,{$ENDIF}
23 TAChartUtils, TADrawUtils;
24
25 type
26
27 { TFPCanvasDrawer }
28
29 TFPCanvasDrawer = class(TBasicDrawer, IChartDrawer)
30 strict private
31 FCanvas: TFPCustomCanvas;
32 {$IFDEF USE_FTFONT}
33 FFont: TFreeTypeFont;
34 FMeasureFont: TFreeTypeFont;
35 // FreeType measures text size in rotated orientation. But we need it
36 // in horizontal horientation. FMeasureFont is always horizontal.
37 {$ENDIF}
38 procedure EnsureFont;
39 procedure SetBrush(ABrush: TFPCustomBrush);
40 procedure SetFont(AFont: TFPCustomFont);
41 procedure SetPen(APen: TFPCustomPen);
42 strict protected
SimpleTextExtentnull43 function SimpleTextExtent(const AText: String): TPoint; override;
44 procedure SimpleTextOut(AX, AY: Integer; const AText: String); override;
45 public
46 constructor Create(ACanvas: TFPCustomCanvas);
47 destructor Destroy; override;
48 public
49 procedure AddToFontOrientation(ADelta: Integer);
50 procedure ClippingStart;
51 procedure ClippingStart(const AClipRect: TRect);
52 procedure ClippingStop;
53 procedure Ellipse(AX1, AY1, AX2, AY2: Integer);
54 procedure FillRect(AX1, AY1, AX2, AY2: Integer);
GetBrushColornull55 function GetBrushColor: TChartColor;
GetFontAnglenull56 function GetFontAngle: Double; override;
GetFontColornull57 function GetFontColor: TFPColor; override;
GetFontNamenull58 function GetFontName: String; override;
GetFontSizenull59 function GetFontSize: Integer; override;
GetFontStylenull60 function GetFontStyle: TChartFontStyles; override;
GetPenColornull61 function GetPenColor: TChartColor;
62 procedure Line(AX1, AY1, AX2, AY2: Integer);
63 procedure Line(const AP1, AP2: TPoint);
64 procedure LineTo(AX, AY: Integer); override;
65 procedure MoveTo(AX, AY: Integer); override;
66 procedure Polygon(
67 const APoints: array of TPoint; AStartIndex, ANumPts: Integer); override;
68 procedure Polyline(
69 const APoints: array of TPoint; AStartIndex, ANumPts: Integer);
70 procedure PrepareSimplePen(AColor: TChartColor);
71 procedure PutPixel(AX, AY: Integer; AColor: TChartColor); override;
72 procedure RadialPie(
73 AX1, AY1, AX2, AY2: Integer;
74 AStartAngle16Deg, AAngleLength16Deg: Integer);
75 procedure Rectangle(const ARect: TRect);
76 procedure Rectangle(AX1, AY1, AX2, AY2: Integer);
77 procedure ResetFont;
78 procedure SetBrushColor(AColor: TChartColor);
79 procedure SetBrushParams(AStyle: TFPBrushStyle; AColor: TChartColor);
80 procedure SetPenColor(AColor: TChartColor);
81 procedure SetPenParams(AStyle: TFPPenStyle; AColor: TChartColor; AWidth: Integer = 1);
82 procedure SetPenWidth(AWidth: Integer);
83 end;
84
85 implementation
86
87 uses
88 SysUtils, TAGeometry;
89
90 type
91 TFPCanvasHelperCrack = class(TFPCanvasHelper);
92
93 procedure AssignFPCanvasHelper(ADest, ASrc: TFPCanvasHelper);
94 var
95 d: TFPCanvasHelperCrack absolute ADest;
96 begin
97 d.DoCopyProps(ASrc);
98 end;
99
100 { TFPCanvasDrawer }
101
102 procedure TFPCanvasDrawer.AddToFontOrientation(ADelta: Integer);
103 begin
104 EnsureFont;
105 {$IFDEF USE_FTFONT}
106 FFont.Angle := FFont.Angle + OrientToRad(ADelta);
107 {$ELSE}
108 Unused(ADelta);
109 {$ENDIF}
110 end;
111
112 procedure TFPCanvasDrawer.ClippingStart(const AClipRect: TRect);
113 begin
114 Unused(AClipRect);
115 FCanvas.ClipRect := AClipRect;
116 ClippingStart;
117 end;
118
119 procedure TFPCanvasDrawer.ClippingStart;
120 begin
121 // FIXME: FPCanvas.Clipping is broken
122 // FCanvas.Clipping := true;
123 end;
124
125 procedure TFPCanvasDrawer.ClippingStop;
126 begin
127 FCanvas.Clipping := false;
128 end;
129
130 constructor TFPCanvasDrawer.Create(ACanvas: TFPCustomCanvas);
131 begin
132 inherited Create;
133 FCanvas := ACanvas;
134 end;
135
136 destructor TFPCanvasDrawer.Destroy;
137 begin
138 {$IFDEF USE_FTFONT}
139 FreeAndNil(FFont);
140 FreeAndNil(FMeasureFont);
141 {$ENDIF}
142 inherited Destroy;
143 end;
144
145 procedure TFPCanvasDrawer.Ellipse(AX1, AY1, AX2, AY2: Integer);
146 begin
147 FCanvas.Ellipse(AX1, AY1, AX2, AY2);
148 end;
149
150 procedure TFPCanvasDrawer.EnsureFont;
151 begin
152 {$IFDEF USE_FTFONT}
153 if FFont = nil then begin
154 FFont := TFreeTypeFont.Create;
155 FFont.Resolution := 72;
156 FFont.AntiAliased := true; //false;
157 FCanvas.Font := FFont;
158 end;
159
160 if FMeasureFont = nil then begin
161 FMeasureFont := TFreeTypeFont.Create;
162 FMeasureFont.Resolution := 72;
163 FMeasureFont.AntiAliased := false;
164 end;
165 {$ENDIF}
166 end;
167
168 procedure TFPCanvasDrawer.FillRect(AX1, AY1, AX2, AY2: Integer);
169 begin
170 // FIXME
171 FCanvas.Rectangle(AX1, AY1, AX2, AY2);
172 end;
173
TFPCanvasDrawer.GetBrushColornull174 function TFPCanvasDrawer.GetBrushColor: TChartColor;
175 begin
176 Result := FPColorToChartColor(FCanvas.Brush.FPColor);
177 end;
178
GetFontAnglenull179 function TFPCanvasDrawer.GetFontAngle: Double;
180 begin
181 {$IFDEF USE_FTFONT}
182 Result := FFont.Angle; // Freetype font angle is in rad.
183 {$ELSE}
184 Result := 0;
185 {$ENDIF}
186 end;
187
TFPCanvasDrawer.GetFontColornull188 function TFPCanvasDrawer.GetFontColor: TFPColor;
189 begin
190 Result := FCanvas.Font.FPColor;
191 end;
192
TFPCanvasDrawer.GetFontNamenull193 function TFPCanvasDrawer.GetFontName: String;
194 begin
195 Result := FCanvas.Font.Name;
196 end;
197
GetFontSizenull198 function TFPCanvasDrawer.GetFontSize: Integer;
199 begin
200 if FCanvas.Font.Size = 0 then
201 Result := DEFAULT_FONT_SIZE
202 else
203 Result := FCanvas.Font.Size;
204 end;
205
GetFontStylenull206 function TFPCanvasDrawer.GetFontStyle: TChartFontStyles;
207 begin
208 Result := [];
209 if FCanvas.Font.Bold then Include(Result, cfsBold);
210 if FCanvas.Font.Italic then Include(Result, cfsItalic);
211 if FCanvas.Font.Underline then Include(Result, cfsUnderline);
212 if FCanvas.Font.Strikethrough then Include(Result, cfsStrikeout);
213 end;
214
TFPCanvasDrawer.GetPenColornull215 function TFPCanvasDrawer.GetPenColor: TChartColor;
216 begin
217 Result := FPColorToChartColor(FCanvas.Pen.FPColor);
218 end;
219
220 procedure TFPCanvasDrawer.Line(AX1, AY1, AX2, AY2: Integer);
221 begin
222 FCanvas.Line(AX1, AY1, AX2, AY2);
223 end;
224
225 procedure TFPCanvasDrawer.Line(const AP1, AP2: TPoint);
226 begin
227 FCanvas.Line(AP1, AP2);
228 end;
229
230 procedure TFPCanvasDrawer.LineTo(AX, AY: Integer);
231 begin
232 FCanvas.LineTo(AX, AY);
233 end;
234
235 procedure TFPCanvasDrawer.MoveTo(AX, AY: Integer);
236 begin
237 FCanvas.MoveTo(AX, AY);
238 end;
239
240 procedure TFPCanvasDrawer.Polygon(
241 const APoints: array of TPoint; AStartIndex, ANumPts: Integer);
242 begin
243 if (ANumPts = Length(APoints)) and (AStartIndex = 0) then
244 FCanvas.Polygon(APoints)
245 else
246 FCanvas.Polygon(CopyPoints(APoints, AStartIndex, ANumPts));
247 end;
248
249 procedure TFPCanvasDrawer.Polyline(
250 const APoints: array of TPoint; AStartIndex, ANumPts: Integer);
251 begin
252 if (ANumPts = Length(APoints)) and (AStartIndex = 0) then
253 FCanvas.Polyline(APoints)
254 else
255 FCanvas.Polyline(CopyPoints(APoints, AStartIndex, ANumPts));
256 end;
257
258 procedure TFPCanvasDrawer.PrepareSimplePen(AColor: TChartColor);
259 begin
260 FCanvas.Pen.FPColor := FChartColorToFPColorFunc(AColor);
261 FCanvas.Pen.Width := 1;
262 FCanvas.Pen.Style := psSolid;
263 end;
264
265 procedure TFPCanvasDrawer.PutPixel(AX, AY: Integer; AColor: TChartColor);
266 begin
267 FCanvas.Colors[AX, AY] := FChartColorToFPColorFunc(AColor);
268 end;
269
270 procedure TFPCanvasDrawer.RadialPie(
271 AX1, AY1, AX2, AY2: Integer; AStartAngle16Deg, AAngleLength16Deg: Integer);
272 var
273 e: TEllipse;
274 p: TPointArray;
275 begin
276 e.InitBoundingBox(AX1, AY1, AX2, AY2);
277 p := e.TesselateRadialPie(
278 Deg16ToRad(AStartAngle16Deg), Deg16ToRad(AAngleLength16Deg), 4);
279 Polygon(p, 0, Length(p));
280 end;
281
282 procedure TFPCanvasDrawer.Rectangle(AX1, AY1, AX2, AY2: Integer);
283 begin
284 FCanvas.Rectangle(AX1, AY1, AX2, AY2);
285 end;
286
287 procedure TFPCanvasDrawer.Rectangle(const ARect: TRect);
288 begin
289 FCanvas.Rectangle(ARect);
290 end;
291
292 procedure TFPCanvasDrawer.ResetFont;
293 begin
294 FCanvas.Font.Orientation := 0;
295 end;
296
297 procedure TFPCanvasDrawer.SetBrush(ABrush: TFPCustomBrush);
298 begin
299 AssignFPCanvasHelper(FCanvas.Brush, ABrush);
300 end;
301
302 procedure TFPCanvasDrawer.SetBrushColor(AColor: TChartColor);
303 begin
304 FCanvas.Brush.FPColor := FChartColorToFPColorFunc(AColor);
305 end;
306
307 procedure TFPCanvasDrawer.SetBrushParams(
308 AStyle: TFPBrushStyle; AColor: TChartColor);
309 begin
310 FCanvas.Brush.FPColor := FChartColorToFPColorFunc(AColor);
311 FCanvas.Brush.Style := AStyle;
312 end;
313
314 procedure TFPCanvasDrawer.SetFont(AFont: TFPCustomFont);
315 begin
316 EnsureFont;
317 {$IFDEF USE_FTFONT}
318 AssignFPCanvasHelper(FFont, AFont);
319 AssignFPCanvasHelper(FMeasureFont, AFont);
320 // DoCopyProps performs direct variable assignment, so call SetName by hand.
321 FFont.Name := AFont.Name;
322 FFont.Angle := OrientToRad(FGetFontOrientationFunc(AFont));
323 FMeasureFont.Name := AFont.Name;
324 FMeasureFont.Angle := 0;
325 {$ELSE}
326 Unused(AFont);
327 {$ENDIF}
328 end;
329
330 procedure TFPCanvasDrawer.SetPen(APen: TFPCustomPen);
331 begin
332 AssignFPCanvasHelper(FCanvas.Pen, APen);
333 end;
334
335 procedure TFPCanvasDrawer.SetPenColor(AColor: TChartColor);
336 begin
337 FCanvas.Pen.FPColor := FChartColorToFPColorFunc(AColor);
338 end;
339
340 procedure TFPCanvasDrawer.SetPenParams(AStyle: TFPPenStyle; AColor: TChartColor;
341 AWidth: Integer = 1);
342 begin
343 FCanvas.Pen.Style := AStyle;
344 FCanvas.Pen.FPColor := FChartColorToFPColorFunc(AColor);
345 FCanvas.Pen.Width := AWidth;
346 end;
347
348 procedure TFPCanvasDrawer.SetPenWidth(AWidth: Integer);
349 begin
350 FCanvas.Pen.Width := AWidth;
351 end;
352
SimpleTextExtentnull353 function TFPCanvasDrawer.SimpleTextExtent(const AText: String): TPoint;
354 var
355 fnt: TFreeTypeFont;
356 begin
357 EnsureFont;
358 {$IFDEF USE_FTFONT}
359 FCanvas.Font := FMeasureFont;
360 FMeasureFont.GetTextSize(AText, Result.X, Result.Y);
361 FCanvas.Font := FFont;
362 // FreeType measures the exact pixel height of characters. But the LCL font
363 // has some space above and below. --> increase height bei 25%
364 Result.Y := Result.Y * 5 div 4;
365 {$ELSE}
366 FCanvas.GetTextSize(AText, Result.X, Result.Y);
367 {$ENDIF}
368 end;
369
370 procedure TFPCanvasDrawer.SimpleTextOut(AX, AY: Integer; const AText: String);
371 {$IFDEF USE_FTFONT}
372 var
373 p: TPoint;
374 h: Integer;
375 {$ENDIF}
376 begin
377 EnsureFont;
378 {$IFDEF USE_FTFONT}
379 // FreeType uses lower-left instead of upper-left corner as starting position.
380 // --> we must correct for text height to find correct text starting point
381 h := SimpleTextExtent('Tg').y;
382 // Approximately correct for the difference in text height in LCL
383 // (incl enpty space below character) and freetype (exact text height).
384 h := h * 3 div 4;
385 // Rotate text height according to font direction
386 p := RotatePoint(Point(0, h), -FFont.Angle);
387 FCanvas.TextOut(p.X + AX, p.Y + AY, AText);
388 {$ELSE}
389 Unused(AX, AY);
390 Unused(AText); // wp: why not call FCanvas.TextOut ???
391 {$ENDIF}
392 end;
393
394 end.
395
396