LazMapViewer: Implement zoomed preview tiles. Patch by Ekkehard Domning. Adapt drawing engines and full demo projects.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8835 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2023-06-13 15:39:47 +00:00
parent d9eb6e9065
commit 875a3a826d
12 changed files with 300 additions and 27 deletions
--- a/components/lazmapviewer/source/addons/bgra_drawingengine/mvde_bgra.pas
+++ b/components/lazmapviewer/source/addons/bgra_drawingengine/mvde_bgra.pas
@@ -57,6 +57,7 @@ type
    procedure DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap;
      UseAlphaChannel: Boolean); override;
    procedure DrawLazIntfImage(X, Y: Integer; AImg: TLazIntfImage); override;
+    procedure DrawScaledLazIntfImage(DestRect, SrcRect: TRect; ASrcImg: TLazIntfImage); override;
    procedure Ellipse(X1, Y1, X2, Y2: Integer); override;
    procedure FillPixels(X1, Y1, X2, Y2: Integer; AColor: TColor); override;
    procedure FillRect(X1, Y1, X2, Y2: Integer); override;
@@ -138,6 +139,29 @@ begin
  end;
 end;

+procedure TMvBGRADrawingEngine.DrawScaledLazIntfImage(
+  DestRect, SrcRect: TRect; ASrcImg: TLazIntfImage);
+var
+  srcBmp: TBGRABitmap;
+  x, y, w, h: Integer;
+  c: TFPColor;
+begin
+  w := SrcRect.Right - SrcRect.Left;
+  h := SrcRect.Bottom - SrcRect.Top;
+  srcBmp := TBGRABitmap.Create(w, h, clWhite);
+  try
+    for y := 0 to h-1 do
+      for x := 0 to w-1 do
+      begin
+        c := ASrcImg.Colors[SrcRect.Left + x, SrcRect.Top + y];
+        srcBmp.DrawPixel(x, y, FPColorToTColor(c));
+      end;
+    FBuffer.CanvasBGRA.StretchDraw(DestRect, srcBmp);
+  finally
+    srcBmp.Free;
+  end;
+end;
+
 procedure TMvBGRADrawingEngine.Ellipse(X1, Y1, X2, Y2: Integer);
 begin
  FBuffer.CanvasBGRA.Ellipse(X1, Y1, X2, Y2);
--- a/components/lazmapviewer/source/addons/rgbgraphics_drawingengine/mvde_rgbgraphics.pas
+++ b/components/lazmapviewer/source/addons/rgbgraphics_drawingengine/mvde_rgbgraphics.pas
@@ -19,7 +19,7 @@ interface
 uses
  Classes, SysUtils, Types, Graphics, IntfGraphics,
  mvDrawingEngine,
-  rgbGraphics;
+  rgbGraphics, rgbTypes;

 type

@@ -57,6 +57,7 @@ type
    procedure DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap;
      UseAlphaChannel: Boolean); override;
    procedure DrawLazIntfImage(X, Y: Integer; AImg: TLazIntfImage); override;
+    procedure DrawScaledLazIntfImage(DestRect, SrcRect: TRect; ASrcImg: TLazIntfImage); override;
    procedure Ellipse(X1, Y1, X2, Y2: Integer); override;
    procedure FillPixels(X1, Y1, X2, Y2: Integer; AColor: TColor); override;
    procedure FillRect(X1, Y1, X2, Y2: Integer); override;
@@ -135,9 +136,10 @@ begin
  {$IFDEF DARWIN}
  rawImg.Description.Init_BPP32_A8R8G8B8_BIO_TTB(FBuffer.Width, FBuffer.Height);
  {$ELSE}
-  rawImg.Description.Init_BPP32_B8G8R8_BIO_TTB(FBuffer.Width, FBuffer.Height);
+//  rawImg.Description.Init_BPP32_B8G8R8_BIO_TTB(FBuffer.Width, FBuffer.Height);        // wp: why twice: here ...
+ // {$ENDIF}
+  rawImg.Description.Init_BPP32_B8G8R8A8_BIO_TTB(FBuffer.Width, FBuffer.Height);      // ... and here again ???
  {$ENDIF}
-  rawImg.Description.Init_BPP32_B8G8R8A8_BIO_TTB(FBuffer.Width, FBuffer.Height);
  rawImg.Data := FBuffer.Pixels;
  intfImg := TLazIntfImage.Create(rawImg, false);
  try
@@ -148,6 +150,30 @@ begin
  end;
 end;

+procedure TMvRGBGraphicsDrawingEngine.DrawScaledLazIntfImage(
+  DestRect, SrcRect: TRect; ASrcImg: TLazIntfImage);
+var
+  srcBmp: TRGB32Bitmap;
+  x, y, w, h: Integer;
+  c: TFPColor;
+begin
+  w := SrcRect.Right - SrcRect.Left;
+  h := SrcRect.Bottom - SrcRect.Top;
+  srcBmp := TRGB32Bitmap.Create(w, h);
+  try
+    for y := 0 to h-1 do
+      for x := 0 to w-1 do
+      begin
+        c := ASrcImg.Colors[SrcRect.Left + x, SrcRect.Top + y];
+        srcBmp.Set32Pixel(x, y, ColorToRGB32Pixel(FPColorToTColor(c)));
+      end;
+    srcBmp.StretchTrunc(DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top);
+    FBuffer.Draw(DestRect.Left, DestRect.Top, srcBmp);
+  finally
+    srcBmp.Free;
+  end;
+end;
+
 procedure TMvRGBGraphicsDrawingEngine.Ellipse(X1, Y1, X2, Y2: Integer);
 begin
  FBuffer.Canvas.Ellipse(X1, Y1, X2, Y2);
--- a/components/lazmapviewer/source/mvcache.pas
+++ b/components/lazmapviewer/source/mvcache.pas
@@ -48,6 +48,7 @@ Type
     destructor Destroy; override;
     Procedure Add(MapProvider: TMapProvider; const TileId: TTileId; Stream: TMemoryStream);
     Procedure GetFromCache(MapProvider: TMapProvider; const TileId: TTileId; out img: TLazIntfImage);
+     function GetPreviewFromCache(MapProvider: TMapProvider; var TileId: TTileId; out ARect: TRect): boolean;
     function InCache(MapProvider: TMapProvider; const TileId: TTileId): Boolean;

     property UseDisk: Boolean read FUseDisk write FUseDisk;
@@ -347,6 +348,64 @@ begin
  end;
 end;

+{ When TileId is not yet in the cache, the function decreases zoom level and
+  returns the TileID of a tile which already is in the cache, and in ARect
+  the rectangle coordinates to get an upscaled preview of the originally
+  requested tile. The function returns true in this case.
+  If the requested tile already is in the cache, or no containing tile is found
+  the function returns false indicating that not preview image must be
+  generated. }
+function TPictureCache.GetPreviewFromCache(MapProvider: TMapProvider;
+  var TileId: TTileId; out ARect: TRect): boolean;
+var
+  ltid: TTileId;
+  xfrac, yfrac: Double;
+  lDeltaZoom: Integer;
+  w, px, py: Integer;
+begin
+  Result := false;
+  ARect := Rect(0, 0, 0, 0);
+
+  if (TileId.Z < 0) or
+     (TileId.X < 0) or
+     (TileId.Y < 0) then exit;
+
+  if InCache(MapProvider, TileID) then
+    exit;
+
+  if TileId.Z <= 0 then
+    exit; // The whole earth as a preview, is simply the earth
+
+  // The "preview" is the part of the containing tile that covers the location of the wanted tile
+  // Every decrement of Zoom reduces the tile area by 4 (half of x and y direction)
+  // So incrementing Z and dividing X and Y in the Id will lead us to the containing tile
+  // The fraction of the division points to the location of the preview
+  // e.g 0.5 = right or lower half of the tile, when divided by 2
+  ltid := TileId;
+  lDeltaZoom := 1;
+  w := TILE_SIZE;
+  repeat
+    w := w shr 1;
+    dec(ltid.Z);
+    lDeltaZoom := lDeltaZoom shl 1;
+    xfrac := TileId.X / lDeltaZoom; // xfrac, yfrac contains the tile number
+    yfrac := TileId.Y / lDeltaZoom;
+    ltid.X := Trunc(xfrac);
+    ltid.Y := Trunc(yfrac);
+    if InCache(MapProvider, ltid) then
+    begin // We found a tile in the cache that contains the preview
+      xfrac := xfrac - ltid.X; //xfrac and yfrac calculated for the position in the tile from the cache
+      yfrac := yfrac - ltid.Y;
+      px := Trunc(xfrac * TILE_SIZE); //x and y are the percentage of the tile width
+      py := Trunc(yfrac * TILE_SIZE);
+      ARect := Rect(px, py, px+w, py+w);
+      TileID := ltid;
+      Result := true;
+      exit;
+    end;
+  until (w <= 1) or (ltid.Z <= 0);
+end;
+
 function TPictureCache.InCache(MapProvider: TMapProvider;
  const TileId: TTileId): Boolean;
 var
--- a/components/lazmapviewer/source/mvde_intfgraphics.pas
+++ b/components/lazmapviewer/source/mvde_intfgraphics.pas
@@ -17,7 +17,7 @@ interface

 uses
  Classes, SysUtils, Graphics, Types, LclVersion,
-  FPImage, FPCanvas, IntfGraphics,
+  FPImage, FPCanvas, IntfGraphics, LazCanvas,
  mvDrawingEngine;

 type
@@ -54,6 +54,7 @@ type
    procedure DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap;
      UseAlphaChannel: Boolean); override;
    procedure DrawLazIntfImage(X, Y: Integer; AImg: TLazIntfImage); override;
+    procedure DrawScaledLazIntfImage(DestRect, SrcRect: TRect; ASrcImg: TLazIntfImage); override;
    procedure Ellipse(X1, Y1, X2, Y2: Integer); override;
    procedure FillPixels(X1, Y1, X2, Y2: Integer; AColor: TColor); override;
    procedure FillRect(X1, Y1, X2, Y2: Integer); override;
@@ -223,6 +224,39 @@ begin
  {$IFEND}
 end;

+{ Scales the rectangle SrcRect of the specified source image (ASrcImg) such
+  that it fits into the rectangle DestRect of the Buffer image. }
+procedure TMvIntfGraphicsDrawingEngine.DrawScaledLazIntfImage(
+  DestRect, SrcRect: TRect; ASrcImg: TLazIntfImage);
+var
+  img: TLazIntfImage;
+  w, h, x, y: Integer;
+begin
+  if FCanvas = nil then
+    exit;
+
+  w := SrcRect.Right - SrcRect.Left;
+  h := SrcRect.Bottom - SrcRect.Top;
+
+  img := TLazIntfImage.Create(0, 0);
+  try
+    img.DataDescription := ASrcImg.DataDescription;
+    img.SetSize(w, h);
+    for y := 0 to h-1 do
+      for x := 0 to w-1 do
+        img.Colors[x, y] := ASrcImg.Colors[SrcRect.Left + x, SrcRect.Top + y];;
+    FCanvas.Interpolation := TFPSharpInterpolation.Create;
+    try
+      FCanvas.StretchDraw(DestRect.Left, DestRect.Top, DestRect.Width, DestRect.Height, img);
+    finally
+      FCanvas.Interpolation.Free;
+      FCanvas.Interpolation := nil;
+    end;
+  finally
+    img.Free;
+  end;
+end;
+
 procedure TMvIntfGraphicsDrawingEngine.Ellipse(X1, Y1, X2, Y2: Integer);
 begin
  if FCanvas <> nil then
--- a/components/lazmapviewer/source/mvdrawingengine.pas
+++ b/components/lazmapviewer/source/mvdrawingengine.pas
@@ -43,6 +43,7 @@ type
    procedure DrawBitmap(X, Y: Integer; ABitmap: TCustomBitmap;
      UseAlphaChannel: Boolean); virtual; abstract;
    procedure DrawLazIntfImage(X, Y: Integer; AImg: TLazIntfImage); virtual; abstract;
+    procedure DrawScaledLazIntfImage(DestRect, SrcRect: TRect; AImg: TLazIntfImage); 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;
--- a/components/lazmapviewer/source/mvengine.pas
+++ b/components/lazmapviewer/source/mvengine.pas
@@ -30,9 +30,12 @@ const
  EARTH_ECCENTRICITY = sqrt(1 - sqr(EARTH_POLAR_RADIUS / EARTH_EQUATORIAL_RADIUS));

 type
-  TDrawTileEvent = Procedure (const TileId: TTileId; X,Y: integer;
+  TDrawTileEvent = procedure (const TileId: TTileId; X,Y: integer;
    TileImg: TLazIntfImage) of object;

+  TDrawStretchedTileEvent = procedure (const TileId: TTileId; X,Y: Integer;
+    TileImg: TLazIntfImage; const R: TRect) of object;
+
  TTileIdArray = Array of TTileId;

  TDistanceUnits = (duMeters, duKilometers, duMiles);
@@ -62,10 +65,12 @@ type
      FBkColor: TFPColor;
      FCyclic: Boolean;
      FDownloadEngine: TMvCustomDownloadEngine;
+      FDrawPreviewTiles: Boolean;
      FDrawTitleInGuiThread: boolean;
      FOnCenterMove: TNotifyEvent;
      FOnChange: TNotifyEvent;
      FOnDrawTile: TDrawTileEvent;
+      FOnDrawStretchedTile: TDrawStretchedTileEvent;
      FOnZoomChange: TNotifyEvent;
      lstProvider : TStringList;
      Queue : TJobQueue;
@@ -110,6 +115,7 @@ type
      function GetTileName(const Id: TTileId): String;
      procedure evDownload(Data: TObject; Job: TJob);
      procedure TileDownloaded(Data: PtrInt);
+      procedure DrawStretchedTile(const TileId: TTileID; X, Y: Integer; TileImg: TLazIntfImage; const R: TRect);
      Procedure DrawTile(const TileId: TTileId; X,Y: integer; TileImg: TLazIntfImage);
      Procedure DoDrag(Sender: TDragObj);
    public
@@ -147,6 +153,7 @@ type

      property BkColor: TFPColor read FBkColor write SetBkColor;
      property Center: TRealPoint read GetCenter write SetCenter;
+      property DrawPreviewTiles : Boolean read FDrawPreviewTiles write FDrawPreviewTiles;

    published
      property Active: Boolean read FActive write SetActive default false;
@@ -167,6 +174,7 @@ type

      property OnCenterMove: TNotifyEvent read FOnCenterMove write FOnCenterMove;
      property OnChange: TNotifyEvent Read FOnChange write FOnchange; //called when visiable area change
+      property OnDrawStretchedTile: TDrawStretchedTileEvent read FOnDrawStretchedTile write FOnDrawStretchedTile;
      property OnDrawTile: TDrawTileEvent read FOnDrawTile write FOnDrawTile;
      property OnZoomChange: TNotifyEvent read FOnZoomChange write FOnZoomChange;
  end;
@@ -376,6 +384,7 @@ end;
 constructor TMapViewerEngine.Create(aOwner: TComponent);
 begin
  DrawTitleInGuiThread := true;
+  DrawPreviewTiles := true;
  DragObj := TDragObj.Create;
  DragObj.OnDrag := @DoDrag;
  Cache := TPictureCache.Create(self);
@@ -522,6 +531,13 @@ begin
    MoveMapCenter(Sender);
 end;

+procedure TMapViewerEngine.DrawStretchedTile(const TileID: TTileID; X, Y: Integer;
+  TileImg: TLazIntfImage; const R: TRect);
+begin
+  if Assigned(FOnDrawStretchedTile) then
+    FOnDrawStretchedTile(TileId, X, Y, TileImg, R);
+end;
+
 procedure TMapViewerEngine.DrawTile(const TileId: TTileId; X, Y: integer;
  TileImg: TLazIntfImage);
 begin
@@ -1038,8 +1054,12 @@ var
  x, y : Integer; //int64;
  Tiles: TTileIdArray = nil;
  iTile: Integer;
+  tile: TTileID;
  numTiles: Integer;
  px, py: Integer;
+  previewDrawn: Boolean;
+  previewImg: TLazIntfImage;
+  R: TRect;
 begin
  if not(Active) then
    Exit;
@@ -1066,9 +1086,24 @@ begin
      // is not valid
      if not Cache.InCache(AWin.MapProvider, Tiles[iTile]) then
      begin
+        previewdrawn := False;
        py := AWin.Y + Y * TILE_SIZE;
        px := AWin.X + X * TILE_SIZE;
-        DrawTile(Tiles[iTile], px, py, nil);
+        if FDrawPreviewTiles then
+        begin
+          if IsValidTile(AWin, Tiles[iTile]) then  // Invalid tiles probably will not be found in the cache
+          begin
+            tile := Tiles[iTile];
+            if Cache.GetPreviewFromCache(AWin.MapProvider, tile, R) then
+            begin
+              Cache.GetFromCache(AWin.MapProvider, tile, previewImg);
+              DrawStretchedTile(Tiles[iTile], px, py, previewImg, R);
+              previewDrawn := true;
+            end;
+          end;
+        end;
+        if not previewDrawn then
+          DrawTile(Tiles[iTile], px, py, nil);  // Draw blank tile if preview cannot be generated
      end;

      if IsValidTile(AWin, Tiles[iTile]) then
--- a/components/lazmapviewer/source/mvmapviewer.pas
+++ b/components/lazmapviewer/source/mvmapviewer.pas
@@ -39,6 +39,7 @@ Type
      FEngine: TMapViewerEngine;
      FBuiltinDrawingEngine: TMvCustomDrawingEngine;
      FDrawingEngine: TMvCustomDrawingEngine;
+      FDrawPreviewTiles: boolean;
      FActive: boolean;
      FGPSItems: TGPSObjectList;
      FPOIImage: TBitmap;
@@ -62,6 +63,7 @@ Type
      function GetCyclic: Boolean;
      function GetDownloadEngine: TMvCustomDownloadEngine;
      function GetDrawingEngine: TMvCustomDrawingEngine;
+      function GetDrawPreviewTiles: Boolean;
      function GetInactiveColor: TColor;
      function GetMapProvider: String;
      function GetOnCenterMove: TNotifyEvent;
@@ -82,6 +84,7 @@ Type
      procedure SetDefaultTrackWidth(AValue: Integer);
      procedure SetDownloadEngine(AValue: TMvCustomDownloadEngine);
      procedure SetDrawingEngine(AValue: TMvCustomDrawingEngine);
+      procedure SetDrawPreviewTiles(AValue: Boolean);
      procedure SetFont(AValue: TFont);
      procedure SetInactiveColor(AValue: TColor);
      procedure SetMapProvider(AValue: String);
@@ -102,6 +105,7 @@ Type
      AsyncInvalidate : boolean;
      procedure ActivateEngine;
      procedure DblClick; override;
+      procedure DoDrawStretchedTile(const TileId: TTileID; X, Y: Integer; TileImg: TLazIntfImage; const R: TRect);
      procedure DoDrawTile(const TileId: TTileId; X,Y: integer; TileImg: TLazIntfImage);
      procedure DoDrawTileInfo(const {%H-}TileID: TTileID; X,Y: Integer);
      function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
@@ -148,6 +152,7 @@ Type
      property DefaultTrackWidth: Integer read FDefaultTrackWidth write SetDefaultTrackWidth default 1;
      property DownloadEngine: TMvCustomDownloadEngine read GetDownloadEngine write SetDownloadEngine;
      property DrawingEngine: TMvCustomDrawingEngine read GetDrawingEngine write SetDrawingEngine;
+      property DrawPreviewTiles: Boolean read GetDrawPreviewTiles write SetDrawPreviewTiles default true;
      property Font: TFont read FFont write SetFont stored IsFontStored;
      property Height default 150;
      property InactiveColor: TColor read GetInactiveColor write SetInactiveColor default clWhite;
@@ -343,6 +348,11 @@ begin
    Result := FDrawingEngine;
 end;

+function TMapView.GetDrawPreviewTiles: Boolean;
+begin
+  Result := Engine.DrawPreviewTiles;
+end;
+
 function TMapView.GetInactiveColor: TColor;
 begin
  Result := FPColorToTColor(Engine.BkColor);
@@ -454,6 +464,11 @@ begin
  UpdateFont(nil);
 end;

+procedure TMapView.SetDrawPreviewTiles(AValue: Boolean);
+begin
+  Engine.DrawPreviewTiles := AValue;
+end;
+
 procedure TMapView.SetFont(AValue: TFont);
 begin
  FFont.Assign(AValue);
@@ -824,21 +839,28 @@ Begin
  AsyncInvalidate := false;
 end;

+procedure TMapView.DoDrawStretchedTile(const TileId: TTileId; X, Y: Integer;
+  TileImg: TLazIntfImage; const R: TRect);
+begin
+  if Assigned(TileImg) then
+    DrawingEngine.DrawScaledLazIntfImage(Rect(X, Y, X + TILE_SIZE, Y + TILE_SIZE), R, TileImg)
+  else
+    DrawingEngine.FillPixels(X, Y, X + TILE_SIZE, Y + TILE_SIZE, InactiveColor);
+
+  if FDebugTiles then
+    DoDrawTileInfo(TileID, X, Y);
+
+  DrawObjects(TileId, X, Y, X + TILE_SIZE, Y + TILE_SIZE);
+end;
+
 procedure TMapView.DoDrawTile(const TileId: TTileId; X, Y: integer;
  TileImg: TLazIntfImage);
 begin
-  if Assigned(TileImg) then begin
-    DrawingEngine.DrawLazIntfImage(X, Y, TileImg);
-  end
+  if Assigned(TileImg) then
+    DrawingEngine.DrawLazIntfImage(X, Y, TileImg)
  else
    DrawingEngine.FillPixels(X, Y, X + TILE_SIZE, Y + TILE_SIZE, InactiveColor);
-  {
-    DrawingEngine.BrushColor := InactiveColor;
-    DrawingEngine.BrushStyle := bsSolid;

-    DrawingEngine.FillRect(X, Y, X + TILE_SIZE, Y + TILE_SIZE);
-  end;
-   }
  if FDebugTiles then
    DoDrawTileInfo(TileID, X, Y);

@@ -888,6 +910,8 @@ begin
  FEngine.CachePath := 'cache/';
  FEngine.CacheOnDisk := true;
  FEngine.OnDrawTile := @DoDrawTile;
+  FEngine.OnDrawStretchedTile := @DoDrawStretchedTile;
+  FEngine.DrawPreviewTiles := True;
  FEngine.DrawTitleInGuiThread := false;
  FEngine.DownloadEngine := FBuiltinDownloadEngine;
  FEngine.ZoomToCursor := True;