{ Mapviewer drawing engine (C) 2019 Werner Pamler (user wp at Lazarus forum https://forum.lazarus.freepascal.org) License: modified LGPL with linking exception (like RTL, FCL and LCL) See the file COPYING.modifiedLGPL.txt, included in the Lazarus distribution, for details about the license. See also: https://wiki.lazarus.freepascal.org/FPC_modified_LGPL } unit mvDrawingEngine; {$mode objfpc}{$H+} interface uses Classes, SysUtils, Graphics, Types, IntfGraphics, mvCache; type TItemDrawMode = (idmDraw, idmUseOpacity, idmUseSourceAlpha); TLineDrawProc = procedure(X1, Y1, X2, Y2: Integer) of Object; TPointArray = array of TPoint; { TMvCustomDrawingEngine } TMvCustomDrawingEngine = class(TComponent) protected function GetPenStyle: TPenStyle; virtual; abstract; function GetBrushColor: TColor; virtual; abstract; function GetBrushStyle: TBrushStyle; virtual; abstract; function GetFontColor: TColor; virtual; abstract; function GetFontName: String; virtual; abstract; function GetFontSize: Integer; virtual; abstract; function GetFontStyle: TFontStyles; virtual; abstract; function GetPenColor: TColor; virtual; abstract; function GetPenWidth: Integer; virtual; abstract; procedure SetPenStyle(AValue: TPenStyle); virtual; abstract; procedure SetBrushColor(AValue: TColor); virtual; abstract; procedure SetBrushStyle(AValue: TBrushStyle); virtual; abstract; procedure SetFontColor(AValue: TColor); virtual; abstract; procedure SetFontName(AValue: String); virtual; abstract; procedure SetFontSize(AValue: Integer); virtual; abstract; procedure SetFontStyle(AValue: TFontStyles); virtual; abstract; procedure SetPenColor(AValue: TColor); virtual; abstract; procedure SetPenWidth(AValue: Integer); virtual; abstract; class procedure DoScanFill(APoly: array of TPoint; ALineDrawProc: TLineDrawProc); class procedure CalcBezier(APoints: array of TPoint; Continuous: Boolean; out APoly: TPointArray); class function ComparePoints(constref L, R: TPoint): Integer; public function GetCacheItemClass: TPictureCacheItemClass; virtual; abstract; procedure CreateBuffer(AWidth, AHeight: Integer); virtual; abstract; procedure DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap; UseAlphaChannel: Boolean); virtual; abstract; // Drawing bitmap with a given opaque and transparent colors procedure DrawBitmapOT(X, Y: Integer; ABitmap: TCustomBitmap; AOpaqueColor, ATransparentColor: TColor); virtual; procedure DrawCacheItem(X, Y: Integer; AImg: TPictureCacheItem; ADrawMode: TItemDrawMode = idmDraw; AOpacity: Single = 1.0); virtual; abstract; procedure DrawScaledCacheItem(DestRect, SrcRect: TRect; AImg: TPictureCacheItem); virtual; abstract; procedure Ellipse(X1, Y1, X2, Y2: Integer); virtual; abstract; procedure FillPixels(X1, Y1, X2, Y2: Integer; AColor: TColor); virtual; abstract; procedure FillRect(X1, Y1, X2, Y2: Integer); virtual; abstract; procedure Line(X1, Y1, X2, Y2: Integer); virtual; abstract; procedure Polyline(const Points: array of TPoint); virtual; abstract; procedure Polygon(const Points: array of TPoint); virtual; abstract; procedure PolyBezier(const Points: array of TPoint; Filled: Boolean = False; Continuous: Boolean = True); virtual; abstract; procedure PaintToCanvas(ACanvas: TCanvas); virtual; abstract; procedure Rectangle(X1, Y1, X2, Y2: Integer); virtual; abstract; function SaveToImage(AClass: TRasterImageClass): TRasterImage; virtual; abstract; function TextExtent(const AText: String): TSize; virtual; abstract; function TextHeight(const AText: String): Integer; procedure TextOut(X, Y: Integer; const AText: String); virtual; abstract; function TextWidth(const AText: String): Integer; property BrushColor: TColor read GetBrushColor write SetBrushColor; property BrushStyle: TBrushStyle read GetBrushStyle write SetBrushStyle; property FontColor: TColor read GetFontColor write SetFontColor; property FontName: String read GetFontName write SetFontName; property FontSize: Integer read GetFontSize write SetFontSize; property FontStyle: TFontStyles read GetFontStyle write SetFontStyle; property PenColor: TColor read GetPenColor write SetPenColor; property PenWidth: Integer read GetPenWidth write SetPenWidth; property PenStyle: TPenStyle read GetPenStyle write SetPenStyle; end; // Vector orthogonal to a line , function OrthoVec(X1, Y1, X2, Y2: Integer; out MX, MY: Double): Boolean; // Intersection point between line segments and // Returns: // 0 - colinear line segments // 1 - line segments intersect at PX // 2 - colinear overlapping line segments, PX lies on both // function Intersect(P1, P2, P3, P4: TPoint; out PX: TPoint): Integer; // Polyline bounds procedure PolyBounds(APoly: array of TPoint; out ABounds: TRect); implementation uses Math, LCLType, FPImage, GraphMath, Generics.Collections, Generics.Defaults; function Intersect(P1, P2, P3, P4: TPoint; out PX: TPoint): Integer; var t, d, u: LongInt; f2: Boolean = False; begin Result := 0; d := (P1.X - P2.X) * (P3.Y - P4.Y) - (P1.Y - P2.Y) * (P3.X - P4.X); if d = 0 then // colinear? begin // P1 on line P3,P4? d := (P1.X - P3.X) * (P4.Y - P3.Y) - (P1.Y - P3.Y) * (P4.X - P3.X); if (P3 = P4) or (d <> 0) then Exit; // P1,P3,P4 not colinear // Trick the intersection by changing the second segment Dec(P3.Y); Inc(P4.Y); d := (P1.X - P2.X) * (P3.Y - P4.Y) - (P1.Y - P2.Y) * (P3.X - P4.X); f2 := True; end; t := (P1.X - P3.X) * (P3.Y - P4.Y) - (P1.Y - P3.Y) * (P3.X - P4.X); if (Sign(t) * Sign(d) < 0) or (Abs(t) > Abs(d)) then // 0 <= t/d <= 1 Exit; u := (P1.X - P3.X) * (P1.Y - P2.Y) - (P1.Y - P3.Y) * (P1.X - P2.X); if (Sign(u) * Sign(d) < 0) or (Abs(u) > Abs(d)) then // 0 <= u/d <= 1 Exit; PX.X := P1.X + Round(Double(t) * (P2.X - P1.X) / d); PX.Y := P1.Y + Round(Double(t) * (P2.Y - P1.Y) / d); if f2 then Result := 2 // Second segment changed else Result := 1; end; procedure PolyBounds(APoly: array of TPoint; out ABounds: TRect); var I, XMax, XMin, YMax, YMin: LongInt; begin ABounds := Default(TRect); if Length(APoly) < 1 then Exit; XMax := APoly[0].X; XMin := XMax; YMax := APoly[0].Y; YMin := YMax; for I := 1 to High(APoly) do begin if APoly[I].X > XMax then XMax := APoly[I].X else if APoly[I].X < XMin then XMin := APoly[I].X; if APoly[I].Y > YMax then YMax := APoly[I].Y else if APoly[I].Y < YMin then YMin := APoly[I].Y; end; ABounds := Rect(XMin, YMin, XMax, YMax); end; function OrthoVec(X1, Y1, X2, Y2: Integer; out MX, MY: Double): Boolean; var DX, DY: Integer; B: Double; // Inverted vector magnitude function InvMagn(X, Y: Double): Double; inline; begin Result := 1.0 / Sqrt(X * X + Y * Y); end; begin if (Y1 = Y2) and (X1 = X2) then Exit(False); DX := X2 - X1; DY := Y2 - Y1; MX := 1.0; MY := 1.0; if DX = 0 then MY := 0.0 // <1.0, 0.0> else if DY = 0 then MX := 0.0 // <0.0, 1.0> else begin B := InvMagn(DX, DY); MX := DY * B; MY := -DX * B; end; Result := True; end; class procedure TMvCustomDrawingEngine.DoScanFill(APoly: array of TPoint; ALineDrawProc: TLineDrawProc); var XI, YI: LongInt; NPoly: array of TPoint = Nil; Bounds: TRect; XPoints: specialize TList; I, R, L: Integer; // Intersect NPoly with the scan line segment . Result in XPoints. procedure ScanLineIntersect(const A, B: TPoint); var I, FirstI, LastI: Integer; X: TPoint; // Return next index with wrapping function Nxt(I: Integer): Integer; inline; begin if I = L then Result := 0 else Result := Succ(I); end; // Return prior index with wrapping function Pri(I: Integer): Integer; inline; begin if I = 0 then Result := L else Result := Pred(I); end; // Logic at a vertice, LI - prev index, RI - next index, PI - for deletion function Vertice(LI, RI, PI: Integer): Boolean; var S1, S2: TValueSign; begin repeat // Prior vertice which is above/below S1 := Sign(A.Y - NPoly[LI].Y); if S1 <> 0 then Break; LI := Pri(LI); until LI = RI; repeat // Next vertice which is above/below S2 := Sign(A.Y - NPoly[RI].Y); if S2 <> 0 then Break; RI := Nxt(RI); until RI = LI; // Both neighboring vertices are on the same side? Result := not ((S1 + S2 = 0) and (S1 <> 0)); if Result then XPoints.Delete(PI); // Delete other (PI) end; // Add an intersection point, with a vertice logic procedure AddPoint(X: TPoint); begin if XPoints.Count = 0 then begin XPoints.Add(X); FirstI := I; LastI := I; end // Twice (on the vertice)? else if (Nxt(LastI) = I) and (XPoints.Last = X) then Vertice(LastI, Nxt(I), Pred(XPoints.Count)) // Twice (on the vertice)? Last point. else if (Nxt(I) = FirstI) and (XPoints.First = X) then Vertice(I, Nxt(FirstI), 0) else begin XPoints.Add(X); LastI := I; end; end; begin XPoints.Clear; for I := 0 to L do begin R := Intersect(A, B, NPoly[I], NPoly[Nxt(I)], X); case R of 1: // One intersection point, X AddPoint(X); 2: // The current segment of the polyline is on the scan line begin AddPoint(NPoly[I]); AddPoint(NPoly[Nxt(I)]); end; otherwise ; // No intersection end; end; XPoints.Sort(specialize TComparer.Construct(@ComparePoints)); end; begin // Make a new polygon on a 2x grid with no zero length or horizontal lines SetLength(NPoly, Length(APoly)); L := 0; I := 0; YI := MaxInt; // Y of the previous point while I < Length(APoly) do begin NPoly[L].X := APoly[I].X shl 1; // X * 2 R := APoly[I].Y shl 1; if R = YI // Last Y was the same? then R := R + 1; // Make it non horizontal NPoly[L].Y := R; // Y * 2 YI := R; // Keep Y for the next Inc(L); XI := Succ(I); // Scan for the next non zero length while (XI < Length(APoly)) and (APoly[XI] = APoly[I]) do Inc(XI); I := XI; end; Dec(L); // L must be at the last point if NPoly[0] = NPoly[L] then Dec(L); // Skip last if it is closed // Get bounds of the new polygon PolyBounds(NPoly, Bounds); XPoints := specialize TList.Create; try // Scan each other horizontal line YI := Bounds.Top; while YI < Bounds.Bottom do begin // Intersect with the polygon ScanLineIntersect(Point(Bounds.Left, YI), Point(Bounds.Right, YI)); // Draw lines, even - odd if XPoints.Count > 0 then for XI := 0 to XPoints.Count div 2 - 1 do ALineDrawProc( XPoints[XI * 2].X shr 1, YI shr 1, XPoints[XI * 2 + 1].X shr 1, YI shr 1); Inc(YI, 2); end; finally XPoints.Free; end; end; class procedure TMvCustomDrawingEngine.CalcBezier(APoints: array of TPoint; Continuous: Boolean; out APoly: TPointArray); var NPoints: Integer; PtArray: PPoint; PtCount: LongInt = 0; begin NPoints := Length(APoints); if NPoints < 4 then Exit; // Curve must have at least 4 points PtArray := Nil; APoly := Nil; try PolyBezier2Polyline(APoints, PtArray, PtCount, Continuous); if PtCount > 0 then begin SetLength(APoly, PtCount); Move(PtArray^, APoly[0], PtCount * SizeOf(TPoint)); end; finally ReallocMem(PtArray, 0); end; end; class function TMvCustomDrawingEngine.ComparePoints(constref L, R: TPoint ): Integer; begin Result := L.X - R.X; if Result = 0 then Result := L.Y - R.Y; end; procedure TMvCustomDrawingEngine.DrawBitmapOT(X, Y: Integer; ABitmap: TCustomBitmap; AOpaqueColor, ATransparentColor: TColor); var img: TLazIntfImage; i, j: Integer; c: TColor; fc, tc: TFPColor; intens, intens0: Int64; alpha: Double; hb, hm: HBitmap; begin img := ABitmap.CreateIntfImage; try fc := TColorToFPColor(AOpaqueColor); intens0 := Int64(fc.Red) + fc.Green + fc.Blue; for j := 0 to img.Height - 1 do for i := 0 to img.Width - 1 do begin c := ABitmap.Canvas.Pixels[i, j]; tc := TColorToFPColor(c); if c = ATransparentColor then tc.Alpha := alphaTransparent else if c = AOpaqueColor then tc.Alpha := alphaOpaque else begin intens := Int64(tc.Red) + tc.Green + tc.Blue; if intens0 = 0 then alpha := (3 * alphaopaque - intens) / (3 * alphaOpaque - intens0) else alpha := intens / intens0; tc.Alpha := round(alphaOpaque * alpha); end; img.Colors[i, j] := tc; end; img.CreateBitmaps(hb, hm); ABitmap.Handle := hb; ABitmap.MaskHandle := hm; DrawBitmap(X, Y, ABitmap, true); finally img.Free; end; end; function TMvCustomDrawingEngine.TextHeight(const AText: String): Integer; begin Result := TextExtent(AText).CX; end; function TMvCustomDrawingEngine.TextWidth(const AText: String): Integer; begin Result := TextExtent(AText).CY; end; end.