/
gm.ml
315 lines (269 loc) · 9.27 KB
/
gm.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
(*
* Google Maps utilities
*
* Copyright (C) 2004-2006 ENAC, Pascal Brisset, Antoine Drouin
*
* This file is part of paparazzi.
*
* paparazzi is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* paparazzi 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 General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with paparazzi; see the file COPYING. If not, write to
* the Free Software Foundation, 59 Temple Place - Suite 330,
* Boston, MA 02111-1307, USA.
*
*)
let (//) = Filename.concat
open Latlong
open Printf
let tile_size = 256, 256
let zoom_max = 22
let zoom_min = 18
let cache_path = ref "/var/tmp"
type tile_t = {
key : string;
sw_corner : Latlong.geographic;
width : float; (* Longitude difference *)
height : float (* Latitude difference *)
}
type maps_source = Google | OSM | MS | MQ | MQ_Aerial
let maps_sources = [Google; OSM; MS; MQ; MQ_Aerial]
let string_of_maps_source = function
Google -> "Google" | OSM -> "OpenStreetMap" | MS -> "Bing" | MQ -> "MapQuest OSM" | MQ_Aerial -> "MapQuest Open Aerial"
let maps_source = ref Google
let set_maps_source = fun s -> maps_source := s
let get_maps_source = fun () -> !maps_source
let mkdir = fun d ->
if not (Sys.file_exists d) then
Unix.mkdir d 0o755
let (/.=) r x = r := !r /. x
let (+.=) r x = r := !r +. x
let inv_norm_lat = fun l -> Latlong.inv_mercator_lat (l *. pi)
let norm_lat = fun l -> Latlong.mercator_lat l /. pi
let tile_coverage = fun lat zoom ->
let normed_size = 2. /. (2. ** (float (zoom_max-zoom))) in
let normed_lat = norm_lat lat in
let normed_lat' = normed_lat +. normed_size in
let lat' = inv_norm_lat normed_lat' in
(normed_size, lat' -. lat)
let gm_pos_and_scale = fun keyholeString tLat latHeight tLon lonWidth ->
let bot_lat = inv_norm_lat tLat in
let top_lat = inv_norm_lat (tLat +. latHeight) in
let bottom_left = make_geo bot_lat (tLon *. pi) in
{ key = keyholeString;
sw_corner = bottom_left;
width = lonWidth *. pi;
height = top_lat -. bot_lat }
(** Returns a keyhole string for a longitude (x), latitude (y), and zoom
for Google Maps (http://www.ponies.me.uk/maps/GoogleTileUtils.java) *)
let tile_of_geo = fun ?level wgs84 zoom ->
let max = match level with
| None -> zoom_max
| Some l -> if l < zoom_min then zoom_min else if l > zoom_max then zoom_max else l
in
let zoom = max - zoom in
(* first convert the lat lon to transverse mercator coordinates *)
let lon = (Rad>>Deg)wgs84.posn_long in
let lon = if lon > 180. then lon -. 180. else lon in
let lon = lon /. 180. in
(* convert latitude to a range -1..+1 *)
let lat = norm_lat wgs84.posn_lat in
let tLat = ref (-1.)
and tLon = ref (-1.)
and latLonSize = ref 2.
and keyholeString = Buffer.create 3 in
Buffer.add_char keyholeString 't';
for i = 0 to zoom - 1 do
latLonSize /.= 2.;
if !tLat +. !latLonSize > lat then
if ((!tLon +. !latLonSize) > lon) then begin
Buffer.add_char keyholeString 't';
end else begin
tLon +.= !latLonSize;
Buffer.add_char keyholeString 's';
end
else begin
tLat +.= !latLonSize;
if ((!tLon +. !latLonSize) > lon) then begin
Buffer.add_char keyholeString 'q';
end
else begin
tLon +.= !latLonSize;
Buffer.add_char keyholeString 'r';
end
end
done;
gm_pos_and_scale (Buffer.contents keyholeString) !tLat !latLonSize !tLon !latLonSize
let tile_of_key = fun keyholeStr ->
assert(keyholeStr.[0] = 't');
let lon = ref (-1.)
and lat = ref (-1.)
and latLonSize = ref 2. in
for i = 1 to String.length keyholeStr - 1 do
latLonSize /.= 2.;
match keyholeStr.[i] with
's' -> lon +.= !latLonSize
| 'r' ->
lat +.= !latLonSize;
lon +.= !latLonSize
| 'q' -> lat +.= !latLonSize
| 't' -> ()
| _ -> invalid_arg ("gm_get_lat_long " ^ keyholeStr)
done;
gm_pos_and_scale keyholeStr !lat !latLonSize !lon !latLonSize
let is_prefix = fun a b ->
String.length b >= String.length a &&
a = String.sub b 0 (String.length a)
(** Get the tile or one which contains it from the cache *)
let get_from_cache = fun dir f ->
let files = Sys.readdir dir in
(* sort files to have the longest names first *)
Array.sort (fun a b -> String.length b - String.length a) files;
let rec loop = fun i ->
if i < Array.length files then
let fi = files.(i) in
let fi_key = try Filename.chop_extension fi with _ -> fi in
(* is it a valid substring ? *)
if fi_key <> "" && is_prefix fi_key f then
(tile_of_key fi_key, dir // fi)
else
loop (i+1)
else
raise Not_found
in
loop 0
(** Get the tile or one which contains it from the a hash table *)
let get_from_hashtbl = fun tbl key ->
let l = String.length key in
let rec loop = fun i ->
if i = 0 then raise Not_found;
try
let subkey = String.sub key 0 i in
let file = Hashtbl.find tbl subkey in
(tile_of_key subkey, file)
with _ -> loop (i-1)
in
loop l
(** Translate the old quadtree naming policy into new (x,y) coordinates
if z is the zoom level, 0 <= x, y < 2^z are the coordinates of the tile *)
let xyz_of_qsrt = fun s ->
let x = ref 0
and y = ref 0
and n = String.length s in
for i = 1 to n - 1 do (* Skip the first t *)
x := !x * 2;
y := !y * 2;
match s.[i] with
'q' -> ()
| 'r' -> incr x
| 's' -> incr x; incr y
| 't' -> incr y
| _ -> failwith "xyz_of_qsrt"
done;
(!x, !y, n-1)
let ms_key = fun key ->
let n = String.length key in
if n = 1 then invalid_arg "Gm.ms_key";
let ms_key = Bytes.create (n-1) in
for i = 1 to n - 1 do
Bytes.set ms_key (i-1)
(match key.[i] with
'q' -> '0'
| 'r' -> '1'
| 's' -> '3'
| 't' -> '2'
| _ -> invalid_arg "Gm.ms_key")
done;
let s = Bytes.to_string ms_key in
(s, s.[n-2])
let url_of_tile_key = fun maps_source s ->
let (x, y, z) = xyz_of_qsrt s in
match maps_source with
Google -> sprintf "http://mt1.google.com/vt/lyrs=s&x=%d&s=&y=%d&z=%d" x y z
| OSM -> sprintf "http://tile.openstreetmap.org/%d/%d/%d.png" z x y
| MQ -> sprintf "http://otile1.mqcdn.com/tiles/1.0.0/osm/%d/%d/%d.png" z x y
| MQ_Aerial -> sprintf "http://otile1.mqcdn.com/tiles/1.0.0/sat/%d/%d/%d.png" z x y
| MS ->
let (key, last_char) = ms_key s in
(* That's the old naming scheme, that still works as of 1st August 2010
sprintf "http://a0.ortho.tiles.virtualearth.net/tiles/a%s.jpeg?g=%d" key (z+32)
*)
(* That's the new code, which conforms to MS naming scheme as of 1st August 2010 *)
sprintf "http://ecn.t%c.tiles.virtualearth.net/tiles/a%s.jpeg?g=516" last_char key
(**)
let get_cache_dir = function
Google -> !cache_path // "Google"
| OSM -> !cache_path // "OSM"
| MQ -> !cache_path // "MapQuest"
| MQ_Aerial -> !cache_path // "MapQuestAerial"
| MS -> !cache_path // "MS"
exception Not_available
type policy = CacheOrHttp | NoHttp | NoCache
let string_of_policy = function
CacheOrHttp -> "CacheOrHttp"
| NoHttp -> "NoHttp"
| NoCache -> "NoCache"
let policies = [CacheOrHttp; NoHttp; NoCache]
let policy = ref CacheOrHttp
let set_policy = fun p ->
policy := p
let get_policy = fun () ->
!policy
let remove_last_char = fun s -> String.sub s 0 (String.length s - 1)
type hashtbl_cache = (string, string) Hashtbl.t
let get_hashtbl_of_cache = fun () ->
let cache_dir = get_cache_dir !maps_source in
mkdir cache_dir;
let files = Sys.readdir cache_dir in
let tbl = Hashtbl.create (Array.length files) in
Array.iter (fun e ->
let key = try Filename.chop_extension e with _ -> e in
if key <> "" then Hashtbl.add tbl key (cache_dir // e);
) files;
tbl
let get_image = fun ?tbl key ->
let cache_dir = get_cache_dir !maps_source in
mkdir cache_dir;
let rec get_from_http = fun k ->
if String.length k >= 1 then
let url = url_of_tile_key !maps_source k in
let jpg_file = cache_dir // (k ^ ".jpg") in
try
ignore (Http.file_of_url ~dest:jpg_file url);
tile_of_key k, jpg_file
with
Http.Not_Found _ -> get_from_http (remove_last_char k)
| Http.Blocked _ ->
begin
prerr_endline (Printf.sprintf "Seem to be temporarily blocked, '%s'" url);
raise Not_available
end
| _ -> raise Not_available
else
raise Not_available
in
try
if !policy = NoCache then raise Not_found;
let (t, f) = match tbl with
| None -> get_from_cache cache_dir key
| Some ht -> get_from_hashtbl ht key
in
(* if not exact match from cache, try http if CacheOrHttp policy *)
if !policy = CacheOrHttp && (String.length t.key < String.length key) then
try get_from_http key with _ -> (t, f)
else (t, f)
with
| Not_found ->
if !policy = NoHttp then raise Not_available;
get_from_http key
let rec get_tile = fun wgs84 zoom ->
let tile = tile_of_geo wgs84 zoom in
get_image tile.key