open Printf
open Tk
open Html

(* Table support using the grid manager and a gross hack to obtain 
   resizing of a text widget to show its entire content.

 * Notes:
  1  we must keep geometry propagation on the grid, otherwise we'll never
     get vertical resizing
  2  the same is valid for each cell !
  3  As a consequence, we must specify a "minsize" for each column,
     otherwise shrinking cells will shring columns.
 *)

let debug = ref true

let default_header_opts = [BorderWidth (Pixels 2); Relief Groove]
let default_data_opts = [BorderWidth (Pixels 2); Relief Groove]

(* a manager for a single TABLE *)
type cell_type = HeaderCell | DataCell
type t = {
  close_table : unit -> unit;
  add_col : Html.tag -> unit;
  open_row : Html.tag -> unit;
  new_cell : cell_type -> Html.tag -> int -> int -> Widget.widget
  }

  (* Set the initial height to the number of lines *)
let text_size t =
  Log.debug (sprintf "Start resizing %s" (Widget.name t));
   match Text.index t (TextIndex(End,[])) with
    LineChar (l,c) -> Text.configure t [TextHeight (l-1)]
  | _ -> ()

(* Make sure a cell [w] occupies [cellw] *)
let recompute_size w cellw =
  if !debug then 
    Log.f (sprintf "Setting width of %s to %d" (Widget.name w) cellw);
  match Winfo.children w with
    [x] ->
      begin match Winfo.class_name x with
      	"Message" ->
	   (* Messages are in a packer, expand true, so by setting
      	      the line width, we should be ok. The message is supposed 
      	      to grow vertically. Note however that the message will
              shrink to its natural size whatever the width configuration,
              if contents fit in less. The given value is a therefore a max.
              minsize does the rest
            *)
      	   Message.configure x [Width (Pixels cellw)]
      | "Text" ->
	   text_size x;
           (* For text widget, we must run the special hack *)
	   let scroll, check = Frx_fit.vert x in
            Text.configure x [YScrollCommand scroll];
           (* A posteriori updates for embedded windows *)
	    List.iter 
	      (fun embedded ->
		bind embedded [[], Configure]
		   (BindSet([], (fun _ ->
				  bind embedded [[], Configure] BindRemove;
				  Frx_after.idle check;
      	       	       	       	  ()))))
              (Text.window_names x)
      | s ->
	  if !debug then
	   Log.f (sprintf "Table.recompute_size: unknown children class %s" s)
      end
  | [] -> () (* there maybe empty cells out there ! *)
  | l -> 
     if !debug then Log.f (sprintf "Table.recompute_size: too many children");
     List.iter (fun w -> Log.f (sprintf "%s\n" (Widget.name w))) l

(* Internal structure of tables *)
type table = {
  master_widget : Widget.widget;
  width : int;
  mutable slaves : (Widget.widget * (int*int*int*int)) list;
  mutable cur_col : int;
  mutable cur_row : int;
  mutable widths : int array;
  mutable slots : int array;
  mutable cols : int option list
  }


let packem table =
  List.iter 
    (fun (w, (row,col,rspan,cspan)) ->
       (* Sticky opt gives Expand true, Fill Both *)
       grid [w] [Row row; Column col;
                    RowSpan rspan; ColumnSpan cspan;
		    Sticky "nswe"])
    table.slaves

(* All the widgets have been drawn. Widths of columns have been computed. *)
let recompute_all table =
  List.iter 
    (function w, (row,col,rspan,cspan) ->
       let wid = ref 0 in
	 for i = col to col + cspan - 1 do
	  wid := !wid + table.widths.(i) 
	 done;
       recompute_size w !wid)
  table.slaves

(* 
   Compute column widths: to be called when the first TR is encountered,
   or, if COL were not specified, at then end of the table (since we don't
   know the number of columns until the end)
*)
let compute_col table last_chance =
  if table.widths = [||] then
    match table.cols with
      [] ->
      (* no COL ! Allocate equal space for each column, and recompute all *)
	if last_chance then (* we are closing the table *)
	 (* the number of columns is given here *)
	 let n = Array.length table.slots in
	 (* assume equal repartition of column space *)
	 let cellw = if n = 0 then table.width else table.width / n in
	  (* Set the columns to given size *)
	  for i = 0 to n - 1 do
           if !debug then
	     Log.f (sprintf "Setting col %d to width %d" i cellw);
	   Grid.column_configure table.master_widget i [Minsize (Pixels cellw)]
	  done;
	  table.widths <- Array.create n cellw;
	  (* Recompute all widgets *)
	  recompute_all table
	else () (* wait until last chance *)
    | l -> 
      (* Compute width array, (only happens the first time we open a row) *)
      let fixed = ref 0    (* columns given with fixed width in pixels *)
      and unspec = ref 0 in (* other columns *)
	List.iter (function
		     Some w -> fixed := w + !fixed
		   | None -> incr unspec)
	      l;
	let defaultw = if !unspec = 0 then 0 (* will not be used *) 
      	 else (* share remaining spec among cols *)
	    (table.width - !fixed) / !unspec
	in
	let colwidths = 
	  List.map (function Some w -> w | None -> defaultw) l in
	(* reverse because COLs constructed in reverse order...*)
	table.widths <- Array.of_list (List.rev colwidths);
        (* Set up the columns sizes *)
	for i = 0 to Array.length table.widths - 1 do
           if !debug then
	     Log.f (sprintf "Setting col %d to width %d" i table.widths.(i));
	  Grid.column_configure table.master_widget i
             [Minsize (Pixels table.widths.(i))] 
	done

  else  (* widths have been set*)
   if last_chance then (* we are closing the table *)
     recompute_all table
   else ()


(* 
 * Slots represent, by column, the number of "pending" row-spanning cells 
 * If this number is zero, the slot is empty. When we allocate slots for
 * col-spanning cells, we keep these slots contiguous (case of overlapping
 * cells)
 *)

let get_slot table needed_cols rspan =
  (* First free slot in cur_col *)
  let rec first_free n =
    if n < Array.length table.slots then
      if table.slots.(n) = 0 then n
      else first_free (n+1)
    else raise Not_found in
  try 
    let first = first_free table.cur_col in
    (* Grow if overflow  (the next free would be first + needed_cols) *)
    if first + needed_cols > Array.length table.slots then
      table.slots <- 
         Array.append table.slots 
           (Array.create (first + needed_cols - (Array.length table.slots)) 
                         rspan);
    (* Mark used *)
    for i = first to first + needed_cols - 1 do
      table.slots.(i) <- max rspan table.slots.(i)
    done;
    table.cur_col <- first + needed_cols;
    first
  with
    Not_found -> (* Grow *)
      let first = Array.length table.slots in
      table.slots <- Array.append table.slots (Array.create needed_cols rspan);
      table.cur_col <- Array.length table.slots;
      first
      

let next_row table =
  for i = 0 to Array.length table.slots - 1 do
    table.slots.(i) <- 
      	match table.slots.(i) with
	  0|1 -> 0
	| n -> n-1
  done

let create top tag =
 let width = 
   try int_of_string (get_attribute tag "width")
   with _ -> Winfo.reqwidth (Winfo.parent top) - 20 in
 if !debug then Log.f (sprintf "Table width: %d" width);
 let tab = {
    master_widget = top;
    slaves = [];
    width = width;
    cur_col = 0;
    cur_row = -1; (* Start with TR *)
    widths = [||];
    slots = [||];
    cols = []} in
   {close_table = (fun () -> 
        packem tab;
	compute_col tab true); (* definitely compute widths *)

    add_col =  (fun tag -> 
      let span = 
       try int_of_string (get_attribute tag "span")
       with _ -> 1 in
      let width = 
       (* Specification of the columns width (only pixel size supported) *)
       try Some (int_of_string (get_attribute tag "width"))
       with _ -> None
      in 
      for i = 1 to span do
	tab.cols <- width :: tab.cols 
      done);

    open_row = (fun _ ->
	tab.cur_col <- 0;
	tab.cur_row <- 1 + tab.cur_row;
        next_row tab);

    new_cell = (fun ctype attrs rspan cspan ->
      (* SPECIAL FIX FOR THE PEOPLE WHO DON'T RESPECT THE DTD *)
      if tab.cur_row < 0 then tab.cur_row <- 0;

      let opts = match ctype with
	 HeaderCell -> [BorderWidth (Pixels 2); Relief Groove]
       | DataCell -> [BorderWidth (Pixels 1); Relief Sunken]
      in
      (* find its place *)
      let real_col = get_slot tab cspan rspan in
      let cell = Frame.create tab.master_widget ((Height (Pixels 10))::opts) in
       if !debug then
          Log.f (sprintf "Cell at row=%d col=%d rspan=%d cspan=%d\n"
	                 tab.cur_row real_col rspan cspan);
       (* We delay the gridding until we have all cells *)
       tab.slaves <- 
          (cell, (tab.cur_row, real_col, rspan, cspan)) :: tab.slaves;
       cell)}
