(* Bindings for hypernavigation *)
open Printf
open Tk
open Hyper
open Viewers

let stdbindings = Hashtbl.create 37

let _ =
 List.iter (fun (ev, f) -> Hashtbl.add stdbindings ev f)
      [ 
       "goto", [[], ButtonPressDetail 1];
       "save", [[Shift], ButtonPressDetail 1];
       "gotonew", [[], ButtonPressDetail 3]
     ] 

(*
An active object is assumed to have the following methods:
*)    


class virtual active() as self =
 virtual widget : Widget.widget
      (* returns the widget to which an hypermenu can be attached *)
 virtual getlink : eventInfo -> Hyper.link
      (* returns the link pointed to by the object *)
 virtual binder : (modifier list * xEvent) list -> bindAction -> unit
      (* binds events on the object *)
 virtual highlight : bool -> unit
      (* user feedback (mostly cursor) indicating that object is active *)
 virtual markused : eventInfo -> unit
      (* say that we've activated this link *)

 method init ctx =
  (* Install all navigation bindings *)
  Hashtbl.iter (fun hyname eventl ->
    try 
      let hyperf = List.assoc hyname ctx.viewer_hyper in
      self#binder eventl
	(BindSet ([Ev_MouseX; Ev_MouseY],
		  (fun ei -> 
		     try let link = self#getlink ei in
		          self#markused ei;
		          hyperf.hyper_func link;
		     with Not_found -> ())))
    with
      Not_found -> ())
    stdbindings;

  (* Install the menu (created by need only) *)
  let activate = ref (fun ei -> ()) in
  let hypermenu = Frx_misc.autodef (fun () ->
     let m = Menu.create_named self#widget "hypermenu" [] in
	List.iter (fun (fname, f) ->
		     if f.hyper_visible then
		      Menu.add_command m
			   [Label f.hyper_title; 
			    Command (fun () -> !activate f)])
	      ctx.viewer_hyper;
	m) in
  self#binder [[Control], ButtonPressDetail 1]
   (BindSet ([Ev_MouseX; Ev_MouseY; Ev_RootX; Ev_RootY], 
       (fun ei -> 
	 activate := 
	   (fun hyperf -> 
	     try
	       let link = self#getlink ei in
                 self#markused ei;
		 hyperf.hyper_func link
	     with Not_found -> ());
	 Menu.popup (hypermenu()) ei.ev_RootX ei.ev_RootY)));

  (* Install the pointsto internal bindings *)
  begin try
    let pointsto = List.assoc "pointsto" ctx.viewer_hyper in
      self#binder [[], Enter]
	(BindSet ([Ev_MouseX; Ev_MouseY], 
		  (fun ei ->
		    try
		      let link = self#getlink ei in
		       self#highlight true;
		       pointsto.hyper_func link
		    with Not_found -> ())))
      with Not_found -> ()
  end;
  begin try
    let  clearpointsto = List.assoc "clearpointsto" ctx.viewer_hyper
    and fakehlink = {h_uri = ""; h_context = None; h_method = GET} in
      self#binder [[], Leave]
	(BindSet ([Ev_MouseX; Ev_MouseY], 
		  (fun ei ->
		    self#highlight false;
		    clearpointsto.hyper_func fakehlink)))
    with Not_found -> ()
  end

end

(*
 * The various active objects
 *)

(* Text widget with anchors marked as tags *)

(* Find the tag indicating the link in the list of tags *)
let rec anchor_tag = function
    [] -> raise Not_found
  | s :: l -> if String.length s > 6 & String.sub s 0 6 = "anchor"
	      then s
	      else anchor_tag l

class hypertext (thtml) as self =
  inherit active() as super
  val thtml = thtml  (* keep our own copy *)

  method widget = thtml

  val anchor_table = 
    (Hashtbl.create 211 : (string, Hyper.link) Hashtbl.t)


  method getlink ei =
     (* The index of the click position *)
     let i = 
       Text.index thtml (TextIndex (AtXY (ei.ev_MouseX,ei.ev_MouseY), [])) in
     (* Tags at this place *)
     let tags = Text.tag_indexnames thtml (TextIndex (i, [])) in
       Hashtbl.find anchor_table (anchor_tag tags)

  method binder = Text.tag_bind thtml "anchor" 

  method highlight flag = 
    if flag then
      Text.configure thtml [Cursor (XCursor "hand2")]
    else
      Text.configure thtml [Cursor (XCursor "xterm")]

  method markused ei =
     (* The index of the click position *)
     let i = 
       Text.index thtml (TextIndex (AtXY (ei.ev_MouseX,ei.ev_MouseY), [])) in
     (* Tags at this place *)
     let tags = Text.tag_indexnames thtml (TextIndex (i, [])) in
      begin try
     	Text.tag_configure thtml (anchor_tag tags)
		   [Foreground (NamedColor "MidnightBlue")]
      with _ -> ()
      end

  (* this method is private *)
  method add_anchor = Hashtbl.add anchor_table

  (* we don't get Enter/Leave when tags are contiguous, so the 
     pointed link displayed in pointsto is no always correct
     Thus, extend initialisation to bind pointsto on motion
   *)
  method init ctx =
    super#init ctx;
    begin try
      let  pointsto = List.assoc "pointsto" ctx.viewer_hyper in
	self#binder [[], Motion]
	  (BindSet ([Ev_MouseX; Ev_MouseY], 
		    (fun ei ->
		      try
			let link = self#getlink ei in
		          pointsto.hyper_func link
		      with
			Not_found -> ())))
      with Not_found -> ()
    end

end


(* embedded objects with direct map *)
class directmap (frame, link) as self =
  inherit active()
  val frame = frame
  method widget = frame
  val link = (link : Hyper.link)
  method getlink (ei : eventInfo) = link
  method binder = bind frame
  method highlight (flag : bool) = ()  (* we already set up the cursor *)
  method markused ei =
    Frame.configure frame [Relief Sunken]
end

(* embedded objects with server map (ISMAP) *)
(* pointsto will get some arbitrary value for x,y... *)
class servermap (frame,link) as self =
  inherit active()
  inherit directmap (frame, link)
  method getlink ei = 
    {h_uri = sprintf "%s?%d,%d" link.h_uri
                                ei.ev_MouseX ei.ev_MouseY;
     h_context = link.h_context;
     h_method = GET}
end

(* embedded objects with form submission *)
class formmap (frame,formlink) as self =
  inherit active()
  val frame = frame
  method widget = frame
  val formlink = (formlink : int * int -> Hyper.link)
  method getlink ei = formlink (ei.ev_MouseX, ei.ev_MouseY)
  method binder = bind frame
  method highlight (flag : bool) = ()  (* we already set up the cursor *)
  method markused ei =
    Frame.configure frame [Relief Sunken]
end


(* Client side image maps are defined in Cmap *)
