X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;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=0000000000000000000000000000000000000000;hp=cb150e08633a8bcef22cd0594e7be56ac758a2a3;hb=3ef089a4c58fbe429dd539af6215991ecbe11ee2;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff 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 deleted file mode 100644 index cb150e086..000000000 --- a/helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/radtest/main.ml +++ /dev/null @@ -1,393 +0,0 @@ -(* $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 ()