open Printf
open Tk
open Embed
open Maps
open Hyper
open Viewers

(* Client Side Image Maps
   We must have two modes: one when the image has not been loaded.
   In that case, we need something like a popup menu. And then, when
   the image is loaded, we use a canvas
   *)


let alt_mode emb m l =
  Log.debug (sprintf "Alt mode map for %s" (Widget.name l));
  try
    let goto = (List.assoc "goto" emb.embed_context.viewer_hyper).hyper_func
    in
    let menu = Menu.create_named l "map" [] in
	List.iter (fun area ->
		     Menu.add_command menu
		       [Label (if area.area_alt = "" then 
			         area.area_link.h_uri
			       else area.area_alt);
			Command (fun () -> goto area.area_link)])
          m;
    bind l [[],ButtonPressDetail 1]
	   (BindSet ([Ev_RootX; Ev_RootY],
		     (fun ei -> Menu.popup menu ei.ev_RootX ei.ev_RootY)))
  with
   Not_found -> ()


let printTagOrId = function
  Id n -> Log.f (sprintf "Id %d" n)
 |Tag s -> Log.f (sprintf "Tag %s" s)


(* See Htbind for semantics of this class *)
class imap (c, items) as self =
 inherit Htbind.active() as super

 val items = items
 val c = c
 method widget = c

 method getlink ei =
   let cx = truncate (Canvas.canvasx c (Pixels ei.ev_MouseX))
   and cy = truncate (Canvas.canvasy c (Pixels ei.ev_MouseY)) in
     match Canvas.find c [Closest (Pixels cx, Pixels cy)] with
       [id] -> List.assoc id items
     |  _ -> raise Not_found

 method binder = Canvas.bind c (Tag "current") 

 method highlight _ = ()
 method markused ei = ()

 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
 



(* This is called when the image has been loaded *)
let gfx_mode emb map c =
  Log.debug (sprintf "Gfx mode map for %s" (Widget.name c));

  (* Build the canvas items corresponding to active zones *)

  (* For points *inside* rects and circle items to be actually considered
     inside for the purpose of activation, we must use both an empty outline
     and an empty fill. *)
  let opts = [Outline (NamedColor ""); FillColor (NamedColor "")] in

  let items = 
     List.map (fun area ->
      try
       match area.area_kind with
	 Default -> Id 1, area.area_link (* the image itself *)
       | Rect ->
	   if List.length area.area_coords <> 4 then begin
	      Log.f "Invalid coords for rect shape";
	      failwith "rect"
	      end
	   else
	    let [x1;y1;x2;y2] = area.area_coords in
	    Canvas.create_rectangle c
		       (Pixels x1) (Pixels y1) (Pixels x2) (Pixels y2) 
		       opts,
	    area.area_link
       | Circle ->
	   if List.length area.area_coords <> 3 then begin
	      Log.f "Invalid coords for circle shape";
	      failwith "circle"
	      end
	   else
	    let [x;y;r] = area.area_coords in
	    Canvas.create_oval c
		       (Pixels (x-r)) (Pixels (y-r))
		       (Pixels (x+r)) (Pixels (y+r))
		       opts,
	    area.area_link

       | Poly ->
	   let l = List.length area.area_coords in
	    (* there must be at least three points, and by pair *)
	   if l < 6 or l mod 2 <> 0 then begin
	      Log.f "Invalid coords for polygon shape";
	      failwith "polygon"
	      end
	   else
	    Canvas.create_polygon c
		       (List.map (fun x -> Pixels x) area.area_coords)
		       opts,
	    area.area_link
     with 
       Protocol.TkError s -> 
	  Log.f (sprintf "Error in area mapping (%s)" s);
	  Tag "area error", area.area_link
     )
     map
  in
  Canvas.lower_bot c (Id 1);
  let htobj = new imap(c,items) in
    htobj#init emb.embed_context


