(* Utilities for tags and attributes *)
open Printf
open Protocol
open Tk
open Frx_text
open Fonts
open Htmlfmt

(* Delayed and shared configuration of tags *)

module TagSet = Set.Make(struct type t = string let compare = compare end)
class tags (thtml) =
  val mutable onhold = []
  val mutable configured = TagSet.empty
  val mutable decorations = []
  val wid = thtml

  (* define a new tag *)
  method define tagname attrs =
    if TagSet.mem tagname configured then ()
    else begin
      onhold <- (tagname,attrs) :: onhold;
      configured <- TagSet.add tagname configured
    end

  method add deco =
    decorations <- deco :: decorations

  (* flush tag definitions *)
  method flush =
    List.iter (fun (t,d) -> 
	try Text.tag_configure wid t d with TkError _ -> ()) onhold;
    List.iter (fun (t,d,e) -> Text.tag_add wid t d e) decorations;
    onhold <- [];
    decorations <- []
end

(* Conversion of moral attributes to Tk attributes.
 * This virtual class has to be instantiated for each converter.
 * 'a is an logical attribute description (or "delta")
 *)
class virtual 'a nested (tagdef) as self =
  val mutable last_change = 0
  val mutable stack = []
  val tagdef = tagdef

  virtual push_convert : 'a -> string * Tk.options list
  virtual pop_convert : 'a -> unit

  method put current_pos tagname =
   if last_change <> current_pos then begin
     let st = abs_index last_change
     and en = abs_index current_pos in
	tagdef#add (tagname, st, en);
        last_change <- current_pos
   end

  (* Push some new attribute. *)
  method push current_pos desc =
    let tag, attr = self#push_convert desc in
    tagdef#define tag attr;
    begin match stack with
       [] -> 
        (* no current definition, don't issue a put *)
        last_change <- current_pos
     | curtag::l ->
        self#put current_pos curtag
    end;
    stack <- tag :: stack;

(* Doesn't check the nature of desc *)
  method pop current_pos (desc : 'a) =
     self#pop_convert desc;
     match stack with
       [] ->
        last_change <- current_pos
     | c::l ->
	stack <- l;
        self#put current_pos c
end

(* 
 * Alignment attribute is left/right/center
 *)
class align (tagdef) =
  inherit (string) nested tagdef
  method push_convert ad =
    match Mstring.lowercase ad with
	 "right" -> "right", [Justify Justify_Right]
       | "center" -> "center", [Justify Justify_Center]
       | _ -> "left", [Justify Justify_Left]
  method pop_convert ad = ()
end

(*
 * Margin attribute is cumulative
 *)
class margin (tagdef) =
  inherit (int) nested tagdef
  val mutable current = 0
  method push_convert ad =
    current <- current + ad;
    sprintf "margin%d" current, 
    [LMargin1 (Pixels current); LMargin2 (Pixels current)]
  method pop_convert ad =
    current <- current - ad
end


(*
 * Font attributes
 *)

class font (tagdef) =
  inherit (fontInfo list) nested tagdef
  val mutable font_stack = []
  method push_convert fil = 
    let curfd = match font_stack with
      [] -> !Fonts.default
    | x::l -> x in
    let newfd = Fonts.merge curfd fil in
      font_stack <- newfd :: font_stack;
      Fonts.compute_tag newfd

  method pop_convert _ = 
    match font_stack with
      [] -> ()
    | x::l -> font_stack <- l

end


(* Special mapping of pre-defined HTML3.2 colors *)
let color_mappings = Hashtbl.create 37
let _ = List.iter (fun (name, value) -> Hashtbl.add color_mappings name value)
  [ "black",   "#000000";
    "silver",  "#c0c0c0";
    "gray",    "#808080";
    "white",   "#ffffff";
    "maroon",  "#800000";
    "red",     "#ff0000";
    "purple",  "#800080";
    "fuchsia", "#ff00ff";
    "green",   "#008000";
    "lime",    "#00ff00";
    "olive",   "#808000";
    "yellow",  "#ffff00";
    "navy",    "#000080";
    "blue",    "#0000ff";
    "teal",    "#008080";
    "aqua",    "#00ffff" ]

let html_color s =
  try Hashtbl.find color_mappings (Mstring.lowercase s)
  with Not_found -> s

(*
 * Foreground color
 *)

class fgcolor (tagdef) =
  inherit (string) nested tagdef 
  method push_convert s =
    let colordef = html_color s in
    if Frx_color.check colordef then
      s, [Foreground (NamedColor colordef)]
    else
      s, []
  method pop_convert s = 
    ()
end

(*
 * Background color
 *)

class bgcolor (tagdef) =
  inherit (string) nested tagdef 
  method push_convert s =
    let colordef = html_color s in
    if Frx_color.check colordef then
      s, [Background (NamedColor colordef)]
    else 
      s, []
  method pop_convert s = 
    ()
end

(*
 * Super and sub script.
 * BOGUS: should depend on current font size
 *)
class offset (tagdef) =
  inherit (int) nested tagdef
  val mutable cur_offset = 0
  method push_convert n =
    cur_offset <- cur_offset + n;
    sprintf "offset%d" cur_offset, [Offset (Pixels cur_offset)]
  method pop_convert n =
    cur_offset <- cur_offset - n
end
(* 
 * Other stuff where nesting is not important
 *)
class misc (tagdef, tagname, attr) as self =
  
  val mutable start_pos = 0  
  val tagdef = tagdef
  val tagname = 
    let _ = tagdef#define tagname  attr in
     tagname

  method pop current_pos =
   if start_pos <> current_pos then begin
     let st = abs_index start_pos
     and en = abs_index current_pos in
	tagdef#add (tagname, st, en)
   end

  method push current_pos  =
     start_pos <- current_pos

end

(* 
 * Spacing is specific, due to Tk's line model and BR
 *  push corresponds to top spacing for the first line
 *  pop corresponds to bottom spacing for the first line
 *)

class spacing (tagdef) =
  val tagdef = tagdef
 
  method push current_pos n =
    let topname = sprintf "topspace%d" n in
     tagdef#define topname [Spacing1 (Pixels n)];
     tagdef#add (topname,
		 TextIndex(LineChar(0,0), [CharOffset current_pos; LineStart]),
		 TextIndex(LineChar(0,0), [CharOffset current_pos; LineEnd]));
     ()

  method pop current_pos n =
    let botname = sprintf "botspace%d" n in
    tagdef#define botname [Spacing3 (Pixels n)];
    tagdef#add (botname,
		TextIndex(LineChar(0,0), [CharOffset current_pos; LineStart]),
		TextIndex(LineChar(0,0), [CharOffset current_pos; LineEnd]));
    ()
end

(* Bullet images *)
let circle_data = 
"#define circle_width 9
#define circle_height 9
static unsigned char circle_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x38, 0x00, 0x44, 0x00, 0x44, 0x00, 0x44, 0x00,
   0x38, 0x00, 0x00, 0x00, 0x00, 0x00};"

let disc_data =
"#define disc_width 9
#define disc_height 9
static unsigned char disc_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x38, 0x00, 0x7c, 0x00, 0x7c, 0x00, 0x7c, 0x00,
   0x38, 0x00, 0x00, 0x00, 0x00, 0x00};"

let square_data = 
"#define square_width 9
#define square_height 9
static unsigned char square_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x7c, 0x00, 0x7c, 0x00, 0x7c, 0x00, 0x7c, 0x00,
   0x7c, 0x00, 0x00, 0x00, 0x00, 0x00};"

let bullet_table = Hashtbl.create 11
let init bg =
  let bg = Background (NamedColor bg) in
  Hashtbl.add bullet_table
     "circle" (ImageBitmap(Imagebitmap.create [Data circle_data; bg]));
  Hashtbl.add bullet_table
     "disc" (ImageBitmap(Imagebitmap.create [Data disc_data; bg]));
  Hashtbl.add bullet_table
     "square" (ImageBitmap(Imagebitmap.create [Data square_data; bg]))
