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
11 unit TADrawerCanvas;
12
13 {$H+}
14
15 interface
16
17 uses
18 Classes, FPCanvas, FPImage, Graphics, SysUtils, TAChartUtils, TADrawUtils;
19
20 type
21 IChartTCanvasDrawer = interface
22 ['{6D8E5591-6788-4D2D-9FE6-596D5157C3C2}']
GetCanvasnull23 function GetCanvas: TCanvas;
24 property Canvas: TCanvas read GetCanvas;
25 end;
26
27 { TCanvasDrawer }
28
29 TCanvasDrawer = class(
30 TBasicDrawer, IChartDrawer, IChartTCanvasDrawer)
31 strict private
32 procedure SetBrush(ABrush: TFPCustomBrush);
33 procedure SetFont(AFont: TFPCustomFont);
34 procedure SetPen(APen: TFPCustomPen);
35 strict protected
36 FCanvas: TCanvas;
37 FBuffer: TBitmap;
GetFontAnglenull38 // function GetFontAngle: Double; override;
39 function SimpleTextExtent(const AText: String): TPoint; override;
40 procedure SimpleTextOut(AX, AY: Integer; const AText: String); override;
41 public
42 procedure AddToFontOrientation(ADelta: Integer);
43 procedure ClippingStart;
44 procedure ClippingStart(const AClipRect: TRect);
45 procedure ClippingStop;
46 constructor Create(ACanvas: TCanvas);
47 destructor Destroy; override;
48 procedure Ellipse(AX1, AY1, AX2, AY2: Integer);
49 procedure FillRect(AX1, AY1, AX2, AY2: Integer);
GetBrushColornull50 function GetBrushColor: TChartColor;
GetCanvasnull51 function GetCanvas: TCanvas; virtual;
GetFontAnglenull52 function GetFontAngle: Double; override;
GetFontColornull53 function GetFontColor: TFPColor; override;
GetFontNamenull54 function GetFontName: String; override;
GetFontSizenull55 function GetFontSize: Integer; override;
GetFontStylenull56 function GetFontStyle: TChartFontStyles; override;
GetPenColornull57 function GetPenColor: TChartColor;
58 procedure Line(AX1, AY1, AX2, AY2: Integer);
59 procedure Line(const AP1, AP2: TPoint);
60 procedure LineTo(AX, AY: Integer); override;
61 procedure MoveTo(AX, AY: Integer); override;
62 procedure Polygon(
63 const APoints: array of TPoint; AStartIndex, ANumPts: Integer); override;
64 procedure Polyline(
65 const APoints: array of TPoint; AStartIndex, ANumPts: Integer);
66 procedure PrepareSimplePen(AColor: TChartColor);
67 procedure PutImage(AX, AY: Integer; AImage: TFPCustomImage); override;
68 procedure PutPixel(AX, AY: Integer; AColor: TChartColor); override;
69 procedure RadialPie(
70 AX1, AY1, AX2, AY2: Integer;
71 AStartAngle16Deg, AAngleLength16Deg: Integer);
72 procedure Rectangle(const ARect: TRect);
73 procedure Rectangle(AX1, AY1, AX2, AY2: Integer);
74 procedure ResetFont;
75 procedure SetAntialiasingMode(AValue: TChartAntialiasingMode);
76 procedure SetBrushColor(AColor: TChartColor);
77 procedure SetBrushParams(AStyle: TFPBrushStyle; AColor: TChartColor);
78 procedure SetPenColor(AColor: TChartColor);
79 procedure SetPenParams(AStyle: TFPPenStyle; AColor: TChartColor; AWidth: Integer = 1);
80 procedure SetPenWidth(AWidth: Integer);
81 procedure SetTransparency(ATransparency: TChartTransparency);
82 end;
83
84 TScaledCanvasDrawer = class(TCanvasDrawer)
85 protected
86 FCoeff: Double;
87 public
88 constructor Create(ACanvas: TCanvas; ACoeff: Double; AScaleItems: TScaleItems);
Scalenull89 function Scale(ADistance: Integer): Integer; override;
90 end;
91
CanvasGetFontOrientationFuncnull92 function CanvasGetFontOrientationFunc(AFont: TFPCustomFont): Integer;
ChartColorSysToFPColornull93 function ChartColorSysToFPColor(AChartColor: TChartColor): TFPColor;
94
95
96 implementation
97
98 uses
99 GraphType, LCLIntf, LCLType, IntfGraphics,
100 TAGeometry;
101
CanvasGetFontOrientationFuncnull102 function CanvasGetFontOrientationFunc(AFont: TFPCustomFont): Integer;
103 begin
104 if AFont is TFont then
105 Result := TFont(AFont).Orientation
106 else
107 Result := AFont.Orientation; //0;
108 end;
109
ChartColorSysToFPColornull110 function ChartColorSysToFPColor(AChartColor: TChartColor): TFPColor;
111 begin
112 Result := ChartColorToFPColor(ColorToRGB(AChartColor));
113 end;
114
115 { TCanvasDrawer }
116
117 procedure TCanvasDrawer.AddToFontOrientation(ADelta: Integer);
118 begin
119 with GetCanvas.Font do
120 Orientation := Orientation + ADelta;
121 end;
122
123 procedure TCanvasDrawer.ClippingStart(const AClipRect: TRect);
124 begin
125 FCanvas.ClipRect := AClipRect;
126 FBuffer.Canvas.ClipRect := AClipRect;
127 ClippingStart;
128 end;
129
130 procedure TCanvasDrawer.ClippingStart;
131 begin
132 FCanvas.Clipping := true;
133 FBuffer.Canvas.Clipping := true;
134 end;
135
136 procedure TCanvasDrawer.ClippingStop;
137 begin
138 FCanvas.Clipping := false;
139 FBuffer.Canvas.Clipping := false;
140 end;
141
142 constructor TCanvasDrawer.Create(ACanvas: TCanvas);
143 begin
144 inherited Create;
145 FCanvas := ACanvas;
146 FBuffer := TBitmap.Create;
147 FBuffer.PixelFormat := pf32bit;
148 end;
149
150 destructor TCanvasDrawer.Destroy;
151 begin
152 FreeAndNil(FBuffer);
153 inherited;
154 end;
155
156 procedure TCanvasDrawer.Ellipse(AX1, AY1, AX2, AY2: Integer);
157 begin
158 GetCanvas.Ellipse(AX1, AY1, AX2, AY2);
159 end;
160
161 procedure TCanvasDrawer.FillRect(AX1, AY1, AX2, AY2: Integer);
162 begin
163 GetCanvas.FillRect(AX1, AY1, AX2, AY2);
164 end;
165
TCanvasDrawer.GetBrushColornull166 function TCanvasDrawer.GetBrushColor: TChartColor;
167 begin
168 Result := GetCanvas.Brush.Color;
169 end;
170
TCanvasDrawer.GetCanvasnull171 function TCanvasDrawer.GetCanvas: TCanvas;
172 begin
173 // When transparency is off, draw directly on canvas for better speed.
174 if FTransparency > 0 then
175 Result := FBuffer.Canvas
176 else
177 Result := FCanvas;
178 end;
179
GetFontAnglenull180 function TCanvasDrawer.GetFontAngle: Double;
181 begin
182 Result := OrientToRad(GetCanvas.Font.Orientation);
183 end;
184
TCanvasDrawer.GetFontColornull185 function TCanvasDrawer.GetFontColor: TFPColor;
186 begin
187 Result := TColorToFPColor(GetCanvas.Font.Color);
188 end;
189
TCanvasDrawer.GetFontNamenull190 function TCanvasDrawer.GetFontName: String;
191 begin
192 Result := GetCanvas.Font.Name;
193 end;
194
GetFontSizenull195 function TCanvasDrawer.GetFontSize: Integer;
196 var
197 h: Integer;
198 begin
199 Result := GetCanvas.Font.Size;
200 if Result = 0 then begin
201 h := GetFontData(GetCanvas.Font.Reference.Handle).Height;
202 Result := round(abs(h) * 72 / ScreenInfo.PixelsPerInchY);
203 end;
204 end;
205
GetFontStylenull206 function TCanvasDrawer.GetFontStyle: TChartFontStyles;
207 begin
208 Result := TChartFontStyles(GetCanvas.Font.Style);
209 end;
210
GetPenColornull211 function TCanvasDrawer.GetPenColor: TChartColor;
212 begin
213 Result := GetCanvas.Pen.Color;
214 end;
215
216 procedure TCanvasDrawer.Line(AX1, AY1, AX2, AY2: Integer);
217 begin
218 GetCanvas.Line(AX1, AY1, AX2, AY2);
219 end;
220
221 procedure TCanvasDrawer.Line(const AP1, AP2: TPoint);
222 begin
223 GetCanvas.Line(AP1, AP2);
224 end;
225
226 procedure TCanvasDrawer.LineTo(AX, AY: Integer);
227 begin
228 GetCanvas.LineTo(AX, AY);
229 end;
230
231 procedure TCanvasDrawer.MoveTo(AX, AY: Integer);
232 begin
233 GetCanvas.MoveTo(AX, AY);
234 end;
235
236 procedure TCanvasDrawer.Polygon(
237 const APoints: array of TPoint; AStartIndex, ANumPts: Integer);
238 begin
239 GetCanvas.Polygon(APoints, false, AStartIndex, ANumPts);
240 end;
241
242 procedure TCanvasDrawer.Polyline(
243 const APoints: array of TPoint; AStartIndex, ANumPts: Integer);
244 begin
245 if ANumPts <= 0 then exit;
246 GetCanvas.Polyline(APoints, AStartIndex, ANumPts);
247 // TCanvas.Polyline does not draw the end point.
248 with APoints[AStartIndex + ANumPts - 1] do
249 GetCanvas.Pixels[X, Y] := GetCanvas.Pen.Color;
250 end;
251
252 procedure TCanvasDrawer.PrepareSimplePen(AColor: TChartColor);
253 begin
254 with GetCanvas.Pen do begin
255 if FXor then
256 Color := clWhite
257 else
258 Color := ColorOrMono(AColor);
259 Style := psSolid;
260 if FXor then
261 Mode := pmXor
262 else
263 Mode := pmCopy;
264 if (scalePen in FScaleItems) then
265 Width := Scale(1) else
266 Width := 1;
267 end;
268 end;
269
270 procedure TCanvasDrawer.PutImage(AX, AY: Integer; AImage: TFPCustomImage);
271 var
272 x, y: Integer;
273 bmp: TBitmap;
274 begin
275 bmp := TBitmap.Create;
276 try
277 if AImage is TLazIntfImage then
278 bmp.LoadFromIntfImage(TLazIntfImage(AImage))
279 else begin
280 bmp.SetSize(AImage.Width, AImage.Height);
281 bmp.Transparent := true;
282 bmp.TransparentMode := tmFixed;
283 bmp.TransparentColor := bmp.Canvas.Pixels[0, 0];
284 for y := 0 to AImage.Height - 1 do
285 for x := 0 to AImage.Width - 1 do
286 if AImage[x, y].alpha > 0 then
287 bmp.Canvas.Colors[x, y] := AImage[x, y];
288 end;
289 GetCanvas.Draw(AX, AY, bmp);
290 finally
291 bmp.Free;
292 end;
293 end;
294
295 procedure TCanvasDrawer.PutPixel(AX, AY: Integer; AColor: TChartColor);
296 begin
297 GetCanvas.Pixels[AX, AY] := AColor;
298 end;
299
300 procedure TCanvasDrawer.RadialPie(
301 AX1, AY1, AX2, AY2: Integer;
302 AStartAngle16Deg, AAngleLength16Deg: Integer);
303 begin
304 GetCanvas.RadialPie(
305 AX1, AY1, AX2, AY2, AStartAngle16Deg, AAngleLength16Deg);
306 end;
307
308 procedure TCanvasDrawer.Rectangle(AX1, AY1, AX2, AY2: Integer);
309 begin
310 GetCanvas.Rectangle(AX1, AY1, AX2, AY2);
311 end;
312
313 procedure TCanvasDrawer.Rectangle(const ARect: TRect);
314 begin
315 GetCanvas.Rectangle(ARect);
316 end;
317
318 procedure TCanvasDrawer.ResetFont;
319 begin
320 GetCanvas.Font.Orientation := 0;
321 end;
322
323 procedure TCanvasDrawer.SetAntialiasingMode(AValue: TChartAntialiasingMode);
324 begin
325 GetCanvas.AntialiasingMode := TAntialiasingMode(AValue);
326 end;
327
328 procedure TCanvasDrawer.SetBrush(ABrush: TFPCustomBrush);
329 begin
330 with GetCanvas.Brush do begin
331 if ABrush is TBrush then
332 Assign(ABrush)
333 else begin
334 FPColor := ABrush.FPColor;
335 Pattern := ABrush.Pattern;
336 Style := ABrush.Style;
337 end;
338 if FXor then
339 Style := bsClear
340 else if FMonochromeColor <> clTAColor then
341 Color := FMonochromeColor;
342 end;
343 end;
344
345 procedure TCanvasDrawer.SetBrushColor(AColor: TChartColor);
346 begin
347 GetCanvas.Brush.Color := ColorOrMono(AColor);
348 end;
349
350 procedure TCanvasDrawer.SetBrushParams(
351 AStyle: TFPBrushStyle; AColor: TChartColor);
352 begin
353 GetCanvas.Brush.Color := ColorOrMono(AColor);
354 GetCanvas.Brush.Style := AStyle;
355 end;
356
357 procedure TCanvasDrawer.SetFont(AFont: TFPCustomFont);
358 var
359 st: TFontStyles = [];
360 begin
361 with GetCanvas.Font do begin
362 if AFont is TFont then
363 Assign(AFont)
364 else begin
365 BeginUpdate;
366 FPColor := AFont.FPColor;
367 Name := AFont.Name;
368 Size := AFont.Size;
369 Orientation := AFont.Orientation;
370 if AFont.Italic then
371 Include(st, fsItalic);
372 if AFont.Bold then
373 Include(st, fsBold);
374 if AFont.Underline then
375 Include(st, fsUnderline);
376 {$IF (FPC_FULLVERSION<=20600) or (FPC_FULLVERSION=20602)}
377 if AFont.StrikeTrough then
378 {$ELSE}
379 if AFont.StrikeThrough then
380 {$ENDIF}
381 Include(st, fsStrikeOut);
382 Style := st;
383 EndUpdate;
384 end;
385 if FMonochromeColor <> clTAColor then
386 Color := FMonochromeColor;
387 if scaleFont in FScaleItems then
388 Size := Scale(GetFontSize)
389 else
390 Size := GetFontSize;
391 end;
392 end;
393
394 procedure TCanvasDrawer.SetPen(APen: TFPCustomPen);
395 begin
396 with GetCanvas do begin
397 if FXor then begin
398 Brush.Style := bsClear;
399 if APen = nil then
400 Pen.Style := psSolid
401 else
402 Pen.Style := APen.Style;
403 Pen.Mode := pmXor;
404 Pen.Color := clWhite;
405 if APen = nil then
406 Pen.Width := 1
407 else
408 Pen.Width := APen.Width;
409 end
410 else begin
411 if APen is TPen then
412 Pen.Assign(APen)
413 else begin
414 Pen.Color := FPColorToChartColor(APen.FPColor);
415 Pen.Style := APen.Style;
416 Pen.Width := APen.Width;
417 Pen.Mode := APen.Mode;
418 Pen.Pattern := APen.Pattern;
419 end;
420 if FMonochromeColor <> clTAColor then
421 Pen.Color := FMonochromeColor;
422 end;
423 if scalePen in FScaleItems then
424 Pen.Width := Scale(Pen.Width);
425 end;
426 end;
427
428 procedure TCanvasDrawer.SetPenColor(AColor: TChartColor);
429 begin
430 if not FXor then
431 GetCanvas.Pen.Color := ColorOrMono(AColor);
432 end;
433
434 procedure TCanvasDrawer.SetPenParams(AStyle: TFPPenStyle; AColor: TChartColor;
435 AWidth: Integer = 1);
436 begin
437 GetCanvas.Pen.Style := AStyle;
438 GetCanvas.Pen.Width := AWidth;
439 if not FXor then
440 GetCanvas.Pen.Color := ColorOrMono(AColor);
441 end;
442
443 procedure TCanvasDrawer.SetPenWidth(AWidth: Integer);
444 begin
445 GetCanvas.Pen.Width := AWidth;
446 end;
447
448 procedure TCanvasDrawer.SetTransparency(ATransparency: TChartTransparency);
449
FillAlphanull450 function FillAlpha(AAlpha: Byte): Byte;
451 var
452 img: TRawImage;
453 p, pEnd: PCardinal;
454 x: Cardinal = 0;
455 r: Cardinal = 0;
456 begin
457 FBuffer.BeginUpdate;
458 img := FBuffer.RawImage;
459 p := PCardinal(img.Data);
460 TRGBAQuad(x).Alpha := AAlpha;
461 pEnd := PCardinal(img.Data + img.DataSize);
462 // This loop is time-critical, so: avoid conditionals inside,
463 // use dword-sized instead of byte-sized access.
464 while p < pEnd do begin
465 // On the first pass, set all alpha values to AAlpha.
466 // Drawing will reset alpha of changed pixels to zero.
467 // On the second pass, flip unchanged pixels back to zero alpha,
468 // and changed ones to the desired alpha level.
469 p^ := p^ xor x;
470 r := r or p^;
471 Inc(p);
472 end;
473 FBuffer.EndUpdate;
474 Result := TRGBAQuad(r).Alpha;
475 end;
476
477 begin
478 if FTransparency = ATransparency then exit;
479 // For each transparency change, create a buffer bitmap, draw on that,
480 // then alpha-blend the bitmap to the canvas.
481 // This is slow, but currently seems the only way.
482 if FTransparency > 0 then begin
483 // StretchMaskBlt performs alpha blending only if the image contains
484 // at least one non-zero alpha value, so fully transparent image
485 // becomes black box. Workround: do not call StretchMaskBlt in this case.
486 if FillAlpha(255 - FTransparency) > 0 then
487 StretchMaskBlt(
488 FCanvas.Handle, 0, 0, FCanvas.Width, FCanvas.Height,
489 FBuffer.Canvas.Handle, 0, 0, FCanvas.Width, FCanvas.Height,
490 0, 0, 0, SRCCOPY);
491 end;
492 inherited;
493 if FTransparency > 0 then begin
494 FBuffer.SetSize(0, 0);
495 FBuffer.SetSize(FCanvas.Width, FCanvas.Height);
496 FillAlpha(255 - FTransparency);
497 end;
498 end;
499
SimpleTextExtentnull500 function TCanvasDrawer.SimpleTextExtent(const AText: String): TPoint;
501 begin
502 Result := GetCanvas.TextExtent(AText);
503 end;
504
505 procedure TCanvasDrawer.SimpleTextOut(AX, AY: Integer; const AText: String);
506
507 procedure DrawSimpleText(ACanvas: TCanvas; x, y: Integer; const txt: String);
508 // add right-to-left mode. Cannot use TextOut since it does not respect TextStyle
509 var
510 r: TRect;
511 ts: TTextStyle;
512 begin
513 ts := ACanvas.TextStyle;
514 ts.RightToLeft := FRightToLeft;
515 ts.WordBreak := false; // added to disable erroneous workbreaks in Linux printing
516 ts.Clipping := false;
517 r := Bounds(x, y, 1, 1);
518 ACanvas.TextRect(r, x, y, txt, ts);
519 end;
520
521 procedure DrawXorText;
522 var
523 bmp: TBitmap;
524 p, ext, bmpSize: TPoint;
525 a: Double;
526 begin
527 ext := GetCanvas.TextExtent(AText);
528 a := OrientToRad(GetCanvas.Font.Orientation);
529 bmpSize := MeasureRotatedRect(ext, a);
530 p := bmpSize div 2 - RotatePoint(ext div 2, -a);
531
532 bmp := TBitmap.Create;
533 try
534 bmp.SetSize(bmpSize.X, bmpSize.Y);
535 bmp.Canvas.Brush.Style := bsClear;
536 bmp.Canvas.Font := GetCanvas.Font;
537 bmp.Canvas.Font.Color := clWhite;
538 DrawSimpleText(bmp.Canvas, p.X, p.Y, AText);
539 bmp.Canvas.Pen.Color := clWhite;
540 BitBlt(
541 GetCanvas.Handle, AX - p.X, AY - p.Y, bmpSize.X, bmpSize.Y,
542 bmp.Canvas.Handle, 0, 0, SRCINVERT);
543 finally
544 bmp.Free;
545 end;
546 end;
547
548 begin
549 if FXor then
550 DrawXorText
551 else
552 DrawSimpleText(GetCanvas, AX, AY, AText);
553 end;
554
555
556 { TScaledCanvasDrawer }
557
558 constructor TScaledCanvasDrawer.Create(ACanvas: TCanvas; ACoeff: Double;
559 AScaleItems: TScaleItems);
560 begin
561 inherited Create(ACanvas);
562 FCoeff := ACoeff;
563 FScaleItems := AScaleItems;
564 end;
565
TScaledCanvasDrawer.Scalenull566 function TScaledCanvasDrawer.Scale(ADistance: Integer): Integer;
567 begin
568 Result := Round(FCoeff * ADistance);
569 end;
570
571 initialization
572 // Suppress incorrect "TAGeometry is unused" hint
573 Unused(DoublePoint(0, 0));
574
575 end.
576
577