diff --git a/sw/ground_segment/cockpit/map2d.ml b/sw/ground_segment/cockpit/map2d.ml index 1f01542975..bd19830bdf 100644 --- a/sw/ground_segment/cockpit/map2d.ml +++ b/sw/ground_segment/cockpit/map2d.ml @@ -37,6 +37,14 @@ let pvect (x1,y1) (x2,y2) = x1*.y2-.y1*.x2 let angle (x1,y1) (x2,y2) (x3,y3) = pvect (x3-.x2, y3-.y2) (x1-.x2,y1-.y2) +let rec list_iter3 = fun f l1 l2 l3 -> + match l1, l2, l3 with + [], [], [] -> () + | x1::x1s, x2::x2s, x3::x3s -> + f x1 x2 x3; + list_iter3 f x1s x2s x3s + | _ -> invalid_arg "list_iter3" + let rec n_first n = function [] -> [] | x::xs -> if n > 0 then x::n_first (n-1) xs else [] @@ -869,7 +877,7 @@ module Live = struct fp#waypoints - let create_ac = fun (geomap:G.widget) (fp_notebook:GPack.notebook) ac_id config -> + let create_ac = fun (geomap:G.widget) (acs_notebook:GPack.notebook) ac_id config -> let color = Pprz.string_assoc "default_gui_color" config and name = Pprz.string_assoc "ac_name" config in @@ -920,16 +928,29 @@ module Live = struct let params = ac_menu_fact#add_check_item "flight param. display" ~active:false in ignore (params#connect#toggled (fun () -> track#set_params_state params#active)); + (** Build the XML flight plan, connect then "jump_to_block" *) let fp_xml = ExtXml.child fp_xml_dump "flight_plan" in - let fp = load_mission ~edit:false color geomap fp_xml in + fp#connect_activated (fun node -> + if XmlEdit.tag node = "block" then + let block = XmlEdit.attrib node "name" in + let id = list_casso block blocks in + jump_to_block ac_id id); + ignore (reset_wp_menu#connect#activate (reset_waypoints fp)); + + (** Add a new tab in the A/Cs notebook, with a colored label *) let eb = GBin.event_box () in let label = GMisc.label ~text:name ~packing:eb#add () in eb#coerce#misc#modify_bg [`NORMAL, `NAME color;`ACTIVE, `NAME color]; - let ac_frame = GBin.frame ~packing: ((fp_notebook:GPack.notebook)#append_page ~tab_label:eb#coerce)() in + (** Put a notebook for this A/C *) + let ac_frame = GBin.frame ~packing:(acs_notebook#append_page ~tab_label:eb#coerce) () in let ac_notebook = GPack.notebook ~packing: ac_frame#add () in + let visible = fun w -> + ac_notebook#page_num w#coerce = ac_notebook#current_page in + + (** Insert the flight plan tab *) let fp_label = GMisc.label ~text: "Flight Plan" () in (ac_notebook:GPack.notebook)#append_page ~tab_label:fp_label#coerce fp#window#coerce; @@ -941,12 +962,13 @@ module Live = struct let gps_label = GMisc.label ~text: "GPS" () in let gps_frame = GBin.frame ~shadow_type: `NONE ~packing: (ac_notebook#append_page ~tab_label: gps_label#coerce) () in - let gps_page = new Pages.gps gps_frame in - + let gps_page = new Pages.gps ~visible gps_frame in + let pfd_label = GMisc.label ~text: "PFD" () in let pfd_frame = GBin.frame ~shadow_type: `NONE ~packing: (ac_notebook#append_page ~tab_label: pfd_label#coerce) () in - let pfd_page = new Pages.pfd pfd_frame in + let pfd_page = new Pages.pfd pfd_frame + and pfd_page_num = ac_notebook#page_num pfd_frame#coerce in let misc_label = GMisc.label ~text: "Misc" () in let misc_frame = GBin.frame ~shadow_type: `NONE @@ -959,25 +981,20 @@ module Live = struct let callback = fun idx value -> let vs = ["ac_id", Pprz.String ac_id; "index", Pprz.Int idx;"value", Pprz.Float value] in Ground_Pprz.message_send "dl" "DL_SETTING" vs in - let settings_tab = new Pages.settings xml_settings callback in + let settings_tab = new Pages.settings ~visible xml_settings callback in let tab_label = (GMisc.label ~text:"Settings" ())#coerce in ac_notebook#append_page ~tab_label settings_tab#widget; Some settings_tab with _ -> None in - fp#connect_activated (fun node -> - if XmlEdit.tag node = "block" then - let block = XmlEdit.attrib node "name" in - let id = list_casso block blocks in - jump_to_block ac_id id); - ignore (reset_wp_menu#connect#activate (reset_waypoints fp)); - + (** Add a strip and connect it to the A/C notebook *) let select_this_tab = - let n = fp_notebook#page_num ac_frame#coerce in - fun () -> fp_notebook#goto_page n in - + let n = acs_notebook#page_num ac_frame#coerce in + fun () -> acs_notebook#goto_page n in let strip = Strip.add strip_table config color select_this_tab center_ac commit_moves in + + Hashtbl.add live_aircrafts ac_id { track = track; color = color; fp_group = fp ; config = config ; fp = fp_xml; ac_name = name; @@ -1090,8 +1107,7 @@ module Live = struct let ac = get_ac vs in let pfd_page = ac.pfd_page in - pfd_page#set_roll (Pprz.float_assoc "roll" vs); - pfd_page#set_pitch (Pprz.float_assoc "pitch" vs); + pfd_page#set_attitude (Pprz.float_assoc "roll" vs) (Pprz.float_assoc "pitch" vs); pfd_page#set_alt (Pprz.float_assoc "alt" vs); pfd_page#set_climb (Pprz.float_assoc "climb" vs); pfd_page#set_speed (Pprz.float_assoc "speed" vs); @@ -1151,8 +1167,7 @@ module Live = struct safe_bind "CAM_STATUS" get_cam_status; let get_circle_status = fun _sender vs -> - let ac_id = Pprz.string_assoc "ac_id" vs in - let ac = Hashtbl.find live_aircrafts ac_id in + let ac = get_ac vs in let a = fun s -> Pprz.float_assoc s vs in let wgs84 = { posn_lat = (Deg>>Rad)(a "circle_lat"); posn_long = (Deg>>Rad)(a "circle_long") } in circle_status_msg ac.track wgs84 (float_of_string (Pprz.string_assoc "radius" vs)) @@ -1204,20 +1219,18 @@ module Live = struct let listen_waypoint_moved = fun () -> let get_values = fun _sender vs -> - let ac_id = Pprz.string_assoc "ac_id" vs in - let ac = Hashtbl.find live_aircrafts ac_id in - (** Not_found catched by safe_bind *) + let ac = get_ac vs in let wp_id = Pprz.int_assoc "wp_id" vs in let a = fun s -> Pprz.float_assoc s vs in let geo = { posn_lat = (Deg>>Rad)(a "lat"); posn_long = (Deg>>Rad)(a "long") } and altitude = a "alt" in - (** No indexed access to waypoints: iter and compare: *) + (** FIXME: No indexed access to waypoints: iter and compare: *) List.iter (fun w -> let (i, w) = ac.fp_group#index w in if i = wp_id then begin w#set ~if_not_moved:true ~altitude ~update:true geo; - raise Exit (** catched by safe_bind *) + raise Exit (** catched by safe_bind *) end) ac.fp_group#waypoints in @@ -1258,16 +1271,14 @@ module Live = struct let ac_id = Pprz.string_assoc "ac_id" vs in let ac = Hashtbl.find live_aircrafts ac_id in let gps_page = ac.gps_page in - let svid = Array.of_list - (Str.split (Str.regexp ",") (Pprz.string_assoc "svid" vs)) in - let cno = Array.of_list - (Str.split (Str.regexp ",") (Pprz.string_assoc "cno" vs)) in - let flags = Array.of_list - (Str.split (Str.regexp ",") (Pprz.string_assoc "flags" vs)) in - - Array.iteri (fun i id -> - if id<>"0" then - gps_page#svsinfo id cno.(i) (int_of_string flags.(i))) svid + let svid = Str.split list_separator (Pprz.string_assoc "svid" vs) + and cn0 = Str.split list_separator (Pprz.string_assoc "cno" vs) + and flags = Str.split list_separator (Pprz.string_assoc "flags" vs) in + + list_iter3 + (fun id cno flags -> + if id <> "0" then gps_page#svsinfo id cno (int_of_string flags)) + svid cn0 flags let listen_svsinfo = fun () -> safe_bind "SVSINFO" get_svsinfo end (** module Live *) diff --git a/sw/ground_segment/cockpit/pages.ml b/sw/ground_segment/cockpit/pages.ml index 543810410f..0125bc8ce4 100644 --- a/sw/ground_segment/cockpit/pages.ml +++ b/sw/ground_segment/cockpit/pages.ml @@ -78,7 +78,7 @@ end (*****************************************************************************) (* gps page *) (*****************************************************************************) -class gps (widget: GBin.frame) = +class gps ?(visible = fun _ -> true) (widget: GBin.frame) = let table = GPack.table ~rows: 1 ~columns: 3 @@ -96,8 +96,7 @@ object (this) val mutable active_flags = [] method svsinfo svid cno flags = - if not (List.mem_assoc svid active_cno) - then begin + if not (List.mem_assoc svid active_cno) then let rows = table#rows in let _svid_label = GMisc.label ~text: ("sat "^ svid) ~packing: (table#attach ~top: rows ~left: 0) () in @@ -109,34 +108,26 @@ object (this) active_cno <- (svid, cno_label)::active_cno; active_flags <- (svid, flags_eb)::active_flags; table#set_rows (table#rows +1) - end - else begin + else if visible widget then let cno_label = List.assoc svid active_cno in let flags_eb = List.assoc svid active_flags in cno_label#set_label (cno^" dB Hz"); update_color flags_eb flags - end end (*****************************************************************************) (* pfd page *) (*****************************************************************************) -class pfd (widget: GBin.frame) = +class pfd ?(visible = fun _ -> true) (widget: GBin.frame) = let horizon = new Horizon.h ~packing: widget#add 150 in + let _lazy = fun f x -> if visible widget then f x in object (this) - val mutable pitch = 0. - val mutable roll = 0. - - method set_roll r = - roll <- r; - horizon#set_attitude ((Deg>>Rad)roll) ((Deg>>Rad)pitch) - method set_pitch p = - pitch <- p; - horizon#set_attitude ((Deg>>Rad)roll) ((Deg>>Rad)pitch) - method set_alt (a:float) = horizon#set_alt a + method set_attitude roll pitch = + _lazy (horizon#set_attitude ((Deg>>Rad)roll)) ((Deg>>Rad)pitch) + method set_alt (a:float) = _lazy horizon#set_alt a method set_climb (c:float) = () - method set_speed (c:float) = horizon#set_speed c + method set_speed (c:float) = _lazy horizon#set_speed c end @@ -165,15 +156,13 @@ class misc ~packing (widget: GBin.frame) = (*****************************************************************************) (* Dataling settings paged *) (*****************************************************************************) -class settings = fun xml_settings callback -> +class settings = fun ?(visible = fun _ -> true) xml_settings callback -> let sw = GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in let vbox = GPack.vbox ~packing:sw#add_with_viewport () in let n = List.length xml_settings in - let current_values = Array.create n 42. in - let i = ref 0 in - let _ = - List.iter - (fun s -> + let current_values = + Array.mapi + (fun i s -> let f = fun a -> float_of_string (ExtXml.attrib s a) in let lower = f "min" and upper = f "max" @@ -185,26 +174,22 @@ class settings = fun xml_settings callback -> let _l = GMisc.label ~width:100 ~text ~packing:hbox#pack () in let _v = GMisc.label ~width:50 ~text:"N/A" ~packing:hbox#pack () in let _scale = GRange.scale `HORIZONTAL ~digits:2 ~adjustment:adj ~packing:hbox#add () in - let ii = !i in - let update_current_value = fun _ -> - let s = string_of_float current_values.(ii) in - if _v#text <> s then - _v#set_text s; - true in - - ignore (Glib.Timeout.add 500 update_current_value); - let callback = fun _ -> callback ii adj#value in + let callback = fun _ -> callback i adj#value in let b = GButton.button ~label:"Commit" ~stock:`APPLY ~packing:hbox#pack () in ignore (b#connect#clicked ~callback); - incr i + _v ) - xml_settings in - object + (Array.of_list xml_settings) in + object (self) method length = n method widget = sw#coerce - method set = fun i v -> current_values.(i) <- v + method set = fun i v -> + if visible self#widget then + let s = string_of_float v in + if current_values.(i)#text <> s then + current_values.(i)#set_text s end diff --git a/sw/ground_segment/cockpit/pages.mli b/sw/ground_segment/cockpit/pages.mli index 2573fbaaa6..8884adecb4 100644 --- a/sw/ground_segment/cockpit/pages.mli +++ b/sw/ground_segment/cockpit/pages.mli @@ -9,24 +9,26 @@ class infrared : GBin.frame -> method set_gps_hybrid_factor : float -> unit method set_gps_hybrid_mode : string -> unit end -class gps : GBin.frame -> +class gps : ?visible:(GBin.frame -> bool) -> GBin.frame -> object method svsinfo : string -> string -> int -> unit end -class pfd : GBin.frame -> + +class pfd : ?visible:(GBin.frame -> bool) -> GBin.frame -> object method set_speed : float -> unit method set_alt : float -> unit method set_climb : float -> unit - method set_pitch : float -> unit - method set_roll : float -> unit + method set_attitude : float -> float -> unit end -class settings : Xml.xml list -> (int -> float -> unit) -> + +class settings : ?visible:(GObj.widget -> bool) -> Xml.xml list -> (int -> float -> unit) -> object method length : int method set : int -> float -> unit method widget : GObj.widget end + class misc : packing:(GObj.widget -> unit) -> GBin.frame -> diff --git a/sw/lib/ocaml/mapTrack.ml b/sw/lib/ocaml/mapTrack.ml index 5e563499ed..ebfd5b902c 100644 --- a/sw/lib/ocaml/mapTrack.ml +++ b/sw/lib/ocaml/mapTrack.ml @@ -47,6 +47,11 @@ let rec norm_angle_360 = fun alpha -> let cam_half_aperture = LL.pi /. 6.0 let half_pi = LL.pi /. 2.0 +type desired = + NoDesired + | DesiredCircle of LL.geographic*float*GnoCanvas.ellipse + | DesiredSegment of LL.geographic*LL.geographic*GnoCanvas.line + class track = fun ?(name="Noname") ?(size = 500) ?(color="red") (geomap:MapCanvas.widget) -> let group = GnoCanvas.group geomap#canvas#root in @@ -82,6 +87,9 @@ class track = fun ?(name="Noname") ?(size = 500) ?(color="red") (geomap:MapCanva let min_distance_scaled = 10. in let min_height_scaled = 0.1 in + let desired_circle = GnoCanvas.ellipse group + and desired_segment = GnoCanvas.line group in + let top = ref 0 in object (self) @@ -101,8 +109,8 @@ class track = fun ?(name="Noname") ?(size = 500) ?(color="red") (geomap:MapCanva val mutable cam_on = false val mutable params_on = false val mutable v_params_on = false - val mutable desired_track = ((GnoCanvas.ellipse group) :> GnoCanvas.base_item) - val mutable zone = GnoCanvas.rect group + val mutable desired_track = NoDesired + val zone = GnoCanvas.rect group val mutable ac_cam_cover = GnoCanvas.rect cam method color = color method set_color c = color <- c @@ -170,19 +178,40 @@ class track = fun ?(name="Noname") ?(size = 500) ?(color="red") (geomap:MapCanva (** draws the circular path to be followed by the aircraft in circle mode *) method draw_circle = fun en radius -> - desired_track#destroy (); - desired_track <- ((geomap#circle ~color:"green" en radius) :> GnoCanvas.base_item); + let create = fun () -> + desired_track <- DesiredCircle (en, radius, geomap#circle ~color:"green" en radius) in + match desired_track with + DesiredCircle (c, r, circle) -> + if c <> en || r <> radius then begin + circle#destroy (); + create () + end + | DesiredSegment (p1,p2,s) -> + s#destroy (); + create () + | NoDesired -> + create () (** draws the linear path to be followed by the aircraft between two waypoints *) - method draw_segment = fun en en2 -> - desired_track#destroy (); - desired_track <- ((geomap#segment ~fill_color:"green" en en2) :> GnoCanvas.base_item) + method draw_segment = fun en1 en2 -> + let create = fun () -> + desired_track <- DesiredSegment (en1, en2, geomap#segment ~fill_color:"green" en1 en2) in + match desired_track with + DesiredCircle (c, r, circle) -> + circle#destroy (); + create () + | DesiredSegment (p1,p2,s) -> + if p1 <> en1 || p2 <> en2 then begin + s#destroy (); + create () + end + | NoDesired -> + create () method draw_zone = fun geo1 geo2 -> - zone#destroy (); let (x1, y1) = geomap#world_of geo1 and (x2, y2) = geomap#world_of geo2 in - zone <- GnoCanvas.rect ~props:[`X1 x1; `Y1 y1; `X2 x2; `Y2 y2; `OUTLINE_COLOR "#ffc0c0"; `WIDTH_PIXELS 2] geomap#canvas#root + zone#set [`X1 x1; `Y1 y1; `X2 x2; `Y2 y2; `OUTLINE_COLOR "#ffc0c0"; `WIDTH_PIXELS 2] (** moves the rectangle representing the field covered by the camera *) method move_cam = fun wgs84 mission_target_wgs84 ->