l4/pkg/ocaml/contrib/otherlibs/labltk/jpf/jpf_font.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16 (* find font information *)
  17
  18 let debug = ref false
  19 let log s =
  20   if !debug then try prerr_endline s with _ -> ()
  21
  22 type ('s, 'i) xlfd = {
  23     (* some of them are currently not interesting for me *)
  24     mutable foundry: 's;
  25     mutable family: 's;
  26     mutable weight: 's;
  27     mutable slant: 's;
  28     mutable setWidth: 's;
  29     mutable addStyle: 's;
  30     mutable pixelSize: 'i;
  31     mutable pointSize: 'i;
  32     mutable resolutionX: 'i;
  33     mutable resolutionY: 'i;
  34     mutable spacing: 's;
  35     mutable averageWidth: 'i;
  36     mutable registry: 's;
  37     mutable encoding: 's
  38   }
  39
  40 let copy xlfd = {xlfd with foundry= xlfd.foundry}
  41
  42 let string_of_xlfd s i xlfd =
  43   let foundry= s xlfd.foundry
  44   and family= s xlfd.family
  45   and weight= s xlfd.weight
  46   and slant= s xlfd.slant
  47   and setWidth = s xlfd.setWidth
  48   and addStyle = s xlfd.addStyle
  49   and pixelSize= i xlfd.pixelSize
  50   and pointSize = i xlfd.pointSize
  51   and resolutionX = i xlfd.resolutionX
  52   and resolutionY = i xlfd.resolutionY
  53   and spacing= s xlfd.spacing
  54   and averageWidth = i xlfd.averageWidth
  55   and registry= s xlfd.registry
  56   and encoding = s xlfd.encoding in
  57
  58   "-"^foundry^
  59   "-"^family^
  60   "-"^weight^
  61   "-"^slant^
  62   "-"^setWidth ^
  63   "-"^addStyle ^
  64   "-"^pixelSize^
  65   "-"^pointSize ^
  66   "-"^resolutionX ^
  67   "-"^resolutionY ^
  68   "-"^spacing^
  69   "-"^averageWidth ^
  70   "-"^registry^
  71   "-"^encoding
  72
  73 exception Parse_Xlfd_Failure of string
  74
  75 let parse_xlfd xlfd_string =
  76   (* this must not be a pattern *)
  77   let split_str char_sep str =
  78     let len = String.length str in
  79     let rec split beg cur =
  80       if cur >= len then [String.sub str beg (len - beg)]
  81       else if char_sep (String.get str cur)
  82       then
  83         let nextw = succ cur in
  84         (String.sub str beg (cur - beg))
  85         ::(split nextw nextw)
  86       else split beg (succ cur) in
  87     split 0 0
  88   in
  89    match split_str (function '-' -> true | _ -> false) xlfd_string with
  90    | [ _; foundry; family; weight; slant; setWidth; addStyle; pixelSize;
  91        pointSize; resolutionX; resolutionY; spacing; averageWidth;
  92        registry; encoding ] ->
  93        { foundry= foundry;
  94          family= family;
  95          weight= weight;
  96          slant= slant;
  97          setWidth= setWidth;
  98          addStyle= addStyle;
  99          pixelSize= int_of_string pixelSize;
 100          pointSize= int_of_string pointSize;
 101          resolutionX= int_of_string resolutionX;
 102          resolutionY= int_of_string resolutionY;
 103          spacing= spacing;
 104          averageWidth= int_of_string averageWidth;
 105          registry= registry;
 106          encoding= encoding;
 107        }
 108    | _ -> raise (Parse_Xlfd_Failure xlfd_string)
 109
 110 type valid_xlfd = (string, int) xlfd
 111
 112 let string_of_valid_xlfd = string_of_xlfd (fun x -> x) string_of_int
 113
 114 type pattern = (string option, int option) xlfd
 115
 116 let empty_pattern =
 117   { foundry= None;
 118     family= None;
 119     weight= None;
 120     slant= None;
 121     setWidth= None;
 122     addStyle= None;
 123     pixelSize= None;
 124     pointSize= None;
 125     resolutionX= None;
 126     resolutionY= None;
 127     spacing= None;
 128     averageWidth= None;
 129     registry= None;
 130     encoding= None;
 131   }
 132
 133 let string_of_pattern =
 134   let pat f = function
 135       Some x -> f x
 136     | None -> "*"
 137   in
 138   let pat_string = pat (fun x -> x) in
 139   let pat_int = pat string_of_int in
 140   string_of_xlfd pat_string pat_int
 141
 142 let is_vector_font xlfd =
 143   (xlfd.pixelSize = 0 && xlfd.resolutionX = 0 && xlfd.resolutionY = 0) ||
 144   xlfd.spacing <> "c"
 145
 146 let list_fonts dispname pattern =
 147   let dispopt = match dispname with
 148     None -> ""
 149   | Some x -> "-display " ^ x
 150   in
 151   let result = List.map parse_xlfd
 152       (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern))
 153   in
 154   if result = [] then raise Not_found
 155   else result
 156
 157 let available_pixel_size_aux dispname pattern =
 158   (* return available pixel size without font resizing *)
 159   (* to obtain good result, *)
 160   (* the pattern should contain as many information as possible *)
 161   let pattern = copy pattern in
 162   pattern.pixelSize <- None;
 163   let xlfds = list_fonts dispname pattern in
 164   let pxszs = Hashtbl.create 107 in
 165   List.iter (fun xlfd ->
 166     Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds;
 167   pxszs
 168
 169 let extract_size_font_hash tbl =
 170   let keys = ref [] in
 171   Hashtbl.iter (fun k _ ->
 172     if not (List.mem k !keys) then keys := k :: !keys) tbl;
 173   Sort.list (fun (k1,_) (k2,_) -> k1 < k2)
 174     (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys)
 175
 176 let available_pixel_size dispname pattern =
 177   let pxszs = available_pixel_size_aux dispname pattern in
 178   extract_size_font_hash pxszs
 179
 180 let nearest_pixel_size dispname vector_ok pattern =
 181   (* find the font with the nearest pixel size *)
 182   log ("\n*** "^string_of_pattern pattern);
 183   let pxlsz =
 184     match pattern.pixelSize with
 185       None -> raise (Failure "invalid pixelSize pattern")
 186     | Some x -> x
 187   in
 188   let tbl = available_pixel_size_aux dispname pattern in
 189   let newtbl = Hashtbl.create 107 in
 190   Hashtbl.iter (fun s xlfd ->
 191     if vector_ok then
 192       if s = 0 then begin
 193         if is_vector_font xlfd then begin
 194           log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd));
 195           xlfd.pixelSize <- pxlsz;
 196           Hashtbl.add newtbl pxlsz xlfd
 197         end
 198       end else Hashtbl.add newtbl s xlfd
 199     else if not (is_vector_font xlfd) && s <> 0 then
 200       Hashtbl.add newtbl s xlfd) tbl;
 201
 202   let size_font_table = extract_size_font_hash newtbl in
 203
 204   let diff = ref 10000 in
 205   let min = ref None in
 206   List.iter (fun (s,xlfds) ->
 207     let d = abs(s - pxlsz) in
 208     if d < !diff then begin
 209       min := Some (s,xlfds);
 210       diff := d
 211     end) size_font_table;
 212   (* if it contains more than one font, just return the first *)
 213   match !min with
 214   | None -> raise Not_found
 215   | Some(s, xlfds) ->
 216      log (Printf.sprintf "Size %d is selected" s);
 217      List.iter (fun xlfd -> log (string_of_valid_xlfd xlfd)) xlfds;
 218      List.hd xlfds