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 TADrawerBGRA;
11
12 {$H+}
13
14 interface
15
16 uses
17 BGRABitmap, BGRABitmapTypes, BGRACanvas, Classes, FPCanvas, FPImage,
18 TAChartUtils, TADrawUtils;
19
20 type
21
22 TBGRABitmapDrawer = class(TBasicDrawer, IChartDrawer)
23 strict private
BGRAColorOrMononull24 function BGRAColorOrMono(AColor: TFPColor): TBGRAPixel; inline;
Canvasnull25 function Canvas: TBGRACanvas; inline;
Opacitynull26 function Opacity: Byte; inline;
27 procedure SetBrush(ABrush: TFPCustomBrush);
28 procedure SetFont(AFont: TFPCustomFont);
29 procedure SetPen(APen: TFPCustomPen);
30 strict protected
31 FBitmap: TBGRABitmap;
32
33 procedure SetAntialiasingMode(AValue: TChartAntialiasingMode);
SimpleTextExtentnull34 function SimpleTextExtent(const AText: String): TPoint; override;
35 procedure SimpleTextOut(AX, AY: Integer; const AText: String); override;
36 public
37 constructor Create(ABitmap: TBGRABitmap);
38 public
39 procedure AddToFontOrientation(ADelta: Integer);
40 procedure ClippingStart;
41 procedure ClippingStart(const AClipRect: TRect);
42 procedure ClippingStop;
43 procedure Ellipse(AX1, AY1, AX2, AY2: Integer);
44 procedure FillRect(AX1, AY1, AX2, AY2: Integer);
GetBrushColornull45 function GetBrushColor: TChartColor;
GetFontAnglenull46 function GetFontAngle: Double; override;
GetFontColornull47 function GetFontColor: TFPColor; override;
GetFontNamenull48 function GetFontName: String; override;
GetFontSizenull49 function GetFontSize: Integer; override;
GetFontStylenull50 function GetFontStyle: TChartFontStyles; override;
GetPenColornull51 function GetPenColor: TChartColor;
52 procedure Line(AX1, AY1, AX2, AY2: Integer);
53 procedure Line(const AP1, AP2: TPoint);
54 procedure LineTo(AX, AY: Integer); override;
55 procedure MoveTo(AX, AY: Integer); override;
56 procedure Polygon(
57 const APoints: array of TPoint; AStartIndex, ANumPts: Integer); override;
58 procedure Polyline(
59 const APoints: array of TPoint; AStartIndex, ANumPts: Integer);
60 procedure PrepareSimplePen(AColor: TChartColor);
61 procedure PutImage(AX, AY: Integer; AImage: TFPCustomImage); override;
62 procedure PutPixel(AX, AY: Integer; AColor: TChartColor); override;
63 procedure RadialPie(
64 AX1, AY1, AX2, AY2: Integer;
65 AStartAngle16Deg, AAngleLength16Deg: Integer);
66 procedure Rectangle(const ARect: TRect);
67 procedure Rectangle(AX1, AY1, AX2, AY2: Integer);
68 procedure ResetFont;
69 procedure SetBrushColor(AColor: TChartColor);
70 procedure SetBrushParams(AStyle: TFPBrushStyle; AColor: TChartColor);
71 procedure SetPenColor(AColor: TChartColor);
72 procedure SetPenParams(AStyle: TFPPenStyle; AColor: TChartColor; AWidth: Integer = 1);
73 procedure SetPenWidth(AWidth: Integer);
74 procedure SetTransparency(ATransparency: TChartTransparency);
75 end;
76
77
78 implementation
79
80 uses
81 BGRAText, Graphics, Math, TAGeometry;
82
83
84 { TBGRABitmapDrawer }
85
86 procedure TBGRABitmapDrawer.AddToFontOrientation(ADelta: Integer);
87 begin
88 with Canvas.Font do
89 Orientation := Orientation + ADelta;
90 end;
91
TBGRABitmapDrawer.BGRAColorOrMononull92 function TBGRABitmapDrawer.BGRAColorOrMono(AColor: TFPColor): TBGRAPixel;
93 begin
94 if FMonochromeColor = clTAColor then
95 Result := FPColorToBGRA(AColor)
96 else
97 Result := ColorToBGRA(FMonochromeColor);
98 end;
99
Canvasnull100 function TBGRABitmapDrawer.Canvas: TBGRACanvas;
101 begin
102 Result := FBitmap.CanvasBGRA;
103 end;
104
105 procedure TBGRABitmapDrawer.ClippingStart(const AClipRect: TRect);
106 begin
107 Canvas.ClipRect := AClipRect;
108 ClippingStart;
109 end;
110
111 procedure TBGRABitmapDrawer.ClippingStart;
112 begin
113 Canvas.Clipping := true;
114 end;
115
116 procedure TBGRABitmapDrawer.ClippingStop;
117 begin
118 Canvas.Clipping := false;
119 end;
120
121 constructor TBGRABitmapDrawer.Create(ABitmap: TBGRABitmap);
122 begin
123 inherited Create;
124 FBitmap := ABitmap;
125 end;
126
127 procedure TBGRABitmapDrawer.Ellipse(AX1, AY1, AX2, AY2: Integer);
128 begin
129 Canvas.Ellipse(AX1, AY1, AX2, AY2);
130 end;
131
132 procedure TBGRABitmapDrawer.FillRect(AX1, AY1, AX2, AY2: Integer);
133 begin
134 Canvas.FillRect(AX1, AY1, AX2, AY2);
135 end;
136
GetBrushColornull137 function TBGRABitmapDrawer.GetBrushColor: TChartColor;
138 begin
139 Result := TChartColor(Canvas.Brush.Color);
140 end;
141
GetFontAnglenull142 function TBGRABitmapDrawer.GetFontAngle: Double;
143 begin
144 // Result := 0.0;
145 Result := OrientToRad(Canvas.Font.Orientation);
146 end;
147
GetFontColornull148 function TBGRABitmapDrawer.GetFontColor: TFPColor;
149 begin
150 Result := TColorToFPColor(Canvas.Font.Color);
151 end;
152
GetFontNamenull153 function TBGRABitmapDrawer.GetFontName: String;
154 begin
155 Result := Canvas.Font.Name;
156 end;
157
TBGRABitmapDrawer.GetFontSizenull158 function TBGRABitmapDrawer.GetFontSize: Integer;
159 begin
160 Result := IfThen(Canvas.Font.Height = 0,
161 DEFAULT_FONT_SIZE,
162 round(abs(Canvas.Font.Height) / ScreenInfo.PixelsPerInchY * 72)
163 );
164 end;
165
GetFontStylenull166 function TBGRABitmapDrawer.GetFontStyle: TChartFontStyles;
167 begin
168 Result := TChartFontStyles(Canvas.Font.Style);
169 end;
170
TBGRABitmapDrawer.GetPenColornull171 function TBGRABitmapDrawer.GetPenColor: TChartColor;
172 begin
173 Result := TChartColor(Canvas.Pen.Color);
174 end;
175
176 procedure TBGRABitmapDrawer.Line(AX1, AY1, AX2, AY2: Integer);
177 begin
178 Canvas.MoveTo(AX1, AY1);
179 Canvas.LineTo(AX2, AY2);
180 end;
181
182 procedure TBGRABitmapDrawer.Line(const AP1, AP2: TPoint);
183 begin
184 Canvas.MoveTo(AP1);
185 Canvas.LineTo(AP2);
186 end;
187
188 procedure TBGRABitmapDrawer.LineTo(AX, AY: Integer);
189 begin
190 Canvas.LineTo(AX, AY);
191 end;
192
193 procedure TBGRABitmapDrawer.MoveTo(AX, AY: Integer);
194 begin
195 Canvas.MoveTo(AX, AY);
196 end;
197
TBGRABitmapDrawer.Opacitynull198 function TBGRABitmapDrawer.Opacity: Byte;
199 begin
200 Result := 255 - FTransparency;
201 end;
202
203 procedure TBGRABitmapDrawer.Polygon(
204 const APoints: array of TPoint; AStartIndex, ANumPts: Integer);
205 begin
206 Canvas.Polygon(APoints, false, AStartIndex, ANumPts);
207 end;
208
209 procedure TBGRABitmapDrawer.Polyline(
210 const APoints: array of TPoint; AStartIndex, ANumPts: Integer);
211 begin
212 Canvas.Polyline(APoints, AStartIndex, ANumPts);
213 end;
214
215 procedure TBGRABitmapDrawer.PrepareSimplePen(AColor: TChartColor);
216 begin
217 Canvas.Pen.Color := AColor;
218 Canvas.Pen.Style := psSolid;
219 Canvas.Pen.Width := 1;
220 Canvas.Pen.Opacity := Opacity;
221 end;
222
223 procedure TBGRABitmapDrawer.PutImage(AX, AY: Integer; AImage: TFPCustomImage);
224 var
225 x, y: Integer;
226 begin
227 for y := 0 to AImage.Height - 1 do
228 for x := 0 to AImage.Width - 1 do
229 if AImage[x, y].alpha > 0 then
230 Canvas.Colors[AX + x, AY + y] := AImage[x, y];
231 end;
232
233 procedure TBGRABitmapDrawer.PutPixel(AX, AY: Integer; AColor: TChartColor);
234 begin
235 Canvas.Pixels[AX, AY] := AColor;
236 end;
237
238 procedure TBGRABitmapDrawer.RadialPie(
239 AX1, AY1, AX2, AY2: Integer; AStartAngle16Deg, AAngleLength16Deg: Integer);
240 begin
241 Canvas.RadialPie(
242 AX1, AY1, AX2, AY2, AStartAngle16Deg, AAngleLength16Deg);
243 end;
244
245 procedure TBGRABitmapDrawer.Rectangle(AX1, AY1, AX2, AY2: Integer);
246 begin
247 Canvas.Rectangle(AX1, AY1, AX2, AY2);
248 end;
249
250 procedure TBGRABitmapDrawer.Rectangle(const ARect: TRect);
251 begin
252 with ARect do
253 Rectangle(Left, Top, Right, Bottom)
254 end;
255
256 procedure TBGRABitmapDrawer.ResetFont;
257 begin
258 Canvas.Font.Orientation := 0;
259 end;
260
261 procedure TBGRABitmapDrawer.SetAntialiasingMode(AValue: TChartAntialiasingMode);
262 begin
263 Canvas.AntialiasingMode := TAntialiasingMode(AValue);
264 Canvas.Font.Antialiasing := AValue = TADrawUtils.amOn;
265 end;
266
267 procedure TBGRABitmapDrawer.SetBrush(ABrush: TFPCustomBrush);
268 begin
269 Canvas.Brush.BGRAColor := BGRAColorOrMono(ABrush.FPColor);
270 Canvas.Brush.Style := ABrush.Style;
271 Canvas.Brush.Opacity := Opacity;
272 end;
273
274 procedure TBGRABitmapDrawer.SetBrushColor(AColor: TChartColor);
275 begin
276 Canvas.Brush.Color := ColorOrMono(AColor);
277 end;
278
279 procedure TBGRABitmapDrawer.SetBrushParams(
280 AStyle: TFPBrushStyle; AColor: TChartColor);
281 begin
282 Canvas.Brush.Style := AStyle;
283 Canvas.Brush.Color := ColorOrMono(AColor);
284 Canvas.Brush.Opacity := Opacity;
285 end;
286
287 procedure TBGRABitmapDrawer.SetFont(AFont: TFPCustomFont);
288 var
289 fs: Integer;
290 begin
291 Canvas.Font.Name := AFont.Name;
292 fs := IfThen(AFont.Size = 0, DEFAULT_FONT_SIZE, AFont.Size);
293 Canvas.Font.Height := FontEmHeightSign * fs * ScreenInfo.PixelsPerInchY div 72;
294 Canvas.Font.Orientation := FGetFontOrientationFunc(AFont);
295 Canvas.Font.BGRAColor := BGRAColorOrMono(AFont.FPColor);
296 if AFont is TFont then
297 Canvas.Font.Style := TFont(AFont).Style;
298 Canvas.Font.Opacity := Opacity;
299 end;
300
301 procedure TBGRABitmapDrawer.SetPen(APen: TFPCustomPen);
302 begin
303 with Canvas.Pen do begin
304 Style := APen.Style;
305 Width := APen.Width;
306 // TODO: Update for FPC 2.8
307 if APen is TPen then begin
308 JoinStyle := TPen(APen).JoinStyle;
309 EndCap := TPen(APen).EndCap;
310 end;
311 BGRAColor := BGRAColorOrMono(APen.FPColor);
312 Opacity := Self.Opacity;
313 end;
314 end;
315
316 procedure TBGRABitmapDrawer.SetPenColor(AColor: TChartColor);
317 begin
318 Canvas.Pen.Color := ColorOrMono(AColor);
319 end;
320
321 procedure TBGRABitmapDrawer.SetPenParams(
322 AStyle: TFPPenStyle; AColor: TChartColor; AWidth: Integer = 1);
323 begin
324 Canvas.Pen.Style := AStyle;
325 Canvas.Pen.Width := AWidth;
326 Canvas.Pen.Color := ColorOrMono(AColor);
327 Canvas.Pen.Opacity := Opacity;
328 end;
329
330 procedure TBGRABitmapDrawer.SetPenWidth(AWidth: Integer);
331 begin
332 Canvas.Pen.Width := AWidth;
333 end;
334
335 procedure TBGRABitmapDrawer.SetTransparency(ATransparency: TChartTransparency);
336 begin
337 inherited;
338 Canvas.Brush.Opacity := Opacity;
339 Canvas.Font.Opacity := Opacity;
340 Canvas.Pen.Opacity := Opacity;
341 end;
342
SimpleTextExtentnull343 function TBGRABitmapDrawer.SimpleTextExtent(const AText: String): TPoint;
344 begin
345 Result := Canvas.TextExtent(AText);
346 end;
347
348 procedure TBGRABitmapDrawer.SimpleTextOut(AX, AY: Integer; const AText: String);
349 begin
350 Canvas.TextOut(AX, AY, AText);
351 end;
352
353 initialization
354 // Suppress incorrect "TAGeometry is unused" hint
355 Unused(DoublePoint(0, 0));
356
357 end.
358
359