+++ /dev/null
-(* $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 ()
projects / helm.git / blobdiff