diff --git a/sw/ground_segment/cockpit/gcs.ml b/sw/ground_segment/cockpit/gcs.ml index f313fea74c..873ac3a82d 100644 --- a/sw/ground_segment/cockpit/gcs.ml +++ b/sw/ground_segment/cockpit/gcs.ml @@ -476,14 +476,36 @@ let pack_papget = let ct = new Papget.canvas_text geomap#still x y msg_listener field_name in begin try - let format = ExtXml.attrib papget "format" in - ct#set_renderer (fun x -> sprintf (Obj.magic format) (float_of_string x)) + ct#set_format (ExtXml.attrib papget "format") with _ -> () end | _ -> failwith (sprintf "pack_papget: %s" field) +(* Drag and drop handler *) +let dnd_targets = [ { Gtk.target = "STRING"; flags = []; info = 0} ] +let parse_dnd = + let sep = Str.regexp ":" in + fun s -> + match Str.split sep s with + [s; c; m; f] -> (s, c, m, f) + | _ -> failwith (Printf.sprintf "parse_dnd: %s" s) +let listen_dropped_papgets = fun (geomap:G.widget) -> + let data_received = fun context ~x ~y data ~info ~time -> + try + let (sender, class_name, msg_name, field_name) = parse_dnd data#data in + let sender = if sender = "*" then None else Some sender in + let msg_listener = new Papget.message ~class_name ?sender msg_name in + let _ct = new Papget.canvas_text geomap#still (float x) (float y) msg_listener field_name in + () + with + exc -> prerr_endline (Printexc.to_string exc) in + + geomap#canvas#drag#dest_set dnd_targets ~actions:[`COPY]; + ignore (geomap#canvas#drag#connect#data_received ~callback:data_received) + + (************************** MAIN ********************************************) let () = @@ -566,6 +588,7 @@ let () = (** packing mapgets *) let papgets = find_widget_children "map2d" the_layout in List.iter (pack_papget geomap) papgets; + listen_dropped_papgets geomap; if !mplayer <> "" then plugin_window := sprintf "mplayer -nomouseinput %s -wid " !mplayer; diff --git a/sw/lib/ocaml/Makefile b/sw/lib/ocaml/Makefile index 0f2bff2d57..0a95ac292e 100644 --- a/sw/lib/ocaml/Makefile +++ b/sw/lib/ocaml/Makefile @@ -32,7 +32,7 @@ SRC = debug.ml base64.ml serial.ml ocaml_tools.ml extXml.ml env.ml xml2h.ml latl CMO = $(SRC:.ml=.cmo) CMX = $(SRC:.ml=.cmx) -XSRC = platform.ml wind_sock.ml papget.ml mapCanvas.ml mapWaypoints.ml mapTrack.ml mapGoogle.ml mapIGN.ml ml_gtk_drag.o xmlEdit.ml mapFP.ml +XSRC = platform.ml wind_sock.ml gtk_papget_text_editor.ml papget.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) @@ -93,6 +93,9 @@ ml_gtkgl_hack.o : ml_gtkgl_hack.c @echo OC $< $(Q)$(OCAMLC) $(XINCLUDES) $< +gtk_papget_text_editor.ml : widgets.glade + lablgladecc2 -root papget_text_editor -hide-default $< | grep -B 1000000 " end" > $@ + clean : rm -f *~ *.cm* *.out *.opt .depend *.a *.o *.so diff --git a/sw/lib/ocaml/papget.ml b/sw/lib/ocaml/papget.ml index 0d75a5161f..4c5a0e2b07 100644 --- a/sw/lib/ocaml/papget.ml +++ b/sw/lib/ocaml/papget.ml @@ -1,35 +1,103 @@ open Printf -class message = fun ?(class_name="telemetry") msg_name -> +let (//) = Filename.concat + +class message = fun ?sender ?(class_name="telemetry") msg_name -> object val mutable callbacks = [] method connect = fun f cb -> callbacks <- (f, cb) :: callbacks initializer let module P = Pprz.Messages (struct let name = class_name end) in - ignore (P.message_bind msg_name - (fun _sender values -> - List.iter - (fun (field_name, cb) -> - let field = Pprz.string_assoc field_name values in - cb field) - callbacks)) + let cb = fun _sender values -> + List.iter + (fun (field_name, cb) -> + let field = Pprz.string_assoc field_name values in + cb field) + callbacks in + ignore (P.message_bind ?sender msg_name cb) end class field = fun msg_obj field_name -> object (self) val mutable last_val = "" - method store = fun value -> last_val <- value + method update = fun value -> last_val <- value initializer - msg_obj#connect field_name self#store + msg_obj#connect field_name self#update + end + +class canvas_item = fun canvas_group x1 y1 -> + let x2 = x1 +. 100. and y2 = y1 +. 25. in + let box = GnoCanvas.rect ~props:[`X1 x1; `X2 x2; `Y1 y1; `Y2 y2; (* `NO_OUTLINE_COLOR*) `OUTLINE_COLOR "green"] canvas_group in + object (self) + val box = box + method set_size = fun width height -> + box#set [`X2 (x1+.width); `Y2 (y1+.height)] end class canvas_text = fun ?(text="") canvas_group x y msg_obj field_name -> - let item = GnoCanvas.text ~x ~y ~text canvas_group in - object + let text = GnoCanvas.text ~x ~y ~text canvas_group in + object (self) inherit field msg_obj field_name as super - val mutable renderer = fun x -> x - method set_renderer = fun f -> renderer <- f - method store = fun value -> - super#store value; - item#set [`SIZE_POINTS 25.; `TEXT (renderer value); `FILL_COLOR "green"; `ANCHOR `NW] + val mutable format = "%.2f" + val mutable motion = false + val mutable size = 15. + initializer + ignore (text#connect#event self#event) + method event = fun (ev : GnoCanvas.item_event) -> + match ev with + (*** `ENTER_NOTIFY _ -> prerr_endline "enter"; box#set [`OUTLINE_COLOR "green"]; true + | `LEAVE_NOTIFY _ -> prerr_endline "leave"; box#set [`NO_OUTLINE_COLOR]; true +***) + | `BUTTON_PRESS ev -> + begin + match GdkEvent.Button.button ev with + | 1 -> + motion <- false; + let curs = Gdk.Cursor.create `FLEUR in + text#grab [`POINTER_MOTION; `BUTTON_RELEASE] curs + (GdkEvent.Button.time ev) + | _ -> () + end; + true + | `MOTION_NOTIFY ev -> + let state = GdkEvent.Motion.state ev in + if Gdk.Convert.test_modifier `BUTTON1 state then begin + motion <- true; + let x = GdkEvent.Motion.x ev + and y = GdkEvent.Motion.y ev in + let (xw, yw) = canvas_group#w2i x y in + text#set [`X xw; `Y yw] + end; + true + | `BUTTON_RELEASE ev -> + if GdkEvent.Button.button ev = 1 then begin + text#ungrab (GdkEvent.Button.time ev); + if not motion then begin + let file = Env.paparazzi_src // "sw" // "lib" // "ocaml" // "widgets.glade" in + let dialog = new Gtk_papget_text_editor.papget_text_editor ~file () in + (* Initialize the entries *) + dialog#entry_format#set_text format; + dialog#spinbutton_size#set_value size; + + (* Connect the entries *) + let callback = fun () -> + format <- dialog#entry_format#text in + ignore (dialog#entry_format#connect#activate ~callback); + let callback = fun () -> + size <- dialog#spinbutton_size#value in + ignore (dialog#spinbutton_size#connect#value_changed ~callback); + + (* Connect the buttons *) + ignore (dialog#button_ok#connect#clicked (fun () -> dialog#papget_text_editor#destroy ())) + end; + motion <- false + end; + true + | _ -> false + + method set_format = fun f -> format <- f + method update = fun value -> + super#update value; + let renderer = fun x -> sprintf (Obj.magic format) (float_of_string x) in + text#set [`SIZE_POINTS size; `TEXT (renderer value); `FILL_COLOR "green"; `ANCHOR `NW] end diff --git a/sw/lib/ocaml/widgets.glade b/sw/lib/ocaml/widgets.glade new file mode 100644 index 0000000000..cbd58e2d3b --- /dev/null +++ b/sw/lib/ocaml/widgets.glade @@ -0,0 +1,190 @@ + + + + + + + True + Text Papget Properties + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_MOUSE + False + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + False + + + + True + False + 0 + + + + True + 2 + 2 + False + 0 + 0 + + + + True + Format + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 0 + 1 + fill + + + + + + + True + Size + False + False + GTK_JUSTIFY_RIGHT + False + False + 0 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 1 + 2 + fill + + + + + + + True + True + True + True + 0 + + True + ● + False + + + 1 + 2 + 0 + 1 + + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 1 + 2 + 1 + 2 + + + + + + 0 + False + True + + + + + + True + True + 0 + + + + True + True + gtk-delete + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + True + gtk-ok + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + 0 + False + True + + + + + + +