(* 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 =
    (match fill_color with
    | Some c -> fill ctx c
    | None -> ());
    match stroke_color with
    | Some c -> stroke ctx c
    | None -> ()

  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 (if not w#misc#visible then w#misc#show ())
  else if w#misc#visible
  then w#misc#hide ()

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 pos := Some (GdkEvent.Button.x ev, GdkEvent.Button.y ev);
         false));
  ignore
    (display#event#connect#button_release (fun ev ->
         if GdkEvent.Button.button ev = 1 then pos := None;
         false));
  ignore
    (display#event#connect#motion_notify (fun ev ->
         (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 -> ());
         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 (
           vadj#set_value (vadj#value -. vadj#step_increment);
           update_scrollbars ();
           true)
         else if keyval = GdkKeysyms._Down
         then (
           vadj#set_value (vadj#value +. vadj#step_increment);
           update_scrollbars ();
           true)
         else if keyval = GdkKeysyms._Left
         then (
           hadj#set_value (hadj#value -. hadj#step_increment);
           update_scrollbars ();
           true)
         else if keyval = GdkKeysyms._Right
         then (
           hadj#set_value (hadj#value +. hadj#step_increment);
           update_scrollbars ();
           true)
         else if keyval = GdkKeysyms._Page_Up
         then (
           vadj#set_value (vadj#value -. vadj#page_increment);
           update_scrollbars ();
           true)
         else if keyval = GdkKeysyms._Page_Down
         then (
           vadj#set_value (vadj#value +. vadj#page_increment);
           update_scrollbars ();
           true)
         else if keyval = GdkKeysyms._0 || keyval = GdkKeysyms._agrave
         then (
           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)
         else if keyval = GdkKeysyms._1 || keyval = GdkKeysyms._ampersand
         then (
           sadj#set_value sadj#upper;
           true)
         else if keyval = GdkKeysyms._plus
                 || keyval = GdkKeysyms._equal
                 || keyval = GdkKeysyms._KP_Add
         then
           let x, y = display#misc#pointer in
           bump_scale (float x) (float y) 1.
         else if keyval = GdkKeysyms._minus || keyval = GdkKeysyms._KP_Subtract
         then
           let x, y = display#misc#pointer in
           bump_scale (float x) (float y) (-1.)
         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 ()