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

(*                                                                     *)

(*                 MLTk, Tcl/Tk interface of OCaml                     *)

(*                                                                     *)

(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)

(*               projet Cristal, INRIA Rocquencourt                    *)

(*            Jacques Garrigue, Kyoto University RIMS                  *)

(*                                                                     *)

(*  Copyright 2002 Institut National de Recherche en Informatique et   *)

(*  en Automatique and Kyoto University.  All rights reserved.         *)

(*  This file is distributed under the terms of the GNU Library        *)

(*  General Public License, with the special exception on linking      *)

(*  described in file LICENSE found in the OCaml source tree.          *)

(*                                                                     *)

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

(* find font information *)

let debug = ref false

let log s =

  if !debug then try prerr_endline s with _ -> ()

type ('s, 'i) xlfd = {

    (* some of them are currently not interesting for me *)

    mutable foundry: 's;

    mutable family: 's;

    mutable weight: 's;

    mutable slant: 's;

    mutable setWidth: 's;

    mutable addStyle: 's;

    mutable pixelSize: 'i;

    mutable pointSize: 'i;

    mutable resolutionX: 'i;

    mutable resolutionY: 'i;

    mutable spacing: 's;

    mutable averageWidth: 'i;

    mutable registry: 's;

    mutable encoding: 's

  }

let copy xlfd = {xlfd with foundry= xlfd.foundry}

let string_of_xlfd s i xlfd =

  let foundry= s xlfd.foundry

  and family= s xlfd.family

  and weight= s xlfd.weight

  and slant= s xlfd.slant

  and setWidth = s xlfd.setWidth

  and addStyle = s xlfd.addStyle

  and pixelSize= i xlfd.pixelSize

  and pointSize = i xlfd.pointSize

  and resolutionX = i xlfd.resolutionX

  and resolutionY = i xlfd.resolutionY

  and spacing= s xlfd.spacing

  and averageWidth = i xlfd.averageWidth

  and registry= s xlfd.registry

  and encoding = s xlfd.encoding in

  "-"^foundry^

  "-"^family^

  "-"^weight^

  "-"^slant^

  "-"^setWidth ^

  "-"^addStyle ^

  "-"^pixelSize^

  "-"^pointSize ^

  "-"^resolutionX ^

  "-"^resolutionY ^

  "-"^spacing^

  "-"^averageWidth ^

  "-"^registry^

  "-"^encoding

exception Parse_Xlfd_Failure of string

let parse_xlfd xlfd_string =

  (* this must not be a pattern *)

  let split_str char_sep str =

    let len = String.length str in

    let rec split beg cur =

      if cur >= len then [String.sub str beg (len - beg)]

      else if char_sep (String.get str cur)

      then

        let nextw = succ cur in

        (String.sub str beg (cur - beg))

        ::(split nextw nextw)

      else split beg (succ cur) in

    split 0 0

  in

   match split_str (function '-' -> true | _ -> false) xlfd_string with

   | [ _; foundry; family; weight; slant; setWidth; addStyle; pixelSize;

       pointSize; resolutionX; resolutionY; spacing; averageWidth;

       registry; encoding ] ->

       { foundry= foundry;

         family= family;

         weight= weight;

         slant= slant;

         setWidth= setWidth;

         addStyle= addStyle;

         pixelSize= int_of_string pixelSize;

         pointSize= int_of_string pointSize;

         resolutionX= int_of_string resolutionX;

         resolutionY= int_of_string resolutionY;

         spacing= spacing;

         averageWidth= int_of_string averageWidth;

         registry= registry;

         encoding= encoding;

       }

   | _ -> raise (Parse_Xlfd_Failure xlfd_string)

type valid_xlfd = (string, int) xlfd

let string_of_valid_xlfd = string_of_xlfd (fun x -> x) string_of_int

type pattern = (string option, int option) xlfd

let empty_pattern =

  { foundry= None;

    family= None;

    weight= None;

    slant= None;

    setWidth= None;

    addStyle= None;

    pixelSize= None;

    pointSize= None;

    resolutionX= None;

    resolutionY= None;

    spacing= None;

    averageWidth= None;

    registry= None;

    encoding= None;

  }

let string_of_pattern =

  let pat f = function

      Some x -> f x

    | None -> "*"

  in

  let pat_string = pat (fun x -> x) in

  let pat_int = pat string_of_int in

  string_of_xlfd pat_string pat_int

let is_vector_font xlfd =

  (xlfd.pixelSize = 0 && xlfd.resolutionX = 0 && xlfd.resolutionY = 0) ||

  xlfd.spacing <> "c"

let list_fonts dispname pattern =

  let dispopt = match dispname with

    None -> ""

  | Some x -> "-display " ^ x

  in

  let result = List.map parse_xlfd

      (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern))

  in

  if result = [] then raise Not_found

  else result

let available_pixel_size_aux dispname pattern =

  (* return available pixel size without font resizing *)

  (* to obtain good result, *)

  (* the pattern should contain as many information as possible *)

  let pattern = copy pattern in

  pattern.pixelSize <- None;

  let xlfds = list_fonts dispname pattern in

  let pxszs = Hashtbl.create 107 in

  List.iter (fun xlfd ->

    Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds;

  pxszs

let extract_size_font_hash tbl =

  let keys = ref [] in

  Hashtbl.iter (fun k _ ->

    if not (List.mem k !keys) then keys := k :: !keys) tbl;

  List.sort (fun (k1,_) (k2,_) -> compare k1 k2)

    (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys)

let available_pixel_size dispname pattern =

  let pxszs = available_pixel_size_aux dispname pattern in

  extract_size_font_hash pxszs

let nearest_pixel_size dispname vector_ok pattern =

  (* find the font with the nearest pixel size *)

  log ("\n*** "^string_of_pattern pattern);

  let pxlsz =

    match pattern.pixelSize with

      None -> raise (Failure "invalid pixelSize pattern")

    | Some x -> x

  in

  let tbl = available_pixel_size_aux dispname pattern in

  let newtbl = Hashtbl.create 107 in

  Hashtbl.iter (fun s xlfd ->

    if vector_ok then

      if s = 0 then begin

        if is_vector_font xlfd then begin

          log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd));

          xlfd.pixelSize <- pxlsz;

          Hashtbl.add newtbl pxlsz xlfd

        end

      end else Hashtbl.add newtbl s xlfd

    else if not (is_vector_font xlfd) && s <> 0 then

      Hashtbl.add newtbl s xlfd) tbl;

  let size_font_table = extract_size_font_hash newtbl in

  let diff = ref 10000 in

  let min = ref None in

  List.iter (fun (s,xlfds) ->

    let d = abs(s - pxlsz) in

    if d < !diff then begin

      min := Some (s,xlfds);

      diff := d

    end) size_font_table;

  (* if it contains more than one font, just return the first *)

  match !min with

  | None -> raise Not_found

  | Some(s, xlfds) ->

     log (Printf.sprintf "Size %d is selected" s);

     List.iter (fun xlfd -> log (string_of_valid_xlfd xlfd)) xlfds;

     List.hd xlfds