diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..f5864b8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +Map/* +Libs/* \ No newline at end of file diff --git a/Demo/MainUnit.dfm b/Demo/MainUnit.dfm new file mode 100644 index 0000000..3eab960 --- /dev/null +++ b/Demo/MainUnit.dfm @@ -0,0 +1,168 @@ +object MainForm: TMainForm + Left = 16 + Top = 116 + Caption = 'Test of OSM map control' + ClientHeight = 720 + ClientWidth = 1003 + Color = clBtnFace + DoubleBuffered = True + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + OnClose = FormClose + OnCreate = FormCreate + OnDestroy = FormDestroy + PixelsPerInch = 120 + TextHeight = 16 + object Splitter1: TSplitter + Left = 767 + Top = 0 + Width = 8 + Height = 576 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Align = alRight + Beveled = True + end + object Panel1: TPanel + Left = 0 + Top = 0 + Width = 767 + Height = 576 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Align = alClient + BevelOuter = bvNone + TabOrder = 0 + object mMap: TScrollBox + Left = 0 + Top = 0 + Width = 767 + Height = 576 + HorzScrollBar.Tracking = True + VertScrollBar.Smooth = True + VertScrollBar.Tracking = True + Align = alClient + AutoScroll = False + DoubleBuffered = True + DragCursor = crSizeAll + ParentDoubleBuffered = False + TabOrder = 0 + OnMouseMove = mMapMouseMove + end + end + object Panel2: TPanel + Left = 775 + Top = 0 + Width = 228 + Height = 576 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Align = alRight + BevelOuter = bvNone + TabOrder = 1 + object btnZoomIn: TSpeedButton + Left = 100 + Top = 13 + Width = 51 + Height = 36 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Glyph.Data = { + 66010000424D6601000000000000760000002800000014000000140000000100 + 040000000000F000000000000000000000001000000000000000000000000000 + 8000008000000080800080000000800080008080000080808000C0C0C0000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00EEEEEEEEEEEE + EEEEEEEE0000EEEEEEEEEEEEEEEEEEEE0000EEEEEEEEEEEEEEEEEEEE0000EEEE + EEE000000EEEEEEE0000EEEEEE0FFFFFF0EEEEEE0000EEEEE0FFFFFFFF0EEEEE + 0000EEEE0FFFFFFFFFF0EEEE0000EEE0FFFFFCCFFFF0EEEE0000EEE0FFFFFCCF + FFFF0EEE0000EEE0FFFCCCCCCFFF0EEE0000EEE0FFFCCCCCCFFF0EEE0000EEE0 + FFFFFCCFFFFF0EEE0000EEE0FFFFFCCFFFF0EEEE0000EEEE0FFFFFFFFFF0EEEE + 0000EEEEE0FFFFFFFF0EEEEE0000EEEEEE0FFFFFF0EEEEEE0000EEEEEEE00000 + 0EEEEEEE0000EEEEEEEEEEEEEEEEEEEE0000EEEEEEEEEEEEEEEEEEEE0000EEEE + EEEEEEEEEEEEEEEE0000} + OnClick = btnZoomInClick + end + object btnZoomOut: TSpeedButton + Left = 164 + Top = 13 + Width = 51 + Height = 36 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Glyph.Data = { + 66010000424D6601000000000000760000002800000014000000140000000100 + 040000000000F000000000000000000000001000000000000000000000000000 + 8000008000000080800080000000800080008080000080808000C0C0C0000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00EEEEEEEEEEEE + EEEEEEEE0000EEEEEEEEEEEEEEEEEEEE0000EEEEEEEEEEEEEEEEEEEE0000EEEE + EEE000000EEEEEEE0000EEEEEE0FFFFFF0EEEEEE0000EEEEE0FFFFFFFF0EEEEE + 0000EEEE0FFFFFFFFFF0EEEE0000EEE0FFFFFFFFFFF0EEEE0000EEE0FFFFFFFF + FFFF0EEE0000EEE0FFFCCCCCCFFF0EEE0000EEE0FFFCCCCCCFFF0EEE0000EEE0 + FFFFFFFFFFFF0EEE0000EEE0FFFFFFFFFFF0EEEE0000EEEE0FFFFFFFFFF0EEEE + 0000EEEEE0FFFFFFFF0EEEEE0000EEEEEE0FFFFFF0EEEEEE0000EEEEEEE00000 + 0EEEEEEE0000EEEEEEEEEEEEEEEEEEEE0000EEEEEEEEEEEEEEEEEEEE0000EEEE + EEEEEEEEEEEEEEEE0000} + OnClick = btnZoomOutClick + end + object Label1: TLabel + Left = 16 + Top = 488 + Width = 41 + Height = 16 + Caption = 'Label1' + end + object Label2: TLabel + Left = 16 + Top = 512 + Width = 41 + Height = 16 + Caption = 'Label2' + end + object lblZoom: TLabel + Left = 7 + Top = 13 + Width = 74 + Height = 36 + AutoSize = False + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -17 + Font.Name = 'Tahoma' + Font.Style = [fsBold] + ParentFont = False + Layout = tlCenter + end + object Button1: TButton + Left = 24 + Top = 256 + Width = 177 + Height = 33 + Caption = 'Save layer' + TabOrder = 0 + OnClick = Button1Click + end + end + object mLog: TMemo + Left = 0 + Top = 576 + Width = 1003 + Height = 144 + Align = alBottom + TabOrder = 2 + end +end diff --git a/Demo/MainUnit.pas b/Demo/MainUnit.pas new file mode 100644 index 0000000..6a1d433 --- /dev/null +++ b/Demo/MainUnit.pas @@ -0,0 +1,221 @@ +unit MainUnit; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, ExtCtrls, Buttons, Vcl.StdCtrls, Math, Types, + OSM.SlippyMapUtils, OSM.MapControl, OSM.TileStorage, + OSM.NetworkRequest, {SynapseRequest,} WinInetRequest; + +const + MSG_GOTTILE = WM_APP + 200; + +type + // Nice trick to avoid registering TMapControl as design-time component + TScrollBox = class(TMapControl) + end; + + TGotTileData = record + Tile: TTile; + Ms: TMemoryStream; + Error: string; + end; + PGotTileData = ^TGotTileData; + + TMainForm = class(TForm) + Panel1: TPanel; + Panel2: TPanel; + Splitter1: TSplitter; + btnZoomIn: TSpeedButton; + btnZoomOut: TSpeedButton; + Button1: TButton; + mMap: TScrollBox; + mLog: TMemo; + Label1: TLabel; + Label2: TLabel; + lblZoom: TLabel; + procedure FormCreate(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure FormDestroy(Sender: TObject); + procedure btnZoomInClick(Sender: TObject); + procedure btnZoomOutClick(Sender: TObject); + procedure Button1Click(Sender: TObject); + procedure mMapMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); + + procedure MapGetTile(Sender: TMapControl; TileHorzNum, TileVertNum: Cardinal; out TileBmp: TBitmap); + procedure MsgGotTile(var Message: TMessage); message MSG_GOTTILE; + procedure NetReqGotTile(const Tile: TTile; Ms: TMemoryStream; const Error: string); + procedure mMapZoomChanged(Sender: TObject); + private + NetworkRequest: TNetworkRequestQueue; + TileStorage: TTileStorage; + procedure Log(const s: string); + end; + +var + MainForm: TMainForm; + +implementation + +{$R *.dfm} + +{ TMainForm } + +procedure TMainForm.FormCreate(Sender: TObject); +begin + // Memory/disc cache of tile images + // You probably won't need it if you have another fast storage (f.e. database) + TileStorage := TTileStorage.Create(30); + TileStorage.FileCacheBaseDir := ExpandFileName('..\Map\'); + // Queuer of tile image network requests + // You won't need it if you have another source (f.e. database) + NetworkRequest := TNetworkRequestQueue.Create(4, 3, {}{SynapseRequest.}WinInetRequest.NetworkRequest, NetReqGotTile); + + mMap.OnGetTile := MapGetTile; + mMap.OnZoomChanged := mMapZoomChanged; + mMap.SetZoom(1); +end; + +procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction); +begin + //... +end; + +procedure TMainForm.FormDestroy(Sender: TObject); +begin + FreeAndNil(NetworkRequest); + FreeAndNil(TileStorage); +end; + +procedure TMainForm.Log(const s: string); +begin + mLog.Lines.Add(DateTimeToStr(Now)+' '+s); + OutputDebugString(PChar(DateTimeToStr(Now)+' '+s)); +end; + +// Callback from map control to receive a tile image +procedure TMainForm.MapGetTile(Sender: TMapControl; TileHorzNum, TileVertNum: Cardinal; out TileBmp: TBitmap); +var + Tile: TTile; +begin + Tile.Zoom := Sender.Zoom; + Tile.ParameterX := TileHorzNum; + Tile.ParameterY := TileVertNum; + + // Query tile from storage + TileBmp := TileStorage.GetTile(Tile); + + // Tile image unavailable - queue network request + if TileBmp = nil then + begin + NetworkRequest.RequestTile(Tile); + Log(Format('Queued request from inet %s', [TileToStr(Tile)])); + end; +end; + +// Callback from a thread of network requester that request has been done +// To avoid thread access troubles, re-post all the data to form +procedure TMainForm.NetReqGotTile(const Tile: TTile; Ms: TMemoryStream; const Error: string); +var + pData: PGotTileData; +begin + New(pData); + pData.Tile := Tile; + pData.Ms := Ms; + pData.Error := Error; + if not PostMessage(Handle, MSG_GOTTILE, 0, LPARAM(pData)) then + begin + Dispose(pData); + FreeAndNil(Ms); + end; +end; + +procedure TMainForm.MsgGotTile(var Message: TMessage); +var + pData: PGotTileData; +begin + pData := PGotTileData(Message.LParam); + if pData.Error <> '' then + begin + Log(Format('Error getting tile %s: %s', [TileToStr(pData.Tile), pData.Error])); + end + else + begin + Log(Format('Got from inet %s', [TileToStr(pData.Tile)])); + TileStorage.StoreTile(pData.Tile, pData.Ms); + mMap.RefreshTile(pData.Tile.ParameterX, pData.Tile.ParameterY); + end; + FreeAndNil(pData.Ms); + Dispose(pData); +end; + +procedure TMainForm.btnZoomInClick(Sender: TObject); +begin + mMap.SetZoom(mMap.Zoom + 1); +end; + +procedure TMainForm.btnZoomOutClick(Sender: TObject); +begin + mMap.SetZoom(mMap.Zoom - 1); +end; + +procedure TMainForm.Button1Click(Sender: TObject); +var + bmp, bmTile: TBitmap; + col, row: Integer; + tile: TTile; + imgAbsent: Boolean; +begin + bmp := TBitmap.Create; + bmp.Height := TileCount(mMap.Zoom)*TILE_IMAGE_HEIGHT; + bmp.Width := TileCount(mMap.Zoom)*TILE_IMAGE_WIDTH; + + try + imgAbsent := False; + for col := 0 to TileCount(mMap.Zoom) - 1 do + for row := 0 to TileCount(mMap.Zoom) - 1 do + begin + tile.Zoom := mMap.Zoom; + tile.ParameterX := col; + tile.ParameterY := row; + bmTile := TileStorage.GetTile(tile); + if bmTile = nil then + begin + NetworkRequest.RequestTile(tile); + imgAbsent := True; + Continue; + end; + bmp.Canvas.Draw(col*TILE_IMAGE_WIDTH, row*TILE_IMAGE_HEIGHT, bmTile); + end; + + if imgAbsent then + begin + ShowMessage('Some images were absent'); + Exit; + end; + + bmp.SaveToFile('Map'+IntToStr(mMap.Zoom)+'.bmp'); + ShowMessage('Saved to Map'+IntToStr(mMap.Zoom)+'.bmp'); + finally + FreeAndNil(bmp); + end; +end; + +procedure TMainForm.mMapMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); +var + MapPt: TPoint; + GeoPt: TPointF; +begin + MapPt := mMap.ViewToMap(Point(X, Y)); + GeoPt := mMap.MapToGeoCoords(MapPt); + Label1.Caption := Format('%d : %d', [MapPt.X, MapPt.Y]); + Label2.Caption := Format('%.3f : %.3f', [GeoPt.X, GeoPt.Y]); +end; + +procedure TMainForm.mMapZoomChanged(Sender: TObject); +begin + lblZoom.Caption := Format('%d / %d', [TMapControl(Sender).Zoom, High(TMapZoomLevel)]); +end; + +end. diff --git a/Demo/OSMMapDemo.dpr b/Demo/OSMMapDemo.dpr new file mode 100644 index 0000000..108111d --- /dev/null +++ b/Demo/OSMMapDemo.dpr @@ -0,0 +1,15 @@ +program OSMMapDemo; + +uses + FastMM4, + Forms, + MainUnit in 'MainUnit.pas' {MainForm}; + +{$R *.res} + +begin + ReportMemoryLeaksOnShutdown := True; + Application.Initialize; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/Demo/OSMMapDemo.dproj b/Demo/OSMMapDemo.dproj new file mode 100644 index 0000000..3279b58 --- /dev/null +++ b/Demo/OSMMapDemo.dproj @@ -0,0 +1,169 @@ + + + {C4875BA9-942C-4C88-84B0-673F38DD35AF} + OSMMapDemo.dpr + True + Debug + 1 + Application + VCL + 13.4 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + Test_OSMTeilsMap_Icon.ico + None + ..\Libs\Synapse;..\;$(DCC_UnitSearchPath) + 1049 + false + false + false + 00400000 + false + false + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + Test_OSMTeilsMap_Icon.ico + + + $(BDS)\bin\default_app.manifest + 1033 + true + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + 0 + false + RELEASE;$(DCC_Define) + false + + + true + 1033 + $(BDS)\bin\default_app.manifest + + + true + true + true + DEBUG;$(DCC_Define) + false + + + $(BDS)\bin\default_app.manifest + true + 1033 + true + 65001 + true + true + 0 + 2 + true + true + false + true + true + + + + MainSource + + +
MainForm
+ + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + OSMMapDemo.dpr + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1049 + 1251 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + False + True + + + 12 + + + + diff --git a/Demo/Test_OSMTeilsMap_Icon.ico b/Demo/Test_OSMTeilsMap_Icon.ico new file mode 100644 index 0000000..1998c2d Binary files /dev/null and b/Demo/Test_OSMTeilsMap_Icon.ico differ diff --git a/OSM.MapControl.pas b/OSM.MapControl.pas new file mode 100644 index 0000000..0b5d939 --- /dev/null +++ b/OSM.MapControl.pas @@ -0,0 +1,729 @@ +{ + Visual control displaying a map. + Data for the map (tile images) must be supplied via callbacks. + See OSM.TileStorage unit +} +unit OSM.MapControl; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Math, Types, + OSM.SlippyMapUtils; + +const + // default W and H of cache image in number of tiles. + // Image's memory occupation: + // (4 bytes per pixel)*TilesH*TilesV*(65536 pixels in single tile) + // For value 8 it counts 16.7 Mb + CacheImageDefTilesH = 8; + CacheImageDefTilesV = 8; + // default W and H of cache image in pixels + CacheImageDefWidth = CacheImageDefTilesH*TILE_IMAGE_WIDTH; + CacheImageDefHeight = CacheImageDefTilesV*TILE_IMAGE_HEIGHT; + // margin that is added to cache image to hold view area, in number of tiles + CacheMarginSize = 2; + // size of margin for labels on map, in pixels + LabelMargin = 2; + +type + TMapOption = ( + moDontDrawCopyright, + moDontDrawScale + ); + + TMapOptions = set of TMapOption; + + TMapMark = record + {}// TODO + end; + PMapMark = ^TMapMark; + + TMapControl = class; + + // Callback to get bitmap of a single tile having number (TileHorzNum;TileVertNum) + // If TileBmp is returned nil, DrawTileLoading method is called for this tile + // Generally you must assign this callback only. + TOnGetTile = procedure (Sender: TMapControl; TileHorzNum, TileVertNum: Cardinal; + out TileBmp: TBitmap) of object; + + // Callback to draw bitmap of a single tile having number (TileHorzNum;TileVertNum) + // If OnDrawTile assigned, it means fully custom drawing process, f.ex. if user has + // fast tile sources that are not TBitmap-s, and it is user responsibility to indicate + // tiles that are loading at the moment. + // If OnDrawTileLoading assigned, the handler will be called only for empty tiles + // allowing a user to draw his own label + TOnDrawTile = procedure (Sender: TMapControl; TileHorzNum, TileVertNum: Cardinal; + const TopLeft: TPoint; DestBmp: TBitMap) of object; + + // Virtual control that doesn't hold any data and must be painted by callbacks + TMapControl = class(TScrollBox) + strict private + FMapSize: TSize; // current map dims in pixels + FCacheImage: TBitmap; // drawn tiles (it could be equal to or larger than view area!) + FCopyright, // lazily created cache images for + FScaleLine: TBitmap; // scale line and copyright + FZoom: Integer; // current zoom; integer for simpler operations + FCacheImageRect: TRect; // position of cache image on map in map coords + FMapOptions: TMapOptions; + FDragPos: TPoint; + FOnGetTile: TOnGetTile; + FOnDrawTile: TOnDrawTile; + FOnDrawTileLoading: TOnDrawTile; + FOnZoomChanged: TNotifyEvent; + protected + // overrides + procedure PaintWindow(DC: HDC); override; + procedure Resize; override; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + function MouseActivate(Button: TMouseButton; Shift: TShiftState; X, Y: Integer; HitTest: Integer): TMouseActivate; override; + function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; + procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override; + procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL; + procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL; + procedure WMPaint(var Message: TWMPaint); message WM_PAINT; + // main methods + function ViewInCache: Boolean; + procedure UpdateCache; + procedure MoveCache; + function SetCacheDimensions: Boolean; + function FindNextMapMark(const Pt: TPoint; PrevIndex: Integer = -1): Integer; + procedure DrawTileLoading(TileHorzNum, TileVertNum: Cardinal; const TopLeft: TPoint; DestBmp: TBitMap); + procedure DoDrawTile(TileHorzNum, TileVertNum: Cardinal; const TopLeft: TPoint; DestBmp: TBitMap); + // helpers + function ViewAreaRect: TRect; + + procedure SetNWPoint(const MapPt: TPoint); overload; + function GetCenterPoint: TPointF; + procedure SetCenterPoint(const Coords: TPointF); + function GetNWPoint: TPointF; + procedure SetNWPoint(const GeoCoords: TPointF); overload; + + class procedure DrawCopyright(const Text: string; DestBmp: TBitmap); + class procedure DrawScale(Zoom: TMapZoomLevel; DestBmp: TBitmap); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + procedure RefreshTile(TileHorzNum, TileVertNum: Cardinal); + + function MapToGeoCoords(const MapPt: TPoint): TPointF; + function GeoCoordsToMap(const GeoCoords: TPointF): TPoint; + function ViewToMap(const ViewPt: TPoint): TPoint; + function MapToView(const MapPt: TPoint): TPoint; + + procedure ScrollMapBy(DeltaHorz, DeltaVert: Integer); + procedure ScrollMapTo(Horz, Vert: Integer); + procedure SetZoom(Value: Integer; const ViewBindPoint: TPoint); overload; + procedure SetZoom(Value: Integer); overload; + + {} + { + add/remove map marks + MouseBox + } + property Zoom: Integer read FZoom; + property MapOptions: TMapOptions read FMapOptions write FMapOptions; + property CenterPoint: TPointF read GetCenterPoint write SetCenterPoint; + property NWPoint: TPointF read GetNWPoint write SetNWPoint; + property OnGetTile: TOnGetTile read FOnGetTile write FOnGetTile; + property OnDrawTile: TOnDrawTile read FOnDrawTile write FOnDrawTile; + property OnDrawTileLoading: TOnDrawTile read FOnDrawTileLoading write FOnDrawTileLoading; + property OnZoomChanged: TNotifyEvent read FOnZoomChanged write FOnZoomChanged; + end; + +function ToInnerCoords(const StartPt, Pt: TPoint): TPoint; overload; inline; +function ToOuterCoords(const StartPt, Pt: TPoint): TPoint; overload; inline; +function ToInnerCoords(const StartPt: TPoint; const Rect: TRect): TRect; overload; inline; +function ToOuterCoords(const StartPt: TPoint; const Rect: TRect): TRect; overload; inline; + +const + SLbl_Loading = 'Loading [%d : %d]...'; + +implementation + +// *** Utils *** + +// Like Client<=>Screen + +function ToInnerCoords(const StartPt, Pt: TPoint): TPoint; +begin + Result := Pt.Subtract(StartPt); +end; + +function ToOuterCoords(const StartPt, Pt: TPoint): TPoint; +begin + Result := Pt.Add(StartPt); +end; + +function ToInnerCoords(const StartPt: TPoint; const Rect: TRect): TRect; +begin + Result.TopLeft := ToInnerCoords(StartPt, Rect.TopLeft); + Result.BottomRight := ToInnerCoords(StartPt, Rect.BottomRight); +end; + +function ToOuterCoords(const StartPt: TPoint; const Rect: TRect): TRect; +begin + Result.TopLeft := ToOuterCoords(StartPt, Rect.TopLeft); + Result.BottomRight := ToOuterCoords(StartPt, Rect.BottomRight); +end; + +// Floor value to tile size + +function ToTileWidthLesser(Width: Cardinal): Cardinal; inline; +begin + Result := (Width div TILE_IMAGE_WIDTH)*TILE_IMAGE_WIDTH; +end; + +function ToTileHeightLesser(Height: Cardinal): Cardinal; inline; +begin + Result := (Height div TILE_IMAGE_HEIGHT)*TILE_IMAGE_HEIGHT; +end; + +// Ceil value to tile size + +function ToTileWidthGreater(Width: Cardinal): Cardinal; inline; +begin + Result := ToTileWidthLesser(Width); + if Width mod TILE_IMAGE_WIDTH > 0 then + Inc(Result, TILE_IMAGE_WIDTH); +end; + +function ToTileHeightGreater(Height: Cardinal): Cardinal; inline; +begin + Result := ToTileHeightLesser(Height); + if Height mod TILE_IMAGE_HEIGHT > 0 then + Inc(Result, TILE_IMAGE_HEIGHT); +end; + +{ TMapControl } + +constructor TMapControl.Create(AOwner: TComponent); +begin + inherited; + FCacheImage := TBitmap.Create; + + FZoom := Pred(Integer(Low(TMapZoomLevel))); + SetZoom(Low(TMapZoomLevel)); +end; + +destructor TMapControl.Destroy; +begin + FreeAndNil(FCacheImage); + FreeAndNil(FCopyright); + FreeAndNil(FScaleLine); + inherited; +end; + +// *** overrides - events *** + +// Main drawing routine +procedure TMapControl.PaintWindow(DC: HDC); +var + ViewRect: TRect; +begin + ViewRect := ViewAreaRect; + // if view area lays within cached image, no update required + if not FCacheImageRect.Contains(ViewRect) then + begin + MoveCache; + UpdateCache; + end; + + // convert ViewRect to CacheImage coords + ViewRect := ToInnerCoords(FCacheImageRect.TopLeft, ViewRect); + + // draw cache (map background) + // ! partial copying from source, TGraphic/TCanvas.Draw can't do that :( + BitBlt(DC, + 0, 0, ViewRect.Width, ViewRect.Height, + FCacheImage.Canvas.Handle, ViewRect.Left, ViewRect.Top, SRCCOPY); + + // init copyright bitmap if not inited yet and draw it + if not (moDontDrawCopyright in FMapOptions) then + begin + if FCopyright = nil then + begin + FCopyright := TBitmap.Create; + DrawCopyright(TilesCopyright, FCopyright); + end; + TransparentBlt(DC, + ClientWidth - FCopyright.Width - LabelMargin, + ClientHeight - FCopyright.Height - LabelMargin, + FCopyright.Width, + FCopyright.Height, + FCopyright.Canvas.Handle, + 0, 0, + FCopyright.Width, + FCopyright.Height, + clWhite); + end; + + // scaleline bitmap must've been inited already in SetZoom + if not (moDontDrawScale in FMapOptions) then + begin + BitBlt(DC, + LabelMargin, + ClientHeight - FScaleLine.Height - LabelMargin, + FScaleLine.Width, + FScaleLine.Height, + FScaleLine.Canvas.Handle, + 0, 0, SRCCOPY); + end; +end; + +// NB: painting on TWinControl is pretty tricky, doing it ordinary way leads +// to weird effects as DC's do not cover whole client area. +// Luckily this could be solved with Invalidate which fully redraws the control +procedure TMapControl.WMHScroll(var Message: TWMHScroll); +begin + Invalidate; + inherited; +end; + +procedure TMapControl.WMVScroll(var Message: TWMVScroll); +begin + Invalidate; + inherited; +end; + +// ! Only with csCustomPaint ControlState the call chain +// TWinControl.WMPaint > PaintHandler > PaintWindow will be executed. +procedure TMapControl.WMPaint(var Message: TWMPaint); +begin + ControlState := ControlState + [csCustomPaint]; + inherited; + ControlState := ControlState - [csCustomPaint]; +end; + +// Reposition cache +procedure TMapControl.Resize; +begin + if SetCacheDimensions then + UpdateCache; + Invalidate; + inherited; +end; + +// Start dragging on mouse press +procedure TMapControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + if FindNextMapMark(ViewToMap(Point(X, Y))) = -1 then + BeginDrag(False, -1); // < 0 - use the DragThreshold property of the global Mouse variable (c) help + inherited; +end; + +// Focus self on mouse press +function TMapControl.MouseActivate(Button: TMouseButton; Shift: TShiftState; X, Y, HitTest: Integer): TMouseActivate; +begin + SetFocus; + Result := inherited; +end; + +// Zoom in/out on mouse wheel +function TMapControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; +begin + inherited; + SetZoom(Zoom + Sign(WheelDelta), ScreenToClient(MousePos)); + Result := True; +end; + +// Process dragging +procedure TMapControl.DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); +begin + inherited; + + Accept := True; + + case State of + dsDragEnter: // drag started - save initial drag position + FDragPos := Point(X, Y); + dsDragMove: // dragging - move the map + begin + ScrollMapBy(FDragPos.X - X, FDragPos.Y - Y); + FDragPos := Point(X, Y); + end; + end; +end; + +// *** new methods *** + +// Set zoom level to Value and reposition to given point +// ViewBindPoint - point in view area's coords that must keep its position +procedure TMapControl.SetZoom(Value: Integer; const ViewBindPoint: TPoint); +var + CurrBindPt, NewViewNW: TPoint; + BindCoords: TPointF; +begin + if not (Value in [Low(TMapZoomLevel)..High(TMapZoomLevel)]) then Exit; + if Value = FZoom then Exit; + + // save bind point if zoom is valid (zoom value is used to calc geo coords) + if FZoom in [Low(TMapZoomLevel)..High(TMapZoomLevel)] + then BindCoords := MapToGeoCoords(ViewToMap(ViewBindPoint)) + else BindCoords := OSM.SlippyMapUtils.MapToGeoCoords(Point(0, 0), 0); + + FZoom := Value; + FMapSize.cx := TileCount(FZoom)*TILE_IMAGE_WIDTH; + FMapSize.cy := TileCount(FZoom)*TILE_IMAGE_HEIGHT; + + HorzScrollBar.Range := FMapSize.cx; + VertScrollBar.Range := FMapSize.cy; + + // init copyright bitmap if not inited yet and draw it + if not (moDontDrawScale in FMapOptions) then + begin + if FScaleLine = nil then + FScaleLine := TBitmap.Create; + DrawScale(FZoom, FScaleLine); + end; + + // move viewport + CurrBindPt := GeoCoordsToMap(BindCoords); // bind point in new map coords + NewViewNW := CurrBindPt.Subtract(ViewBindPoint); // view's top-left corner in new map coords + SetNWPoint(NewViewNW); + + SetCacheDimensions; + if not FCacheImageRect.Contains(ViewAreaRect) then + MoveCache; + UpdateCache; // zoom changed - update cache anyway + + Refresh; + + if Assigned(FOnZoomChanged) then + FOnZoomChanged(Self); +end; + +// Simple zoom change with binding to top-left corner +procedure TMapControl.SetZoom(Value: Integer); +begin + SetZoom(Value, Point(0,0)); +end; + +// Determines cache image size according to control and map size +// Returns true if size was changed +function TMapControl.SetCacheDimensions: Boolean; +var + CtrlSize, CacheSize: TSize; +begin + // dims of view area in pixels rounded to full tiles + CtrlSize.cx := ToTileWidthGreater(ClientWidth); + CtrlSize.cy := ToTileHeightGreater(ClientHeight); + + // cache dims = Max(control+margins, Min(map, default+margins)) + CacheSize.cx := Min(FMapSize.cx, CacheImageDefWidth + CacheMarginSize*TILE_IMAGE_WIDTH); + CacheSize.cy := Min(FMapSize.cy, CacheImageDefHeight + CacheMarginSize*TILE_IMAGE_HEIGHT); + + CacheSize.cx := Max(CacheSize.cx, CtrlSize.cx + CacheMarginSize*TILE_IMAGE_WIDTH); + CacheSize.cy := Max(CacheSize.cy, CtrlSize.cy + CacheMarginSize*TILE_IMAGE_HEIGHT); + + Result := (FCacheImageRect.Width <> CacheSize.cx) or (FCacheImageRect.Height <> CacheSize.cy); + if not Result then Exit; + FCacheImageRect.Size := CacheSize; + FCacheImage.SetSize(CacheSize.cx, CacheSize.cy); +end; + +// Recalc point in view area coords to map coords +function TMapControl.ViewToMap(const ViewPt: TPoint): TPoint; +begin + Result := ToOuterCoords(ViewAreaRect.TopLeft, ViewPt); +end; + +// Recalc point in map coords to view area coords +function TMapControl.MapToView(const MapPt: TPoint): TPoint; +begin + Result := ToInnerCoords(ViewAreaRect.TopLeft, MapPt); +end; + +// View area position and size in map coords +function TMapControl.ViewAreaRect: TRect; +begin + Result := ClientRect; + Result.Offset(Point(HorzScrollBar.Position, VertScrollBar.Position)); +end; + +// Whether view area is inside cache image +function TMapControl.ViewInCache: Boolean; +begin + Result := FCacheImageRect.Contains(ViewAreaRect); +end; + +// Fill the cache image +procedure TMapControl.UpdateCache; +var + CanvRect: TRect; + CacheHorzCount, CacheVertCount, horz, vert, CacheHorzNum, CacheVertNum: Cardinal; +begin + // Bounds of cache image in its own coords + CanvRect := FCacheImageRect; + CanvRect.SetLocation(0, 0); + // Clear the image + FCacheImage.Canvas.Brush.Color := Self.Color; + FCacheImage.Canvas.FillRect(CanvRect); + // Get dimensions of cache + CacheHorzCount := Min(FMapSize.cx - FCacheImageRect.Left, FCacheImageRect.Width) div TILE_IMAGE_WIDTH; + CacheVertCount := Min(FMapSize.cy - FCacheImageRect.Top, FCacheImageRect.Height) div TILE_IMAGE_HEIGHT; + // Get top-left of cache in tiles + CacheHorzNum := FCacheImageRect.Left div TILE_IMAGE_WIDTH; + CacheVertNum := FCacheImageRect.Top div TILE_IMAGE_HEIGHT; + // Draw cache tiles + for horz := 0 to CacheHorzCount - 1 do + for vert := 0 to CacheVertCount - 1 do + DoDrawTile(CacheHorzNum + horz, CacheVertNum + vert, Point(horz*TILE_IMAGE_WIDTH, vert*TILE_IMAGE_HEIGHT), FCacheImage); +end; + +// Calc new cache coords to cover current view area +procedure TMapControl.MoveCache; +var + ViewRect: TRect; + MarginH, MarginV: Cardinal; +begin + ViewRect := ViewAreaRect; + // move view rect to the border of tiles (to lesser value) + ViewRect.Left := ToTileWidthLesser(ViewRect.Left); + ViewRect.Top := ToTileHeightLesser(ViewRect.Top); + // resize view rect to the border of tiles (to greater value) + ViewRect.Right := ToTileWidthGreater(ViewRect.Right); + ViewRect.Bottom := ToTileHeightGreater(ViewRect.Bottom); + + // reposition new cache rect to cover tile-aligned view area + // calc margins + MarginH := FCacheImageRect.Width - ViewRect.Width; + MarginV := FCacheImageRect.Height - ViewRect.Height; + // margins on the both sides + if MarginH > TILE_IMAGE_WIDTH then + MarginH := MarginH div 2; + if MarginV > TILE_IMAGE_HEIGHT then + MarginV := MarginV div 2; + FCacheImageRect.SetLocation(ViewRect.TopLeft); + FCacheImageRect.TopLeft.Subtract(Point(MarginH, MarginV)); +end; + +// Draw single tile (TileHorzNum;TileVertNum) +procedure TMapControl.RefreshTile(TileHorzNum, TileVertNum: Cardinal); +var + TileTopLeft: TPoint; +begin + // calc tile rect in map coords + TileTopLeft := Point(TileHorzNum*TILE_IMAGE_WIDTH, TileVertNum*TILE_IMAGE_HEIGHT); + // the tile is not in cache + if not FCacheImageRect.Contains(TileTopLeft) then + Exit; + // convert tile to cache image coords + TileTopLeft.SetLocation(ToInnerCoords(FCacheImageRect.TopLeft, TileTopLeft)); + // draw to cache + DoDrawTile(TileHorzNum, TileVertNum, TileTopLeft, FCacheImage); + // redraw the view + Refresh; +end; + +// Draw single tile (TileHorzNum;TileVertNum) to bitmap DestBmp at point TopLeft +procedure TMapControl.DoDrawTile(TileHorzNum, TileVertNum: Cardinal; const TopLeft: TPoint; DestBmp: TBitMap); +var + TileBmp: TBitmap; +begin + // check if user wants custom draw + if Assigned(OnDrawTile) then + begin + OnDrawTile(Self, TileHorzNum, TileVertNum, TopLeft, DestBmp); + Exit; + end; + // request tile bitmap via callback + TileBmp := nil; + if Assigned(OnGetTile) then + OnGetTile(Self, TileHorzNum, TileVertNum, TileBmp); + // no such tile - draw "loading" + if TileBmp = nil then + begin + if Assigned(FOnDrawTileLoading) then + FOnDrawTileLoading(Self, TileHorzNum, TileVertNum, TopLeft, DestBmp) + else + DrawTileLoading(TileHorzNum, TileVertNum, TopLeft, DestBmp); + end + else + DestBmp.Canvas.Draw(TopLeft.X, TopLeft.Y, TileBmp); +end; + +// Draw single tile (TileHorzNum;TileVertNum) loading to bitmap DestBmp at point TopLeft +procedure TMapControl.DrawTileLoading(TileHorzNum, TileVertNum: Cardinal; const TopLeft: TPoint; DestBmp: TBitMap); +var + TileRect: TRect; + TextExt: TSize; + Canv: TCanvas; + txt: string; +begin + TileRect.TopLeft := TopLeft; + TileRect.Size := TSize.Create(TILE_IMAGE_WIDTH, TILE_IMAGE_HEIGHT); + + Canv := DestBmp.Canvas; + Canv.Brush.Color := Color; + Canv.Pen.Color := clDkGray; + Canv.Rectangle(TileRect); + + txt := Format(SLbl_Loading, [TileHorzNum, TileVertNum]); + TextExt := Canv.TextExtent(txt); + Canv.Font.Color := clGreen; + Canv.TextOut( + TileRect.Left + (TileRect.Width - TextExt.cx) div 2, + TileRect.Top + (TileRect.Height - TextExt.cy) div 2, + txt); +end; + +// Draw copyright label on bitmap and set its size. Happens only once. +class procedure TMapControl.DrawCopyright(const Text: string; DestBmp: TBitmap); +var + Canv: TCanvas; + TextExt: TSize; +begin + Canv := DestBmp.Canvas; + + Canv.Font.Name := 'Arial'; + Canv.Font.Size := 8; + Canv.Font.Style := []; + + TextExt := Canv.TextExtent(Text); + + DestBmp.SetSize(TextExt.cx, TextExt.cy); + + // Text + Canv.Font.Color := clGray; + Canv.TextOut(LabelMargin, LabelMargin, Text); +end; + +// Draw scale line on bitmap and set its size. Happens every zoom change. +class procedure TMapControl.DrawScale(Zoom: TMapZoomLevel; DestBmp: TBitmap); +var + Canv: TCanvas; + LetterWidth, ScalebarWidthPixel, ScalebarWidthMeter: Integer; + Text: string; + TextExt: TSize; + ScalebarRect: TRect; +begin + Canv := DestBmp.Canvas; + + GetScaleBarParams(Zoom, ScalebarWidthPixel, ScalebarWidthMeter, Text); + + Canv.Font.Name := 'Arial'; + Canv.Font.Size := 8; + Canv.Font.Style := []; + + TextExt := Canv.TextExtent(Text); + LetterWidth := Canv.TextWidth('W'); + + DestBmp.Width := LetterWidth + TextExt.cx + LetterWidth + ScalebarWidthPixel; // text, space, bar + DestBmp.Height := 2*LabelMargin + TextExt.cy; + + // Frame + Canv.Brush.Color := clWhite; + Canv.Pen.Color := clSilver; + Canv.Rectangle(0, 0, DestBmp.Width, DestBmp.Height); + + // Text + Canv.Font.Color := clBlack; + Canv.TextOut(LetterWidth div 2, LabelMargin, Text); + + // Scale-Bar + Canv.Brush.Color := clWhite; + Canv.Pen.Color := clBlack; + ScalebarRect.Left := LetterWidth div 2 + TextExt.cx + LetterWidth; + ScalebarRect.Top := (DestBmp.Height - TextExt.cy div 2) div 2; + ScalebarRect.Width := ScalebarWidthPixel; + ScalebarRect.Height := TextExt.cy div 2; + Canv.Rectangle(ScalebarRect); +end; + +// Pixels => degrees +function TMapControl.MapToGeoCoords(const MapPt: TPoint): TPointF; +begin + Result := OSM.SlippyMapUtils.MapToGeoCoords(MapPt, FZoom); +end; + +// Degrees => pixels +function TMapControl.GeoCoordsToMap(const GeoCoords: TPointF): TPoint; +begin + Result := OSM.SlippyMapUtils.GeoCoordsToMap(GeoCoords, FZoom); +end; + +// Delta move the view area +procedure TMapControl.ScrollMapBy(DeltaHorz, DeltaVert: Integer); +begin + Invalidate; // refresh the image + HorzScrollBar.Position := HorzScrollBar.Position + DeltaHorz; + VertScrollBar.Position := VertScrollBar.Position + DeltaVert; +end; + +// Absolutely move the view area +procedure TMapControl.ScrollMapTo(Horz, Vert: Integer); +begin + Invalidate; // refresh the image + HorzScrollBar.Position := Horz; + VertScrollBar.Position := Vert; +end; + +// Move the view area to new top-left point +procedure TMapControl.SetNWPoint(const MapPt: TPoint); +begin + ScrollMapTo(MapPt.X, MapPt.Y); +end; + +{}//? +function TMapControl.GetCenterPoint: TPointF; +begin + Result := MapToGeoCoords(ViewAreaRect.CenterPoint); +end; + +procedure TMapControl.SetCenterPoint(const Coords: TPointF); +var + ViewRect: TRect; + Pt: TPoint; +begin + // new center point in map coords + Pt := GeoCoordsToMap(Coords); + // new NW point + ViewRect := ViewAreaRect; + Pt.Offset(-ViewRect.Width div 2, -ViewRect.Height div 2); + // move + SetNWPoint(Pt); +end; + +// Get top-left point of the view area +function TMapControl.GetNWPoint: TPointF; +begin + Result := MapToGeoCoords(ViewAreaRect.TopLeft); +end; + +// Move the view area to new top-left point +procedure TMapControl.SetNWPoint(const GeoCoords: TPointF); +begin + SetNWPoint(GeoCoordsToMap(GeoCoords)); +end; + +// Find the next map mark that has specified coordinates. +// PrevIndex - index of previous found map mark in the list. -1 (default) to +// start from the 1st element. +// Returns: +// index of map mark in the list, -1 if not found. +// +// Samples: +// 1) Check if there's any map marks at this point +// if FindNextMapMark(Point) <> -1 then ... +// 2) Select all map marks at this point +// idx := -1; +// repeat +// idx := FindNextMapMark(Point, idx); +// if idx = -1 then Break; +// ... do something with MapMarks[idx] ... +// until False; +function TMapControl.FindNextMapMark(const Pt: TPoint; PrevIndex: Integer): Integer; +begin + { + if index = -1 - start searching + if no marks - return -1 + if index > -1 - continue from index + + } + + {} Result := -1; +end; + +end. diff --git a/OSM.NetworkRequest.pas b/OSM.NetworkRequest.pas new file mode 100644 index 0000000..af695ff --- /dev/null +++ b/OSM.NetworkRequest.pas @@ -0,0 +1,263 @@ +{ + Generic (no real network implementation) classes and declarations for + requesting OSM tile images from network. + Real network function from any network must be supplied to actually execute request. +} +unit OSM.NetworkRequest; + +interface + +uses + SysUtils, Classes, Contnrs, + OSM.SlippyMapUtils; + +type + THttpRequestType = (reqPost, reqGet); + + THttpRequestProps = record + RequestType: THttpRequestType; + URL: string; + POSTData: string; + HttpUserName: string; + HttpPassword: string; + HeaderLines: TStrings; + Additional: Pointer; + end; + + // Generic type of blocking network request function + // RequestProps - all details regarding a request + // ResponseStm - stream that accepts response data + // ErrMsg - error description if any. + // Returns: success flag + TBlockingNetworkRequestFunc = function (const RequestProps: THttpRequestProps; + const ResponseStm: TStream; out ErrMsg: string): Boolean; + + // Generic type of method to call when request is completed + // ! Called from the context of a background thread ! + TGotTileFromNetworkCallback = procedure (const Tile: TTile; Ms: TMemoryStream; const Error: string) of object; + + // Queuer of network requests + TNetworkRequestQueue = class + strict private + FTaskQueue: TQueue; // list of tiles to be requested + FThreads: TList; + FCurrentTasks: TList; // list of tiles that are requested but not yet received + FNotEmpty: Boolean; + + FMaxTasksPerThread: Cardinal; + FMaxThreads: Cardinal; + FGotTileCb: TGotTileFromNetworkCallback; + FRequestFunc: TBlockingNetworkRequestFunc; + procedure Lock; + procedure Unlock; + procedure AddThread; + private + // for access from TNetworkRequestThread + procedure DoRequestComplete(Sender: TThread; const Tile: TTile; Ms: TMemoryStream; const Error: string); + function PopTask: Pointer; + + property NotEmpty: Boolean read FNotEmpty; + property RequestFunc: TBlockingNetworkRequestFunc read FRequestFunc; + public + constructor Create(MaxTasksPerThread, MaxThreads: Cardinal; + RequestFunc: TBlockingNetworkRequestFunc; + GotTileCb: TGotTileFromNetworkCallback); + destructor Destroy; override; + + procedure RequestTile(const Tile: TTile); + end; + +implementation + +type + // Thread that consumes tasks from owner's queue and executes them + // When there are no tasks in the queue, it finishes and must be destroyed + TNetworkRequestThread = class(TThread) + strict private + FOwner: TNetworkRequestQueue; + public + constructor Create(Owner: TNetworkRequestQueue); + procedure Execute; override; + end; + +{ TNetworkRequestThread } + +constructor TNetworkRequestThread.Create(Owner: TNetworkRequestQueue); +begin + FOwner := Owner; + inherited Create(False); +end; + +procedure TNetworkRequestThread.Execute; +var + pT: PTile; + tile: TTile; + sURL, sErrMsg: string; + ms: TMemoryStream; + ReqProps: THttpRequestProps; +begin + ReqProps := Default(THttpRequestProps); + ReqProps.RequestType := reqGet; + + while not Terminated do + begin + pT := PTile(FOwner.PopTask); + if pT <> nil then + begin + tile := pT^; + sURL := TileToFullSlippyMapFileURL(tile); + ms := TMemoryStream.Create; + ReqProps.URL := sURL; + if not FOwner.RequestFunc(ReqProps, ms, sErrMsg) then + FreeAndNil(ms) + else + ms.Position := 0; + + FOwner.DoRequestComplete(Self, tile, ms, sErrMsg); + end; + end; +end; + +{ TNetworkRequestQueue } + +// MaxTasksPerThread - if TaskCount > MaxTasksPerThread*ThreadCount, add one more thread +// MaxThreads - limit the number of threads +// GotTileCb - method to call when request is completed +constructor TNetworkRequestQueue.Create(MaxTasksPerThread, MaxThreads: Cardinal; + RequestFunc: TBlockingNetworkRequestFunc; GotTileCb: TGotTileFromNetworkCallback); +begin + FTaskQueue := TQueue.Create; + FThreads := TList.Create; + FCurrentTasks := TList.Create; + FMaxTasksPerThread := MaxTasksPerThread; + FMaxThreads := MaxThreads; + FGotTileCb := GotTileCb; + FRequestFunc := RequestFunc; +end; + +destructor TNetworkRequestQueue.Destroy; +var i: Integer; +begin + // Command the threads to stop, wait and destroy them + for i := 0 to FThreads.Count - 1 do + TThread(FThreads[i]).Terminate; + for i := 0 to FThreads.Count - 1 do + TThread(FThreads[i]).WaitFor; + for i := 0 to FThreads.Count - 1 do + if TThread(FThreads[i]).Finished then + TThread(FThreads[i]).Free + else + raise Exception.Create('Thread was not finished'); + FreeAndNil(FThreads); + + // Data cleanup + while FTaskQueue.Count > 0 do + Dispose(PTile(FTaskQueue.Pop)); + FreeAndNil(FTaskQueue); + for i := 0 to FCurrentTasks.Count - 1 do + Dispose(PTile(FCurrentTasks[0])); + FreeAndNil(FCurrentTasks); +end; + +procedure TNetworkRequestQueue.Lock; +begin + System.TMonitor.Enter(Self); +end; + +procedure TNetworkRequestQueue.Unlock; +begin + System.TMonitor.Exit(Self); +end; + +function IndexOfTile(const Tile: TTile; List: TList): Integer; +begin + for Result := 0 to List.Count - 1 do + if TilesEqual(Tile, PTile(List[Result])^) then + Exit; + Result := -1; +end; + +type + TQueueHack = class(TQueue) end; + +procedure TNetworkRequestQueue.RequestTile(const Tile: TTile); +var + pT: PTile; +begin + Lock; + try + // check if tile already in process + if IndexOfTile(Tile, FCurrentTasks) <> -1 then + Exit; + // or in queue + if IndexOfTile(Tile, TQueueHack(FTaskQueue).List) <> -1 then + Exit; + + New(pT); + pT^ := Tile; + FTaskQueue.Push(pT); + FNotEmpty := True; + if (FTaskQueue.Count > FMaxTasksPerThread*FThreads.Count) and + (FThreads.Count < FMaxThreads) then + AddThread; + finally + Unlock; + end; +end; + +procedure TNetworkRequestQueue.AddThread; +begin + Lock; + try + FThreads.Add(TNetworkRequestThread.Create(Self)); + finally + Unlock; + end; +end; + +// Extract next item from queue +// ! Executed from bg threads +function TNetworkRequestQueue.PopTask: Pointer; +begin + // Fast check + if not NotEmpty then + Exit(nil); + + Lock; + try + if FTaskQueue.Count > 0 then + begin + Result := FTaskQueue.Pop; + FCurrentTasks.Add(Result); + end + else + Result := nil; + FNotEmpty := (FTaskQueue.Count > 0); + finally + Unlock; + end; +end; + +// Network request complete +// ! Executed from bg threads +procedure TNetworkRequestQueue.DoRequestComplete(Sender: TThread; const Tile: TTile; Ms: TMemoryStream; const Error: string); +var + idx: Integer; +begin + Lock; + try + idx := IndexOfTile(Tile, FCurrentTasks); + Dispose(PTile(FCurrentTasks[idx])); + FCurrentTasks.Delete(idx); + if Sender.Finished then + begin + Sender.Free; + FThreads.Delete(FThreads.IndexOf(Sender)); + end; + finally + Unlock; + end; + FGotTileCb(Tile, Ms, Error); +end; + +end. diff --git a/OSM.SlippyMapUtils.pas b/OSM.SlippyMapUtils.pas new file mode 100644 index 0000000..c9a143a --- /dev/null +++ b/OSM.SlippyMapUtils.pas @@ -0,0 +1,267 @@ +{ + OSM map types & functions. + Ref.: https://wiki.openstreetmap.org/wiki/Slippy_Map + + based on unit by Simon Kroik, 06.2018, kroiksm@gmx.de + which is based on UNIT openmap.pas + https://github.com/norayr/meridian23/blob/master/openmap/openmap.pas + New BSD License +} +unit OSM.SlippyMapUtils; + +interface + +uses Types, SysUtils, Math; + +type + TMapZoomLevel = 0..19; // 19 = Maximum zoom for Mapnik layer + + TTile = record + Zoom: TMapZoomLevel; + ParameterX: Integer; + ParameterY: Integer; + end; + PTile = ^TTile; + +const + TILE_IMAGE_WIDTH = 256; + TILE_IMAGE_HEIGHT = 256; + // https://wiki.openstreetmap.org/wiki/Zoom_levels + TileMetersPerPixelOnEquator: array [TMapZoomLevel] of Double = + ( + 156412, + 78206, + 39103, + 19551, + 9776, + 4888, + 2444, + 1222, + 610.984, + 305.492, + 152.746, + 76.373, + 38.187, + 19.093, + 9.547, + 4.773, + 2.387, + 1.193, + 0.596, + 0.298 + ); + +var // configurable + TilesCopyright: string = '(c) OpenStreetMap contributors'; + MapURLPrefix: string = 'http://tile.openstreetmap.org/'; + MapURLPostfix: string = ''; + +function TileCount(Zoom: TMapZoomLevel): Integer; inline; +function TileValid(const Tile: TTile): Boolean; inline; +function TileToStr(const Tile: TTile): string; +function TilesEqual(const Tile1, Tile2: TTile): Boolean; inline; + +function LongitudeToMapCoord(Longitude: Double; Zoom: TMapZoomLevel): Integer; +function LatitudeToMapCoord(Latitude: Double; Zoom: TMapZoomLevel): Integer; +function MapCoordToLongitude(X: Integer; Zoom: TMapZoomLevel): Double; +function MapCoordToLatitude(Y: Integer; Zoom: TMapZoomLevel): Double; +function MapToGeoCoords(const MapPt: TPoint; Zoom: TMapZoomLevel): TPointF; +function GeoCoordsToMap(const GeoCoords: TPointF; Zoom: TMapZoomLevel): TPoint; + +function CalcLinDistanceInMeter(const Coord1, Coord2: TPointF): Double; +procedure GetScaleBarParams(Zoom: TMapZoomLevel; + var ScalebarWidthInPixel: Integer; var ScalebarWidthInMeter: Integer; + var Text: string); + +function TileToSlippyMapFileSubURL(const Tile: TTile): string; +function TileToSlippyMapFileSubPath(const Tile: TTile): string; +function TileToFullSlippyMapFileURL(const Tile: TTile): string; + +implementation + +// Tile utils + +// Tile count on level is 2^Zoom +function TileCount(Zoom: TMapZoomLevel): Integer; +begin + Result := 1 shl Zoom; +end; + +// Check tile fields for validity +function TileValid(const Tile: TTile): Boolean; +begin + Result := + (Tile.Zoom in [Low(TMapZoomLevel)..High(TMapZoomLevel)]) and + (Tile.ParameterX >= 0) and (Tile.ParameterX < TileCount(Tile.Zoom)) and + (Tile.ParameterY >= 0) and (Tile.ParameterY < TileCount(Tile.Zoom)); +end; + +// Just a standartized string representation +function TileToStr(const Tile: TTile): string; +begin + Result := Format('%d * [%d : %d]', [Tile.Zoom, Tile.ParameterX, Tile.ParameterY]); +end; + +function TilesEqual(const Tile1, Tile2: TTile): Boolean; +begin + Result := + (Tile1.Zoom = Tile2.Zoom) and + (Tile1.ParameterX = Tile2.ParameterX) and + (Tile1.ParameterY = Tile2.ParameterY); +end; + +// Degrees to pixels + +function LongitudeToMapCoord(Longitude: Double; Zoom: TMapZoomLevel): Integer; +begin + Result := Floor((Longitude + 180.0) / 360.0 * TileCount(Zoom)*TILE_IMAGE_WIDTH); +end; + +function LatitudeToMapCoord(Latitude: Double; Zoom: TMapZoomLevel): Integer; +var + SavePi: Extended; + LatInRad: Extended; +begin + SavePi := Pi; + LatInRad := Latitude * SavePi / 180.0; + Result := Floor((1.0 - ln(Tan(LatInRad) + 1.0 / Cos(LatInRad)) / SavePi) / 2.0 * TileCount(Zoom)*TILE_IMAGE_HEIGHT); +end; + +function GeoCoordsToMap(const GeoCoords: TPointF; Zoom: TMapZoomLevel): TPoint; +begin + Result := Point( + LongitudeToMapCoord(GeoCoords.X, Zoom), + LatitudeToMapCoord(GeoCoords.Y, Zoom) + ); +end; + +// Pixels to degrees + +function MapCoordToLongitude(X: Integer; Zoom: TMapZoomLevel): Double; +begin + Result := X / (TileCount(Zoom)*TILE_IMAGE_WIDTH) * 360.0 - 180.0; +end; + +function MapCoordToLatitude(Y: Integer; Zoom: TMapZoomLevel): Double; +var + n: Extended; + SavePi: Extended; +begin + SavePi := Pi; + n := SavePi - 2.0 * SavePi * Y / (TileCount(Zoom)*TILE_IMAGE_HEIGHT); + + Result := 180.0 / SavePi * ArcTan(0.5 * (Exp(n) - Exp(-n))); +end; + +function MapToGeoCoords(const MapPt: TPoint; Zoom: TMapZoomLevel): TPointF; +begin + Result := PointF( + MapCoordToLongitude(MapPt.X, Zoom), + MapCoordToLatitude(MapPt.Y, Zoom) + ); +end; + +// Other + +function CalcLinDistanceInMeter(const Coord1, Coord2: TPointF): Double; +var + Phimean: Double; + dLambda: Double; + dPhi: Double; + Alpha: Double; + Rho: Double; + Nu: Double; + R: Double; + z: Double; + Temp: Double; +const + D2R: Double = 0.017453; + R2D: Double = 57.295781; + a: Double = 6378137.0; + b: Double = 6356752.314245; + e2: Double = 0.006739496742337; + f: Double = 0.003352810664747; +begin + dLambda := (Coord1.X - Coord2.X) * D2R; + dPhi := (Coord1.Y - Coord2.Y) * D2R; + Phimean := ((Coord1.Y + Coord2.Y) / 2.0) * D2R; + + Temp := 1 - e2 * Sqr(Sin(Phimean)); + Rho := (a * (1 - e2)) / Power(Temp, 1.5); + Nu := a / (Sqrt(1 - e2 * (Sin(Phimean) * Sin(Phimean)))); + + z := Sqrt(Sqr(Sin(dPhi / 2.0)) + Cos(Coord2.Y * D2R) * + Cos(Coord1.Y * D2R) * Sqr(Sin(dLambda / 2.0))); + + z := 2 * ArcSin(z); + + Alpha := Cos(Coord2.Y * D2R) * Sin(dLambda) * 1 / Sin(z); + Alpha := ArcSin(Alpha); + + R := (Rho * Nu) / (Rho * Sqr(Sin(Alpha)) + (Nu * Sqr(Cos(Alpha)))); + + Result := (z * R); +end; + +procedure GetScaleBarParams(Zoom: TMapZoomLevel; var ScalebarWidthInPixel, ScalebarWidthInMeter: Integer; var Text: string); +const + ScalebarWidthInKm: array [TMapZoomLevel] of Double = + ( + 10000, + 5000, + 3000, + 1000, + 500, + 300, + 200, + 100, + 50, + 30, + 10, + 5, + 3, + 1, + 0.500, + 0.300, + 0.200, + 0.100, + 0.050, + 0.020 + ); +var + dblScalebarWidthInMeter: Double; +begin + dblScalebarWidthInMeter := ScalebarWidthInKm[Zoom] * 1000; + ScalebarWidthInPixel := Round(dblScalebarWidthInMeter / TileMetersPerPixelOnEquator[Zoom]); + ScalebarWidthInMeter := Round(dblScalebarWidthInMeter); + + if ScalebarWidthInMeter < 1000 then + Text := IntToStr(ScalebarWidthInMeter) + ' m' + else + Text := IntToStr(ScalebarWidthInMeter div 1000) + ' km' +end; + +// Tile path + +function TileToSlippyMapFileSubURL(const Tile: TTile): string; +begin + Result := + IntToStr(Tile.Zoom) + '/' + + IntToStr(Tile.ParameterX) + '/' + + IntToStr(Tile.ParameterY) + '.png'; +end; + +function TileToSlippyMapFileSubPath(const Tile: TTile): string; +begin + Result := + IntToStr(Tile.Zoom) + PathDelim + + IntToStr(Tile.ParameterX) + PathDelim + + IntToStr(Tile.ParameterY) + '.png'; +end; + +function TileToFullSlippyMapFileURL(const Tile: TTile): string; +begin + Result := MapURLPrefix + TileToSlippyMapFileSubURL(Tile) + MapURLPostfix; +end; + +end. diff --git a/OSM.TileStorage.pas b/OSM.TileStorage.pas new file mode 100644 index 0000000..6a3ad70 --- /dev/null +++ b/OSM.TileStorage.pas @@ -0,0 +1,206 @@ +{ + OSM tile images cache. + Stores tile images for the map, could read/save them from/to local files but + doesn't request them from network. See OSM.NetworkRequest unit +} +unit OSM.TileStorage; + +interface + +uses + SysUtils, Classes, Graphics, PngImage, + OSM.SlippyMapUtils; + +const + // Amount of bytes that a single tile bitmap occupies in memory. + // Bitmap consumes ~4 byte per pixel. This constant could be used to + // determine acceptable cache size knowing acceptable memory usage. + TILE_BITMAP_SIZE = 4*TILE_IMAGE_WIDTH*TILE_IMAGE_HEIGHT; + +type + // List of cached tile bitmaps with fixed capacity organised as queue + TTileBitmapCache = class + strict private + type + TTileBitmapRec = record + Tile: TTile; + Bmp: TBitmap; + end; + PTileBitmapRec = ^TTileBitmapRec; + strict private + FCache: TList; + class function NewItem(const Tile: TTile; Bmp: TBitmap): PTileBitmapRec; + class procedure FreeItem(pItem: PTileBitmapRec); + public + constructor Create(Capacity: Integer); + destructor Destroy; override; + procedure Push(const Tile: TTile; Bmp: TBitmap); + function Find(const Tile: TTile): TBitmap; + end; + + TTileStorageOption = ( + tsoNoFileCache, // disable all file cache operations + tsoReadOnlyFileCache // disable write file cache operations + ); + TTileStorageOptions = set of TTileStorageOption; + + // Class that encapsulates memory and file cache of tile images + TTileStorage = class + strict private + FBmpCache: TTileBitmapCache; + FFileCacheBaseDir: string; + FOptions: TTileStorageOptions; + + function GetFromFileCache(const Tile: TTile): TBitmap; + procedure StoreInFileCache(const Tile: TTile; Ms: TMemoryStream); + public + constructor Create(CacheSize: Integer); + destructor Destroy; override; + function GetTile(const Tile: TTile): TBitmap; + procedure StoreTile(const Tile: TTile; Ms: TMemoryStream); + + property Options: TTileStorageOptions read FOptions write FOptions; + // Base path to images on disk: \ \ \ .png + property FileCacheBaseDir: string read FFileCacheBaseDir write FFileCacheBaseDir; + end; + +implementation + +{$REGION 'TTileBitmapCache'} + +class function TTileBitmapCache.NewItem(const Tile: TTile; Bmp: TBitmap): PTileBitmapRec; +begin + New(Result); + Result.Tile := Tile; + Result.Bmp := Bmp; +end; + +class procedure TTileBitmapCache.FreeItem(pItem: PTileBitmapRec); +begin + pItem.Bmp.Free; + Dispose(pItem); +end; + +constructor TTileBitmapCache.Create(Capacity: Integer); +begin + FCache := TList.Create; + FCache.Capacity := Capacity; +end; + +destructor TTileBitmapCache.Destroy; +begin + while FCache.Count > 0 do + begin + FreeItem(PTileBitmapRec(FCache[0])); + FCache.Delete(0); + end; + FreeAndNil(FCache); +end; + +procedure TTileBitmapCache.Push(const Tile: TTile; Bmp: TBitmap); +begin + if FCache.Count = FCache.Capacity then + begin + FreeItem(PTileBitmapRec(FCache[0])); + FCache.Delete(0); + end; + FCache.Add(NewItem(Tile, Bmp)); +end; + +function TTileBitmapCache.Find(const Tile: TTile): TBitmap; +var idx: Integer; +begin + for idx := 0 to FCache.Count - 1 do + if TilesEqual(Tile, PTileBitmapRec(FCache[idx]).Tile) then + Exit(PTileBitmapRec(FCache[idx]).Bmp); + Result := nil; +end; + +{$ENDREGION} + +{$REGION 'TTileStorage'} + +// CacheSize - capacity of image cache. +constructor TTileStorage.Create(CacheSize: Integer); +begin + FBmpCache := TTileBitmapCache.Create(CacheSize); +end; + +destructor TTileStorage.Destroy; +begin + FreeAndNil(FBmpCache); +end; + +function TTileStorage.GetFromFileCache(const Tile: TTile): TBitmap; +var + png: TPngImage; + Path: string; +begin + Result := nil; + Path := FFileCacheBaseDir + TileToSlippyMapFileSubPath(Tile); + if FileExists(Path) then + begin + png := TPngImage.Create; + png.LoadFromFile(Path); + Result := TBitmap.Create; + Result.Assign(png); + FreeAndNil(png); + end; +end; + +procedure TTileStorage.StoreInFileCache(const Tile: TTile; Ms: TMemoryStream); +var + Path: string; +begin + Path := FFileCacheBaseDir + TileToSlippyMapFileSubPath(Tile); + ForceDirectories(ExtractFileDir(Path)); + Ms.SaveToFile(Path); +end; + +// Try to get tile bitmap, return nil if not available locally. +// If bitmap has been loaded from file, store it in cache +function TTileStorage.GetTile(const Tile: TTile): TBitmap; +begin + // try to load from memory cache + Result := FBmpCache.Find(Tile); + if Result <> nil then + Exit; + + // try to load from disk cache + if not (tsoNoFileCache in FOptions) then + begin + Result := GetFromFileCache(Tile); + if Result <> nil then + FBmpCache.Push(Tile, Result); + end; +end; + +// Add tile PNG to memory and file cache +procedure TTileStorage.StoreTile(const Tile: TTile; Ms: TMemoryStream); +var + png: TPngImage; + bmp: TBitmap; + SavePos: Int64; +begin + png := nil; + try + SavePos := Ms.Position; + // Save to disk as PNG + if ([tsoNoFileCache, tsoReadOnlyFileCache] * FOptions = []) then + StoreInFileCache(Tile, Ms); + Ms.Position := SavePos; + // Convert to bitmap and store in memory cache + png := TPngImage.Create; + png.LoadFromStream(Ms); + Ms.Position := SavePos; + bmp := TBitmap.Create; + bmp.Assign(png); + FBmpCache.Push(Tile, Bmp); + finally + FreeAndNil(png); + end; +end; + +{$ENDREGION} + +end. diff --git a/README.md b/README.md new file mode 100644 index 0000000..045e05d --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +Компонент для отображения карты OpenStreetMap и вспомогательные классы +Демо-проект включает механизм для скачивания карты с сети + +Совместимость: Delphi XE2+, VCL, Windows (на данный момент) + +!! Версия alpha, всё может меняться произвольным образом !! diff --git a/SynapseRequest.pas b/SynapseRequest.pas new file mode 100644 index 0000000..faf58ff --- /dev/null +++ b/SynapseRequest.pas @@ -0,0 +1,85 @@ +{ + Implements blocking HTTP request with Synapse framework. + + based on code by Simon Kroik, 06.2018, kroiksm@gmx.de +} +unit SynapseRequest; + +interface + +uses + SysUtils, Classes, + HTTPSend, SynaUtil, + OSM.NetworkRequest; + +// RequestProps.Additional: Boolean - SendAsMozilla flag +function NetworkRequest(const RequestProps: THttpRequestProps; + const ResponseStm: TStream; out ErrMsg: string): Boolean; + +implementation + +const + SEMsg_HTTPErr = 'HTTP error: %d %s'; + +procedure PrepareHTTPSendAsMozilla(AHTTP: THTTPSend); +begin + AHTTP.UserAgent:='Mozilla/5.0 (Windows NT 6.1; WOW64; rv:51.0) Gecko/20100101 Firefox/51.0'; + AHTTP.Headers.Add('Accept-Language: de,en-US;q=0.7,en;q=0.3'); + AHTTP.Headers.Add('Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8'); +end; + +//------------------------------------------------------------------------------ +//based on Synapse +//For HTTPS-Support: +// 1) USES ssl_openssl; +// 2) copy libeay32.dll +// 3) copy ssleay32.dll +function NetworkRequest(const RequestProps: THttpRequestProps; + const ResponseStm: TStream; out ErrMsg: string): Boolean; +var + HTTP: THTTPSend; +begin + ErrMsg := ''; + + HTTP := THTTPSend.Create; + try + HTTP.UserName := RequestProps.HttpUserName; + HTTP.Password := RequestProps.HttpPassword; + + if RequestProps.RequestType = reqPost then + begin + WriteStrToStream(HTTP.Document, RawByteString(RequestProps.POSTData)); + HTTP.MimeType := 'application/x-www-form-urlencoded'; + end; + + if Boolean(RequestProps.Additional) then + PrepareHTTPSendAsMozilla(HTTP); + + if Assigned(RequestProps.HeaderLines) then + HTTP.Headers.AddStrings(RequestProps.HeaderLines); + + if RequestProps.RequestType = reqPost then + Result := HTTP.HTTPMethod('POST', RequestProps.URL) + else + Result := HTTP.HTTPMethod('GET', RequestProps.URL); + + // check network error + if not Result then + begin + ErrMsg := HTTP.Sock.LastErrorDesc; + Exit; + end; + // check HTTP error + if HTTP.ResultCode <> 200 then + begin + ErrMsg := Format(SEMsg_HTTPErr, [HTTP.ResultCode, HTTP.ResultString]); + Exit; + end; + // OK + ResponseStm.CopyFrom(HTTP.Document, 0); + finally + FreeAndNil(HTTP); + end; +end; + +end. diff --git a/WinInetRequest.pas b/WinInetRequest.pas new file mode 100644 index 0000000..cb03cee --- /dev/null +++ b/WinInetRequest.pas @@ -0,0 +1,65 @@ +{ + Implements blocking HTTP request with WinInet. +} +unit WinInetRequest; + +interface + +uses + SysUtils, Classes, Windows, WinInet, + OSM.NetworkRequest; + +// Only GET requests. No auth fields used. +function NetworkRequest(const RequestProps: THttpRequestProps; + const ResponseStm: TStream; out ErrMsg: string): Boolean; + +implementation + +const + SEMsg_UnsuppReqType = 'Only GET request type supported'; + +function NetworkRequest(const RequestProps: THttpRequestProps; + const ResponseStm: TStream; out ErrMsg: string): Boolean; +var + hInet: HINTERNET; + Headers: string; + Buf: array[0..1024-1] of Byte; + read: DWORD; + hFile: HINTERNET; +begin + ErrMsg := ''; Result := False; hInet := nil; hFile := nil; + + try try + if RequestProps.RequestType <> reqGet then + raise Exception.Create(SEMsg_UnsuppReqType); + // Init WinInet + hInet := InternetOpen('Foo', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0); + if hInet = nil then + raise Exception.Create(SysErrorMessage(GetLastError)); + // Open address + if RequestProps.HeaderLines <> nil then + Headers := RequestProps.HeaderLines.Text; + hFile := InternetOpenUrl(hInet, PChar(RequestProps.URL), PChar(Headers), 0, + INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_NO_COOKIES or INTERNET_FLAG_NO_UI, + 0); + if hFile = nil then + raise Exception.Create(SysErrorMessage(GetLastError)); + + // Read the URL + while InternetReadFile(hFile, @Buf, SizeOf(Buf), read) do + begin + if read = 0 then Break; + ResponseStm.Write(Buf, read); + end; + + Result := True; + except on E: Exception do + ErrMsg := E.Message; + end; + finally + InternetCloseHandle(hFile); + InternetCloseHandle(hInet); + end; +end; + +end.