Source file dGraphContainer.ml

(**************************************************************************)
(*                                                                        *)
(*  This file is part of OcamlGraph.                                      *)
(*                                                                        *)
(*  Copyright (C) 2009-2010                                               *)
(*    CEA (Commissariat � l'�nergie Atomique)                             *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1, with a linking exception.                    *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the file ../LICENSE for more details.                             *)
(*                                                                        *)
(*  Authors:                                                              *)
(*    - Julien Signoles  (Julien.Signoles@cea.fr)                         *)
(*    - Jean-Denis Koeck (jdkoeck@gmail.com)                              *)
(*    - Benoit Bataille  (benoit.bataille@gmail.com)                      *)
(*                                                                        *)
(**************************************************************************)

open Graph

let ($) f x = f x

type cluster = string
type status = Global | Tree | Both

(* ABSTRACT CLASS *)

class type
  ['vertex, 'edge, 'cluster, 'tree_vertex, 'tree_edge, 'tree_cluster]
    view_container_type =
  object

    method global_view :
      ('vertex, 'edge, 'cluster) DGraphView.view option

    method tree_view:
      ('tree_vertex, 'tree_edge, 'tree_cluster) DGraphView.view option

    method tree_root: 'vertex option

    method depth_backward : int
    method depth_forward : int
    method status : status

    method set_depth_backward : int -> unit
    method set_depth_forward : int -> unit
    method set_tree_root: 'vertex -> unit
    method switch : status -> unit

    method adapt_zoom: unit -> unit

  end

module type S = sig

  type graph
  type vertex
  type edge

  module Tree: Sig.G with type V.label = vertex

  module GView: DGraphView.S with type vertex = vertex
                              and type edge = edge
                              and type cluster = cluster

  module TView: DGraphView.S with type vertex = Tree.V.t
                              and type edge = Tree.E.t
                              and type cluster = cluster

  type global_view = (vertex, edge, cluster) DGraphView.view
  type tree_view = (Tree.V.t, Tree.E.t, cluster) DGraphView.view

  class view_container :
    ?packing:(GObj.widget -> unit)
    -> ?status:status
    -> ?default_callbacks:bool
    -> mk_global_view: (unit -> global_view)
    -> mk_tree_view:
    (depth_backward:int -> depth_forward:int -> Gtk.widget Gtk.obj -> vertex
     -> tree_view)
    -> vertex option
    -> [ vertex, edge, cluster, Tree.V.t, Tree.E.t, cluster]
      view_container_type

end

(* CONTAINER *)

let with_commands ?packing mk_view model =
  let main_table = GPack.table ~columns:2 ~rows:2 ?packing () in
  let view =
    let packing w = main_table#attach ~left:0 ~right:2 ~top:1 ~expand:`BOTH w in
    mk_view ~packing model
  in
  (* Buttons box *)
  let buttons_box =
    GPack.button_box
      `HORIZONTAL
      ~border_width:3
      ~child_height:10
      ~child_width:85
      ~spacing:10
      ~layout:`START
      ~packing:(main_table#attach ~top:0 ~left:0 ~expand:`X) ()
  in
  let view_label = GMisc.label ~markup:"<b>View</b>" () in
  buttons_box#pack ~expand:false view_label#coerce;
  let add_button label mode =
    let b = GButton.button ~label ~packing:buttons_box#pack () in
    ignore (b#connect#clicked ~callback:(fun _ -> view#switch mode))
  in
  add_button "Global" Global;
  add_button "Tree" Tree;
  add_button "Both" Both;

  (* Depth of exploration controls *)
  let depth_hbox =
    GPack.hbox ~packing:(main_table#attach ~expand:`X ~top:0 ~left:1) ()
  in
  let depth_forward_adj = GData.adjustment ~lower:0. ~page_size:0. () in
  let depth_backward_adj = GData.adjustment ~lower:0. ~page_size:0. () in
  let change_depth_forward adj content () =
    content#set_depth_forward (int_of_float adj#value);
  in
  let change_depth_backward adj content () =
    content#set_depth_backward (int_of_float adj#value)
  in
  ignore $ depth_forward_adj#connect#value_changed
    ~callback:(change_depth_forward depth_forward_adj view);
  ignore $ depth_backward_adj#connect#value_changed
    ~callback:(change_depth_backward depth_backward_adj view);
  let depth_label = GMisc.label ~markup:"<b>Depth</b>" () in
  let depth_forward_label = GMisc.label ~text:" forward: " () in
  let depth_backward_label = GMisc.label ~text:" backward: " () in
  let depth_forward_spin =
    GEdit.spin_button ~value:2. ~adjustment:depth_forward_adj ()
  in
  let depth_backward_spin =
    GEdit.spin_button ~value:2. ~adjustment:depth_backward_adj ()
  in
  depth_hbox#pack ~from:`END depth_backward_spin#coerce;
  depth_hbox#pack ~from:`END depth_backward_label#coerce;
  depth_hbox#pack ~from:`END depth_forward_spin#coerce;
  depth_hbox#pack ~from:`END depth_forward_label#coerce;
  depth_hbox#pack ~from:`END depth_label#coerce;

  main_table, view

(* FROM GRAPH *)

module HString = struct
  type t = string
  let equal = (=)
  let hash = Hashtbl.hash
end

module Build
    (G: Sig.G)
    (T: DGraphTreeModel.S with type Tree.V.label = G.V.t) =
struct

  type graph = G.t
  type vertex = G.V.t
  type edge = G.E.t
  module Tree = T.Tree

  module HE(E: sig type t val compare: t -> t -> int end) = struct
    type t = E.t
    let equal x y = E.compare x y = 0
    let hash = Hashtbl.hash
  end
  module GView = DGraphView.Make(G.V)(HE(G.E))(HString)
  module TView = DGraphView.Make(Tree.V)(HE(Tree.E))(HString)

  type global_view = (G.V.t, G.E.t, string) DGraphView.view
  type tree_view = (Tree.V.t, Tree.E.t, string) DGraphView.view

  class view_container
      ?packing
      ?(status=Global)
      ?(default_callbacks=true)
      ~mk_global_view
      ~mk_tree_view
      default_tree_root
    =

    (* widgets *)
    let paned_box = GPack.paned `VERTICAL ?packing () in
    let global_frame = GBin.frame ~label:"Global View" () in
    let tree_frame = GBin.frame ~label:"Tree View" () in

    (* Callback functions *)
    let connect_tree_callback view node =
      let item = node#item in
      let callback ev =
        let apply f = match view#global_view with
          | None -> false
          | Some gview ->
            let tree = T.tree () in
            let vlist = T.TreeManipulation.get_graph_vertex item tree in
            f (gview:global_view) (gview#get_node vlist);
            false
        in
        match ev with
        | `BUTTON_PRESS _ ->
          (* clicking on a node of the tree view *)
          view#set_tree_root (T.Tree.V.label item);
          apply (fun v -> v#dehighlight)
        | `MOTION_NOTIFY _ -> apply (fun v n -> v#highlight n)
        | `LEAVE_NOTIFY _ -> apply (fun v -> v#dehighlight)
        | _ -> false
      in
      node#connect_event ~callback
    in
    let connect_global_callback view node =
      let item = node#item in
      let callback ev =
        let apply f = match view#tree_view with
          | None -> false
          | Some tview ->
            let tree = T.tree () in
            let vlist = T.TreeManipulation.get_tree_vertices item tree in
            List.iter (fun v -> f (tview:tree_view) (tview#get_node v)) vlist;
            false
        in
        match ev with
        | `BUTTON_PRESS _ -> (* clicking on a node of the global view *)
          (* Update the root of the tree view *)
          view#set_tree_root node#item;
          (* Center the global view on the selected node *)
          begin match view#global_view with 
            | None -> ()
            | Some w -> w#center_node node
          end;
          false
        | `MOTION_NOTIFY _ -> apply (fun v n -> v#highlight n)
        | `LEAVE_NOTIFY _ -> apply (fun v -> v#dehighlight)
        |_ -> false
      in
      node#connect_event ~callback
    in

    object (self)

      val mutable global_view: global_view option = None
      val mutable tree_view: tree_view option = None
      val mutable tree_change = false (* must recompute the tree? *)
      val mutable tree_root = default_tree_root
      val mutable status = status
      val mutable depth_forward = 2
      val mutable depth_backward = 2

      (* Getters *)

      method status = status
      method global_view = global_view
      method tree_view = tree_view
      method tree_root = tree_root
      method depth_forward = depth_forward
      method depth_backward = depth_backward

      (* Setters *)

      method set_depth_forward i =
        depth_forward <- i;
        tree_change <- true;
        self#update ()

      method set_depth_backward i =
        depth_backward <- i;
        tree_change <- true;
        self#update ()

      method set_tree_root v =
        tree_root <- Some v;
        tree_change <- true;

        self#update ()

      method switch s =
        status <- s;
        self#update ()

      (* Compute the views *)

      method private memo_tree_view () =
        if tree_change then begin
          (match tree_view with
           | None -> ()
           | Some view ->
             match view#misc#parent with
             | Some parent -> tree_frame#remove parent
             | None -> ()
          );
          match tree_root with
          | None -> assert false
          | Some r ->
            let view =
              mk_tree_view ~depth_backward ~depth_forward paned_box#as_widget r
            in
            tree_view <- Some view;
            if default_callbacks then begin
              view#connect_highlighting_event();
              view#iter_nodes (connect_tree_callback self);
            end;
            let scroll =
              GBin.scrolled_window
                ~hpolicy:`AUTOMATIC
                ~vpolicy:`AUTOMATIC
                ~packing:tree_frame#add
                ()
            in
            scroll#add view#coerce
        end

      method private memo_global_view () = match global_view with
        | None ->
          let view = mk_global_view () in
          global_view <- Some view;
          if default_callbacks then begin
            view#connect_highlighting_event ();
            view#iter_nodes (connect_global_callback self);
          end;
          let scroll =
            GBin.scrolled_window
              ~hpolicy:`AUTOMATIC
              ~vpolicy:`AUTOMATIC
              ~packing:global_frame#add
              ()
          in
          scroll#add view#coerce
        | Some _ ->
          ()

      method adapt_zoom () =
        let az = function
          | None -> ()
          | Some w -> w#adapt_zoom ()
        in
        az tree_view;
        az global_view

      method private add_global_view () =
        self#memo_global_view ();
        paned_box#pack1 global_frame#coerce

      method private add_tree_view () =
        self#memo_tree_view ();
        paned_box#pack2 tree_frame#coerce

      method private update () =
        List.iter paned_box#remove paned_box#all_children;
        (match status, tree_root with
         | Global, _ | _, None -> self#add_global_view ()
         | Tree, Some _ -> self#add_tree_view ()
         | Both, Some _ -> self#add_global_view (); self#add_tree_view ())

      initializer
        self#update ()

    end

end

module Make(G: Graphviz.GraphWithDotAttrs) = struct

  module FullTreeModel = DGraphTreeModel.SubTreeMake(G)
  include Build(G)(FullTreeModel)
  module GlobalModel = DGraphModel.Make(G)

  let from_graph
      ?packing
      ?status
      ?(default_callbacks=true)
      ?(mk_global_view = fun model -> GView.view ~aa:true model)
      ?(mk_tree_view = fun model -> TView.view ~aa:true model)
      ?root
      g =
    let status = match status with
      | None ->
        if G.nb_vertex g < 500 && G.nb_edges g < 2500 then Global else Tree
      | Some s -> s
    in
    new view_container
      ?packing
      ~default_callbacks
      ~status
      ~mk_global_view:(fun () -> mk_global_view (GlobalModel.from_graph g))
      ~mk_tree_view:(fun ~depth_backward ~depth_forward w v ->
          let context = GtkBase.Widget.create_pango_context w in
          let fontMeasure = PangoMeasure.withContext ~context in
          let model =
            FullTreeModel.from_graph ~depth_forward ~depth_backward ~fontMeasure g v
          in
          mk_tree_view model)
      root

  let from_graph_with_commands ?packing ?status ?(default_callbacks=true) ?mk_global_view ?mk_tree_view ?root g =
    with_commands
      ?packing
      (fun ~packing g ->
         from_graph
           ~packing ?status ~default_callbacks ?mk_global_view ?mk_tree_view
           ?root g)
      g

end

(* FROM DOT *)

module Dot = struct

  include Build(DGraphModel.DotG)(DGraphTreeModel.SubTreeDotModelMake)

  exception Found of DGraphModel.DotG.V.t

  let from_dot
      ?packing
      ?status
      ?(default_callbacks=true)
      ?(mk_global_view = fun model -> GView.view ~aa:true model)
      ?(mk_tree_view = fun model -> TView.view ~aa:true model)
      dot_file =
    let gmodel =
      if Filename.check_suffix dot_file "xdot" then
        DGraphModel.read_xdot dot_file
      else
        DGraphModel.read_dot dot_file
    in
    let one_vertex =
      try
        gmodel#iter_vertex (fun v -> raise (Found v));
        None
      with Found v ->
        Some v
    in
    let status = match status with
      | None ->
        let nb f =
          let cpt = ref 0 in
          f gmodel (fun _ -> incr cpt);
          !cpt
        in
        if nb (fun g -> g#iter_vertex) < 500
        && nb (fun g -> g#iter_edges_e) < 2500
        then Global
        else Tree
      | Some s -> s
    in
    new view_container
      ?packing
      ~status
      ~default_callbacks
      ~mk_global_view:(fun () -> mk_global_view gmodel)
      ~mk_tree_view:(fun ~depth_backward ~depth_forward _ v ->
          mk_tree_view
            (DGraphTreeModel.SubTreeDotModelMake.from_model
               ~depth_forward
               ~depth_backward
               gmodel
               v))
      one_vertex

  let from_dot_with_commands ?packing ?status ?(default_callbacks=true) ?mk_global_view ?mk_tree_view dot_file =
    with_commands
      ?packing
      (fun ~packing d ->
         from_dot
           ~packing ?status ~default_callbacks ?mk_global_view ?mk_tree_view d)
      dot_file

end