source: trunk/Packages/bgrabitmap/bgraarrow.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 15.8 KB
Line 
1unit BGRAArrow;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, BGRABitmapTypes, BGRAGraphics;
9
10type
11 { TBGRAArrow }
12
13 TBGRAArrow = class(TBGRACustomArrow)
14 private
15 FLineCap: TPenEndCap;
16 FWidth : single;
17 FStart : ArrayOfTPointF;
18 FStartComputed: boolean;
19 FStartStyle: TBGRAArrowStyle;
20 FStartSizeFactor: TPointF;
21 FStartTipStyle: TPenJoinStyle;
22 FStartOffsetX: single;
23 FStartRepeatCount: integer;
24 FStartRelativePenWidth: single;
25 FStartTriangleBackOffset: single;
26 FEnd : ArrayOfTPointF;
27 FEndComputed: boolean;
28 FEndStyle: TBGRAArrowStyle;
29 FEndSizeFactor: TPointF;
30 FEndTipStyle: TPenJoinStyle;
31 FEndOffsetX: single;
32 FEndRepeatCount: integer;
33 FEndRelativePenWidth: single;
34 FEndTriangleBackOffset: single;
35 function ComputeAnyAt(const AData: ArrayOfTPointF; const APosition, ADirection: TPointF): ArrayOfTPointF;
36 function ComputeData(AStyle: TBGRAArrowStyle; const ASizeFactor: TPointF;
37 ATipStyle: TPenJoinStyle; ALineCap: TPenEndCap; const AWidth: single; AOffsetX: single;
38 ARepeatCount: integer; ARelativePenWidth: single; ATriangleBackOffset: single): ArrayOfTPointF;
39 procedure SetWidth(AValue: single);
40 protected
41 function GetEndRepeatCount: integer; override;
42 function GetEndSizeFactor: TPointF; override;
43 function GetIsEndDefined: boolean; override;
44 function GetIsStartDefined: boolean; override;
45 function GetEndOffsetX: single; override;
46 function GetStartOffsetX: single; override;
47 function GetStartRepeatCount: integer; override;
48 function GetStartSizeFactor: TPointF; override;
49 procedure SetEndOffsetX(AValue: single); override;
50 procedure SetEndRepeatCount(AValue: integer); override;
51 procedure SetEndSizeFactor(AValue: TPointF); override;
52 procedure SetStartOffsetX(AValue: single); override;
53 procedure SetStartRepeatCount(AValue: integer); override;
54 procedure SetStartSizeFactor(AValue: TPointF); override;
55 function GetLineCap: TPenEndCap; override;
56 procedure SetLineCap(AValue: TPenEndCap); override;
57 procedure SetStart(AStyle: TBGRAArrowStyle; ATipStyle: TPenJoinStyle = pjsMiter; ARelativePenWidth: single = 1; ATriangleBackOffset: single = 0);
58 procedure SetEnd(AStyle: TBGRAArrowStyle; ATipStyle: TPenJoinStyle = pjsMiter; ARelativePenWidth: single = 1; ATriangleBackOffset: single = 0);
59 public
60 constructor Create;
61 procedure StartAsNone; override;
62 procedure StartAsClassic(AFlipped: boolean = false; ACut: boolean = false; ARelativePenWidth: single = 1); override;
63 procedure StartAsTriangle(ABackOffset: single = 0; ARounded: boolean = false; AHollow: boolean = false; AHollowPenWidth: single = 0.5); override;
64 procedure StartAsTail; override;
65 procedure EndAsNone; override;
66 procedure EndAsClassic(AFlipped: boolean = false; ACut: boolean = false; ARelativePenWidth: single = 1); override;
67 procedure EndAsTriangle(ABackOffset: single = 0; ARounded: boolean = false; AHollow: boolean = false; AHollowPenWidth: single = 0.5); override;
68 procedure EndAsTail; override;
69 function ComputeStartAt(const APosition: TPointF; const ADirection: TPointF; const AWidth: single; const ACurrentPos: single): ArrayOfTPointF; override;
70 function ComputeEndAt(const APosition: TPointF; const ADirection: TPointF; const AWidth: single; const ACurrentPos: single): ArrayOfTPointF; override;
71
72 end;
73
74implementation
75
76uses BGRATransform, BGRAPen, BGRAPath;
77
78{ TBGRAArrow }
79
80function TBGRAArrow.ComputeAnyAt(const AData: ArrayOfTPointF; const APosition,
81 ADirection: TPointF): ArrayOfTPointF;
82var m: TAffineMatrix;
83 i: integer;
84begin
85 if (AData = nil) or isEmptyPointF(APosition) or isEmptyPointF(ADirection) or ((ADirection.x = 0) and (ADirection.y = 0)) then
86 begin
87 result := nil;
88 exit;
89 end;
90 m := AffineMatrixTranslation(APosition.x,APosition.y)*AffineMatrixLinear(ADirection, PointF(-ADirection.y, ADirection.x));
91 setlength(result, length(AData));
92 for i := 0 to high(result) do
93 if not isEmptyPointF(AData[i]) then
94 result[i] := m*AData[i]
95 else
96 result[i] := EmptyPointF;
97end;
98
99function TBGRAArrow.ComputeData(AStyle: TBGRAArrowStyle;
100 const ASizeFactor: TPointF; ATipStyle: TPenJoinStyle; ALineCap: TPenEndCap;
101 const AWidth: single; AOffsetX: single; ARepeatCount: integer;
102 ARelativePenWidth: single; ATriangleBackOffset: single): ArrayOfTPointF;
103var sizeFactorX,sizeFactorY,ofsX: single;
104 prefix,suffix,middle: ArrayOfTPointF;
105 arc: TArcDef;
106 i,j,n : integer;
107 withCut: ArrayOfTPointF;
108 subResult: ArrayOfTPointF;
109 w: single;
110 backOfs: single;
111 tailSizeX, tailAdditionalWidth: single;
112begin
113 sizeFactorX := abs(ASizeFactor.X)*AWidth;
114 sizeFactorY := abs(ASizeFactor.Y)*AWidth;
115 if (sizeFactorX = 0) or (sizeFactorY = 0) then
116 begin
117 result := nil;
118 exit;
119 end;
120 w := AWidth*ARelativePenWidth;
121 if AStyle in [asTail,asTailRepeat] then
122 begin
123 tailSizeX := sizeFactorX/SizeFactorY*AWidth*0.5;
124 if AStyle = asTailRepeat then
125 begin
126 tailAdditionalWidth:= AWidth-tailSizeX;
127 if tailAdditionalWidth < 0 then tailAdditionalWidth := 0;
128 end else
129 tailAdditionalWidth:=0;
130 end
131 else
132 begin
133 tailSizeX := 0;
134 tailAdditionalWidth:=0;
135 end;
136 case AStyle of
137 asTriangle,asHollowTriangle: begin
138 backOfs := ATriangleBackOffset*sizeFactorX;
139 if AStyle = asHollowTriangle then
140 begin
141 result := ComputeWidePolylinePoints(PointsF([PointF(0.5*w,-AWidth*0.5),
142 PointF(0.5*w-backOfs,-sizeFactorY+w*0.5),
143 PointF(sizeFactorX-w*0.5,0),
144 PointF(w*0.5-backOfs,sizeFactorY-w*0.5),
145 PointF(0.5*w,AWidth*0.5)]),
146 w,BGRABlack,ALineCap,ATipStyle,nil,[plCycle]);
147 end else
148 begin
149 prefix := PointsF([PointF(0,-AWidth*0.5),PointF(-backOfs,-sizeFactorY)]);
150 suffix := PointsF([PointF(-backOfs,sizeFactorY),PointF(0,AWidth*0.5)]);
151 if (ATipStyle in[pjsRound,pjsBevel]) then
152 begin
153 arc := Html5ArcTo(prefix[1],PointF(sizeFactorX,0),suffix[0],AWidth*0.5);
154 if ATipStyle = pjsRound then
155 middle := ComputeArc(arc)
156 else
157 middle := PointsF([ArcStartPoint(arc),ArcEndPoint(arc)]);
158 end
159 else middle := PointsF([PointF(sizeFactorX,0)]);
160 result := ConcatPointsF([prefix,middle,suffix]);
161 end;
162 end;
163 asNormal,asCut:
164 begin
165 if AStyle = asCut then ALineCap:= pecSquare;
166 result := ComputeWidePolylinePoints([PointF(-sizeFactorX,-sizeFactorY),
167 PointF(0,0),PointF(-sizeFactorX,+sizeFactorY)],w,BGRABlack,ALineCap,ATipStyle,nil,[]);
168 end;
169 asFlipped,asFlippedCut:
170 begin
171 if AStyle = asFlippedCut then ALineCap:= pecSquare;
172 result := ComputeWidePolylinePoints([PointF(+sizeFactorX,-sizeFactorY),
173 PointF(0,0),PointF(+sizeFactorX,+sizeFactorY)],w,BGRABlack,ALineCap,ATipStyle,nil,[]);
174 end;
175 asTail: result := PointsF([PointF(0,-0.5*AWidth),PointF(tailSizeX,-0.5*AWidth),PointF(0,0),PointF(tailSizeX,0.5*AWidth),PointF(0,0.5*AWidth)]);
176 asTailRepeat: result := PointsF([PointF(0,-0.5*AWidth),PointF(tailSizeX+tailAdditionalWidth,-0.5*AWidth),PointF(tailAdditionalWidth,0),PointF(tailSizeX+tailAdditionalWidth,0.5*AWidth),PointF(0,0.5*AWidth),PointF(-tailSizeX,0)]);
177 else
178 result := nil;
179 end;
180 if (AStyle in [asCut,asFlippedCut,asHollowTriangle]) then
181 begin
182 n := 0;
183 setlength(withCut,length(result)*2);
184 for i := 0 to high(result) do
185 if isEmptyPointF(result[i]) then
186 begin
187 if (n > 0) and not isEmptyPointF(withCut[n-1]) then
188 begin
189 withCut[n] := EmptyPointF;
190 inc(n);
191 end;
192 end else
193 if abs(result[i].y)<=sizeFactorY then
194 begin
195 withCut[n] := result[i];
196 inc(n);
197 end else
198 if result[i].y>sizeFactorY then
199 begin
200 j := (i+length(result)-1) mod length(result);
201 if result[j].y<=sizeFactorY then
202 begin
203 withCut[n].x := result[j].x + (result[i].x-result[j].x)/(result[i].y-result[j].y)*(sizeFactorY-result[j].y);
204 withCut[n].y := sizeFactorY;
205 inc(n);
206 end;
207 j := (i+1) mod length(result);
208 if result[j].y<=sizeFactorY then
209 begin
210 withCut[n].x := result[j].x + (result[i].x-result[j].x)/(result[i].y-result[j].y)*(sizeFactorY-result[j].y);
211 withCut[n].y := sizeFactorY;
212 inc(n);
213 end;
214 end else
215 if result[i].y<-sizeFactorY then
216 begin
217 j := (i+length(result)-1) mod length(result);
218 if result[j].y>=-sizeFactorY then
219 begin
220 withCut[n].x := result[j].x + (result[i].x-result[j].x)/(result[i].y-result[j].y)*(-sizeFactorY-result[j].y);
221 withCut[n].y := -sizeFactorY;
222 inc(n);
223 end;
224 j := (i+1) mod length(result);
225 if result[j].y>=-sizeFactorY then
226 begin
227 withCut[n].x := result[j].x + (result[i].x-result[j].x)/(result[i].y-result[j].y)*(-sizeFactorY-result[j].y);
228 withCut[n].y := -sizeFactorY;
229 inc(n);
230 end;
231 end;
232 if (n > 0) and isEmptyPointF(withCut[n-1]) then dec(n);
233 setlength(withCut,n);
234 result := withCut;
235 end;
236 if AOffsetX <> 0 then
237 begin
238 ofsX := AOffsetX*AWidth;
239 for i := 0 to high(result) do
240 if not isEmptyPointF(result[i]) then
241 result[i].x += ofsX;
242 end;
243 if ARepeatCount > 1 then
244 begin
245 if ARepeatCount > 10 then ARepeatCount:= 10;
246 if AStyle in[asTriangle,asHollowTriangle] then AOffsetX += sizeFactorX/AWidth
247 else if AStyle in[asTail,asTailRepeat] then AOffsetX += (tailSizeX+tailAdditionalWidth)/AWidth+1
248 else AOffsetX += 2*ARelativePenWidth;
249 if AStyle = asTail then AStyle := asTailRepeat;
250 subResult := ComputeData(AStyle,ASizeFactor,ATipStyle,ALineCap,AWidth,AOffsetX,ARepeatCount-1,ARelativePenWidth,ATriangleBackOffset);
251 result := ConcatPointsF([result,PointsF([EmptyPointF]),subResult]);
252 end;
253end;
254
255function TBGRAArrow.GetIsEndDefined: boolean;
256begin
257 result := FEndStyle <> asNone;
258end;
259
260function TBGRAArrow.GetIsStartDefined: boolean;
261begin
262 result := FStartStyle <> asNone;
263end;
264
265function TBGRAArrow.GetEndOffsetX: single;
266begin
267 result := FEndOffsetX;
268end;
269
270function TBGRAArrow.GetStartOffsetX: single;
271begin
272 result := FStartOffsetX;
273end;
274
275function TBGRAArrow.GetStartRepeatCount: integer;
276begin
277 result := FStartRepeatCount;
278end;
279
280function TBGRAArrow.GetStartSizeFactor: TPointF;
281begin
282 result := FStartSizeFactor;
283end;
284
285procedure TBGRAArrow.SetEndOffsetX(AValue: single);
286begin
287 if FEndOffsetX=AValue then Exit;
288 FEndOffsetX:=AValue;
289 FEndComputed:= false;
290 FEnd := nil;
291end;
292
293function TBGRAArrow.GetLineCap: TPenEndCap;
294begin
295 result := FLineCap;
296end;
297
298procedure TBGRAArrow.SetEndRepeatCount(AValue: integer);
299begin
300 if FEndRepeatCount=AValue then Exit;
301 FEndRepeatCount:=AValue;
302 FEndComputed:= false;
303 FEnd := nil;
304end;
305
306procedure TBGRAArrow.SetEndSizeFactor(AValue: TPointF);
307begin
308 if FEndSizeFactor=AValue then Exit;
309 FEndSizeFactor:=AValue;
310 FEndComputed:= false;
311 FEnd := nil;
312end;
313
314procedure TBGRAArrow.SetLineCap(AValue: TPenEndCap);
315begin
316 if FLineCap=AValue then Exit;
317 FLineCap:=AValue;
318 FStartComputed:= false;
319 FEndComputed:= false;
320 FStart:= nil;
321 FEnd := nil;
322end;
323
324procedure TBGRAArrow.SetStartOffsetX(AValue: single);
325begin
326 if FStartOffsetX=AValue then Exit;
327 FStartOffsetX:=AValue;
328 FStartComputed:= false;
329 FStart := nil;
330end;
331
332procedure TBGRAArrow.SetStartRepeatCount(AValue: integer);
333begin
334 if FStartRepeatCount=AValue then Exit;
335 FStartRepeatCount:=AValue;
336 FStartComputed:= false;
337 FStart := nil;
338end;
339
340procedure TBGRAArrow.SetStartSizeFactor(AValue: TPointF);
341begin
342 if FStartSizeFactor=AValue then Exit;
343 FStartSizeFactor:=AValue;
344 FStartComputed:= false;
345 FStart := nil;
346end;
347
348procedure TBGRAArrow.SetWidth(AValue: single);
349begin
350 if FWidth=AValue then Exit;
351 FWidth:=AValue;
352 FStartComputed := false;
353 FEndComputed:= false;
354end;
355
356function TBGRAArrow.GetEndRepeatCount: integer;
357begin
358 Result:= FEndRepeatCount;
359end;
360
361function TBGRAArrow.GetEndSizeFactor: TPointF;
362begin
363 Result:= FEndSizeFactor;
364end;
365
366constructor TBGRAArrow.Create;
367begin
368 FWidth := 1;
369 FStartSizeFactor := PointF(2,2);
370 FEndSizeFactor := PointF(2,2);
371end;
372
373procedure TBGRAArrow.StartAsNone;
374begin
375 SetStart(asNone);
376end;
377
378procedure TBGRAArrow.StartAsClassic(AFlipped: boolean; ACut: boolean;
379 ARelativePenWidth: single);
380var join: TPenJoinStyle;
381begin
382 if (LineCap = pecRound) and not ACut then join := pjsRound else join := pjsMiter;
383 if ACut then
384 begin
385 if AFlipped then
386 SetStart(asFlippedCut,join,ARelativePenWidth)
387 else
388 SetStart(asCut,join,ARelativePenWidth)
389 end
390 else
391 begin
392 if AFlipped then
393 SetStart(asFlipped,join,ARelativePenWidth)
394 else
395 SetStart(asNormal,join,ARelativePenWidth)
396 end;
397end;
398
399procedure TBGRAArrow.StartAsTriangle(ABackOffset: single; ARounded: boolean;
400 AHollow: boolean; AHollowPenWidth: single);
401var join: TPenJoinStyle;
402begin
403 if ARounded then join := pjsRound else join := pjsMiter;
404 if AHollow then
405 SetStart(asHollowTriangle, join,AHollowPenWidth, ABackOffset)
406 else
407 SetStart(asTriangle, join,1,ABackOffset);
408end;
409
410procedure TBGRAArrow.StartAsTail;
411begin
412 SetStart(asTail);
413end;
414
415procedure TBGRAArrow.EndAsNone;
416begin
417 SetEnd(asNone);
418end;
419
420procedure TBGRAArrow.EndAsClassic(AFlipped: boolean; ACut: boolean;
421 ARelativePenWidth: single);
422var join: TPenJoinStyle;
423begin
424 if (LineCap = pecRound) and not ACut then join := pjsRound else join := pjsMiter;
425 if ACut then
426 begin
427 if AFlipped then
428 SetEnd(asFlippedCut,join,ARelativePenWidth)
429 else
430 SetEnd(asCut,join,ARelativePenWidth)
431 end
432 else
433 begin
434 if AFlipped then
435 SetEnd(asFlipped,join,ARelativePenWidth)
436 else
437 SetEnd(asNormal,join,ARelativePenWidth)
438 end;
439end;
440
441procedure TBGRAArrow.EndAsTriangle(ABackOffset: single; ARounded: boolean;
442 AHollow: boolean; AHollowPenWidth: single);
443var join: TPenJoinStyle;
444begin
445 if ARounded then join := pjsRound else join := pjsMiter;
446 if AHollow then
447 SetEnd(asHollowTriangle, join,AHollowPenWidth, ABackOffset)
448 else
449 SetEnd(asTriangle, join,1, ABackOffset);
450end;
451
452procedure TBGRAArrow.EndAsTail;
453begin
454 SetEnd(asTail);
455end;
456
457procedure TBGRAArrow.SetStart(AStyle: TBGRAArrowStyle;
458 ATipStyle: TPenJoinStyle; ARelativePenWidth: single; ATriangleBackOffset: single);
459begin
460 FStartStyle := AStyle;
461 FStartTipStyle := ATipStyle;
462 FStartComputed := false;
463 FStartRelativePenWidth:= ARelativePenWidth;
464 FStartTriangleBackOffset := ATriangleBackOffset;
465 FStart := nil;
466end;
467
468procedure TBGRAArrow.SetEnd(AStyle: TBGRAArrowStyle; ATipStyle: TPenJoinStyle;
469 ARelativePenWidth: single; ATriangleBackOffset: single);
470begin
471 FEndStyle := AStyle;
472 FEndTipStyle := ATipStyle;
473 FEndComputed := false;
474 FEndRelativePenWidth:= ARelativePenWidth;
475 FEndTriangleBackOffset := ATriangleBackOffset;
476 FEnd := nil;
477end;
478
479function TBGRAArrow.ComputeStartAt(const APosition: TPointF;
480 const ADirection: TPointF; const AWidth: single; const ACurrentPos: single
481 ): ArrayOfTPointF;
482begin
483 if not IsStartDefined then
484 begin
485 result := nil;
486 exit;
487 end;
488 if AWidth <> FWidth then
489 begin
490 FWidth := AWidth;
491 FStartComputed:= false;
492 end;
493 if not FStartComputed then
494 begin
495 FStart := ComputeData(FStartStyle,FStartSizeFactor,FStartTipStyle,FLineCap,FWidth,
496 FStartOffsetX-ACurrentPos,FStartRepeatCount,FStartRelativePenWidth,FStartTriangleBackOffset);
497 FStartComputed:= true;
498 end;
499 result := ComputeAnyAt(FStart,APosition,ADirection);
500end;
501
502function TBGRAArrow.ComputeEndAt(const APosition: TPointF;
503 const ADirection: TPointF; const AWidth: single; const ACurrentPos: single
504 ): ArrayOfTPointF;
505begin
506 if not IsEndDefined then
507 begin
508 result := nil;
509 exit;
510 end;
511 if AWidth <> FWidth then
512 begin
513 FWidth := AWidth;
514 FEndComputed:= false;
515 end;
516 if not FEndComputed then
517 begin
518 FEnd := ComputeData(FEndStyle,FEndSizeFactor,FEndTipStyle,FLineCap,FWidth,
519 FEndOffsetX-ACurrentPos,FEndRepeatCount,FEndRelativePenWidth,FEndTriangleBackOffset);
520 FEndComputed:= true;
521 end;
522 result := ComputeAnyAt(FEnd,APosition,ADirection);
523end;
524
525end.
526
Note: See TracBrowser for help on using the repository browser.