helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/fixed_editor.ml

   1 open Gdk
   2 open Gtk
   3 open GObj
   4 open GMain
   5
   6 let dnd_source_window () =
   7   let window = GWindow.window ~position:`MOUSE () in
   8   let vbx = GPack.vbox ~border_width:10 ~packing:window#add ()
   9   in
  10   let evb = GBin.event_box ~border_width:0 ~packing:vbx#add () in
  11   let frm = GBin.frame ~shadow_type:`OUT ~packing:evb#add () in
  12   let lbl = GMisc.label ~text:"hello" ~packing:frm#add () in
  13   let lbl2 = GMisc.label ~text:"drag from here!" ~packing:vbx#add () in
  14   let targets = [ { target = "STRING"; flags = []; info = 0} ] in
  15   begin
  16     window#show ();
  17     evb#drag#source_set targets ~modi:[`BUTTON1] ~actions:[`COPY];
  18     evb#drag#connect#data_get ~callback: begin
  19       fun _ data ~info ~time:_ ->
  20         data#set ~typ:data#target ~format:0 ~data:"hello! "
  21     end
  22   end
  23
  24 let corner_width  = 7
  25 let corner_height = 7
  26
  27 type drag_action_type =
  28     GB_DRAG_NONE
  29   | GB_MIDDLE
  30   | GB_TOP
  31   | GB_BOTTOM
  32   | GB_LEFT
  33   | GB_RIGHT
  34   | GB_TOP_LEFT
  35   | GB_TOP_RIGHT
  36   | GB_BOTTOM_LEFT
  37   | GB_BOTTOM_RIGHT
  38
  39 let get_position_in_widget w ~x ~y ~width ~height =
  40   if (x <= corner_width) then
  41     if (y <= corner_height) then
  42       GB_TOP_LEFT
  43     else if (y >= height-corner_width) then
  44       GB_BOTTOM_LEFT
  45     else GB_LEFT
  46   else if (x >= width-corner_width) then
  47     if (y <= corner_height) then
  48       GB_TOP_RIGHT
  49     else if (y >= height-corner_width) then
  50       GB_BOTTOM_RIGHT
  51     else GB_RIGHT
  52   else if (y <= corner_height) then
  53       GB_TOP
  54     else if (y >= height-corner_width) then
  55       GB_BOTTOM
  56     else GB_MIDDLE
  57
  58 class drag_info = object
  59   val mutable drag_action = GB_DRAG_NONE
  60   val mutable drag_offset = (0, 0)
  61   val mutable toimen      = (0, 0)
  62   val mutable drag_widget = None
  63   method drag_action = drag_action
  64   method drag_offset = drag_offset
  65   method toimen = toimen (* coord. of opposite corner *)
  66   method set_drag_widget (w : GObj.widget) = begin
  67     match drag_widget with
  68       None -> begin
  69         GMain.Grab.add w;
  70         drag_widget <- Some w;
  71         ()
  72       end
  73     | Some w -> ()
  74   end
  75   method unset_drag_widget () = begin
  76     match drag_widget with
  77       Some w -> begin
  78         GMain.Grab.remove w;
  79         drag_widget <- None;
  80         ()
  81       end
  82     | None -> ()
  83   end
  84   method set_drag_offset ~x ~y = drag_offset <- (x, y)
  85   method set_drag_action (w : Gdk.window) ~x ~y =
  86     begin
  87       let (x0, y0) = Window.get_position w in
  88       let (width, height) = Window.get_size w in
  89       drag_action <- get_position_in_widget w ~x ~y ~width ~height;
  90       let (x1, y1) = (x0+width, y0+height) in
  91       toimen <-
  92         match drag_action with
  93           GB_TOP_LEFT     -> (x1, y1)
  94         | GB_BOTTOM_LEFT  -> (x1, y0)
  95         | GB_TOP_RIGHT    -> (x0, y1)
  96         | GB_BOTTOM_RIGHT -> (x0, y0)
  97         | GB_TOP          -> (x0, y1)
  98         | GB_BOTTOM       -> (x0, y0)
  99         | GB_LEFT         -> (x1, y0)
 100         | GB_RIGHT        -> (x0, y0)
 101         |  _              -> (-1, -1)
 102     end
 103   method unset_drag_action () = drag_action <- GB_DRAG_NONE
 104 end
 105
 106
 107 let to_grid g x = x - (x mod g)
 108
 109 let to_grid2 g (x, y) = (to_grid g x, to_grid g y)
 110
 111 class fix_editor ~width ~height ~packing =
 112   let info = new drag_info in
 113   let fix = GPack.fixed ~width ~height ~packing () in
 114   let _ = fix#misc#realize () in
 115   let fix_window = fix#misc#window in
 116   let fix_drawing = new GDraw.drawable fix_window in
 117
 118   object (self)
 119     inherit GObj.widget fix#as_widget
 120     val mutable grid = 1
 121     method set_grid g =
 122       if (grid != g) then begin
 123         let pix =
 124           GDraw.pixmap ~window:fix ~width:g ~height:g ~mask:true () in
 125         let c = fix#misc#style#bg `NORMAL in
 126         pix#set_foreground (`COLOR c);
 127         pix#rectangle ~filled:true ~x:0 ~y:0 ~width:g ~height:g ();
 128         pix#set_foreground `BLACK;
 129         pix#point ~x:0 ~y:0;
 130         Gdk.Window.set_back_pixmap (fix#misc#window) (`PIXMAP pix#pixmap)
 131       end;
 132       grid <- g
 133
 134     method new_child ~name ~x ~y ~width ~height ~callback =
 135       let evb = GBin.event_box ~border_width:0 ~packing:fix#add () in
 136       let lbl = GMisc.label ~text:name ~width ~height ~packing:evb#add () in
 137       evb#misc#realize ();
 138       evb#misc#set_geometry ~x ~y ();
 139       self#connect_signals ~ebox:evb ~widget:lbl#coerce ~callback;
 140       ()
 141
 142     method private connect_signals
 143       ~ebox:(ebox : GBin.event_box) ~widget:(widget : widget) ~callback:cbfun =
 144       let drawing = new GDraw.drawable (ebox#misc#window) in
 145       let draw_id = ref None in
 146       let exps_id = ref None in
 147       let on_paint _ =
 148         let (width, height) = Window.get_size (ebox#misc#window) in begin
 149           drawing#set_foreground `BLACK;
 150           drawing#rectangle ~filled:true ~x:0 ~y:0
 151             ~width:corner_width ~height:corner_height ();
 152           drawing#rectangle ~filled:true ~x:(width-corner_width) ~y:0
 153             ~width:corner_width ~height:corner_height ();
 154           drawing#rectangle ~filled:true
 155             ~x:(width-corner_width)
 156             ~y:(height-corner_height)
 157             ~width:corner_width ~height:corner_height ();
 158           drawing#rectangle ~filled:true
 159             ~x:0
 160             ~y:(height-corner_height)
 161             ~width:corner_width ~height:corner_height ();
 162           drawing#rectangle ~filled:false
 163             ~x:0 ~y:0 ~width:(width-1) ~height:(height-1) ();
 164         end
 165       in
 166       ebox#event#connect#button_press ~callback:
 167         begin fun ev ->
 168           let bx = int_of_float (GdkEvent.Button.x ev) in
 169           let by = int_of_float (GdkEvent.Button.y ev) in
 170           info#set_drag_action (ebox#misc#window) ~x:bx ~y:by;
 171           info#set_drag_offset ~x:bx ~y:by;
 172           true
 173         end;
 174       ebox#event#connect#motion_notify ~callback:
 175         begin fun ev ->
 176           info#set_drag_widget ebox#coerce;
 177           let action = info#drag_action in
 178           let (mx, my) = fix#misc#pointer in
 179           let (ox, oy) = info#drag_offset in
 180           begin match action with
 181             GB_MIDDLE ->
 182               let (nx, ny) = to_grid2 grid (mx-ox, my-oy) in
 183               ebox#misc#set_geometry ~x:nx ~y:ny ();
 184               if cbfun ~x:nx ~y:ny ~width:(-2) ~height:(-2) then
 185                 ()
 186               else (* should we undo ? *) ()
 187           | GB_DRAG_NONE -> () (* do nothing *)
 188           | GB_TOP_LEFT | GB_BOTTOM_LEFT
 189           | GB_TOP_RIGHT | GB_BOTTOM_RIGHT ->
 190               let (toi_x, toi_y) =  info#toimen in
 191               let (mx, my) = to_grid2 grid (mx, my) in
 192               let (lx, rx) =
 193                 if mx<toi_x then (mx, toi_x) else (toi_x, mx) in
 194               let (ty, by) =
 195                 if my<toi_y then (my, toi_y) else (toi_y, my) in
 196               let (w, h) = (rx-lx, by-ty) in
 197               ebox#misc#set_geometry ~x:lx ~y:ty ~width:w ~height:h ();
 198               if cbfun ~x:lx ~y:ty ~width:w ~height:h then
 199                 ()
 200               else (* should we undo ? *) ()
 201           | GB_TOP | GB_BOTTOM ->
 202               let (lx, toi_y) = info#toimen in
 203               let my = to_grid grid my in
 204               let (ty, by) = if my<toi_y then (my, toi_y) else (toi_y, my) in
 205               let h = by-ty in
 206               ebox#misc#set_geometry ~y:ty ~height:h ();
 207               if cbfun ~x:lx ~y:ty ~width:(-2) ~height:h then
 208                 ()
 209               else (* should we undo ? *) ()
 210           | GB_LEFT | GB_RIGHT ->
 211               let (toi_x, ty) = info#toimen in
 212               let mx = to_grid grid mx in
 213               let (lx, rx) = if mx<toi_x then (mx, toi_x) else (toi_x, mx) in
 214               let w = rx-lx in
 215               ebox#misc#set_geometry ~x:lx ~width:w ();
 216               if cbfun ~x:lx ~y:ty ~width:w ~height:(-2) then
 217                 ()
 218               else (* should we undo ? *) ()
 219           end;
 220           true
 221         end;
 222       ebox#event#connect#button_release ~callback:
 223         begin fun ev ->
 224           info#unset_drag_action ();
 225           info#unset_drag_widget ();
 226           true
 227         end;
 228       exps_id := Some (ebox#event#connect#after#expose
 229                          ~callback:(fun _ -> on_paint(); false));
 230       draw_id := Some (ebox#misc#connect#draw ~callback:on_paint);
 231       ()
 232     initializer
 233       fix#drag#dest_set ~actions:[`COPY]
 234         [ { target = "STRING"; flags = []; info = 0} ];
 235       fix#drag#connect#data_received ~callback: begin
 236         fun context ~x ~y data ~info ~time ->
 237           let name = data#data in
 238           let _ = self#new_child ~name ~x ~y ~width:32 ~height:32
 239               ~callback:(fun ~x ~y ~width ~height -> true) in
 240 (*                Printf.printf "%s %d %d\n" (data#data) x y;
 241                   flush stdout; *)
 242           context#finish ~success:true ~del:false ~time;
 243       end;
 244       ()
 245   end
 246
 247 (* the following is for test only *)
 248 let window1 () =
 249   let window = GWindow.window () in
 250   let _ = window#connect#destroy ~callback: Main.quit in
 251   let fix = new fix_editor ~width:640 ~height:480 ~packing:window#add in
 252   fix#set_grid 5;
 253   let setter = fix#new_child ~name:"hello" ~x:100 ~y:200 ~width:32 ~height:32
 254       ~callback:begin fun ~x ~y ~width ~height ->
 255         (* Printf.printf "name=%s, x=%d, y=%d, width=%d, height=%d\n"
 256                       "hello" x y width height;
 257         flush stdout; *)
 258         true
 259       end in
 260    window#show ();
 261   ()
 262
 263
 264
 265 let main () =
 266   window1 ();
 267   dnd_source_window ();
 268   Main.main ()
 269
 270 let _ = main ()
 271
 272 (* Todo
 273
 274    change mouse cursor
 275    resize fixed itself
 276    remove_child
 277    (drag and) drop
 278
 279 *)