Editing in map2d

sw/configurator/medit.ml

@@ -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");

sw/ground_segment/cockpit/Makefile

@@ -1,5 +1,5 @@
-OCAMLC=ocamlc
+OCAMLC=ocamlc -thread
-OCAMLOPT=ocamlopt
+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:

sw/ground_segment/cockpit/map2d.ml

@@ -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 lon0 = float_attr xml "lon0" in
-  and alt0 = float_attr xml "alt" in
+  {posn_lat = (Deg>>Rad)lat0; posn_long = (Deg>>Rad)lon0 }
-  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
 
+	    
+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
+    a.fp_group#hide ()
-    match a.fp_group with
+
-      None -> ()
-    | Some (g, _wpts) -> 
-	a.fp_group <- None;
-	g#group#destroy ()
 
 let commit_changes = fun ac ->
   let a = Hashtbl.find live_aircrafts ac in
-  match a.fp_group with
+  List.iter 
-    Some (_g, wpts) -> 
+    (fun w ->
-      List.iter 
+      let (i, w) = a.fp_group#index w in
-	(fun (i, w) -> 
+      if w#moved then 
-	  if w#moved then 
+	let wgs84 = w#pos in
-	    let wgs84 = w#pos in
+	let vs = ["ac_id", Pprz.String ac;
-	    let vs = ["ac_id", Pprz.String ac;
+		  "wp_id", Pprz.Int i;
-		      "wp_id", Pprz.Int i;
+		  "lat", Pprz.Float ((Rad>>Deg)wgs84.posn_lat);
-		      "lat", Pprz.Float ((Rad>>Deg)wgs84.posn_lat);
+		  "long", Pprz.Float ((Rad>>Deg)wgs84.posn_long);
-		      "long", Pprz.Float ((Rad>>Deg)wgs84.posn_long);
 		      "alt", Pprz.Float w#alt
-		    ] in
+		] in
-	    Ground_Pprz.message_send "map2d" "MOVE_WAYPOINT" vs)
+	Ground_Pprz.message_send "map2d" "MOVE_WAYPOINT" vs)
-	wpts
+    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 ->
+      match GToolbox.select_file ~filename:(default_path_maps//".xml") ~title:"Save region map" () with
-	let jpg = Filename.chop_extension xml_file ^ ".png" in
+	None -> ()
-	GdkPixbuf.save jpg "png" p;
+      | Some xml_file  ->
-	let point = fun (x,y) xyw ->
+	  let jpg = Filename.chop_extension xml_file ^ ".png" in
-	  let wgs84 = geomap#of_world xyw in
+	  GdkPixbuf.save jpg "png" p;
-	  Xml.Element ("point", ["x",soi x;"y",soi y;"geo", Latlong.string_of wgs84], []) in
+	  let point = fun (x,y) xyw ->
-	let points = [point (0, 0) (xw1,yw1); point (width, height) (xw2,yw2)] in
+	    let wgs84 = geomap#of_world xyw in
-	let xml = Xml.Element ("map", 
+	    Xml.Element ("point", ["x",soi x;"y",soi y;"geo", Latlong.string_of wgs84], []) in
-			       ["file", Filename.basename jpg;
+	  let points = [point (0, 0) (xw1,yw1); point (width, height) (xw2,yw2)] in
-				"projection", geomap#projection],
+	  let xml = Xml.Element ("map", 
+				 ["file", Filename.basename jpg;
+				  "projection", geomap#projection],
 			       points) in
-	let f = open_out xml_file in
+	  let f = open_out xml_file in
-	Printf.fprintf f "%s\n" (Xml.to_string_fmt xml);
+	  Printf.fprintf f "%s\n" (Xml.to_string_fmt xml);
-	close_out f) ()
+	  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 ());
 

sw/lib/ocaml/Makefile

@@ -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)
 

sw/lib/ocaml/mapCanvas.ml

@@ -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];

sw/lib/ocaml/mapFP.ml

@@ -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

sw/lib/ocaml/mapFP.mli

@@ -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

sw/lib/ocaml/mapWaypoints.ml

@@ -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
+      if n <> name then begin
-	name <- n
+	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) =

sw/lib/ocaml/mapWaypoints.mli

@@ -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
 
 

sw/lib/ocaml/xmlEdit.ml

@@ -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, window
-  tree_model

sw/lib/ocaml/xmlEdit.mli

@@ -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 *)
-