Merge branch 'maps_zoom_level'

GCS: basic support for higher resolution background maps * specify max map zoom level with -maps_zoom option - defaults to 18, max is 22 * Only a startup parameter for now, not changeable at runtime. * If only lower res tile cache, try http according to policy. * Lower resolution are displayed behind higher resolution.
2026-06-05 23:49:00 +08:00 · 2013-03-24 13:00:33 +01:00
parent 1740fbf8de 2ca78d11be
commit 7e02b677b5
7 changed files with 117 additions and 80 deletions
@@ -174,10 +174,11 @@ end
 (************ Google, OSM Maps handling *****************************************)
 module GM = struct
  (** Fill the visible background with Google, OSM tiles *)
+  let zoomlevel = ref 18
  let fill_tiles = fun geomap ->
    match geomap#georef with
      None -> ()
-    | Some _ -> TodoList.add (fun () -> MapGoogle.fill_window geomap)
+    | Some _ -> TodoList.add (fun () -> MapGoogle.fill_window geomap !zoomlevel)

  let auto = ref false
  let update = fun geomap ->
@@ -197,7 +198,7 @@ module GM = struct
           posn_long = min geo1.posn_long geo2.posn_long }
    and ne = { posn_lat = max geo1.posn_lat geo2.posn_lat;
           posn_long = max geo1.posn_long geo2.posn_long } in
-    let pix = MapGoogle.pixbuf sw ne in
+    let pix = MapGoogle.pixbuf sw ne !zoomlevel in
    let nw = { posn_lat = ne.posn_lat; posn_long = sw.posn_long }
    and se = { posn_lat = sw.posn_lat; posn_long = ne.posn_long } in
    save_map geomap ~projection:"Mercator" pix nw se
@@ -277,7 +278,7 @@ let button_press = fun (geomap:G.widget) ev ->
    and display_gm = fun () ->
      TodoList.add
    (fun () ->
-      try ignore (MapGoogle.display_tile geomap wgs84) with
+      try ignore (MapGoogle.display_tile geomap wgs84 !GM.zoomlevel) with
        Gm.Not_available -> ()) in

    let m = if !ign then [`I ("Load IGN tile", display_ign)] else [] in
@@ -286,7 +287,7 @@ let button_press = fun (geomap:G.widget) ev ->
    (`I ("Load BDORTHO", display_bdortho geomap wgs84))::m
      else
    m in
-    GToolbox.popup_menu ~entries:([`I ("Load Google tile", display_gm)]@m)
+    GToolbox.popup_menu ~entries:([`I ("Load background tile", display_gm)]@m)
      ~button:3 ~time:(Int32.of_int 0);
    true
  end else if GdkEvent.Button.button ev = 1 && Gdk.Convert.test_modifier `CONTROL state then
@@ -347,6 +348,7 @@ let options =
   "-edit", Arg.Unit (fun () -> edit := true; layout_file := "editor.xml"), "Flight plan editor";
   "-fullscreen", Arg.Set fullscreen, "Fullscreen window";
   "-maps_fill", Arg.Set GM.auto, "Automatically start loading background maps";
+   "-maps_zoom", Arg.Set_int GM.zoomlevel, "Background maps zoomlevel (default: 18, max: 22)";
   "-ign", Arg.String (fun s -> ign:=true; IGN.data_path := s), "IGN tiles path";
   "-lambertIIe", Arg.Unit (fun () -> projection:=G.LambertIIe),"Switch to LambertIIe projection";
   "-layout", Arg.Set_string layout_file, (sprintf "<XML layout specification> GUI layout. Default: %s" !layout_file);
@@ -470,7 +472,7 @@ let create_geomap = fun switch_fullscreen editor_frame ->
  (** Separate from A/C menus *)
  ignore (geomap#factory#add_separator ());

-  (** Set the initial soom *)
+  (** Set the initial zoom *)
  geomap#zoom !zoom;
  geomap, menu_fact

@@ -28,7 +28,8 @@ open Latlong
 open Printf

 let tile_size = 256, 256
-let zoom_max = 18
+let zoom_max = 22
+let zoom_min = 18

 let cache_path = ref "/var/tmp"

@@ -39,10 +40,10 @@ type tile_t = {
    height : float (* Latitude difference *)
  }

-type maps_source = Google | OSM | MS
-let maps_sources = [Google; OSM; MS]
+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 -> "OSM" | MS -> "MS"
+    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
@@ -78,8 +79,12 @@ let gm_pos_and_scale = fun keyholeString tLat latHeight tLon lonWidth ->

 (** 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 wgs84 zoom ->
-  let zoom = zoom_max - zoom in
+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
@@ -150,16 +155,20 @@ let is_prefix = fun a b ->
 (** 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)
+        (tile_of_key fi_key, dir // fi)
      else
-    loop (i+1)
+        loop (i+1)
    else
-      raise Not_found in
+      raise Not_found
+    in
  loop 0

 (** Translate the old quadtree naming policy into new (x,y) coordinates
@@ -202,6 +211,8 @@ let url_of_tile_key = fun maps_source s ->
  match maps_source with
    Google -> sprintf "http://khm0.google.com/kh/v=%d&x=%d&s=&y=%d&z=%d" google_version 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
@@ -215,6 +226,8 @@ let url_of_tile_key = fun maps_source s ->
 let get_cache_dir = function
    Google -> !cache_path (* Historic ! Should be // Google *)
  | OSM -> !cache_path // "OSM"
+  | MQ -> !cache_path // "MapQuest"
+  | MQ_Aerial -> !cache_path // "MapQuestAerial"
  | MS -> !cache_path // "MS"


@@ -238,30 +251,35 @@ let remove_last_char = fun s -> String.sub s 0 (String.length s - 1)
 let get_image = fun 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;
-    get_from_cache cache_dir key
+    let (t, f) = get_from_cache cache_dir 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;
-        let rec loop = 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 _ -> loop (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
-        loop key
+  | Not_found ->
+      if !policy = NoHttp then raise Not_available;
+      get_from_http key


 let rec get_tile = fun wgs84 zoom ->
@@ -23,6 +23,8 @@
 *)

 val tile_size : int * int
+val zoom_max : int
+val zoom_min : int
 val tile_coverage : float -> int -> float * float
 (** [tile_coverage wgs84_lat zoom] Returns (width,height) *)

@@ -33,14 +35,14 @@ type tile_t = {
    height : float (* Latitude difference *)
  }

-type maps_source = Google | OSM | MS
+type maps_source = Google | OSM | MS | MQ | MQ_Aerial
 val string_of_maps_source : maps_source -> string
 val maps_sources : maps_source list
 val set_maps_source : maps_source -> unit
 val get_maps_source : unit -> maps_source
 (** Initialized to Google *)

-val tile_of_geo : Latlong.geographic -> int -> tile_t
+val tile_of_geo : ?level:int -> Latlong.geographic -> int -> tile_t
 (** [tile_string geo zoom] Returns the tile description containing a
  given point with a the smallest available zoom greater or equal to [zoom]. *)

@@ -152,6 +152,8 @@ class basic_widget = fun ?(height=800) ?width ?(projection = Mercator) ?georef (
  let canvas = GnoCanvas.canvas ~packing:(frame#pack ~expand:true) () in
  let background = GnoCanvas.group canvas#root
  and still = GnoCanvas.group canvas#root in
+  (* create several layers of canvas group to display the map in correct order *)
+  let maps = Array.init (Gm.zoom_max - Gm.zoom_min + 1) (fun _ -> GnoCanvas.group background) in
  let view_cbs = Hashtbl.create 3 in (* Store for view event callback *)
  let region_rectangle = GnoCanvas.rect canvas#root ~props:[`WIDTH_PIXELS 2; `OUTLINE_COLOR "red"] in

@@ -184,6 +186,7 @@ class basic_widget = fun ?(height=800) ?width ?(projection = Mercator) ?georef (
    method toolbar = toolbar
    method background = background
    method still = still
+    method maps = maps
    method top_still = 3.5*.s
    method utc_time = utc_time
    method set_utc_time = fun h m s ->
@@ -373,14 +376,23 @@ class basic_widget = fun ?(height=800) ?width ?(projection = Mercator) ?georef (
      self#of_world (xw, yw)


-    method display_pixbuf = fun ?opacity ((x1,y1), geo1) ((x2,y2), geo2) image ->
+    method display_pixbuf = fun ?opacity ?level ((x1,y1), geo1) ((x2,y2), geo2) image ->
      let x1 = float x1 and x2 = float x2
      and y1 = float y1 and y2 = float y2 in
      let image =
 	match opacity with
 	  None -> image
 	| Some o -> set_opacity image o in
-      let pix = GnoCanvas.pixbuf ~x:(-.x1) ~y:(-.y1)~pixbuf:image ~props:[`ANCHOR `NW] background in
+      let map_layer = match level with
+        | None -> 0
+        | Some l ->
+            if l > Gm.zoom_max then
+              Array.length maps - 1
+            else if l < Gm.zoom_min then
+              0
+            else l - Gm.zoom_min
+      in
+      let pix = GnoCanvas.pixbuf ~x:(-.x1) ~y:(-.y1) ~pixbuf:image ~props:[`ANCHOR `NW] maps.(map_layer) in
      let xw1, yw1 = self#world_of geo1
      and xw2, yw2 = self#world_of geo2 in

@@ -43,6 +43,7 @@ class widget :
      float * float -> float -> float -> float -> GnoCanvas.line
    method background : GnoCanvas.group
    method background_event : GnoCanvas.item_event -> bool
+    method maps : GnoCanvas.group array
    method canvas : GnoCanvas.canvas
    method center : Latlong.geographic -> unit
    method circle :
@@ -57,6 +58,7 @@ class widget :
    method display_group : string -> unit
    method display_pixbuf :
      ?opacity:int ->
+      ?level:int ->
      (int * int) * Latlong.geographic ->
      (int * int) * Latlong.geographic -> GdkPixbuf.pixbuf -> GnoCanvas.pixbuf
    method display_xy : string -> unit
@@ -72,7 +72,7 @@ let add_tile = fun tile_key ->
  loop 0 [|gm_tiles|] 0


-let display_the_tile = fun (geomap:MapCanvas.widget) tile jpg_file ->
+let display_the_tile = fun (geomap:MapCanvas.widget) tile jpg_file level ->
  let south_lat = tile.Gm.sw_corner.LL.posn_lat
  and west_long = tile.Gm.sw_corner.LL.posn_long in
  let north_lat = south_lat +. tile.Gm.height
@@ -83,7 +83,7 @@ let display_the_tile = fun (geomap:MapCanvas.widget) tile jpg_file ->
  try
    let pixbuf = GdkPixbuf.from_file jpg_file in
    ignore (GMain.Idle.add (fun () ->
-      let map = geomap#display_pixbuf ((0,tx), tile.Gm.sw_corner) ((ty,0),ne) pixbuf in
+      let map = geomap#display_pixbuf ((0,tx), tile.Gm.sw_corner) ((ty,0),ne) pixbuf ~level in
      map#raise 1;
      false));
    add_tile tile.Gm.key
@@ -97,19 +97,19 @@ let display_the_tile = fun (geomap:MapCanvas.widget) tile jpg_file ->


 (** Displaying the tile around the given point *)
-let display_tile = fun (geomap:MapCanvas.widget) wgs84 ->
-  let desired_tile = Gm.tile_of_geo wgs84 1 in
+let display_tile = fun (geomap:MapCanvas.widget) wgs84 level ->
+  let desired_tile = Gm.tile_of_geo ~level wgs84 1 in

  let key = desired_tile.Gm.key in
  if not (mem_tile key) then
-    let (tile, jpg_file) = Gm.get_tile wgs84 1 in
-    display_the_tile geomap tile jpg_file
+    let (tile, jpg_file) = Gm.get_image key in
+    display_the_tile geomap tile jpg_file (String.length tile.Gm.key)


 exception New_displayed of int
 (** [New_displayed zoom] Raised when a new is loadded *)

-let fill_window = fun (geomap:MapCanvas.widget) ->
+let fill_window = fun (geomap:MapCanvas.widget) zoomlevel ->
  (** First estimate the coverage of the window *)
  let width_c, height_c = Gdk.Drawable.get_size geomap#canvas#misc#window
  and (xc0, yc0) = geomap#canvas#get_scroll_offsets in
@@ -130,35 +130,36 @@ let fill_window = fun (geomap:MapCanvas.widget) ->
    if not (twest > east || (twest+.tsize < west && (east < 1. (* Standard case *) || twest+.2.>east (* Over 180° *))) || tsouth > north || tsouth+.tsize < south) then
      let tsize2 = tsize /. 2. in
      try
-	match trees.(i) with
-	  Tile -> ()
-	| Empty ->
-	    if zoom = 1 then
-	      let tile, image = Gm.get_image key in
-	      display_the_tile geomap tile image;
-	      raise (New_displayed (19-String.length tile.Gm.key))
-	    else begin
-	      trees.(i) <- Node (Array.create 4 Empty);
-	      loop twest tsouth tsize trees i zoom key
-	    end
-	| Node sons ->
-	    let continue = fun j tw ts ->
-	      loop tw ts tsize2 sons j (zoom-1) (key^String.make 1 (char_of j)) in
+        match trees.(i) with
+          Tile -> ()
+        | Empty ->
+            if zoom = 1 then
+              let tile, image = Gm.get_image key in
+              let level = String.length tile.Gm.key in
+              display_the_tile geomap tile image level;
+              raise (New_displayed (zoomlevel+1-String.length tile.Gm.key))
+            else begin
+              trees.(i) <- Node (Array.create 4 Empty);
+              loop twest tsouth tsize trees i zoom key
+            end
+        | Node sons ->
+            let continue = fun j tw ts ->
+              loop tw ts tsize2 sons j (zoom-1) (key^String.make 1 (char_of j)) in

-	    continue 0 twest (tsouth+.tsize2);
-	    continue 1 (twest+.tsize2) (tsouth+.tsize2);
-	    continue 2 (twest+.tsize2) tsouth;
-	    continue 3 twest tsouth;
+            continue 0 twest (tsouth+.tsize2);
+            continue 1 (twest+.tsize2) (tsouth+.tsize2);
+            continue 2 (twest+.tsize2) tsouth;
+            continue 3 twest tsouth;

-	    (* If the current node is complete, replace it by a Tile *)
-	    if array_forall (fun x -> x = Tile) sons then begin
-	      trees.(i) <- Tile
-	    end
+            (* If the current node is complete, replace it by a Tile *)
+            if array_forall (fun x -> x = Tile) sons then begin
+              trees.(i) <- Tile
+            end
      with
-	New_displayed z when z = zoom ->
-	  trees.(i) <- Tile
+        New_displayed z when z = zoom ->
+          trees.(i) <- Tile
      | Gm.Not_available -> () in
-  loop (-1.) (-1.)  2. [|gm_tiles|] 0 18 "t"
+  loop (-1.) (-1.)  2. [|gm_tiles|] 0 zoomlevel "t"


 exception To_copy of int * string
@@ -172,7 +173,7 @@ let gdk_pixbuf_safe_copy_area ~dest ~dest_x ~dest_y ~width ~height ~src_x ~src_y
  and height = min height (GdkPixbuf.get_height dest -dest_y) in
  GdkPixbuf.copy_area ~dest ~dest_x ~dest_y ~width ~height ~src_x ~src_y pixbuf

-let pixbuf = fun sw ne ->
+let pixbuf = fun sw ne zoomlevel->
  assert (sw.LL.posn_lat < ne.LL.posn_lat);
  assert (sw.LL.posn_long < ne.LL.posn_long);
  let west = sw.LL.posn_long /. LL.pi
@@ -191,7 +192,7 @@ let pixbuf = fun sw ne ->
 	if zoom = 1
 	then
 	  let tile, image = Gm.get_image key in
-	  raise (To_copy (19-String.length tile.Gm.key, image))
+	  raise (To_copy (zoomlevel+1-String.length tile.Gm.key, image))
 	else begin
 	  let continue = fun j tw ts ->
 	    loop tw ts tsize2 (zoom-1) (key^String.make 1 (char_of j)) in
@@ -210,5 +211,5 @@ let pixbuf = fun sw ne ->
 	  let pixbuf = GdkPixbuf.from_file image in
 	  gdk_pixbuf_safe_copy_area ~dest ~dest_x ~dest_y ~width ~height:width ~src_x ~src_y pixbuf
      | Gm.Not_available -> () in
-  loop (-1.) (-1.)  2. 18 "t";
+  loop (-1.) (-1.)  2. zoomlevel "t";
  dest
@@ -22,11 +22,11 @@
 *
 *)

-val display_tile : MapCanvas.widget -> Latlong.geographic -> unit
-(** Displaying the Google Maps tile around the given point (zoom=1) *)
+val display_tile : MapCanvas.widget -> Latlong.geographic -> int -> unit
+(** Displaying the Google Maps tile around the given point (zoom=1) up to max level *)

-val fill_window : MapCanvas.widget -> unit
-(** Filling the canvas window with Google Maps tiles *)
+val fill_window : MapCanvas.widget -> int -> unit
+(** Filling the canvas window with Google Maps tiles at given zoomlevel*)

-val pixbuf : Latlong.geographic -> Latlong.geographic -> GdkPixbuf.pixbuf
-(** [pixbuf south_west north_east] Returns a map background of the given area *)
+val pixbuf : Latlong.geographic -> Latlong.geographic -> int -> GdkPixbuf.pixbuf
+(** [pixbuf south_west north_east zoomlevel] Returns a map background of the given area *)