paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

LazMapViewer: Added layers collection and center point to the map. Map can be activated into the form designer.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@9226 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
alpine-a110 2024-02-09 06:46:54 +00:00
parent cf44ec6b55
commit ea1efb8066
4 changed files with 408 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
components/lazmapviewer/lazmapviewerpkg.lpk
View File

@ -19,7 +19,7 @@
<Description Value="Component for viewing maps (Google, OpenStreetMap, etc). This is a fork of MapViewer by ti_dic (https://sourceforge.net/p/roadbook/code/ci/master/tree/mapviewer/) which itself is based on the MapViewer by Maciej Kaczkowski (https://github.com/maciejkaczkowski/mapviewer)."/>
<License Value="Modified LGPL with linking exception, like FreePascal RTL/FCL and Lazarus LCL"/>
<Version Minor="2" Release="7"/>
<Files Count="18">
<Files Count="19">
<Item1>
<Filename Value="source/mvcache.pas"/>
<UnitName Value="mvCache"/>
@ -93,12 +93,20 @@
<Filename Value="source/mvdlewin.pas"/>
<UnitName Value="mvDLEWin"/>
</Item18>
<Item19>
<Filename Value="source/mvmapviewerpropedits.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="mvMapViewerPropEdits"/>
</Item19>
</Files>
<CompatibilityMode Value="True"/>
<RequiredPkgs Count="1">
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="LCLBase"/>
<PackageName Value="IDEIntf"/>
</Item1>
<Item2>
<PackageName Value="LCLBase"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>

3
components/lazmapviewer/lazmapviewerpkg.pas
View File

@ -10,13 +10,14 @@ uses
mvCache, mvDownloadEngine, mvDragObj, mvEngine, mvGeoNames, mvGpsObj,
mvJobQueue, mvJobs, mvMapProvider, mvTypes, mvMapViewer, mvExtraData,
mvDLEFpc, mvMapViewerReg, mvGPX, mvDrawingEngine, mvDE_IntfGraphics,
mvDLEWin, LazarusPackageIntf;
mvDLEWin, mvMapViewerPropEdits, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('mvMapViewerReg', @mvMapViewerReg.Register);
RegisterUnit('mvMapViewerPropEdits', @mvMapViewerPropEdits.Register);
end;
initialization

25
components/lazmapviewer/source/mvengine.pas
View File

@ -392,8 +392,12 @@ end;
procedure TMapViewerEngine.CalculateWin(var AWin: TMapWindow);
var
PixelLocation: TPoint; // review: coth: Should it use Int64?
PType: TProjectionType;
begin
case AWin.MapProvider.ProjectionType of
if Assigned(AWin.MapProvider)
then PType := AWin.MapProvider.ProjectionType
else PType := ptEPSG3857; // Default
case PType of
ptEPSG3857: PixelLocation := DegreesToPixelsEPSG3857(AWin, AWin.Center);
ptEPSG3395: PixelLocation := DegreesToPixelsEPSG3395(AWin, AWin.Center);
else PixelLocation := DegreesToPixelsEPSG3857(AWin, AWin.Center);
@ -620,8 +624,12 @@ function TMapViewerEngine.DegreesToMapPixels(const AWin: TMapWindow;
var
pixelLocation: TPoint;
mapWidth: Int64;
PType: TProjectionType;
begin
case AWin.MapProvider.ProjectionType of
if Assigned(AWin.MapProvider)
then PType := AWin.MapProvider.ProjectionType
else PType := ptEPSG3857; // Default
case PType of
ptEPSG3395: pixelLocation := DegreesToPixelsEPSG3395(AWin, ALonLat);
ptEPSG3857: pixelLocation := DegreesToPixelsEPSG3857(AWin, ALonLat);
else pixelLocation := DegreesToPixelsEPSG3857(AWin, ALonLat);
@ -716,6 +724,7 @@ function TMapViewerEngine.MapPixelsToDegrees(const AWin: TMapWindow;
var
mapWidth: Int64;
mPoint : TPoint;
PType: TProjectionType;
begin
mapWidth := round(ZoomFactor(AWin.Zoom)) * TILE_SIZE;
@ -730,7 +739,10 @@ begin
mPoint.X := EnsureRange(APoint.X - AWin.X, 0, mapWidth);
mPoint.Y := EnsureRange(APoint.Y - AWin.Y, 0, mapWidth);
case aWin.MapProvider.ProjectionType of
if Assigned(AWin.MapProvider)
then PType := AWin.MapProvider.ProjectionType
else PType := ptEPSG3857; // Default
case PType of
ptEPSG3857: Result := PixelsToDegreesEPSG3857(mPoint, AWin.Zoom);
ptEPSG3395: Result := PixelsToDegreesEPSG3395(mPoint, AWin.Zoom);
else Result := PixelsToDegreesEPSG3857(mPoint, AWin.Zoom);
@ -1056,6 +1068,11 @@ var
begin
if not(Active) then
Exit;
if not Assigned(AWin.MapProvider) then
begin
EraseBackground(Rect(0, 0, AWin.Width, AWin.Height));
Exit;
end;
if not CalculateVisibleTiles(AWin, TilesVis) then
EraseAround;
@ -1193,7 +1210,7 @@ procedure TMapViewerEngine.SetCyclic(AValue: Boolean);
begin
if FCyclic = AValue then exit;
FCyclic := AValue;
if CrossesDateLine then
if Assigned(MapWin.MapProvider) and CrossesDateLine then
Redraw;
end;

382
components/lazmapviewer/source/mvmapviewer.pas
View File

@ -24,7 +24,8 @@ interface
uses
Classes, SysUtils, Controls, GraphType, Graphics, FPImage, IntfGraphics,
Forms, ImgList, LCLVersion,
MvTypes, MvGPSObj, MvEngine, MvMapProvider, MvDownloadEngine, MvDrawingEngine, mvCache;
MvTypes, MvGPSObj, MvEngine, MvMapProvider, MvDownloadEngine, MvDrawingEngine,
mvCache;
Type
@ -44,10 +45,90 @@ const
type
TMapView = class;
TGPSTileLayer = class;
{ TMapLayer }
TMapLayer = class(TCollectionItem)
private
FTileLayer: TGPSTileLayer;
FCaption: TCaption;
FDrawMode: TItemDrawMode;
FUseThreads: Boolean;
FMapProvider: String;
FOpacity: Single;
FTag: PtrInt;
FVisible: Boolean;
function GetMapProvider: String;
function GetMapView: TMapView;
function GetUseThreads: Boolean;
procedure SetCaption(AValue: TCaption);
procedure SetDrawMode(AValue: TItemDrawMode);
procedure SetMapProvider(AValue: String);
procedure SetOpacity(AValue: Single);
procedure SetUseThreads(AValue: Boolean);
procedure SetVisible(AValue: Boolean);
protected
function GetDisplayName: string; override;
procedure SetIndex(Value: Integer); override;
procedure LayerChanged; virtual;
procedure ReflectChanges; virtual;
public
constructor Create(ACollection: TCollection); override;
destructor Destroy; override;
property MapView: TMapView read GetMapView;
published
property Caption: TCaption read FCaption write SetCaption;
property Visible: Boolean read FVisible write SetVisible default True;
property MapProvider: String read GetMapProvider write SetMapProvider;
property UseThreads: Boolean read GetUseThreads write SetUseThreads default True;
property DrawMode: TItemDrawMode read FDrawMode write SetDrawMode default idmUseOpacity;
property Opacity: Single read FOpacity write SetOpacity default 0.25;
property Tag: PtrInt read FTag write FTag default 0;
end;
{ TMapLayers }
TMapLayers = class(TCollection)
private
FView: TMapView;
function GetLayer(Index: Integer): TMapLayer;
procedure SetLayer(Index: Integer; AValue: TMapLayer);
protected
function GetOwner: TPersistent; override;
procedure Update(Item: TCollectionItem); override;
procedure FixOrder(APrevIndex, AIndex: Integer);
public
constructor Create(AView: TMapView; AItemClass: TCollectionItemClass);
property MapView: TMapView read FView;
property Items[Index: Integer]: TMapLayer read GetLayer write SetLayer; default;
end;
{ TMapCenter }
TMapCenter = class(TPersistent)
private
FLattitude: Double;
FLongitude: Double;
FView: TMapView;
procedure SetLattitude(AValue: Double);
procedure SetLongitude(AValue: Double);
procedure SetViewCenter;
protected
function GetOwner: TPersistent; override;
public
constructor Create(AView: TMapView);
published
property Longitude: Double read FLongitude write SetLongitude;
property Lattitude: Double read FLattitude write SetLattitude;
end;
{ TMapView }
TMapView = class(TCustomControl)
private
FCenter: TMapCenter;
FDownloadEngine: TMvCustomDownloadEngine;
FBuiltinDownloadEngine: TMvCustomDownloadEngine;
FEngine: TMapViewerEngine;
@ -55,6 +136,7 @@ type
FDrawingEngine: TMvCustomDrawingEngine;
FDrawPreviewTiles: boolean;
FActive: boolean;
FLayers: TMapLayers;
FGPSItems: array [0..9] of TGPSObjectList;
FOptions: TMapViewOptions;
FPOIImage: TBitmap;
@ -66,6 +148,9 @@ type
FFont: TFont;
FPOIImages: TCustomImageList;
FPOIImagesWidth: Integer;
FCacheOnDisk: Boolean;
FZoomMax: Integer;
FZoomMin: Integer;
procedure CallAsyncInvalidate;
procedure DoAsyncInvalidate({%H-}Data: PtrInt);
procedure DrawObjects(const {%H-}TileId: TTileId; aLeft, aTop, aRight,aBottom: integer);
@ -81,6 +166,7 @@ type
function GetGPSItems: TGPSObjectList;
function GetGPSLayer(Layer: Integer): TGPSObjectList;
function GetInactiveColor: TColor;
function GetLayers: TMapLayers;
function GetMapProvider: String;
function GetOnCenterMove: TNotifyEvent;
function GetOnChange: TNotifyEvent;
@ -91,6 +177,7 @@ type
function IsCacheMaxAgeStored: Boolean;
function IsCachePathStored: Boolean;
function IsFontStored: Boolean;
function IsLayersStored: Boolean;
procedure SetActive(AValue: boolean);
procedure SetCacheMaxAge(AValue: Integer);
procedure SetCacheOnDisk(AValue: boolean);
@ -105,6 +192,7 @@ type
procedure SetDrawPreviewTiles(AValue: Boolean);
procedure SetFont(AValue: TFont);
procedure SetInactiveColor(AValue: TColor);
procedure SetLayers(const ALayers: TMapLayers);
procedure SetMapProvider(AValue: String);
procedure SetOnCenterMove(AValue: TNotifyEvent);
procedure SetOnChange(AValue: TNotifyEvent);
@ -116,6 +204,8 @@ type
procedure SetPOITextBgColor(AValue: TColor);
procedure SetUseThreads(AValue: boolean);
procedure SetZoom(AValue: integer);
procedure SetZoomMax(AValue: Integer);
procedure SetZoomMin(AValue: Integer);
procedure SetZoomToCursor(AValue: Boolean);
procedure UpdateFont(Sender: TObject);
procedure UpdateImage(Sender: TObject);
@ -142,6 +232,10 @@ type
procedure Paint; override;
procedure OnGPSItemsModified(Sender: TObject; objs: TGPSObjList;
Adding: boolean);
function CreateLayers: TMapLayers; virtual;
procedure UpdateLayers;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
@ -182,10 +276,12 @@ type
property DrawingEngine: TMvCustomDrawingEngine read GetDrawingEngine write SetDrawingEngine;
property DrawPreviewTiles: Boolean read GetDrawPreviewTiles write SetDrawPreviewTiles default true;
property Options: TMapViewOptions read FOptions write SetOptions default DefaultMapViewOptions;
property Layers: TMapLayers read GetLayers write SetLayers stored IsLayersStored;
property Font: TFont read FFont write SetFont stored IsFontStored;
property Height default 150;
property InactiveColor: TColor read GetInactiveColor write SetInactiveColor default clWhite;
property MapProvider: String read GetMapProvider write SetMapProvider;
property MapCenter: TMapCenter read FCenter write FCenter;
property POIImage: TBitmap read FPOIImage write SetPOIImage;
property POIImages: TCustomImageList read FPOIImages write SetPOIImages;
property POIImagesWidth: Integer read FPOIImagesWidth write SetPOIImagesWidth default 0;
@ -194,6 +290,8 @@ type
property UseThreads: boolean read GetUseThreads write SetUseThreads default false;
property Width default 150;
property Zoom: integer read GetZoom write SetZoom default 0;
property ZoomMax: Integer read FZoomMax write SetZoomMax default 19;
property ZoomMin: Integer read FZoomMin write SetZoomMin default 0;
property ZoomToCursor: Boolean read GetZoomToCursor write SetZoomToCursor default True;
property OnCenterMove: TNotifyEvent read GetOnCenterMove write SetOnCenterMove;
property OnZoomChange: TNotifyEvent read GetOnZoomChange write SetOnZoomChange;
@ -274,6 +372,9 @@ uses
{$ENDIF}
mvDE_IntfGraphics;
const
_TILELAYERS_ID_ = -42; // OwnerIDs of the tile layers
{ Converts a length given in millimeters to screen pixels }
function mmToPx(AValue: Double): Integer;
begin
@ -305,6 +406,212 @@ type
destructor Destroy; override;
end;
{ TMapCenter }
procedure TMapCenter.SetLongitude(AValue: Double);
begin
if FLongitude = AValue then Exit;
FLongitude := AValue;
SetViewCenter;
end;
procedure TMapCenter.SetLattitude(AValue: Double);
begin
if FLattitude = AValue then Exit;
FLattitude := AValue;
SetViewCenter;
end;
procedure TMapCenter.SetViewCenter;
var
R: TRealPoint;
begin
R.Init(FLongitude, FLattitude);
FView.SetCenter(R);
end;
function TMapCenter.GetOwner: TPersistent;
begin
Result := FView;
end;
constructor TMapCenter.Create(AView: TMapView);
begin
FView := AView;
end;
{ TMapLayer }
function TMapLayer.GetMapView: TMapView;
begin
if Collection is TMapLayers
then Result := (Collection as TMapLayers).MapView
else Result := Nil;
end;
function TMapLayer.GetMapProvider: String;
begin
//if Assigned(FTileLayer) then
Result := FTileLayer.MapProvider
// else Result := '';
end;
function TMapLayer.GetUseThreads: Boolean;
begin
Result := FUseThreads;
end;
procedure TMapLayer.SetCaption(AValue: TCaption);
begin
if FCaption=AValue then Exit;
FCaption:=AValue;
LayerChanged;
end;
procedure TMapLayer.SetDrawMode(AValue: TItemDrawMode);
begin
if FDrawMode=AValue then Exit;
FDrawMode:=AValue;
LayerChanged;
end;
procedure TMapLayer.SetMapProvider(AValue: String);
begin
if FMapProvider = AValue then
Exit;
// TODO: Check compat. of provider projection type against the base provider!
FMapProvider := AValue;
LayerChanged;
end;
procedure TMapLayer.SetOpacity(AValue: Single);
begin
AValue := EnsureRange(AValue, 0.0, 1.0);
if FOpacity = AValue then
Exit;
FOpacity:=AValue;
LayerChanged;
end;
procedure TMapLayer.SetUseThreads(AValue: Boolean);
begin
if FUseThreads = AValue then
Exit;
FUseThreads := AValue;
LayerChanged;
end;
procedure TMapLayer.SetVisible(AValue: Boolean);
begin
if FVisible=AValue then Exit;
FVisible:=AValue;
LayerChanged;
end;
function TMapLayer.GetDisplayName: string;
begin
if FCaption <> ''
then Result := FCaption
else Result := ClassName;
if not FVisible
then Result := Result + ' (Invisible)';
end;
procedure TMapLayer.SetIndex(Value: Integer);
var
PrevIndex: Integer;
begin
PrevIndex := Index;
inherited SetIndex(Value);
if (PrevIndex <> Index) and Assigned(Collection) then
TMapLayers(Collection).FixOrder(PrevIndex, Index);
end;
procedure TMapLayer.LayerChanged;
begin
ReflectChanges;
Changed(False);
end;
procedure TMapLayer.ReflectChanges;
begin
if not Assigned(FTileLayer) then
Exit;
FTileLayer.MapProvider := FMapProvider;
FTileLayer.UseThreads := FUseThreads;
FTileLayer.DrawMode := FDrawMode;
FTileLayer.Opacity := FOpacity;
FTileLayer.Visible := FVisible;
end;
constructor TMapLayer.Create(ACollection: TCollection);
begin
inherited Create(ACollection);
FUseThreads := True;
FDrawMode := idmUseOpacity;
FOpacity := 0.25;
FVisible := True;
FTag := 0;
begin
FTileLayer := TGPSTileLayer.Create;
MapView.GPSItems.Add(FTileLayer, _TILELAYERS_ID_, Self.Index);
end;
end;
destructor TMapLayer.Destroy;
begin
if Assigned(FTileLayer) then
MapView.GPSItems.Delete(FTileLayer);
inherited Destroy;
end;
{ TMapLayers }
function TMapLayers.GetLayer(Index: Integer): TMapLayer;
begin
Result := TMapLayer(inherited GetItem(Index));
end;
procedure TMapLayers.SetLayer(Index: Integer; AValue: TMapLayer);
begin
GetLayer(Index).Assign(AValue);
end;
function TMapLayers.GetOwner: TPersistent;
begin
Result := FView;
end;
procedure TMapLayers.Update(Item: TCollectionItem);
begin
inherited Update(Item);
if Assigned(MapView) then
MapView.Invalidate;
end;
procedure TMapLayers.FixOrder(APrevIndex, AIndex: Integer);
var
I, T, B: Integer;
begin
T := Min(APrevIndex, AIndex);
B := Max(APrevIndex, AIndex);
if APrevIndex < 0 then
begin
T := AIndex;
B := Pred(Count);
end;
for I := T to B do
MapView.GPSItems.ChangeZOrder(Items[I].FTileLayer, I);
end;
constructor TMapLayers.Create(AView: TMapView; AItemClass: TCollectionItemClass
);
begin
inherited Create(AItemClass);
FView := AView;
end;
{ TDrawObjJob }
function TDrawObjJob.pGetTask: integer;
@ -395,11 +702,12 @@ begin
if Engine.CacheMaxAge = AValue then
Exit;
Engine.CacheMaxAge := AValue;
UpdateLayers;
end;
function TMapView.GetCacheOnDisk: boolean;
begin
Result := Engine.CacheOnDisk;
Result := FCacheOnDisk;
end;
function TMapView.GetCachePath: String;
@ -453,6 +761,11 @@ begin
Result := FPColorToTColor(Engine.BkColor);
end;
function TMapView.GetLayers: TMapLayers;
begin
Result := FLayers;
end;
function TMapView.GetMapProvider: String;
begin
result := Engine.MapProvider;
@ -504,14 +817,24 @@ begin
(FFont.Style = []) and (FFont.Color = clBlack);
end;
function TMapView.IsLayersStored: Boolean;
begin
Result := True;
end;
procedure TMapView.SetCacheOnDisk(AValue: boolean);
begin
Engine.CacheOnDisk := AValue;
FCacheOnDisk := AValue;
if csDesigning in ComponentState
then Engine.CacheOnDisk := False
else Engine.CacheOnDisk := AValue;
UpdateLayers;
end;
procedure TMapView.SetCachePath(AValue: String);
begin
Engine.CachePath := AValue;
UpdateLayers;
end;
procedure TMapView.SetCenter(AValue: TRealPoint);
@ -523,6 +846,7 @@ end;
procedure TMapView.SetCyclic(AValue: Boolean);
begin
Engine.Cyclic := AValue;
UpdateLayers;
Invalidate;
end;
@ -551,6 +875,7 @@ procedure TMapView.SetDownloadEngine(AValue: TMvCustomDownloadEngine);
begin
FDownloadEngine := AValue;
FEngine.DownloadEngine := GetDownloadEngine;
UpdateLayers;
end;
procedure TMapView.SetDrawingEngine(AValue: TMvCustomDrawingEngine);
@ -587,6 +912,11 @@ begin
Invalidate;
end;
procedure TMapView.SetLayers(const ALayers: TMapLayers);
begin
FLayers.Assign(ALayers);
end;
procedure TMapView.ActivateEngine;
begin
Engine.SetSize(ClientWidth,ClientHeight);
@ -660,10 +990,24 @@ end;
procedure TMapView.SetZoom(AValue: integer);
begin
Engine.Zoom := AValue;
Engine.Zoom := EnsureRange(AValue, FZoomMin, FZoomMax);
Invalidate;
end;
procedure TMapView.SetZoomMax(AValue: Integer);
begin
if FZoomMax = AValue then Exit;
FZoomMax := EnsureRange(AValue, FZoomMin, 19);
Zoom := GetZoom;
end;
procedure TMapView.SetZoomMin(AValue: Integer);
begin
if FZoomMin = AValue then Exit;
FZoomMin := EnsureRange(AValue, 0, FZoomMax);
Zoom := GetZoom;
end;
procedure TMapView.SetZoomToCursor(AValue: Boolean);
begin
Engine.ZoomToCursor := AValue;
@ -1147,10 +1491,7 @@ end;
function TMapView.IsActive: Boolean;
begin
if not(csDesigning in ComponentState) then
Result := FActive
else
Result := false;
end;
constructor TMapView.Create(AOwner: TComponent);
@ -1161,6 +1502,8 @@ begin
Width := 150;
Height := 150;
FLayers := CreateLayers;
FActive := false;
FOptions := DefaultMapViewOptions;
@ -1208,17 +1551,28 @@ begin
FPOIImage := TBitmap.Create;
FPOIImage.OnChange := @UpdateImage;
FPOITextBgColor := clNone;
FCenter := TMapCenter.Create(Self);
FCenter.Longitude := 0.0;
FCenter.Lattitude := 51.47696; // Greenwich observatory
FZoomMin := 0;
FZoomMax := 19;
Zoom := 15;
end;
destructor TMapView.Destroy;
var
I: Integer;
begin
Active := False;
Engine.Jobqueue.RemoveAsyncCalls(Self);
FFont.Free;
FreeAndNil(FPOIImage);
FLayers.Free;
for I := 0 to High(FGPSItems) do
FreeAndNil(FGPSItems[I]);
FCenter.Free;
inherited Destroy;
end;
@ -1446,6 +1800,19 @@ begin
Engine.Redraw;
end;
function TMapView.CreateLayers: TMapLayers;
begin
Result := TMapLayers.Create(Self, TMapLayer);
end;
procedure TMapView.UpdateLayers;
var
I: Integer;
begin
for I := 0 to Pred(FLayers.Count) do
FLayers[I].FTileLayer.ParentViewChanged;
end;
{ TGPSTileLayerBase }
function TGPSTileLayerBase.GetMapProvider: String;
@ -1625,6 +1992,5 @@ begin
FEngine.Redraw;
end;
end.