(* $Id$
 * ----------------------------------------------------------------------
 *
 *)

open Pxp_types
open Pxp_document
open Ds_context


let get_dimension s =
  let re = Str.regexp "\\([0-9]*\\(.[0-9]+\\)?\\)[ \t\n]*\\(px\\|cm\\|in\\|mm\\|pt\\)" in
  if Str.string_match re s 0 then begin
    let number = Str.matched_group 1 s in
    let dim = Str.matched_group 3 s in
    match dim with
	"px" -> Tk.Pixels (int_of_float (float_of_string number))
      | "cm" -> Tk.Centimeters (float_of_string number)
      | "in" -> Tk.Inches (float_of_string number)
      | "mm" -> Tk.Millimeters (float_of_string number)
      | "pt" -> Tk.PrinterPoint (float_of_string number)
      | _ -> assert false
  end
  else
    failwith ("Bad dimension: " ^ s)
;;


class virtual shared =
  object(self)

    (* --- default_ext --- *)

    val mutable node = (None : shared node option)

    method clone = {< >}
    method node =
      match node with
          None ->
            assert false
        | Some n -> n
    method set_node n =
      node <- Some n

    (* --- shared attributes: color & font settings --- *)

    val mutable fgcolor = (None : string option)
    val mutable bgcolor = (None : string option)
    val mutable font = (None : string option)

    method fgcolor =
      (* Get the foreground color: If there is a local value, return it;
       * otherwise ask parent node
       *)
      match fgcolor with
	  Some c -> c
	| None   -> try self # node # parent # extension # fgcolor with
	            Not_found -> failwith "#fgcolor"

    method bgcolor =
      (* Get the background color: If there is a local value, return it;
       * otherwise ask parent node
       *)
      match bgcolor with
	  Some c -> c
	| None   -> try self # node # parent # extension # bgcolor with
	            Not_found -> failwith "#bgcolor"

    method font =
      (* Get the current font: If there is a local value, return it;
       * otherwise ask parent node
       *)
      match font with
	  Some c -> c
	| None   -> try self # node # parent # extension # font with
	            Not_found -> failwith "#font"

    method private init_color_and_font =
      let get_color n =
      	try
	  match self # node # attribute n with
	      Value v -> Some v
	    | Implied_value -> None
	    | _ -> assert false
      	with Not_found -> None in
      fgcolor <- get_color "fgcolor";
      bgcolor <- get_color "bgcolor";
      font    <- get_color "font";      (* sic! *)


    method private bg_color_opt =
      [ Tk.Background (Tk.NamedColor (self # bgcolor)) ]

    method private fg_color_opt =
      [ Tk.Foreground (Tk.NamedColor (self # fgcolor)) ]

    method private font_opt =
      [ Tk.Font (self # font) ]

    (* --- virtual --- *)

    method virtual prepare : shared Pxp_yacc.index -> unit
    method virtual create_widget : Widget.widget -> context -> Widget.widget

    method pack_opts = ( [] : Tk.options list )
    method xstretchable = false
    method ystretchable = false

    method accept (c:context) = ()

    method private get_mask =
      (* find parent which is a mask *)
      let rec search n =
	match n # node_type with
	    T_element "mask" ->
	      n # extension
	  | T_element _ ->
	      search (n # parent)
	  | _ ->
	      assert false
      in
      search (self # node)


    method private accept_mask (c:context) =
      let rec iterate n =
	n # extension # accept c;
	List.iter iterate (n # sub_nodes)
      in
      iterate (self # get_mask # node)


    method start_node_name =
      (failwith "#start_node_name" : string)

    (* --- debug --- *)

    method private name =
      let nt = self # node # node_type in
      match nt with
	  T_element n -> n
	| T_data      -> "#PCDATA"
	| _           -> assert false

  end
;;


class default =
  object (self)
    inherit shared

    method prepare idx =
      self # init_color_and_font

    method create_widget w c =
      failwith "default # create_widget"
  end
;;


let dummy_node = new element_impl (new default);;

class application =
  object (self)
    inherit shared

    val mutable start_node = dummy_node

    method prepare idx =
      (* prepare this node *)
      self # init_color_and_font;
      if fgcolor = None then fgcolor <- Some "black";
      if bgcolor = None then bgcolor <- Some "white";
      if font = None then font <- Some "fixed";
      let start =
	match self # node # attribute "start" with
	    Value v -> v
	  | _       -> assert false in
      start_node <- (try idx # find start with
	  Not_found -> failwith "Start node not found");
      (* iterate over the subtree *)
      let rec iterate n =
	n # extension # prepare idx;
	List.iter iterate (n # sub_nodes)
      in
      List.iter iterate (self # node # sub_nodes)


    method start_node_name =
      match self # node # attribute "start" with
	  Value v -> v
	| _       -> assert false

    method create_widget w c =
      start_node # extension # create_widget w c

    method pack_opts =
      start_node # extension # pack_opts
  end
;;


class sequence =
  object (self)
    inherit shared

    method prepare idx =
      self # init_color_and_font;

    method create_widget w c =
      let node = List.hd (self # node # sub_nodes) in
      node # extension # create_widget w c

    method pack_opts =
      let node = List.hd (self # node # sub_nodes) in
      node # extension # pack_opts
  end
;;


class vbox =
  object (self)
    inherit shared

    val mutable att_halign = "left"

    method prepare idx =
      self # init_color_and_font;
      match self # node # attribute "halign" with
	  Value v -> att_halign <- v
	| _ -> assert false

    method create_widget w c =
      let f = Frame.create w (self # bg_color_opt) in
      let nodes = self # node # sub_nodes in
      let options =
	match att_halign with
	    "left"     -> [ Tk.Anchor Tk.W ]
	  | "right"    -> [ Tk.Anchor Tk.E ]
	  | "center"   -> [ Tk.Anchor Tk.Center ]
	  | _ -> assert false
      in
      List.iter
	(fun n ->
	   let opts = n # extension # pack_opts in
	   let wdg = n # extension # create_widget f c in
	   Tk.pack [wdg] (options @ opts);
	)
	nodes;
      f

    method pack_opts =
      match self # xstretchable, self # ystretchable with
	  true, false  -> [ Tk.Fill Tk.Fill_X; (* Tk.Expand true *) ]
	| false, true  -> [ Tk.Fill Tk.Fill_Y;  (* Tk.Expand true *) ]
	| true, true   -> [ Tk.Fill Tk.Fill_Both; (* Tk.Expand true *) ]
	| false, false -> []

    method xstretchable =
      let nodes = self # node # sub_nodes in
      List.exists (fun n -> n # extension # xstretchable) nodes

    method ystretchable =
      let nodes = self # node # sub_nodes in
      List.exists (fun n -> n # extension # ystretchable) nodes

  end

;;


class mask =
  object (self)

    inherit vbox

    method prepare idx =
      self # init_color_and_font;
      att_halign <- "left"
  end
;;


class hbox =
  object (self)
    inherit shared

    val mutable att_width = None
    val mutable att_halign = "left"
    val mutable att_valign = "top"

    method prepare idx =
      self # init_color_and_font;
      begin match self # node # attribute "halign" with
	  Value v -> att_halign <- v
	| _ -> assert false
      end;
      begin match self # node # attribute "valign" with
	  Value v -> att_valign <- v
	| _ -> assert false
      end;
      begin match self # node # attribute "width" with
	  Value v       -> att_width <- Some (get_dimension v)
	| Implied_value -> att_width <- None
	| _ -> assert false
      end

    method create_widget w c =
      let f1 = Frame.create w (self # bg_color_opt) in
      let f_extra =
	match att_width with
	    None    -> []
	  | Some wd ->
	      [ Canvas.create f1
		  ( [ Tk.Width wd; Tk.Height (Tk.Pixels 0);
		      Tk.Relief Tk.Flat;
		      Tk.HighlightThickness (Tk.Pixels 0);
		    ] @
		    self # bg_color_opt ) ]
      in
      let f2 = Frame.create f1 (self # bg_color_opt) in
      let nodes = self # node # sub_nodes in

      let outer_pack_opts =
      	match att_halign with
	    "left"     -> [ Tk.Anchor Tk.W ]
	  | "right"    -> [ Tk.Anchor Tk.E ]
	  | "center"   -> [ Tk.Anchor Tk.Center ]
	  | _ -> assert false
      in
      let inner_pack_opts =
	match att_valign with
	    "top"      -> [ Tk.Anchor Tk.N ]
	  | "bottom"   -> [ Tk.Anchor Tk.S ]
	  | "center"   -> [ Tk.Anchor Tk.Center ]
	  | _ -> assert false
      in
      List.iter
	(fun n ->
	   let opts = n # extension # pack_opts in
	   let wdg = n # extension # create_widget f2 c in
	   Tk.pack [wdg] (inner_pack_opts @ [ Tk.Side Tk.Side_Left ] @ opts);
	)
	nodes;
      let extra_opts = self # pack_opts in
      Tk.pack (f_extra @ [f2]) (outer_pack_opts @ extra_opts);
      f1

    method pack_opts =
      match self # xstretchable, self # ystretchable with
	  true, false  -> [ Tk.Fill Tk.Fill_X;  (* Tk.Expand true *) ]
	| false, true  -> [ Tk.Fill Tk.Fill_Y;  (* Tk.Expand true *) ]
	| true, true   -> [ Tk.Fill Tk.Fill_Both;  (* Tk.Expand true *) ]
	| false, false -> []

    method xstretchable =
      let nodes = self # node # sub_nodes in
      List.exists (fun n -> n # extension # xstretchable) nodes

    method ystretchable =
      let nodes = self # node # sub_nodes in
      List.exists (fun n -> n # extension # ystretchable) nodes

  end
;;

class vspace =
  object (self)
    inherit shared

    val mutable att_height = Tk.Pixels 0
    val mutable att_fill  = false

    method prepare idx =
      self # init_color_and_font;
      begin match self # node # attribute "height" with
	  Value v       -> att_height <- get_dimension v
	| _ -> assert false
      end;
      begin match self # node # attribute "fill" with
	  Value "yes" -> att_fill <- true
	| Value "no"  -> att_fill <- false
	| _ -> assert false
      end


    method create_widget w c =
      let f = Frame.create w ( self # bg_color_opt ) in
      let strut =
      	Canvas.create f
	  ( [ Tk.Height att_height; Tk.Width (Tk.Pixels 0);
	      Tk.Relief Tk.Flat;
	      Tk.HighlightThickness (Tk.Pixels 0);
	    ] @
	    self # bg_color_opt ) in
      if att_fill then
	Tk.pack [strut] [Tk.Fill Tk.Fill_Y; Tk.Expand true]
      else
	Tk.pack [strut] [];
      f

    method pack_opts =
      if att_fill then [ Tk.Fill Tk.Fill_Y; Tk.Expand true ] else []

    method ystretchable = att_fill
  end
;;

class hspace =
  object (self)
    inherit shared


    val mutable att_width = Tk.Pixels 0
    val mutable att_fill  = false

    method prepare idx =
      self # init_color_and_font;
      begin match self # node # attribute "width" with
	  Value v       -> att_width <- get_dimension v
	| _ -> assert false
      end;
      begin match self # node # attribute "fill" with
	  Value "yes" -> att_fill <- true
	| Value "no"  -> att_fill <- false
	| _ -> assert false
      end


    method create_widget w c =
      let f = Frame.create w ( self # bg_color_opt ) in
      let strut =
      	Canvas.create f
	  ( [ Tk.Width att_width; Tk.Height (Tk.Pixels 0);
	      Tk.Relief Tk.Flat;
	      Tk.HighlightThickness (Tk.Pixels 0);
	    ] @
	    self # bg_color_opt ) in
      if att_fill then
	Tk.pack [strut] [Tk.Fill Tk.Fill_X; Tk.Expand true]
      else
	Tk.pack [strut] [];
      f

    method pack_opts =
      if att_fill then [ Tk.Fill Tk.Fill_X; Tk.Expand true ] else []

    method xstretchable = att_fill
  end
;;

class label =
  object (self)
    inherit shared

    val mutable att_textwidth = (-1)
    val mutable att_halign = "left"

    method prepare idx =
      self # init_color_and_font;
      att_textwidth <- (match self # node # attribute "textwidth" with
			    Value v ->
			      let w = try int_of_string v
			      with _ -> failwith ("Not an integer: " ^ v) in
			      w
			  | Implied_value ->
			      (-1)
			  | _ -> assert false);
      att_halign <- (match self # node # attribute "halign" with
			 Value v -> v
		       | _ -> assert false);


    method create_widget w c =
      let opts_textwidth = if att_textwidth < 0 then [] else
	                                       [ Tk.TextWidth att_textwidth ] in
      let opts_halign =
	match att_halign with
	    "left"     -> [ Tk.Anchor Tk.W ]
	  | "right"    -> [ Tk.Anchor Tk.E ]
	  | "center"   -> [ Tk.Anchor Tk.Center ]
	  | _ -> assert false
      in
      let opts_content =
	[ Tk.Text (self # node # data) ] in
      let label = Label.create w (opts_textwidth @ opts_halign @
				  opts_content @ self # bg_color_opt @
				  self # fg_color_opt @ self # font_opt) in
      label

  end
;;

class entry =
  object (self)
    inherit shared

    val mutable tv = lazy (Textvariable.create())
    val mutable att_textwidth = (-1)
    val mutable att_slot = ""

    method prepare idx =
      self # init_color_and_font;
      tv <- lazy (Textvariable.create());
      att_textwidth <- (match self # node # attribute "textwidth" with
			    Value v ->
			      let w = try int_of_string v
			      with _ -> failwith ("Not an integer: " ^ v) in
			      w
			  | Implied_value ->
			      (-1)
			  | _ -> assert false);
      att_slot <- (match self # node # attribute "slot" with
	  Value v -> v
	| _ -> assert false);

    method create_widget w c =
      let opts_textwidth = if att_textwidth < 0 then [] else
	                                       [ Tk.TextWidth att_textwidth ] in
      let e = Entry.create w ( [ Tk.TextVariable (Lazy.force tv) ] @
			       self # fg_color_opt @
			       self # bg_color_opt @
			       self # font_opt @
			       opts_textwidth
			     ) in
      let s =
	try c # get_slot att_slot with
	    Not_found -> self # node # data in
      Textvariable.set (Lazy.force tv) s;
      e

    method accept c =
      c # set_slot att_slot (Textvariable.get (Lazy.force tv))

  end
;;

class textbox =
  object (self)
    inherit shared

    val mutable att_textwidth = (-1)
    val mutable att_textheight = (-1)
    val mutable att_slot = ""
    val mutable last_widget = None

    method prepare idx =
      self # init_color_and_font;
      att_textwidth <- (match self # node # attribute "textwidth" with
			    Value v ->
			      let w = try int_of_string v
			      with _ -> failwith ("Not an integer: " ^ v) in
			      w
			  | Implied_value ->
			      (-1)
			  | _ -> assert false);
      att_textheight <- (match self # node # attribute "textheight" with
			    Value v ->
			      let w = try int_of_string v
			      with _ -> failwith ("Not an integer: " ^ v) in
			      w
			  | Implied_value ->
			      (-1)
			  | _ -> assert false);
      att_slot <- (match self # node # attribute "slot" with
		       Value v -> v
		     | Implied_value -> ""
		     | _ -> assert false);


    method create_widget w c =
      let opts_textwidth = if att_textwidth < 0 then [] else
	                                       [ Tk.TextWidth att_textwidth ] in
      let opts_textheight = if att_textheight < 0 then [] else
	                                    [ Tk.TextHeight att_textheight ] in
      let f = Frame.create w (self # bg_color_opt) in
      let vscrbar = Scrollbar.create f [ Tk.Orient Tk.Vertical ] in
      let e = Text.create f ( [ ] @
			      self # fg_color_opt @
			      self # bg_color_opt @
			      self # font_opt @
			      opts_textwidth @ opts_textheight
			    ) in
      last_widget <- Some e;
      Scrollbar.configure vscrbar [ Tk.ScrollCommand
				      (fun s -> Text.yview e s);
				    Tk.Width (Tk.Pixels 9) ];
      Text.configure e [ Tk.YScrollCommand
			   (fun a b -> Scrollbar.set vscrbar a b) ];
      let s =
	if att_slot <> "" then
	  try c # get_slot att_slot with
	      Not_found -> self # node # data 
	else 
	  self # node # data 
      in
      (* Text.insert appends always a newline to the last line; so strip 
       * an existing newline first
       *)
      let s' = 
	if s <> "" & s.[String.length s - 1] = '\n' then
	  String.sub s 0 (String.length s - 1)
	else 
	  s in
      Text.insert e (Tk.TextIndex(Tk.End,[])) s' [];
      if att_slot = "" then
	Text.configure e [ Tk.State Tk.Disabled ];
      Tk.pack [e] [ Tk.Side Tk.Side_Left ];
      Tk.pack [vscrbar] [ Tk.Side Tk.Side_Left; Tk.Fill Tk.Fill_Y ];
      f

    method accept c =
      if att_slot <> "" then
	match last_widget with
	    None -> ()
	  | Some w ->
	      let s =
		Text.get
		  w
		  (Tk.TextIndex(Tk.LineChar(1,0),[]))
		  (Tk.TextIndex(Tk.End,[])) in
	      c # set_slot att_slot s

  end
;;

class button =
  object (self)
    inherit shared

    val mutable att_label = ""
    val mutable att_action = ""
    val mutable att_goto = ""

    method prepare idx =
      self # init_color_and_font;
      att_label <- (match self # node # attribute "label" with
			Value v -> v
		      | _ -> assert false);
      att_action <- (match self # node # attribute "action" with
			 Value v -> v
		       | _ -> assert false);
      att_goto <- (match self # node # attribute "goto" with
		       Value v -> v
		     | Implied_value -> ""
		     | _ -> assert false);
      if att_action = "goto" then begin
	try let _ = idx # find att_goto in () with
	    Not_found -> failwith ("Target `" ^ att_goto ^ "' not found")
      end;
      if att_action = "list-prev" or att_action = "list-next" then begin
	let m = self # get_mask in
	if m # node # parent # node_type <> T_element "sequence" then
	  failwith ("action " ^ att_action ^ " must not be used out of <sequence>");
      end;


    method create_widget w c =
      let cmd () =
	self # accept_mask c;
	match att_action with
	    "goto" ->
	      c # goto att_goto
	  | "save" ->
	      c # save_obj
	  | "exit" ->
	      Protocol.closeTk()
	  | "save-exit" ->
	      c # save_obj;
	      Protocol.closeTk()
	  | "list-prev" ->
	      let m = self # get_mask # node in
	      let s = m # parent in
	      let rec search l =
		match l with
		    x :: y :: l' ->
		      if y == m then
			match x # attribute "name" with
			    Value s -> c # goto s
			  | _ -> assert false
		      else
			search (y :: l')
		  | _ -> ()
	      in
	      search (s # sub_nodes)
	  | "list-next" ->
	      let m = self # get_mask # node in
	      let s = m # parent in
	      let rec search l =
		match l with
		    x :: y :: l' ->
		      if x == m then
			match y # attribute "name" with
			    Value s -> c # goto s
			  | _ -> assert false
		      else
			search (y :: l')
		  | _ -> ()
	      in
	      search (s # sub_nodes)
	  | "hist-prev" ->
	      (try c # previous with Not_found -> ())
	  | "hist-next" ->
	      (try c # next with Not_found -> ())
	  | _ -> ()
      in
      let b = Button.create w ( [ Tk.Text att_label; Tk.Command cmd ] @
			      	self # fg_color_opt @
			      	self # bg_color_opt @
			      	self # font_opt ) in
      b


  end
;;


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

open Pxp_yacc

let tag_map =
  make_spec_from_mapping
    ~data_exemplar:(new data_impl (new default))
    ~default_element_exemplar:(new element_impl (new default))
    ~element_mapping:
       (let m = Hashtbl.create 50 in
	Hashtbl.add m "application"
	 	      (new element_impl (new application));
	Hashtbl.add m "sequence"
		      (new element_impl (new sequence));
	Hashtbl.add m "mask"
		      (new element_impl (new mask));
	Hashtbl.add m "vbox"
	              (new element_impl (new vbox));
	Hashtbl.add m "hbox"
		      (new element_impl (new hbox));
	Hashtbl.add m "vspace"
		      (new element_impl (new vspace));
	Hashtbl.add m "hspace"
		      (new element_impl (new hspace));
	Hashtbl.add m "label"
		      (new element_impl (new label));
	Hashtbl.add m "entry"
		      (new element_impl (new entry));
	Hashtbl.add m "textbox"
		      (new element_impl (new textbox));
	Hashtbl.add m "button"
		      (new element_impl (new button));
	m)
    ()
;;

(* ======================================================================
 * History:
 *
 * $Log$
 * Revision 1.1  2000/11/17 09:57:31  lpadovan
 * Initial revision
 *
 * Revision 1.5  2000/08/30 15:58:49  gerd
 * 	Updated.
 *
 * Revision 1.4  2000/07/16 19:36:03  gerd
 * 	Updated.
 *
 * Revision 1.3  2000/07/08 22:03:11  gerd
 * 	Updates because of PXP interface changes.
 *
 * Revision 1.2  2000/06/04 20:29:19  gerd
 * 	Updates because of renamed PXP modules.
 *
 * Revision 1.1  1999/08/21 19:11:05  gerd
 * 	Initial revision.
 *
 *
 *)