mirror of
https://github.com/paparazzi/paparazzi.git
synced 2026-05-21 20:04:09 +08:00
Editing in map2d
This commit is contained in:
Pascal Brisset
@@ -320,8 +320,9 @@ let float_attrib = fun x a -> float_of_string (Xml.attrib x a)
|
||||
|
||||
|
||||
let load_mission_xml = fun root zoomadj xml ->
|
||||
let xml_tree_view = XmlEdit.create (Dtd.parse_file dtd) xml in
|
||||
let xml_tree_view, window = XmlEdit.create (Dtd.parse_file dtd) xml in
|
||||
let xml_root = XmlEdit.root xml_tree_view in
|
||||
window#show ();
|
||||
let wpts = XmlEdit.child xml_root "waypoints" in
|
||||
|
||||
Ref.set (float_attrib xml "lat0") (float_attrib xml "lon0");
|
||||
|
||||
@@ -1,5 +1,5 @@
|
||||
OCAMLC=ocamlc
|
||||
OCAMLOPT=ocamlopt
|
||||
OCAMLC=ocamlc -thread
|
||||
OCAMLOPT=ocamlopt -thread
|
||||
INCLUDES=-I +lablgtk2 -I +camlimages -I ../../lib/ocaml
|
||||
LIBS=glibivy-ocaml.cma lablgtk.cma ci_core.cma ci_png.cma ci_gif.cma ci_jpeg.cma ci_tiff.cma ci_bmp.cma ci_ppm.cma ci_ps.cma lib-pprz.cma lablgnomecanvas.cma xlib-pprz.cma
|
||||
CMXA=$(LIBS:.cma=.cmxa)
|
||||
@@ -11,19 +11,19 @@ opt : map2d.opt
|
||||
|
||||
|
||||
map2d : map2d.ml ../../lib/ocaml/lib-pprz.cma ../../lib/ocaml/xlib-pprz.cma
|
||||
$(OCAMLC) -thread -custom $(INCLUDES) $(LIBS) threads.cma gtkThread.cmo gtkInit.cmo $< -o $@
|
||||
$(OCAMLC) -custom $(INCLUDES) $(LIBS) threads.cma gtkThread.cmo gtkInit.cmo $< -o $@
|
||||
|
||||
map2d.opt : map2d.cmx
|
||||
$(OCAMLOPT) $(INCLUDES) str.cmxa unix.cmxa xml-light.cmxa $(LIBS:.cma=.cmxa) gtkInit.cmx $< -o $@
|
||||
$(OCAMLOPT) $(INCLUDES) str.cmxa unix.cmxa xml-light.cmxa $(LIBS:.cma=.cmxa) threads.cmxa gtkInit.cmx $< -o $@
|
||||
|
||||
|
||||
.SUFFIXES: .ml .mli .cmo .cmi .cmx
|
||||
|
||||
.ml.cmo:
|
||||
%.cmo: %.ml
|
||||
$(OCAMLC) $(INCLUDES) -labels -w s -c $<
|
||||
.mli.cmi:
|
||||
%.cmi: %.ml
|
||||
$(OCAMLC) $(INCLUDES) -labels -w s -c $<
|
||||
.ml.cmx:
|
||||
%.cmx: %.ml
|
||||
$(OCAMLOPT) $(INCLUDES) -labels -w s -c $<
|
||||
|
||||
clean:
|
||||
|
||||
+255
-104
@@ -31,10 +31,10 @@ module Ground_Pprz = Pprz.Protocol(struct let name = "ground" end)
|
||||
|
||||
let float_attr = fun xml a -> float_of_string (ExtXml.attrib xml a)
|
||||
let int_attr = fun xml a -> int_of_string (ExtXml.attrib xml a)
|
||||
|
||||
type color = string
|
||||
|
||||
let soi = string_of_int
|
||||
let sof = string_of_float
|
||||
let list_separator = Str.regexp ","
|
||||
|
||||
(*** parameters used for creating the vertical display window
|
||||
@@ -51,17 +51,33 @@ let home = Env.paparazzi_home
|
||||
let (//) = Filename.concat
|
||||
let default_path_srtm = home // "data" // "srtm"
|
||||
let default_path_maps = home // "data" // "maps" // ""
|
||||
let path_fps = home // "conf" // "flight_plans" // ""
|
||||
let fp_dtd = path_fps // "flight_plan.dtd"
|
||||
let var_maps_path = home // "var" // "maps"
|
||||
let _ =
|
||||
ignore (Sys.command (sprintf "mkdir -p %s" var_maps_path))
|
||||
let fp_example = path_fps // "example.xml"
|
||||
|
||||
let labelled_entry = fun text value h ->
|
||||
let _ = GMisc.label ~text ~packing:h#add () in
|
||||
GEdit.entry ~text:value ~packing:h#add ()
|
||||
|
||||
|
||||
|
||||
(** Dummy flight plan *)
|
||||
let dummy_fp = fun latlong ->
|
||||
Xml.Element("flight_plan",
|
||||
["lat0", sof ((Rad>>Deg)latlong.posn_lat);
|
||||
"lon0", sof ((Rad>>Deg)latlong.posn_long);
|
||||
"alt", "42.";
|
||||
"MAX_DIST_FROM_HOME", "1000."
|
||||
],
|
||||
[Xml.Element("waypoints", [],[])])
|
||||
|
||||
type aircraft = {
|
||||
config : Pprz.values;
|
||||
track : MapTrack.track;
|
||||
color: color;
|
||||
mutable fp_group : (MapWaypoints.group * (int * MapWaypoints.waypoint) list) option;
|
||||
fp_group : MapFP.flight_plan;
|
||||
fp : Xml.xml;
|
||||
dl_settings : GWindow.window
|
||||
}
|
||||
@@ -72,7 +88,6 @@ let set_georef_if_none = fun geomap wgs84 ->
|
||||
match geomap#georef with
|
||||
None -> geomap#set_georef wgs84
|
||||
| Some _ -> ()
|
||||
|
||||
|
||||
|
||||
let display_map = fun (geomap:G.widget) xml_map ->
|
||||
@@ -106,41 +121,22 @@ let display_map = fun (geomap:G.widget) xml_map ->
|
||||
| _ -> failwith (sprintf "display_map: two ref points required")
|
||||
|
||||
|
||||
let load_map = fun geomap () ->
|
||||
let load_map = fun (geomap:G.widget) () ->
|
||||
match GToolbox.select_file ~title:"Open Map" ~filename:(default_path_maps^"*.xml") () with
|
||||
None -> ()
|
||||
| Some f -> display_map geomap f
|
||||
|
||||
|
||||
let load_mission = fun color geomap xml ->
|
||||
(** FIXME : also in MapFP.ml *)
|
||||
let georef_of_fp = fun xml ->
|
||||
let lat0 = float_attr xml "lat0"
|
||||
and lon0 = float_attr xml "lon0"
|
||||
and alt0 = float_attr xml "alt" in
|
||||
let ref_wgs84 = {posn_lat = (Deg>>Rad)lat0; posn_long = (Deg>>Rad)lon0 } in
|
||||
let utm0 = utm_of WGS84 ref_wgs84 in
|
||||
let waypoints = ExtXml.child xml "waypoints" in
|
||||
let max_dist_from_home = float_attr xml "MAX_DIST_FROM_HOME" in
|
||||
|
||||
set_georef_if_none geomap ref_wgs84;
|
||||
|
||||
let wgs84_of_xy = fun x y ->
|
||||
Latlong.of_utm WGS84 (utm_add utm0 (x, y) ) in
|
||||
|
||||
let fp = new MapWaypoints.group ~color ~editable:true geomap in
|
||||
let i = ref 0 in
|
||||
let wpts = List.map
|
||||
(fun wp ->
|
||||
let wgs84 = wgs84_of_xy (float_attr wp "x") (float_attr wp "y") in
|
||||
let alt = try float_attr wp "alt" with _ -> alt0 in
|
||||
let w = MapWaypoints.waypoint fp ~name:(ExtXml.attrib wp "name") ~alt wgs84 in
|
||||
if ExtXml.attrib wp "name" = "HOME" then
|
||||
ignore (geomap#circle ~color wgs84 max_dist_from_home);
|
||||
incr i;
|
||||
!i, w
|
||||
)
|
||||
(Xml.children waypoints) in
|
||||
fp, wpts
|
||||
and lon0 = float_attr xml "lon0" in
|
||||
{posn_lat = (Deg>>Rad)lat0; posn_long = (Deg>>Rad)lon0 }
|
||||
|
||||
|
||||
let load_mission = fun color geomap xml ->
|
||||
set_georef_if_none geomap (georef_of_fp xml);
|
||||
new MapFP.flight_plan geomap color fp_dtd xml
|
||||
|
||||
let aircraft_pos_msg = fun track wgs84 heading altitude speed climb ->
|
||||
let h =
|
||||
@@ -166,42 +162,30 @@ let ap_status_msg = fun track flight_time ->
|
||||
track#update_ap_status flight_time
|
||||
|
||||
|
||||
let display_fp = fun geomap ac ->
|
||||
try
|
||||
let ac = Hashtbl.find live_aircrafts ac in
|
||||
ac.fp_group <- Some (load_mission ac.color geomap ac.fp)
|
||||
with Failure x ->
|
||||
GToolbox.message_box ~title:"Error while loading flight plan" x
|
||||
|
||||
|
||||
let show_mission = fun geomap ac on_off ->
|
||||
let a = Hashtbl.find live_aircrafts ac in
|
||||
if on_off then
|
||||
display_fp geomap ac
|
||||
a.fp_group#show ()
|
||||
else
|
||||
let a = Hashtbl.find live_aircrafts ac in
|
||||
match a.fp_group with
|
||||
None -> ()
|
||||
| Some (g, _wpts) ->
|
||||
a.fp_group <- None;
|
||||
g#group#destroy ()
|
||||
a.fp_group#hide ()
|
||||
|
||||
|
||||
let commit_changes = fun ac ->
|
||||
let a = Hashtbl.find live_aircrafts ac in
|
||||
match a.fp_group with
|
||||
Some (_g, wpts) ->
|
||||
List.iter
|
||||
(fun (i, w) ->
|
||||
if w#moved then
|
||||
let wgs84 = w#pos in
|
||||
let vs = ["ac_id", Pprz.String ac;
|
||||
"wp_id", Pprz.Int i;
|
||||
"lat", Pprz.Float ((Rad>>Deg)wgs84.posn_lat);
|
||||
"long", Pprz.Float ((Rad>>Deg)wgs84.posn_long);
|
||||
List.iter
|
||||
(fun w ->
|
||||
let (i, w) = a.fp_group#index w in
|
||||
if w#moved then
|
||||
let wgs84 = w#pos in
|
||||
let vs = ["ac_id", Pprz.String ac;
|
||||
"wp_id", Pprz.Int i;
|
||||
"lat", Pprz.Float ((Rad>>Deg)wgs84.posn_lat);
|
||||
"long", Pprz.Float ((Rad>>Deg)wgs84.posn_long);
|
||||
"alt", Pprz.Float w#alt
|
||||
] in
|
||||
Ground_Pprz.message_send "map2d" "MOVE_WAYPOINT" vs)
|
||||
wpts
|
||||
| _ -> ()
|
||||
] in
|
||||
Ground_Pprz.message_send "map2d" "MOVE_WAYPOINT" vs)
|
||||
a.fp_group#waypoints
|
||||
|
||||
|
||||
let send_event = fun ac e ->
|
||||
Ground_Pprz.message_send "map2d" "SEND_EVENT"
|
||||
@@ -347,7 +331,9 @@ let create_ac = fun (geomap:MapCanvas.widget) ac_id config ->
|
||||
|
||||
let ds = dl_settings ac_id fp_xml in
|
||||
|
||||
Hashtbl.add live_aircrafts ac_id { track = track; color = color; fp_group = None ; config = config ; fp = fp_xml; dl_settings = ds}
|
||||
let fp = load_mission color geomap fp_xml in
|
||||
fp#hide ();
|
||||
Hashtbl.add live_aircrafts ac_id { track = track; color = color; fp_group = fp ; config = config ; fp = fp_xml; dl_settings = ds}
|
||||
|
||||
|
||||
|
||||
@@ -447,24 +433,6 @@ let gm_auto = ref false
|
||||
let active_gm_auto = fun x ->
|
||||
gm_auto := x
|
||||
|
||||
let button_press = fun (geomap:MapCanvas.widget) ev ->
|
||||
if GdkEvent.Button.button ev = 3 then begin
|
||||
let xc = GdkEvent.Button.x ev
|
||||
and yc = GdkEvent.Button.y ev in
|
||||
let (xw,yw) = geomap#window_to_world xc yc in
|
||||
|
||||
let wgs84 = geomap#of_world (xw,yw) in
|
||||
let display = fun geo ->
|
||||
if Gdk.Convert.test_modifier `SHIFT (GdkEvent.Button.state ev) then
|
||||
MapIGN.display_tile geomap geo
|
||||
else
|
||||
try ignore (MapGoogle.display_tile geomap geo) with
|
||||
Gm.Not_available -> () in
|
||||
|
||||
ignore(Thread.create display wgs84)
|
||||
end;
|
||||
false
|
||||
|
||||
|
||||
let fill_gm_tiles = fun geomap ->
|
||||
ignore (Thread.create MapGoogle.fill_window geomap)
|
||||
@@ -472,17 +440,6 @@ let fill_gm_tiles = fun geomap ->
|
||||
let gm_update = fun geomap ->
|
||||
if !gm_auto then fill_gm_tiles geomap
|
||||
|
||||
let file_dialog ?(filename="*.xml") ~title ~callback () =
|
||||
let sel = GWindow.file_selection ~title ~filename ~modal:true () in
|
||||
ignore (sel#cancel_button#connect#clicked ~callback:sel#destroy);
|
||||
ignore
|
||||
(sel#ok_button#connect#clicked
|
||||
~callback:(fun () ->
|
||||
let name = sel#filename in
|
||||
sel#destroy ();
|
||||
callback name));
|
||||
sel#show ()
|
||||
|
||||
let map_from_region = fun (geomap:MapCanvas.widget) () ->
|
||||
match geomap#region with
|
||||
None -> GToolbox.message_box "Error" "Select a region first (drag left button)"
|
||||
@@ -494,20 +451,204 @@ let map_from_region = fun (geomap:MapCanvas.widget) () ->
|
||||
let (x0, y0) = geomap#canvas#get_scroll_offsets in
|
||||
let xc1= xc1 - x0 and yc1 = yc1 - y0 in
|
||||
GdkPixbuf.get_from_drawable ~dest:p ~width ~height ~src_x:xc1 ~src_y:yc1 geomap#canvas#misc#window;
|
||||
file_dialog ~filename:(default_path_maps//".xml") ~title:"Save region map" ~callback:(fun xml_file ->
|
||||
let jpg = Filename.chop_extension xml_file ^ ".png" in
|
||||
GdkPixbuf.save jpg "png" p;
|
||||
let point = fun (x,y) xyw ->
|
||||
let wgs84 = geomap#of_world xyw in
|
||||
Xml.Element ("point", ["x",soi x;"y",soi y;"geo", Latlong.string_of wgs84], []) in
|
||||
let points = [point (0, 0) (xw1,yw1); point (width, height) (xw2,yw2)] in
|
||||
let xml = Xml.Element ("map",
|
||||
["file", Filename.basename jpg;
|
||||
"projection", geomap#projection],
|
||||
match GToolbox.select_file ~filename:(default_path_maps//".xml") ~title:"Save region map" () with
|
||||
None -> ()
|
||||
| Some xml_file ->
|
||||
let jpg = Filename.chop_extension xml_file ^ ".png" in
|
||||
GdkPixbuf.save jpg "png" p;
|
||||
let point = fun (x,y) xyw ->
|
||||
let wgs84 = geomap#of_world xyw in
|
||||
Xml.Element ("point", ["x",soi x;"y",soi y;"geo", Latlong.string_of wgs84], []) in
|
||||
let points = [point (0, 0) (xw1,yw1); point (width, height) (xw2,yw2)] in
|
||||
let xml = Xml.Element ("map",
|
||||
["file", Filename.basename jpg;
|
||||
"projection", geomap#projection],
|
||||
points) in
|
||||
let f = open_out xml_file in
|
||||
Printf.fprintf f "%s\n" (Xml.to_string_fmt xml);
|
||||
close_out f) ()
|
||||
let f = open_out xml_file in
|
||||
Printf.fprintf f "%s\n" (Xml.to_string_fmt xml);
|
||||
close_out f
|
||||
|
||||
|
||||
module Edit = struct
|
||||
(** Editing of ONE single flight plan *)
|
||||
let current_fp = ref None
|
||||
|
||||
(** Wrapper checking there is currently no flight plan loaded *)
|
||||
let if_none = fun f ->
|
||||
match !current_fp with
|
||||
Some _ -> GToolbox.message_box "Error" "Only one editable flight plan at a time"
|
||||
| None -> f ()
|
||||
|
||||
|
||||
let load_xml_fp = fun geomap ?(xml_file=path_fps) xml ->
|
||||
set_georef_if_none geomap (georef_of_fp xml);
|
||||
let fp = new MapFP.flight_plan geomap "red" fp_dtd xml in
|
||||
fp#show_xml ();
|
||||
current_fp := Some (fp,xml_file);
|
||||
fp
|
||||
|
||||
|
||||
let new_fp = fun geomap () ->
|
||||
if_none (fun () ->
|
||||
let dialog = GWindow.window ~border_width:10 ~title:"New flight plan" () in
|
||||
let dvbx = GPack.box `VERTICAL ~packing:dialog#add () in
|
||||
let h = GPack.hbox ~packing:dvbx#pack () in
|
||||
let default_latlong =
|
||||
match geomap#georef with
|
||||
None -> "WGS84 37.21098 -113.45678"
|
||||
| Some geo -> Latlong.string_of geo in
|
||||
let latlong = labelled_entry "latlong" default_latlong h in
|
||||
let alt0 = labelled_entry "ground_alt" "380" h in
|
||||
let h = GPack.hbox ~packing:dvbx#pack () in
|
||||
let alt = labelled_entry "alt" "430" h in
|
||||
let qfu = labelled_entry "QFU" "270" h in
|
||||
let mdfh = labelled_entry "Max dist" "500" h in
|
||||
|
||||
let h = GPack.hbox ~packing:dvbx#pack () in
|
||||
let name = labelled_entry "Name" "Test flight" h in
|
||||
|
||||
let h = GPack.hbox ~packing:dvbx#pack () in
|
||||
let createfp = GButton.button ~label:"Create FP" ~packing: h#add () in
|
||||
let cancel = GButton.button ~label:"Close" ~packing: h#add () in
|
||||
ignore(cancel#connect#clicked ~callback:dialog#destroy);
|
||||
ignore(createfp#connect#clicked ~callback:
|
||||
begin fun _ ->
|
||||
let xml = Xml.parse_file fp_example in
|
||||
let s = ExtXml.subst_attrib in
|
||||
let wgs84 = Latlong.of_string latlong#text in
|
||||
let xml = s "lat0" (deg_string_of_rad wgs84.posn_lat) xml in
|
||||
let xml = s "lon0" (deg_string_of_rad wgs84.posn_long) xml in
|
||||
let xml = s "ground_alt" alt0#text xml in
|
||||
let xml = s "qfu" qfu#text xml in
|
||||
let xml = s "alt" alt#text xml in
|
||||
let xml = s "max_dist_from_home" mdfh#text xml in
|
||||
let xml = s "name" name#text xml in
|
||||
ignore (load_xml_fp geomap xml);
|
||||
dialog#destroy ()
|
||||
end);
|
||||
dialog#show ())
|
||||
|
||||
|
||||
(** Loading a flight plan for edition *)
|
||||
let load_fp = fun geomap () ->
|
||||
if_none (fun () ->
|
||||
match GToolbox.select_file ~title:"Open flight plan" ~filename:(path_fps^"*.xml") () with
|
||||
None -> ()
|
||||
| Some xml_file ->
|
||||
let xml = Xml.parse_file xml_file in
|
||||
ignore (load_xml_fp geomap ~xml_file xml))
|
||||
|
||||
let create_wp = fun geomap geo ->
|
||||
match !current_fp with
|
||||
None -> GToolbox.message_box "Error" "Load a flight plan first"
|
||||
| Some (fp,_) ->
|
||||
ignore (fp#add_waypoint geo)
|
||||
|
||||
let close_fp = fun geomap () ->
|
||||
match !current_fp with
|
||||
None -> () (* Nothing to close *)
|
||||
| Some (fp, filename) ->
|
||||
fp#destroy ();
|
||||
current_fp := None
|
||||
|
||||
let save_fp = fun geomap () ->
|
||||
match !current_fp with
|
||||
None -> () (* Nothing to save *)
|
||||
| Some (fp, filename) ->
|
||||
match GToolbox.select_file ~title:"Save Flight Plan" ~filename () with
|
||||
None -> ()
|
||||
| Some file ->
|
||||
let f = open_out file in
|
||||
fprintf f "%s\n" (Xml.to_string_fmt fp#xml);
|
||||
close_out f
|
||||
|
||||
let ref_point_of_waypoint = fun xml ->
|
||||
Xml.Element("point", ["x",Xml.attrib xml "x";
|
||||
"y",Xml.attrib xml "y";
|
||||
"geo", Xml.attrib xml "name"],[])
|
||||
|
||||
(** Calibration of chosen image *)
|
||||
let calibrate_map = fun (geomap:G.widget) () ->
|
||||
match !current_fp with
|
||||
| Some (fp,_) -> GToolbox.message_box "Error" "Close current flight plan before calibration"
|
||||
| None ->
|
||||
match GToolbox.select_file ~filename:default_path_maps ~title:"Open Image" () with
|
||||
None -> ()
|
||||
| Some image ->
|
||||
(** Displaying the image in the NW corner *)
|
||||
let pixbuf = GdkPixbuf.from_file image in
|
||||
let pix = GnoCanvas.pixbuf ~pixbuf ~props:[`ANCHOR `NW] geomap#canvas#root in
|
||||
let (x0, y0) = geomap#canvas#get_scroll_offsets in
|
||||
let (x,y) = geomap#canvas#window_to_world (float x0) (float y0) in
|
||||
pix#move x y;
|
||||
|
||||
(** Open a dummy flight plan *)
|
||||
let dummy_georef =
|
||||
match geomap#georef with
|
||||
None -> {posn_lat = (Deg>>Rad)43.; posn_long = (Deg>>Rad)1. }
|
||||
| Some geo -> geo in
|
||||
let fp_xml = dummy_fp dummy_georef in
|
||||
let fp = load_xml_fp geomap fp_xml in
|
||||
|
||||
(** Dialog to finish calibration *)
|
||||
let dialog = GWindow.window ~border_width:10 ~title:"Map calibration" () in
|
||||
let v = GPack.vbox ~packing:dialog#add () in
|
||||
let _ = GMisc.label ~text:"Choose 2 (or more) waypoints (CTRL Left Button)\nRename the waypoints with their geographic coordinates\nFor example: 'WGS84 43.123456 1.234567' or 'UTM 530134 3987652 12' or 'LBT2e 123456 543210'\nClick the button below to save the XML result file\n" ~packing:v#add () in
|
||||
let h = GPack.hbox ~packing:v#pack () in
|
||||
let cal = GButton.button ~label:"Calibrate" ~packing:h#add () in
|
||||
let cancel = GButton.button ~label:"Close" ~packing:h#add () in
|
||||
let destroy = fun () ->
|
||||
dialog#destroy ();
|
||||
close_fp geomap ();
|
||||
pix#destroy () in
|
||||
ignore(cancel#connect#clicked ~callback:destroy);
|
||||
ignore(cal#connect#clicked ~callback:(fun _ ->
|
||||
let points = List.map XmlEdit.xml_of_node fp#waypoints in
|
||||
let points = List.map ref_point_of_waypoint points in
|
||||
let xml = Xml.Element ("map",
|
||||
["file", Filename.basename image;
|
||||
"projection", geomap#projection],
|
||||
points) in
|
||||
match GToolbox.select_file ~filename:(default_path_maps//".xml") ~title:"Save calibrated map" () with
|
||||
None -> ()
|
||||
| Some xml_file ->
|
||||
let f = open_out xml_file in
|
||||
Printf.fprintf f "%s\n" (Xml.to_string_fmt xml);
|
||||
close_out f));
|
||||
dialog#show ()
|
||||
end (** Edit module *)
|
||||
|
||||
|
||||
|
||||
let button_press = fun (geomap:MapCanvas.widget) ev ->
|
||||
let state = GdkEvent.Button.state ev in
|
||||
if GdkEvent.Button.button ev = 3 then begin
|
||||
(** Display a tile from Google Maps or IGN *)
|
||||
let xc = GdkEvent.Button.x ev
|
||||
and yc = GdkEvent.Button.y ev in
|
||||
let (xw,yw) = geomap#window_to_world xc yc in
|
||||
|
||||
let wgs84 = geomap#of_world (xw,yw) in
|
||||
let display = fun geo ->
|
||||
if Gdk.Convert.test_modifier `SHIFT (GdkEvent.Button.state ev) then
|
||||
MapIGN.display_tile geomap geo
|
||||
else
|
||||
try ignore (MapGoogle.display_tile geomap geo) with
|
||||
Gm.Not_available -> () in
|
||||
|
||||
ignore(Thread.create display wgs84);
|
||||
true;
|
||||
end else if GdkEvent.Button.button ev = 1 && Gdk.Convert.test_modifier `CONTROL state then begin
|
||||
let xc = GdkEvent.Button.x ev in
|
||||
let yc = GdkEvent.Button.y ev in
|
||||
let xyw = geomap#canvas#window_to_world xc yc in
|
||||
let geo = geomap#of_world xyw in
|
||||
Edit.create_wp geomap geo;
|
||||
true
|
||||
end else
|
||||
false
|
||||
|
||||
|
||||
|
||||
|
||||
let _ =
|
||||
@@ -558,6 +699,7 @@ let _ =
|
||||
let map_menu = geomap#factory#add_submenu "Maps" in
|
||||
let map_menu_fact = new GMenu.factory ~accel_group map_menu in
|
||||
ignore (map_menu_fact#add_item "Load" ~key:GdkKeysyms._M ~callback:(load_map geomap));
|
||||
ignore (map_menu_fact#add_item "Calibrate" ~key:GdkKeysyms._C ~callback:(Edit.calibrate_map geomap));
|
||||
ignore (map_menu_fact#add_item "GM Fill" ~key:GdkKeysyms._G ~callback:(fun _ -> fill_gm_tiles geomap));
|
||||
ignore (map_menu_fact#add_check_item "GM Http" ~key:GdkKeysyms._H ~active:true ~callback:active_gm_http);
|
||||
ignore (map_menu_fact#add_check_item "GM Auto" ~active:false ~callback:active_gm_auto);
|
||||
@@ -566,6 +708,15 @@ let _ =
|
||||
(** Connect Google Maps display to view change *)
|
||||
geomap#connect_view (fun () -> gm_update geomap);
|
||||
|
||||
|
||||
(** Flight plan editing *)
|
||||
let fp_menu = geomap#factory#add_submenu "Edit" in
|
||||
let fp_menu_fact = new GMenu.factory ~accel_group fp_menu in
|
||||
ignore (fp_menu_fact#add_item "New flight plan" ~key:GdkKeysyms._N ~callback:(Edit.new_fp geomap));
|
||||
ignore (fp_menu_fact#add_item "Open flight plan" ~key:GdkKeysyms._O ~callback:(Edit.load_fp geomap));
|
||||
ignore (fp_menu_fact#add_item "Save flight plan" ~key:GdkKeysyms._S ~callback:(Edit.save_fp geomap));
|
||||
ignore (fp_menu_fact#add_item "Close flight plan" ~callback:(Edit.close_fp geomap));
|
||||
|
||||
(** Separate from A/C menus *)
|
||||
ignore (geomap#factory#add_separator ());
|
||||
|
||||
|
||||
@@ -30,7 +30,7 @@ SRC = debug.ml env.ml serial.ml ocaml_tools.ml extXml.ml xml2h.ml latlong.ml srt
|
||||
CMO = $(SRC:.ml=.cmo)
|
||||
CMX = $(SRC:.ml=.cmx)
|
||||
|
||||
XSRC = platform.ml gtkgl_Hack.ml ml_gtkgl_hack.o gtk_image.ml gtk_tools_icons.ml gtk_tools.ml gtk_draw.ml gtk_tools_GL.ml gtk_3d.ml mapCanvas.ml mapWaypoints.ml mapTrack.ml mapGoogle.ml mapIGN.ml ml_gtk_drag.o xmlEdit.ml
|
||||
XSRC = platform.ml gtkgl_Hack.ml ml_gtkgl_hack.o gtk_image.ml gtk_tools_icons.ml gtk_tools.ml gtk_draw.ml gtk_tools_GL.ml gtk_3d.ml mapCanvas.ml mapWaypoints.ml mapTrack.ml mapGoogle.ml mapIGN.ml ml_gtk_drag.o xmlEdit.ml mapFP.ml
|
||||
XCMO = $(XSRC:.ml=.cmo)
|
||||
XCMX = $(XSRC:.ml=.cmx)
|
||||
|
||||
|
||||
@@ -55,6 +55,7 @@ class basic_widget = fun ?(height=800) ?width ?(projection = Mercator) ?georef (
|
||||
let background = GnoCanvas.group canvas#root 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
|
||||
|
||||
object (self)
|
||||
|
||||
(** GUI attributes *)
|
||||
@@ -238,7 +239,7 @@ class basic_widget = fun ?(height=800) ?width ?(projection = Mercator) ?georef (
|
||||
let xc = GdkEvent.Button.x ev in
|
||||
let yc = GdkEvent.Button.y ev in
|
||||
match GdkEvent.Button.button ev with
|
||||
1 ->
|
||||
1 when Gdk.Convert.test_modifier `SHIFT (GdkEvent.Button.state ev) ->
|
||||
let (x1,y1) = self#window_to_world xc yc in
|
||||
grouping <- Some (x1,y1);
|
||||
region_rectangle#set [`X1 x1; `Y1 y1; `X2 x1; `Y2 y1];
|
||||
|
||||
@@ -0,0 +1,136 @@
|
||||
(*
|
||||
* $Id$
|
||||
*
|
||||
* Displaying and editing a flight plan on a MapCanvas
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*)
|
||||
|
||||
open Latlong
|
||||
|
||||
let sof = string_of_float
|
||||
let float_attr = fun xml a -> float_of_string (ExtXml.attrib xml a)
|
||||
let rec assoc_nocase at = function
|
||||
[] -> raise Not_found
|
||||
| (a, v)::avs ->
|
||||
if String.uppercase at = String.uppercase a then v else assoc_nocase at avs
|
||||
|
||||
(** Connect a change in the XML editor to the graphical rep *)
|
||||
let update_wp utm_ref wp = function
|
||||
XmlEdit.Deleted -> wp#delete
|
||||
| XmlEdit.New_child _ -> failwith "update_wp"
|
||||
| XmlEdit.Modified attribs ->
|
||||
try
|
||||
let float_attrib = fun a -> float_of_string (assoc_nocase a attribs) in
|
||||
let x = (float_attrib "x") and y = (float_attrib "y") in
|
||||
let wgs84 = Latlong.of_utm WGS84 (utm_add utm_ref (x, y)) in
|
||||
wp#set wgs84;
|
||||
wp#set_name (assoc_nocase "name" attribs)
|
||||
with
|
||||
_ -> ()
|
||||
|
||||
let waypoints_node = fun xml_tree ->
|
||||
let xml_root = XmlEdit.root xml_tree in
|
||||
XmlEdit.child xml_root "waypoints"
|
||||
|
||||
(** Connect a change from the graphical rep to the xml tree *)
|
||||
let update_xml = fun xml_tree utm0 wp ->
|
||||
let xml_wpts = XmlEdit.children (waypoints_node xml_tree) in
|
||||
let node = List.find (fun w -> XmlEdit.attrib w "name" = wp#name) xml_wpts in
|
||||
let utm = utm_of WGS84 (wp#pos) in
|
||||
let (dx, dy) = utm_sub utm utm0 in
|
||||
XmlEdit.set_attribs node ["name",wp#name; "x",sof dx; "y",sof dy; "alt", sof wp#alt]
|
||||
|
||||
let new_wp = fun xml_tree waypoints utm_ref node ->
|
||||
let float_attrib =
|
||||
fun a -> try float_of_string (XmlEdit.attrib node a) with _ -> 0. in
|
||||
let x = (float_attrib "x") and y = (float_attrib "y") in
|
||||
let wgs84 = Latlong.of_utm WGS84 (utm_add utm_ref (x, y)) in
|
||||
let alt = float_attrib "alt" in
|
||||
let name = XmlEdit.attrib node "name" in
|
||||
let wp = MapWaypoints.waypoint waypoints ~name ~alt wgs84 in
|
||||
XmlEdit.connect node (update_wp utm_ref wp);
|
||||
wp#connect (fun () -> update_xml xml_tree utm_ref wp);
|
||||
wp
|
||||
|
||||
let gensym =
|
||||
let x = ref 0 in
|
||||
fun p -> incr x; Printf.sprintf "%s%d" p !x
|
||||
|
||||
|
||||
class flight_plan = fun geomap color fp_dtd xml ->
|
||||
(** Xml Editor *)
|
||||
let xml_tree_view, xml_window = XmlEdit.create (Dtd.parse_file fp_dtd) xml in
|
||||
let xml_root = XmlEdit.root xml_tree_view in
|
||||
let xml_wpts = XmlEdit.child xml_root "waypoints" in
|
||||
|
||||
(** Geographic ref *)
|
||||
let lat0 = float_attr xml "lat0"
|
||||
and lon0 = float_attr xml "lon0"
|
||||
and alt0 = float_attr xml "alt" in
|
||||
let ref_wgs84 = {posn_lat = (Deg>>Rad)lat0; posn_long = (Deg>>Rad)lon0 } in
|
||||
let utm0 = utm_of WGS84 ref_wgs84 in
|
||||
|
||||
(** The graphical waypoints *)
|
||||
let wpts_group = new MapWaypoints.group ~color ~editable:true geomap in
|
||||
|
||||
let yaws = Hashtbl.create 5 in (* Yes Another Waypoints Store *)
|
||||
let create_wp =
|
||||
let i = ref 0 in
|
||||
fun node ->
|
||||
let w = new_wp xml_tree_view wpts_group utm0 node in
|
||||
Hashtbl.add yaws (XmlEdit.attrib node "name") (!i, w);
|
||||
w in
|
||||
|
||||
let max_dist_from_home = float_attr xml "MAX_DIST_FROM_HOME" in
|
||||
|
||||
let _ = List.iter
|
||||
(fun wp ->
|
||||
let w = create_wp wp in
|
||||
let name = XmlEdit.attrib wp "name" in
|
||||
if name = "HOME" then
|
||||
ignore (geomap#circle ~color w#pos max_dist_from_home))
|
||||
(XmlEdit.children xml_wpts) in
|
||||
|
||||
object
|
||||
val mutable max_dist_from_home = max_dist_from_home
|
||||
method georef = ref_wgs84
|
||||
method show_xml () = xml_window#show ()
|
||||
method destroy () =
|
||||
wpts_group#group#destroy ();
|
||||
xml_window#destroy ()
|
||||
method show () = wpts_group#group#show ()
|
||||
method hide () = wpts_group#group#hide ()
|
||||
method index wp = Hashtbl.find yaws (XmlEdit.attrib wp "name")
|
||||
method waypoints = XmlEdit.children (waypoints_node xml_tree_view)
|
||||
method xml = XmlEdit.xml_of_view xml_tree_view
|
||||
method add_waypoint (geo:geographic) =
|
||||
let name = gensym "wp" in
|
||||
let utm = utm_of WGS84 geo in
|
||||
let (dx, dy) = utm_sub utm utm0 in
|
||||
let node = XmlEdit.add_child xml_wpts "waypoint" ["x",sof dx;"y",sof dy;"name",name] in
|
||||
create_wp node
|
||||
|
||||
initializer (
|
||||
(** Create a graphic waypoint when it is created from the xml editor *)
|
||||
XmlEdit.connect xml_wpts (function XmlEdit.New_child node -> ignore (create_wp node) | _ -> ())
|
||||
)
|
||||
end
|
||||
@@ -0,0 +1,44 @@
|
||||
(*
|
||||
* $Id$
|
||||
*
|
||||
* Displaying and editing a flight plan on a MapCanvas
|
||||
*
|
||||
* 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.
|
||||
*
|
||||
*)
|
||||
|
||||
(** [flight_plan geomap color dtd_tile xml] *)
|
||||
class flight_plan :
|
||||
MapCanvas.widget ->
|
||||
string ->
|
||||
string ->
|
||||
Xml.xml ->
|
||||
object
|
||||
val mutable max_dist_from_home : float
|
||||
method add_waypoint : Latlong.geographic -> MapWaypoints.waypoint
|
||||
method destroy : unit -> unit
|
||||
method georef : Latlong.geographic
|
||||
method hide : unit -> unit
|
||||
method index : XmlEdit.node -> int * MapWaypoints.waypoint
|
||||
method show : unit -> unit
|
||||
method show_xml : unit -> unit
|
||||
method waypoints : XmlEdit.node list
|
||||
method xml : Xml.xml
|
||||
end
|
||||
@@ -44,6 +44,10 @@ class waypoint = fun (group:group) (name :string) ?(alt=0.) wgs84 ->
|
||||
and color = group#color
|
||||
and editable = group#editable in
|
||||
let xw, yw = geomap#world_of wgs84 in
|
||||
let callbacks = Hashtbl.create 5 in
|
||||
let updated () =
|
||||
Hashtbl.iter (fun cb _ -> cb ()) callbacks in
|
||||
|
||||
object (self)
|
||||
val mutable x0 = 0.
|
||||
val mutable y0 = 0.
|
||||
@@ -52,14 +56,19 @@ class waypoint = fun (group:group) (name :string) ?(alt=0.) wgs84 ->
|
||||
~props:[`FILL_COLOR color; `OUTLINE_COLOR "midnightblue" ; `WIDTH_UNITS 1.; `FILL_STIPPLE (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\002\001")]
|
||||
|
||||
val label = GnoCanvas.text group#group ~props:[`TEXT name; `X s; `Y 0.; `ANCHOR `SW; `FILL_COLOR "green"]
|
||||
val mutable name = name
|
||||
val mutable name = name (* FIXME: already in label ! *)
|
||||
val mutable alt = alt
|
||||
val mutable moved = false
|
||||
val mutable deleted = false
|
||||
initializer self#move xw yw
|
||||
method connect = fun (cb:unit -> unit) ->
|
||||
Hashtbl.add callbacks cb ()
|
||||
method name = name
|
||||
method set_name n =
|
||||
if n <> name then
|
||||
name <- n
|
||||
if n <> name then begin
|
||||
name <- n;
|
||||
label#set [`TEXT name]
|
||||
end
|
||||
method alt = alt
|
||||
method label = label
|
||||
method xy = let a = item#i2w_affine in (a.(4), a.(5)) (*** item#i2w 0. 0. causes Seg Fault !***)
|
||||
@@ -69,7 +78,7 @@ class waypoint = fun (group:group) (name :string) ?(alt=0.) wgs84 ->
|
||||
let dvbx = GPack.box `VERTICAL ~packing:dialog#add () in
|
||||
let wgs84 = self#pos in
|
||||
let s = sprintf "WGS84 %s" (geomap#geo_string wgs84) in
|
||||
let ename = GEdit.entry ~text:name ~packing:dvbx#add () in
|
||||
let ename = GEdit.entry ~text:name ~editable:false ~packing:dvbx#add () in
|
||||
let e_pos = GEdit.entry ~text:s ~packing:dvbx#add () in
|
||||
let ea = GEdit.entry ~text:(string_of_float alt) ~packing:dvbx#add () in
|
||||
let cancel = GButton.button ~label:"Cancel" ~packing: dvbx#add () in
|
||||
@@ -81,6 +90,7 @@ class waypoint = fun (group:group) (name :string) ?(alt=0.) wgs84 ->
|
||||
alt <- float_of_string ea#text;
|
||||
label#set [`TEXT name];
|
||||
self#set (LL.of_string e_pos#text);
|
||||
updated ();
|
||||
dialog#destroy ()
|
||||
end);
|
||||
dialog#show ()
|
||||
@@ -114,6 +124,7 @@ class waypoint = fun (group:group) (name :string) ?(alt=0.) wgs84 ->
|
||||
let dx = geomap#current_zoom *. (x-. x0)
|
||||
and dy = geomap#current_zoom *. (y -. y0) in
|
||||
self#move dx dy ;
|
||||
updated ();
|
||||
x0 <- x; y0 <- y
|
||||
end
|
||||
| `BUTTON_RELEASE ev ->
|
||||
@@ -126,6 +137,7 @@ class waypoint = fun (group:group) (name :string) ?(alt=0.) wgs84 ->
|
||||
true
|
||||
initializer ignore(if editable then ignore (item#connect#event self#event))
|
||||
method moved = moved
|
||||
method deleted = deleted
|
||||
method item = item
|
||||
method pos = geomap#of_world self#xy
|
||||
method set wgs84 =
|
||||
@@ -133,6 +145,7 @@ class waypoint = fun (group:group) (name :string) ?(alt=0.) wgs84 ->
|
||||
and (xw0, yw0) = self#xy in
|
||||
self#move (xw-.xw0) (yw-.yw0)
|
||||
method delete =
|
||||
deleted <- true; (* BOF *)
|
||||
item#destroy ();
|
||||
label#destroy ()
|
||||
method zoom (z:float) =
|
||||
|
||||
@@ -55,6 +55,8 @@ class waypoint :
|
||||
method xy : float * float
|
||||
method zoom : float -> unit
|
||||
method moved : bool
|
||||
method deleted : bool
|
||||
method connect : (unit -> unit) -> unit
|
||||
end
|
||||
|
||||
|
||||
|
||||
+9
-10
@@ -37,7 +37,7 @@ open Printf
|
||||
type tag = string
|
||||
type attributes = (string * string) list
|
||||
type t = GTree.tree_store
|
||||
type node = t * Gtk.tree_path
|
||||
type node = GTree.tree_store * Gtk.tree_path
|
||||
|
||||
let cols = new GTree.column_list
|
||||
let attribute = cols#add Gobject.Data.string
|
||||
@@ -249,11 +249,11 @@ let root = fun (model:t) ->
|
||||
| Some i -> (model, model#get_path i)
|
||||
|
||||
|
||||
let attribs = fun ((model:t), path) ->
|
||||
let attribs = fun ((model, path):node) ->
|
||||
let row = model#get_iter path in
|
||||
model#get ~row ~column:attributes
|
||||
|
||||
let set_attribs = fun ((model:t), path) attribs ->
|
||||
let set_attribs = fun ((model, path):node) attribs ->
|
||||
let row = model#get_iter path in
|
||||
model#set ~row ~column:attributes attribs
|
||||
|
||||
@@ -266,11 +266,11 @@ let attrib = fun node at ->
|
||||
if String.uppercase a = at then v else loop avs in
|
||||
loop ats
|
||||
|
||||
let tag = fun ((model:t), path) ->
|
||||
let tag = fun ((model, path):node) ->
|
||||
let row = model#get_iter path in
|
||||
model#get ~row ~column:tag_col
|
||||
|
||||
let children = fun ((model:t), path) ->
|
||||
let children = fun ((model, path):node) ->
|
||||
let row = model#get_iter path in
|
||||
if model#iter_has_child row then
|
||||
let i = model#iter_children (Some row) in
|
||||
@@ -282,7 +282,7 @@ let children = fun ((model:t), path) ->
|
||||
else
|
||||
[]
|
||||
|
||||
let rec xml_of_node = fun node ->
|
||||
let rec xml_of_node = fun (node:node) ->
|
||||
let attrs = attribs node
|
||||
and tag = tag node
|
||||
and children = List.map xml_of_node (children node) in
|
||||
@@ -291,7 +291,7 @@ let rec xml_of_node = fun node ->
|
||||
let xml_of_view = fun (tree:t) ->
|
||||
xml_of_node (root tree)
|
||||
|
||||
let child = fun ((model:t), path) (t:string) ->
|
||||
let child = fun ((model, path):node) (t:string) ->
|
||||
let row = model#get_iter path in
|
||||
if model#iter_has_child row then
|
||||
let i = model#iter_children (Some row) in
|
||||
@@ -306,7 +306,7 @@ let child = fun ((model:t), path) (t:string) ->
|
||||
failwith (sprintf "XmlEdit.child: %s" t)
|
||||
|
||||
|
||||
let delete = fun ((model:t), path) ->
|
||||
let delete = fun (model, path) ->
|
||||
let row = model#get_iter path in
|
||||
if model#iter_is_valid row then
|
||||
ignore (model#remove row)
|
||||
@@ -443,5 +443,4 @@ let create = fun dtd xml ->
|
||||
let _ = tree_view#drag#connect#motion ~callback:motion in
|
||||
let _ = tree_view#drag#connect#drop ~callback:drop in
|
||||
|
||||
window#show ();
|
||||
tree_model
|
||||
tree_model, window
|
||||
|
||||
@@ -39,10 +39,11 @@ type attributes = (string * string) list
|
||||
|
||||
type event = Deleted | Modified of attributes | New_child of node
|
||||
|
||||
val create : Dtd.dtd -> Xml.xml -> t
|
||||
val create : Dtd.dtd -> Xml.xml -> (t * GWindow.window)
|
||||
(** [create dtd xml] Opens a display of [xml] with contextual right button
|
||||
actions constrained by [dtd]. Returns the corresponding model. *)
|
||||
|
||||
val xml_of_node : node -> Xml.xml
|
||||
val xml_of_view : t -> Xml.xml
|
||||
(** [xml_of_view v] Returns the XML displayed data structure *)
|
||||
|
||||
@@ -62,4 +63,3 @@ val add_child : node -> tag -> attributes -> node
|
||||
|
||||
val connect : node -> (event -> unit) -> unit
|
||||
(** To be kept informed about modifications *)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user