X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Flablgtk%2Flablgtk_20000829-0.1.0%2Fapplications%2Fradtest%2FtiWindow.ml;fp=helm%2FDEVEL%2Flablgtk%2Flablgtk_20000829-0.1.0%2Fapplications%2Fradtest%2FtiWindow.ml;h=b44b4d479a9f694cceffe23007a9f781aa9b376f;hb=2ee84a2a641938988703e329aef9fc3c5eb5aacf;hp=0000000000000000000000000000000000000000;hpb=34d83812af9b7064cc8f735c2a78169881140010;p=helm.git

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiWindow.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiWindow.ml
new file mode 100644
index 000000000..b44b4d479
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/tiWindow.ml
@@ -0,0 +1,117 @@
+
+open Utils
+open Property
+
+open TiBase
+open TiContainer
+
+
+class tiwindow ~widget ~name ~parent_tree ~pos ?(insert_evbox=true)
+    parent_window =
+object(self)
+  val window = widget
+  inherit ticontainer ~name ~widget
+      ~insert_evbox:false ~parent_tree ~pos parent_window as container
+
+  method connect_event = window#event#connect
+
+  method private class_name = "GWindow.window"
+
+  method private get_mandatory_props = [ "title" ]
+
+(*  method private save_clean_proplist =
+    List.remove_assoc "title" container#save_clean_proplist
+
+  method private emit_clean_proplist plist =
+    List.remove_assoc "title" (container#emit_clean_proplist plist)
+*)
+  method remove_me () =
+    let sref = ref "" in
+    self#save_to_string sref;
+    let lexbuf = Lexing.from_string !sref in
+    let node = Load_parser.window Load_lexer.token lexbuf in
+    add_undo (Add_window node);
+    self#remove_me_without_undo ()
+
+  method copy () = self#copy_to_sel window_selection
+
+  method remove_me_without_undo () =
+    self#forall ~callback:(fun tiw -> tiw#remove_me_without_undo ());
+    parent_window#remove_sel (self : #tiwidget0 :> tiwidget0);
+    name_list := list_remove !name_list ~f:(fun n -> n=name);
+    Hashtbl.remove widget_map name;
+    Propwin.remove name;
+    widget#destroy ()
+
+  method private get_packing packing = ""
+
+  method emit_code f param_list =
+    let param_string =
+      match param_list with
+      |	 [] -> ""
+      |	_ -> "['" ^
+	  (String.concat ~sep:", '"
+	     (List.map ~f:(fun c -> (String.make 1 c)) param_list)) ^
+	  "] " in
+    Format.fprintf f "(* Code for %s *)@\n@\n@[<hv 2>class %s%s () ="
+      name param_string name;
+    self#emit_init_code f ~packing:"";
+    Format.fprintf f "@]@\n@[<hv 2>object (self)";
+    self#emit_method_code f;
+    Format.fprintf f "@ method show () = %s#show ()" name;
+    Format.fprintf f "@ @[<v 2>initializer";
+    self#emit_initializer_code f;
+    Format.fprintf f "@ ()@]@]@ end@\n@\n"
+
+(*  method private save_start formatter =
+    Format.fprintf formatter "@[<0>@\n@[<2><window name=%s>" name;
+    Format.fprintf formatter "@\ntitle=\"%s\""
+      (List.assoc "title" proplist)#get
+*)
+  method private save_end formatter =
+    Format.fprintf formatter "@]@\n</window>@\n@]"
+
+  method private menu ~time =
+    let menu = GMenu.menu () and menu_add = GMenu.menu () in
+    List.iter
+      ~f:(fun n ->
+	let mi = GMenu.menu_item ~packing:menu_add#append ~label:n ()
+	in mi#connect#activate
+	  ~callback:(fun () -> self#add_child n (); ()); ())
+      widget_add_list;      
+    let mi_add = GMenu.menu_item ~packing:menu#append ~label:("add to "^ name) ()
+    and mi_paste = GMenu.menu_item ~packing:menu#append ~label:"Paste" ()
+    in
+    mi_add#set_submenu menu_add;
+    if !selection <> ""
+    then begin mi_paste#connect#activate ~callback:self#paste; () end
+    else mi_paste#misc#set_sensitive false;
+    menu#popup ~button:3 ~time
+
+
+  initializer
+    classe <- "window";
+    window#set_title name;
+    proplist <-	proplist @
+      [ "title",
+	new prop_string ~name:"title" ~init:name ~set:(ftrue window#set_title);
+	"allow_shrink",	new prop_bool ~name:"allow_shrink" ~init:"false"
+	                  ~set:(ftrue window#set_allow_shrink);
+	"allow_grow", new prop_bool ~name:"allow_grow" ~init:"true"
+	                ~set:(ftrue window#set_allow_grow);
+	"auto_shrink", new prop_bool ~name:"auto_shrink" ~init:"false"
+	                 ~set:(ftrue window#set_auto_shrink);
+	"x position", new prop_int ~name:"x" ~init:"-2"
+	  ~set:(fun x -> window#misc#set_geometry ~x (); true);
+	"y position", new prop_int ~name:"y" ~init:"-2"
+	  ~set:(fun y -> window#misc#set_geometry ~y (); true) ]
+end
+
+let new_tiwindow ~name ?(listprop = []) =
+  let w = GWindow.window ~show:true () in
+  w#misc#set_can_focus false;
+  w#misc#set_can_default false;
+  new tiwindow ~widget:w ~name
+
+
+