helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/radtest/main.ml

   1 (* $Id$ *)
   2
   3 open GdkKeysyms
   4 open Gtk
   5 open GObj
   6
   7 open Utils
   8 open TiBase
   9
  10 let main_project_modify = ref false
  11
  12 let main_window  = GWindow.window ~title:"ZOOM" ~x:10 ~y:10 ()
  13 let main_vbox    = GPack.vbox ~packing:main_window#add ()
  14 let main_menu    = GMenu.menu_bar ~packing:(main_vbox#pack ~expand:false) ()
  15
  16 let can_copy = ref (fun _ -> assert false)
  17 let can_paste = ref (fun _ -> assert false)
  18
  19 class project () =
  20   let project_box = GPack.vbox ~packing:main_vbox#pack () in
  21   let project_tree = GTree2.tree ~packing:project_box#pack () in
  22   object(self)
  23     val mutable window_list = []
  24
  25 (* the selected window *)
  26     val mutable selected = (None : window_and_tree option)
  27
  28     method change_selected sel =
  29       match selected with
  30       | None ->
  31           selected <- Some sel;
  32           sel#project_tree_item#misc#set_state `SELECTED;
  33           !can_copy true
  34       | Some old_sel ->
  35           if sel = old_sel then begin
  36             selected <- None;
  37             sel#project_tree_item#misc#set_state `NORMAL;
  38             !can_copy false
  39           end else begin
  40             old_sel#project_tree_item#misc#set_state `NORMAL;
  41             selected <- Some sel;
  42             sel#project_tree_item#misc#set_state `SELECTED;
  43             !can_copy true
  44           end
  45
  46     val mutable filename = ""
  47     val mutable dirname = ""
  48
  49     method set_filename f =
  50       let dir, file = split_filename f ~ext:".rad" in
  51       filename <- file;
  52       dirname <- dir
  53
  54     method get_filename () =
  55       get_filename ~callback:self#set_filename ~dir:dirname ()
  56
  57     method dirname = dirname
  58
  59 (*    method set_dirname f = dirname <- f *)
  60
  61     method add_window ~name ?tree:wt () =
  62       let wt = match wt with
  63       | None -> new window_and_tree ~name
  64       | Some wt -> wt in
  65       let tiwin = wt#tiwin and tw=wt#tree_window in
  66       let project_tree_item = wt#project_tree_item in
  67       project_tree#append project_tree_item;
  68       let show = ref true in
  69       project_tree_item#event#connect#button_press ~callback:
  70         (fun ev ->
  71         match GdkEvent.get_type ev with
  72         | `BUTTON_PRESS ->
  73             if GdkEvent.Button.button ev = 1 then begin
  74               self#change_selected wt
  75             end else
  76             if GdkEvent.Button.button ev = 3 then begin
  77               let menu = GMenu.menu () in
  78               let name = wt#tiwin#name in
  79               let mi_remove = GMenu.menu_item ~label:("delete " ^ name)
  80                   ~packing:menu#append ()
  81               and mi_copy = GMenu.menu_item ~label:("copy " ^ name)
  82                   ~packing:menu#append ()
  83               and mi_cut = GMenu.menu_item ~label:("cut " ^ name)
  84                   ~packing:menu#append () in
  85               mi_remove#connect#activate
  86                 ~callback:(fun () -> self#delete_window wt);
  87               mi_copy#connect#activate
  88                 ~callback:(fun () -> self#copy_wt wt);
  89               mi_cut#connect#activate
  90                 ~callback:(fun () -> self#cut_wt wt);
  91               menu#popup ~button:3 ~time:(GdkEvent.Button.time ev)
  92             end;
  93             GtkSignal.stop_emit ();
  94             true
  95         | `TWO_BUTTON_PRESS ->
  96             if GdkEvent.Button.button ev = 1 then begin
  97               if !show then begin
  98                 show := false;
  99                 tiwin#widget#misc#hide ();
 100                 tw#misc#hide ()
 101               end
 102               else begin
 103                 show := true;
 104                 tiwin#widget#misc#show ();
 105                 tw#misc#show ()
 106               end
 107             end;
 108             true
 109         | _ -> false);
 110       tiwin#connect_event#delete ~callback:
 111         (fun _ -> show := false; tiwin#widget#misc#hide (); true);
 112       tw#event#connect#delete ~callback:
 113         (fun _ -> show := false; tw#misc#hide (); true);
 114       window_list <- wt :: window_list;
 115       add_undo (Remove_window name);
 116       main_window#misc#set_can_focus false;
 117       main_window#misc#grab_focus ()
 118
 119
 120     method add_window_by_node
 121         (Node ((classe, name, proplist), children)) =
 122       if classe <> "window"
 123       then failwith "add_window_by_node: class <> \"window\"";
 124       let name = change_name name in  (* for paste *)
 125       let wt = new window_and_tree ~name in
 126       let tiwin = wt#tiwin in
 127       List.iter proplist ~f:(fun (n,v) -> tiwin#set_property n v);
 128       begin match children with
 129       | [] -> ()
 130       | [ ch ] -> tiwin#add_children_wo_undo ch; ()
 131       | _ -> failwith "add_window_by_node: more than one child"
 132       end;
 133       self#add_window ~name ~tree:wt ()
 134
 135     method delete_window (wt : window_and_tree) =
 136       let tiwin = wt#tiwin in
 137       project_tree#remove wt#project_tree_item;
 138       tiwin#remove_me ();
 139       wt#tree_window#destroy ();
 140       window_list <- list_remove ~f:(fun w -> w = wt) window_list
 141
 142     method delete_window_by_name ~name =
 143       let wt = List.find window_list ~f:(fun wt -> wt#tiwin#name = name) in
 144       self#delete_window wt
 145
 146     method delete () =
 147       List.iter window_list
 148         ~f:(fun wt -> self#delete_window wt);
 149       main_vbox#remove project_box#coerce;
 150 (* remove after test *)
 151       if !name_list <> [] then failwith "name_list not empty"
 152
 153     method save_as () = if self#get_filename () then self#save ()
 154
 155     method save () =
 156       if filename = "" then self#save_as ()
 157       else begin
 158         let outch = open_out (dirname ^ filename ^ ".rad") in
 159         let f = Format.formatter_of_out_channel outch in
 160         List.iter window_list ~f:(fun wt -> wt#tiwin#save f);
 161         close_out outch;
 162         main_project_modify := false
 163       end
 164
 165     method copy_wt (wt : window_and_tree) =
 166       wt#tiwin#copy ();
 167       !can_paste true
 168
 169     method cut_wt (wt : window_and_tree) =
 170       self#copy_wt wt;
 171       self#delete_window wt
 172
 173     method copy () =
 174       match selected with
 175       | None -> failwith "main_project copy"
 176       | Some sel -> self#copy_wt sel
 177
 178     method cut () =
 179       match selected with
 180       | None -> failwith "main_project cut"
 181       | Some sel -> self#cut_wt sel
 182
 183     method paste () =
 184       let lexbuf = Lexing.from_string !window_selection in
 185       let node = Load_parser.window Load_lexer.token lexbuf in
 186       self#add_window_by_node node
 187
 188     method emit () =
 189       let outc = open_out (dirname ^ filename ^ ".ml") in
 190       let f = Format.formatter_of_out_channel outc in
 191       List.iter window_list ~f:(fun wt -> wt#emit f);
 192       Format.fprintf f "let main () =@\n";
 193 (* this is just for demo *)
 194       List.iter window_list ~f:
 195         begin fun wt ->
 196           let name = wt#tiwin#name in
 197           Format.fprintf f "  let %s = new %s () in %s#show ();@\n"
 198             name name name
 199         end;
 200       Format.fprintf f
 201         "  GMain.Main.main ()@\n@\nlet _ = main ()@\n";
 202       close_out outc
 203
 204   end
 205
 206
 207 let main_project = ref (new project ())
 208
 209 let load () =
 210   let filename = ref "" in
 211   get_filename ~callback:(fun f -> filename := f) ~dir:!main_project#dirname ();
 212   if !filename <> "" then begin
 213     !main_project#delete ();
 214     main_project := new project ();
 215     let inch = open_in !filename in
 216     let lexbuf = Lexing.from_channel inch in
 217     let project_list = Load_parser.project Load_lexer.token lexbuf in
 218     close_in inch;
 219     List.iter project_list
 220       ~f:(fun node -> !main_project#add_window_by_node node);
 221     !main_project#set_filename !filename
 222   end
 223
 224
 225 let interpret_undo = function
 226   | Add (parent_name, node, pos) ->
 227       let parent = Hashtbl.find widget_map parent_name in
 228       parent#add_children node ~pos
 229   | Remove child_name ->
 230       let child  = Hashtbl.find widget_map child_name in
 231       child#remove_me ()
 232   | Property (property, value_string) ->
 233       property#set value_string
 234   | Add_window node -> !main_project#add_window_by_node node
 235   | Remove_window name -> !main_project#delete_window_by_name ~name
 236
 237 let undo () =
 238   if !last_action_was_undo then begin
 239     match !next_undo_info with
 240     | hd :: tl -> interpret_undo hd; next_undo_info := tl
 241     | [] -> message "no more undo info"
 242   end
 243   else begin
 244     match !undo_info with
 245     | hd :: tl -> interpret_undo hd; next_undo_info := tl
 246     | [] -> message "no undo info"
 247   end;
 248   last_action_was_undo := true
 249
 250
 251 let targets = [  { target = "STRING"; flags = []; info = 0}  ]
 252
 253 let xpm_window () =
 254   let source_drag_data_get classe _ (data : selection_data) ~info ~time =
 255     data#set ~typ:data#target ~format:0 ~data:classe in
 256   let window = GWindow.window ~title:"icons" ~x:250 ~y:10 () in
 257   window#misc#realize ();
 258   let vbox = GPack.vbox ~packing:window#add () in
 259   let table = GPack.table ~rows:1 ~columns:5 ~border_width:20
 260       ~packing:vbox#pack () in
 261   let tooltips = GData.tooltips () in
 262   let add_xpm ~file ~left ~top ~tip =
 263     let gdk_pix = GDraw.pixmap_from_xpm ~file ~window () in
 264     let ev = GBin.event_box ~packing:(table#attach ~left ~top) () in
 265     let pix = GMisc.pixmap gdk_pix ~packing:ev#add () in
 266     ev#event#connect#button_press ~callback:
 267       (fun ev -> match GdkEvent.get_type ev with
 268         | `BUTTON_PRESS ->
 269             if GdkEvent.Button.button ev = 1 then begin
 270               !main_project#add_window ~name:(make_new_name "window") ()
 271             end;
 272             true
 273         | _ -> false);
 274     tooltips#set_tip ev#coerce ~text:tip
 275   in
 276   add_xpm ~file:"window.xpm" ~left:0 ~top:0 ~tip:"window";
 277   GMisc.separator `HORIZONTAL ~packing:vbox#pack ();
 278   let table = GPack.table ~rows:6 ~columns:6 ~packing:vbox#pack
 279       ~row_spacings:20 ~col_spacings:20 ~border_width:20 () in
 280   let add_xpm file ~left ~top ~classe =
 281     let gdk_pix = GDraw.pixmap_from_xpm ~file ~window () in
 282     let ev = GBin.event_box ~packing:(table#attach ~left ~top) () in
 283     let pix = GMisc.pixmap gdk_pix ~packing:ev#add () in
 284     ev#drag#source_set ~modi:[`BUTTON1] targets ~actions:[`COPY];
 285     ev#drag#source_set_icon ~colormap:window#misc#style#colormap
 286       gdk_pix;
 287     ev#drag#connect#data_get ~callback:(source_drag_data_get classe);
 288     tooltips#set_tip ev#coerce ~text:classe
 289   in
 290
 291   add_xpm "button.xpm"         ~left:0 ~top:0 ~classe:"button";
 292   add_xpm "togglebutton.xpm"   ~left:1 ~top:0 ~classe:"toggle_button";
 293   add_xpm "checkbutton.xpm"    ~left:2 ~top:0 ~classe:"check_button";
 294   add_xpm "radiobutton.xpm"    ~left:3 ~top:0 ~classe:"radio_button";
 295   add_xpm "toolbar.xpm"        ~left:4 ~top:0 ~classe:"toolbar";
 296   add_xpm "hbox.xpm"           ~left:0 ~top:1 ~classe:"hbox";
 297   add_xpm "vbox.xpm"           ~left:1 ~top:1 ~classe:"vbox";
 298   add_xpm "hbuttonbox.xpm"     ~left:2 ~top:1 ~classe:"hbutton_box";
 299   add_xpm "vbuttonbox.xpm"     ~left:3 ~top:1 ~classe:"vbutton_box";
 300   add_xpm "fixed.xpm"          ~left:4 ~top:1 ~classe:"fixed";
 301   add_xpm "frame.xpm"          ~left:0 ~top:2 ~classe:"frame";
 302   add_xpm "aspectframe.xpm"    ~left:1 ~top:2 ~classe:"aspect_frame";
 303   add_xpm "scrolledwindow.xpm" ~left:2 ~top:2 ~classe:"scrolled_window";
 304   add_xpm "eventbox.xpm"       ~left:3 ~top:2 ~classe:"event_box";
 305   add_xpm "handlebox.xpm"      ~left:4 ~top:2 ~classe:"handle_box";
 306   add_xpm "viewport.xpm"       ~left:5 ~top:2 ~classe:"viewport";
 307   add_xpm "hseparator.xpm"     ~left:0 ~top:3 ~classe:"hseparator";
 308   add_xpm "vseparator.xpm"     ~left:1 ~top:3 ~classe:"vseparator";
 309   add_xpm "clist.xpm"          ~left:2 ~top:3 ~classe:"clist";
 310   add_xpm "label.xpm"          ~left:0 ~top:4 ~classe:"label";
 311   add_xpm "statusbar.xpm"      ~left:1 ~top:4 ~classe:"statusbar";
 312   add_xpm "notebook.xpm"       ~left:2 ~top:4 ~classe:"notebook";
 313   add_xpm "colorselection.xpm" ~left:3 ~top:4 ~classe:"color_selection";
 314   add_xpm "pixmap.xpm"         ~left:4 ~top:4 ~classe:"pixmap";
 315   add_xpm "entry.xpm"          ~left:0 ~top:5 ~classe:"entry";
 316   add_xpm "spinbutton.xpm"     ~left:1 ~top:5 ~classe:"spin_button";
 317   add_xpm "combo.xpm"          ~left:2 ~top:5 ~classe:"combo";
 318
 319   window#show ();
 320   window
 321
 322
 323 let main () =
 324   let _ = GMain.Main.init () in
 325   let prop_win = Propwin.init () in
 326   let palette = xpm_window () in
 327   main_window#show ();
 328   main_window#connect#destroy ~callback:GMain.Main.quit;
 329
 330   let mp = main_project in
 331   let f = new GMenu.factory main_menu in
 332   let accel_group  = f#accel_group in
 333   main_window#add_accel_group accel_group;
 334   prop_win#add_accel_group accel_group;
 335   palette#add_accel_group accel_group;
 336
 337   let file_menu    = new GMenu.factory (f#add_submenu "File") ~accel_group
 338   and edit_menu    = new GMenu.factory (f#add_submenu "Edit") ~accel_group
 339   and view_menu    = new GMenu.factory (f#add_submenu "View") ~accel_group
 340   and project_menu = new GMenu.factory (f#add_submenu "Project") ~accel_group
 341   in
 342
 343   file_menu#add_item "Quit" ~key:_Q ~callback:GMain.Main.quit;
 344
 345   project_menu#add_item "New" ~key:_N
 346     ~callback:(fun () -> !mp#delete (); mp := new project ());
 347   project_menu#add_item "Open..." ~key:_O ~callback:load;
 348   project_menu#add_item "Save" ~key:_S ~callback:(fun () -> !mp#save ());
 349   project_menu#add_item "Save as..." ~callback:(fun () -> !mp#save_as ());
 350   project_menu#add_separator ();
 351   project_menu#add_item "Emit code" ~callback:(fun () -> !mp#emit ());
 352
 353   let copy_item =
 354     edit_menu#add_item "Copy" ~key:_C ~callback:(fun () -> !mp#copy ())
 355   and cut_item =
 356     edit_menu#add_item "Cut" ~key:_X ~callback:(fun () -> !mp#cut ())
 357   and paste_item =
 358     edit_menu#add_item "Paste" ~key:_V ~callback:(fun () -> !mp#paste ())
 359   in
 360   can_copy :=
 361     (fun b -> copy_item#misc#set_sensitive b; cut_item#misc#set_sensitive b);
 362   can_paste := paste_item#misc#set_sensitive;
 363   !can_copy false; !can_paste false;
 364   edit_menu#add_item "Undo" ~key:_Z ~callback:undo;
 365
 366   let palette_visible = ref true in
 367   palette#event#connect#delete ~callback:
 368     (fun _ -> palette_visible := false; palette#misc#hide (); true);
 369   view_menu#add_item "Palette"
 370     ~callback:(fun () ->
 371       if !palette_visible then begin
 372         palette#misc#hide ();
 373         palette_visible := false
 374       end else begin
 375         palette#misc#show ();
 376         palette_visible := true
 377       end);
 378   let prop_win_visible = ref true in
 379   prop_win#event#connect#delete ~callback:
 380     (fun _ -> prop_win_visible := false; prop_win#misc#hide (); true);
 381   view_menu#add_item "Properties window"
 382     ~callback:(fun () ->
 383       if !prop_win_visible then begin
 384         prop_win#misc#hide ();
 385         prop_win_visible := false
 386       end else begin
 387         prop_win#misc#show ();
 388         prop_win_visible := true
 389       end);
 390
 391   GMain.Main.main ()
 392
 393 let _ = main ()