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

342 lines
8.8 KiB
ObjectPascal

{
(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, laz2_xmlwrite, laz2_dom;
type
{ TTileId }
TTileId = record
X, Y: int64;
Z: integer;
end;
TGetSvrStr = function (id: integer): string;
TGetValStr = function (const Tile: TTileId): String;
TMapProvider = class;
{TBaseTile}
TBaseTile= class
FID:integer;
FMapProvider:TMapProvider;
Public
constructor Create(aProvider:TMapProvider);
destructor Destroy; override;
Property ID:integer read FID;
end;
{ 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;
FTiles:array of TBaseTile;
FTileHandling: TRTLCriticalSection;
function GetLayerCount: integer;
procedure SetLayer(AValue: integer);
public
constructor Create(AName: String);
destructor Destroy; override;
function AppendTile(aTile: TBaseTile): integer;
procedure RemoveTile(aTile: TBaseTile);
procedure AddURL(Url: String; NbSvr, aMinZoom, aMaxZoom: integer;
GetSvrStr: TGetSvrStr; GetXStr: TGetValStr; GetYStr: TGetValStr;
GetZStr: TGetValStr);
procedure GetZoomInfos(out AZoomMin, AZoomMax: integer);
function GetUrlForTile(id: TTileId): String;
procedure ToXML(ADoc: TXMLDocument; AParentNode: TDOMNode);
property Name: String read FName;
property LayerCount: integer read GetLayerCount;
property Layer: integer read FLayer write SetLayer;
end;
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;
implementation
function GetLetterSvr(id: integer): String;
begin
Result := Char(Ord('a') + id);
end;
function 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;
function GetYahooSvr(id: integer): String;
Begin
Result := IntToStr(id + 1);
end;
function GetYahooY(const Tile : TTileId): string;
begin
Result := IntToStr( -(Tile.Y - (1 shl Tile.Z) div 2) - 1);
end;
function GetYahooZ(const Tile : TTileId): string;
Begin
result := IntToStr(Tile.Z + 1);
end;
{ TBaseTile }
constructor TBaseTile.Create(aProvider: TMapProvider);
begin
FMapProvider := aProvider;
if assigned(aProvider) then
FID:=aProvider.AppendTile(self);
end;
destructor TBaseTile.Destroy;
begin
If assigned(FMapProvider) then
FMapProvider.RemoveTile(self);
FMapProvider:=nil;
inherited Destroy;
end;
{ 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;
InitCriticalSection(FTileHandling);
end;
destructor TMapProvider.Destroy;
var
i: Integer;
begin
Finalize(idServer);
Finalize(FName);
Finalize(FUrl);
Finalize(FNbSvr);
Finalize(FGetSvrStr);
Finalize(FGetXStr);
Finalize(FGetYStr);
Finalize(FGetZStr);
Finalize(FMinZoom);
Finalize(FMaxZoom);
EnterCriticalSection(FTileHandling);
for i := high(FTiles) downto 1 do
try
freeandnil(FTiles[i]);
except
FTiles[i]:=nil;
end;
LeaveCriticalsection(FTileHandling);
DoneCriticalsection(FTileHandling);
inherited;
end;
function TMapProvider.AppendTile(aTile: TBaseTile): integer;
var
lNewID: Integer;
begin
EnterCriticalSection(FTileHandling);
lNewID :=high(FTiles)+1;
setlength(FTiles,lNewID+1);
FTiles[lNewID]:=aTile;
LeaveCriticalsection(FTileHandling);
result := lNewID;
end;
procedure TMapProvider.RemoveTile(aTile: TBaseTile);
var
lID, lMaxTile: Integer;
begin
if (atile.ID <= high(FTiles)) and (atile.ID>0) and (FTiles[aTile.ID]=aTile) then
begin
EnterCriticalSection(FTileHandling);
lID := aTile.ID;
lMaxTile :=High(FTiles);
aTile.FID := -1;
FTiles[lID] := FTiles[lMaxTile];
FTiles[lID].FID := lID;
setlength(FTiles,lMaxTile);
LeaveCriticalsection(FTileHandling);
end;
end;
procedure TMapProvider.AddURL(Url: String; NbSvr, aMinZoom, 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 AZoomMin, AZoomMax: integer);
begin
AZoomMin := FMinZoom[layer];
AZoomMax := 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;
procedure TMapProvider.ToXML(ADoc: TXMLDocument; AParentNode: TDOMNode);
var
i: Integer;
node: TDOMElement;
layerNode: TDOMElement;
s: String;
begin
node := ADoc.CreateElement('map_provider');
node.SetAttribute('name', FName);
AParentNode.AppendChild(node);
for i:=0 to LayerCount-1 do begin
layerNode := ADoc.CreateElement('layer');
node.AppendChild(layernode);
layerNode.SetAttribute('url', FUrl[i]);
layerNode.SetAttribute('minZoom', IntToStr(FMinZoom[i]));
layerNode.SetAttribute('maxZoom', IntToStr(FMaxZoom[i]));
layerNode.SetAttribute('serverCount', IntToStr(FNbSvr[i]));
if FGetSvrStr[i] = @getLetterSvr then s := 'Letter'
else if FGetSvrStr[i] = @GetYahooSvr then s := 'Yahoo'
else if FGetSvrstr[i] <> nil then s := 'unknown'
else s := '';
if s <> '' then layerNode.SetAttribute('serverProc', s);
if FGetXStr[i] = @GetQuadKey then s := 'QuadKey'
else if FGetXStr[i] <> nil then s := '(unknown)'
else s := '';
if s <> '' then layerNode.SetAttribute('xProc', s);
if FGetYStr[i] = @GetQuadKey then s := 'QuadKey'
else if FGetYStr[i] = @GetYahooY then s := 'YahooY'
else if FGetYStr[i] <> nil then s := '(unknown)'
else s := '';
if s <> '' then layerNode.SetAttribute('yProc', s);
if FGetZStr[i] = @GetQuadKey then s := 'QuadKey'
else if FGetZStr[i] = @GetYahooZ then s := 'YahooZ'
else if FGetZStr[i] <> nil then s := '(unknown)'
else s := '';
if s <> '' then layerNode.SetAttribute('zProc', s);
end;
end;
end.