open Tk

(* Font manipulation *)

(* We share tags for fonts, but this requires combinations of all
 * possible styles (weight, slant and size). The tag attribute is computed 
 * on demand. Each widget must do its "tag configure" separately.
 *)

type fontDesc =
  { mutable family : string;
    mutable weight : string;
    mutable slant : string;
    mutable pxlsz : int }

type fontInfo =
   Family of string
 | Weight of string
 | Slant of string
 | FontIndex of int
 | FontDelta of int

let copy fd =
  {family = fd.family;
   weight = fd.weight;
   slant = fd.slant;
   pxlsz = fd.pxlsz}

(* HTML3.2 specifies that absolute font size are ranging from 1 to 7, 
   the default basefont, used for "normal" text, being 3.

   We map these sizes to X Font Pxlsz, keeping some latitude for
   mapping the base. The lowest reasonable font is 8
 *)

let sizes = [| 8; 10; 12; 15; 18; 20; 24; 26; 28 |]

(* Given a pxlsz for base, find out the base offset,
   which is the max of defined sized lower than argument
 *)
let get_index size =
  try
    let rec walk n =
      if sizes.(n) > size then n-1
      else walk (succ n)
    in 
    let idx = walk 0 in if idx < 0 then 0 else idx
  with
    _ -> Array.length sizes - 1 (* base is too large, just discard *)

let base_index = ref (get_index 15)

(* Convert an absolute font to a pxlsz *)
let pxlsz absfont =
  let font_idx = absfont + (!base_index - 3) in
  let safe_idx = 
    if font_idx < 0 then 0
    else if font_idx >= Array.length sizes then Array.length sizes - 1
    else font_idx in
   sizes.(safe_idx)

(* Convert a pxlsz to an absolute font *)
let font_index pxlsz =
  (get_index pxlsz) - !base_index + 3

(* Merge font attributes in a fontDesc *)
let merge fd fil =
  let newfd = copy fd in
  List.iter (function
      Family s -> newfd.family <- s
    | Weight s -> newfd.weight <- s
    | Slant s -> newfd.slant <- s
    | FontIndex i -> newfd.pxlsz <- i
    | FontDelta n -> newfd.pxlsz <- newfd.pxlsz + n
    )
    fil;
  newfd

(* This table is shared by all widgets *)
let tags = Hashtbl.create 37

let default = ref 
    {family = "";
     weight = "";
     slant = "";
     pxlsz = 3}

(* For a given fontDesc, return the name of the tags and its attributes *)
let rec compute_tag fd =
  try
    Hashtbl.find tags fd 
  with
    Not_found ->
     try
      let pxlsz = pxlsz fd.pxlsz in
      let f = Frx_font.find fd.family fd.weight fd.slant pxlsz in
      let tagdesc = 
      	(fd.family^fd.weight^fd.slant^(string_of_int pxlsz), [Font f]) in
      	Hashtbl.add tags fd tagdesc;
	tagdesc
     with Invalid_argument f ->  (* font is not available *)
       (* Misc.warning (I18n.sprintf "Font %s is not available" f); *)
       if fd = !default then (* ARGH *)
       	 let tagdesc = ("fixedfont", [Font "fixed"]) in
	   Hashtbl.add tags fd tagdesc;
	   tagdesc
       else begin
      	let tagdesc = compute_tag !default in
	   Hashtbl.add tags fd tagdesc;
	   tagdesc
       end
