1 { $Id: extgraphics.pas 51223 2016-01-07 12:53:41Z mattias $ }
2 {
3 /***************************************************************************
4 extgraphics.pas
5 ---------------
6
7 ***************************************************************************/
8
9 *****************************************************************************
10 This file is part of the Lazarus Component Library (LCL)
11
12 See the file COPYING.LCL, included in this distribution,
13 for details about the license.
14 *****************************************************************************
15 }
16 unit ExtGraphics;
17
18 {$mode objfpc}{$H+}
19
20 interface
21
22 uses Types, Classes, LCLProc, Graphics, Math, GraphMath;
23
24 type
25 TShapeDirection = (atUp, atDown, atLeft, atRight);
26 TInitShapeProc = procedure(var P: array of TPoint;const R: TRect;
27 var NumPts: Integer);
28
29
30 procedure Paint2HeadArrow(Canvas: TCanvas; const PaintRect: TRect;
31 RadAngle :Extended=0.0);
32 procedure PaintBarbadosTrident(Canvas: TCanvas; const PaintRect: TRect;
33 RadAngle :Extended=0.0);
34 procedure PaintBigI(Canvas: TCanvas; const PaintRect: TRect;
35 RadAngle :Extended=0.0);
36 procedure PaintBoldArrow(Canvas: TCanvas; const PaintRect: TRect;
37 RadAngle :Extended=0.0);
38 procedure PaintCanadianMaple(Canvas: TCanvas; const PaintRect: TRect;
39 RadAngle :Extended=0.0);
40 procedure PaintChevronArrow(Canvas: TCanvas; const PaintRect: TRect;
41 RadAngle :Extended=0.0);
42 procedure PaintFivePointStar(Canvas: TCanvas; const PaintRect: TRect;
43 RadAngle :Extended=0.0);
44 procedure PaintHexagon(Canvas: TCanvas; const PaintRect: TRect;
45 RadAngle :Extended=0.0);
46 procedure PaintNotchedArrow(Canvas: TCanvas; const PaintRect: TRect;
47 RadAngle :Extended=0.0);
48 procedure PaintOctogon(Canvas: TCanvas; const PaintRect: TRect;
49 RadAngle :Extended=0.0);
50 procedure PaintPentagon(Canvas: TCanvas; const PaintRect: TRect;
51 RadAngle :Extended=0.0);
52 procedure PaintPlus(Canvas: TCanvas; const PaintRect: TRect;
53 RadAngle :Extended=0.0);
54 procedure PaintQuadrangle(Canvas: TCanvas; const PaintRect: TRect;
55 RadAngle :Extended=0.0);
56 procedure PaintRightTriangle(Canvas: TCanvas; const PaintRect: TRect;
57 RadAngle :Extended=0.0);
58 procedure PaintTriangle(Canvas: TCanvas; const PaintRect: TRect;
59 RadAngle :Extended=0.0);
60 procedure PaintTriangular(Canvas: TCanvas; const PaintRect: TRect;
61 RadAngle :Extended=0.0; RightLeftFactor:extended=0.5);
62 procedure PaintValve(Canvas: TCanvas; const PaintRect: TRect;
63 RadAngle: Extended = 0.0);
64 procedure PaintVArrow(Canvas: TCanvas; const PaintRect : TRect;
65 RadAngle :Extended=0.0);
66
67
68
69 procedure PaintCross(Canvas: TCanvas; XLeft,YUp,XRight,YLow,
70 CrossX1,CrossX2,CrossY1,CrossY2:integer);
71 procedure PaintHalfEllipse(Canvas: TCanvas; Const PaintRect: TRect;
72 AHalfEllipseDirection: TShapeDirection);
73 procedure PaintFivePointLineStar(Canvas: TCanvas; const PaintRect: TRect);
74 procedure PaintStarN(Canvas: TCanvas;cx,cy,r,n,a:Integer);
75
76
77 procedure InitPolygon(Canvas: TCanvas;PaintRect: TRect;RadAngle: Extended;
78 InitShapeProc: TInitShapeProc);
79
80 procedure CalculatePentagonPoints
81 (const PentagonRect:TRect; var P1,P2,P3,P4,P5:TPoint);
LinesPointOfIntersectionnull82 function LinesPointOfIntersection
83 (const Line1a,Line1b,Line2a,line2b:TPoint):TPoint;
84
85
86 implementation
87
88 procedure CalculatePentagonPoints(const PentagonRect:TRect;
89 var P1,P2,P3,P4,P5:TPoint);
90 var cx,cy,dy,dx:Integer; r:real;
91 begin
92 P1.y:=PentagonRect.Top;
93 P2.x:=PentagonRect.Left;
94 P3.y:=PentagonRect.Bottom;
95 P4.y:=PentagonRect.Bottom;
96 P5.x:=PentagonRect.Right;
97 P1.x:=(PentagonRect.Right+PentagonRect.Left) div 2;
98 dy:=RoundToInt((P1.x-P2.x)*tan(Pi/10));
99 r := sqrt(dy*dy+(P1.x-P2.x)*(P1.x-P2.x));
100 cx:=P1.x;
101 cy:=P1.y+round(r);
102 P2.y:=cy-dy;
103 P5.y:=P2.y;
104 dx:=RoundToInt(r*sin(Pi/5));
105 P3.x:=cx-dx;
106 P4.x:=cx+dx;
107 end;
108
109
LinesPointOfIntersectionnull110 function LinesPointOfIntersection
111 (const Line1a,Line1b,Line2a,line2b:TPoint):TPoint;
112 var k1,k2,b1,b2,x,x1,x2,x3,x4,y,y1,y2,y3,y4:real;
113 p:TPoint;
114 begin
115 x1:=Line1a.x; y1:=Line1a.y;
116 x2:=Line1b.x; y2:=Line1b.y;
117 x3:=Line2a.x; y3:=Line2a.y;
118 x4:=Line2b.x; y4:=Line2b.y;
119 k1:=(y2-y1)/(x2-x1);
120 k2:=(y4-y3)/(x4-x3);
121 b1:=-k1*x1+y1;
122 b2:=-k2*x3+y3;
123 x:=(b1-b2)/(k2-k1);
124 y:=(k2*b1-k1*b2)/(k2-k1);
125 p.x:=RoundToInt(x);
126 p.y:=RoundToInt(y);
127 LinesPointOfIntersection:=p;
128 end;
129
130
131
132 procedure PaintCross(Canvas: TCanvas; XLeft,YUp,XRight,YLow,
133 CrossX1,CrossX2,CrossY1,CrossY2:integer);
134 var P:array[0..12] of TPoint;
135 begin
136 P[ 0].x:=XLeft; P[ 0].y:=CrossY1;
137 P[ 1].x:=CrossX1; P[ 1].y:=P[0].y;
138 P[ 2].x:=P[ 1].x; P[ 2].y:= YUp;
139 P[ 3].x:=CrossX2; P[ 3].y:=P[2].y;
140 P[ 4].x:=P[ 3].x; P[ 4].y:=CrossY1;
141 P[ 5].x:=XRight; P[ 5].y:=P[4].y;
142 P[ 6].x:=P[ 5].x; P[ 6].y:=CrossY2;
143 P[ 7].x:=CrossX2; P[ 7].y:=P[6].y;
144 P[ 8].x:=P[ 7].x; P[ 8].y:=YLow;
145 P[ 9].x:=CrossX1; P[ 9].y:=P[8].y;
146 P[10].x:=P[ 9].x; P[10].y:=CrossY2;
147 P[11].x:=XLeft; P[11].y:=P[10].y;
148 P[12].x:=P[11].x; P[12].y:=CrossY1;
149 Canvas.Polygon(P);
150 end;
151
152 procedure PolycRotate
153 (var Pts:array of TPoint; CountPts:Integer; cntPoint:TPoint; fii:Extended);
154 var i,dx,dy:Integer;
155 x,y:Extended;
156 begin
157 for i:=0 to CountPts-1 do
158 begin
159 dx:=Pts[i].x-cntPoint.x;
160 dy:=Pts[i].y-cntPoint.y;
161 x:=dx*cos(fii)+dy*sin(fii);
162 y:=dy*cos(fii)-dx*sin(fii);
163 Pts[i].x:=cntPoint.x+Round(x);
164 Pts[i].y:=cntPoint.y+Round(y);
165 end;
166 end;
167
168
169 procedure PolycMinMax
170 (var N:array of TPoint; const P:array of TPoint; CountPts:Integer);
171 var i,Xmin,Xmax,Ymin,Ymax:Integer;
172 begin
173 Xmin:=P[0].x; Xmax:=P[0].x; Ymin:=P[0].y; Ymax:=P[0].y;
174 for i:=0 to CountPts-1 do
175 begin
176 if P[i].x<Xmin then Xmin:=P[i].x;
177 if P[i].x>Xmax then Xmax:=P[i].x;
178 if P[i].y<Ymin then Ymin:=P[i].y;
179 if P[i].y>Ymax then Ymax:=P[i].y;
180 end;
181 N[0]:=Point(Xmin,Ymin); N[1]:=Point(Xmin,Ymax);
182 N[2]:=Point(Xmax,Ymax); N[3]:=Point(Xmax,Ymin);
183 end;
184
185
186 procedure PolycNewPaintRect(var PR:TRect; cP:TPoint; wv,hv:Integer);
187 begin
188 PR.Left:=cP.x-wv;
189 PR.Right:=cP.x+wv;
190 PR.Top:=cP.y-hv;
191 PR.Bottom:=cP.y+hv;
192 end;
193
194 procedure PolycFixCenterpoint
195 (var N:array Of TPoint; cP:TPoint; var P:array Of TPoint; CountPts:Integer);
196 var i,nx,ny,dx,dy:Integer;
197 begin
198 nx:=(N[0].x+N[2].x) div 2;
199 ny:=(N[0].y+N[2].y) div 2;
200 dx:=cP.x-nx;
201 dy:=cP.y-ny;
202 for i:=0 to 3 do
203 begin
204 N[i].x:=N[i].x+dx;
205 N[i].y:=N[i].y+dy;
206 end;
207 for i:=0 to CountPts-1 do
208 begin
209 P[i].x:=P[i].x+dx;
210 P[i].y:=P[i].y+dy;
211 end;
212 end;
213
214 procedure PolycSetHalfWidthAndHeight
215 (const PR:TRect;var hv,wv:Integer;fii:Extended);
216 var h,w:Integer;
217 begin
218 h:=PR.Bottom-PR.Top;
219 w:=PR.Right-PR.Left;
220 hv:=Round(h*abs(cos(fii))+w*abs(sin(fii))) div 2;
221 wv:=Round(h*abs(sin(fii))+w*abs(cos(fii))) div 2;
222 end;
223
224 procedure PolycScale(var P:array of TPoint; CountPts:Integer;
225 const PaintRect:TRect; cntPoint:TPoint; N:array of TPoint);
226 var k,kx,ky:Extended;
227 i:Integer;
228 begin
229 kx:=(PaintRect.Right-PaintRect.Left)/(N[2].x-N[0].x);
230 ky:=(PaintRect.Bottom-PaintRect.Top)/(N[2].y-N[0].y);
231 k:=min(kx,ky);
232 for i:=0 to CountPts-1 do
233 begin
234 P[i].x:=cntPoint.x+Round(k*(P[i].x-cntPoint.x));
235 P[i].y:=cntPoint.y+Round(k*(P[i].y-cntPoint.y));
236 end;
237 end;
238
239
240
241
242 procedure PaintPolycon(Canvas: TCanvas;PR : TRect; fii :Extended;
243 P:array of TPoint; CountPts:Integer;cntPoint:TPoint);
244 var N:array[0..3] of TPoint;
245
246 begin
247 PolycRotate(P,CountPts,cntPoint,fii);
248 PolycMinMax(N,P,CountPts);
249 PolycFixCenterpoint(N,cntPoint,P,CountPts);
250 PolycScale(P,CountPts,PR,cntPoint,N);
251 Case CountPts of
252 3: Canvas.Polygon([P[0],P[1],P[2]]);
253 4: Canvas.Polygon([P[0],P[1],P[2],P[3]]);
254 5: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4]]);
255 6: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5]]);
256 7: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6]]);
257 8: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6],P[7]]);
258 9: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6],P[7],P[8]]);
259 10: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6],P[7],P[8],P[9]]);
260 11: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6],P[7],P[8],P[9],
261 P[10]]);
262 12: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6],P[7],P[8],P[9],
263 P[10],P[11]]);
264 13: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6],P[7],P[8],P[9],
265 P[10],P[11],P[12]]);
266
267 20: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6],P[7],P[8],P[9],
268 P[10],P[11],P[12],P[13],P[14],P[15],P[16],P[17],P[18],P[19]]);
269 33: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6],P[7],P[8],P[9],
270 P[10],P[11],P[12],P[13],P[14],P[15],P[16],P[17],P[18],P[19],
271 P[20],P[21],P[22],P[23],P[24],P[25],P[26],P[27],P[28],P[29],
272 P[30],P[31],P[32]]);
273 35: Canvas.Polygon([P[0],P[1],P[2],P[3],P[4],P[5],P[6],P[7],P[8],P[9],
274 P[10],P[11],P[12],P[13],P[14],P[15],P[16],P[17],P[18],P[19],
275 P[20],P[21],P[22],P[23],P[24],P[25],P[26],P[27],P[28],P[29],
276 P[30],P[31],P[32],P[33],P[34]]);
277
278 end;
279 end;
280
281
282 procedure InitPolygon(Canvas: TCanvas;PaintRect: TRect;RadAngle: Extended;
283 InitShapeProc: TInitShapeProc);
284 var
285 PR, vPR: TRect;
286 P: array[0..35] of TPoint;
287 CountPts, hv, wv: Integer;
288 cntPoint: TPoint;
289 begin
290 PR := PaintRect;
291 cntPoint := CenterPoint(PR);
292 PolycSetHalfWidthAndHeight(PR, hv, wv, RadAngle);
293 PolycNewPaintRect(vPR, cntPoint, wv, hv);
294 InitShapeProc(P, vPR, CountPts);
295 PaintPolycon(Canvas, PR, RadAngle, P, CountPts, cntPoint);
296 end;
297
298 procedure Init2HeadArrow
299 (var P:array of TPoint;const R:TRect;var NumPts:Integer);
300 var dx,dy:Integer;
301 begin
302 dx:=(R.Right-R.Left)div 4;
303 dy:=(R.Bottom-R.Top)div 4;
304 P[0].x:=R.Left; P[0].y:=R.Top+(R.Bottom-R.Top) div 2;
305 P[1].x:=R.Left+dx; P[1].y:=R.Top;
306 P[2].x:=P[1].x; P[2].y:=R.Top+dy;
307 P[3].x:=R.Right-dx;P[3].y:=P[2].y;
308 P[4].x:=P[3].x; P[4].y:= R.Top;
309 P[5].x:=R.Right; P[5].y:=P[0].y;
310 P[6].x:=P[3].x; P[6].y:=R.Bottom;
311 P[7].x:=P[3].x; P[7].y:=R.Bottom-dy;
312 P[8].x:=P[1].x; P[8].y:=P[7].y;
313 P[9].x:=P[1].x; P[9].y:=R.Bottom;
314 NumPts:=10;
315 end;
316
317 procedure InitBarbadosTrident
318 (var P:array of TPoint; const R: TRect; var NumPts:Integer);
319 var RmLpW,BmTpH:extended;cntPoint:TPoint;
320 begin
321 cntPoint:=CenterPoint(R);
322 RmLpW:=(R.Right-R.Left)/140;
323 BmTpH:=(R.Bottom-R.Top)/160;
324 P[0].x:=cntPoint.x-round(RmLpW*10); P[0].y:=R.Bottom;
325 P[34].x:=cntPoint.x+round(RmLpW*10);P[34].y:=P[0].y;
326 P[1].x:=P[0].x; P[1].y:=R.Bottom-round(BmTpH*50);
327 P[33].x:=P[34].x; P[33].y:=P[1].y;
328 P[2].x:=cntPoint.x-round(RmLpW*35); P[2].y:=P[1].y;
329 P[32].x:=cntPoint.x+round(RmLpW*35);P[32].y:=P[2].y;
330 P[3].x:=cntPoint.x-round(RmLpW*48); P[3].y:=R.Bottom-round(BmTpH*98);
331 P[31].x:=cntPoint.x+round(RmLpW*48);P[31].y:=P[3].y;
332 P[4].x:=R.left; P[4].y:=R.top;
333 P[30].x:=R.Right; P[30].y:=P[4].y;
334 P[5].x:=cntPoint.x-round(RmLpW*42); P[5].y:=R.Top+round(BmTpH*4);
335 P[29].x:=cntPoint.x+round(RmLpW*42);P[29].y:=P[5].y;
336 P[6].x:=cntPoint.x-round(RmLpW*40); P[6].y:=R.Top+round(BmTpH*6);
337 P[28].x:=cntPoint.x+round(RmLpW*40);P[28].y:=P[6].y;
338 P[7].x:=cntPoint.x-round(RmLpW*39); P[7].y:=R.Top+round(BmTpH*11);
339 P[27].x:=cntPoint.x+round(RmLpW*39);P[27].y:=P[7].y;
340 P[8].x:=cntPoint.x-round(RmLpW*45); P[8].y:=R.Top+round(BmTpH*16);
341 P[26].x:=cntPoint.x+round(RmLpW*45);P[26].y:=P[8].y;
342 P[9].x:=cntPoint.x-round(RmLpW*45); P[9].y:=R.Top+round(BmTpH*21);
343 P[25].x:=cntPoint.x+round(RmLpW*45);P[25].y:=P[9].y;
344 P[10].x:=cntPoint.x-round(RmLpW*32);P[10].y:=R.Top+round(BmTpH*47);
345 P[24].x:=cntPoint.x+round(RmLpW*32);P[24].y:=P[10].y;
346 P[11].x:=cntPoint.x-round(RmLpW*28);P[11].y:=R.Top+round(BmTpH*70);
347 P[23].x:=cntPoint.x+round(RmLpW*28);P[23].y:=P[11].y;
348 P[12].x:=cntPoint.x-round(RmLpW*22);P[12].y:=R.Top+round(BmTpH*92);
349 P[22].x:=cntPoint.x+round(RmLpW*22);P[22].y:=P[12].y;
350 P[13].x:=P[0].x; P[13].y:=P[12].y;
351 P[21].x:=P[34].x; P[21].y:=P[13].y;
352 P[14].x:=P[0].x; P[14].y:=R.Top+round(BmTpH*30);
353 P[20].x:=P[34].x; P[20].y:=P[14].y;
354 P[15].x:=cntPoint.x-round(RmLpW*22);P[15].y:=R.Top+round(BmTpH*22);
355 P[19].x:=cntPoint.x+round(RmLpW*22);P[19].y:=P[15].y;
356 P[16].x:=cntPoint.x-round(RmLpW*9); P[16].y:=R.Top+round(BmTpH*12);
357 P[18].x:=cntPoint.x+round(RmLpW*9); P[18].y:=P[16].y;
358 P[17].x:=cntPoint.x; P[17].y:=R.Top;
359
360 NumPts:=35;
361 end;
362
363 procedure InitBigI(var P:array of TPoint; const R: TRect; var NumPts:Integer);
364 var dx,dy:Integer;
365 begin
366 dx:=(R.Right-R.Left) div 4;
367 dy:=(R.Bottom-R.Top) div 18;
368 P[0].x:=R.Left; P[0].y:=R.Top;
369 P[1].x:=R.Right; P[1].y:=R.TOP;
370 P[2].x:=R.Right-dx; P[2].y:=R.Top+dy;
371 P[3].x:=P[2].x; P[3].y:=R.Bottom-dy;
372 P[4].x:=R.Right; P[4].y:=R.Bottom;
373 P[5].x:=R.Left; P[5].y:=R.Bottom;
374 P[6].x:=R.Left+dx;P[6].y:=P[3].y;
375 P[7].x:=P[6].x;P[7].y:=P[2].y;
376 NumPts:=8;
377 end;
378
379 procedure InitBoldArrow(var P:array of TPoint;const R:TRect;var NumPts:Integer);
380 var dy:Integer;cntPoint:TPoint;
381 begin
382 cntPoint:=CenterPoint(R);
383 dy:=(R.Bottom - R.Top) div 4;
384 P[0].x:=R.Left;
385 P[0].y:=R.Top+dy;
386 P[1].x:=cntPoint.x;
387 P[1].y:=P[0].y;
388 P[2].x:=cntPoint.x;
389 P[2].y:=R.Top;
390 P[3].x:=R.Right;
391 P[3].y:=cntPoint.y;
392 P[4].x:=cntPoint.x;
393 P[4].y:= R.Bottom;
394 P[5].x:= cntPoint.x;
395 P[5].y:=R.Bottom-dy;
396 P[6].x:= R.Left;
397 P[6].y:=P[5].y;
398 NumPts:=7;
399 end;
400
401 procedure InitCanadianMaple
402 (var P:array of TPoint;const R:TRect; var NumPts:Integer);
403 const leafheight=54; leafwidth=50;
404 var xcenter,x2:integer;
405 RmLpLW, // (Right - Left)/LeafWidth;
406 BmTpLH //(Bottom-Top)/ LeafHeight
407 :extended;
408 begin
409 xcenter:=R.Left+(R.Right - R.Left) div 2;
410 p[0].y:=R.Top;
411 p[0].x:=xcenter;
412 RmLpLW:=(R.Right - R.Left)/LeafWidth;
413 BmTpLH:=(R.Bottom-R.Top)/ LeafHeight;
414 x2:=RoundToInt(RmLpLW*5);
415 P[1].x:=xcenter-x2; P[1].y:=RoundToInt(BmTpLH*9+R.Top);
416 P[32].x:=xcenter+x2; P[32].y:=P[1].y;
417 x2:=RoundToInt(RmLpLW*10);
418 P[2].x:=xcenter-x2; P[2].y:=RoundToInt(BmTpLH *7+R.Top);
419 P[31].x:=xcenter+x2; P[31].y:=P[2].y;
420 x2:=RoundToInt(RmLpLW*7);
421 P[3].x:=xcenter-x2; P[3].y:=RoundToInt(BmTpLH*21+R.Top);
422 P[30].x:=xcenter+x2; P[30].y:=P[3].y;
423 x2:=RoundToInt(RmLpLW*9);
424 P[4].x:=xcenter-x2; P[4].y:=P[3].y;
425 P[29].x:=xcenter+x2; P[29].y:=P[3].y;
426 x2:=RoundtoInt(RmLpLW*15);
427 P[5].x:=xcenter-x2; P[5].y:=RoundtoInt(BmTpLH*15+R.Top);
428 P[28].x:=xcenter+x2; P[28].y:=P[5].y;
429 x2:=RoundtoInt(RmLpLW*17);
430 P[6].x:=xcenter-x2; P[6].y:=RoundtoInt(BmTpLH*19+R.Top);
431 P[27].x:=xcenter+x2; P[27].y:=P[6].y;
432 x2:=RoundtoInt(RmLpLW*24);
433 P[7].x:=xcenter-x2; P[7].y:=RoundtoInt(BmTpLH*17+R.Top);
434 P[26].x:=xcenter+x2; P[26].y:=P[7].y;
435 x2:=RoundtoInt(RmLpLW*22);
436 P[8].x:=xcenter-x2; P[8].y:=RoundtoInt(BmTpLH*26+R.Top);
437 P[25].x:=xcenter+x2; P[25].y:=P[8].y;
438 x2:=RoundtoInt(RmLpLW*25);
439 P[9].x:=xcenter-x2; P[9].y:=RoundtoInt(BmTpLH*28+R.Top);
440 P[24].x:=xcenter+x2; P[24].y:=P[9].y;
441 x2:=RoundtoInt(RmLpLW*14);
442 P[10].x:=xcenter-x2; P[10].y:=RoundtoInt(BmTpLH*38+R.Top);
443 P[23].x:=xcenter+x2; P[23].y:=P[10].y;
444 x2:=RoundtoInt(RmLpLW*15);
445 P[11].x:=xcenter-x2; P[11].y:=RoundtoInt(BmTpLH*43+R.Top);
446 P[22].x:=xcenter+x2; P[22].y:=P[11].y;
447 x2:=RoundtoInt(RmLpLW);
448 P[12].x:=xcenter-x2; P[12].y:=RoundtoInt(BmTpLH*41+R.Top);
449 P[21].x:=xcenter+x2; P[21].y:=P[12].y;
450 x2:=RoundtoInt(RmLpLW/2);
451 P[13].x:=xcenter-x2; P[13].y:=RoundtoInt(BmTpLH*42+R.Top);
452 P[20].x:=xcenter+x2; P[20].y:=P[13].y;
453 P[14].x:=P[13].x; P[14].y:=RoundtoInt(BmTpLH*47+R.Top);
454 P[19].x:=P[20].x; P[19].y:=P[14].y;
455 x2:=RoundtoInt(RmLpLW);
456 P[15].x:=xcenter-x2; P[15].y:=P[14].y;
457 P[18].x:=xcenter+x2; P[18].y:=P[14].y;
458 P[16].x:=P[15].x; P[16].y:=R.bottom;
459 P[17].x:=P[18].x; P[17].y:=R.bottom;
460 NumPts:=33;
461 end;
462
463 procedure InitChevronArrow
464 (var P:array of TPoint;const R:TRect; var NumPts:Integer);
465 var dx:Integer;
466 begin
467 dx:=(R.Right - R.Left) div 3;
468 P[0].x:=R.Left;
469 P[0].y:=R.Top;
470 P[1].x:= R.Right-dx;
471 P[1].y:=R.Top;
472 P[2].x:=R.Right;
473 P[2].y:=(R.Top+R.Bottom) div 2;
474 P[3].x:=P[1].x;
475 P[3].y:=R.Bottom;
476 P[4].x:=R.Left;
477 P[4].y:= R.Bottom;
478 P[5].x:= R.Left+dx;
479 P[5].y:=P[2].y;
480 NumPts:=6;
481 end;
482
483
484 procedure InitFivePointStar
485 ( var P:array of TPoint;const R: TRect;var NumPts:Integer);
486 begin
487 CalculatePentagonPoints(R,P[0],P[2],P[4],P[6],P[8]);
488 P[1]:=LinesPointOfIntersection(P[0],P[4],P[2],P[8]);
489 P[3]:=LinesPointOfIntersection(P[0],P[4],P[2],P[6]);
490 P[5]:=LinesPointOfIntersection(P[8],P[4],P[2],P[6]);
491 P[7]:=LinesPointOfIntersection(P[8],P[4],P[0],P[6]);
492 P[9]:=LinesPointOfIntersection(P[8],P[2],P[0],P[6]);
493 NumPts:=10;
494 end;
495
496
497 procedure InitHexagon(var P:array of TPoint;const R: TRect;var NumPts:Integer);
498 var dx:Integer;
499 begin
500 dx:=round(((R.Right - R.Left) /2*cos(DegToRad(15)))/2);
501 P[0].x:=R.Left+dx; P[0].y:=R.Top;
502 P[1].x:=R.Left; P[1].y:=(R.Top+R.Bottom) div 2;
503 P[2].x:=P[0].x; P[2].y:= R.Bottom;
504 P[3].x:=R.Right-dx; P[3].y:=R.Bottom;
505 P[4].x:=R.Right; P[4].y:=P[1].y;
506 P[5].x:=R.Right-dx; P[5].y:=R.Top;
507 NumPts:=6;
508 end;
509
510 procedure InitNotchedArrow
511 (var P:array of TPoint;const R:TRect;var NumPts:Integer);
512 begin
513 InitBoldArrow(P,R,NumPts);
514 P[7].x:=R.Left+(R.Right-R.Left) div 4;
515 P[7].y:=P[3].y; // centerpoint y
516 NumPts:=8;
517 end;
518
519 procedure InitOctogon(var P:array of TPoint;const R: TRect;var NumPts:Integer);
520 var dx,dy:Integer;
521 begin
522 dx:=R.Right - R.Left;
523 dx:=round((dx-dx/(sqrt(2)+1))/2);
524 dy:=R.Bottom - R.Top;
525 dy:=round((dy-dy/(sqrt(2)+1))/2);
526 P[0].x:=R.Left+dx; P[0].y:=R.Top;
527 P[1].x:=R.Right-dx;P[1].y:=R.Top;
528 P[2].x:=R.Right; P[2].y:= R.Top+dy;
529 P[3].x:=R.Right; P[3].y:=R.Bottom-dy;
530 P[4].x:=P[1].x; P[4].y:=R.Bottom;
531 P[5].x:=P[0].x; P[5].y:=R.Bottom;
532 P[6].x:=R.Left; P[6].y:= P[3].y;
533 P[7].x:=R.Left; P[7].y:= P[2].y;
534 NumPts:=8;
535 end;
536
537 procedure InitPentagon(var P:array of TPoint;const R: TRect;var NumPts:Integer);
538 begin
539 CalculatePentagonPoints(R,P[0],P[1],P[2],P[3],P[4]);
540 NumPts:=5;
541 end;
542
543 procedure InitPlus(var P:array of TPoint;const R: TRect;var NumPts:Integer);
544 var CrossX,Crossy:integer;
545 begin
546 CrossX:=(R.Right-R.Left) div 3 ;
547 CrossY:=(R.Bottom-R.Top) div 3 ;
548 P[ 0].x:=R.Left; P[ 0].y:=R.Top+CrossY;
549 P[ 1].x:=R.Left+CrossX; P[ 1].y:=P[0].y;
550 P[ 2].x:=P[ 1].x; P[ 2].y:= R.Top;
551 P[ 3].x:=R.Right-CrossX; P[ 3].y:=P[2].y;
552 P[ 4].x:=P[ 3].x; P[ 4].y:=P[ 0].y;
553 P[ 5].x:=R.Right; P[ 5].y:=P[4].y;
554 P[ 6].x:=P[ 5].x; P[ 6].y:=R.Bottom-CrossY;
555 P[ 7].x:=P[ 3].x; P[ 7].y:=P[6].y;
556 P[ 8].x:=P[ 7].x; P[ 8].y:=R.Bottom;
557 P[ 9].x:=P[ 1].x; P[ 9].y:=P[8].y;
558 P[10].x:=P[ 9].x; P[10].y:=P[ 6].y;
559 P[11].x:=R.Left; P[11].y:=P[10].y;
560 P[12].x:=P[11].x; P[12].y:=P[ 0].y;
561 NumPts:=13;
562 end;
563
564 procedure InitQuadrangle
565 (var P:array of TPoint;const R: TRect;var NumPts:Integer);
566 begin
567 P[0].x:=R.Left; P[0].y:=R.Top;
568 P[1].x:=R.Left; P[1].y:=R.Bottom;
569 P[2].x:=R.Right; P[2].y:= R.Bottom;
570 P[3].x:=R.Right; P[3].y:=R.Top;
571 NumPts:=4;
572 end;
573
574 procedure InitRightTriangle
575 (var P:array of TPoint; const R: TRect; var NumPts:Integer);
576 begin
577 P[0].x:=R.Left; P[0].y:=R.Top;
578 P[1].x:=R.Right; P[1].y:=R.Bottom;
579 P[2].x:=P[0].x; P[2].y:= R.Bottom;
580 NumPts:=3;
581 end;
582
583 procedure InitTriangle(var P:array of TPoint; const R: TRect;
584 var NumPts:Integer);
585 begin
586 P[0].x:=R.Left; P[0].y:=R.Top;
587 P[1].x:=R.Right; P[1].y:=R.Top+(R.Bottom-R.Top) div 2;
588 P[2].x:=P[0].x; P[2].y:= R.Bottom;
589 NumPts:=3;
590 end;
591
592 procedure InitValve(var P: array of TPoint; const R: TRect; var NumPts: Integer);
593 var
594 cntPoint: TPoint;
595 begin
596 cntPoint := CenterPoint(R);
597 P[0].x := R.Left;
598 P[0].y := R.Top;
599 P[1].x := cntPoint.x;
600 P[1].y := cntPoint.y;
601 P[2].x := R.Right;
602 P[2].y := R.Top;
603 P[3].x := R.Right;
604 P[3].y := R.Bottom;
605 P[4].x := cntPoint.x;
606 P[4].y := cntPoint.y;
607 P[5].x := R.Left;
608 P[5].y := R.Bottom;
609 NumPts := 6;
610 end;
611
612 procedure InitVArrow(var P:array of TPoint;const R:TRect; var NumPts:Integer);
613 var cntPoint:TPoint;
614 begin
615 cntPoint:=CenterPoint(R);
616 P[0].x:=R.Left;
617 P[0].y:=R.Top;
618 P[1].x:=R.Right;
619 P[1].y:=cntPoint.y;
620 P[2].x:=R.Left;
621 P[2].y:=R.Bottom;
622 P[3].x:=cntPoint.x;
623 P[3].y:=cntPoint.y;
624 NumPts:=4;
625 end;
626
627
628
629 procedure Paint2HeadArrow(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
630 begin
631 InitPolygon(Canvas,PaintRect,RadAngle,@Init2HeadArrow);
632 end;
633
634 procedure PaintBarbadosTrident(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
635 begin
636 InitPolygon(Canvas,PaintRect,RadAngle,@InitBarbadosTrident);
637 end;
638
639 procedure PaintBigI(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
640 begin
641 InitPolygon(Canvas,PaintRect,RadAngle,@InitBigI);
642 end;
643
644 procedure PaintBoldArrow(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
645 begin
646 InitPolygon(Canvas,PaintRect,RadAngle,@InitBoldArrow);
647 end;
648
649 procedure PaintCanadianMaple(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
650 begin
651 InitPolygon(Canvas,PaintRect,RadAngle,@InitCanadianMaple);
652 end;
653
654 procedure PaintChevronArrow(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
655 begin
656 InitPolygon(Canvas,PaintRect,RadAngle,@InitChevronArrow);
657 end;
658
659 procedure PaintFivePointStar(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
660 begin
661 InitPolygon(Canvas,PaintRect,RadAngle,@InitFivePointStar);
662 end;
663
664 procedure PaintHexagon(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
665 begin
666 InitPolygon(Canvas,PaintRect,RadAngle,@InitHexagon);
667 end;
668
669 procedure PaintNotchedArrow(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
670 begin
671 InitPolygon(Canvas,PaintRect,RadAngle,@InitNotchedArrow);
672 end;
673
674 procedure PaintOctogon(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
675 begin
676 InitPolygon(Canvas,PaintRect,RadAngle,@InitOctogon);
677 end;
678
679 procedure PaintPentagon(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
680 begin
681 InitPolygon(Canvas,PaintRect,RadAngle,@InitPentagon);
682 end;
683
684 procedure PaintPlus(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
685 begin
686 InitPolygon(Canvas,PaintRect,RadAngle,@InitPlus);
687 end;
688
689 procedure PaintQuadrangle(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
690 begin
691 InitPolygon(Canvas,PaintRect,RadAngle,@InitQuadrangle);
692 end;
693
694 procedure PaintRightTriangle(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
695 begin
696 InitPolygon(Canvas,PaintRect,RadAngle,@InitRightTriangle);
697 end;
698
699 procedure PaintTriangle(Canvas: TCanvas; const PaintRect: TRect;RadAngle :Extended=0.0);
700 begin
701 InitPolygon(Canvas,PaintRect,RadAngle,@InitTriangle);
702 end;
703
704 procedure PaintValve(Canvas: TCanvas; const PaintRect: TRect; RadAngle: Extended = 0.0);
705 begin
706 InitPolygon(Canvas, PaintRect, RadAngle, @InitValve);
707 end;
708
709 procedure PaintVArrow(Canvas: TCanvas; const PaintRect : TRect; RadAngle :Extended=0.0);
710 begin
711 InitPolygon(Canvas,PaintRect,RadAngle,@InitVArrow);
712 end;
713
714 procedure PaintTriangular(Canvas: TCanvas; const PaintRect: TRect;
715 RadAngle :Extended=0.0; RightLeftFactor:Extended=0.5);
716 var PR,vPR:TRect;
717 P:array[0..35] of TPoint;
718 CountPts,hv,wv:Integer;
719 cntPoint:TPoint;
720 begin
721 PR:=PaintRect;
722 cntPoint:=CenterPoint(PR);
723 PolycSetHalfWidthAndHeight(PR,hv,wv,RadAngle);
724 PolycNewPaintRect(vPR,cntPoint,wv,hv);
725
726 P[0].x:=vPR.Left; P[0].y:=vPR.Bottom;
727 P[1].x:=vPR.Left+round((vPR.Right-vPR.left)* RightLeftFactor); P[1].y:=vPR.Top;
728 P[2].x:=vPR.Right; P[2].y:= vPR.Bottom;
729 CountPts:=3;
730
731 PaintPolycon(Canvas,PR,RadAngle,P,CountPts,cntPoint);
732 end;
733
734
735
736
737 procedure PaintHalfEllipse(Canvas: TCanvas;const PaintRect: TRect;
738 AHalfEllipseDirection: TShapeDirection);
739 var Ex1,Ex2,Ey1,Ey2,Sx,Sy,Ex,Ey,i:integer;
740 begin
741 Case AHalfEllipseDirection of
742 atUp:
743 begin
744 Ex1:=PaintRect.Left; Ex2:=PaintRect.Right;
745 Ex:=PaintRect.Left; Sx:=PaintRect.Right;
746 i:=PaintRect.Bottom-PaintRect.Top;
747 Ey1:=PaintRect.Top;Ey2:=PaintRect.Bottom+i;
748 Sy:=PaintRect.Top+i;Ey:=PaintRect.Top+i;
749 end;
750 atDown:
751 begin
752 Ex1:=PaintRect.Left; Ex2:=PaintRect.Right;
753 Sx:=PaintRect.Left; Ex:=PaintRect.Right;
754 i:=PaintRect.Bottom-PaintRect.Top;
755 Ey1:=PaintRect.Top-i;Ey2:=PaintRect.Bottom;
756 Sy:=PaintRect.Top;Ey:=PaintRect.Top;
757 end;
758 atRight:
759 begin
760 Ey1:=PaintRect.Top; Ey2:=PaintRect.Bottom;
761 Ey:=PaintRect.Top; Sy:=PaintRect.Bottom;
762 i:=PaintRect.Right-PaintRect.Left;
763 Ex1:=PaintRect.Left-i;Ex2:=PaintRect.Right;
764 Sx:=PaintRect.Left;Ex:=PaintRect.Left;
765 end;
766 atLeft:
767 begin
768 Ey1:=PaintRect.Top; Ey2:=PaintRect.Bottom;
769 Sy:=PaintRect.Top; Ey:=PaintRect.Bottom;
770 i:=PaintRect.Right-PaintRect.Left;
771 Ex1:=PaintRect.Left;Ex2:=PaintRect.Right+i;
772 Sx:=PaintRect.Left+i;Ex:=PaintRect.Left+i;
773 end;
774 end;
775 Canvas.Pie(Ex1,Ey1,Ex2,Ey2,Sx,Sy,Ex,Ey);
776 end;
777
778 procedure PaintFivePointLineStar(Canvas: TCanvas; const PaintRect: TRect);
779 var P: array[0..4] of TPoint;
780 begin
781 CalculatePentagonPoints(PaintRect,P[0],P[1],P[2],P[3],P[4]);
782 Canvas.Line(P[0].x,P[0].y,P[2].x,P[2].y);
783 Canvas.Line(P[0].x,P[0].y,P[3].x,P[3].y);
784 Canvas.Line(P[1].x,P[1].y,P[3].x,P[3].y);
785 Canvas.Line(P[1].x,P[1].y,P[4].x,P[4].y);
786 Canvas.Line(P[2].x,P[2].y,P[4].x,P[4].y);
787 end;
788
789 procedure PaintStarN(Canvas: TCanvas;cx,cy,r,n,a:Integer);
790 const MaxStarPoint=36;
791 var
792 r1,r0,alpha:double;
793 P:array[0..MaxStarPoint*2-1] of TPoint;
794 i,cs:Integer;
795 begin
796 r1:=r/2;
797 for i:=0 to 2*n
798 do begin
799 if (i mod 2)=0 then r0:=r else r0:=r1;
800 alpha:=a+(0.5+i/n)*Pi;
801 cs:=RoundToInt(r0*cos(alpha));
802 P[i].x:=cx+cs;
803 P[i].y:=cy-Round(r0*sin(alpha));
804 end;
805 for i:=2*n to MaxStarPoint*2-1
806 do begin
807 P[i].x:=P[2*n-1].x;
808 P[i].y:=P[2*n-1].y;
809 end;
810 Canvas.Polygon(P);
811 end;
812
813
814
815
816 end.
817
818
819