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