(**************************************************************************)
(*                                                                        *)
(*  Ocamlviz --- real-time profiling tools for Objective Caml             *)
(*  Copyright (C) by INRIA - CNRS - Universite Paris Sud                  *)
(*  Authors: Julien Robert                                                *)
(*           Guillaume Von Tokarski                                       *)
(*           Sylvain Conchon                                              *)
(*           Jean-Christophe Filliatre                                    *)
(*           Fabrice Le Fessant                                           *)
(*  GNU Library General Public License version 2                          *)
(*  See file LICENSE for details                                          *)
(*                                                                        *)
(**************************************************************************)

open GMain
open Protocol
open Db
open Gui_misc
open Gui_models
open Gui_views
open Gui_pref

let () = ignore (GtkMain.Main.init ())





(************************************************************
                         DECLARATIONS
*************************************************************
*************************************************************)

let graphs = Hashtbl.create 17

let main_window = ref None
(* becomes true when main window is destroyed *)
let destroyed = ref false

let app_notebook = ref None
(* number of permanent pages of the notebook *)
let nb_real_pages = ref 5

let time_label = ref None
let time_window_label = ref None
let time_obs_label = ref None
let timeout = ref None
let timeout_lab = ref None

(* "visualize in" menu *)
let visualize_menu = ref None
(* and its factory *)
let visualize_factory = ref None
let gc_item = ref None


let current_time = ref 0.
let observe_time = ref 0.
let resumed = ref false
let paused = ref false

(* GData.adjustment for the record slider *)
let record_adj = ref None
(*  pause button *)
let record_pause = ref None

let _ = Random.self_init ()

(* index to make tab labels *)
let nb_graph = ref 0
let nb_list = ref 0
let nb_tree = ref 0

external create_color : red:int -> green:int -> blue:int -> Gdk.color
      = "ml_GdkColor"


(* Updates the values of current time and max record time on the GUI *)
let fill_labels () =
  let current_t = Db.get_current_time () in
  current_time := current_t;
  if !paused then
    begin
      Db.set_offset (current_t -. !observe_time);
      match !record_scale with
	|None -> ()
	|Some scl -> scl#adjustment#set_value (-.(Db.get_offset ()))
    end;
  begin
    match !time_label with
      |None -> ()
      |Some (t_l: GMisc.label) -> 
	 t_l#set_text (time_of_float current_t)
  end;
  begin
    match !time_window_label with
      |None -> ()
      |Some (t_l: GMisc.label) -> 
	 let f' = current_t -. !record_window in
	 if f' >= 0.  then
	   t_l#set_text (time_of_float (current_t -. !record_window))
	 else t_l#set_text ""
  end;
  begin
    match !time_obs_label with
      |None -> ()
      |Some (t_l: GMisc.label) -> 
	 let t = Db.get_observe_time () in
	 t_l#set_text (time_of_float t)
  end;
  true
 	    

(* Refresh the GUI with new values *)

let refresh_models () =
  begin
    try
      fill_stat (Db.get_point_list ()) (Db.get_time_list ());
      
      fill_tag (Db.get_tag_count_list ()) (Db.get_tag_size_list ());
      
      fill_value (Db.get_value_int_list ()) value_i_model row_int v_i_name_col 
	v_i_tag_col v_i_value_col v_i_value_lm_col v_i_value_lm_s_col v_i_color_col;

      fill_value (Db.get_value_float_list ()) value_f_model row_float v_f_name_col 
	v_f_tag_col v_f_value_col v_f_value_lm_col v_f_value_lm_s_col v_f_color_col;

      fill_value (Db.get_value_string_list ()) value_s_model row_string v_s_name_col 
	v_s_tag_col v_s_value_col v_s_value_lm_col v_s_value_lm_s_col v_s_color_col;

      fill_value (Db.get_value_bool_list ()) value_b_model row_bool v_b_name_col 
	v_b_tag_col v_b_value_col v_b_value_lm_col v_b_value_lm_s_col v_b_color_col;

      fill_tree (Db.get_tree_list ());

      fill_hash (Db.get_hash_list ());

      fill_gc ();

      fill_log (Db.get_log ());

      fill_lists ();

    with e -> 
      Format.printf "%s@." (Printexc.to_string e)
	
  end;
  true


(***************************************************************************)


(* Detaches a page from the notebook and makes a new window from it *)
let detach_from_nb (nb:GPack.notebook) (hb:GPack.box) (hb2:GPack.box) name = 
  let w = GWindow.window ~title:name ~width:450 ~height:300 ~position:`MOUSE
    ~icon:(GdkPixbuf.from_file "/usr/share/pixmaps/ocaml.xpm") () in
  let a_g = GtkData.AccelGroup.create () in
  w#add_accel_group a_g;
  let parent = hb#misc#parent in
  ignore(w#event#connect#after#key_press
	   (fun key -> if (GdkEvent.Key.keyval key) = 119 
	    then begin w#destroy () end; true));
  ignore (w#connect#destroy 
	    ~callback:
	    (fun () -> 
	       match parent with
		 | Some p ->
		     hb#misc#reparent p;     
		     nb#set_page ~tab_label:hb2#coerce hb#coerce;
		     let i = nb#page_num hb#coerce in
		     nb#goto_page i;
		 | None -> ()));
  hb#misc#reparent w#coerce;
  w#show ()
  
    
(* Removes a page from the notebook *)
let remove_from_nb (nb:GPack.notebook) (hb:GPack.box) (pg:int) =
  let pg = nb#page_num hb#coerce in
  nb#remove_page pg
    

(* Done when a page was removed from the notebook *)
let removed_from_nb item table name =
  Hashtbl.remove table name; 
  match !visualize_menu with
    |Some (m : GMenu.menu) -> 
       if not !destroyed then m#remove item;
    |None -> () 
 

(* Makes the tab and the label of a page *)
let mk_label_nb_close_and_detach (nb:GPack.notebook) (hb:GPack.box) name =
  let hb2 = GPack.hbox () in
  let _ = GMisc.label ~height:30 ~markup:name ~packing:hb2#add () in
  let bdetach = GButton.button ~packing:hb2#add () in
  let im_detach = GMisc.image ~stock:`FULLSCREEN ~icon_size:`MENU () in
  bdetach#set_image im_detach#coerce;
  bdetach#set_relief `NONE;
  bdetach#set_focus_on_click false;
  let bclose = GButton.button ~packing:hb2#add () in
  let im_close = GMisc.image ~stock:`CLOSE ~icon_size:`MENU () in
  bclose#set_image im_close#coerce;
  bclose#set_relief `NONE;
  bclose#set_focus_on_click false;
  let page = nb#append_page ~tab_label:hb2#coerce hb#coerce in
  page,hb2,bdetach,bclose


let mk_label_nb_detach (nb:GPack.notebook) (hb:GPack.box) name =
  let hb2 = GPack.hbox () in
  let _ = GMisc.label ~height:30 ~markup:name ~packing:hb2#add () in
  let bdetach = GButton.button ~packing:hb2#add () in
  let im_detach = GMisc.image ~stock:`FULLSCREEN ~icon_size:`MENU () in
  bdetach#set_image im_detach#coerce;
  bdetach#set_relief `NONE;
  bdetach#set_focus_on_click false;
  let page = nb#append_page ~tab_label:hb2#coerce hb#coerce in
  hb2,page,bdetach


(*************** SCALE FOR TIMEOUTS **************)

let changed_spin adj () =
  match !timeout, !timeout_lab with
    |None,None -> ()
    |Some t,Some t2 -> 
       GMain.Timeout.remove t;
	GMain.Timeout.remove t2;
	let period = int_of_float (adj#value) in
	default_pref.period <- period;
	timeout := Some (GMain.Timeout.add ~ms:period ~callback:refresh_models);
	timeout_lab := Some (GMain.Timeout.add ~ms:period ~callback:fill_labels)
    |None, Some t -> 
       GMain.Timeout.remove t;
	let period = int_of_float (adj#value) in
	default_pref.period <- period;
	timeout_lab := Some (GMain.Timeout.add ~ms:period ~callback:fill_labels)
    |_ -> assert false


let changed_graph_spin gr adj () = 
  match !timeout with
    |None -> ()
    |Some t -> 
	let period = int_of_float (adj#value) in
	Graph.set_timer gr period


let changed_pause adj scl pause () = 
  match !timeout with
    |None ->
       paused := false;
	let im = GMisc.image ~stock:`MEDIA_PAUSE ~icon_size:`MENU () in
	pause#set_image im#coerce;
	let period = int_of_float (adj#value) in
	default_pref.period <- period;
	timeout := Some (GMain.Timeout.add ~ms:period ~callback:refresh_models);
        if !resumed 
        then Hashtbl.iter (fun _ (gr,_,_) -> Graph.resume gr) graphs
        else Hashtbl.iter (fun _ (gr,_,_) -> Graph.restart gr default_pref.period) graphs;
        resumed := false 
    |Some t ->
       paused := true;
        resumed := true;
	observe_time := Db.get_observe_time ();
	let im = GMisc.image ~stock:`MEDIA_PLAY ~icon_size:`MENU () in
	pause#set_image im#coerce;
	GMain.Timeout.remove t;
	Hashtbl.iter (fun _ (gr,_,_) -> Graph.stop gr) graphs;
	timeout := None



let mk_spin_aux_graph (table: GPack.table) lab =
  let lbl = GMisc.label
    ~markup:(Format.sprintf ("<span weight=\"bold\">%s Period</span>") lab)
    ~justify:`CENTER ~packing:(table#attach ~top:0 ~left:0 ~expand:`NONE) () in
  lbl#set_width_chars 15;
  
  let adjust = GData.adjustment ~lower:100. ~upper:5000. ~step_incr:1. ~page_incr:10. () in
  adjust#set_value (float_of_int default_pref.period);
  let spin =  GEdit.spin_button ~update_policy:`IF_VALID
    ~digits:0 ~packing:(table#attach ~top:0 ~left:1 ~expand:`NONE) ~adjustment:adjust () in
  let _ = GMisc.label
    ~markup:"<span weight=\"bold\">ms</span>"
    ~justify:`CENTER ~packing:(table#attach ~top:0 ~left:2) () in
  table#set_col_spacing 2 20;
  (spin,adjust)


let mk_spin_aux_record (box: GPack.box) lab =
  let frame = GBin.frame ~packing:(box#pack ~expand:false) () in
  let table = GPack.table ~columns:1 ~rows:2 ~packing:frame#add () in
 
  let lbl = GMisc.label
    ~markup:lab
    ~justify:`CENTER ~height:37 ~packing:(table#attach ~left:0 ~top:0 ~expand:`NONE) () in
  lbl#set_width_chars 15;
  
  let adjust = GData.adjustment ~lower:100. ~upper:5000. ~step_incr:1. ~page_incr:10. () in
  adjust#set_value (float_of_int default_pref.period);
  let hbox = GPack.hbox ~packing:(table#attach ~left:0 ~top:1 ~expand:`NONE) () in
  hbox#set_spacing 5;
  let spin =  GEdit.spin_button ~update_policy:`IF_VALID
    ~digits:0 ~packing:(hbox#pack ~expand:true) ~adjustment:adjust () in
  let _ = GMisc.label
    ~markup:"<span weight=\"bold\">ms </span>"
    ~justify:`CENTER ~packing:(hbox#pack ~expand:false) () in
  (spin,adjust)


let mk_record_box (box: GPack.table) lab lab2 f1 f2 =

  let hbox = GPack.hbox ~height:70 ~packing:(box#attach ~top:1 ~left:0 ~expand:`X) () in

  let spin,adjust = mk_spin_aux_record hbox lab in
  ignore (spin#connect#value_changed ~callback:(f1 adjust) );

  let frame = GBin.frame ~packing:hbox#add () in
  let table = GPack.table ~columns:3 ~rows:2 ~packing:frame#add () in
  table#set_col_spacings 10;
   
  let lbl = GMisc.label ~markup:lab2
    ~justify:`CENTER ~packing:(table#attach ~top:0 ~left:0 ~expand:`NONE) () in
  lbl#set_width_chars 15;

  let im = GMisc.image ~stock:`MEDIA_PAUSE ~icon_size:`MENU () in
  let pause = GButton.button ~packing:(table#attach ~top:0 ~left:1 ~expand:`NONE) () in
  pause#set_image im#coerce;

  let scl = GRange.scale `HORIZONTAL ~digits:2 ~update_policy:`CONTINUOUS 
    ~packing:(table#attach ~top:0 ~left:2 ~expand:`X) () in
  scl#adjustment#set_bounds ~lower:(-. !record_window) ~upper:0.0 ~step_incr:0.01 ~page_incr:0.05 ();
  ignore(scl#connect#value_changed ~callback:(fun () ->
                                                let off = -. scl#adjustment#value in 
                                                Db.set_offset off;
                                                scl#adjustment#set_value (-.Db.get_offset ());
                                                ignore(refresh_models ());
                                             ));
  ignore(scl#connect#adjust_bounds ~callback:(fun _ ->
                                                if not !paused then 
                                                  begin
                                                    let off = -. scl#adjustment#value in 
                                                    Db.set_offset off;
                                                    scl#adjustment#set_value (-.Db.get_offset ());
                                                    ignore(refresh_models ());
					            Hashtbl.iter (fun _ (g,_,_) -> Graph.clear g) graphs
                                                  end
                                                else 
                                                  begin
                                                    resumed := false;
                                                    let off = -. scl#adjustment#value in
                                                    Db.set_offset off;
                                                    scl#adjustment#set_value (-.Db.get_offset ());
                                                    observe_time := Db.get_observe_time ();
                                                    ignore(refresh_models ());
                                                  end
                                             ));
  record_scale := Some scl;
  record_pause := Some pause;
  record_adj := Some adjust;
  ignore (pause#connect#clicked ~callback:(f2 adjust scl pause) );
  let labl_hbox = GPack.hbox ~packing:(table#attach ~top:1 ~left:2 ~expand:`NONE) () in
  let lab1 = GMisc.label ~packing:(labl_hbox#pack ~from:`START ~expand:false) () in
  let lab2 = GMisc.label ~packing:(labl_hbox#pack ~from:`END ~expand:false) () in
  let lab3 = GMisc.label ~packing:(table#attach ~top:1 ~left:0 ~expand:`NONE) () in
  time_label := Some lab2;
  time_window_label := Some lab1;
  time_obs_label := Some lab3


let mk_spin_graph (box: GPack.box) lab f graph =
  let table = GPack.table ~columns:4 ~rows:1 ~packing:(box#pack ~expand:false) () in
  table#set_col_spacings 10;
  
  let spin,adjust = mk_spin_aux_graph table lab in
  let window = 
    match !main_window with
      | None -> assert false
      | Some (w: GWindow.window) -> w 
  in
  let im = GMisc.image ~stock:`PREFERENCES ~icon_size:`MENU () in
  let butt = GButton.button ~packing:(table#attach ~top:0 ~left:3) () in
  butt#set_image im#coerce; 

  ignore (spin#connect#value_changed ~callback:(f graph adjust) );
  ignore (butt#connect#clicked ~callback:(fun () -> mk_preferences_graph window graph lab))
			
 

(***************************************************************************)


(* Adds a tree in a page on the notebook *)
let add_tree (nb:GPack.notebook) =
  let id = ref 0 in
  tree_model#foreach
    (fun _ row -> 
	 if tree_model#get ~row ~column:tree_radio_col then
	   id := tree_model#get ~row ~column:tree_tag_col ;
       false
    );
  let tree = Db.get_tag !id in
  match tree.value with
    |_,Protocol.Tree t -> 
       begin 
         let hb = GPack.hbox () in
         let page,hb2,bdetach,bclose = mk_label_nb_close_and_detach nb hb tree.name in
         let t_p = Tree_panel.create ~packing:hb#add tree.name t in
         incr nb_tree;
         let idx = !nb_tree in
         Hashtbl.add trees idx (tree,t_p);
         ignore(bdetach#connect#clicked
	          ~callback:(fun () -> detach_from_nb nb hb hb2 tree.name));
         ignore(bclose#connect#clicked
	          ~callback:(fun () -> remove_from_nb nb hb page; Hashtbl.remove trees idx));
         nb#goto_page page
       end  
    |_,No_value -> ()
    |_ -> assert false
  


(*******************************************************************************************)

let remove_function (container:GPack.table) hb gr f () = 
  Graph.remove gr f;
  container#remove (hb#coerce);
  let children = container#all_children in
  List.iter (fun c -> container#remove (c#coerce)) children;
  let rec fct i j = function
    |c::cl -> 
       if (i < 3) then
	 begin
	   container#attach ~left:i ~top:j c#coerce;
	   fct (i+1) j cl
	 end
       else 
	 begin
	   container#attach ~left:0 ~top:(j+1) c#coerce;
	   fct 1 (j+1) cl
	 end
    |[] -> ()
  in
  fct 0 0 (List.rev children)
  

let mk_color_button (container:GPack.table) graph f s column row =
  let hb = GPack.hbox ~packing:(container#attach ~left:column ~top:row) () in
  let (r,g,b) = Graph.get_color f in
  let r = int_of_float (r*.256.*.255.) in
  let g = int_of_float (g*.255.*.256.) in
  let b = int_of_float (b*.255.*.256.) in
  let col = create_color ~red:r ~green:g ~blue:b in
  let b = GButton.color_button ~color:col ~packing:hb#add () in
  b#set_relief `NONE;
  ignore(b#connect#color_set ~callback:(
    fun () -> 
      let color = b#color in
      let r = float_of_int (Gdk.Color.red color) /.256. /. 255. in
      let g = float_of_int (Gdk.Color.green color) /.256. /. 255. in
      let b = float_of_int (Gdk.Color.blue color) /.256. /. 255. in
      Graph.set_color f (r,g,b)));
  let _ = GMisc.label ~text:s ~packing:hb#add () in
  let vis = GButton.check_button ~active:true ~packing:hb#add () in
  ignore(vis#connect#toggled ~callback:(fun () -> Graph.set_visible f (vis#active)));
  let bclose = GButton.button ~packing:hb#add () in
  let im = GMisc.image ~stock:`CLOSE ~icon_size:`MENU () in
  bclose#set_image im#coerce;
  bclose#set_relief `NONE;
  bclose#set_focus_on_click false;
  bclose#connect#clicked 
	   ~callback:(remove_function container hb graph f)


let kind_of_column = function
  | Tag_count | Stat_count | Tag_max_count | Value_i -> Graph.Int
  | Tag_size | Tag_max_size | Gc_total | Gc_max | Gc_alive -> Graph.Byte
  | Value_f | Hash_mean | Stat_time -> Graph.Float
  | Tag_percent_size | Hash_percent | Stat_percent_time -> Graph.Percentage
  | Hash_elts | Hash_size | Hash_bckts | Hash_empty_bckts -> Graph.Int
  | _ -> assert false

let style_of_status = function 
  | St_active -> Graph.Full
  | St_killed | St_collected -> Graph.Dashed

let graph_function tag col = 
  let _,st = (Db.get_tag tag).status in
  let style = style_of_status st in
  match col with
      
    | Tag_count -> 
	begin
	  match Db.get_tag_count tag with
	  | _,Int i -> float i, style
	  | _,Int64 i -> Int64.to_float i, style
	  | _ -> assert false
	end
	  
    | Tag_size -> 
	begin
	  match Db.get_tag_size tag with
	    | _,Int64 i -> Int64.to_float i, style
	    | _ -> assert false
	end
      
    | Stat_count ->
	begin
	  match Db.get_point tag with
	    | _,Int i -> float i, style
	    | _,Int64 i -> Int64.to_float i, style
	    | _ -> assert false
	end
  
    | Stat_time ->
        begin
          match Db.get_time tag with
            |_,Float f -> f,style
            |_ -> assert false
        end

    | Stat_percent_time ->
        begin
          match Db.get_percent_time tag with
            |_,Float f -> f,style
            |_ -> assert false
        end

    | Tag_max_size ->
	begin
	  match Db.get_tag_max_size tag with
	    | _,Int64 i -> Int64.to_float i, style
	    | _ -> assert false
	end
	  
    | Tag_max_count ->
      begin
	match Db.get_tag_max_count tag with
	  | _,Int i -> float i , style
	  | _,Int64 i -> Int64.to_float i, style
	  | _ -> assert false
      end
	
    | Tag_percent_size -> 
	begin
	  match Db.get_tag_percent_size tag with
	    | _,Float f -> f , style
	    | _ -> assert false
	end
	  
    | Value_i -> 
	begin 
	match Db.get_value_int tag with
	  | _,Int i -> float i , style
	  | _,Int64 i -> Int64.to_float i , style
	  | _,Collected -> 0. , Graph.Dashed
	  | _ -> assert false
	end
	  
    | Value_f -> 
	begin
	  match Db.get_value_float tag with
	    | _,Float f -> f , style
	    | _,Collected -> 0. , Graph.Dashed
	    | _ -> assert false
	end
	  
    | Gc_total -> let _,size = Db.get_heap_total_size () in 
      begin
	match size with
	  | Int64 i -> Int64.to_float i, Graph.Full
	  | No_value -> 0. , Graph.Full
	  | _ -> assert false
      end
	
    | Gc_max -> 
	begin
	  match Db.get_heap_max_size () with
	    | _,Int64 i -> Int64.to_float i, Graph.Full
	    | _,No_value -> 0. , Graph.Full
	    | _ -> assert false
	end
	  
    | Gc_alive -> let _,alive = Db.get_heap_alive_size () in 
      begin
	match alive with
	  | Int64 i -> Int64.to_float i , Graph.Full
	  | No_value -> 0. , Graph.Full
	  | _ -> assert false
      end

    | Hash_size ->
	begin
	  match Db.get_hash tag with
	    | _,Hashtable (Int v1,_,_,_) -> float v1, Graph.Full
	    | _,Hashtable (Int64 v1,_,_,_) -> Int64.to_float v1, Graph.Full
	    | _ -> assert false
	end

    | Hash_elts -> 
	begin
	  match Db.get_hash tag with
	    | _,Hashtable (_,Int v2,_,_) -> float v2, Graph.Full
	    | _,Hashtable (_,Int64 v2,_,_) -> Int64.to_float v2, Graph.Full
	    | _ -> assert false
	end
    
    | Hash_empty_bckts ->
	begin
	  match Db.get_hash tag with
	    | _,Hashtable (_,_,Int v3,_) -> float v3, Graph.Full
	    | _,Hashtable (_,_,Int64 v3,_) -> Int64.to_float v3, Graph.Full
	    | _ -> assert false
	end
   
    | Hash_bckts ->
	begin
	  match Db.get_hash tag with
	    | _,Hashtable (_,_,_,Int v4) -> float v4, Graph.Full
	    | _,Hashtable (_,_,_,Int64 v4) -> Int64.to_float v4, Graph.Full
	    | _ -> assert false
	end

    | Hash_mean -> 
	begin
	  match Db.get_hash_mean tag with
	    | _,Float f -> f, Graph.Full
	    | _ -> assert false
	end

    | Hash_percent -> 
      	begin
	  match Db.get_hash_percent_filled tag with
	    | _,Float f -> f, Graph.Full
	    | _ -> assert false
	end

    | _ -> assert false
	
	
let rec add_function gr container i j = function
    |(typ,id,name)::list -> 
       if ( kind_of_column typ = Graph.get_kind gr 
	   || Graph.get_kind gr = Graph.Undefined)
       then
	 begin
	   let r = Random.float 0.7 in
	   let g = Random.float 0.7 in
	   let b = Random.float 0.7 in
	   let f = Graph.add gr id ~name 
	     (fun () -> 
		graph_function id typ
	     ) (kind_of_column typ) (r,g,b)
	   in 
	   if i <= 3 then begin
	     ignore(mk_color_button container gr f name i j ); 
	     add_function gr container (i+1) j list end
	   else begin
	     container#set_rows (j+1);
	     ignore(mk_color_button container gr f name 0 (j+1) );
	   add_function gr container 1 (j+1) list end
	 end
    |[] -> ()


let int_of_column = function
  | Name -> 0
  | Tag_count -> 1
  | Tag_size -> 2
  | Tag_max_count -> 3
  | Tag_max_size -> 4
  | Tag_percent_size -> 5
  | Stat_count -> 6
  | Stat_time -> 7
  | Stat_percent_time -> 8
  | Value_i -> 9
  | Value_f -> 10
  | Value_b -> 11
  | Value_s -> 12
  | Gc_total -> 13
  | Gc_max -> 14
  | Gc_alive -> 15
  | Hash_elts -> 16
  | Hash_size -> 17
  | Hash_bckts -> 18
  | Hash_empty_bckts -> 19
  | Hash_mean -> 20
  | Hash_percent -> 21
  | Null -> 22


let add_list (model: GTree.list_store) (tag_col: int GTree.column) (name_col: string GTree.column) 
    value_col color_col (type_col: int GTree.column) (l: (column * int * string ) list ) =
  let rec add = function
    |(c,id,name)::list -> 
       let row = model#append () in
       model#set ~row ~column:name_col name;
       model#set ~row ~column:tag_col id;
       let c' = int_of_column c in
       model#set ~row ~column:type_col c';
       add list
    |[] -> ()
  in
  add l

(* Adds the functions from the list l to the selected graph *)
let add_to_graph selected l = 
  let gr,container,_ = Hashtbl.find graphs selected in
  let nb_f = Graph.get_nb_fct gr in
  let i = nb_f mod 4 in
  let j = nb_f/ 4 in
  add_function gr container i j (List.rev l)
  
let add_to_list selected l = 
  let model,tag_col,name_col,value_col,_,_,color_col,type_col = Hashtbl.find lists_table selected in
  add_list model tag_col name_col value_col color_col type_col (List.rev l)

let col_tag_of_typ = function
  | Tag_count | Tag_max_count -> t_tag_count_col
  | Tag_size | Tag_max_size | Tag_percent_size -> Format.eprintf "ici@.";t_tag_size_col
  | Stat_count -> s_tag_count_col
  | Stat_time | Stat_percent_time -> s_tag_time_col
  | Value_i -> v_i_tag_col
  | Value_f -> v_f_tag_col
  | Value_b -> v_b_tag_col
  | Value_s -> v_s_tag_col
  | Hash_elts | Hash_size | Hash_bckts | Hash_empty_bckts | Hash_mean | Hash_percent-> h_tag_col
  |_ -> Format.eprintf "col_tag_of_typ@.";assert false

(* Iters on a column and returns the names of the checked cells *)


let check_toggle_aux (model : GTree.list_store) (column : bool GTree.column) name_column typ (l : (Protocol.tag * string ) list ref) =
  begin
    model#foreach
      (fun _ row ->
	 let bool = model#get ~row ~column in
	 if bool then begin
	   let v = model#get ~row ~column:(col_tag_of_typ typ) in
	   if (v<>0) then begin
             l:= (v,model#get ~row ~column:name_column )::!l;
	   end;
	   model#set ~row ~column false;
	 end; false);
    match !l with
      |_::_ -> typ,!l
      |[] -> Null,!l
  end

let check_toggle (column : bool GTree.column) typ page = 
  let l = ref [] in
  match page with 
    |Stat -> check_toggle_aux stat_model column s_name_col typ l
 
    |Tag -> check_toggle_aux tag_model column t_name_col typ l
   
    |Hash -> check_toggle_aux hash_model column h_name_col typ l

    |Value_int -> check_toggle_aux value_i_model column v_i_name_col typ l
      
    |Value_float -> check_toggle_aux value_f_model column v_f_name_col typ l

    |Value_string -> check_toggle_aux value_s_model column v_s_name_col typ l

    |Value_bool -> check_toggle_aux value_b_model column v_b_name_col typ l

    |Gc -> 
       begin
	 gc_model#foreach 
	   (fun _ row ->
	      let bool = gc_model#get ~row ~column in
	      if bool then begin 
		let _ = match typ with
		  |Gc_total -> l:= (0,"Total Size")::!l
		  |Gc_max ->  l:= (0,"Max Size")::!l
		  |Gc_alive ->  l:= (1,"Living Bytes")::!l
		  |_-> assert false
		in
		gc_model#set ~row ~column false;
	      end; false);
	 match !l with
	   |_::_ -> typ,!l
	   |[] -> Null,!l
       end
    | _ -> assert false



let clear_toggle column = function
  | Stat_time | Stat_percent_time -> 
      stat_model#foreach
	(fun _ row -> 
	   stat_model#set ~row ~column false; false)
  | Value_s -> 
      value_s_model#foreach
	(fun _ row -> 
	   value_s_model#set ~row ~column false; false)
  | Value_b ->
      value_b_model#foreach
	(fun _ row -> 
	   value_b_model#set ~row ~column false; false)
  | _ -> assert false (* for now *)


let treat_toggles nb (l : (column * (int*string) list) list) =
  let rec treatment_aux acc = function
    |[] -> acc
    |(col,list)::res -> treatment_aux  ((List.map (fun (i,n) -> (col,i,n)) list)::acc) res
  in
  List.flatten (treatment_aux [] l) 


(* *)

let rec collect_toggles_aux acc = function
  | check::c, typ::t, page::p -> collect_toggles_aux ((check_toggle check typ page)::acc) (c, t, p)
  | [],[],[] -> acc
  | _ -> assert false
  

let collect_toggles nb col_typ =
  let c = [s_check_count_col;t_check_count_col;t_check_max_count_col;t_check_size_col;t_check_max_size_col;t_check_percent_col;
	   v_i_check_value_col;v_f_check_value_col;gc_check_total;gc_check_max;gc_check_alive;h_length_check_col;h_real_length_check_col;
	   h_length_b_check_col;h_empty_b_check_col;h_mean_check_col;h_percent_check_col;s_check_time_col;s_check_percent_col] in
  
  let t = [Stat_count;Tag_count;Tag_max_count;Tag_size;Tag_max_size;Tag_percent_size;Value_i;Value_f;Gc_total;
	   Gc_max;Gc_alive;Hash_elts;Hash_size;Hash_bckts;Hash_empty_bckts;Hash_mean;Hash_percent;Stat_time;Stat_percent_time] in
  
  let o = [Stat;Tag;Tag;Tag;Tag;Tag;Value_int;Value_float;Gc;Gc;Gc;Hash;Hash;Hash;Hash;Hash;Hash;Stat;Stat] in
  
  if col_typ = 1 then (* collects toggle for lists *)
    let c = v_s_check_value_col::v_b_check_value_col::c in
    let t = Value_s::Value_b::t in
    let o = Value_string::Value_bool::o in
    let list = collect_toggles_aux [] (c, t, o) in
    treat_toggles nb list
  else (* collects toggle for graphs *)
    let list = collect_toggles_aux [] (c, t, o) in
    clear_toggle v_s_check_value_col Value_s;
    clear_toggle v_b_check_value_col Value_b;
    treat_toggles nb list



(* Makes a new graph from the list l *)
let rec new_graph noteb (l: (column * int * string) list) = 
  try 
    let t,_,_ = List.find (fun (typ,_,_) -> typ <> Null) l in
    incr nb_graph; 
    let name = Format.sprintf "Graph%s" (string_of_int !nb_graph) in
    let item = 
      match !visualize_factory with
	|Some (f : GMenu.menu GMenu.factory) -> 
	   f#add_item name ~callback:(fun () -> add_to_graph name (collect_toggles noteb 0))
        | _ -> assert false
    in
    mk_notebook name (Exported_graph(t,item)) noteb;
    let gr,container,_ = Hashtbl.find graphs name in
    add_function gr container 0 0 (List.rev l) 
  with Not_found -> ()


and new_list noteb (l: (column * int * string ) list ) =
  try
    let _ = List.find (fun (typ,_,_) -> typ <> Null) l in
    incr nb_list;
    let name = Format.sprintf "List%s" (string_of_int !nb_list) in
    let item =
      match !visualize_factory with
	|Some (f : GMenu.menu GMenu.factory) -> 
	   f#add_item name ~callback:(fun () -> add_to_list name (collect_toggles noteb 1))
        | _ -> assert false
    in
    mk_notebook name (Exported_list(item)) noteb;
    let model,tag_col,name_col,value_col,value_lm_col,value_lm_s_col,color_col,type_col = Hashtbl.find lists_table name in
    add_list model tag_col name_col value_col color_col type_col (List.rev l)
  with Not_found -> ()


(* Creates a new notebook page *)
and mk_notebook name typ (nb:GPack.notebook) =
  let hb = GPack.hbox () in
  match typ with
    
    |Stat ->  
       let hb2,_,bdetach = mk_label_nb_detach nb hb name in 
       let m,m' = mk_model stat_model Stat in
       mk_view m m' hb Stat;
       ignore(bdetach#connect#clicked 
	        ~callback:(fun () -> detach_from_nb nb hb hb2 name));
    
    |Gc -> 
       let hb2,_,bdetach = mk_label_nb_detach nb hb name in 
       let vb = GPack.vbox ~packing:hb#add () in
       vb#set_spacing 10;
       let m,m' = mk_model gc_model Gc in
       mk_view m m' vb Gc;
       ignore(init_gc ());
       let gr = Graph.create  ~width:450 ~height:200 ~timeout:default_pref.period
	 ~steps:default_pref.steps ~grid_divx:default_pref.gridx  ~grid_divy:default_pref.gridy
	 ~xaxis:default_pref.xaxis ~yaxis:default_pref.yaxis ~packing:vb#add ~kind:Graph.Byte () in
       let f1 = Graph.add gr 0 ~name:"size" 
	 (fun () -> graph_function 0 Gc_total) Graph.Byte (1.0,0.0,0.0) in
       let f3 = Graph.add gr 1 ~name:"alive"
	 (fun () -> graph_function 1 Gc_alive) Graph.Byte (0.0,0.0,1.0) in
       let f2 = Graph.add gr 0 ~name:"max"
	 (fun () -> begin
	    match Db.get_heap_max_size () with
	      | _,Int64 i -> Int64.to_float i, Graph.Full
	      | _,No_value -> 0. , Graph.Full
	      | _ -> assert false
	  end) Graph.Byte (0.0,1.0,0.0) in
       mk_spin_graph vb "Gc" 
	 changed_graph_spin  gr;
       let color_frame = GBin.frame ~height:50 ~packing:vb#add () in
       let color_container = GPack.table ~columns:4 ~rows:1 ~packing:color_frame#add () in
       let item = match !gc_item with Some i -> i | None -> assert false in
       Hashtbl.add graphs "GC" (gr,color_container,item);
       ignore (mk_color_button color_container gr f1 "Total Size" 0 0 );
       ignore (mk_color_button color_container gr f2 "Max Size" 1 0 );
       ignore (mk_color_button color_container gr f3 "Living Bytes" 2 0);
       ignore(bdetach#connect#clicked 
	        ~callback:(fun () -> detach_from_nb nb hb hb2 name));
       
    |Tag -> 
       let hb2,_,bdetach = mk_label_nb_detach nb hb name in 
       let m,m' = mk_model tag_model Tag in
       mk_view m m' hb Tag;
       ignore(bdetach#connect#clicked 
	        ~callback:(fun () -> detach_from_nb nb hb hb2 name));
    
    |Value -> 
       let hb2,_,bdetach = mk_label_nb_detach nb hb name in 
       let vb = GPack.vbox ~packing:hb#add () in
       mk_view_value vb Value_int value_i_model "Integers" ;
       mk_view_value vb Value_float value_f_model "Floats" ;
       mk_view_value vb Value_bool value_b_model "Booleans" ;
       mk_view_value vb Value_string value_s_model "Strings";
       ignore(bdetach#connect#clicked 
	        ~callback:(fun () -> detach_from_nb nb hb hb2 name));
    
    |Exported_graph (typ,item)-> 
       let page,hb2,bdetach,bclose = mk_label_nb_close_and_detach nb hb name in
       let vb = GPack.vbox ~packing:hb#add () in
       let kind = kind_of_column typ in
       let gr = Graph.create ~height:200 ~timeout:default_pref.period 
	 ~steps:default_pref.steps ~grid_divx:default_pref.gridx ~grid_divy:default_pref.gridy
	 ~xaxis:default_pref.xaxis ~yaxis:default_pref.yaxis ~packing:vb#add ~kind () in
       ignore(bdetach#connect#clicked 
		~callback:(fun () -> detach_from_nb nb hb hb2 name));
       
       ignore(bclose#connect#clicked 
		~callback:(fun () -> 
			     remove_from_nb nb hb page;
			     Graph.stop gr;
			     removed_from_nb item graphs name
			  ));
       

       mk_spin_graph vb name
	 changed_graph_spin gr;
       let color_frame = GBin.frame ~height:50 ~packing:vb#add () in
       let color_container  = GPack.table ~columns:4 ~rows:1 ~packing:color_frame#add () in
       Hashtbl.add graphs name (gr,color_container,item);
       nb#goto_page page

    |Exported_list (item) ->
       let page,hb2,bdetach,bclose = mk_label_nb_close_and_detach nb hb name in
       let m,n_col,v_col,v_lm_col,c_col = mk_model_list name in 
       mk_view_list m n_col v_col v_lm_col c_col hb;
       ignore(bdetach#connect#clicked 
	 ~callback:(fun () -> detach_from_nb nb hb hb2 name));
       ignore(bclose#connect#clicked 
		~callback:(fun () -> 
			     remove_from_nb nb hb page;
			     removed_from_nb item lists_table name
			  ));
       nb#goto_page page

    |Tree ->
       let hb2,_,bdetach = mk_label_nb_detach nb hb name in 
       let vb = GPack.vbox ~packing:hb#add () in
       vb#set_spacing 10;
       let table = GPack.table ~rows:1 ~columns:1 ~packing:(vb#pack ~expand:false) () in
       let butt = GButton.button ~label:" Visualize" ~packing:(table#attach ~left:0 ~top:0) () in
       let im = GMisc.image ~stock:`OK ~icon_size:`MENU () in
       butt#set_image im#coerce;
       ignore(butt#connect#clicked (fun () -> add_tree nb));
       let hb3 = GPack.hbox ~packing:vb#add () in
       let m,m' = mk_model tree_model Tree in
       mk_view_tree m m' hb3;
       ignore(bdetach#connect#clicked 
	        ~callback:(fun () -> detach_from_nb nb hb hb2 name));

    |Hash -> 
       let hb2,_,bdetach = mk_label_nb_detach nb hb name in 
       let m,m' = mk_model hash_model Hash in
       mk_view m m' hb Hash;
       ignore(bdetach#connect#clicked 
	        ~callback:(fun () -> detach_from_nb nb hb hb2 name));

    |Log ->
       let hb2,_,bdetach = mk_label_nb_detach nb hb name in 
       mk_view_log log_model hb;
       ignore(bdetach#connect#clicked 
	        ~callback:(fun () -> detach_from_nb nb hb hb2 name)) 

    |_ -> assert false



(***************************************************
                       MAIN
****************************************************
****************************************************)

open GdkKeysyms


let tab_of_key = function
  |38 -> 0
  |233 -> 1
  |34 -> 2
  |39 -> 3
  |40 -> 4
  |45 -> 5
  |232 -> 6
  |95 -> 7
  |231 -> 8
  | _ -> assert false

let bind_keys key window (noteb: GPack.notebook) = 
  match (GdkEvent.Key.keyval key) with
    |k when k = 119  -> 
       let pg = noteb#current_page in
       if pg > !nb_real_pages then begin noteb#remove_page pg; end ;
       true
    |k when (k = 38 || k = 233 || k = 34 || k = 39 || 
	   k = 231 || k = 95 || k = 232 || k = 45 || k = 40 ) ->
       noteb#goto_page (tab_of_key k); true
    |k when k = 112 -> 
       let adjust,scl,pause =
	 match !record_adj,!record_scale,!record_pause with
	   |Some a, Some s, Some p -> a,s,p
	   |_ -> assert false
       in
       changed_pause adjust scl pause (); true
    |_  -> (* as  k -> Format.eprintf "key: %d @." k; *) true
 

let start () =
  let window = GWindow.window 
    ~title:"Ocamlviz" ~position:`CENTER
    ~icon:(GdkPixbuf.from_file "/usr/share/pixmaps/ocaml.xpm")
    () in
  main_window := Some window;

  let table = GPack.table ~rows:3 ~columns:1 ~packing:window#add () in
  
  (************** menu ******************)
  let menubar = GMenu.menu_bar ~packing:(table#attach ~top:0 ~left:0 ~expand:`NONE)(* vb#pack *) () in
  let factory = new GMenu.factory menubar in
  let accel_group = factory#accel_group in
  let file_menu = factory#add_submenu "Menu" in
  let factory1 = new GMenu.factory file_menu ~accel_group in
   
  let visualize = factory#add_submenu "Visualize in" in
  visualize_menu := Some visualize;
  let preference = factory#add_submenu "Preferences" in
  let factory2 = new GMenu.factory visualize ~accel_group in
  visualize_factory := Some factory2;
  let factory3 = new GMenu.factory preference ~accel_group in
  let factory4 = new GMenu.factory preference ~accel_group in
  let factory5 = new GMenu.factory preference ~accel_group in
  
  mk_record_box table "<span weight=\"bold\">Refresh Period</span>" 
    "<span weight=\"bold\">Record Panel</span>" changed_spin changed_pause;


  (************** notebook **************)

  let noteb = GPack.notebook ~packing:(table#attach ~top:2 ~left:0 ~expand:`BOTH) () in
  app_notebook := Some noteb;

  (************** menu ******************)
  ignore(factory1#add_item "Next Tab" ~key:_Page_Up ~callback:(fun () -> noteb#next_page () ));
  ignore(factory1#add_item "Previous Tab" ~key:_Page_Down ~callback:(fun () -> noteb#previous_page () ));
  ignore(factory1#add_separator ());
  ignore(factory1#add_item "Close" ~key:_Q ~callback:Main.quit );
  ignore(factory2#add_item "a New Graph" ~key:_G 
	   ~callback:(fun ()-> new_graph noteb (collect_toggles noteb 0) ));
  ignore(factory2#add_separator ());
  let gc = factory2#add_item "GC page"  
    ~callback:(fun ()-> add_to_graph "GC" (collect_toggles noteb 0) ) 
  in
  ignore(factory2#add_separator ());
  ignore(factory2#add_item "a New List" ~key:_T
	   ~callback:(fun () -> new_list noteb (collect_toggles noteb 1) ));
  gc_item := Some gc;
  ignore(factory3#add_item "Graphs" ~key:_E 
	   ~callback:(fun () -> mk_graph_preferences_menu window));
  ignore(factory4#add_item "Record Time Window" ~key:_R
	   ~callback:(fun () -> mk_time_window_preferences window));
  ignore(factory5#add_item "Log Size" ~key:_L
	   ~callback:(fun () -> mk_log_preferences window));


  mk_notebook "Stats" Stat noteb;
  mk_notebook "Values" Value noteb;
  mk_notebook "Tags" Tag noteb;
  mk_notebook "Hash tables" Hash noteb;
  mk_notebook "Trees" Tree noteb;
  mk_notebook "Log" Log noteb;
  mk_notebook "Gc" Gc noteb;
      

  noteb#goto_page 6;

  window#add_accel_group accel_group;

  ignore(window#event#connect#after#key_press
    (fun key -> bind_keys key window noteb));

  ignore(window#connect#destroy ~callback:(fun () -> destroyed:=true));
  ignore(window#connect#destroy ~callback:Main.quit );


  window#show ();

  let _ = Thread.create Net.read_data () in

  (* Requests a refresh every X ms *)
  timeout := Some (GMain.Timeout.add ~ms:default_pref.period ~callback:refresh_models);
  timeout_lab := Some (GMain.Timeout.add ~ms:default_pref.period ~callback:fill_labels);
  GtkThread.main ()
  

let () = start ()

 (*
Local Variables: 
compile-command: "unset LANG; make -C .."
End: 
*)

