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

lazMapViewer: Initial commit to CCR (based on Maciej Kaczkowski (https://github.com/maciejkaczkowski/mapviewer) and ti-dic's (https://sourceforge.net/p/roadbook/code/ci/master/tree/mapviewer/) MapViewer components. Removed dependence on RGB_Graphics. Rename TMapViewer to TMapView and TMVGLGeonames to TMvGeoNames to avoid naming conflicts with original packages.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6307 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz 2018-04-16 13:59:19 +00:00
parent b27acb05ae
commit c76a4f904a
20 changed files with 4894 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
components/lazmapviewer/example/MapViewer_Demo.lpi Normal file
View File

@ -0,0 +1,82 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="MapViewer_Demo"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="lazMapViewerPkg"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="MapViewer_Demo.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="main.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Main"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="MapViewer_Demo"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

22
components/lazmapviewer/example/MapViewer_Demo.lpr Normal file
View File

@ -0,0 +1,22 @@
program MapViewer_Demo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Main
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Scaled:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

8
components/lazmapviewer/example/main.lfm Normal file
View File

@ -0,0 +1,8 @@
object Form1: TForm1
Left = 258
Height = 545
Top = 127
Width = 869
Caption = 'Form1'
LCLVersion = '1.9.0.0'
end

29
components/lazmapviewer/example/main.pas Normal file
View File

@ -0,0 +1,29 @@
unit Main;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
end.

93
components/lazmapviewer/lazmapviewerpkg.lpk Normal file
View File

@ -0,0 +1,93 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<Name Value="lazMapViewerPkg"/>
<Type Value="RunAndDesignTime"/>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<OtherUnitFiles Value="source"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Files Count="13">
<Item1>
<Filename Value="source/mvcache.pas"/>
<UnitName Value="mvCache"/>
</Item1>
<Item2>
<Filename Value="source/mvdlesynapse.pas"/>
<UnitName Value="mvDLESynapse"/>
</Item2>
<Item3>
<Filename Value="source/mvdownloadengine.pas"/>
<UnitName Value="mvDownloadEngine"/>
</Item3>
<Item4>
<Filename Value="source/mvdragobj.pas"/>
<UnitName Value="mvdragobj"/>
</Item4>
<Item5>
<Filename Value="source/mvengine.pas"/>
<UnitName Value="mvEngine"/>
</Item5>
<Item6>
<Filename Value="source/mvgeonames.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="mvgeonames"/>
</Item6>
<Item7>
<Filename Value="source/mvgpsobj.pas"/>
<UnitName Value="mvgpsobj"/>
</Item7>
<Item8>
<Filename Value="source/mvjobqueue.pas"/>
<UnitName Value="mvJobQueue"/>
</Item8>
<Item9>
<Filename Value="source/mvjobs.pas"/>
<UnitName Value="mvJobs"/>
</Item9>
<Item10>
<Filename Value="source/mvmapprovider.pas"/>
<UnitName Value="mvMapProvider"/>
</Item10>
<Item11>
<Filename Value="source/mvtypes.pas"/>
<UnitName Value="mvtypes"/>
</Item11>
<Item12>
<Filename Value="source/mvmapviewer.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="mvmapviewer"/>
</Item12>
<Item13>
<Filename Value="source/mvextradata.pas"/>
<UnitName Value="mvextradata"/>
</Item13>
</Files>
<RequiredPkgs Count="4">
<Item1>
<PackageName Value="laz_synapse"/>
</Item1>
<Item2>
<PackageName Value="rgb_graphics"/>
</Item2>
<Item3>
<PackageName Value="LCLBase"/>
</Item3>
<Item4>
<PackageName Value="FCL"/>
</Item4>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<CustomOptions Items="ExternHelp" Version="2">
<_ExternHelp Items="Count"/>
</CustomOptions>
</Package>
</CONFIG>

27
components/lazmapviewer/lazmapviewerpkg.pas Normal file
View File

@ -0,0 +1,27 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit lazMapViewerPkg;
{$warn 5023 off : no warning about unused units}
interface
uses
mvCache, mvDLESynapse, mvDownloadEngine, mvDragObj, mvEngine, mvGeoNames,
mvGPSObj, mvJobQueue, mvJobs, mvMapProvider, mvTypes, mvMapViewer,
mvExtraData,
LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('mvgeonames', @mvgeonames.Register);
RegisterUnit('mvmapviewer', @mvmapviewer.Register);
end;
initialization
RegisterPackage('lazMapViewerPkg', @Register);
end.

360
components/lazmapviewer/source/mvcache.pas Normal file
View File

@ -0,0 +1,360 @@
{
Picture cache manager (c) 2014 ti_dic
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvCache;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,mvmapprovider,IntfGraphics,syncObjs,mvtypes;
Type
{ TPictureCache }
TPictureCache = Class(TComponent)
private
FMemMaxElem : integer;
Crit : TCriticalSection;
Cache : TStringList;
FBasePath: String;
FUseDisk: Boolean;
FUseThreads: Boolean;
procedure SetUseThreads(AValue: Boolean);
Procedure EnterCrit;
Procedure LeaveCrit;
protected
function GetNewImgFor(aStream : TStream) : TLazIntfImage;
procedure FreeCache;
Function MapProvider2FileName(MapProvider : TMapProvider) : String;
Function DiskCached(const aFileName : String) : Boolean;
procedure LoadFromDisk(const aFileName : String;out img : TLazIntfImage);
Function GetFileName(MapProvider : TMapProvider;const TileId : TTileId) : String;
public
Procedure CheckCacheSize(sender : TObject);
constructor Create(aOwner : TComponent);override;
destructor destroy;override;
Procedure Add(MapProvider : TMapProvider;const TileId : TTileId;Stream : TMemoryStream);
Procedure GetFromCache(MapProvider : TMapProvider;const TileId : TTileId;out img : TLazIntfImage);
function InCache(MapProvider : TMapProvider;const TileId : TTileId) : Boolean;
property UseDisk : Boolean read FUseDisk write FUseDisk;
property BasePath : String read FBasePath write FBasePath;
property UseThreads : Boolean read FUseThreads write SetUseThreads;
end;
implementation
uses FPimage,GraphType,FPReadJPEG;
{ TPictureCache }
function IsValidPNG(stream: TStream): Boolean;
var
s: string;
y: Int64;
begin
if Assigned(stream) then
begin
SetLength(s, 3);
y := stream.Position;
stream.Position := 1;
stream.Read(s[1], 3);
stream.Position := y;
Result := s = 'PNG';
end
else
Result := False;
end;
function IsValidJPEG(stream: TStream): Boolean;
var
s: string;
y: Int64;
begin
if Assigned(stream) then
begin
SetLength(s, 4);
y := stream.Position;
stream.Position := 6;
stream.Read(s[1], 4);
stream.Position := y;
Result := (s = 'JFIF') or (s = 'Exif');
end
else
Result := False;
end;
procedure TPictureCache.SetUseThreads(AValue: Boolean);
begin
if FUseThreads=AValue then Exit;
FUseThreads:=AValue;
if aValue then
Crit:=TCriticalSection.Create
else
FreeAndnil(Crit);
end;
procedure TPictureCache.EnterCrit;
begin
if Assigned(Crit) then
Crit.Enter;
end;
procedure TPictureCache.LeaveCrit;
begin
if Assigned(Crit) then
Crit.Leave;
end;
function TPictureCache.GetNewImgFor(aStream: TStream): TLazIntfImage;
var
reader : TFPCustomImageReader;
rawImg : TRawImage;
begin
result:=nil;
Reader := nil;
if not(assigned(aStream)) then
exit;
if IsValidJPEG(astream) then
Reader := TFPReaderJPEG.create
else
if IsValidPNG(astream) then
Reader := TLazReaderPNG.create;
if Assigned(reader) then
Begin
try
rawImg.Init;
rawImg.Description.Init_BPP24_B8G8R8_BIO_TTB(TILE_SIZE,TILE_SIZE);
Result:=TLazIntfImage.create(rawImg,true);
Try
Result.LoadFromStream(aStream,reader);
except
FreeAndNil(result);
end;
finally
FreeAndNil(Reader)
end;
end;
end;
procedure TPictureCache.FreeCache;
var i : integer;
begin
EnterCrit;
Try
For i:=0 to pred(Cache.Count) do
begin
Cache.Objects[i].Free;
end;
Cache.Clear;
Cache.Free;
finally
LeaveCrit;
end;
end;
function TPictureCache.MapProvider2FileName(MapProvider: TMapProvider): String;
var i : integer;
begin
Result:='';
if Assigned(MapProvider) then
begin
Result:=MapProvider.Name;
For i:=1 to length(Result) do
if not(result[i] in ['a'..'z','A'..'Z','0'..'9','_','.']) then
Result[i]:='-';
end;
end;
function TPictureCache.DiskCached(const aFileNAme: String): Boolean;
Var FullFileName : string;
begin
if UseDisk then
Begin
FullFileName:=BasePath+aFileName;
Result:=FileExists(FullFileName);
end
Else
Result:=False;
end;
procedure TPictureCache.LoadFromDisk(const aFileName: String; out
img: TLazIntfImage);
var FullFileName : String;
aStream : TFileStream;
begin
img:=nil;
FullFileName:=BasePath+aFileName;
if FileExists(fullFileName) then
Begin
aStream:=TFileStream.Create(FullFileName,fmOpenRead);
try
Try
img:=GetNewImgFor(aStream);
except
FreeAndNil(img);
end;
if Assigned(img) then
begin
EnterCrit;
Try
Cache.AddObject(aFileName,img);
finally
LeaveCrit;
end;
end;
finally
aStream.Free;
end;
end;
end;
function TPictureCache.GetFileName(MapProvider: TMapProvider;const TileId: TTileId
): String;
begin
Result:=MapProvider2FileName(MapProvider)+'_'+inttostr(TileId.X)+'_'+inttostr(TileId.Y)+'_'+inttostr(TileId.Z);
end;
procedure TPictureCache.CheckCacheSize(Sender : TObject);
var i ,idx : integer;
begin
EnterCrit;
try
if Cache.Count>FMemMaxElem then
Begin
For i:=1 to 10 do
Begin
idx:=pred(Cache.Count);
if idx>1 then
Begin
Cache.Objects[idx].free;
Cache.Delete(idx);
end;
end;
end;
finally
LeaveCrit;
end;
end;
constructor TPictureCache.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FMemMaxElem :=2048 div 256;
Cache:=TStringList.create;
end;
destructor TPictureCache.destroy;
begin
inherited destroy;
FreeCache;
FreeAndNil(Crit);
end;
procedure TPictureCache.Add(MapProvider: TMapProvider;const TileId: TTileId;
Stream: TMemoryStream);
var FileName : String;
img : TLazIntfImage;
aFile : TFileStream;
idx : integer;
begin
FileName:=GetFileName(MapProvider,TileId);
EnterCrit;
Try
idx:=Cache.IndexOF(FileName);
if idx<>-1 then
Cache.Objects[idx].Free
else
Begin
Cache.Insert(0,FileName);
idx:=0;
end;
img:=GetNewImgFor(Stream);
Cache.Objects[idx]:=img;
finally
LeaveCrit;
end;
if UseDisk then
Begin
if assigned(img) then
Begin
aFile:=TFileStream.Create(BasePath+FileName,fmCreate);
Try
Stream.Position:=0;
aFile.CopyFrom(Stream,0);
finally
FreeAndNil(aFile);
end;
end;
end;
if Not(FUseThreads) then
CheckCacheSize(self);
end;
procedure TPictureCache.GetFromCache(MapProvider: TMapProvider;const TileId: TTileId; out img: TLazIntfImage);
var FileName : String;
idx : integer;
begin
img:=nil;
FileName:=GetFileName(MapProvider,TileId);
EnterCrit;
Try
idx:=Cache.IndexOF(FileName);
if idx<>-1 then
Begin
img:=TLazIntfImage(Cache.Objects[idx]);
if Idx>FMemMaxElem div 2 then
Begin
Cache.Delete(idx);
Cache.Insert(0,FileName);
Cache.Objects[0]:=img;
end;
end;
finally
leaveCrit;
end;
if idx=-1 then
Begin
if UseDisk then
LoadFromDisk(FileName,img);
end;
end;
function TPictureCache.InCache(MapProvider: TMapProvider;const TileId: TTileId
): Boolean;
var FileName : String;
idx : integer;
begin
FileName:=GetFileName(MapProvider,TileId);
EnterCrit;
try
idx:=Cache.IndexOF(FileNAme);
finally
leaveCrit;
end;
if idx<>-1 then
Result:=True
else
Result:=DiskCached(FileName);
end;
end.

80
components/lazmapviewer/source/mvdlesynapse.pas Normal file
View File

@ -0,0 +1,80 @@
{ Map Viewer Download Engine Synapse
Copyright (C) 2011 Maciej Kaczkowski / keit.co
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvDLESynapse;
{$mode objfpc}{$H+}
interface
uses
mvDownloadEngine,SysUtils, Classes, httpsend;
type
{ TMVDESynapse }
TMVDESynapse = class(TCustomDownloadEngine)
private
FProxyHost: string;
FProxyPassword: string;
FProxyPort: Integer;
FProxyUsername: string;
FUseProxy: Boolean;
public
procedure DownloadFile(const Url: string; str: TStream); override;
published
property UseProxy: Boolean read FUseProxy write FUseProxy;
property ProxyHost: string read FProxyHost write FProxyHost;
property ProxyPort: Integer read FProxyPort write FProxyPort;
property ProxyUsername: string read FProxyUsername write FProxyUsername;
property ProxyPassword: string read FProxyPassword write FProxyPassword;
end;
implementation
{ TMVDESynapse }
procedure TMVDESynapse.DownloadFile(const Url: string; str: TStream);
var
FHttp: THTTPSend;
begin
inherited DownloadFile(Url, str);
FHttp := THTTPSend.Create;
try
if FUseProxy then
begin
FHTTP.ProxyHost := FProxyHost;
FHTTP.ProxyPort := IntToStr(FProxyPort);
FHTTP.ProxyUser := FProxyUsername;
FHTTP.ProxyPass := FProxyPassword;
end;
if FHTTP.HTTPMethod('GET', Url) then
begin
str.Seek(0, soFromBeginning);
str.CopyFrom(FHTTP.Document, 0);
str.Position := 0;
end;
finally
FHttp.Free;
end;
end;
end.

46
components/lazmapviewer/source/mvdownloadengine.pas Normal file
View File

@ -0,0 +1,46 @@
{ Map Viewer Download Engine Synapse
Copyright (C) 2011 Maciej Kaczkowski / keit.co
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvDownloadEngine;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
Type
{ TCustomDownloadEngine }
TCustomDownloadEngine = class(TComponent)
public
procedure DownloadFile(const Url: string; str: TStream); virtual;
end;
implementation
{ TCustomDownloadEngine }
procedure TCustomDownloadEngine.DownloadFile(const Url: string; str: TStream);
begin
end;
end.

202
components/lazmapviewer/source/mvdragobj.pas Normal file
View File

@ -0,0 +1,202 @@
{
(c) 2014 ti_dic
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvdragobj;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
Type
TDragObj = Class;
TDragEvent = Procedure (Sender : TDragObj) of Object;
{ TDragObj }
TDragObj = Class
private
FMouseDown : boolean;
FLnkObj: TObject;
FDragsrc,FStartSrc : TObject;
FOfsX: integer;
FOfsY: integer;
InDrag : Boolean;
FStartX,FStartY : integer;
FMouseX,FMouseY : integer;
FEndX,FEndY : integer;
FOnDrag: TDragEvent;
FOnEndDrag: TDragEvent;
procedure SetDest(X,Y : Integer);
procedure SetLnkObj(AValue: TObject);
procedure SetOnDrag(AValue: TDragEvent);
procedure SetOnEndDrag(AValue: TDragEvent);
Procedure DostartDrag(X,Y : Integer);
Procedure DoDrag(X,Y : integer);
Procedure DoEndDrag(X,Y : integer);
Function HasMoved(X,Y : integer) : Boolean;
Procedure AbortDrag;
public
Procedure MouseDown(aDragSrc : TObject;X,Y : integer);
Procedure MouseUp(X,Y : integer);
Procedure MouseMove(X,Y : integer);
property OnDrag : TDragEvent read FOnDrag write SetOnDrag;
property OnEndDrag : TDragEvent read FOnEndDrag write SetOnEndDrag;
property OfsX : integer read FOfsX;
property OfsY : integer read FOfsY;
property StartX : integer read FStartX;
property StartY : integer read FStartY;
property MouseX : Integer read FMouseX;
property MouseY : integer read FMouseY;
property EndX : integer read FEndX;
property EndY : integer read FEndY;
Property LnkObj : TObject Read FLnkObj write SetLnkObj;
property DragSrc : TObject Read FStartSrc;
end;
implementation
{ TDragObj }
procedure TDragObj.SetDest(X, Y: Integer);
begin
FEndX:=X;
FEndY:=Y;
FOfsX:=FEndX-FstartX;
FOfsY:=FEndY-FstartY;
end;
procedure TDragObj.SetLnkObj(AValue: TObject);
begin
if FLnkObj=AValue then Exit;
FreeAndNil(FLnkObj);
FLnkObj:=AValue;
end;
procedure TDragObj.SetOnDrag(AValue: TDragEvent);
begin
if FOnDrag=AValue then Exit;
FOnDrag:=AValue;
end;
procedure TDragObj.SetOnEndDrag(AValue: TDragEvent);
begin
if FOnEndDrag=AValue then Exit;
FOnEndDrag:=AValue;
end;
procedure TDragObj.DostartDrag(X, Y: Integer);
begin
InDrag:=True;
FStartSrc := FDragSrc;
DoDrag(X,Y);
end;
procedure TDragObj.DoDrag(X, Y: integer);
begin
if (X<>FEndX) or (Y<>FEndY) then
Begin
SetDest(X,Y);
if Assigned(FOnDrag) then
FOnDrag(Self);
end;
end;
procedure TDragObj.DoEndDrag(X, Y: integer);
begin
DoDrag(X,Y);
if Assigned(FOnEndDrag) then
FOnEndDrag(self);
FreeAndNil(FLnkObj);
FStartSrc := nil;
InDrag:=False;
end;
function TDragObj.HasMoved(X, Y: integer): Boolean;
begin
Result:=(X<>FStartX) or (Y<>FStartY);
end;
procedure TDragObj.AbortDrag;
begin
if InDrag then
Begin
DoDrag(FstartX,FStartY);
InDrag:=False;
FMouseDown:=False;
FDragSrc :=nil;
FStartSrc := nil;
FreeAndNil(FLnkObj);
end;
end;
procedure TDragObj.MouseDown(aDragSrc : TObject;X, Y: integer);
begin
if not(FMouseDown) then
Begin
FDragSrc := aDragSrc;
FMouseDown := True;
FStartX := X;
FStartY := Y;
FEndX := X;
FEndY := Y;
End
Else
AbortDrag;
end;
procedure TDragObj.MouseMove(X, Y: integer);
begin
FMouseX := X;
FMouseY := Y;
if FMouseDown then
Begin
if InDrag then
DoDrag(X,Y)
else
Begin
if HasMoved(X,Y) then
DoStartDrag(X,Y);
end;
end;
end;
procedure TDragObj.MouseUp(X, Y: integer);
begin
if FMouseDown then
Begin
FMouseDown:=False;
if InDrag then
DoEndDrag(X,Y);
FDragSrc := nil;
end;
end;
end.

930
components/lazmapviewer/source/mvengine.pas Normal file
View File

@ -0,0 +1,930 @@
{
(c) 2014 ti_dic
Parts of this component are based on :
Map Viewer Copyright (C) 2011 Maciej Kaczkowski / keit.co
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvEngine;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,mvJobQueue,mvmapprovider,mvDownloadEngine,IntfGraphics,
mvCache,mvdragobj,controls,mvtypes;
const
EARTH_RADIUS = 6378137;
MIN_LATITUDE = -85.05112878;
MAX_LATITUDE = 85.05112878;
MIN_LONGITUDE = -180;
MAX_LONGITUDE = 180;
SHIFT = 2 * pi * EARTH_RADIUS / 2.0;
Type
TDrawTileEvent = Procedure (const TileId : TTileId;X,Y : integer;TileImg : TLazIntfImage) of object;
TTileIdArray = Array of TTileId;
{ TMapWindow }
TMapWindow = Record
MapProvider: TMapProvider;
X: Int64;
Y: Int64;
Center : TRealPoint;
Zoom: integer;
Height: integer;
Width: integer;
end;
{ TMapViewerEngine }
TMapViewerEngine = Class(TComponent)
private
DragObj : TDragObj;
Cache : TPictureCache;
FActive: boolean;
FDownloadEngine: TCustomDownloadEngine;
FDrawTitleInGuiThread: boolean;
FOnCenterMove: TNotifyEvent;
FOnChange: TNotifyEvent;
FOnDrawTile: TDrawTileEvent;
FOnZoomChange: TNotifyEvent;
lstProvider : TStringList;
Queue : TJobQueue;
MapWin : TMapWindow;
procedure ConstraintZoom(var aWin: TMapWindow);
function GetCacheOnDisk: Boolean;
function GetCachePath: String;
function GetCenter: TRealPoint;
function GetHeight: integer;
function GetMapProvider: String;
function GetUseThreads: Boolean;
function GetWidth: integer;
function GetZoom: integer;
function IsValidTile(const aWin: TMapWindow; const aTile: TTIleId
): boolean;
procedure MoveMapCenter(Sender: TDragObj);
procedure SetActive(AValue: boolean);
procedure SetCacheOnDisk(AValue: Boolean);
procedure SetCachePath(AValue: String);
procedure SetDownloadEngine(AValue: TCustomDownloadEngine);
procedure SetHeight(AValue: integer);
procedure SetMapProvider(AValue: String);
procedure SetUseThreads(AValue: Boolean);
procedure SetWidth(AValue: integer);
procedure SetZoom(AValue: integer);
function LonLatToMapWin(const aWin: TMapWindow; aPt: TRealPoint): TPoint;
Function MapWinToLonLat(const aWin: TMapWindow; aPt : TPoint) : TRealPoint;
Procedure CalculateWin(var aWin : TMapWindow);
Procedure Redraw(const aWin : TmapWindow);
function CalculateVisibleTiles(const aWin : TMapWindow) : TArea;
function IsCurrentWin(const aWin : TMapWindow) : boolean;
protected
function GetTileName(const Id : TTileId) : String;
procedure evDownload(Data : TObject;Job : TJob);
procedure TileDownloaded(Data: PtrInt);
Procedure RegisterProviders;
Procedure DrawTile(const TileId : TTileId;X,Y : integer;TileImg : TLazIntfImage);
function GetLetterSvr(id: integer): String;
function GetYahooSvr(id: integer): String;
function GetYahooY(const Tile : TTileId): string;
function GetYahooZ(const Tile : TTileId): string;
function GetQuadKey(const Tile : TTileId): string;
Procedure DoDrag(Sender : TDragObj);
public
Procedure CancelCurrentDrawing;
Procedure Redraw;
function AddMapProvider(OpeName: String; Url: String; MinZoom : integer;MaxZoom : integer;NbSvr: integer; GetSvrStr: TGetSvrStr =nil; GetXStr: TGetValStr =nil; GetYStr: TGetValStr =nil; GetZStr: TGetValStr =nil) : TMapProvider;
Procedure GetMapProviders(lst : TStrings);
Constructor Create(aOwner : TComponent);override;
destructor Destroy; override;
Function ScreenToLonLat(aPt : TPoint) : TRealPoint;
Function LonLatToScreen(aPt : TRealPoint) : TPoint;
Function WorldScreenToLonLat(aPt : TPoint) : TRealPoint;
Function LonLatToWorldScreen(aPt : TRealPoint) : TPoint;
Procedure SetSize(aWidth,aHeight : integer);
Procedure MouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
Procedure MouseUp(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer);
Procedure MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
Procedure DblClick(Sender: TObject);
Procedure MouseWheel(Sender: TObject; Shift: TShiftState;WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
Procedure SetCenter(aCenter : TRealPoint);
Procedure ZoomOnArea(const aArea : TRealArea);
property Center : TRealPoint read GetCenter write SetCenter;
property Zoom : integer read GetZoom write SetZoom;
property Width : integer read GetWidth write SetWidth;
property Height : integer read GetHeight write SetHeight;
property UseThreads : Boolean read GetUseThreads write SetUseThreads;
property MapProvider : String read GetMapProvider write SetMapProvider;
property DownloadEngine : TCustomDownloadEngine read FDownloadEngine write SetDownloadEngine;
property CacheOnDisk : Boolean read GetCacheOnDisk write SetCacheOnDisk;
property CachePath : String read GetCachePath write SetCachePath;
property Active : boolean read FActive write SetActive;
property OnDrawTile :TDrawTileEvent read FOnDrawTile write FOnDrawTile;
property DrawTitleInGuiThread : boolean read FDrawTitleInGuiThread write FDrawTitleInGuiThread;
property OnCenterMove : TNotifyEvent read FOnCenterMove write FOnCenterMove;
property OnZoomChange : TNotifyEvent read FOnZoomChange write FOnZoomChange;
property Jobqueue : TJobQueue read Queue;
property OnChange : TNotifyEvent Read FOnChange write FOnchange; //called when visiable area change
End;
implementation
uses Math,mvJobs,forms,mvgpsobj;
Type
{ TLaunchDownloadJob }
TLaunchDownloadJob = Class(TJob)
private
AllRun : boolean;
Win : TMapWindow;
Engine : TMapViewerEngine;
FRunning : boolean;
FTiles : TTileIdArray;
FStates : Array of integer;
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(Eng : TMapViewerEngine;const Tiles : TTileIdArray;const aWin : TMapWindow);
end;
{ TEnvTile }
TEnvTile = Class
private
Tile : TTileId;
Win : TMapWindow;
public
constructor Create(const aTile : TTileId;Const aWin : TMapWindow);
End;
{ TLaunchDownloadJob }
function TLaunchDownloadJob.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 TLaunchDownloadJob.pTaskStarted(aTask: integer);
begin
FRunning:=True;
FStates[aTask-1]:=1;
end;
procedure TLaunchDownloadJob.pTaskEnded(aTask: integer; aExcept: Exception);
begin
if Assigned(aExcept) then
FStates[aTask-1]:=3
Else
FStates[aTask-1]:=2;
end;
procedure TLaunchDownloadJob.ExecuteTask(aTask: integer; FromWaiting: boolean);
var iTile : integer;
begin
iTile:=aTask-1;
Queue.AddUniqueJob(TEventJob.Create(@Engine.evDownload,TEnvTile.Create(FTiles[iTile],Win),false,Engine.GetTileName(FTiles[iTile])),Launcher);
end;
function TLaunchDownloadJob.Running: boolean;
begin
Result:=FRunning;
end;
constructor TLaunchDownloadJob.Create(Eng : TMapViewerEngine;const Tiles: TTileIdArray;const aWin : TMapWindow);
var i : integer;
begin
Engine:=Eng;
SetLength(FTiles,Length(Tiles));
For i:=low(FTiles) to high(FTiles) do
FTiles[i]:=Tiles[i];
SetLength(FStates,length(Tiles));
AllRun:=false;
Name:='LaunchDownload';
Win:=aWin;
end;
{ TEnvTile }
constructor TEnvTile.Create(const aTile : TTileId;Const aWin : TMapWindow);
begin
Tile:=aTile;
Win:=aWin;
end;
{ TMapViewerEngine }
procedure TMapViewerEngine.SetZoom(AValue: integer);
begin
if MapWin.Zoom=AValue then Exit;
MapWin.Zoom:=AValue;
ConstraintZoom(MapWin);
CalculateWin(MapWin);
Redraw(MapWin);
if assigned(OnZoomChange) then
OnZoomChange(Self);
if Assigned(OnChange) then
OnChange(Self);
end;
procedure TMapViewerEngine.SetWidth(AValue: integer);
begin
if MapWin.Width=AValue then Exit;
MapWin.Width:=AValue;
CalculateWin(MapWin);
Redraw(MapWin);
end;
procedure TMapViewerEngine.SetHeight(AValue: integer);
begin
if MapWin.Height=AValue then Exit;
MapWin.Height:=AValue;
CalculateWin(MapWin);
Redraw(MapWin);
end;
procedure TMapViewerEngine.ConstraintZoom(var aWin : TMapWindow);
var zMin,zMax :integer;
Begin
if Assigned(aWin.MapProvider) then
Begin
aWin.MapProvider.GetZoomInfos(zMin,zMax);
if aWin.Zoom<zMin then
aWin.Zoom:=zMin;
if aWin.Zoom>zMax then
aWin.Zoom:=zMax;
End;
end;
procedure TMapViewerEngine.SetMapProvider(AValue: String);
var idx : integer;
zMin,zMax : integer;
begin
idx:=lstProvider.IndexOf(aValue);
if not((aValue='') or (idx<>-1)) then
Raise Exception.Create('Unknow Provider : '+aValue);
if Assigned(MapWin.MapProvider) and (MapWin.MapProvider.Name=AValue) then Exit;
if idx<>-1 then
Begin
MapWin.MapProvider:=TMapProvider(lstProvider.Objects[idx]);
ConstraintZoom(MapWin);
end
else
MapWin.MapProvider:=nil;
if Assigned(MapWin.MapProvider) then
Redraw(MapWin);
end;
procedure TMapViewerEngine.SetUseThreads(AValue: Boolean);
begin
if Queue.UseThreads=AValue then Exit;
Queue.UseThreads:=AValue;
Cache.UseThreads:=AValue;
end;
function TMapViewerEngine.GetZoom: integer;
begin
Result:=MapWin.zoom;
end;
procedure TMapViewerEngine.SetCacheOnDisk(AValue: Boolean);
begin
if Cache.UseDisk=AValue then Exit;
Cache.UseDisk:=AValue;
end;
procedure TMapViewerEngine.SetCachePath(AValue: String);
begin
Cache.BasePath:=aValue;
end;
procedure TMapViewerEngine.SetDownloadEngine(AValue: TCustomDownloadEngine);
begin
if FDownloadEngine=AValue then Exit;
FDownloadEngine:=AValue;
if Assigned(FDownloadEngine) then
FDownloadEngine.FreeNotification(self);
end;
function TMapViewerEngine.GetHeight: integer;
begin
Result:=MapWin.Height
end;
function TMapViewerEngine.GetCacheOnDisk: Boolean;
begin
Result:=Cache.UseDisk;
end;
function TMapViewerEngine.GetCachePath: String;
begin
Result:=Cache.BasePath;
end;
function TMapViewerEngine.GetCenter: TRealPoint;
begin
Result:=MapWin.Center;
end;
function TMapViewerEngine.GetMapProvider: String;
begin
if Assigned(MapWin.MapProvider) then
Result:=MapWin.MapProvider.Name
else
Result:='';
end;
function TMapViewerEngine.GetUseThreads: Boolean;
begin
Result:=Queue.UseThreads;
end;
function TMapViewerEngine.GetWidth: integer;
begin
Result:=MapWin.Width
end;
function TMapViewerEngine.ScreenToLonLat(aPt: TPoint): TRealPoint;
begin
Result:=MapWinToLonLat(MapWin,aPt);
end;
function TMapViewerEngine.LonLatToScreen(aPt: TRealPoint): TPoint;
Begin
Result:=LonLatToMapWin(MapWin,aPt);
end;
function TMapViewerEngine.WorldScreenToLonLat(aPt: TPoint): TRealPoint;
begin
aPt.X:=aPt.X-MapWin.X;
aPt.Y:=aPt.Y-MapWin.Y;
Result:=ScreenToLonLat(aPt);
end;
function TMapViewerEngine.LonLatToWorldScreen(aPt: TRealPoint): TPoint;
begin
Result:=LonLatToScreen(aPt);
Result.X:=Result.X+MapWin.X;
Result.Y:=Result.Y+MapWin.Y;
end;
procedure TMapViewerEngine.SetSize(aWidth, aHeight: integer);
begin
if (MapWin.Width=aWidth) and (MapWin.Height=aHeight) then Exit;
CancelCurrentDrawing;
MapWin.Width:=aWidth;
MapWin.Height:=aHeight;
CalculateWin(MapWin);
Redraw(MapWin);
if Assigned(Onchange) then
OnChange(Self);
end;
procedure TMapViewerEngine.MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button=mbLeft then
DragObj.MouseDown(self,X,Y);
end;
procedure TMapViewerEngine.MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button=mbLeft then
DragObj.MouseUp(X,Y);
end;
procedure TMapViewerEngine.MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
DragObj.MouseMove(X,Y);
end;
procedure TMapViewerEngine.DblClick(Sender: TObject);
var pt: TPoint;
begin
pt.X:=DragObj.MouseX;
pt.Y:=DragObj.MouseY;
SetCenter(ScreenToLonLat(pt));
end;
procedure TMapViewerEngine.MouseWheel(Sender: TObject;
Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint;
var Handled: Boolean);
var Val : Integer;
nZoom : integer;
begin
Val:=0;
if WheelDelta>0 then
Val:=1;
if WheelDelta<0 then
Val:=-1;
nZoom:=Zoom+Val;
if (nZoom>0) and (nZoom<20) then
Zoom:=nZoom;
Handled:=true;
end;
procedure TMapViewerEngine.SetCenter(aCenter: TRealPoint);
begin
if (MapWin.Center.lon<>aCenter.Lon) and (MapWin.Center.lat<>aCenter.Lat) then
Begin
Mapwin.center:=aCenter;
CalculateWin(MapWin);
Redraw(MapWin);
if assigned(OnCenterMove) then
OnCenterMove(Self);
if Assigned(OnChange) then
OnChange(Self);
end;
end;
procedure TMapViewerEngine.ZoomOnArea(const aArea: TRealArea);
var tmpWin : TMapWindow;
visArea : TRealArea;
TopLeft,BottomRight : TPoint;
begin
tmpWin:=MapWin;
tmpWin.Center.Lon:=(aArea.TopLeft.Lon+aArea.BottomRight.Lon)/2;
tmpWin.Center.Lat:=(aArea.TopLeft.Lat+aArea.BottomRight.Lat)/2;
tmpWin.Zoom:=15;
TopLeft.X:=0;
TopLeft.Y:=0;
BottomRight.X:=tmpWin.Width;
BottomRight.Y:=tmpWin.Height;
Repeat
CalculateWin(tmpWin);
visArea.TopLeft:=MapWinToLonLat(tmpWin,TopLeft);
visArea.BottomRight:=MapWinToLonLat(tmpWin,BottomRight);
if (AreaInsideArea(aArea,visArea)) then
begin
break;
end;
Dec(tmpWin.Zoom);
until (tmpWin.Zoom=2);
MapWin:=tmpWin;
Redraw(MapWin);
end;
procedure TMapViewerEngine.GetMapProviders(lst: TStrings);
begin
lst.Assign(lstProvider);
end;
function TMapViewerEngine.LonLatToMapWin(const aWin : TMapWindow;aPt: TRealPoint): TPoint;
var
tiles: Int64;
circumference: Int64;
lat: Extended;
res: Extended;
tmpX,tmpY : Double;
begin
tiles := 1 shl aWin.Zoom;
circumference := tiles * TILE_SIZE;
tmpX := ((aPt.Lon+ 180.0)*circumference)/360.0;
res := (2 * pi * EARTH_RADIUS) / circumference;
tmpY := -aPt.Lat;
tmpY := ln(tan((degToRad(tmpY) + pi / 2.0) / 2)) *180 / pi;
tmpY:= (((tmpY /180.0)*SHIFT)+SHIFT)/res;
tmpX := tmpX + aWin.X;
tmpY := tmpY + aWin.Y;
Result.X:=trunc(tmpX);
Result.Y:=trunc(tmpY);
End;
function TMapViewerEngine.MapWinToLonLat(const aWin: TMapWindow; aPt: TPoint): TRealPoint;
var
tiles: Int64;
circumference: Int64;
lat: Extended;
res: Extended;
mPoint : TPoint;
begin
tiles := 1 shl aWin.Zoom;
circumference := tiles * TILE_SIZE;
mPoint.X := aPt.X - aWin.X;
mPoint.Y := aPt.Y - aWin.Y;
if mPoint.X < 0 then
mPoint.X := 0
else
if mPoint.X > circumference then
mPoint.X := circumference;
if mPoint.Y < 0 then
mPoint.Y := 0
else
if mPoint.Y > circumference then
mPoint.Y := circumference;
Result.Lon := ((mPoint.X * 360.0) / circumference) - 180.0;
res := (2 * pi * EARTH_RADIUS) / circumference;
lat := ((mPoint.Y * res - SHIFT) / SHIFT) * 180.0;
lat := radtodeg (2 * arctan( exp( lat * pi / 180.0)) - pi / 2.0);
Result.Lat := -lat;
if Result.Lat > MAX_LATITUDE then
Result.Lat := MAX_LATITUDE
else
if Result.Lat < MIN_LATITUDE then
Result.Lat := MIN_LATITUDE;
if Result.Lon > MAX_LONGITUDE then
Result.Lon := MAX_LONGITUDE
else
if Result.Lon < MIN_LONGITUDE then
Result.Lon := MIN_LONGITUDE;
end;
procedure TMapViewerEngine.CalculateWin(var aWin: TMapWindow);
var
mx, my: Extended;
res: Extended;
px, py: Int64;
Begin
mx := aWin.Center.Lon * SHIFT / 180.0;
my := ln( tan((90 - aWin.Center.Lat) * pi / 360.0 )) / (pi / 180.0);
my := my * SHIFT / 180.0;
res := (2 * pi * EARTH_RADIUS) / (TILE_SIZE * (1 shl aWin.Zoom));
px := Round((mx + shift) / res);
py := Round((my + shift) / res);
aWin.X := aWin.Width div 2 - px;
aWin.Y := aWin.Height div 2 - py;
end;
function TMapViewerEngine.IsValidTile(const aWin: TMapWindow;const aTile : TTIleId) : boolean;
var tiles : int64;
begin
tiles := 1 shl aWin.Zoom;
Result:=(aTile.X>=0) and (aTile.X<=tiles-1) and (aTile.Y>=0) and (aTile.Y<=tiles-1);
end;
procedure TMapViewerEngine.Redraw(const aWin: TmapWindow);
var TilesVis : TArea;
x,y : Integer; //int64;
Tiles : TTileIdArray;
iTile : Integer;
begin
if not(Active) then
Exit;
Queue.CancelAllJob(self);
TilesVis:=CalculateVisibleTiles(aWin);
SetLength(Tiles,(TilesVis.Bottom-TilesVis.top+1)*(TilesVis.Right-TilesVis.Left+1));
iTile:=low(Tiles);
For y:=TilesVis.top to TilesVis.Bottom do
For X:=TilesVis.Left to TilesVis.Right do
Begin
Tiles[iTile].X:=X;
Tiles[iTile].Y:=Y;
Tiles[iTile].Z:=aWin.Zoom;
if IsValidTile(aWin,Tiles[iTile]) then
iTile+=1;
end;
SetLength(Tiles,iTile);
if length(Tiles)>0 then
Begin
Queue.AddJob(TLaunchDownloadJob.Create(self,Tiles,aWin),self);
end;
end;
function TMapViewerEngine.CalculateVisibleTiles(const aWin: TMapWindow): TArea;
var MaxX,MAxY,Startx,StartY : int64;
begin
MaxX := (aWin.Width div TILE_SIZE) + 1;
MaxY := (aWin.Height div TILE_SIZE) + 1;
startX := (-(aWin.X)) div TILE_SIZE;
startY := (-(aWin.Y)) div TILE_SIZE;
Result.Left := startX;
Result.right := startX + MaxX;
Result.top := startY;
Result.bottom := startY + MaxY;
end;
function TMapViewerEngine.IsCurrentWin(const aWin: TMapWindow): boolean;
begin
Result:=(aWin.Zoom=MapWin.Zoom) and (aWin.Center.Lat=MapWin.Center.Lat) and (aWin.Center.Lon=MapWin.Center.Lon) and (aWin.Width=MapWin.Width) and (aWin.Height=MapWin.Height);
end;
function TMapViewerEngine.GetTileName(const Id: TTileId): String;
begin
Result:=Inttostr(Id.X)+'.'+inttostr(Id.Y)+'.'+inttostr(Id.Z);
end;
procedure TMapViewerEngine.evDownload(Data : TObject;Job : TJob);
var Id : TTileId;
Url : String;
Env : TEnvTile;
MapO : TMapProvider;
FStream : TMemoryStream;
Begin
Env:=TEnvTile(Data);
Id:=Env.Tile;
MapO:=Env.Win.MapProvider;
if Assigned(MapO) then
Begin
if not(Cache.InCache(MapO,Id)) then
Begin
if Assigned(FDownloadEngine) then
begin
Url:=MapO.GetUrlForTile(Id);
if Url<>'' then
begin
FStream:=TMemoryStream.Create;
Try
Try
FDownloadEngine.DownloadFile(Url,Fstream);
Cache.Add(MapO,Id,FStream);
except
end;
finally
FreeAndNil(FStream);
end;
end;
end;
end;
end;
if Job.Cancelled then
Exit;
if DrawTitleInGuiThread then
Queue.QueueAsyncCall(@TileDownloaded,PtrInt(Env))
else
TileDownloaded(PtrInt(Env));
end;
procedure TMapViewerEngine.TileDownloaded(Data: PtrInt);
var EnvTile : TEnvTile;
img : TLazIntfImage;
X,Y : integer;
begin
EnvTile:=TEnvTile(Data);
Try
if IsCurrentWin(EnvTile.Win)then
Begin
Cache.GetFromCache(EnvTile.Win.MapProvider,EnvTile.Tile,img);
X := EnvTile.Win.X + EnvTile.Tile.X * TILE_SIZE; // begin of X
Y := EnvTile.Win.Y + EnvTile.Tile.Y * TILE_SIZE; // begin of X
DrawTile(EnvTile.Tile,X,Y,img);
end;
finally
FreeAndNil(EnvTile);
end;
end;
function TMapViewerEngine.GetLetterSvr(id: integer): String;
Begin
Result:=Char(Ord('a')+id);
end;
function TMapViewerEngine.GetYahooSvr(id: integer): String;
Begin
Result:=inttostr(id+1);
end;
function TMapViewerEngine.GetYahooY(const Tile : TTileId): string;
Begin
Result :=inttostr( - (Tile.Y - (1 shl Tile.Z) div 2) - 1);
end;
function TMapViewerEngine.GetYahooZ(const Tile : TTileId): string;
Begin
result:=inttostr(Tile.Z+1);
end;
function TMapViewerEngine.GetQuadKey(const Tile : TTileId): string;
var
i, d, m: Longword;
begin
{
Bing Maps Tile System
http://msdn.microsoft.com/en-us/library/bb259689.aspx
}
Result := '';
for i := Tile.Z downto 1 do
begin
d := 0;
m := 1 shl (i - 1);
if (Tile.x and m) <> 0 then
Inc(d, 1);
if (Tile.y and m) <> 0 then
Inc(d, 2);
Result := Result + IntToStr(d);
end;
end;
Type
{ TMemObj }
TMemObj = Class
private
FWin : TMapWindow;
public
constructor Create(const aWin : TMapWindow);
End;
{ TMemObj }
constructor TMemObj.Create(const aWin: TMapWindow);
begin
FWin:=aWin;
end;
procedure TMapViewerEngine.MoveMapCenter(Sender: TDragObj);
var old : TMemObj;
nCenter : TRealPoint;
Job : TJob;
aPt : TPoint;
Begin
if Sender.LnkObj=nil then
Begin
Sender.LnkObj:=TMemObj.Create(MapWin);
end;
old:=TMemObj(Sender.LnkObj);
aPt.X:=old.FWin.Width DIV 2-Sender.OfsX;
aPt.Y:=old.FWin.Height DIV 2-Sender.OfsY;
nCenter:=MapWinToLonLat(old.FWin,aPt);
SetCenter(nCenter);
end;
procedure TMapViewerEngine.SetActive(AValue: boolean);
begin
if FActive=AValue then Exit;
FActive:=AValue;
if not(FActive) then
Queue.CancelAllJob(self)
else
Redraw(MapWin);
end;
procedure TMapViewerEngine.DoDrag(Sender: TDragObj);
begin
if Sender.DragSrc=self then
Begin
MoveMapCenter(Sender);
end;
end;
procedure TMapViewerEngine.CancelCurrentDrawing;
var Jobs : TJobArray;
begin
Jobs:=Queue.CancelAllJob(self);
Queue.WaitForTerminate(Jobs);
end;
procedure TMapViewerEngine.Redraw;
begin
Redraw(MapWin);
end;
function TMapViewerEngine.AddMapProvider(OpeName: String; Url: String;
MinZoom : integer;MaxZoom : integer;
NbSvr: integer; GetSvrStr: TGetSvrStr; GetXStr: TGetValStr;
GetYStr: TGetValStr; GetZStr: TGetValStr) : TMapProvider;
var idx :integer;
Begin
idx:=lstProvider.IndexOf(OpeName);
if idx=-1 then
Begin
result:=TMapProvider.Create(OpeName);
lstProvider.AddObject(OpeName,result);
end
else
result:=TMapProvider(lstProvider.Objects[idx]);
result.AddUrl(Url,NbSvr,MinZoom,MaxZoom,GetSvrStr,GetXStr,GetYStr,GetZStr);
end;
procedure TMapViewerEngine.RegisterProviders;
begin
AddMapProvider('Aucun','',0,30, 0);
{
AddMapProvider('Google Satellite','http://khm%d.google.com/kh/v=82&x=%x%&y=%y%&z=%z%&s=Ga',4);
AddMapProvider('Google Hybrid','http://khm%d.google.com/kh/v=82&x=%x%&y=%y%&z=%z%&s=Ga',4);
AddMapProvider('Google Hybrid','http://mt%d.google.com/vt/lyrs=h@145&v=w2.104&x=%d&y=%d&z=%z%',4);
AddMapProvider('Google physical','http://mt%d.google.com/vt/lyrs=t@145&v=w2.104&x=%d&y=%d&z=%z%',4);
AddMapProvider('Google Physical Hybrid','http://mt%d.google.com/vt/lyrs=t@145&v=w2.104&x=%x%&y=%y%&z=%z%',4);
AddMapProvider('Google Physical Hybrid','http://mt%d.google.com/vt/lyrs=h@145&v=w2.104&x=%x%&y=%y%&z=%z%',4);}
//AddMapProvider('OpenStreetMap Osmarender','http://%serv%.tah.openstreetmap.org/Tiles/tile/%z%/%x%/%y%.png',0,20,3, @getLetterSvr); // [Char(Ord('a')+Random(3)), Z, X, Y]));
//AddMapProvider('Yahoo Normal','http://maps%serv%.yimg.com/hx/tl?b=1&v=4.3&.intl=en&x=%x%&y=%y%d&z=%d&r=1' , 0,20,3,@GetYahooSvr, nil, @getYahooY, @GetYahooZ); //(Z+1]));
//AddMapProvider('Yahoo Satellite','http://maps%serv%.yimg.com/ae/ximg?v=1.9&t=a&s=256&.intl=en&x=%d&y=%d&z=%d&r=1', 0,20,3,@GetYahooSvr, nil, @getYahooY, @GetYahooZ); //[Random(3)+1, X, YahooY(Y), Z+1]));
//AddMapProvider('Yahoo Hybrid','http://maps%serv%.yimg.com/ae/ximg?v=1.9&t=a&s=256&.intl=en&x=%x%&y=%y%&z=%z%&r=1', 0,20,3,@GetYahooSvr, nil, @getYahooY, @GetYahooZ); //[Random(3)+1, X, YahooY(Y), Z+1]));
//AddMapProvider('Yahoo Hybrid','http://maps%serv%.yimg.com/hx/tl?b=1&v=4.3&t=h&.intl=en&x=%x%&y=%y%&z=%z%&r=1' , 0,20,3,@GetYahooSvr, nil, @getYahooY, @GetYahooZ); //[Random(3)+1, X, YahooY(Y), Z+1]));
MapWin.MapProvider:=AddMapProvider('OpenStreetMap Mapnik','http://%serv%.tile.openstreetmap.org/%z%/%x%/%y%.png',0,19, 3, @getLetterSvr);
AddMapProvider('Open Cycle Map','http://%serv%.tile.opencyclemap.org/cycle/%z%/%x%/%y%.png',0,18,3, @getLetterSvr);
AddMapProvider('Virtual Earth Bing','http://ecn.t%serv%.tiles.virtualearth.net/tiles/r%x%?g=671&mkt=en-us&lbl=l1&stl=h&shading=hill',1,19,8,nil,@GetQuadKey);
AddMapProvider('Virtual Earth Road','http://r%serv%.ortho.tiles.virtualearth.net/tiles/r%x%.png?g=72&shading=hill',1,19,4,nil,@getQuadKey);
AddMapProvider('Virtual Earth Aerial','http://a%serv%.ortho.tiles.virtualearth.net/tiles/a%x%.jpg?g=72&shading=hill',1,19,4,nil,@getQuadKey);
AddMapProvider('Virtual Earth Hybrid','http://h%serv%.ortho.tiles.virtualearth.net/tiles/h%x%.jpg?g=72&shading=hill',1,19,4,nil,@getQuadKey);
AddMapProvider('Ovi Normal', 'http://%serv%.maptile.maps.svc.ovi.com/maptiler/v2/maptile/newest/normal.day/%z%/%x%/%y%/256/png8', 0,20,5,@getLetterSvr);
AddMapProvider('Ovi Satellite','http://%serv%.maptile.maps.svc.ovi.com/maptiler/v2/maptile/newest/satellite.day/%z%/%x%/%y%/256/png8', 0,20,5,@getLetterSvr);
AddMapProvider('Ovi Hybrid','http://%serv%.maptile.maps.svc.ovi.com/maptiler/v2/maptile/newest/hybrid.day/%z%/%x%/%y%/256/png8', 0,20,5,@getLetterSvr);
AddMapProvider('Ovi Physical','http://%serv%.maptile.maps.svc.ovi.com/maptiler/v2/maptile/newest/terrain.day/%z%/%x%/%y%/256/png8', 0,20,5,@getLetterSvr);
end;
procedure TMapViewerEngine.DrawTile(const TileId : TTileId;X, Y: integer; TileImg: TLazIntfImage);
begin
if Assigned(FOnDrawTile) then
FOnDrawTile(TileId,X,Y,TileImg);
end;
constructor TMapViewerEngine.Create(aOwner: TComponent);
begin
DrawTitleInGuiThread := true;
DragObj := TDragObj.Create;
DragObj.OnDrag:=@DoDrag;
Cache := TPictureCache.Create(self);
lstProvider:=TStringList.Create;
RegisterProviders;
Queue:=TJobQueue.Create(8);
Queue.OnIdle:= @Cache.CheckCacheSize;
inherited Create(aOwner);
ConstraintZoom(MapWin);
CalculateWin(mapWin);
end;
destructor TMapViewerEngine.Destroy;
var
i: Integer;
begin
FreeAndNil(DragObj);
for i:=0 to lstProvider.Count-1 do
TObject(lstProvider.Objects[i]).Free;
FreeAndNil(lstProvider);
FreeAndNil(Cache);
FreeAndNil(Queue);
inherited Destroy;
end;
end.

43
components/lazmapviewer/source/mvextradata.pas Normal file
View File

@ -0,0 +1,43 @@
unit mvextradata;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,graphics;
type
{ TDrawingExtraData }
TDrawingExtraData = class
private
FColor: TColor;
FId: integer;
procedure SetColor(AValue: TColor);
public
constructor Create(aId : integer);virtual;
property Color : TColor read FColor write SetColor;
property Id : integer read FId;
End;
implementation
{ TDrawingExtraData }
procedure TDrawingExtraData.SetColor(AValue: TColor);
begin
if FColor=AValue then Exit;
FColor:=AValue;
end;
constructor TDrawingExtraData.Create(aId: integer);
begin
FId:=aId;
FColor:=clRed;
end;
end.

197
components/lazmapviewer/source/mvgeonames.pas Normal file
View File

@ -0,0 +1,197 @@
{ Map Viewer Geolocation Engine for geonames.org
Copyright (C) 2011 Maciej Kaczkowski / keit.co
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvGeoNames;
interface
uses
SysUtils, Classes, StrUtils,
mvTypes, mvDownloadEngine;
type
TNameFoundEvent = procedure (const AName: string; const ADescr: String;
const ALoc: TRealPoint) of object;
TStringArray = array of string;
{ TMVGeoNames }
TMVGeoNames = class(TComponent)
private
FLocationName: string;
FOnNameFound: TNameFoundEvent;
function RemoveTag(const str: String): TStringArray;
public
function DoSearch(dl : TCustomDownloadEngine): TRealPoint;
published
property LocationName: string read FLocationName write FLocationName;
property OnNameFound : TNameFoundEvent read FOnNameFound write FOnNameFound;
end;
procedure Register;
implementation
function CleanLocationName(x: string): string;
var
i: Integer;
begin
Result := '';
for i := 1 to Length(x) do
begin
if x[i] in ['A'..'Z', 'a'..'z', '0'..'9'] then
Result := Result + x[i]
else
Result := Result + '+'
end;
end;
{ TMVGeoNames }
Type
TResRec = record
Name : String;
Descr : String;
Loc : TRealPoint;
End;
procedure Register;
begin
RegisterComponents('Maps',[TMVGeoNames]);
end;
function TMVGeoNames.RemoveTag(Const str : String) : TStringArray;
var iStart,iEnd,i : Integer;
tmp : String;
lst : TStringList;
Begin
SetLength(Result,0);
tmp:=StringReplace(str,'<br>',#13,[rfReplaceall]);
tmp:=StringReplace(tmp,'&nbsp;',' ',[rfReplaceall]);
tmp:=StringReplace(tmp,' ',' ',[rfReplaceall]);
repeat
iEnd:=-1;
iStart:=pos('<',tmp);
if iStart>0 then
Begin
iEnd:=posEx('>',tmp,iStart);
if iEnd>0 then
Begin
tmp:=copy(tmp,1,iStart-1)+copy(tmp,iEnd+1,length(tmp));
end;
end;
until iEnd<=0;
lst:=TStringList.Create;
try
lst.Text:=tmp;
SetLEngth(Result,lst.Count);
For i:=0 to pred(lst.Count) do
Result[i]:=trim(lst[i]);
finally
freeAndNil(lst);
end;
end;
function TMVGeoNames.DoSearch(dl: TCustomDownloadEngine): TRealPoint;
const
LAT_ID = '<span class="latitude">';
LONG_ID = '<span class="longitude">';
var
s: string;
function gs(id: string;Start : integer): string;
var
i: Integer;
ln: Integer;
begin
Result := '';
ln := Length(s);
i := PosEx(id, s,start) + Length(id);
while (s[i] <> '<') and (i < ln) do
begin
if s[i] = '.' then
Result := Result + DecimalSeparator
else
Result := Result + s[i];
Inc(i);
end;
end;
var
m: TMemoryStream;
iRes,i : integer;
lstRes : Array of TResRec;
iStartDescr : integer;
lst : TStringArray;
begin
m := TMemoryStream.Create;
try
dl.DownloadFile('http://www.geonames.org/search.html?q='+
CleanLocationName(FLocationName), m);
m.Position := 0;
SetLength(s, m.Size);
m.Read(s[1], m.Size);
finally
m.Free;
end;
Result.Lon := 0;
Result.Lat:=0;
SetLength(lstRes,0);
iRes:=Pos('<span class="geo"',s);
while (iRes>0) do
Begin
SetLength(lstRes,length(lstRes)+1);
lstRes[high(lstRes)].Loc.Lon:=strtofloat(gs(LONG_ID,iRes));
lstRes[high(lstRes)].Loc.Lat:=strtofloat(gs(LAT_ID,iRes));
iStartDescr:=RPosex('<td>',s,iRes);
if iStartDescr>0 then
Begin
lst:=RemoveTag(Copy(s,iStartDescr,iRes-iStartDescr));
if length(lst)>0 then
lstRes[high(lstRes)].Name:=lst[0];
lstRes[high(lstRes)].Descr:='';
For i:=1 to high(lst) do
lstRes[high(lstRes)].Descr+=lst[i];
end;
Result.Lon += lstRes[high(lstRes)].Loc.Lon;
Result.Lat += lstRes[high(lstRes)].Loc.Lat;
iRes:=PosEx('<span class="geo"',s,iRes+17);
End;
if length(lstRes)>0 then
Begin
if length(lstRes)>1 then
begin
Result.Lon := Result.Lon/length(lstRes);
Result.Lat := Result.Lat/length(lstRes);
end;
if Assigned(FOnNameFound) then
For iRes:=low(lstRes) to high(lstRes) do
Begin
FOnNameFound(lstRes[iRes].Name,lstRes[iRes].Descr,lstRes[iRes].Loc);
end;
End;
end;
end.

728
components/lazmapviewer/source/mvgpsobj.pas Normal file
View File

@ -0,0 +1,728 @@
{ Map Viewer - basic gps object
Copyright (C) 2014 ti_dic@hotmail.com
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}unit mvgpsobj;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,fgl,mvtypes,contnrs,syncobjs;
const
NO_ELE = -10000000;
NO_DATE = 0;
type
TIdArray = Array of integer;
{ TGPSObj }
TGPSObj = Class
private
BBoxSet : Boolean;
FBoundingBox : TRealArea;
FExtraData: TObject;
FName: String;
FIdOwner : integer;
function GetBoundingBox: TRealArea;
procedure SetBoundingBox(AValue: TRealArea);
procedure SetExtraData(AValue: TObject);
public
destructor Destroy;override;
Procedure GetArea(out Area : TRealArea);virtual;abstract;
property Name : String read FName write FName;
property ExtraData : TObject read FExtraData write SetExtraData;
property BoundingBox : TRealArea read GetBoundingBox write SetBoundingBox;
end;
TGPSObjarray = Array of TGPSObj;
{ TGPSPoint }
TGPSPoint = Class(TGPSObj)
private
FRealPt : TRealPoint;
FEle : Double;
FDateTime : TDateTime;
function GetLat: Double;
function GetLon: Double;
public
Procedure GetArea(out Area : TRealArea);override;
Function HasEle : boolean;
Function HasDateTime : Boolean;
Function DistanceInKmFrom(OtherPt : TGPSPoint;UseEle : boolean=true) : double;
constructor Create(ALon,ALat : double;AEle : double=NO_ELE;ADateTime : TDateTime=NO_DATE);
Class function CreateFrom(aPt : TRealPoint) : TGPSPoint;
property Lon : Double read GetLon;
property Lat : Double read GetLat;
property Ele : double read FEle;
property DateTime : TDateTime read FDateTime;
property RealPoint : TRealPoint read FRealPt;
end;
TGPSPointList = specialize TFPGObjectList<TGPSPoint>;
{ TGPSTrack }
TGPSTrack = Class(TGPSObj)
private
FDateTime: TDateTime;
FPoints : TGPSPointList;
function GetDateTime: TDateTime;
public
constructor Create;
destructor Destroy;override;
Procedure GetArea(out Area : TRealArea);override;
Function TrackLengthInKm(UseEle : Boolean=true) : double;
property Points : TGPSPointList read FPoints;
property DateTime : TDateTime read GetDateTime write FDateTime;
end;
TGPSObjList_ = specialize TFPGObjectList<TGPSObj>;
{ TGPSObjList }
TGPSObjList = class(TGPSObjList_)
private
FRef : TObject;
public
Destructor Destroy;override;
end;
{ TGPSObjectList }
TModifiedEvent = procedure (Sender : TObject;objs : TGPSObjList;Adding : boolean) of object;
TGPSObjectList = Class(TGPSObj)
private
Crit:TCriticalSection;
FPending : TObjectList;
FRefCount : integer;
FOnModified: TModifiedEvent;
FUpdating : integer;
FItems : TGPSObjList;
function Getcount: integer;
protected
Procedure _Delete(Idx : Integer;out DelLst : TGPSObjList);
Procedure FreePending;
Procedure DecRef;
procedure Lock;
procedure UnLock;
procedure CallModified(lst : TGPSObjList;Adding : boolean);
property Items : TGPSObjList read FItems;
procedure IdsToObj(const Ids : TIdArray;out objs : TGPSObjArray;IdOwner : integer);
public
Procedure GetArea(out Area : TRealArea);override;
function GetObjectsInArea(const Area: TRealArea): TGPSObjList;
constructor Create;
destructor Destroy;override;
Procedure Clear(OwnedBy : integer);
procedure ClearExcept(OwnedBy : integer;const ExceptLst : TIdArray;out Notfound : TIdArray);
function GetIdsArea(const Ids : TIdArray;IdOwner : integer) : TRealArea;
function Add(aItem : TGpsObj;IdOwner : integer) : integer;
Procedure DeleteById(const Ids : Array of integer);
Procedure BeginUpdate;
Procedure EndUpdate;
property Count : integer read Getcount;
property OnModified : TModifiedEvent read FOnModified write FOnModified;
end;
function hasIntersectArea(const Area1 : TRealArea;const Area2 : TRealArea) : boolean;
function IntersectArea(const Area1 : TRealArea;const Area2 : TRealArea) : TRealArea;
function PtInsideArea(const aPoint : TRealPoint;const Area : TRealArea) : boolean;
Function AreaInsideArea(const AreaIn : TRealArea;const AreaOut : TRealArea) : boolean;
Procedure ExtendArea(var AreaToExtend : TRealArea;Const Area : TRealArea);
Function GetAreaOf(objs : TGPSObjList) : TRealArea;
implementation
uses mvextradata;
function hasIntersectArea(const Area1: TRealArea; const Area2: TRealArea): boolean;
begin
Result:=(Area1.TopLeft.Lon<=Area2.BottomRight.Lon) and (Area1.BottomRight.Lon>=Area2.TopLeft.Lon) and
(Area1.TopLeft.Lat>=Area2.BottomRight.Lat) and (Area1.BottomRight.Lat<=Area2.TopLeft.Lat);
end;
function IntersectArea(const Area1: TRealArea; const Area2: TRealArea
): TRealArea;
begin
Result:=Area1;
if Result.TopLeft.Lon<Area2.topLeft.Lon then
Result.TopLeft.Lon:=Area2.topLeft.Lon;
if Result.TopLeft.Lat>Area2.topLeft.Lat then
Result.TopLeft.Lat:=Area2.topLeft.Lat;
if Result.BottomRight.Lon>Area2.BottomRight.Lon then
Result.BottomRight.Lon:=Area2.BottomRight.Lon;
if Result.BottomRight.Lat<Area2.BottomRight.Lat then
Result.BottomRight.Lat:=Area2.BottomRight.Lat;
end;
function PtInsideArea(const aPoint: TRealPoint; const Area: TRealArea): boolean;
begin
Result:=(Area.TopLeft.Lon<=aPoint.Lon) and (Area.BottomRight.Lon>=aPoint.Lon) and
(Area.TopLeft.Lat>=aPoint.Lat) and (Area.BottomRight.Lat<=aPoint.Lat);
end;
function AreaInsideArea(const AreaIn: TRealArea; const AreaOut: TRealArea
): boolean;
begin
Result:=(AreaIn.TopLeft.Lon>=AreaOut.TopLeft.Lon) and (AreaIn.BottomRight.Lon<=AreaOut.BottomRight.Lon) and
(AreaOut.TopLeft.Lat>=AreaIn.TopLeft.Lat) and (AreaOut.BottomRight.Lat<=AreaIn.BottomRight.Lat);
end;
procedure ExtendArea(var AreaToExtend: TRealArea; const Area: TRealArea);
begin
if AreaToExtend.TopLeft.Lon>Area.TopLeft.Lon then
AreaToExtend.TopLeft.Lon:=Area.TopLeft.Lon;
if AreaToExtend.BottomRight.Lon<Area.BottomRight.Lon then
AreaToExtend.BottomRight.Lon:=Area.BottomRight.Lon;
if AreaToExtend.TopLeft.Lat<Area.TopLeft.Lat then
AreaToExtend.TopLeft.Lat:=Area.TopLeft.Lat;
if AreaToExtend.BottomRight.Lat>Area.BottomRight.Lat then
AreaToExtend.BottomRight.Lat:=Area.BottomRight.Lat;
end;
function GetAreaOf(objs: TGPSObjList): TRealArea;
var i : integer;
begin
Result.TopLeft.Lon:=0;
Result.TopLeft.Lat:=0;
Result.BottomRight.Lon:=0;
Result.BottomRight.Lat:=0;
if Objs.Count>0 then
Begin
Result:=Objs[0].BoundingBox;
For i:=1 to pred(Objs.Count) do
ExtendArea(Result,Objs[i].BoundingBox);
end;
end;
{ TGPSObjList }
destructor TGPSObjList.Destroy;
begin
if Assigned(FRef) then
TGPSObjectList(FRef).DecRef;
inherited Destroy;
end;
{ TGPSObj }
procedure TGPSObj.SetExtraData(AValue: TObject);
begin
if FExtraData=AValue then Exit;
if Assigned(FExtraData) then
FreeAndNil(FExtraData);
FExtraData:=AValue;
end;
function TGPSObj.GetBoundingBox: TRealArea;
begin
if not(BBoxSet) then
Begin
GetArea(FBoundingBox);
BBoxSet:=true;
end;
Result:=FBoundingBox;
end;
procedure TGPSObj.SetBoundingBox(AValue: TRealArea);
begin
FBoundingBox:=AValue;
BBoxSet:=true;
end;
destructor TGPSObj.Destroy;
begin
FreeAndNil(FExtraData);
inherited Destroy;
end;
{ TGPSObjectList }
function TGPSObjectList.Getcount: integer;
begin
Result:=FItems.Count
end;
procedure TGPSObjectList._Delete(Idx: Integer; out DelLst: TGPSObjList);
var Item : TGpsObj;
begin
Lock;
Try
if not(Assigned(DelLst)) then
Begin
DelLst:=TGpsObjList.Create(False);
DelLst.FRef:=Self;
inc(FRefCount);
end;
if not Assigned(FPending) then
FPending:=TObjectList.Create(true);
Item:=Items.Extract(Items[Idx]);
FPending.Add(Item);
finally
UnLock;
end;
DelLst.Add(Item);
end;
procedure TGPSObjectList.FreePending;
begin
if Assigned(FPending) then
Begin
Lock;
Try
FreeAndNil(FPending);
finally
UnLock;
end;
end;
end;
procedure TGPSObjectList.DecRef;
begin
FRefCount-=1;
if FRefCount=0 then
FreePending;
end;
procedure TGPSObjectList.Lock;
begin
if Assigned(Crit) then
Crit.Enter;
end;
procedure TGPSObjectList.UnLock;
begin
if Assigned(Crit) then
Crit.Leave;
end;
procedure TGPSObjectList.CallModified(lst: TGPSObjList; Adding: boolean);
begin
if (FUpdating=0) and Assigned(FOnModified) then
FOnModified(self,lst,Adding)
else
lst.Free;
end;
procedure TGPSObjectList.IdsToObj(const Ids: TIdArray; out objs: TGPSObjArray;IdOwner : integer);
function ToSelect(aId : integer) : boolean;
var i : integer;
begin
result:=false;
for i:=low(Ids) to high(Ids) do
if Ids[i]=aId then
begin
result:=true;
break;
end;
end;
var i,nb : integer;
begin
SetLength(objs,length(Ids));
nb:=0;
Lock;
Try
for i:=0 to pred(FItems.Count) do
begin
if (IdOwner=0) or (IdOwner=FItems[i].FIdOwner) then
if Assigned(FItems[i].ExtraData) and FItems[i].ExtraData.InheritsFrom(TDrawingExtraData) then
Begin
if ToSelect(TDrawingExtraData(FItems[i].ExtraData).Id) then
Begin
objs[nb]:=FItems[i];
nb+=1;
end;
end;
end;
finally
Unlock;
end;
SetLength(objs,nb);
end;
procedure TGPSObjectList.GetArea(out Area: TRealArea);
var i : integer;
ptArea : TRealArea;
begin
Area.BottomRight.lon:=0;
Area.BottomRight.lat:=0;
Area.TopLeft.lon:=0;
Area.TopLeft.lat:=0;
Lock;
Try
if Items.Count>0 then
begin
Area:=Items[0].BoundingBox;
for i:=1 to pred(Items.Count) do
begin
ptArea:=Items[i].BoundingBox;
ExtendArea(Area,ptArea);
end;
end;
finally
Unlock;
end;
end;
function TGPSObjectList.GetObjectsInArea(const Area: TRealArea): TGPSObjList;
var i : integer;
ItemArea : TRealArea;
begin
Result:=TGPSObjList.Create(false);
Lock;
Try
Inc(FRefCount);
For i:=0 to pred(Items.Count) do
Begin
ItemArea:=Items[i].BoundingBox;
If hasIntersectArea(Area,ItemArea) then
Result.Add(Items[i]);
end;
if Result.Count>0 then
Result.FRef:=Self
else
Dec(FRefCount);
finally
Unlock;
end;
end;
constructor TGPSObjectList.Create;
begin
Crit:=TCriticalSection.Create;
FItems := TGPSObjList.Create(true);
end;
destructor TGPSObjectList.Destroy;
begin
inherited Destroy;
FreeAndNil(FItems);
FreeAndNil(FPending);
FreeAndNil(Crit);
end;
procedure TGPSObjectList.Clear(OwnedBy: integer);
var i : integer;
DelObj : TGPSObjList;
begin
DelObj:=nil;
Lock;
try
For i:=pred(FItems.Count) downto 0 do
if (OwnedBy=0) or (FItems[i].FIdOwner=OwnedBy) then
_Delete(i,DelObj);
finally
Unlock;
end;
if Assigned(DelObj) then
CallModified(DelObj,false);
end;
procedure TGPSObjectList.ClearExcept(OwnedBy: integer;
const ExceptLst : TIdArray; out Notfound: TIdArray);
var Found : TIdArray;
function ToDel(aIt : TGPsObj) : boolean;
var i,Id : integer;
Begin
if (aIt.ExtraData=nil) or not(aIt.ExtraData.InheritsFrom(TDrawingExtraData)) then
result:=true
else
Begin
Result:=true;
Id:=TDrawingExtraData(aIt.ExtraData).Id;
for i:=low(ExceptLst) to high(ExceptLst) do
if Id=ExceptLst[i] then
begin
result:=false;
SetLength(Found,Length(Found)+1);
Found[high(Found)]:=Id;
exit;
end;
end;
end;
var i,j : integer;
IsFound : boolean;
DelLst : TGPSObjList;
begin
DelLst:=nil;
SetLength(NotFound,0);
SetLength(Found,0);
Lock;
try
For i:=pred(FItems.Count) downto 0 do
begin
if (FItems[i].FIdOwner=OwnedBy) or (OwnedBy=0) then
Begin
if ToDel(FItems[i]) then
_Delete(i,DelLst);
end;
end;
finally
Unlock;
end;
For i:=low(ExceptLst) to high(ExceptLst) do
Begin
IsFound:=false;
for j:=low(Found) to high(Found) do
if Found[j]=ExceptLst[i] then
begin
IsFound:=true;
break;
end;
if not(IsFound) then
Begin
SetLength(NotFound,length(NotFound)+1);
NotFound[high(NotFound)]:=ExceptLst[i];
end;
end;
if Assigned(DelLst) then
CallModified(DelLst,false);
end;
function TGPSObjectList.GetIdsArea(const Ids: TIdArray;IdOwner : integer): TRealArea;
var Objs : TGPSObjarray;
i : integer;
begin
Result.BottomRight.Lat:=0;
Result.BottomRight.Lon:=0;
Result.TopLeft.Lat:=0;
Result.TopLeft.Lon:=0;
Lock;
Try
IdsToObj(Ids,Objs,IdOwner);
if length(Objs)>0 then
Begin
Result:=Objs[0].BoundingBox;
for i:=succ(low(Objs)) to high(Objs) do
begin
ExtendArea(Result,Objs[i].BoundingBox);
end;
end;
finally
Unlock;
end;
end;
function TGPSObjectList.Add(aItem: TGpsObj;IdOwner : integer): integer;
var mList : TGPSObjList;
begin
aItem.FIdOwner:=IdOwner;
Lock;
try
Result:=Items.Add(aItem);
mList:=TGPSObjList.Create(false);
mList.Add(aItem);
inc(FRefCount);
mList.FRef:=Self;
finally
Unlock;
end;
CallModified(mList,true);
end;
procedure TGPSObjectList.DeleteById(const Ids: array of integer);
function ToDelete(const AId : integer) : Boolean;
var i : integer;
begin
result:=false;
For i:=low(Ids) to high(Ids) do
if Ids[i]=AId then
Begin
result:=true;
exit;
end;
end;
var Extr : TDrawingExtraData;
i : integer;
DelLst : TGPSObjList;
begin
DelLst:=nil;
Lock;
try
For i:=Pred(Items.Count) downto 0 do
Begin
if Assigned(Items[i].ExtraData) then
Begin
if Items[i].ExtraData.InheritsFrom(TDrawingExtraData) then
Begin
Extr := TDrawingExtraData(Items[i]);
if ToDelete(Extr.Id) then
_Delete(i,DelLst);
end;
end;
end;
finally
Unlock;
end;
if Assigned(DelLst) then
end;
procedure TGPSObjectList.BeginUpdate;
begin
inc(FUpdating);
end;
procedure TGPSObjectList.EndUpdate;
begin
if FUpdating>0 then
begin
Dec(FUpdating);
if FUpdating=0 then
CallModified(nil,true);
end;
end;
{ TGPSTrack }
function TGPSTrack.GetDateTime: TDateTime;
begin
if FDateTime=0 then
Begin
if FPoints.Count>0 then
FDateTime:=FPoints[0].DateTime;
end;
Result:=FDateTime;
end;
constructor TGPSTrack.Create;
begin
FPoints := TGPSPointList.Create(true);
end;
destructor TGPSTrack.Destroy;
begin
inherited Destroy;
FreeAndNil(FPoints);
end;
procedure TGPSTrack.GetArea(out Area: TRealArea);
var i : integer;
ptArea : TRealArea;
begin
Area.BottomRight.lon:=0;
Area.BottomRight.lat:=0;
Area.TopLeft.lon:=0;
Area.TopLeft.lat:=0;
if FPoints.Count>0 then
begin
Area:=FPoints[0].BoundingBox;
for i:=1 to pred(FPoints.Count) do
begin
ptArea:=FPoints[i].BoundingBox;
ExtendArea(Area,ptArea);
end;
end;
end;
function TGPSTrack.TrackLengthInKm(UseEle: Boolean): double;
var i : integer;
begin
Result:=0;
For i:=1 to pred(FPoints.Count) do
begin
result+=FPoints[i].DistanceInKmFrom(FPoints[pred(i)],UseEle);
end;
end;
{ TGPSPoint }
function TGPSPoint.GetLat: Double;
begin
result:=FRealPt.Lat;
end;
function TGPSPoint.GetLon: Double;
begin
result:=FRealPt.Lon;
end;
procedure TGPSPoint.GetArea(out Area: TRealArea);
begin
Area.TopLeft:=FRealPt;
Area.BottomRight:=FRealPt;
end;
function TGPSPoint.HasEle: boolean;
begin
Result:=FEle<>NO_ELE;
end;
function TGPSPoint.HasDateTime: Boolean;
begin
Result:=FDateTime<>NO_DATE;
end;
function TGPSPoint.DistanceInKmFrom(OtherPt: TGPSPoint;UseEle : boolean): double;
var a : double;
lat1,lat2,lon1,lon2,t1,t2,t3,t4,t5,rad_dist : double;
DiffEle :Double;
begin
a := PI / 180;
lat1 := lat * a;
lat2 := OtherPt.lat * a;
lon1 := lon * a;
lon2 := OtherPt.lon * a;
t1 := sin(lat1) * sin(lat2);
t2 := cos(lat1) * cos(lat2);
t3 := cos(lon1 - lon2);
t4 := t2 * t3;
t5 := t1 + t4;
rad_dist := arctan(-t5/sqrt(-t5 * t5 +1)) + 2 * arctan(1);
result := (rad_dist * 3437.74677 * 1.1508) * 1.6093470878864446;
if UseEle and (FEle<>OtherPt.FEle) then
if (HasEle) and (OtherPt.HasEle) then
Begin
//FEle is assumed in Metter
DiffEle:=(FEle-OtherPt.Ele)/1000;
Result:=sqrt(DiffEle*DiffEle+result*result);
end;
end;
constructor TGPSPoint.Create(ALon, ALat: double; AEle: double;
ADateTime: TDateTime);
begin
FRealPt.Lon:=ALon;
FRealPt.Lat:=ALat;
FEle:=AEle;
FDateTime:=ADateTime;
end;
class function TGPSPoint.CreateFrom(aPt: TRealPoint): TGPSPoint;
begin
Result:=Create(aPt.Lon,aPt.Lat);
end;
end.

803
components/lazmapviewer/source/mvjobqueue.pas Normal file
View File

@ -0,0 +1,803 @@
{
Multi thread Queue,witch can be used without multi-thread (c) 2014 ti_dic
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvJobQueue;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,syncobjs,contnrs,forms;
const ALL_TASK_COMPLETED = -1;
NO_MORE_TASK = 0;
type
TjobQueue = class;
{ TJob }
TJob = Class
private
FLauncher : TObject;
FCancelled : Boolean;
FName: String;
protected
Queue : TJobQueue;
procedure DoCancel;virtual;
Procedure WaitForResultOf(aJob : TJob);
Procedure EnterCriticalSection;
procedure LeaveCriticalSection;
//should be called inside critical section
function pGetTask : integer;virtual;
procedure pTaskStarted(aTask: integer);virtual;abstract;
procedure pTaskEnded(aTask : integer;aExcept : Exception);virtual;abstract;
property Launcher : TObject read FLauncher;
public
procedure ExecuteTask(aTask : integer;FromWaiting : boolean);virtual;abstract;
function Running : boolean;virtual;abstract;
procedure Cancel;
property Cancelled : boolean read FCancelled;
property Name : String read FName write FName;
end;
TJobArray = Array of TJob;
{ TjobQueue }
TjobQueue = Class
private
FMainThreadId : TThreadID;
FOnIdle: TNotifyEvent;
waitings : TStringList;
FNbThread : integer;
TerminatedThread : integer;
FSect : TCriticalSection;
FEvent,TerminateEvent : TEvent;
FUseThreads: boolean;
Threads : TList;
Jobs : TObjectList;
procedure pJobCompleted(var aJob: TJob);
procedure SetUseThreads(AValue: boolean);
procedure ClearWaitings;
protected
Procedure InitThreads;
Procedure FreeThreads;
Procedure EnterCriticalSection;
procedure LeaveCriticalSection;
Procedure DoWaiting(E : Exception;TaskId : integer);
//Should be called inside critical section
procedure pAddWaiting(aJob : TJob;aTask : integer;JobId : String);
procedure pTaskStarted(aJob : TJob;aTask : integer);
procedure pTaskEnded(var aJob : TJob;aTask : integer;aExcept : Exception);
function pGetJob(out TaskId : integer;out Restart : boolean) : TJob;
function pFindJobByName(const aName : string;ByLauncher: TObject) : TJobArray;
procedure pNotifyWaitings(aJob : TJob);
Function IsMainThread : boolean;
public
constructor Create(NbThread : integer = 5);
destructor Destroy;override;
procedure QueueAsyncCall(const AMethod: TDataEvent; Data: PtrInt);
procedure QueueSyncCall(const AMethod: TDataEvent; Data: PtrInt);
property UseThreads : boolean read FUseThreads write SetUseThreads;
Procedure AddJob(aJob : TJob;Launcher : TObject);
function AddUniqueJob(aJob : TJob;Launcher : TObject) : boolean;
function CancelAllJob(ByLauncher: TObject) : TJobArray;
function CancelJobByName(aJobName : String;ByLauncher: TObject) : boolean;
Procedure WaitForTerminate(const lstJob : TJobArray);
Procedure WaitAllJobTerminated(ByLauncher: TObject);
property OnIdle : TNotifyEvent read FOnIdle write FOnIdle;
end;
implementation
const
WAIT_TIME = 3000;
TERMINATE_TIMEOUT = 1000;
Type
{ EWaiting }
EWaiting = Class(Exception)
private
FLauncher : TJob;
FNewJob : TJob;
public
constructor Create(launcher : TJob;NewJob : TJob);
end;
{ TRestartTask }
TRestartTask = Class(TJob)
private
FStarted : Boolean;
FJob : TJob;
FTask : integer;
protected
procedure DoCancel;override;
procedure pTaskStarted(aTask: integer);override;
procedure pTaskEnded(aTask : integer;aExcept : Exception);override;
function pGetTask : integer;override;
public
constructor Create(aJob : TJob;aTask : integer);
procedure ExecuteTask(aTask : integer;FromWaiting : boolean);override;
function Running : boolean;override;
end;
{ TQueueThread }
TQueueThread = Class(TThread)
private
MyQueue : TJobqueue;
function ProcessJob : boolean;
public
constructor Create(aQueue: TJobQueue);
procedure Execute; override;
end;
{ TRestartTask }
procedure TRestartTask.DoCancel;
begin
FJob.Cancel;
end;
procedure TRestartTask.pTaskStarted(aTask: integer);
begin
FStarted := true;
end;
procedure TRestartTask.pTaskEnded(aTask: integer; aExcept: Exception);
begin
Queue.pTaskEnded(FJob,FTask,aExcept);
end;
function TRestartTask.pGetTask: integer;
begin
if FStarted then
Result:=inherited pGetTask
else
Result:=1;
end;
constructor TRestartTask.Create(aJob: TJob; aTask: integer);
begin
FJob:=aJob;
FTask:=aTask;
end;
procedure TRestartTask.ExecuteTask(aTask: integer; FromWaiting: boolean);
begin
FJob.ExecuteTask(FTask,true);
end;
function TRestartTask.Running: boolean;
begin
Result:=Fstarted;
end;
{ EWaiting }
constructor EWaiting.Create(launcher: TJob; NewJob: TJob);
begin
FLauncher:=launcher;
FNewJob:=NewJob;
end;
{ TQueueThread }
function TQueueThread.ProcessJob : boolean;
var aJob : TJob;
TaskId : Integer;
Procedure SetRes(e : Exception);
Begin
MyQueue.EnterCriticalSection;
Try
MyQueue.pTaskEnded(aJob,TaskId,nil);
finally
MyQueue.LeaveCriticalSection;
end;
end;
var RestartTask : boolean;
SomeJob : Boolean;
begin
Result:=false;
Repeat
SomeJob:=false;
MyQueue.EnterCriticalSection;
Try
result:=result or (MyQueue.Jobs.Count>0);
aJob:=MyQueue.pGetJob(TaskId,RestartTask);
if Assigned(aJob) then
Begin
if TaskId=ALL_TASK_COMPLETED then
begin
MyQueue.pJobCompleted(aJob);
SomeJob := true;
end
else
Begin
MyQueue.FEvent.ResetEvent;
if not(RestartTask) then
MyQueue.pTaskStarted(aJob,TaskId);
end;
end;
finally
MyQueue.LeaveCriticalSection;
end;
if Assigned(aJob) then
Begin
SomeJob:=true;
Try
aJob.ExecuteTask(TaskId,RestartTask);
SetRes(nil);
Except
on e : Exception do
if e.InheritsFrom(EWaiting) then
MyQueue.DoWaiting(e,TaskId)
else
SetRes(e);
end;
end;
until SomeJob=false;
end;
constructor TQueueThread.Create(aQueue: TJobQueue);
begin
MyQueue := aQueue;
inherited Create(False);
end;
procedure TQueueThread.Execute;
var wRes : TWaitResult;
begin
while not Terminated do
begin
wRes:=MyQueue.FEvent.WaitFor(WAIT_TIME);
if not(Terminated) then
Begin
if not(ProcessJob) then
if wRes=wrTimeout then
if Assigned(MyQueue.OnIdle) then
MyQueue.OnIdle(self);
end;
end;
MyQueue.EnterCriticalSection;
Try
inc(MyQueue.TerminatedThread);
if Assigned(MyQueue.TerminateEvent) then
if MyQueue.TerminatedThread=MyQueue.Threads.count then
MyQueue.TerminateEvent.SetEvent;
finally
MyQueue.LeaveCriticalSection;
end;
end;
{ TjobQueue }
procedure TjobQueue.SetUseThreads(AValue: boolean);
begin
if FUseThreads=AValue then
Exit;
FUseThreads:=AValue;
if Fusethreads then
InitThreads
else
FreeThreads;
end;
procedure TjobQueue.ClearWaitings;
var i : integer;
begin
For i:=0 to pred(Waitings.count) do
Waitings.Objects[i].Free;
Waitings.Clear;
end;
procedure TjobQueue.InitThreads;
var i : integer;
begin
Jobs:=TObjectList.Create(true);
Threads:=TObjectList.Create(true);
FEvent:=TEvent.Create(nil,true,false,'');
FSect:=TCriticalSection.Create;
TerminatedThread := 0;
For i:=1 to FNbThread do
Threads.Add(TQueueThread.Create(self));
end;
procedure TjobQueue.FreeThreads;
var i : integer;
begin
if Assigned(Threads) then
Begin
TerminateEvent := TEvent.Create(nil,false,false,'');
Try
FEvent.SetEvent;
TerminatedThread:=0;
For i:=0 to pred(Threads.Count) do
TQueueThread(Threads[i]).Terminate;
TerminateEvent.WaitFor(TERMINATE_TIMEOUT);
FreeAndNil(FSect);
FreeAndNil(FEvent);
FreeAndNil(Threads);
finally
FreeAndNil(TerminateEvent);
end;
FreeAndNil(Jobs);
end;
end;
procedure TjobQueue.EnterCriticalSection;
begin
if Assigned(FSect) and UseThreads then
FSect.Enter;
end;
procedure TjobQueue.LeaveCriticalSection;
begin
if Assigned(FSect) and UseThreads then
FSect.Leave;
end;
procedure TjobQueue.DoWaiting(E : Exception;TaskId : integer);
var we : EWaiting;
begin
EnterCriticalSection;
try
we:=EWaiting(e);
pAddWaiting(we.FLauncher,TaskId,we.FNewJob.Name);
AddUniqueJob(we.FNewJob,we.FLauncher.FLauncher);
finally
LeaveCriticalSection;
end;
end;
procedure TjobQueue.pAddWaiting(aJob: TJob; aTask: integer; JobId: String);
begin
Waitings.AddObject(JobId,TRestartTask.Create(aJob,aTask));
end;
procedure TjobQueue.pTaskStarted(aJob: TJob; aTask: integer);
begin
aJob.pTaskStarted(aTask);
end;
procedure TjobQueue.pJobCompleted(var aJob: TJob);
Begin
pNotifyWaitings(aJob);
if FuseThreads then
Begin
Jobs.Remove(aJob);
aJob:=nil;
end
else
FreeAndNil(aJob);
end;
procedure TjobQueue.pTaskEnded(var aJob: TJob; aTask: integer; aExcept: Exception);
begin
aJob.pTaskEnded(aTask,aExcept);
if (aJob.pGetTask=ALL_TASK_COMPLETED) then
Begin
pJobcompleted(aJob);
end;
end;
function TjobQueue.pGetJob(out TaskId : integer;out Restart : boolean): TJob;
var iJob : integer;
aJob : TJob;
begin
Restart:=false;
Result:=nil;
For iJob:=0 to pred(Jobs.Count) do
Begin
aJob:=TJob(Jobs[iJob]);
if aJob.InheritsFrom(TRestartTask) then
Begin
result:=TRestartTask(aJob).FJob;
TaskId:=TRestartTask(aJob).FTask;
Restart:=true;
Jobs.Delete(iJob);
Exit;
end;
TaskId:=aJob.pGetTask;
if (TaskId>NO_MORE_TASK) or (TaskId=ALL_TASK_COMPLETED) then
Begin
Result:=aJob;
Exit;
end;
end;
if not(assigned(result)) then
TaskId:=NO_MORE_TASK;
end;
function TjobQueue.pFindJobByName(const aName: string;ByLauncher: TObject): TJobArray;
var iRes,i : integer;
begin
SetLength(result,Jobs.count);
iRes:=0;
For i:=0 to pred(Jobs.Count) do
Begin
if TJob(Jobs[i]).Name=aName then
begin
if (ByLauncher=nil) or (TJob(Jobs[i]).FLauncher=ByLauncher) then
Begin
Result[iRes]:=TJob(Jobs[i]);
inc(iRes);
end;
end;
end;
SetLength(result,iRes);
end;
procedure TjobQueue.pNotifyWaitings(aJob: TJob);
var JobId : String;
ObjRestart : TRestartTask;
idx : integer;
begin
JobId:=aJob.Name;
Repeat
idx:=waitings.IndexOf(JobId);
if idx<>-1 then
Begin
ObjRestart:=TRestartTask(waitings.Objects[idx]);
waitings.Delete(idx);
Jobs.Add(ObjRestart);
end;
until idx=-1;
end;
function TjobQueue.IsMainThread: boolean;
begin
Result:=GetCurrentThreadId=FMainThreadID;
end;
constructor TjobQueue.Create(NbThread: integer);
begin
waitings:=TStringList.create;
FNbThread:=NbThread;
FMainThreadId:=GetCurrentThreadId;
end;
destructor TjobQueue.Destroy;
begin
FreeThreads;
ClearWaitings;
FreeAndNil(Waitings);
inherited;
end;
procedure TjobQueue.QueueAsyncCall(const AMethod: TDataEvent; Data: PtrInt);
begin
if UseThreads then
Application.QueueAsyncCall(aMethod,Data)
else
AMethod(Data);
end;
Type
{ TSyncCallData }
TSyncCallData = Class
private
FMethod : TDataEvent;
FData : PtrInt;
public
Constructor Create(AMethod : TDataEvent;AData : PtrInt);
Procedure SyncCall;
End;
{ TSyncCallData }
constructor TSyncCallData.Create(AMethod: TDataEvent; AData: PtrInt);
begin
FMethod:=AMethod;
FData:=AData;
end;
procedure TSyncCallData.SyncCall;
begin
FMethod(FData);
end;
procedure TjobQueue.QueueSyncCall(const AMethod: TDataEvent; Data: PtrInt);
var tmp : TSyncCallData;
begin
tmp := TSyncCallData.Create(AMethod,Data);
Try
TThread.Synchronize(nil,@tmp.SyncCall);
finally
tmp.free;
end;
end;
procedure TjobQueue.AddJob(aJob: TJob;Launcher : TObject);
var TaskId : Integer;
restart : boolean;
begin
aJob.FLauncher:=Launcher;
aJob.Queue:=self;
if Usethreads then
Begin
EnterCriticalSection;
Try
Jobs.add(aJob);
finally
LeaveCriticalSection;
end;
FEvent.SetEvent;
end
Else
Begin
Try
Repeat
TaskId:=aJob.pGetTask;
restart:=false;
if TaskId>NO_MORE_TASK then
Begin
pTaskStarted(aJob,TaskId);
Try
aJob.ExecuteTask(TaskId,restart);
pTaskEnded(aJob,TaskId,nil);
except
on e : Exception do
Begin
if not(e.InheritsFrom(EWaiting)) then
pTaskEnded(aJob,TaskId,e)
else
DoWaiting(e,TaskId);
end;
end;
end;
if not(Assigned(aJob)) then
TaskId:=ALL_TASK_COMPLETED;
until TaskId=ALL_TASK_COMPLETED;
finally
aJob.Free;
end;
end;
end;
function TjobQueue.AddUniqueJob(aJob: TJob; Launcher: TObject): boolean;
var lst : TJobArray;
begin
Result:=true;
if FUseThreads then
Begin
aJob.Queue:=self;
aJob.FLauncher:=Launcher;
EnterCriticalSection;
Try
lst:=pFindJobByName(aJob.Name,Launcher);
if length(lst)=0 then
Jobs.add(aJob)
else
Result:=false;
finally
LeaveCriticalSection;
end;
FEvent.SetEvent;;
end
Else
AddJob(aJob,Launcher);
end;
function TjobQueue.CancelAllJob(ByLauncher: TObject) : TJobArray;
var i,iJob : integer;
begin
SetLength(Result,0);
if FUseThreads then
Begin
EnterCriticalSection;
Try
SetLEngth(Result,Jobs.Count);
iJob:=0;
For i:=pred(Jobs.Count) downto 0 do
Begin
if (ByLauncher=nil) or (TJob(Jobs[i]).FLauncher=ByLauncher) then
Begin
TJob(Jobs[i]).Cancel;
Result[iJob]:=TJob(Jobs[i]);
iJob+=1;
End;
End;
SetLength(Result,iJob);
finally
LeaveCriticalSection;
end;
end;
end;
function TjobQueue.CancelJobByName(aJobName: String;ByLauncher: TObject) : boolean;
var lst : TJobArray;
i : integer;
begin
Result:=false;
if FUseThreads then
Begin
EnterCriticalSection;
Try
lst:=pFindJobByName(aJobName,ByLauncher);
For i:=low(lst) to high(lst) do
Begin
result:=true;
lst[i].Cancel;
End;
finally
LeaveCriticalSection;
end;
end;
end;
procedure TjobQueue.WaitForTerminate(const lstJob: TJobArray);
var OneFound : Boolean;
i : integer;
mThread : Boolean;
TimeOut : integer;
begin
TimeOut:=0;
mThread:=IsMainThread;
if FUseThreads then
Begin
repeat
OneFound:=False;
EnterCriticalSection;
Try
For i:=low(lstJob) to high(lstJob) do
Begin
if Jobs.IndexOf(lstJob[i])<>-1 then
Begin
OneFound:=True;
break;
end;
end;
finally
LeaveCriticalSection;
end;
if OneFound and (TimeOut>200) then
Raise Exception.Create('TimeOut');
if mThread then
Application.ProcessMessages;
if OneFound then
Sleep(100);
Inc(TimeOut);
until not(OneFound);
end;
end;
procedure TjobQueue.WaitAllJobTerminated(ByLauncher: TObject);
var OneFound : boolean;
i : integer;
TimeOut : integer;
mThread : Boolean;
Procedure CheckTimeOut;
Begin
if TimeOut>200 then
Raise Exception.Create('TimeOut');
if mThread then
Application.ProcessMessages;
sleep(100);
inc(TimeOut);
end;
begin
TimeOut:=0;
if FUseThreads then
Begin
mThread:=IsMainThread;
if ByLauncher=nil then
Begin
While Jobs.Count>0 do
CheckTimeOut;
end
else
Begin
repeat
OneFound:=False;
EnterCriticalSection;
Try
For i:=0 to pred(Jobs.Count) do
Begin
if TJob(Jobs[i]).FLauncher=ByLauncher then
Begin
OneFound:=True;
break;
end;
end;
finally
LeaveCriticalSection;
end;
if OneFound then
CheckTimeOut;
until not(OneFound);
end;
end;
end;
{ TjobQueue }
procedure TJob.Cancel;
var lst : Array of TRestartTask;
i,idx : integer;
begin
Queue.EnterCriticalSection;
Try
FCancelled := true;
if (Name<>'') and (Queue.waitings.count>0) then
Begin
SetLength(lst,0);
Repeat
idx:=Queue.waitings.IndexOf(Name);
if idx<>-1 then
Begin
SetLength(lst,length(lst)+1);
lst[high(lst)]:=TRestartTask(Queue.waitings.Objects[idx]);
Queue.waitings.Delete(idx);
end;
until idx=-1;
For i:=low(lst) to high(lst) do
Begin
lst[i].Cancel;
lst[i].pTaskEnded(1,nil);
lst[i].Free;
end;
end;
DoCancel;
finally
Queue.LeaveCriticalSection;
end;
end;
procedure TJob.DoCancel;
begin
end;
function TJob.pGetTask: integer;
begin
result:=ALL_TASK_COMPLETED;
end;
procedure TJob.WaitForResultOf(aJob: TJob);
begin
Raise EWaiting.Create(self,aJob);
end;
procedure TJob.EnterCriticalSection;
begin
Queue.EnterCriticalSection;
end;
procedure TJob.LeaveCriticalSection;
begin
Queue.LeaveCriticalSection;
end;
end.

130
components/lazmapviewer/source/mvjobs.pas Normal file
View File

@ -0,0 +1,130 @@
{
basics jobs for multi-threading(c) 2014 ti_dic
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvJobs;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,mvJobQueue;
type
{ TSimpleJob }
//job with only one task
TSimpleJob = class(TJob)
private
FRunning,FEnded : boolean;
protected
function pGetTask : integer;override;
procedure pTaskStarted(aTask: integer);override;
procedure pTaskEnded(aTask : integer;aExcept : Exception);override;
public
function Running : boolean;override;
end;
TJobProc = Procedure (Data : TObject;Job : TJob) of object;
{ TEventJob }
//job with only one task (callback an event)
TEventJob = Class(TSimpleJob)
private
FData : TObject;
FTask : TJobProc;
FOwnData : Boolean;
public
constructor Create(aEvent : TJobProc;Data : TObject;OwnData : Boolean;JobName : String='');virtual;
procedure ExecuteTask(aTask : integer;FromWaiting : boolean);override;
destructor Destroy;override;
end;
implementation
{ TEventJob }
constructor TEventJob.Create(aEvent: TJobProc; Data: TObject;
OwnData: Boolean;JobName : String='');
begin
Name:=JobName;
FTask:=aEvent;
if Assigned(Data) or OwnData then
Begin
FData:=Data;
FOwnData:=OwnData;
end
else
Begin
FOwnData:=false;
FData:=self;
end;
end;
procedure TEventJob.ExecuteTask(aTask : integer;FromWaiting : boolean);
begin
if Assigned(FTask) then
FTask(FData,self);
end;
destructor TEventJob.Destroy;
begin
if FOwnData then
if FData<>self then
FData.Free;
inherited Destroy;
end;
{ TSimpleJob }
function TSimpleJob.pGetTask: integer;
begin
if FRunning or Cancelled then
Begin
if not FRunning then
Result := ALL_TASK_COMPLETED
else
Result:=NO_MORE_TASK
end
else
if FEnded then
Result := ALL_TASK_COMPLETED
else
Result:=1;
end;
procedure TSimpleJob.pTaskStarted(aTask: integer);
begin
FEnded:=false;
FRunning:=True;
end;
procedure TSimpleJob.pTaskEnded(aTask: integer; aExcept: Exception);
begin
FEnded:=True;
FRunning:=False;
end;
function TSimpleJob.Running: boolean;
begin
Result:=FRunning;
end;
end.

172
components/lazmapviewer/source/mvmapprovider.pas Normal file
View File

@ -0,0 +1,172 @@
{
(c) 2014 ti_dic
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvMapProvider;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
Type
{ TTileId }
TTileId = record
X,Y : int64;
Z : integer;
end;
TGetSvrStr = Function (id : integer) : string of object;
TGetValStr = Function (const Tile : TTileId) : String of object;
{ TMapProvider }
TMapProvider = Class
private
FLayer : integer;
idServer : Array of Integer;
FName : String;
FUrl : Array of string;
FNbSvr : Array of integer;
FGetSvrStr : Array of TGetSvrStr;
FGetXStr : Array of TGetValStr;
FGetYStr : Array of TGetValStr;
FGetZStr : Array of TGetValStr;
FMinZoom : Array of integer;
FMaxZoom : Array of integer;
function getLayerCount: integer;
procedure SetLayer(AValue: integer);
public
constructor Create(aName : String);
destructor Destroy; override;
procedure AddURL(Url: String; NbSvr: integer;aMinZoom : integer;aMaxZoom : integer; GetSvrStr: TGetSvrStr; GetXStr: TGetValStr; GetYStr: TGetValStr; GetZStr: TGetValStr);
procedure GetZoomInfos(out zMin:integer;out zMax : integer);
Function GetUrlForTile(id : TTileId) : String;
property Name : String read FName;
property LayerCount : integer read getLayerCount;
property Layer : integer read FLayer write SetLayer;
end;
implementation
{ TMapProvider }
function TMapProvider.getLayerCount: integer;
begin
Result:=length(FUrl);
end;
procedure TMapProvider.SetLayer(AValue: integer);
begin
if FLayer=AValue then Exit;
if (aValue<low(FUrl)) and (aValue>high(FUrl)) then
Begin
Raise Exception.create('bad Layer');
end;
FLayer:=AValue;
end;
constructor TMapProvider.Create(aName: String);
begin
FName:=aName;
end;
destructor TMapProvider.Destroy;
begin
Finalize(idServer);
Finalize(FName);
Finalize(FUrl);
Finalize(FNbSvr);
Finalize(FGetSvrStr);
Finalize(FGetXStr);
Finalize(FGetYStr);
Finalize(FGetZStr);
Finalize(FMinZoom);
Finalize(FMaxZoom);
inherited;
end;
procedure TMapProvider.AddURL(Url: String; NbSvr: integer;
aMinZoom : integer;aMaxZoom : integer;
GetSvrStr: TGetSvrStr; GetXStr: TGetValStr; GetYStr: TGetValStr;
GetZStr: TGetValStr);
var nb : integer;
begin
nb:=length(FUrl)+1;
SetLength(IdServer,nb);
SetLength(FUrl,nb);
SetLength(FNbSvr,nb);
SetLength(FGetSvrStr,nb);
SetLength(FGetXStr,nb);
SetLength(FGetYStr,nb);
SetLength(FGetZStr,nb);
SetLength(FMinZoom,nb);
SetLength(FMaxZoom,nb);
nb:=high(FUrl);
FUrl[nb]:=Url;
FNbSvr[nb]:=NbSvr;
FMinZoom[nb]:=aMinZoom;
FMaxZoom[nb]:=aMaxZoom;
FGetSvrStr[nb]:=GetSvrStr;
FGetXStr[nb]:=GetXStr;
FGetYStr[nb]:=GetYStr;
FGetZStr[nb]:=GetZStr;
FLayer:=low(FUrl);
end;
procedure TMapProvider.GetZoomInfos(out zMin: integer; out zMax: integer);
begin
zMin:=FMinZoom[layer];
zMax:=FMaxZoom[layer];
end;
function TMapProvider.GetUrlForTile(id: TTileId): String;
var i : integer;
XVal,yVal,zVal,SvrVal : String;
idsvr: integer;
begin
Result:='';
i:=layer;
if (i>high(idServer)) or (i<low(idServer)) or (FNbSvr[i]=0) then
exit;
idsvr:=idServer[i] mod FNbSvr[i];
idServer[i]+=1;
SvrVal:=inttostr(idsvr);
XVal:=inttostr(id.X);
YVal:=inttostr(id.Y);
ZVal:=inttostr(id.Z);
if Assigned(FGetSvrStr[i]) then
SvrVal:=FGetSvrStr[i](idsvr);
if Assigned(FGetXStr[i]) then
XVal:=FGetXStr[i](id);
if Assigned(FGetYStr[i]) then
YVal:=FGetYStr[i](id);
if Assigned(FGetZStr[i]) then
ZVal:=FGetZStr[i](id);
Result:=StringReplace(FUrl[i],'%serv%',SvrVal,[rfreplaceall]);
Result:=StringReplace(Result,'%x%',XVal,[rfreplaceall]);
Result:=StringReplace(Result,'%y%',YVal,[rfreplaceall]);
Result:=StringReplace(Result,'%z%',ZVal,[rfreplaceall]);
end;
end.

834
components/lazmapviewer/source/mvmapviewer.pas Normal file
View File

@ -0,0 +1,834 @@
{ (c) 2014 ti_dic MapViewer component for lazarus
Parts of this component are based on :
Map Viewer Copyright (C) 2011 Maciej Kaczkowski / keit.co
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvmapviewer;
{$MODE objfpc}{$H+}
// Activate one of the following defines
{$DEFINE USE_LAZINTFIMAGE}
{.$DEFINE USE_RGBGRAPHICS} // NOTE: This needs package "rgb_graphics" in requirements
// Make sure that one of the USE_XXXX defines is active. Default is USE_LAZINTFIMAGE
{$IFNDEF USE_RGBGRAPHICS}{$IFNDEF USE_LAZINTFIMAGE}{$DEFINE USE_LAZINTFIMAGES}{$ENDIF}{$ENDIF}
{$IFDEF USE_RGBGRAPHICS}{$IFDEF USE_LAZINTFIMAGE}{$UNDEF USE_RGBGRAPHICS}{$ENDIF}{$ENDIF}
interface
uses
Classes, SysUtils, Controls, Graphics, IntfGraphics,
{$IFDEF USE_RGBGRAPHICS}RGBGraphics,{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}FPCanvas,{$ENDIF}
MvTypes, MvGPSObj, MvEngine, MvMapProvider, MVDLESynapse;
Type
{ TMapView }
TMapView = class(TCustomControl)
private
dl : TMVDESynapse;
FEngine : TMapViewerEngine;
{$IFDEF USE_RGBGRAPHICS}
Buffer : TRGB32Bitmap;
{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}
Buffer: TLazIntfImage;
BufferCanvas: TFPCustomCanvas;
{$ENDIF}
FActive: boolean;
FGPSItems: TGPSObjectList;
FInactiveColor: TColor;
FPOIImage: TBitmap;
procedure CallAsyncInvalidate;
procedure DoAsyncInvalidate(Data: PtrInt);
procedure DrawObjects(const TileId: TTileId; aLeft, aTop, aRight,aBottom: integer);
procedure DrawPt(const Area: TRealArea;aPOI: TGPSPoint);
procedure DrawTrk(const Area: TRealArea;trk: TGPSTrack);
function GetCacheOnDisk: boolean;
function GetCachePath: String;
function GetCenter: TRealPoint;
function GetMapProvider: String;
function GetOnCenterMove: TNotifyEvent;
function GetOnChange: TNotifyEvent;
function GetOnZoomChange: TNotifyEvent;
function GetUseThreads: boolean;
function GetZoom: integer;
procedure SetActive(AValue: boolean);
procedure SetCacheOnDisk(AValue: boolean);
procedure SetCachePath(AValue: String);
procedure SetCenter(AValue: TRealPoint);
procedure SetInactiveColor(AValue: TColor);
procedure SetMapProvider(AValue: String);
procedure SetOnCenterMove(AValue: TNotifyEvent);
procedure SetOnChange(AValue: TNotifyEvent);
procedure SetOnZoomChange(AValue: TNotifyEvent);
procedure SetUseThreads(AValue: boolean);
procedure SetZoom(AValue: integer);
protected
AsyncInvalidate : boolean;
procedure ActivateEngine;
{$IFDEF USE_LAZINTFIMAGE}
procedure CreateLazIntfImageAndCanvas(out ABuffer: TLazIntfImage;
out ACanvas: TFPCustomCanvas; AWidth, AHeight: Integer);
{$ENDIF}
procedure DblClick; override;
Procedure DoDrawTile(const TileId: TTileId; X,Y: integer; TileImg: TLazIntfImage);
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 Paint; override;
procedure OnGPSItemsModified(Sender: TObject; objs: TGPSObjList;Adding : boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ClearBuffer;
procedure GetMapProviders(lstProviders : TStrings);
function GetVisibleArea: TRealArea;
function LonLatToScreen(aPt: TRealPoint): TPoint;
function ScreenToLonLat(aPt: TPoint): TRealPoint;
procedure CenterOnObj(obj: TGPSObj);
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 FGPSItems;
published
property Active: boolean read FActive write SetActive;
property Align;
property CacheOnDisk: boolean read GetCacheOnDisk write SetCacheOnDisk;
property CachePath: String read GetCachePath write SetCachePath;
property Height default 150;
property InactiveColor: TColor read FInactiveColor write SetInactiveColor;
property MapProvider: String read GetMapProvider write SetMapProvider;
property POIImage: TBitmap read FPOIImage write FPOIImage;
property PopupMenu;
property UseThreads: boolean read GetUseThreads write SetUseThreads;
property Width default 150;
property Zoom: integer read GetZoom write SetZoom;
property OnCenterMove: TNotifyEvent read GetOnCenterMove write SetOnCenterMove;
property OnZoomChange: TNotifyEvent read GetOnZoomChange write SetOnZoomChange;
property OnChange: TNotifyEvent Read GetOnChange write SetOnChange;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
end;
procedure Register;
implementation
uses
{$IFDEF USE_LAZINTFIMAGE}
Math, FPImgCanv, FPImage, LCLVersion,
{$ENDIF}
GraphType, mvjobqueue, mvextradata, LResources;
procedure Register;
begin
{$I mvmapviewer_icon.lrs}
RegisterComponents('Maps',[TMapView]);
end;
{$IFDEF USE_LAZINTFIMAGE}
// Workaround for http://mantis.freepascal.org/view.php?id=27144
procedure CopyPixels(ASource, ADest: TLazIntfImage;
XDst: Integer = 0; YDst: Integer = 0;
AlphaMask: Boolean = False; AlphaTreshold: Word = 0);
var
SrcHasMask, DstHasMask: Boolean;
x, y, xStart, yStart, xStop, yStop: Integer;
c: TFPColor;
SrcRawImage, DestRawImage: TRawImage;
begin
ASource.GetRawImage(SrcRawImage);
ADest.GetRawImage(DestRawImage);
if DestRawImage.Description.IsEqual(SrcRawImage.Description) and (XDst = 0) and (YDst = 0) then
begin
// same description -> copy
if DestRawImage.Data <> nil then
System.Move(SrcRawImage.Data^, DestRawImage.Data^, DestRawImage.DataSize);
if DestRawImage.Mask <> nil then
System.Move(SrcRawImage.Mask^, DestRawImage.Mask^, DestRawImage.MaskSize);
Exit;
end;
// copy pixels
XStart := IfThen(XDst < 0, -XDst, 0);
YStart := IfThen(YDst < 0, -YDst, 0);
XStop := IfThen(ADest.Width - XDst < ASource.Width, ADest.Width - XDst, ASource.Width) - 1;
YStop := IfTHen(ADest.Height - YDst < ASource.Height, ADest.Height - YDst, ASource.Height) - 1;
SrcHasMask := SrcRawImage.Description.MaskBitsPerPixel > 0;
DstHasMask := DestRawImage.Description.MaskBitsPerPixel > 0;
if DstHasMask then begin
for y:= yStart to yStop do
for x:=xStart to xStop do
ADest.Masked[x+XDst,y+YDst] := SrcHasMask and ASource.Masked[x,y];
end;
for y:=yStart to yStop do
for x:=xStart to xStop do
begin
c := ASource.Colors[x,y];
if not DstHasMask and SrcHasMask and (c.alpha = $FFFF) then // copy mask to alpha channel
if ASource.Masked[x,y] then
c.alpha := 0;
ADest.Colors[x+XDst,y+YDst] := c;
if AlphaMask and (c.alpha < AlphaTreshold) then
ADest.Masked[x+XDst,y+YDst] := True;
end;
end;
{$ENDIF}
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;
{ 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];
if Obj.InheritsFrom(TGPSTrack) then
Begin
Viewer.DrawTrk(FArea,TGPSTrack(Obj));
End;
if Obj.InheritsFrom(TGPSPoint) then
Begin
Viewer.DrawPt(FArea,TGPSPoint(Obj));
end;
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);
if not(Cancelled) then
Viewer.CallAsyncInvalidate;
end;
{ TMapView }
procedure TMapView.SetActive(AValue: boolean);
begin
if FActive=AValue then Exit;
FActive:=AValue;
if FActive then
ActivateEngine
else
Engine.Active:=false;
end;
function TMapView.GetCacheOnDisk: boolean;
begin
Result:=Engine.CacheOnDisk;
end;
function TMapView.GetCachePath: String;
begin
Result:=Engine.CachePath;
end;
function TMapView.GetCenter: TRealPoint;
begin
Result:=Engine.Center;
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;
procedure TMapView.SetCacheOnDisk(AValue: boolean);
begin
Engine.CacheOnDisk:=AValue;
end;
procedure TMapView.SetCachePath(AValue: String);
begin
Engine.CachePath:=CachePath;
end;
procedure TMapView.SetCenter(AValue: TRealPoint);
begin
Engine.Center:=AValue;
end;
procedure TMapView.SetInactiveColor(AValue: TColor);
begin
if FInactiveColor=AValue then Exit;
FInactiveColor:=AValue;
if not(IsActive) then
invalidate;
end;
procedure TMapView.ActivateEngine;
begin
Engine.SetSize(ClientWidth,ClientHeight);
if IsActive then
Engine.Active:=true
else
Engine.Active:=false;
end;
procedure TMapView.SetMapProvider(AValue: String);
begin
Engine.MapProvider:=AValue;
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.SetUseThreads(AValue: boolean);
begin
Engine.UseThreads:=aValue;
end;
procedure TMapView.SetZoom(AValue: integer);
begin
Engine.Zoom:=AValue;
end;
function TMapView.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
begin
Result:=inherited DoMouseWheel(Shift, WheelDelta, MousePos);
if IsActive then
Engine.MouseWheel(self,Shift,WheelDelta,MousePos,Result);
end;
procedure TMapView.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
if IsActive then
Engine.MouseDown(self,Button,Shift,X,Y);
end;
procedure TMapView.MouseUp(Button: TMouseButton; Shift: TShiftState;
X: Integer; Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if IsActive then
Engine.MouseUp(self,Button,Shift,X,Y);
end;
procedure TMapView.MouseMove(Shift: TShiftState; X: Integer; Y: Integer);
var aPt : TPoint;
begin
inherited MouseMove(Shift, X, Y);
if IsActive then
Engine.MouseMove(self,Shift,X,Y);
end;
procedure TMapView.DblClick;
begin
inherited DblClick;
if IsActive then
Engine.DblClick(self);
end;
procedure TMapView.DoOnResize;
begin
inherited DoOnResize;
//cancel all rendering threads
Engine.CancelCurrentDrawing;
FreeAndNil(Buffer);
{$IFDEF USE_RGBGRAPHICS}
Buffer := TRGB32Bitmap.Create(ClientWidth,ClientHeight);
{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}
BufferCanvas.Free;
CreateLazIntfImageAndCanvas(Buffer, BufferCanvas, ClientWidth, ClientHeight);
{$ENDIF}
if IsActive then
Engine.SetSize(ClientWidth, ClientHeight);
end;
procedure TMapView.Paint;
var
bmp: TBitmap;
begin
inherited Paint;
if IsActive and Assigned(Buffer) then
begin
{$IFDEF USE_RGBGRAPHICS}
Buffer.Canvas.DrawTo(Canvas,0,0);
{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}
bmp := TBitmap.Create;
try
bmp.SetSize(Buffer.Width, Buffer.Height);
bmp.LoadFromIntfImage(Buffer);
Canvas.Draw(0, 0, bmp);
finally
bmp.Free;
end;
{$ENDIF}
end
else
begin
Canvas.Brush.Color:=InactiveColor;
Canvas.Brush.Style:=bsSolid;
Canvas.FillRect(0,0,ClientWidth,ClientHeight);
end;
end;
procedure TMapView.OnGPSItemsModified(Sender: TObject; objs: TGPSObjList;
Adding: boolean);
var Area,ObjArea,vArea : TRealArea;
begin
if Adding and assigned(Objs) then
Begin
ObjArea:=GetAreaOf(Objs);
vArea:=GetVisibleArea;
if hasIntersectArea(ObjArea,vArea) then
Begin
Area:=IntersectArea(ObjArea,vArea);
Engine.Jobqueue.AddJob(TDrawObjJob.Create(self,Objs,Area),Engine);
end
else
objs.Free;
end
else
Begin
Engine.Redraw;
Objs.free;
end;
end;
procedure TMapView.DrawTrk(const Area : TRealArea;trk : TGPSTrack);
var Old,New : TPoint;
i : integer;
aPt : TRealPoint;
LastInside,IsInside : boolean;
trkColor : TColor;
Begin
if trk.Points.Count>0 then
Begin
trkColor:=clRed;
if trk.ExtraData<>nil then
Begin
if trk.ExtraData.inheritsFrom(TDrawingExtraData) then
trkColor:=TDrawingExtraData(trk.ExtraData).Color;
end;
LastInside:=false;
For i:=0 to pred(trk.Points.Count) do
Begin
aPt:=trk.Points[i].RealPoint;
IsInside:=PtInsideArea(aPt,Area);
if IsInside or LastInside then
Begin
New:=Engine.LonLatToScreen(aPt);
if i>0 then
Begin
if not(LastInside) then
Old:=Engine.LonLatToScreen(trk.Points[pred(i)].RealPoint);
{$IFDEF USE_RGBGRAPHICS}
Buffer.canvas.OutlineColor := trkColor;
Buffer.canvas.Line(Old.X,Old.y,New.X,New.Y);
{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}
BufferCanvas.Pen.FPColor := TColorToFPColor(trkColor);
BufferCanvas.Line(Old.X, Old.Y, New.X, New.Y);
{$ENDIF}
end;
Old:=New;
LastInside:=IsInside;
end;
end;
end;
end;
procedure TMapView.DrawPt(const Area: TRealArea; aPOI: TGPSPoint);
var
PT : TPoint;
PtColor : TColor;
begin
Pt:=Engine.LonLatToScreen(aPOI.RealPoint);
PtColor:=clRed;
if aPOI.ExtraData<>nil then
Begin
if aPOI.ExtraData.inheritsFrom(TDrawingExtraData) then
PtColor:=TDrawingExtraData(aPOI.ExtraData).Color;
end;
{$IFDEF USE_RGBGRAPHICS}
Buffer.canvas.OutlineColor:=ptColor;
Buffer.canvas.Line(Pt.X,Pt.y-5,Pt.X,Pt.Y+5);
Buffer.canvas.Line(Pt.X-5,Pt.y,Pt.X+5,Pt.Y);
{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}
BufferCanvas.Pen.FPColor := TColorToFPColor(ptColor);
BufferCanvas.Line(Pt.X, Pt.Y-5, Pt.X, Pt.Y+5);
BufferCanvas.Line(Pt.X-5, Pt.Y, Pt.X+5, Pt.Y);
{$ENDIF}
// Buffer.Draw();
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 aPt : TPoint;
Area : TRealArea;
lst : TGPSObjList;
i : integer;
trk : TGPSTrack;
begin
aPt.X:=aLeft;
aPt.Y:=aTop;
Area.TopLeft:=Engine.ScreenToLonLat(aPt);
aPt.X:=aRight;
aPt.Y:=aBottom;
Area.BottomRight:=Engine.ScreenToLonLat(aPt);
if GPSItems.count>0 then
begin
lst:=GPSItems.GetObjectsInArea(Area);
if lst.Count>0 then
Engine.Jobqueue.AddJob(TDrawObjJob.Create(self,lst,Area),Engine)
else
begin
freeAndNil(Lst);
CallAsyncInvalidate;
end;
end
Else
CallAsyncInvalidate;
end;
procedure TMapView.DoAsyncInvalidate(Data: PtrInt);
Begin
Invalidate;
AsyncInvalidate:=false;
end;
procedure TMapView.DoDrawTile(const TileId: TTileId; X, Y: integer;
TileImg: TLazIntfImage);
var
{$IFDEF USE_RGBGRAPHICS}
temp : TRGB32Bitmap;
ri : TRawImage;
BuffLaz : TLazIntfImage;
{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}
temp: TBitmap;
{$ENDIF}
begin
if Assigned(Buffer) then
begin
if Assigned(TileImg) then
Begin
{$IFDEF USE_RGBGRAPHICS}
if (X>=0) and (Y>=0) then //http://mantis.freepascal.org/view.php?id=27144
begin
ri.Init;
ri.Description.Init_BPP32_R8G8B8A8_BIO_TTB(Buffer.Width,Buffer.Height);
ri.Data:=Buffer.Pixels;
BuffLaz := TLazIntfImage.Create(ri,false);
try
BuffLaz.CopyPixels(TileImg,X,y);
ri.Init;
finally
FreeandNil(BuffLaz);
end;
end
else
begin
//i think it take more memory then the previous method but work in all case
temp:=TRGB32Bitmap.CreateFromLazIntfImage(TileImg);
try
Buffer.Draw(X,Y,temp);
finally
FreeAndNil(Temp);
end;
end;
{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}
{$IF LCL_FULLVERSION < 1090000}
{ Workaround for //http://mantis.freepascal.org/view.php?id=27144 }
CopyPixels(TileImg, Buffer, X, Y);
{$ELSE}
Buffer.CopyPixels(TileImg, X, Y);
{$IFEND}
{$ENDIF}
end
else
{$IFDEF USE_RGBGRAPHICS}
Buffer.Canvas.FillRect(X,Y,X+TILE_SIZE,Y+TILE_SIZE);
{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}
begin
BufferCanvas.Brush.FPColor := ColWhite;
BufferCanvas.FillRect(X, Y, X + TILE_SIZE, Y + TILE_SIZE);
end;
{$ENDIF}
end;
DrawObjects(TileId,X,Y,X+TILE_SIZE,Y+TILE_SIZE);
end;
function TMapView.IsActive: Boolean;
begin
if not(csDesigning in ComponentState) then
Result:=FActive
else
Result:=false;
end;
constructor TMapView.Create(AOwner: TComponent);
begin
Active := false;
FGPSItems := TGPSObjectList.Create;
FGPSItems.OnModified := @OnGPSItemsModified;
FInactiveColor := clWhite;
FEngine := TMapViewerEngine.Create(self);
dl := TMVDESynapse.Create(self);
{$IFDEF USE_RGBGRAPHICS}
Buffer := TRGB32Bitmap.Create(Width,Height);
{$ENDIF}
{$IFDEF USE_LAZINTFIMAGE}
CreateLazIntfImageAndCanvas(Buffer, BufferCanvas, Width, Height);
{$ENDIF}
Engine.CachePath := 'cache/';
Engine.CacheOnDisk := true;
Engine.OnDrawTile := @DoDrawTile;
Engine.DrawTitleInGuiThread := false;
Engine.DownloadEngine := dl;
inherited Create(AOwner);
Width := 150;
Height := 150;
end;
destructor TMapView.Destroy;
begin
{$IFDEF USE_LAZINTFIMAGE}
BufferCanvas.Free;
{$ENDIF}
Buffer.Free;
inherited Destroy;
FreeAndNil(FGPSItems);
end;
{$IFDEF USE_LAZINTFIMAGE}
procedure TMapView.CreateLazIntfImageAndCanvas(out ABuffer: TLazIntfImage;
out ACanvas: TFPCustomCanvas; AWidth, AHeight: Integer);
var
rawImg: TRawImage;
begin
rawImg.Init;
rawImg.Description.Init_BPP24_B8G8R8_BIO_TTB(AWidth, AHeight);
rawImg.CreateData(True);
ABuffer := TLazIntfImage.Create(rawImg, true);
ACanvas := TFPImageCanvas.Create(ABuffer);
ACanvas.Brush.FPColor := colWhite;
ACanvas.FillRect(0, 0, AWidth, AHeight);
end;
{$ENDIF}
function TMapView.ScreenToLonLat(aPt: TPoint): TRealPoint;
begin
Result:=Engine.ScreenToLonLat(aPt);
end;
function TMapView.LonLatToScreen(aPt: TRealPoint): TPoint;
begin
Result:=LonLatToScreen(aPt);
end;
procedure TMapView.GetMapProviders(lstProviders: TStrings);
begin
Engine.GetMapProviders(lstProviders);
end;
procedure TMapView.WaitEndOfRendering;
begin
Engine.Jobqueue.WaitAllJobTerminated(Engine);
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;
function TMapView.GetVisibleArea: TRealArea;
var aPt : TPoint;
begin
aPt.X:=0;
aPt.Y:=0;
Result.TopLeft:=Engine.ScreenToLonLat(aPt);
aPt.X:=Width;
aPt.Y:=Height;
Result.BottomRight:=Engine.ScreenToLonLat(aPt);;
end;
procedure TMapView.ClearBuffer;
begin
{$IFDEF USE_LAZINTFIMAGE}
CreateLazIntfImageAndCanvas(Buffer, BufferCanvas, ClientWidth, ClientHeight);
{$ENDIF}
end;
end.

54
components/lazmapviewer/source/mvmapviewer_icon.lrs Normal file
View File

@ -0,0 +1,54 @@
LazarusResources.Add('TMapViewer','PNG',[
#137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0
+#0#0#6'bKGD'#0#255#0#255#0#255#160#189#167#147#0#0#0#9'pHYs'#0#0#11#19#0#0#11
+#19#1#0#154#156#24#0#0#4#127'IDATH'#199#165#150#217'n'#20'W'#16#134#191':'
+#231#244'63'#158#5#143#205'"c'#2'Al'#10#216'(w'#201#3'D'#17#202#211'"'#30'!'
+#185#9#138#29#161#128#162#160#16#2'x'#155#177#199#179#245#222#231#228'b'#198
+'c'#6'B'#20'%u'#211']'#173#174#255'T'#213#255'Wu'#203#147#221']'#231#128'@k'
+#186#181#144#184'(8I2.D!'#183#186'-'#146#188#228#217#209#9#255#213#12'@d4_^Y'
+'C'#128#131'I'#194#141'N'#11#17#8#148'b'#130#163#29#250#12#179#28#231#254#30
+#196#211#138#210':'#220#252#5#1#206'^U'#206#193#221#181#14'''IF'#229#28'F'#9
+'u_'#19#25#141#3'V'#195#128#245'z'#180#0#215'"l4'#235#212'<'#131#3#26#190'G'
+#168'5'#206'9D'#160'r'#142#235#157'&v'#30#160'.'#173#212'8'#156'$'#212'='#195
+'o'#199'C'#154#129#191#148#169#18#225#221'x'#186#240'WB'#15#173#20'qQ"'#192
+'8/'#24#229#197','#198#205#18'8'#156'&'#172'F!'#14'PqQ'#2'0'#201#11#250'q'
+#202'(/'#22#167'3/'#213'('#189#240'Gi'#193#171#193'h'#225#203#156#191#11#181
+'`'#6'('#130#167#132'['#221#22#129'V'#168#202'Z'#140#18#6'i'#142#18#225'Eo'
+#192#193'4Y'#0#148#214#145#149#229#194#183#206#161'E'#150'8'#168'y'#134'A'
+#146#1'p'#183#219#230#254#250#5#4#161#29#5#168'n=$'#173'*.7"'#30'\\E'#139'0L'
+'s'#206'0Jk'#153#230#179'v'#156'U'#20'z'#134#134#167#169#220#140#216#180',Y'
+#171'G<'#188#212#165#19#5#243#170#133';'#171'mLd'#12#235#181#136#131'I'#140
+#136#176'^'#143#24'e9'#130#144#219#138#231#189#1#145#167#201'+;S'#140#18#238
+#172'D'#248#190#225'('#171#168#156#165#27#133'h'#165'(m'#181'T'#153'u'#14#181
+'V'#11#17#129#180#172'(l'#133'u'#142#172#156']'#159#190#235'1'#201#11#174'4'
+#235#139#128#205'f'#157#17#130'C'#209#9#3'6'#155#13'j'#158'!'#208#138#186#231
+'}$a'#5#240#250't'#194#222'8'#230#179'V'#147#154'g'#200'+'#203#211#189#30#213
+#156#236'W'#131'1F)'#2#163#169'{'#30#135#211#148#10#136#188's'#242#229#3'^'
+#150#6#237#222'Z'#135'v'#24#160#4#174#183'W8I2FY'#190#164#148#150'o'#176#14
+#178#170#226'j='#164'H'#19'"'#223#195'ZK^'#20'h'#165'p'#206#225#251'>UU!"h'
+#173'QY'#158'3'#156'N'#241'e'#150#237'/'#189#1'Z'#132#15#135#246'8'#201#216
+'l5 '#137'I'#135'C'#252'0b'#146#164#140#227#152' '#8#240'<'#15#223#247#24#156
+#158'.'#218'y|2'#192#4#190'O'#0#164'E'#193'8+8'#142'S*'#231'x'#191'`'#7'l'
+#214'B'#142#147#140#161#21'"'#17#252#188'@'#128#195#211'1'#27#8'e'#158'S'#139
+'B:'#237'6'#206'9'#242#162#160#211'n'#161#242'|'#222#10#165'x'#222#31','#250
+#254#161#137'o'#184#216#136'X'#247'=\'#16'r'#146#21#216'$'#230#218'j'#135#192
+'h'#162'0$'#207#11'D'#4#17'!'#240'}'#140'R'#24#223#247#249#225#205#1'F'#169
+'On'#196'P'#11'+'#206#18#26'M'''#10#184#28#248'T'#214'2'#173','#206'A?I'#209
+#2'W'#218'-'#246#143#250'xF'#211'\Y!'#1#204#143'{='#174#214'Cz'#147#148'J'#9
+'JdiU `'#16'|'#223''''#142#19#130#192#167#172','#198'h'#166#195'1Q'#24#240'v'
+#18'SX'#199#197'f'#131'WY'#201#26#138#184#223#231'u'#238'PYY'#241#199'8%'#21
+#184#223#237#240#237#214#22#29'-'#139'V='#218#218'&'#174','#189'i'#194#149
+#171'7X]'#223' '#201'RF'#163'1wn'#222#225#218#198'u'#190'y'#176#133#0'?'#237
+#247#177#206'1*J'#250'N'#211'4z&S'#165#4'_+TY'#0#240#213#253'-^'#190'}'#197
+#205#141#235#11#146#183'n'#223#227#241#206#14#235#129#199#198#213#207'y'#251
+#231'K'#0#30#239#236#160'Dx'#180#189#205#147#221']'#0#10#231#232#134#1#158
+#146#217#1#206'9'#226#162#196#206''''#241#244'x'#159#246#234'e'#190#255#245#5
+'_'#223#190#187#180#186#147#185#190#178't'#182#220#190'{'#248#16'`'#1#14'PT'
+#150#189'I|>hg'#193#207#142#6#179#224','#227#224#232#29';'#251#253'%'#178#31
+'mo/'#238#27#245#8#128#159#127#127#201#155#209#228'c'#213#1#155#173#198#249#1
+#239'[YYv'#143'z'#31'=?'#203#242#209#246'6'#251#201'L'#222'o'#134#227'O'#174
+#137#192'h'#228#201#238#238'B2'#13#223#227#139#245#14'/z'#167#12#223'['#21#31
+'Ze'#29'J'#132'O'#224#158#15#168's'#231#21#184#249#242'z'#209';'#229'4'#203
+#249#167'X'#173#228'_'#253'Q'#136#8'K'#211'U'#148#21'qQ.'#190'X"'#194#255#181
+#191#0#1#137#23#12'Mu'#148#1#0#0#0#0'IEND'#174'B`'#130
]);

54
components/lazmapviewer/source/mvtypes.pas Normal file
View File

@ -0,0 +1,54 @@
{
(c) 2014 ti_dic
Parts of this component are based on :
Map Viewer Copyright (C) 2011 Maciej Kaczkowski / keit.co
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit mvtypes;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
const
TILE_SIZE = 256;
Type
{ TArea }
TArea = record
top, left, bottom, right: Int64;
end;
{ TRealPoint }
TRealPoint = Record
Lon : Double;
Lat : Double;
end;
{ TRealArea }
TRealArea = Record
TopLeft : TRealPoint;
BottomRight : TRealPoint;
end;
implementation
end.