More and more for the papgets

conf/gcs/layout.dtd

@@ -2,8 +2,8 @@
 <!ELEMENT rows (columns|widget)*>
 <!ELEMENT columns (rows|widget)*>
 <!ELEMENT widget (papget)*>
-<!ELEMENT papget (attr)*>
-<!ELEMENT attr EMPTY>
+<!ELEMENT papget (property)*>
+<!ELEMENT property EMPTY>
 
 <!ATTLIST layout
 width CDATA #IMPLIED
@@ -30,7 +30,7 @@ y CDATA #REQUIRED
 display CDATA #REQUIRED
 >
 
-<!ATTLIST attr
+<!ATTLIST property
 name CDATA #REQUIRED
 value CDATA #REQUIRED
 >

conf/gcs/tmp_papgets.xml

@@ -4,28 +4,34 @@
  <rows>
   <widget size="500" name="map2d">
     <papget x="10" y="400" type="message_field" display="text">
-      <attr name="field" value="ESTIMATOR:z_dot" />
-      <attr name="format" value="Climb:%.1fm/s"/>
-      <attr name="size" value="20"/>
-      <attr name="color" value="blue"/>
+      <property name="field" value="ESTIMATOR:z_dot" />
+      <property name="format" value="Climb:%.1fm/s"/>
+      <property name="size" value="20"/>
+      <property name="color" value="pink"/>
     </papget>
     <papget x="990" y="250" type="message_field" display="ruler">
-      <attr name="height" value="200" />
-      <attr name="field" value="ESTIMATOR:z" />
+      <property name="height" value="200" />
+      <property name="field" value="ESTIMATOR:z" />
     </papget>
     <papget x="10" y="250" type="variable_setting" display="button">
-      <attr name="variable" value="launch" />
-      <attr name="value" value="1"/>
-      <attr name="icon" value="launch.png" />
+      <property name="variable" value="launch" />
+      <property name="value" value="1"/>
+      <property name="icon" value="launch.png" />
     </papget>
+<!--
     <papget x="10" y="250" type="variable_setting" display="slider">
-      <attr name="variable" value="nav_altitude" />
-      <attr name="min" value="0"/>
-      <attr name="max" value="1000"/>
+      <property name="variable" value="nav_altitude" />
+      <property name="min" value="0"/>
+      <property name="max" value="1000"/>
     </papget>
+-->
     <papget x="10" y="300" type="goto_block" display="button">
-      <attr name="block_name" value="Standby" />
-      <attr name="icon" value="home.png" />
+      <property name="block_name" value="Standby" />
+      <property name="icon" value="home.png" />
+    </papget>    
+    <papget x="10" y="330" type="goto_block" display="button">
+      <property name="block_name" value="Takeoff" />
+      <property name="icon" value="takeoff.png" />
     </papget>    
   </widget>
   <columns>

sw/ground_segment/cockpit/gcs.ml

@@ -464,17 +464,46 @@ let rec find_widget_children = fun name xml ->
   | _ -> raise Not_found
 
 
-let get_papget_attr = fun xml attr_name ->
-  let attr = ExtXml.child ~select:(fun x -> ExtXml.attrib x "name" = attr_name) xml "attr" in
-  ExtXml.attrib attr "value"
+let rec replace_widget_children = fun name children xml ->
+  let xmls = Xml.children xml
+  and tag = String.lowercase (Xml.tag xml) in
+  match tag with
+    "widget" ->
+      Xml.Element("widget",
+		  Xml.attribs xml,
+		  if ExtXml.attrib xml "name" = name then children else xmls)
+  | "rows" | "columns" ->
+      let rec loop = function
+	  [] -> []
+	| x::xs ->
+	    replace_widget_children name children x :: loop xs in
+      Xml.Element(tag,
+		  Xml.attribs xml,
+		  loop xmls)
+  | x -> xml
+
+
 
 let try_fun = fun f -> try f () with _ -> ()
+let papget = fun type_ display attrs ->
+  Xml.Element ("papget", ["type", type_; "display", display], attrs)
+let papgets = Hashtbl.create 5
+let register_papget = fun p p -> Hashtbl.add papgets p p
+let papgets_config = fun () ->
+  Hashtbl.fold
+    (fun _ p r ->
+      if not p#deleted then
+	p#config ()::r
+      else
+	r)
+    papgets
+    []
 
 let papget_listener =
   let sep = Str.regexp ":" in
   fun papget ->
     try
-      let field = get_papget_attr papget "field" in
+      let field = Papget.get_property "field" papget in
       match Str.split sep field with
 	[msg_name; field_name] ->
 	  (new Papget.message msg_name, field_name)
@@ -487,31 +516,84 @@ let pack_papget =
     let type_ = ExtXml.attrib papget "type"
     and display = ExtXml.attrib papget "display"
     and x = ExtXml.float_attrib papget "x"
-    and y = ExtXml.float_attrib papget "y" in
+    and y = ExtXml.float_attrib papget "y"
+    and config = Xml.children papget in
     match type_ with
       "message_field" ->
 	let msg_listener, field_name = papget_listener papget
 	and renderer =
 	  match display with
 	    "text" ->
-	      let renderer = new Papget.canvas_text geomap#still x y in
-	      try_fun (fun () ->renderer#set_format (get_papget_attr papget "format") );
-	      try_fun (fun () ->renderer#set_size (float_of_string (get_papget_attr papget "size")) );
-	      try_fun (fun () ->renderer#set_color (get_papget_attr papget "color") );
-	      (renderer :> Papget.renderer)
+	      (new Papget.canvas_text ~config geomap#still x y :> Papget.renderer)
 		
-	| "ruler" ->
-	    let h = try Some (float_of_string (get_papget_attr papget "height")) with _ -> None in
-	    (new Papget.canvas_ruler geomap#still ?h x y :> Papget.renderer)
+	  | "ruler" ->
+	      (new Papget.canvas_ruler geomap#still ~config x y :> Papget.renderer)
 	| _ -> failwith (sprintf "Unexpected papget display: %s" display) in
-	ignore (new Papget.canvas_display_item msg_listener field_name renderer)
-    | "variable_setting" | "goto_block" ->
-	fprintf stderr "Papget %s soon\n%!" type_
+	let p = new Papget.canvas_display_item msg_listener field_name renderer in
+	let p = (p :> Papget.item) in
+	register_papget p p
+    | "goto_block" ->
+(***
+	let button = GButton.button ()
+	and icon = Papget.get_property "icon" papget in
+	let pixbuf = GdkPixbuf.from_file (Env.gcs_icons_path // icon) in
+	ignore (GMisc.image ~pixbuf ~packing:button#add ());
+	let renderer = (new Papget.widget_renderer "Button" button#coerce geomap#still ~config x y :> Papget.renderer) in
+***)
+	let renderer = 
+	  match display with
+	    "button" ->
+	      (new Papget.canvas_button geomap#still ~config x y :> Papget.renderer)
+	  | _ -> failwith (sprintf "Unexpected papget display: %s" display) in
+	let block_name = Papget.get_property "block_name" papget in
+	let clicked = fun () ->
+	  prerr_endline "Warning: goto_block papget sends to all A/C";
+	  Hashtbl.iter
+	    (fun ac_id ac ->
+	      let blocks = ExtXml.child ac.Live.fp "blocks" in
+	      let block = ExtXml.child ~select:(fun x -> ExtXml.attrib x "name" = block_name) blocks "block" in
+	      let block_id = ExtXml.int_attrib block "no" in
+	      Live.jump_to_block ac_id block_id
+	      )
+	    Live.aircrafts
+	in
+	let properties = [ Papget.property "block_name" block_name ] in
+
+	let p = new Papget.canvas_goto_block_item properties clicked renderer in
+	let p = (p :> Papget.item) in
+	register_papget p p
+    | "variable_setting" ->
+	let renderer = 
+	  match display with
+	    "button" ->
+	      (new Papget.canvas_button geomap#still ~config x y :> Papget.renderer)
+	  | _ -> failwith (sprintf "Unexpected papget display: %s" display) in
+
+	let varname = Papget.get_property "variable" papget
+	and value = float_of_string (Papget.get_property "value" papget) in
+
+	let clicked = fun () ->
+	  prerr_endline "Warning: variable_setting papget sending to all active A/C";
+	  Hashtbl.iter
+	    (fun ac_id ac ->
+	      match ac.Live.dl_settings_page with
+		None -> ()
+	      | Some settings ->
+		  let var_id = settings#assoc varname in
+		  Live.dl_setting ac_id var_id value)
+	    Live.aircrafts
+	in
+	let properties = [ Papget.property "variable" varname;
+			   Papget.float_property "value" value ] in
+	let p = new Papget.canvas_variable_setting_item properties clicked renderer in
+	let p = (p :> Papget.item) in
+	register_papget p p
+	
     | _ -> failwith (sprintf "Unexpected papget type: %s" type_)
 	    
 
 (* Drag and drop handler for papgets *)
-let dnd_targets = [ { Gtk.target = "STRING"; flags = []; info = 0} ]
+let dnd_targets = [ { Gtk.target = "STRING"; flags = []; info = 0 } ]
 let parse_dnd =
   let sep = Str.regexp ":" in
   fun s ->
@@ -525,8 +607,9 @@ let listen_dropped_papgets = fun (geomap:G.widget) ->
       let sender = if sender = "*" then None else Some sender in
       let msg_listener = new Papget.message ~class_name ?sender msg_name in
       let renderer = new Papget.canvas_text geomap#still (float x) (float y) in
-      let _ = new Papget.canvas_display_item msg_listener field_name (renderer:> Papget.renderer) in
-      ()
+      let p = new Papget.canvas_display_item msg_listener field_name (renderer:> Papget.renderer) in
+      let p = (p :> Papget.item) in
+      register_papget p p
     with
       exc -> prerr_endline (Printexc.to_string exc) in
   
@@ -535,6 +618,26 @@ let listen_dropped_papgets = fun (geomap:G.widget) ->
 
 
 
+let save_layout = fun filename contents ->
+  let dir = Filename.dirname filename in
+  let dialog = GWindow.file_chooser_dialog ~action:`SAVE ~title:"Save Layout" () in
+  ignore (dialog#set_current_folder dir);
+  dialog#add_filter (GFile.filter ~name:"xml" ~patterns:["*.xml"] ());
+  dialog#add_button_stock `CANCEL `CANCEL ;
+  dialog#add_select_button_stock `SAVE `SAVE ;
+  let _ = dialog#set_current_name (Filename.basename filename) in
+  begin match dialog#run (), dialog#filename with
+    `SAVE, Some name ->
+      dialog#destroy ();
+      let f = open_out name in
+      fprintf f "%s\n" contents;
+      close_out f
+  | _ -> dialog#destroy ()
+  end
+
+
+
+
 (************************** MAIN ********************************************)
 let () =
   let file_to_edit = ref "" in
@@ -614,9 +717,17 @@ let () =
   pack_widgets `HORIZONTAL the_layout widgets window#add;
 
   (** packing mapgets *)
-  let papgets = find_widget_children "map2d" the_layout in
+  let papgets = try find_widget_children "map2d" the_layout with Not_found -> [] in
   List.iter (pack_papget geomap) papgets;
   listen_dropped_papgets geomap;
+  let save_layout = fun () ->
+    let the_new_layout = replace_widget_children "map2d" (papgets_config ()) the_layout in
+    let width, height = Gdk.Drawable.get_size window#misc#window in
+    let new_layout = Xml.Element ("layout", ["width", soi width; "height", soi height], [the_new_layout]) in
+    save_layout layout_file (Xml.to_string_fmt new_layout)
+ in
+  ignore (menu_fact#add_item "Save layout" ~key:GdkKeysyms._S ~callback:save_layout);
+
 
   if !mplayer <> "" then
     plugin_window := sprintf "mplayer -nomouseinput %s -wid " !mplayer;

sw/ground_segment/cockpit/live.ml

@@ -204,6 +204,10 @@ let jump_to_block = fun ac_id id ->
   Ground_Pprz.message_send "gcs" "JUMP_TO_BLOCK" 
     ["ac_id", Pprz.String ac_id; "block_id", Pprz.Int id]
 
+let dl_setting = fun ac_id 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
+
 let menu_entry_of_block = fun ac_id (id, name) ->
   let send_msg = fun () -> jump_to_block ac_id id in
   `I (name, send_msg)
@@ -476,9 +480,8 @@ let create_ac = fun alert (geomap:G.widget) (acs_notebook:GPack.notebook) (ac_id
       prerr_endline (Printexc.to_string exc);
       Xml.Element("empty", [], [])
   in
-  let dl_setting_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 dl_setting_callback = fun idx value ->
+    dl_setting ac_id idx value in
   let dl_settings_page =
     try
       let xml_settings = Xml.children (ExtXml.child settings_xml "dl_settings") in

sw/ground_segment/cockpit/live.mli

@@ -26,7 +26,7 @@
 
 
 type color = string
-type aircraft = {
+type aircraft = private {
     ac_name : string;
     config : Pprz.values;
     track : MapTrack.track;
@@ -72,3 +72,10 @@ val track_size : int ref
 
 val listen_acs_and_msgs : MapCanvas.widget -> GPack.notebook -> Pages.alert -> bool -> GMisc.drawing_area -> unit
 (** [listen_acs_and_msgs geomap aircraft_notebook alert_page auto_center_new_ac] *)
+
+val jump_to_block : string -> int -> unit
+(** [jump_to_block ac_id block_id] Sends a JUMP_TO_BLOCK message *)
+
+val dl_setting : string -> int -> float -> unit
+(** [dl_setting ac_id var_index value] Sends a DL_SETTING message *)
+

sw/lib/ocaml/papget.ml

@@ -8,10 +8,17 @@ let affine_pos xw yw = affine_pos_and_angle xw yw 0.
 
 let (//) = Filename.concat
 
+
+class type item = object
+  method config : unit -> Xml.xml
+  method deleted : bool
+end
+
 class message = fun ?sender ?(class_name="telemetry") msg_name ->
   object
     val mutable callbacks = []
     method connect = fun f cb -> callbacks <- (f, cb) :: callbacks
+    method msg_name = msg_name
     initializer
       let module P = Pprz.Messages (struct let name = class_name end) in
       let cb = fun _sender values -> 
@@ -45,19 +52,38 @@ class type renderer =
     method edit : (GObj.widget -> unit) -> unit
     method item : movable_item
     method update : string -> unit
+    method config : unit -> Xml.xml list
   end
 
+let get_property = fun attr_name xml ->
+  let attr = ExtXml.child ~select:(fun x -> ExtXml.attrib x "name" = attr_name) xml "property" in
+  ExtXml.attrib attr "value"
 
-class canvas_text = fun canvas_group x y ->
+
+let get_prop = fun name children default ->
+  let xml = Xml.Element ("", [], children) in
+  try get_property name xml with _ -> default
+
+let property = fun name value ->
+  Xml.Element("property", [ "name", name; "value", value ], [])
+
+let float_property = fun name value ->
+  property name (string_of_float value)
+
+class canvas_text = fun ?(config=[]) canvas_group x y ->
   let group = GnoCanvas.group ~x ~y canvas_group in
   let text = GnoCanvas.text group in
   object (self)
-    val mutable format = "%.2f"
-    val mutable size = 15.
-    val mutable color = "green"
+    val mutable format = get_prop "format" config "%.2f"
+    val mutable size = float_of_string (get_prop "size" config "15.")
+    val mutable color = get_prop "color" config "green"
  
     method tag = "Text"
     method item = (group :> movable_item)
+    method config = fun () ->
+      [ property "format" format;
+	float_property "size" size;
+	property "color" color ]
     method set_format = fun f -> format <- f 
     method set_size = fun f -> size <- f 
     method set_color = fun f -> color <- f 
@@ -85,36 +111,43 @@ class canvas_text = fun canvas_group x y ->
   end
 
 
-(********************************* Ruler *************************************)
-class canvas_ruler = fun ?(index_on_right=false) ?(text_props=[`ANCHOR `CENTER; `FILL_COLOR "white"]) ?(max=1000) ?(scale=2.) ?(w=32.) ?(index_width=10.) ?(step=10) ?(h=100.) canvas_group x y ->
+(***************************Vertical Ruler ***********************************)
+class canvas_ruler = fun ?(config=[]) canvas_group x y ->
+
+  let h = float_of_string (get_prop "height" config "100.")
+  and index_on_right = bool_of_string (get_prop "index_on_right" config "false")
+  and scale = float_of_string (get_prop "scale" config "2.")
+  and w = float_of_string (get_prop "width" config "32.")
+  and step = int_of_string (get_prop "step" config "10") in
+  let text_props=[`ANCHOR `CENTER; `FILL_COLOR "white"]
+  and index_width = 10. in
+
   let root = GnoCanvas.group ~x ~y canvas_group in
   let r = GnoCanvas.group root in
-  let height = scale *. float max in
   
-  (* Grey background *)
-  let _ = GnoCanvas.rect ~x1:0. ~y1:(-.height) ~x2:w ~y2:height ~fill_color:"#808080" r in
   let props = (text_props@[`ANCHOR `EAST]) in
   
   (* One step drawer *)
-  let tab = Array.create (max/step) false in
-  let draw = fun i ->
+  let draw = fun i value ->
     let i = i * step in
-    let y = -. scale *. float i in
-    let text = Printf.sprintf "%d" i in
-    let _ = GnoCanvas.text ~text ~props ~y ~x:(w*.0.75) r in
-    let _ = GnoCanvas.line ~points:[|w*.0.8;y;w-.1.;y|] ~fill_color:"white" r in
+    let y = -. scale *. (float i -. value) in
+    if y >= -. h && y <= h then begin
+      let text = Printf.sprintf "%d" i in
+      ignore (GnoCanvas.text ~text ~props ~y ~x:(w*.0.75) r);
+      ignore(GnoCanvas.line ~points:[|w*.0.8;y;w-.1.;y|] ~fill_color:"white" r)
+    end;
     let y = y -. float step /. 2. *. scale in
-    let _ = GnoCanvas.line ~points:[|w*.0.8;y;w-.1.;y|] ~fill_color:"white" r in
-    () in
+    if y >= -. h && y <= h then
+      ignore(GnoCanvas.line ~points:[|w*.0.8;y;w-.1.;y|] ~fill_color:"white" r)
+  in
   
-  let lazy_drawer = fun v ->
-    let v = truncate v / step in
+  let drawer = fun value ->
+    (* Remove previous items *)
+    List.iter (fun i -> i#destroy ()) r#get_items;
+    let v = truncate value / step in
     let k = truncate (h /. scale) / step in
-    for i = Pervasives.max 0 (v - k) to min (v + k) (Array.length tab - 1) do (* FIXME *)
-      if not tab.(i) then begin
-	tab.(i) <- true;
-	draw i
-      end
+    for i = Pervasives.max 0 (v - k) to (v + k) do
+      draw i value
     done in
   
   (** Yellow index *)
@@ -125,34 +158,57 @@ class canvas_ruler = fun ?(index_on_right=false) ?(text_props=[`ANCHOR `CENTER;
     if index_on_right then
       idx#affine_absolute (affine_pos_and_angle w 0. Latlong.pi) in
   
-  (** Mask (bottom & top) *)
-  let _ = GnoCanvas.rect ~x1:0. ~y1:(-.height) ~x2:w ~y2:(-.h) ~fill_color:"black" root in
-  let _ = GnoCanvas.rect ~x1:0. ~y1:height ~x2:w ~y2:h ~fill_color:"black" root in
-  
   object
     method tag = "Ruler"
     method edit = fun (pack:GObj.widget -> unit) -> ()
     method update = fun value ->
       let value = float_of_string value in
-      r#affine_absolute (affine_pos 0. 0.);
-      lazy_drawer value;
-      r#affine_absolute (affine_pos 0. (scale*.value));
+      drawer value
     method item = (root :> movable_item)
+    method config = fun () -> config (* Not editable *)
+  end
+
+(****************************************************************************)
+class canvas_button = fun ?(config=[]) canvas_group x y ->
+  let icon = get_prop "icon" config "icon_file" in
+  let pixbuf = GdkPixbuf.from_file (Env.gcs_icons_path // icon) in
+  let group = GnoCanvas.group ~x ~y canvas_group in
+  let _item = GnoCanvas.pixbuf ~pixbuf group in
+  object
+    method tag = "Button"
+    method item = (group :> movable_item)
+    method edit = fun (pack:GObj.widget -> unit) -> ()
+    method update = fun (value:string) -> ()
+    method config = fun () ->
+      [ property "icon" icon]
+  end
+
+
+(****************************************************************************)
+class widget_renderer = fun (tag:string) widget ?(config=[]) canvas_group x y ->
+  let group = GnoCanvas.group ~x ~y canvas_group in
+  let item = GnoCanvas.widget ~width:50. ~height:50. ~widget group in
+  object
+    method tag = tag
+    method edit = fun (_:GObj.widget->unit) -> () 
+    method item = (item :> movable_item)
+    method update = fun (_:string) -> ()
+    method config = fun () -> (config : Xml.xml list)
   end
 
 
 let renderers =
-  [ (new canvas_text :> #GnoCanvas.group -> float -> float -> renderer);
-    new canvas_ruler ] 
+  [ (new canvas_text :> ?config:Xml.xml list -> #GnoCanvas.group -> float -> float -> renderer);
+    (new canvas_ruler :> ?config:Xml.xml list -> #GnoCanvas.group -> float -> float -> renderer) ] 
 
 let lazy_tagged_renderers = lazy
-  (let x = 0. and y = 0.
-  and group = (GnoCanvas.canvas ())#root in
-  List.map
-    (fun constructor ->
-      let o = constructor group x y in
-      (o#tag, constructor))
-    renderers)
+    (let x = 0. and y = 0.
+    and group = (GnoCanvas.canvas ())#root in
+    List.map
+      (fun constructor ->
+	let o = constructor ?config:None group x y in
+	(o#tag, constructor))
+      renderers)
     
 
 class canvas_item = fun canvas_renderer ->
@@ -162,6 +218,15 @@ class canvas_item = fun canvas_renderer ->
     val mutable renderer = canvas_renderer
     val mutable x_press = 0.
     val mutable y_press = 0.
+    val mutable deleted = false
+	
+    method renderer = renderer
+
+    method xy = 
+      let (x0, y0) = renderer#item#i2w 0. 0. in
+      renderer#item#parent#w2i x0 y0
+
+    method deleted = deleted
 
     method update = fun value ->
       (renderer#update:string->unit) value
@@ -192,7 +257,8 @@ class canvas_item = fun canvas_renderer ->
 	    let x = GdkEvent.Motion.x ev
 	    and y = GdkEvent.Motion.y ev in
 	    let (xw, yw) = renderer#item#parent#w2i x y in
-	    item#set [`X (xw-.x_press); `Y (yw-.y_press)]
+	    item#set [`X (xw-.x_press); `Y (yw-.y_press)];
+	    renderer#item#parent#affine_relative [|1.;0.;0.;1.;0.;0.|]
 	  end;
 	  true
       | `BUTTON_RELEASE ev ->
@@ -214,6 +280,13 @@ class canvas_item = fun canvas_renderer ->
       let strings = List.map fst tagged_renderers in
 
       let (combo, (tree, column)) = GEdit.combo_box_text ~packing:dialog#box_item_chooser#add ~strings () in
+      tree#foreach 
+	(fun _path row ->
+	  if tree#get ~row ~column = renderer#tag then begin
+	    combo#set_active_iter (Some row);
+	    true
+	  end else
+	    false);
       
       let connect_item_editor = fun () ->
 	begin (* Remove the current child ? *)
@@ -245,6 +318,11 @@ class canvas_item = fun canvas_renderer ->
 			connect_item_editor ()));
 
       (* Connect the buttons *)
+      ignore (dialog#button_delete#connect#clicked
+		(fun () -> 
+		  dialog#papget_editor#destroy ();
+		  renderer#item#destroy ();
+		  deleted <- true));
       ignore (dialog#button_ok#connect#clicked (fun () -> dialog#papget_editor#destroy ()))
 
     val mutable connection =
@@ -257,26 +335,27 @@ class canvas_item = fun canvas_renderer ->
       self#connect ()
   end
 
-
 class canvas_display_item = fun msg_obj field_name canvas_renderer ->
   object
     inherit field msg_obj field_name as super
     inherit canvas_item canvas_renderer as item
 
     method update_field = fun value ->
-      super#update_field value;
-      item#update value
+      if not deleted then begin
+	super#update_field value;
+	item#update value
+      end
 
-  end
-
-
-(****************************************************************************)
-class canvas_button = fun icon_file ->
-  let button = GButton.button () in
-  let pixbuf = GdkPixbuf.from_file icon_file in
-  let _ = GMisc.image ~pixbuf ~packing:button#add () in
-  object
-    method update = fun (value:float) -> ()
+    method config = fun () ->
+      let props = renderer#config () in
+      let field = sprintf "%s:%s" msg_obj#msg_name field_name in
+      let prop = property "field" field in
+      let (x, y) = item#xy in
+      let attrs =
+	[ "type", "message_field";
+	  "display", String.lowercase item#renderer#tag;
+	  "x", sprintf "%.0f" x; "y", sprintf "%.0f" y ] in
+      Xml.Element ("papget", attrs, prop::props)
   end
 
 
@@ -293,4 +372,31 @@ class canvas_setting_item = fun variable canvas_renderer ->
   end
 
 
+(****************************************************************************)
+(** A clickable item is not editable: The #edit method is overiden with a
+    provided callback *)
+class canvas_clickable_item = fun type_ properties callback canvas_renderer ->
+  object
+    inherit canvas_item canvas_renderer as item
+    method edit = fun () -> callback () 
 
+    method config = fun () ->
+      let props = renderer#config () in
+      let (x, y) = item#xy in
+      let attrs =
+	[ "type", type_;
+	  "display", String.lowercase item#renderer#tag;
+	  "x", sprintf "%.0f" x; "y", sprintf "%.0f" y ] in
+      Xml.Element ("papget", attrs, properties@props)
+  end
+
+
+class canvas_goto_block_item = fun properties callback canvas_renderer ->
+  object
+    inherit canvas_clickable_item "goto_block" properties callback canvas_renderer as item
+  end
+
+class canvas_variable_setting_item = fun properties callback canvas_renderer ->
+  object
+    inherit canvas_clickable_item "variable_setting" properties callback canvas_renderer
+  end

sw/lib/ocaml/widgets.glade

@@ -134,7 +134,7 @@
   <property name="title" translatable="yes">Papget Editor</property>
   <property name="type">GTK_WINDOW_TOPLEVEL</property>
   <property name="window_position">GTK_WIN_POS_NONE</property>
-  <property name="modal">False</property>
+  <property name="modal">True</property>
   <property name="resizable">True</property>
   <property name="destroy_with_parent">False</property>
   <property name="decorated">True</property>
@@ -211,7 +211,7 @@
 	    <widget class="GtkButton" id="button_ok">
 	      <property name="visible">True</property>
 	      <property name="can_focus">True</property>
-	      <property name="label">gtk-ok</property>
+	      <property name="label">gtk-close</property>
 	      <property name="use_stock">True</property>
 	      <property name="relief">GTK_RELIEF_NORMAL</property>
 	      <property name="focus_on_click">True</property>