lazarus-ccr/components/lazmapviewer/source/mvdrawingengine.pas

{ 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 <MX, MY> orthogonal to a line <X1, Y1>, <X2, Y2>
function OrthoVec(X1, Y1, X2, Y2: Integer; out MX, MY: Double): Boolean;

// Intersection point between line segments <P1, P2> and <P3, P4>
// 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;
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 // Quick and dirty...
    if CompareValue(Abs(DY/DX), 1.0, 0.5) = 0
      then B := 0.7
      else B := 1.0;
    MX := EnsureRange(-DY/DX, -B, B);
    MY := EnsureRange(-DX/DY, -B, B);
    if Sign(DX) = Sign(DY) then
      MX := -MX;
    {$IFDEF 0}
    // The correct way
    A := ArcTan2(-DX, DY);
    MX := Cos(A);
    MY := Sin(A);
    {$IFEND}
  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<TPoint>;
  I, R, L: Integer;

  // Intersect NPoly with the scan line segment <A, B>. 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<TPoint>.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<TPoint>.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.