X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=inline;f=helm%2FDEVEL%2Flablgtk%2Flablgtk_20001129-0.1.0%2Fapplications%2Fradtest%2Fmain.ml;fp=helm%2FDEVEL%2Flablgtk%2Flablgtk_20001129-0.1.0%2Fapplications%2Fradtest%2Fmain.ml;h=cb150e08633a8bcef22cd0594e7be56ac758a2a3;hb=7aa91a2cd4497f68ebf5b9dd85b5f2c791f738a1;hp=0000000000000000000000000000000000000000;hpb=044a71416237d8e2b575678b5f49b8c9380ca409;p=helm.git diff --git a/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/radtest/main.ml b/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/radtest/main.ml new file mode 100644 index 000000000..cb150e086 --- /dev/null +++ b/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/radtest/main.ml @@ -0,0 +1,393 @@ +(* $Id$ *) + +open GdkKeysyms +open Gtk +open GObj + +open Utils +open TiBase + +let main_project_modify = ref false + +let main_window = GWindow.window ~title:"ZOOM" ~x:10 ~y:10 () +let main_vbox = GPack.vbox ~packing:main_window#add () +let main_menu = GMenu.menu_bar ~packing:(main_vbox#pack ~expand:false) () + +let can_copy = ref (fun _ -> assert false) +let can_paste = ref (fun _ -> assert false) + +class project () = + let project_box = GPack.vbox ~packing:main_vbox#pack () in + let project_tree = GTree2.tree ~packing:project_box#pack () in + object(self) + val mutable window_list = [] + +(* the selected window *) + val mutable selected = (None : window_and_tree option) + + method change_selected sel = + match selected with + | None -> + selected <- Some sel; + sel#project_tree_item#misc#set_state `SELECTED; + !can_copy true + | Some old_sel -> + if sel = old_sel then begin + selected <- None; + sel#project_tree_item#misc#set_state `NORMAL; + !can_copy false + end else begin + old_sel#project_tree_item#misc#set_state `NORMAL; + selected <- Some sel; + sel#project_tree_item#misc#set_state `SELECTED; + !can_copy true + end + + val mutable filename = "" + val mutable dirname = "" + + method set_filename f = + let dir, file = split_filename f ~ext:".rad" in + filename <- file; + dirname <- dir + + method get_filename () = + get_filename ~callback:self#set_filename ~dir:dirname () + + method dirname = dirname + +(* method set_dirname f = dirname <- f *) + + method add_window ~name ?tree:wt () = + let wt = match wt with + | None -> new window_and_tree ~name + | Some wt -> wt in + let tiwin = wt#tiwin and tw=wt#tree_window in + let project_tree_item = wt#project_tree_item in + project_tree#append project_tree_item; + let show = ref true in + project_tree_item#event#connect#button_press ~callback: + (fun ev -> + match GdkEvent.get_type ev with + | `BUTTON_PRESS -> + if GdkEvent.Button.button ev = 1 then begin + self#change_selected wt + end else + if GdkEvent.Button.button ev = 3 then begin + let menu = GMenu.menu () in + let name = wt#tiwin#name in + let mi_remove = GMenu.menu_item ~label:("delete " ^ name) + ~packing:menu#append () + and mi_copy = GMenu.menu_item ~label:("copy " ^ name) + ~packing:menu#append () + and mi_cut = GMenu.menu_item ~label:("cut " ^ name) + ~packing:menu#append () in + mi_remove#connect#activate + ~callback:(fun () -> self#delete_window wt); + mi_copy#connect#activate + ~callback:(fun () -> self#copy_wt wt); + mi_cut#connect#activate + ~callback:(fun () -> self#cut_wt wt); + menu#popup ~button:3 ~time:(GdkEvent.Button.time ev) + end; + GtkSignal.stop_emit (); + true + | `TWO_BUTTON_PRESS -> + if GdkEvent.Button.button ev = 1 then begin + if !show then begin + show := false; + tiwin#widget#misc#hide (); + tw#misc#hide () + end + else begin + show := true; + tiwin#widget#misc#show (); + tw#misc#show () + end + end; + true + | _ -> false); + tiwin#connect_event#delete ~callback: + (fun _ -> show := false; tiwin#widget#misc#hide (); true); + tw#event#connect#delete ~callback: + (fun _ -> show := false; tw#misc#hide (); true); + window_list <- wt :: window_list; + add_undo (Remove_window name); + main_window#misc#set_can_focus false; + main_window#misc#grab_focus () + + + method add_window_by_node + (Node ((classe, name, proplist), children)) = + if classe <> "window" + then failwith "add_window_by_node: class <> \"window\""; + let name = change_name name in (* for paste *) + let wt = new window_and_tree ~name in + let tiwin = wt#tiwin in + List.iter proplist ~f:(fun (n,v) -> tiwin#set_property n v); + begin match children with + | [] -> () + | [ ch ] -> tiwin#add_children_wo_undo ch; () + | _ -> failwith "add_window_by_node: more than one child" + end; + self#add_window ~name ~tree:wt () + + method delete_window (wt : window_and_tree) = + let tiwin = wt#tiwin in + project_tree#remove wt#project_tree_item; + tiwin#remove_me (); + wt#tree_window#destroy (); + window_list <- list_remove ~f:(fun w -> w = wt) window_list + + method delete_window_by_name ~name = + let wt = List.find window_list ~f:(fun wt -> wt#tiwin#name = name) in + self#delete_window wt + + method delete () = + List.iter window_list + ~f:(fun wt -> self#delete_window wt); + main_vbox#remove project_box#coerce; +(* remove after test *) + if !name_list <> [] then failwith "name_list not empty" + + method save_as () = if self#get_filename () then self#save () + + method save () = + if filename = "" then self#save_as () + else begin + let outch = open_out (dirname ^ filename ^ ".rad") in + let f = Format.formatter_of_out_channel outch in + List.iter window_list ~f:(fun wt -> wt#tiwin#save f); + close_out outch; + main_project_modify := false + end + + method copy_wt (wt : window_and_tree) = + wt#tiwin#copy (); + !can_paste true + + method cut_wt (wt : window_and_tree) = + self#copy_wt wt; + self#delete_window wt + + method copy () = + match selected with + | None -> failwith "main_project copy" + | Some sel -> self#copy_wt sel + + method cut () = + match selected with + | None -> failwith "main_project cut" + | Some sel -> self#cut_wt sel + + method paste () = + let lexbuf = Lexing.from_string !window_selection in + let node = Load_parser.window Load_lexer.token lexbuf in + self#add_window_by_node node + + method emit () = + let outc = open_out (dirname ^ filename ^ ".ml") in + let f = Format.formatter_of_out_channel outc in + List.iter window_list ~f:(fun wt -> wt#emit f); + Format.fprintf f "let main () =@\n"; +(* this is just for demo *) + List.iter window_list ~f: + begin fun wt -> + let name = wt#tiwin#name in + Format.fprintf f " let %s = new %s () in %s#show ();@\n" + name name name + end; + Format.fprintf f + " GMain.Main.main ()@\n@\nlet _ = main ()@\n"; + close_out outc + + end + + +let main_project = ref (new project ()) + +let load () = + let filename = ref "" in + get_filename ~callback:(fun f -> filename := f) ~dir:!main_project#dirname (); + if !filename <> "" then begin + !main_project#delete (); + main_project := new project (); + let inch = open_in !filename in + let lexbuf = Lexing.from_channel inch in + let project_list = Load_parser.project Load_lexer.token lexbuf in + close_in inch; + List.iter project_list + ~f:(fun node -> !main_project#add_window_by_node node); + !main_project#set_filename !filename + end + + +let interpret_undo = function + | Add (parent_name, node, pos) -> + let parent = Hashtbl.find widget_map parent_name in + parent#add_children node ~pos + | Remove child_name -> + let child = Hashtbl.find widget_map child_name in + child#remove_me () + | Property (property, value_string) -> + property#set value_string + | Add_window node -> !main_project#add_window_by_node node + | Remove_window name -> !main_project#delete_window_by_name ~name + +let undo () = + if !last_action_was_undo then begin + match !next_undo_info with + | hd :: tl -> interpret_undo hd; next_undo_info := tl + | [] -> message "no more undo info" + end + else begin + match !undo_info with + | hd :: tl -> interpret_undo hd; next_undo_info := tl + | [] -> message "no undo info" + end; + last_action_was_undo := true + + +let targets = [ { target = "STRING"; flags = []; info = 0} ] + +let xpm_window () = + let source_drag_data_get classe _ (data : selection_data) ~info ~time = + data#set ~typ:data#target ~format:0 ~data:classe in + let window = GWindow.window ~title:"icons" ~x:250 ~y:10 () in + window#misc#realize (); + let vbox = GPack.vbox ~packing:window#add () in + let table = GPack.table ~rows:1 ~columns:5 ~border_width:20 + ~packing:vbox#pack () in + let tooltips = GData.tooltips () in + let add_xpm ~file ~left ~top ~tip = + let gdk_pix = GDraw.pixmap_from_xpm ~file ~window () in + let ev = GBin.event_box ~packing:(table#attach ~left ~top) () in + let pix = GMisc.pixmap gdk_pix ~packing:ev#add () in + ev#event#connect#button_press ~callback: + (fun ev -> match GdkEvent.get_type ev with + | `BUTTON_PRESS -> + if GdkEvent.Button.button ev = 1 then begin + !main_project#add_window ~name:(make_new_name "window") () + end; + true + | _ -> false); + tooltips#set_tip ev#coerce ~text:tip + in + add_xpm ~file:"window.xpm" ~left:0 ~top:0 ~tip:"window"; + GMisc.separator `HORIZONTAL ~packing:vbox#pack (); + let table = GPack.table ~rows:6 ~columns:6 ~packing:vbox#pack + ~row_spacings:20 ~col_spacings:20 ~border_width:20 () in + let add_xpm file ~left ~top ~classe = + let gdk_pix = GDraw.pixmap_from_xpm ~file ~window () in + let ev = GBin.event_box ~packing:(table#attach ~left ~top) () in + let pix = GMisc.pixmap gdk_pix ~packing:ev#add () in + ev#drag#source_set ~modi:[`BUTTON1] targets ~actions:[`COPY]; + ev#drag#source_set_icon ~colormap:window#misc#style#colormap + gdk_pix; + ev#drag#connect#data_get ~callback:(source_drag_data_get classe); + tooltips#set_tip ev#coerce ~text:classe + in + + add_xpm "button.xpm" ~left:0 ~top:0 ~classe:"button"; + add_xpm "togglebutton.xpm" ~left:1 ~top:0 ~classe:"toggle_button"; + add_xpm "checkbutton.xpm" ~left:2 ~top:0 ~classe:"check_button"; + add_xpm "radiobutton.xpm" ~left:3 ~top:0 ~classe:"radio_button"; + add_xpm "toolbar.xpm" ~left:4 ~top:0 ~classe:"toolbar"; + add_xpm "hbox.xpm" ~left:0 ~top:1 ~classe:"hbox"; + add_xpm "vbox.xpm" ~left:1 ~top:1 ~classe:"vbox"; + add_xpm "hbuttonbox.xpm" ~left:2 ~top:1 ~classe:"hbutton_box"; + add_xpm "vbuttonbox.xpm" ~left:3 ~top:1 ~classe:"vbutton_box"; + add_xpm "fixed.xpm" ~left:4 ~top:1 ~classe:"fixed"; + add_xpm "frame.xpm" ~left:0 ~top:2 ~classe:"frame"; + add_xpm "aspectframe.xpm" ~left:1 ~top:2 ~classe:"aspect_frame"; + add_xpm "scrolledwindow.xpm" ~left:2 ~top:2 ~classe:"scrolled_window"; + add_xpm "eventbox.xpm" ~left:3 ~top:2 ~classe:"event_box"; + add_xpm "handlebox.xpm" ~left:4 ~top:2 ~classe:"handle_box"; + add_xpm "viewport.xpm" ~left:5 ~top:2 ~classe:"viewport"; + add_xpm "hseparator.xpm" ~left:0 ~top:3 ~classe:"hseparator"; + add_xpm "vseparator.xpm" ~left:1 ~top:3 ~classe:"vseparator"; + add_xpm "clist.xpm" ~left:2 ~top:3 ~classe:"clist"; + add_xpm "label.xpm" ~left:0 ~top:4 ~classe:"label"; + add_xpm "statusbar.xpm" ~left:1 ~top:4 ~classe:"statusbar"; + add_xpm "notebook.xpm" ~left:2 ~top:4 ~classe:"notebook"; + add_xpm "colorselection.xpm" ~left:3 ~top:4 ~classe:"color_selection"; + add_xpm "pixmap.xpm" ~left:4 ~top:4 ~classe:"pixmap"; + add_xpm "entry.xpm" ~left:0 ~top:5 ~classe:"entry"; + add_xpm "spinbutton.xpm" ~left:1 ~top:5 ~classe:"spin_button"; + add_xpm "combo.xpm" ~left:2 ~top:5 ~classe:"combo"; + + window#show (); + window + + +let main () = + let _ = GMain.Main.init () in + let prop_win = Propwin.init () in + let palette = xpm_window () in + main_window#show (); + main_window#connect#destroy ~callback:GMain.Main.quit; + + let mp = main_project in + let f = new GMenu.factory main_menu in + let accel_group = f#accel_group in + main_window#add_accel_group accel_group; + prop_win#add_accel_group accel_group; + palette#add_accel_group accel_group; + + let file_menu = new GMenu.factory (f#add_submenu "File") ~accel_group + and edit_menu = new GMenu.factory (f#add_submenu "Edit") ~accel_group + and view_menu = new GMenu.factory (f#add_submenu "View") ~accel_group + and project_menu = new GMenu.factory (f#add_submenu "Project") ~accel_group + in + + file_menu#add_item "Quit" ~key:_Q ~callback:GMain.Main.quit; + + project_menu#add_item "New" ~key:_N + ~callback:(fun () -> !mp#delete (); mp := new project ()); + project_menu#add_item "Open..." ~key:_O ~callback:load; + project_menu#add_item "Save" ~key:_S ~callback:(fun () -> !mp#save ()); + project_menu#add_item "Save as..." ~callback:(fun () -> !mp#save_as ()); + project_menu#add_separator (); + project_menu#add_item "Emit code" ~callback:(fun () -> !mp#emit ()); + + let copy_item = + edit_menu#add_item "Copy" ~key:_C ~callback:(fun () -> !mp#copy ()) + and cut_item = + edit_menu#add_item "Cut" ~key:_X ~callback:(fun () -> !mp#cut ()) + and paste_item = + edit_menu#add_item "Paste" ~key:_V ~callback:(fun () -> !mp#paste ()) + in + can_copy := + (fun b -> copy_item#misc#set_sensitive b; cut_item#misc#set_sensitive b); + can_paste := paste_item#misc#set_sensitive; + !can_copy false; !can_paste false; + edit_menu#add_item "Undo" ~key:_Z ~callback:undo; + + let palette_visible = ref true in + palette#event#connect#delete ~callback: + (fun _ -> palette_visible := false; palette#misc#hide (); true); + view_menu#add_item "Palette" + ~callback:(fun () -> + if !palette_visible then begin + palette#misc#hide (); + palette_visible := false + end else begin + palette#misc#show (); + palette_visible := true + end); + let prop_win_visible = ref true in + prop_win#event#connect#delete ~callback: + (fun _ -> prop_win_visible := false; prop_win#misc#hide (); true); + view_menu#add_item "Properties window" + ~callback:(fun () -> + if !prop_win_visible then begin + prop_win#misc#hide (); + prop_win_visible := false + end else begin + prop_win#misc#show (); + prop_win_visible := true + end); + + GMain.Main.main () + +let _ = main ()