{ Initial map viewer library: Copyright (C) 2011 Maciej Kaczkowski / keit.co Extensions: (C) 2014 ti_dic@hotmail.com (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 } // ToDo: Make Active work at designtime. unit mvMapViewer; {$MODE objfpc}{$H+} {$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined} interface uses Classes, SysUtils, Controls, GraphType, Graphics, FPImage, IntfGraphics, Forms, ImgList, LCLVersion, MvTypes, MvGPSObj, MvEngine, MvMapProvider, MvDownloadEngine, MvDrawingEngine, mvCache; Type TDrawGpsPointEvent = procedure (Sender: TObject; ADrawer: TMvCustomDrawingEngine; APoint: TGpsPoint) of object; TMapViewOption = ( mvoMouseDragging, // Allow dragging of the map with the mouse mvoMouseZooming // Allow zooming into the map with the mouse ); TMapViewOptions = set of TMapViewOption; const DefaultMapViewOptions = [mvoMouseDragging, mvoMouseZooming]; type TMapView = class; TPointOfInterest = class; TPointsOfInterest = class; TGPSTileLayer = class; TGPSComboLayer = class; TPointOfInterestDrawEvent = procedure(Sender: TObject; ADrawer: TMvCustomDrawingEngine; APoint: TPointOfInterest) of object; { TMapCollection } generic TMapCollection = class(TOwnedCollection) private FMCOwner: OT; function GetItems(Index: Integer): T; procedure SetItems(Index: Integer; AValue: T); public constructor Create(AOwner: OT); property MCOwner: OT read FMCOwner; property Items[Index: Integer]: T read GetItems write SetItems; default; end; { TMapItem } TMapItem = class(TCollectionItem) private FCaption: TCaption; FTag: PtrInt; FVisible: Boolean; procedure SetCaption(AValue: TCaption); procedure SetVisible(AValue: Boolean); protected function GetDisplayName: string; override; procedure ItemChanged; virtual; abstract; published property Caption: TCaption read FCaption write SetCaption; property Visible: Boolean read FVisible write SetVisible default True; property Tag: PtrInt read FTag write FTag default 0; end; { TMapLayer } TMapLayer = class(TMapItem) private FComboLayer: TGPSComboLayer; FDrawMode: TItemDrawMode; FUseThreads: Boolean; FMapProvider: String; FOpacity: Single; FPointsOfInterest: TPointsOfInterest; function GetMapProvider: String; function GetMapView: TMapView; function GetPointsOfInterest: TPointsOfInterest; function GetUseThreads: Boolean; procedure SetDrawMode(AValue: TItemDrawMode); procedure SetMapProvider(AValue: String); procedure SetOpacity(AValue: Single); procedure SetPointsOfInterest(AValue: TPointsOfInterest); procedure SetUseThreads(AValue: Boolean); protected procedure SetIndex(Value: Integer); override; procedure ItemChanged; override; public constructor Create(ACollection: TCollection); override; destructor Destroy; override; property MapView: TMapView read GetMapView; published 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 PointsOfInterest: TPointsOfInterest read GetPointsOfInterest write SetPointsOfInterest; end; { TMapLayers } TMapLayers = class(specialize TMapCollection) protected procedure Update(Item: TCollectionItem); override; procedure FixOrder(APrevIndex, AIndex: Integer); end; { TMapCenter } TMapCenter = class(TPersistent) private FLatitude: Double; FLongitude: Double; FView: TMapView; procedure SetLatitude(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 Latitude: Double read FLatitude write SetLatitude; end; { TPointOfInterest } TPointOfInterest = class(TMapItem) private FDateTime: TDateTime; FElevation: Double; FImageIndex: TImageIndex; FLatitude: Double; FLongitude: Double; FOnDrawPoint: TPointOfInterestDrawEvent; FPoint: TGPSPointOfInterest; function GetLayer: TMapLayer; function GetMapView: TMapView; function IsDateTimeStored: Boolean; function IsElevationStored: Boolean; procedure SetDateTime(AValue: TDateTime); procedure SetElevation(AValue: Double); procedure SetImageIndex(AValue: TImageIndex); procedure SetLatitude(AValue: Double); procedure SetLongitude(AValue: Double); procedure SetOnDrawPoint(AValue: TPointOfInterestDrawEvent); protected procedure SetIndex(Value: Integer); override; procedure ItemChanged; override; procedure DrawPoint(Sender: TObject; AGPSObj: TGPSObj; AArea: TRealArea); public constructor Create(ACollection: TCollection); override; destructor Destroy; override; property MapView: TMapView read GetMapView; property Layer: TMapLayer read GetLayer; published property Longitude: Double read FLongitude write SetLongitude; property Latitude: Double read FLatitude write SetLatitude; property Elevation: Double read FElevation write SetElevation stored IsElevationStored; property DateTime: TDateTime read FDateTime write SetDateTime stored IsDateTimeStored; property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1; property OnDrawPoint: TPointOfInterestDrawEvent read FOnDrawPoint write SetOnDrawPoint; end; { TPointsOfInterest } TPointsOfInterest = class(specialize TMapCollection) protected procedure Update(Item: TCollectionItem); override; procedure FixOrder(APrevIndex, AIndex: Integer); end; { TMapView } TMapView = class(TCustomControl) private FCenter: TMapCenter; FDownloadEngine: TMvCustomDownloadEngine; FBuiltinDownloadEngine: TMvCustomDownloadEngine; FEngine: TMapViewerEngine; FBuiltinDrawingEngine: TMvCustomDrawingEngine; FDrawingEngine: TMvCustomDrawingEngine; FDrawPreviewTiles: boolean; FActive: boolean; FLayers: TMapLayers; FGPSItems: array [0..9] of TGPSObjectList; FOptions: TMapViewOptions; FPOIImage: TBitmap; FPOITextBgColor: TColor; FOnDrawGpsPoint: TDrawGpsPointEvent; FDebugTiles: Boolean; FDefaultTrackColor: TColor; FDefaultTrackWidth: Integer; 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); procedure DrawGpsObj(const {%H-}Area: TRealArea; AObj: TGPSObj); function GetCacheMaxAge: Integer; function GetCacheOnDisk: boolean; function GetCachePath: String; function GetCenter: TRealPoint; function GetCyclic: Boolean; function GetDownloadEngine: TMvCustomDownloadEngine; function GetDrawingEngine: TMvCustomDrawingEngine; function GetDrawPreviewTiles: Boolean; function GetGPSItems: TGPSObjectList; function GetGPSLayer(Layer: Integer): TGPSObjectList; function GetInactiveColor: TColor; function GetLayers: TMapLayers; function GetMapProvider: String; function GetOnCenterMove: TNotifyEvent; function GetOnChange: TNotifyEvent; function GetOnZoomChange: TNotifyEvent; function GetUseThreads: boolean; function GetZoom: integer; function GetZoomToCursor: Boolean; function IsCacheMaxAgeStored: Boolean; function IsCachePathStored: Boolean; function IsFontStored: Boolean; function IsLayersStored: Boolean; procedure SetActive(AValue: boolean); procedure SetCacheMaxAge(AValue: Integer); procedure SetCacheOnDisk(AValue: boolean); procedure SetCachePath(AValue: String); procedure SetCenter(AValue: TRealPoint); procedure SetCyclic(AValue: Boolean); procedure SetDebugTiles(AValue: Boolean); procedure SetDefaultTrackColor(AValue: TColor); 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 SetLayers(const ALayers: TMapLayers); procedure SetMapProvider(AValue: String); procedure SetOnCenterMove(AValue: TNotifyEvent); procedure SetOnChange(AValue: TNotifyEvent); procedure SetOnZoomChange(AValue: TNotifyEvent); procedure SetOptions(AValue: TMapViewOptions); procedure SetPOIImage(const AValue: TBitmap); procedure SetPOIImages(const AValue: TCustomImageList); procedure SetPOIImagesWidth(AValue: Integer); 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); protected AsyncInvalidate : boolean; procedure ActivateEngine; procedure DblClick; override; procedure DoDrawStretchedTile(const TileId: TTileID; X, Y: Integer; TileImg: TPictureCacheItem; const R: TRect); procedure DoDrawTile(const TileId: TTileId; X,Y: integer; TileImg: TPictureCacheItem); procedure DoDrawTileInfo(const {%H-}TileID: TTileID; X,Y: Integer); procedure DoEraseBackground(const R: TRect); procedure DoTileDownloaded(const TileId: TTileId); function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; procedure DoOnResize; override; function IsActive: Boolean; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X,Y: Integer); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; 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; function CyclicPointOf(APoint: TPoint; ARefX: LongInt; Eastwards: Boolean = True): TPoint; function CyclicPointsOf(APoint: TPoint): TPointArray; procedure DrawPointOfInterest(const {%H-}Area: TRealArea; APt: TGPSPointOfInterest); procedure DrawPt(const {%H-}Area: TRealArea; APt: TGPSPoint); procedure DrawTrack(const Area: TRealArea; trk: TGPSTrack); procedure ClearBuffer; procedure GetMapProviders(lstProviders: TStrings); function GetVisibleArea: TRealArea; function LonLatToScreen(aPt: TRealPoint): TPoint; function ObjsAtScreenPt(X, Y: Integer; ATolerance: Integer = -1): TGPSObjarray; procedure SaveToFile(AClass: TRasterImageClass; const AFileName: String); function SaveToImage(AClass: TRasterImageClass): TRasterImage; procedure SaveToStream(AClass: TRasterImageClass; AStream: TStream); function ScreenToLonLat(aPt: TPoint): TRealPoint; procedure CenterOnObj(obj: TGPSObj); procedure Redraw; inline; procedure ZoomOnArea(const aArea: TRealArea); procedure ZoomOnObj(obj: TGPSObj); procedure WaitEndOfRendering; property Center: TRealPoint read GetCenter write SetCenter; property Engine: TMapViewerEngine read FEngine; property GPSItems: TGPSObjectList read GetGPSItems; property GPSLayer[L: Integer]: TGPSObjectList read GetGPSLayer; published property Active: boolean read FActive write SetActive default false; property Align; property CacheOnDisk: boolean read GetCacheOnDisk write SetCacheOnDisk default true; property CachePath: String read GetCachePath write SetCachePath stored IsCachePathStored; property CacheMaxAge: Integer read GetCacheMaxAge write SetCacheMaxAge stored IsCacheMaxAgeStored; property Cyclic: Boolean read GetCyclic write SetCyclic default false; property DebugTiles: Boolean read FDebugTiles write SetDebugTiles default false; property DefaultTrackColor: TColor read FDefaultTrackColor write SetDefaultTrackColor default clRed; 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 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; property POITextBgColor: TColor read FPOITextBgColor write SetPOITextBgColor default clNone; property PopupMenu; 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; property OnChange: TNotifyEvent read GetOnChange write SetOnChange; property OnDrawGpsPoint: TDrawGpsPointEvent read FOnDrawGpsPoint write FOnDrawGpsPoint; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; end; { TGPSTileLayerBase } TGPSTileLayerBase = class(TGPSObj) private FDrawMode: TItemDrawMode; FMapProvider: String; FOpacity: Single; FParentView: TMapView; FEngine: TMapViewerEngine; FParentViewChanged: Boolean; function GetMapProvider: String; function GetUseThreads: Boolean; procedure DoTileDownloaded(const TileId: TTileId); procedure DoDrawTile(const TileId: TTileId; X, Y: Integer; TileImg: TPictureCacheItem); procedure SetDrawMode(AValue: TItemDrawMode); procedure SetMapProvider(AValue: String); procedure SetOpacity(AValue: Single); procedure SetUseThreads(AValue: Boolean); procedure SetParentView(AValue: TMapView); protected procedure TileDownloaded(const TileId: TTileId); virtual; procedure DrawTile(const TileId: TTileId; X, Y: Integer; TileImg: TPictureCacheItem); virtual; abstract; public constructor Create; destructor Destroy; override; procedure GetArea(out Area: TRealArea); override; procedure Draw(AView: TObject; Area: TRealArea); override; procedure ParentViewChanged; virtual; property MapProvider: String read GetMapProvider write SetMapProvider; property UseThreads: Boolean read GetUseThreads write SetUseThreads; property DrawMode: TItemDrawMode read FDrawMode write SetDrawMode; property Opacity: Single read FOpacity write SetOpacity; end; { TGPSTileLayer } TGPSTileLayer = class(TGPSTileLayerBase) protected procedure DrawTile(const TileId: TTileId; X, Y: Integer; TileImg: TPictureCacheItem); override; public procedure Draw(AView: TObject; Area: TRealArea); override; procedure TileDownloaded(const TileId: TTileId); override; end; { TGPSTileLayerLabels } TGPSTileLayerLabels = class(TGPSTileLayerBase) protected procedure DrawTile(const TileId: TTileId; X, Y: Integer; TileImg: TPictureCacheItem); override; public procedure Draw(AView: TObject; Area: TRealArea); override; end; { TGPSComboLayer } TGPSComboLayer = class(TGPSObjectList) FTileLayer: TGPSTileLayer; public constructor Create; destructor Destroy; override; procedure GetArea(out Area: TRealArea); override; procedure Draw(AView: TObject; Area: TRealArea); override; property TileLayer: TGPSTileLayer read FTileLayer; end; implementation uses GraphMath, Types, Math, mvJobQueue, mvExtraData, mvDLEFpc, {$IFDEF MSWINDOWS} mvDLEWin, {$ENDIF} mvDE_IntfGraphics; const LAYERS_ZOFFS = -9999; _TILELAYERS_ID_ = -42; // OwnerIDs of the tile layers { Converts a length given in millimeters to screen pixels } function mmToPx(AValue: Double): Integer; begin Result := round(AValue / 25.4 * ScreenInfo.PixelsPerInchX); end; type { TDrawObjJob } TDrawObjJob = class(TJob) private AllRun: boolean; Viewer: TMapView; FRunning: boolean; FLst: TGPSObjList; FStates: Array of integer; FArea: TRealArea; protected function pGetTask: integer; override; procedure pTaskStarted(aTask: integer); override; procedure pTaskEnded(aTask: integer; aExcept: Exception); override; public procedure ExecuteTask(aTask: integer; FromWaiting: boolean); override; function Running: boolean;override; public constructor Create(aViewer: TMapView; aLst: TGPSObjList; const aArea: TRealArea); destructor Destroy; override; end; { TMapItem } procedure TMapItem.SetCaption(AValue: TCaption); begin if FCaption=AValue then Exit; FCaption:=AValue; ItemChanged; end; procedure TMapItem.SetVisible(AValue: Boolean); begin if FVisible=AValue then Exit; FVisible:=AValue; ItemChanged; end; function TMapItem.GetDisplayName: string; begin if FCaption <> '' then Result := FCaption else Result := ClassName; if not FVisible then Result := Result + ' (Invisible)'; end; { TMapCollection } function TMapCollection.GetItems(Index: Integer): T; begin Result := T(inherited GetItem(Index)); end; procedure TMapCollection.SetItems(Index: Integer; AValue: T); begin (GetItems(Index) as TPersistent).Assign(AValue); end; constructor TMapCollection.Create(AOwner: OT); begin inherited Create(AOwner, T); FMCOwner := AOwner; end; { TGPSComboLayer } procedure TGPSComboLayer.GetArea(out Area: TRealArea); begin FTileLayer.GetArea(Area); end; constructor TGPSComboLayer.Create; begin inherited Create; FTileLayer := TGPSTileLayer.Create; end; destructor TGPSComboLayer.Destroy; begin FTileLayer.Free; inherited Destroy; end; procedure TGPSComboLayer.Draw(AView: TObject; Area: TRealArea); var I: Integer; Objs: TGPSObjList; begin inherited Draw(AView, Area); FTileLayer.Draw(AView, Area); Objs := GetObjectsInArea(Area); try if Objs.Count > 0 then begin for I := 0 to Pred(Objs.Count) do if Objs[I].Visible then Items[I].Draw(AView, Area) end; finally FreeAndNil(Objs); end; end; { TPointsOfInterest } procedure TPointsOfInterest.Update(Item: TCollectionItem); begin inherited Update(Item); if Assigned(MCOwner.MapView) then MCOwner.MapView.Invalidate; end; procedure TPointsOfInterest.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 MCOwner.FComboLayer.ChangeZOrder(Items[I].FPoint, I); end; { TPointOfInterest } function TPointOfInterest.GetMapView: TMapView; begin if Collection is TPointsOfInterest then Result := (Collection as TPointsOfInterest).MCOwner.MapView else Result := Nil; end; function TPointOfInterest.IsDateTimeStored: Boolean; begin Result := not (FDateTime = NO_DATE); end; function TPointOfInterest.IsElevationStored: Boolean; begin Result := not (FElevation = NO_ELE); end; procedure TPointOfInterest.SetDateTime(AValue: TDateTime); begin if FDateTime=AValue then Exit; FDateTime:=AValue; ItemChanged; end; procedure TPointOfInterest.SetElevation(AValue: Double); begin if FElevation=AValue then Exit; FElevation:=AValue; ItemChanged; end; function TPointOfInterest.GetLayer: TMapLayer; begin if Collection is TPointsOfInterest then Result := (Collection as TPointsOfInterest).MCOwner else Result := Nil; end; procedure TPointOfInterest.SetImageIndex(AValue: TImageIndex); begin if FImageIndex = AValue then Exit; FImageIndex := AValue; ItemChanged; end; procedure TPointOfInterest.SetLatitude(AValue: Double); begin if FLatitude = AValue then Exit; FLatitude := AValue; ItemChanged; end; procedure TPointOfInterest.SetLongitude(AValue: Double); begin if FLongitude = AValue then Exit; FLongitude := AValue; ItemChanged; end; procedure TPointOfInterest.SetOnDrawPoint(AValue: TPointOfInterestDrawEvent); begin if CompareMem(@FOnDrawPoint, @AValue, SizeOf(TMethod)) then Exit; FOnDrawPoint := AValue; if Assigned(FOnDrawPoint) then FPoint.OnDrawObj := @DrawPoint else FPoint.OnDrawObj := Nil; ItemChanged; end; procedure TPointOfInterest.SetIndex(Value: Integer); var PrevIndex: Integer; begin PrevIndex := Index; inherited SetIndex(Value); if (PrevIndex <> Index) and Assigned(Collection) then TPointsOfInterest(Collection).FixOrder(PrevIndex, Self.Index); end; procedure TPointOfInterest.ItemChanged; begin FPoint.Lon := Longitude; FPoint.Lat := Latitude; FPoint.Name := Caption; FPoint.ImageIndex := ImageIndex; FPoint.Visible := Visible; FPoint.Elevation := Elevation; FPoint.DateTime := DateTime; Changed(False); end; procedure TPointOfInterest.DrawPoint(Sender: TObject; AGPSObj: TGPSObj; AArea: TRealArea); begin if Assigned(FOnDrawPoint) then FOnDrawPoint(Sender, MapView.DrawingEngine, Self); end; constructor TPointOfInterest.Create(ACollection: TCollection); begin inherited Create(ACollection); FImageIndex := -1; FLongitude := MapView.Center.Lon; FLatitude := MapView.Center.Lat; FVisible := True; FElevation := NO_ELE; FDateTime := NO_DATE; FPoint := TGPSPointOfInterest.Create(FLongitude, FLatitude); Layer.FComboLayer.Add(FPoint, Pred(_TILELAYERS_ID_), Self.Index + 1); end; destructor TPointOfInterest.Destroy; begin if Assigned(FPoint) then Layer.FComboLayer.Delete(FPoint); inherited Destroy; end; { TMapCenter } procedure TMapCenter.SetLongitude(AValue: Double); begin if FLongitude = AValue then Exit; FLongitude := AValue; SetViewCenter; end; procedure TMapCenter.SetLatitude(AValue: Double); begin if FLatitude = AValue then Exit; FLatitude := AValue; SetViewCenter; end; procedure TMapCenter.SetViewCenter; var R: TRealPoint; begin R.Init(FLongitude, FLatitude); 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).MCOwner //MapView else Result := Nil; end; function TMapLayer.GetPointsOfInterest: TPointsOfInterest; begin Result := FPointsOfInterest; end; function TMapLayer.GetMapProvider: String; begin Result := FComboLayer.TileLayer.MapProvider end; function TMapLayer.GetUseThreads: Boolean; begin Result := FUseThreads; end; procedure TMapLayer.SetDrawMode(AValue: TItemDrawMode); begin if FDrawMode=AValue then Exit; FDrawMode:=AValue; ItemChanged; end; procedure TMapLayer.SetMapProvider(AValue: String); var P: TMapProvider; LPS, MPS: String; begin if FMapProvider = AValue then Exit; // Check compat. of provider projection type against the base provider. if Assigned(MapView) then begin P := MapView.Engine.MapProviderByName(AValue); if Assigned(P) and (MapView.Engine.MapProjectionType <> P.ProjectionType) then begin WriteStr(LPS, MapView.Engine.MapProjectionType); WriteStr(MPS, P.ProjectionType); raise EArgumentException.CreateFmt( '%s has different projection type (%s) from the base map (%s).', [AValue, LPS, MPS]); end; end; FMapProvider := AValue; ItemChanged; end; procedure TMapLayer.SetOpacity(AValue: Single); begin AValue := EnsureRange(AValue, 0.0, 1.0); if FOpacity = AValue then Exit; FOpacity:=AValue; ItemChanged; end; procedure TMapLayer.SetPointsOfInterest(AValue: TPointsOfInterest); begin FPointsOfInterest.Assign(AValue); end; procedure TMapLayer.SetUseThreads(AValue: Boolean); begin if FUseThreads = AValue then Exit; FUseThreads := AValue; ItemChanged; 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.ItemChanged; begin if Assigned(FComboLayer) then begin FComboLayer.TileLayer.MapProvider := FMapProvider; FComboLayer.TileLayer.UseThreads := FUseThreads; FComboLayer.TileLayer.DrawMode := FDrawMode; FComboLayer.TileLayer.Opacity := FOpacity; FComboLayer.Visible := FVisible; end; Changed(False); end; constructor TMapLayer.Create(ACollection: TCollection); begin inherited Create(ACollection); FUseThreads := True; FDrawMode := idmUseOpacity; FOpacity := 0.25; FVisible := True; FTag := 0; FPointsOfInterest := TPointsOfInterest.Create(Self); FComboLayer := TGPSComboLayer.Create; MapView.GPSItems.Add(FComboLayer, _TILELAYERS_ID_, Self.Index - LAYERS_ZOFFS); end; destructor TMapLayer.Destroy; begin FPointsOfInterest.Free; if Assigned(FComboLayer) then MapView.GPSItems.Delete(FComboLayer); inherited Destroy; end; { TMapLayers } procedure TMapLayers.Update(Item: TCollectionItem); begin inherited Update(Item); if Assigned(MCOwner) then MCOwner.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 MCOwner.GPSItems.ChangeZOrder(Items[I].FComboLayer, I + LAYERS_ZOFFS); end; { TDrawObjJob } function TDrawObjJob.pGetTask: integer; var i: integer; begin if not(AllRun) and not(Cancelled) then begin for i := Low(FStates) to High(FStates) do if FStates[i]=0 then begin result := i+1; Exit; end; AllRun:=True; end; Result := ALL_TASK_COMPLETED; for i := Low(FStates) to High(FStates) do if FStates[i]=1 then begin Result := NO_MORE_TASK; Exit; end; end; procedure TDrawObjJob.pTaskStarted(aTask: integer); begin FRunning := True; FStates[aTask-1] := 1; end; procedure TDrawObjJob.pTaskEnded(aTask: integer; aExcept: Exception); begin if Assigned(aExcept) then FStates[aTask-1] := 3 else FStates[aTask-1] := 2; end; procedure TDrawObjJob.ExecuteTask(aTask: integer; FromWaiting: boolean); var iObj: integer; Obj: TGpsObj; begin iObj := aTask-1; Obj := FLst[iObj]; Viewer.DrawGpsObj(FArea, Obj); end; function TDrawObjJob.Running: boolean; begin Result := FRunning; end; constructor TDrawObjJob.Create(aViewer: TMapView; aLst: TGPSObjList; const aArea: TRealArea); begin FArea := aArea; FLst := aLst; SetLength(FStates, FLst.Count); Viewer := aViewer; AllRun := false; Name := 'DrawObj'; end; destructor TDrawObjJob.Destroy; begin inherited Destroy; FreeAndNil(FLst); end; { TMapView } procedure TMapView.SetActive(AValue: boolean); begin if FActive = AValue then Exit; if AValue and (MapProvider = '') then // Raising an exception won't let the component to be loaded if not (csLoading in ComponentState) then raise Exception.Create('MapProvider is not selected.'); FActive := AValue; if FActive then ActivateEngine else Engine.Active := false; end; procedure TMapView.SetCacheMaxAge(AValue: Integer); begin if Engine.CacheMaxAge = AValue then Exit; Engine.CacheMaxAge := AValue; UpdateLayers; end; function TMapView.GetCacheOnDisk: boolean; begin Result := FCacheOnDisk; end; function TMapView.GetCachePath: String; begin Result := Engine.CachePath; end; function TMapView.GetCenter: TRealPoint; begin Result := Engine.Center; end; function TMapView.GetCyclic: Boolean; begin Result := Engine.Cyclic; end; function TMapView.GetDownloadEngine: TMvCustomDownloadEngine; begin if FDownloadEngine = nil then Result := FBuiltinDownloadEngine else Result := FDownloadEngine; end; function TMapView.GetDrawingEngine: TMvCustomDrawingEngine; begin if FDrawingEngine = nil then Result := FBuiltinDrawingEngine else Result := FDrawingEngine; end; function TMapView.GetDrawPreviewTiles: Boolean; begin Result := Engine.DrawPreviewTiles; end; function TMapView.GetGPSItems: TGPSObjectList; begin Result := GetGPSLayer(5); end; function TMapView.GetGPSLayer(Layer: Integer): TGPSObjectList; begin Result := FGPSItems[Layer mod 10]; end; function TMapView.GetInactiveColor: TColor; begin Result := FPColorToTColor(Engine.BkColor); end; function TMapView.GetLayers: TMapLayers; begin Result := FLayers; end; function TMapView.GetMapProvider: String; begin result := Engine.MapProvider; end; function TMapView.GetOnCenterMove: TNotifyEvent; begin result := Engine.OnCenterMove; end; function TMapView.GetOnChange: TNotifyEvent; begin Result := Engine.OnChange; end; function TMapView.GetOnZoomChange: TNotifyEvent; begin Result := Engine.OnZoomChange; end; function TMapView.GetUseThreads: boolean; begin Result := Engine.UseThreads; end; function TMapView.GetZoom: integer; begin result := Engine.Zoom; end; function TMapView.GetZoomToCursor: Boolean; begin Result := Engine.ZoomToCursor; end; function TMapView.IsCacheMaxAgeStored: Boolean; begin Result := Engine.CacheMaxAge <> MaxInt; end; function TMapView.IsCachePathStored: Boolean; begin Result := not SameText(CachePath, 'cache/'); end; function TMapView.IsFontStored: Boolean; begin Result := SameText(FFont.Name, 'default') and (FFont.Size = 0) and (FFont.Style = []) and (FFont.Color = clBlack); end; function TMapView.IsLayersStored: Boolean; begin Result := True; end; procedure TMapView.SetCacheOnDisk(AValue: boolean); begin 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); begin Engine.Center := AValue; Invalidate; end; procedure TMapView.SetCyclic(AValue: Boolean); begin Engine.Cyclic := AValue; UpdateLayers; Invalidate; end; procedure TMapView.SetDebugTiles(AValue: Boolean); begin if FDebugTiles = AValue then exit; FDebugTiles := AValue; Invalidate; end; procedure TMapView.SetDefaultTrackColor(AValue: TColor); begin if FDefaultTrackColor = AValue then exit; FDefaultTrackColor := AValue; Invalidate; end; procedure TMapView.SetDefaultTrackWidth(AValue: Integer); begin if FDefaultTrackWidth = AValue then exit; FDefaultTrackWidth := AValue; Invalidate; end; procedure TMapView.SetDownloadEngine(AValue: TMvCustomDownloadEngine); begin FDownloadEngine := AValue; FEngine.DownloadEngine := GetDownloadEngine; UpdateLayers; end; procedure TMapView.SetDrawingEngine(AValue: TMvCustomDrawingEngine); begin FDrawingEngine := AValue; if AValue = nil then begin FBuiltinDrawingEngine.CreateBuffer(ClientWidth, ClientHeight); FEngine.CacheItemClass := FBuiltinDrawingEngine.GetCacheItemClass; end else begin FBuiltinDrawingEngine.CreateBuffer(0, 0); FDrawingEngine.CreateBuffer(ClientWidth, ClientHeight); FEngine.CacheItemClass := FDrawingEngine.GetCacheItemClass; end; UpdateFont(nil); end; procedure TMapView.SetDrawPreviewTiles(AValue: Boolean); begin Engine.DrawPreviewTiles := AValue; end; procedure TMapView.SetFont(AValue: TFont); begin FFont.Assign(AValue); UpdateFont(nil); end; procedure TMapView.SetInactiveColor(AValue: TColor); begin Engine.BkColor := TColorToFPColor(AValue); if not IsActive then Invalidate; end; procedure TMapView.SetLayers(const ALayers: TMapLayers); begin FLayers.Assign(ALayers); end; procedure TMapView.ActivateEngine; begin Engine.SetSize(ClientWidth,ClientHeight); Engine.Active := IsActive; end; procedure TMapView.SetMapProvider(AValue: String); begin //if AValue = '' then // raise EArgumentException.Create('Empty map provider is not allowed.'); Engine.MapProvider := AValue; if AValue = '' then Active := False; Invalidate; end; procedure TMapView.SetOnCenterMove(AValue: TNotifyEvent); begin Engine.OnCenterMove := AValue; end; procedure TMapView.SetOnChange(AValue: TNotifyEvent); begin Engine.OnChange := AValue; end; procedure TMapView.SetOnZoomChange(AValue: TNotifyEvent); begin Engine.OnZoomChange := AValue; end; procedure TMapView.SetOptions(AValue: TMapViewOptions); begin if FOptions = AValue then Exit; FOptions := AValue; if Engine.InDrag and not (mvoMouseDragging in FOptions) then begin Engine.DragObj.AbortDrag; Invalidate; end; end; procedure TMapView.SetPOIImage(const AValue: TBitmap); begin if FPOIImage = AValue then exit; FPOIImage := AValue; Invalidate; end; procedure TMapView.SetPOIImages(const AValue: TCustomImageList); begin if FPOIImages = AValue then exit; FPOIImages := AValue; Invalidate; end; procedure TMapView.SetPOIImagesWidth(AValue: Integer); begin if FPOIImagesWidth = AValue then exit; FPOIImagesWidth := AValue; Invalidate; end; procedure TMapView.SetPOITextBgColor(AValue: TColor); begin if FPOITextBgColor = AValue then exit; FPOITextBgColor := AValue; Invalidate; end; procedure TMapView.SetUseThreads(AValue: boolean); begin Engine.UseThreads := aValue; end; procedure TMapView.SetZoom(AValue: integer); begin 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; end; function TMapView.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; begin Result:=inherited DoMouseWheel(Shift, WheelDelta, MousePos); if IsActive and (mvoMouseZooming in FOptions) then begin Engine.MouseWheel(self,Shift,WheelDelta,MousePos,Result); Invalidate; end; end; procedure TMapView.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseDown(Button, Shift, X, Y); if IsActive and (mvoMouseDragging in FOptions) then begin Engine.MouseDown(self,Button,Shift,X,Y); Invalidate; end; end; procedure TMapView.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseUp(Button, Shift, X, Y); if IsActive and (mvoMouseDragging in FOptions) then begin Engine.MouseUp(self,Button,Shift,X,Y); Engine.Redraw; Invalidate; end; end; procedure TMapView.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited MouseMove(Shift, X, Y); if IsActive and (mvoMouseDragging in FOptions) then begin Engine.MouseMove(self,Shift,X,Y); if Engine.InDrag then Invalidate; end; end; procedure TMapView.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (AComponent = FPOIImages) and (Operation = opRemove) then FPOIImages := nil; end; procedure TMapView.DblClick; begin inherited DblClick; if IsActive then begin Engine.DblClick(self); Invalidate; end; end; procedure TMapView.DoOnResize; begin inherited DoOnResize; //cancel all rendering threads Engine.CancelCurrentDrawing; DrawingEngine.CreateBuffer(ClientWidth, ClientHeight); if IsActive then begin Engine.SetSize(ClientWidth, ClientHeight); Invalidate; end; end; procedure TMapView.Paint; const FREE_DRAG = 0; //(TILE_SIZE * TILE_SIZE) div 4; procedure DrawCenter; var C: TPoint; begin C := Point(ClientWidth div 2, ClientHeight div 2); Canvas.Pen.Color := clBlack; Canvas.Pen.Width := 1; Canvas.Line(C.X, C.Y - 15, C.X, C.Y + 15); Canvas.Line(C.X - 15, C.Y, C.X + 15, C.Y); end; procedure InactiveDraw; begin Canvas.Brush.Color := InactiveColor; Canvas.Brush.Style := bsSolid; Canvas.FillRect(0, 0, ClientWidth, ClientHeight); end; procedure FullRedraw; var W: Integer; begin Engine.Redraw; W := Canvas.Width; if Cyclic then W := Min(1 shl Zoom * TILE_SIZE, W); DrawObjects(Default(TTileId), 0, 0, W - 1, Canvas.Height); DrawingEngine.PaintToCanvas(Canvas); if DebugTiles then DrawCenter; end; procedure DragDraw; var O: TPoint; begin O := Point(Engine.DragObj.OfsX, Engine.DragObj.OfsY); // Free drag up to half of the tile if ((O.X * O.X + O.Y * O.Y) < FREE_DRAG) then begin DrawingEngine.PaintToCanvas(Canvas); DrawingEngine.PaintToCanvas(Canvas, O); if DebugTiles then DrawCenter; end else FullRedraw; end; begin inherited Paint; if IsActive then if Engine.InDrag then DragDraw else FullRedraw else InactiveDraw; end; procedure TMapView.OnGPSItemsModified(Sender: TObject; objs: TGPSObjList; Adding: boolean); var Area, objArea, visArea: TRealArea; begin if Adding and Assigned(Objs) then begin objArea := GetAreaOf(Objs); visArea := GetVisibleArea; if hasIntersectArea(objArea, visArea) then begin Area := IntersectArea(objArea, visArea); Invalidate; end end else Engine.Redraw; end; procedure TMapView.DrawTrack(const Area: TRealArea; trk: TGPSTrack); var I, L, T, WS: Integer; ClipRect: TRect; iPt1, iPt2, iPt3, iPt4: TPoint; ToEast: Boolean; pt1, pt2: TRealPoint; trkColor: TColor; trkWidth: Integer; procedure ClipDrawLine(P1, P2: TPoint); inline; begin if not ClipLineToRect(ClipRect, P1, P2) then DrawingEngine.Line(P1.X, P1.Y, P2.X, P2.Y); end; begin if not trk.Visible or (trk.Points.Count = 0) then exit; // Determine track color if trk.LineColor = clDefault then begin trkColor := ColorToRGB(FDefaultTrackColor); if (trk.ExtraData <> nil) and trk.ExtraData.InheritsFrom(TDrawingExtraData) then trkColor := TDrawingExtraData(trk.ExtraData).Color; end else trkColor := ColorToRGB(trk.LineColor); // Determine track width if trk.LineWidth = -1 then begin trkWidth := FDefaultTrackWidth; if (trk.ExtraData <> nil) and trk.ExtraData.InheritsFrom(TTrackExtraData) then trkWidth := mmToPx(TTrackExtraData(trk.ExtraData).Width); end else trkWidth := mmToPx(trk.LineWidth); if trkWidth < 1 then trkWidth := 1; DrawingEngine.PenColor := trkColor; DrawingEngine.PenWidth := trkWidth; // Clipping rectangle if Cyclic then ClipRect := Rect(0, 0, ClientWidth, ClientHeight) else begin L := Max(0, Engine.MapLeft); T := Max(0, Engine.MapTop); WS := ZoomFactor(Zoom) * TILE_SIZE; ClipRect := Rect(L, T, Min(Engine.MapLeft + WS, ClientWidth), Min(Engine.MapTop + WS, ClientHeight)); end; pt1 := trk.Points[0].RealPoint; iPt1 := Engine.LonLatToScreen(pt1); for I := 1 to Pred(trk.Points.Count) do begin pt2 := trk.Points[I].RealPoint; iPt2 := Engine.LonLatToScreen(pt2); ToEast := GoingEast(pt1.Lon, pt2.Lon); // Eastwards? iPt2 := CyclicPointOf(iPt2, iPt1.X, ToEast); // Nearest iPt2 to iPt1 // Rightmost cyclic copy of the segment if ToEast then begin iPt3 := CyclicPointOf(iPt1, ClipRect.Right); // Left point iPt4 := (iPt2 - iPt1); // delta to the right point end else begin iPt3 := CyclicPointOf(iPt2, ClipRect.Right); // Left point iPt4 := (iPt1 - iPt2); // delta to the right point end; // Draw all copies of the segment, right to left repeat ClipDrawLine(iPt3, iPt3 + iPt4); iPt3 := CyclicPointOf(iPt3, Pred(iPt3.X), False); // Next left cyclic iPt3 until Max(iPt3.X, iPt3.X + iPt4.X) < ClipRect.Left; pt1 := pt2; iPt1 := iPt2; end; end; procedure TMapView.DrawPointOfInterest(const Area: TRealArea; APt: TGPSPointOfInterest); var pt: TPoint; ptCyc: TPointArray; ptColor: TColor; extent: TSize; s: String; bmp: TBitmap; w, h: Integer; procedure DrawOne(pt: TPoint); begin if Assigned(bmp) then DrawingEngine.DrawBitmap(pt.X - w div 2, pt.Y - h, bmp, true) else begin // ... or as cross ptColor := clRed; if (APt.ExtraData <> nil) and APt.ExtraData.InheritsFrom(TDrawingExtraData) then ptColor := TDrawingExtraData(APt.ExtraData).Color; DrawingEngine.PenColor := ptColor; DrawingEngine.PenWidth := 3; DrawingEngine.Line(pt.X, pt.Y - 5, pt.X, pt.Y + 5); DrawingEngine.Line(pt.X - 5, pt.Y, pt.X + 5, pt.Y); pt.Y := pt.Y + 5; end; if FPOITextBgColor = clNone then DrawingEngine.BrushStyle := bsClear else begin DrawingEngine.BrushStyle := bsSolid; DrawingEngine.BrushColor := FPOITextBgColor; end; DrawingEngine.TextOut(pt.X - extent.CX div 2, pt.Y + 5, s); end; begin pt := Engine.LonLatToScreen(APt.RealPoint); bmp := Nil; try // Draw point as symbol from image list ... if Assigned(FPOIImages) and (APt.ImageIndex <> -1) and (APt.ImageIndex < FPOIImages.Count) then begin bmp := TBitmap.Create; FPOIImages.GetBitmap(APt.ImageIndex, bmp); {$IF LCL_FullVersion >= 2000000} w := FPOIImages.WidthForPPI[FPOIImagesWidth, Font.PixelsPerInch]; h := FPOIImages.HeightForPPI[FPOIImagesWidth, Font.PixelsPerInch]; {$ELSE} w := FPOIImages.Width; h := FPOIImages.Height; {$IFEND} end; // Draw point text s := APt.Name; if FPOITextBgColor <> clNone then s := ' ' + s + ' '; extent := DrawingEngine.TextExtent(s); if Cyclic then begin ptCyc := CyclicPointsOf(pt); for pt in ptCyc do DrawOne(pt); end else DrawOne(pt); finally bmp.Free; end; end; procedure TMapView.DrawPt(const Area: TRealArea; APt: TGPSPoint); var Pt: TPoint; PtCyc: TPointArray; PtColor: TColor; extent: TSize; s: String; procedure DrawOne(Pt: TPoint); begin // Draw point marker if Assigned(FPOIImage) and not (FPOIImage.Empty) then DrawingEngine.DrawBitmap(Pt.X - FPOIImage.Width div 2, Pt.Y - FPOIImage.Height, FPOIImage, true) else begin DrawingEngine.PenColor := ptColor; DrawingEngine.PenWidth := 3; DrawingEngine.Line(Pt.X, Pt.Y - 5, Pt.X, Pt.Y + 5); DrawingEngine.Line(Pt.X - 5, Pt.Y, Pt.X + 5, Pt.Y); Pt.Y := Pt.Y + 5; end; // Draw point text s := APt.Name; if FPOITextBgColor = clNone then DrawingEngine.BrushStyle := bsClear else begin DrawingEngine.BrushStyle := bsSolid; DrawingEngine.BrushColor := FPOITextBgColor; s := ' ' + s + ' '; end; extent := DrawingEngine.TextExtent(s); DrawingEngine.Textout(Pt.X - extent.CX div 2, Pt.Y + 5, s); end; begin if Assigned(FOnDrawGpsPoint) then begin FOnDrawGpsPoint(Self, DrawingEngine, APt); exit; end; Pt := Engine.LonLatToScreen(APt.RealPoint); PtColor := clRed; if APt.ExtraData <> nil then begin if APt.ExtraData.inheritsFrom(TDrawingExtraData) then PtColor := TDrawingExtraData(APt.ExtraData).Color; end; PtCyc := CyclicPointsOf(Pt); for Pt in PtCyc do DrawOne(Pt); end; procedure TMapView.DrawGpsObj(const Area: TRealArea; AObj: TGPSObj); begin GPSItems.Lock; try AObj.Draw(Self, Area); finally GPSItems.Unlock; end; end; function TMapView.GetCacheMaxAge: Integer; begin Result := Engine.CacheMaxAge; end; procedure TMapView.CallAsyncInvalidate; Begin if not(AsyncInvalidate) then begin AsyncInvalidate := true; Engine.Jobqueue.QueueAsyncCall(@DoAsyncInvalidate, 0); end; end; procedure TMapView.DrawObjects(const TileId: TTileId; aLeft, aTop,aRight,aBottom: integer); var Area: TRealArea; lst: TGPSObjList; I, J: Integer; begin Area.TopLeft := Engine.ScreenToLonLat(Point(aLeft, aTop)); Area.BottomRight := Engine.ScreenToLonLat(Point(aRight, aBottom)); for J := 0 to High(FGPSItems) do if FGPSItems[J].Visible and (FGPSItems[J].Count > 0) then begin lst := FGPSItems[J].GetObjectsInArea(Area); try if lst.Count > 0 then begin for I := 0 to Pred(lst.Count) do if lst[I].Visible then DrawGpsObj(Area, lst[I]); end; finally FreeAndNil(Lst); end; end; end; procedure TMapView.DoAsyncInvalidate(Data: PtrInt); Begin Invalidate; AsyncInvalidate := false; end; procedure TMapView.DoDrawStretchedTile(const TileId: TTileID; X, Y: Integer; TileImg: TPictureCacheItem; const R: TRect); begin if Assigned(TileImg) then DrawingEngine.DrawScaledCacheItem(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); end; procedure TMapView.DoDrawTile(const TileId: TTileId; X, Y: integer; TileImg: TPictureCacheItem); begin if Assigned(TileImg) then DrawingEngine.DrawCacheItem(X, Y, TileImg) else DrawingEngine.FillPixels(X, Y, X + TILE_SIZE, Y + TILE_SIZE, InactiveColor); if FDebugTiles then DoDrawTileInfo(TileID, X, Y); end; procedure TMapView.DoDrawTileInfo(const TileID: TTileID; X, Y: Integer); begin DrawingEngine.PenColor := clGray; DrawingEngine.PenWidth := 1; DrawingEngine.Line(X, Y, X, Y + TILE_SIZE); DrawingEngine.Line(X, Y, X + TILE_SIZE, Y); DrawingEngine.Line(X + TILE_SIZE, Y, X + TILE_SIZE, Y + TILE_SIZE); DrawingEngine.Line(X, Y + TILE_SIZE, X + TILE_SIZE, Y + TILE_SIZE); end; procedure TMapView.DoEraseBackground(const R: TRect); begin DrawingEngine.FillPixels(R.Left, R.Top, R.Right, R.Bottom, InactiveColor); end; procedure TMapView.DoTileDownloaded(const TileId: TTileId); begin // TODO: Include tile information to optimize redraw. CallAsyncInvalidate; end; function TMapView.IsActive: Boolean; begin Result := FActive end; constructor TMapView.Create(AOwner: TComponent); var I: Integer; begin inherited Create(AOwner); Width := 150; Height := 150; FLayers := CreateLayers; FActive := false; FOptions := DefaultMapViewOptions; FDefaultTrackColor := clRed; FDefaultTrackWidth := 1; for I := 0 to High(FGPSItems) do begin FGPSItems[I] := TGPSObjectList.Create; FGPSItems[I].OnModified := @OnGPSItemsModified; end; {$IFDEF MSWindows} FBuiltinDownloadEngine := TMvDEWin.Create(self); {$ELSE} FBuiltinDownloadEngine := TMvDEFpc.Create(self); {$ENDIF} FBuiltinDownloadEngine.Name := 'BuiltInDLE'; FEngine := TMapViewerEngine.Create(self); FEngine.BkColor := colWhite; FEngine.CachePath := 'cache/'; FEngine.CacheOnDisk := true; FEngine.OnDrawTile := @DoDrawTile; FEngine.OnDrawStretchedTile := @DoDrawStretchedTile; FEngine.OnEraseBackground := @DoEraseBackground; FEngine.OnTileDownloaded := @DoTileDownloaded; FEngine.DrawPreviewTiles := True; FEngine.DrawTitleInGuiThread := false; FEngine.DownloadEngine := FBuiltinDownloadEngine; FEngine.ZoomToCursor := True; FBuiltinDrawingEngine := TMvIntfGraphicsDrawingEngine.Create(self); FEngine.CacheItemClass := FBuiltinDrawingEngine.GetCacheItemClass; FBuiltinDrawingEngine.Name := 'BuiltInDE'; FBuiltinDrawingEngine.CreateBuffer(Width, Height); FFont := TFont.Create; FFont.Name := 'default'; FFont.Size := 0; FFont.Style := []; FFont.Color := clBlack; FFont.OnChange := @UpdateFont; FPOIImage := TBitmap.Create; FPOIImage.OnChange := @UpdateImage; FPOITextBgColor := clNone; FCenter := TMapCenter.Create(Self); FCenter.Longitude := 0.0; FCenter.Latitude := 0.0; FZoomMin := 0; FZoomMax := 19; Zoom := 1; 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; function TMapView.CyclicPointOf(APoint: TPoint; ARefX: LongInt; Eastwards: Boolean): TPoint; var WorldSize: Int64; begin Result := APoint; WorldSize := ZoomFactor(Zoom) * TILE_SIZE; if Eastwards then begin while Result.X < ARefX do Inc(Result.X, WorldSize); while Result.X >= ARefX + WorldSize do Dec(Result.X, WorldSize); end else begin while Result.X > ARefX do Dec(Result.X, WorldSize); while Result.X <= ARefX - WorldSize do Inc(Result.X, WorldSize); end; end; function TMapView.CyclicPointsOf(APoint: TPoint): TPointArray; var I, R, L, WorldSize: LongInt; begin Result := Default(TPointArray); if not Cyclic then begin SetLength(Result, 1); Result[0] := APoint; end else begin WorldSize := ZoomFactor(Zoom) * TILE_SIZE; SetLength(Result, 1 + Canvas.Width div WorldSize); Result[0] := APoint; I := 1; R := APoint.X + WorldSize; L := APoint.X - WorldSize; while (R < Canvas.Width) or (L >= 0) do begin if R < Canvas.Width then begin Result[I].Y := APoint.Y; Result[I].X := R; Inc(I); end; if L >= 0 then begin Result[I].Y := APoint.Y; Result[I].X := L; Inc(I); end; Inc(R, WorldSize); Dec(L, WorldSize); end; if I < Length(Result) then SetLength(Result, I); end; end; procedure TMapView.SaveToFile(AClass: TRasterImageClass; const AFileName: String); var stream: TFileStream; begin stream := TFileStream.Create(AFileName, fmCreate + fmShareDenyNone); try SaveToStream(AClass, stream); finally stream.Free; end; end; function TMapView.SaveToImage(AClass: TRasterImageClass): TRasterImage; begin Result := DrawingEngine.SaveToImage(AClass); end; procedure TMapView.SaveToStream(AClass: TRasterImageClass; AStream: TStream); var img: TRasterImage; begin img := SaveToImage(AClass); try img.SaveToStream(AStream); finally img.Free; end; end; function TMapView.ScreenToLonLat(aPt: TPoint): TRealPoint; begin Result:=Engine.ScreenToLonLat(aPt); end; function TMapView.LonLatToScreen(aPt: TRealPoint): TPoint; begin Result:=Engine.LonLatToScreen(aPt); end; procedure TMapView.GetMapProviders(lstProviders: TStrings); var L: TStringList; begin L := TStringList.Create; try Engine.GetMapProviders(L); L.Sort; lstProviders.Assign(L); finally L.Free; end; // Engine.GetMapProviders(lstProviders); end; procedure TMapView.WaitEndOfRendering; begin Engine.Jobqueue.WaitAllJobTerminated(Engine); end; function TMapView.ObjsAtScreenPt(X, Y: Integer; ATolerance: Integer = -1): TGPSObjarray; const DELTA = 3; var rArea: TRealArea; gpsList: TGPSObjList; i, J: Integer; L: TGPSObjectList; begin Result := nil; if ATolerance = -1 then ATolerance := DELTA; // Define area of +/-ATolerance pixels around the screen point rArea.TopLeft := ScreenToLonLat(Point(X-ATolerance, Y-ATolerance)); rArea.BottomRight := ScreenToLonLat(Point(X+ATolerance, Y+ATolerance)); // Collect Objects in this are for J := 0 to 9 do begin gpsList := FGPSItems[J].GetObjectsInArea(rArea); try SetLength(Result, gpsList.Count); for i := 0 to gpsList.Count-1 do if gpsList[i] is TGPSPoint then Result[i] := gpsList[i]; finally gpsList.Free; end; end; end; procedure TMapView.CenterOnObj(obj: TGPSObj); var Area: TRealArea; Pt: TRealPoint; begin obj.GetArea(Area); Pt.Lon := (Area.TopLeft.Lon + Area.BottomRight.Lon) /2; Pt.Lat := (Area.TopLeft.Lat + Area.BottomRight.Lat) /2; Center := Pt; end; procedure TMapView.ZoomOnObj(obj: TGPSObj); var Area: TRealArea; begin obj.GetArea(Area); Engine.ZoomOnArea(Area); end; procedure TMapView.ZoomOnArea(const aArea: TRealArea); begin Engine.ZoomOnArea(aArea); end; procedure TMapView.Redraw; begin Invalidate; end; function TMapView.GetVisibleArea: TRealArea; var mapWidth: Int64; begin Result.TopLeft := Engine.ScreenToLonLat(Point(0, 0)); Result.BottomRight := Engine.ScreenToLonLat(Point(Width, Height)); if Cyclic then begin mapWidth := ZoomFactor(Engine.Zoom) * TILE_SIZE; if Width >= mapWidth then begin Result.TopLeft.Lon := -180; Result.BottomRight.Lon := 180; end; end; end; procedure TMapView.ClearBuffer; begin DrawingEngine.CreateBuffer(ClientWidth, ClientHeight); // ??? end; procedure TMapView.UpdateFont(Sender: TObject); begin if SameText(FFont.Name, 'default') then DrawingEngine.FontName := Screen.SystemFont.Name else DrawingEngine.FontName := FFont.Name; if FFont.Size = 0 then DrawingEngine.FontSize := Screen.SystemFont.Size else DrawingEngine.FontSize := FFont.Size; DrawingEngine.FontStyle := FFont.Style; DrawingEngine.FontColor := ColorToRGB(FFont.Color); Engine.Redraw; end; procedure TMapView.UpdateImage(Sender: TObject); begin Engine.Redraw; end; function TMapView.CreateLayers: TMapLayers; begin Result := TMapLayers.Create(Self); end; procedure TMapView.UpdateLayers; var I: Integer; begin for I := 0 to Pred(FLayers.Count) do FLayers[I].FComboLayer.TileLayer.ParentViewChanged; end; { TGPSTileLayerBase } function TGPSTileLayerBase.GetMapProvider: String; begin Result := FEngine.MapProvider; end; function TGPSTileLayerBase.GetUseThreads: Boolean; begin Result := FEngine.UseThreads; end; procedure TGPSTileLayerBase.SetParentView(AValue: TMapView); begin if (FParentView = AValue) and not FParentViewChanged then Exit; FEngine.Active := False; FParentView := AValue; if not Assigned(FParentView) then Exit; FEngine.DownloadEngine := FParentView.DownloadEngine; FEngine.CacheItemClass := FParentView.Engine.CacheItemClass; FEngine.CachePath := FParentView.Engine.CachePath; FEngine.CacheOnDisk := FParentView.Engine.CacheOnDisk; FEngine.CacheMaxAge := FParentView.Engine.CacheMaxAge; FEngine.Cyclic := FParentView.Engine.Cyclic; FEngine.CopyMapWindowFrom(FParentView.Engine); FEngine.Active := True; end; procedure TGPSTileLayerBase.DoTileDownloaded(const TileId: TTileId); begin TileDownLoaded(TileId); if Assigned(FParentView) then FParentView.Redraw; end; procedure TGPSTileLayerBase.DoDrawTile(const TileId: TTileId; X, Y: Integer; TileImg: TPictureCacheItem); begin DrawTile(TileId, X, Y, TileImg); end; procedure TGPSTileLayerBase.SetDrawMode(AValue: TItemDrawMode); begin if FDrawMode = AValue then Exit; FDrawMode := AValue; if Assigned(FParentView) then FParentView.Redraw; end; procedure TGPSTileLayerBase.TileDownloaded(const TileId: TTileId); begin ; // Intentionally empty end; procedure TGPSTileLayerBase.SetMapProvider(AValue: String); begin if AValue = FMapProvider then Exit; FMapProvider := AValue; FEngine.MapProvider := FMapProvider; end; procedure TGPSTileLayerBase.SetOpacity(AValue: Single); begin if FOpacity = AValue then Exit; FOpacity := AValue; if Assigned(FParentView) then FParentView.Redraw; end; procedure TGPSTileLayerBase.SetUseThreads(AValue: Boolean); begin FEngine.UseThreads := AValue; end; constructor TGPSTileLayerBase.Create; begin inherited; FEngine := TMapViewerEngine.Create(Nil); FMapProvider := FEngine.MapProvider; FEngine.OnTileDownloaded := @DoTileDownloaded; FEngine.OnDrawTile := @DoDrawTile; end; destructor TGPSTileLayerBase.Destroy; begin FEngine.Free; inherited Destroy; end; procedure TGPSTileLayerBase.GetArea(out Area: TRealArea); begin if Assigned(FParentView) then Area := FParentView.GetVisibleArea // Always over visible area else Area.Init(-180.0, 90.0, 180.0, -90.0); // Worldwide end; procedure TGPSTileLayerBase.Draw(AView: TObject; Area: TRealArea); begin SetParentView(AView as TMapView); FEngine.CopyMapWindowFrom(FParentView.Engine); end; procedure TGPSTileLayerBase.ParentViewChanged; begin FParentViewChanged := True; end; { TGPSTileLayerLabels } procedure TGPSTileLayerLabels.DrawTile(const TileId: TTileId; X, Y: Integer; TileImg: TPictureCacheItem); begin ; // Intentionally blank end; procedure TGPSTileLayerLabels.Draw(AView: TObject; Area: TRealArea); var V: TMapView; PtTL, PtBR, Pt0, Pt: TPoint; X, Y, Z, W, H: Integer; S: String; extent: TSize; begin inherited Draw(AView, Area); V := FParentView; PtTL := V.Engine.LonLatToWorldScreen(Area.TopLeft); PtBR := V.Engine.LonLatToWorldScreen(Area.BottomRight); X := -PtTL.X div TILE_SIZE; Y := -PtTL.Y div TILE_SIZE; Pt0 := Point(V.Engine.MapLeft + X * TILE_SIZE, V.Engine.MapTop + Y * TILE_SIZE); Pt := Pt0; H := Y + (PtBR.Y - PtTL.Y) div TILE_SIZE; while Y <= H do begin X := -PtTL.X div TILE_SIZE; W := X + (PtBR.X - PtTL.X) div TILE_SIZE; while X <= W do begin Z := V.Zoom; V.DrawingEngine.BrushStyle := bsSolid; V.DrawingEngine.BrushColor := clCream; S := Format(' %d-%d-%d ', [X, Y, Z]); extent := V.DrawingEngine.TextExtent(S); V.DrawingEngine.TextOut(Pt.X + (TILE_SIZE - extent.CX) div 2, Pt.Y + (TILE_SIZE - extent.CY) div 2, S); Inc(Pt.X, TILE_SIZE); Inc(X); end; Pt.X := Pt0.X; Inc(Pt.Y, TILE_SIZE); Inc(Y); end; end; { TGPSTileLayer } procedure TGPSTileLayer.DrawTile(const TileId: TTileId; X, Y: Integer; TileImg: TPictureCacheItem); begin if not Assigned(FParentView) or not Assigned(TileImg) then Exit; FParentView.DrawingEngine.DrawCacheItem(X, Y, TileImg, FDrawMode, FOpacity); end; procedure TGPSTileLayer.Draw(AView: TObject; Area: TRealArea); begin inherited Draw(AView, Area); FEngine.Redraw; end; procedure TGPSTileLayer.TileDownloaded(const TileId: TTileId); begin FEngine.Redraw; end; end.