(* Graph viewer
 * Copyright (C) 2010 Jérôme Vouillon
 * Laboratoire PPS - CNRS Université Paris Diderot
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program 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.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)

open Scene

let pi = 4. *. atan 1.

(****)

let path_extent ctx fill stroke =
  if stroke <> None then Cairo.stroke_extents ctx
  else Cairo.fill_extents ctx

let compute_extent ctx e =
  Cairo.new_path ctx;
  match e with
    Path (cmd, fill, stroke) ->
      Array.iter
        (fun c ->
           match c with
             Move_to (x, y) ->
               Cairo.move_to ctx x y
           | Curve_to (x1, y1, x2, y2, x3, y3) ->
               Cairo.curve_to ctx x1 y1 x2 y2 x3 y3)
        cmd;
      path_extent ctx fill stroke
  | Ellipse (cx, cy, rx, ry, fill, stroke) ->
      Cairo.save ctx;
      Cairo.translate ctx cx cy;
      Cairo.scale ctx rx ry;
      Cairo.arc ctx 0. 0. 1. 0. (2. *. pi);
      Cairo.restore ctx;
      path_extent ctx fill stroke
  | Polygon (points, fill, stroke) ->
      Array.iteri
        (fun i (x, y) ->
           if i = 0 then Cairo.move_to ctx x y else Cairo.line_to ctx x y)
        points;
      Cairo.close_path ctx;
      path_extent ctx fill stroke
  | Text (x, y, txt, (font, font_size), fill, stroke) ->
      Cairo.select_font_face ctx font
        Cairo.FONT_SLANT_NORMAL Cairo.FONT_WEIGHT_NORMAL;
      Cairo.set_font_size ctx font_size;
      let ext = Cairo.text_extents ctx txt in
      (x -. ext.Cairo.text_width /. 2. -. 5.,
       y +. ext.Cairo.y_bearing -. 5.,
       x +. ext.Cairo.text_width /. 2. +. 5.,
       y +. ext.Cairo.y_bearing +. ext.Cairo.text_height +. 5.)

(****)

module Common = Viewer_common.F (struct
  type font = string * float
  type color = float * float * float
  type text = string
  let white = (1., 1., 1.)

  type ctx = Cairo.t

  let save = Cairo.save
  let restore = Cairo.restore

  let scale = Cairo.scale
  let translate = Cairo.translate

  let begin_path = Cairo.new_path
  let close_path = Cairo.close_path
  let move_to = Cairo.move_to
  let line_to = Cairo.line_to
  let curve_to = Cairo.curve_to
  let arc = Cairo.arc
  let rectangle = Cairo.rectangle

  let fill ctx (r, g, b) =
    Cairo.set_source_rgb ctx r g b; Cairo.fill_preserve ctx
  let stroke ctx (r, g, b) =
    Cairo.set_source_rgb ctx r g b; Cairo.stroke_preserve ctx
  let clip = Cairo.clip

  let perform_draw ctx fill_color stroke_color =
    begin match fill_color with
      Some c -> fill ctx c
    | None   -> ()
    end;
    begin match stroke_color with
      Some c -> stroke ctx c
    | None   -> ()
    end

  let draw_text ctx x y txt (font, font_size) fill stroke =
     Cairo.select_font_face ctx font
       Cairo.FONT_SLANT_NORMAL Cairo.FONT_WEIGHT_NORMAL;
     Cairo.set_font_size ctx font_size;
     let ext = Cairo.text_extents ctx txt in
     Cairo.move_to ctx
       (x -. ext.Cairo.x_bearing -. ext.Cairo.text_width /. 2.) y;
     Cairo.show_text ctx txt;
     perform_draw ctx fill stroke

  type window = GMisc.drawing_area
  type drawable = GDraw.drawable
  type pixmap = GDraw.pixmap
  let get_drawable w = new GDraw.drawable (w#misc#window)
  let make_pixmap window width height =
    GDraw.pixmap ~width ~height ~window ()
  let drawable_of_pixmap p = (p : GDraw.pixmap :> GDraw.drawable)
  let get_context p = Cairo_lablgtk.create p#pixmap
  let put_pixmap ~(dst : GDraw.drawable) ~x ~y ~xsrc ~ysrc ~width ~height p =
    dst#put_pixmap ~x ~y ~xsrc ~ysrc ~width ~height p#pixmap;

  (****)

  type rectangle = Gtk.rectangle = {x : int; y : int; width : int; height: int}
  let compute_extents = Scene_extents.compute
end)

open Common

(****)

let set_visible w vis =
  if vis then begin
    if not w#misc#visible then w#misc#show ()
  end else begin
    if w#misc#visible then w#misc#hide ()
  end

let scroll_view ?width ?height ?packing st =
  let table = GPack.table ?width ?height ~columns:2 ~rows:2 ?packing () in
  let hadj = GData.adjustment () in
  let hbar =
    GRange.scrollbar `HORIZONTAL ~adjustment:hadj
      ~packing:(table#attach ~left:0 ~top:1 ~fill:`BOTH ~expand:`NONE) () in
  hbar#misc#hide ();
  let vadj = GData.adjustment () in
  let vbar =
    GRange.scrollbar `VERTICAL ~adjustment:vadj
      ~packing:(table#attach ~left:1 ~top:0 ~fill:`BOTH ~expand:`NONE) () in
  vbar#misc#hide ();
  let display =
    GMisc.drawing_area
      ~packing:(table#attach ~left:0 ~top:0 ~fill:`BOTH ~expand:`BOTH) () in
  display#misc#set_can_focus true;
  display#misc#set_double_buffered false;

  let sadj =
    GData.adjustment ~upper:20. ~step_incr:1. ~page_incr:1. ~page_size:0. () in
  let zoom_steps = 8. in (* Number of steps to get a factor of 2 *)
  let set_zoom_factor f =
    let count = ceil (log f /. log 2. *. zoom_steps) in
    let f = 2. ** (count /. zoom_steps) in
    sadj#set_bounds ~upper:count ();
Format.eprintf "Factor: %f@." f;
    st.zoom_factor <- f
  in
  let get_scale () = 2. ** (sadj#value /. zoom_steps) /. st.zoom_factor in

  let update_scrollbars () =
    let a = display#misc#allocation in
    let scale = get_scale () in
    let aw = ceil (float a.Gtk.width /. scale) in
    let ah = ceil (float a.Gtk.height /. scale) in
    hadj#set_bounds ~step_incr:(aw /. 20.) ~page_incr:(aw /. 2.)
      ~page_size:(min aw st.st_width) ~upper:st.st_width ();
    let mv = st.st_width -. hadj#page_size in
    if hadj#value > mv then hadj#set_value mv;
    vadj#set_bounds ~step_incr:(ah /. 20.) ~page_incr:(ah /. 2.)
      ~page_size:(min ah st.st_height) ~upper:st.st_height ();
    let mv = st.st_height -. vadj#page_size in
    if vadj#value > mv then vadj#set_value mv;
    set_visible hbar (aw < st.st_width);
    set_visible vbar (ah < st.st_height)
  in

  let refresh () =
    invalidate_pixmap st.st_pixmap;
    GtkBase.Widget.queue_draw display#as_widget
  in

  ignore (display#event#connect#configure
    (fun ev ->
prerr_endline "CONFIGURE";
       update_scrollbars (); false));
  ignore (display#event#connect#map
    (fun ev ->
       let a = display#misc#allocation in
Format.eprintf "alloc: %d %d@." a.Gtk.width a.Gtk.height;
       let zoom_factor =
         max (st.st_width /. float a.Gtk.width)
             (st.st_height /. float a.Gtk.height)
       in
       set_zoom_factor zoom_factor;
       refresh ();
       update_scrollbars (); false));
  display#event#add [`STRUCTURE];

  ignore (display#event#connect#expose
    (fun ev ->
       let area = GdkEvent.Expose.area ev in
       let x = Gdk.Rectangle.x area in
       let y = Gdk.Rectangle.y area in
       let width = Gdk.Rectangle.width area in
       let height = Gdk.Rectangle.height area in
       redraw st (get_scale ()) hadj#value vadj#value
         display display#misc#allocation x y width height;
       true));

  ignore (hadj#connect#value_changed
    (fun () -> GtkBase.Widget.queue_draw display#as_widget));
  ignore (vadj#connect#value_changed
    (fun () -> GtkBase.Widget.queue_draw display#as_widget));
  let prev_scale = ref (get_scale ()) in
  let zoom_center = ref (0.5, 0.5) in
  ignore (sadj#connect#value_changed
    (fun () ->
       let scale = get_scale () in
       let r = (1. -. !prev_scale /. scale) in
Format.eprintf "update@.";
       hadj#set_value (hadj#value +. hadj#page_size *. r *. fst !zoom_center);
       vadj#set_value (vadj#value +. vadj#page_size *. r *. snd !zoom_center);
       prev_scale := scale;
       refresh ();
       update_scrollbars ()));

  let bump_scale x y v =
    let a = display#misc#allocation in
    let x = x /. float a.Gtk.width in
    let y = y /. float a.Gtk.height in
    if x >= 0. && x <= 1. && y >= 0. && y <= 1. then
      zoom_center := (x, y);
Format.eprintf "loc: %f %f@." x y;
    sadj#set_value (sadj#value +. v *. sadj#step_increment);
Format.eprintf "reset@.";
    zoom_center := (0.5, 0.5);
    true
  in
  (* Zoom using the mouse wheel *)
  ignore (display#event#connect#scroll
    (fun ev ->
       let x = GdkEvent.Scroll.x ev in
       let y = GdkEvent.Scroll.y ev in
       match GdkEvent.Scroll.direction ev with
         `UP   -> bump_scale x y 1.
       | `DOWN -> bump_scale x y (-1.)
       | _     -> false));
  display#event#add [`SCROLL];

  let pos = ref None in
  ignore (display#event#connect#button_press
    (fun ev ->
       display#misc#grab_focus ();
       if
         GdkEvent.get_type ev = `BUTTON_PRESS && GdkEvent.Button.button ev = 1
       then begin
         pos := Some (GdkEvent.Button.x ev, GdkEvent.Button.y ev);
       end;
       false));
  ignore (display#event#connect#button_release
    (fun ev ->
       if GdkEvent.Button.button ev = 1 then begin
         pos := None;
       end;
       false));
  ignore (display#event#connect#motion_notify
    (fun ev ->
       begin match !pos with
         Some (x, y) ->
           let (x', y') =
             if GdkEvent.Motion.is_hint ev then
               let (x', y') = display#misc#pointer in
               (float x', float y')
             else
               (GdkEvent.Motion.x ev, GdkEvent.Motion.y ev)
           in
           let offset a d =
             a#set_value (min (a#value +. d) (a#upper -. a#page_size)) in
           let scale = get_scale () in
           offset (hadj) ((x -. x') /. scale);
           offset (vadj) ((y -. y') /. scale);
           pos := Some (x', y')
       | None ->
           ()
       end;
       false));
  display#event#add
    [`BUTTON_PRESS; `BUTTON_RELEASE; `BUTTON1_MOTION; `POINTER_MOTION_HINT];

  ignore (display#event#connect#key_press
    (fun ev ->
       let keyval = GdkEvent.Key.keyval ev in
       if
         keyval = GdkKeysyms._Up
       then begin
         vadj#set_value (vadj#value -. vadj#step_increment);
         update_scrollbars ();
         true
       end else if
         keyval = GdkKeysyms._Down
       then begin
         vadj#set_value (vadj#value +. vadj#step_increment);
         update_scrollbars ();
         true
       end else if
         keyval = GdkKeysyms._Left
       then begin
         hadj#set_value (hadj#value -. hadj#step_increment);
         update_scrollbars ();
         true
       end else if
         keyval = GdkKeysyms._Right
       then begin
         hadj#set_value (hadj#value +. hadj#step_increment);
         update_scrollbars ();
         true
       end else if
         keyval = GdkKeysyms._Page_Up
       then begin
         vadj#set_value (vadj#value -. vadj#page_increment);
         update_scrollbars ();
         true
       end else if
         keyval = GdkKeysyms._Page_Down
       then begin
         vadj#set_value (vadj#value +. vadj#page_increment);
         update_scrollbars ();
         true
       end else if
         keyval = GdkKeysyms._0 || keyval = GdkKeysyms._agrave
       then begin
         let a = table#misc#allocation in
Format.eprintf "alloc: %d %d@." a.Gtk.width a.Gtk.height;
         let zf =
           max (st.st_width /. float a.Gtk.width)
               (st.st_height /. float a.Gtk.height)
         in
         let v = ceil (log zf /. log 2. *. zoom_steps) in
Format.eprintf "ZOOM: %f %f %f@." zf v sadj#upper;
         sadj#set_value (min sadj#upper (max 0. (sadj#upper -. v)));
         true
       end else if
         keyval = GdkKeysyms._1 || keyval = GdkKeysyms._ampersand
       then begin
         sadj#set_value (sadj#upper);
         true
       end else if
         keyval = GdkKeysyms._plus ||
         keyval = GdkKeysyms._equal ||
         keyval = GdkKeysyms._KP_Add
       then begin
         let (x, y) = display#misc#pointer in
         bump_scale (float x) (float y) 1.
       end else if
         keyval = GdkKeysyms._minus ||
         keyval = GdkKeysyms._KP_Subtract
       then begin
         let (x, y) = display#misc#pointer in
         bump_scale (float x) (float y) (-1.)
       end else
         false));
  display#event#add [`KEY_PRESS];

  object
    method scale_adjustment = sadj
  end

let create ?(full_screen=false) (x1, y1, x2, y2) scene =
  let st =
    { bboxes = [||]; scene = Scene.get scene; zoom_factor = 20.;
      st_x = x1; st_y = y1; st_width = x2 -. x1; st_height = y2 -. y1;
      st_pixmap = make_pixmap () } in

  let initial_size = 600 in
  let w = GWindow.window () in
  ignore (w#connect#destroy GMain.quit);
  let b = GPack.hbox ~packing:w#add () in
  let f =
    scroll_view ~width:initial_size ~height:initial_size
      ~packing:(b#pack ~expand:true) st in
  ignore
    (GRange.scale `VERTICAL ~inverted:true ~draw_value:false
       ~adjustment:(f#scale_adjustment) ~packing:b#pack ());

(*XXX Tooltips
area#misc#set_has_tooltip true;
ignore (area#misc#connect#query_tooltip (fun ~x ~y ~kbd tooltip ->
Format.eprintf "%d %d %b@." x y kbd; false));
*)

  (* Full screen mode *)
  let fullscreen = ref false in
  let toggle_fullscreen () =
    if !fullscreen then w#unfullscreen () else w#fullscreen ();
    fullscreen := not !fullscreen;
    true
  in
  if full_screen then ignore (toggle_fullscreen ());

  ignore (w#event#connect#key_press
    (fun ev ->
       let keyval = GdkEvent.Key.keyval ev in
       if keyval = GdkKeysyms._q || keyval = GdkKeysyms._Q then
         exit 0
       else if
         keyval = GdkKeysyms._F11 ||
         keyval = GdkKeysyms._F5 ||
         (keyval = GdkKeysyms._Escape && !fullscreen) ||
         keyval = GdkKeysyms._f || keyval = GdkKeysyms._F
       then
         toggle_fullscreen ()
       else
         false));

  w#show ()