Source file font.ml

open Misc
open Tsdl_ttf

let default_font_size = ref 12

type font_metrics =
  {
    font_height : int ;
    font_ascent : int ;
    font_descent : int ;
    font_line_skip : int ;
    font_is_fixed_width : int ;
  }

let font_metrics f =
  { font_height = Ttf.font_height f ;
    font_ascent = Ttf.font_ascent f ;
    font_descent = Ttf.font_descent f ;
    font_line_skip = Ttf.font_line_skip f ;
    font_is_fixed_width = Ttf.font_face_is_fixed_width f ;
  }

type font_desc =
    {
      size : int [@ocf Ocf.Wrapper.int, 12] ;
      italic : bool [@ocf Ocf.Wrapper.bool, false] ;
      bold : bool [@ocf Ocf.Wrapper.bool, false] ;
      family : string [@ocf Ocf.Wrapper.string, "Liberation Sans"] ;
      underline : bool [@ocf Ocf.Wrapper.bool, false] ;
      strikethrough : bool [@ocf Ocf.Wrapper.bool, false] ;
      kerning : bool [@ocf Ocf.Wrapper.bool, true] ;
      outline : int [@ocf Ocf.Wrapper.int, 0] ;
    } [@@ocf]

let font_desc_compare : font_desc -> font_desc -> int = Stdlib.compare

let font_desc ?(size= !default_font_size)
  ?(italic=false) ?(bold=false)
    ?(underline=false)
    ?(strikethrough=false) ?(kerning=true) ?(outline=0)
    family =
    { family ; size ; italic ; bold ;
      underline ; strikethrough ; kerning ; outline ;
    }

let string_of_font_desc f =
  Yojson.Safe.to_string (font_desc_wrapper.to_json f)

let pp_font_desc ppf d = Format.fprintf ppf "%s" (string_of_font_desc d)

module IntervalMap = Map.Make
  (struct type t = int * int let compare = Stdlib.compare end)


let fallback_fonts = ref (IntervalMap.empty : string IntervalMap.t)
let fallback_font char_code =
  match IntervalMap.find_first_opt
    (fun (low,hi) -> low <= char_code && char_code <= hi)
    !fallback_fonts
  with
  | None -> None
  | Some (_,family) -> Some family

let add_fallback_font low hi family =
  fallback_fonts := IntervalMap.add (low, hi) family !fallback_fonts

module IBBMap = Map.Make
  (struct type t = int * bool * bool let compare = Stdlib.compare end)

module AttsMap = Map.Make
  (struct type t = bool * bool * bool * int let compare = Stdlib.compare end)
let atts_of_desc d = (d.underline, d.strikethrough, d.kerning, d.outline)

let font_exts = ref [".ttf"]
let font_dirs = ref
  [ Filename.current_dir_name, false ;
    "/usr/share/fonts/truetype", true ;
  ]

let fonts = ref SMap.empty

let add_font ?(close=false) size file fn =
  let family = Ttf.font_face_family_name fn in
  let style = Ttf.font_face_style_name fn in
  let st = Ttf.get_font_style fn in
  let sibmap =
    match SMap.find_opt family !fonts with
    | None -> IBBMap.empty
    | Some m -> m
  in
  let desc =
    let open Ttf.Style in
    { family ; size ;
      italic = test st italic ;
      bold = test st bold ;
      underline = test st underline ;
      strikethrough = test st strikethrough ;
      kerning = Ttf.get_font_kerning fn ;
      outline = Ttf.get_font_outline fn ;
    }
  in
  match
    let sib = (desc.size, desc.italic, desc.bold) in
    let atts = atts_of_desc desc in
    match IBBMap.find_opt sib sibmap with
    | None ->
        let fn =
          if close
          then (Ttf.close_font fn ; None)
          else Some fn
        in
        let amap = AttsMap.singleton atts (file, ref fn) in
        Some (IBBMap.add sib amap sibmap)
    | Some amap ->
        match AttsMap.find_opt atts amap with
        | None ->
            let fn =
              if close
              then (Ttf.close_font fn ; None)
              else Some fn
            in
            let amap = AttsMap.add atts (file, ref fn) amap in
            Some (IBBMap.add sib amap sibmap)
        | Some _ ->
            None
  with
  | None ->
      Log.debug (fun m -> m
         "Ignoring file %s with font %s %s already added"
           file family style)
  | Some sibmap ->
      Log.info (fun m -> m "Adding font %s %S [size=%d]" family style size);
      fonts := SMap.add family sibmap !fonts

let add_atts desc file_fn =
  let sib = (desc.size, desc.italic, desc.bold) in
  let atts = atts_of_desc desc in
  match SMap.find_opt desc.family !fonts with
  | None ->
      (* we do this only if this font desc is already in font *)
      assert false
  | Some sibmap ->
      match IBBMap.find_opt sib sibmap with
      | None -> assert false
      | Some amap ->
          let amap = AttsMap.add atts file_fn amap in
          let sibmap = IBBMap.add sib amap sibmap in
          fonts := SMap.add desc.family sibmap !fonts

let load_font ?close size file =
  try
    Log.debug (fun m -> m "opening font file %S" file);
    let> fn = Ttf.open_font file size in
    add_font ?close size file fn;
    true
  with e ->
      Log.err (fun m -> m "%s" (Printexc.to_string e));
      false

let may_load_font size file =
  if List.mem (Filename.extension file) !font_exts then
    ignore(load_font ~close:true size file)
  else
    ()

let load_fonts_from_dir =
  let mutex = Lwt_mutex.create () in
  let rec iter size recur dir =
    Log.debug (fun m -> m "Loading fonts from directory %s" dir);
    let stream = Lwt_unix.files_of_directory dir in
    let%lwt l = Lwt_stream.to_list stream in
    Lwt_list.iter_p
      (fun e ->
         if e = Filename.parent_dir_name ||
           e = Filename.current_dir_name
         then
           Lwt.return_unit
         else
           (
            let e = Filename.concat dir e in
            match%lwt Lwt_unix.stat e with
            | exception _ -> Lwt.return_unit
            | { Unix.st_kind = S_REG } ->
                Lwt_mutex.with_lock mutex
                  (fun () -> Lwt.return(may_load_font size e))
            | { st_kind = S_DIR } ->
                if recur then
                  iter size recur e
                else
                  Lwt.return_unit
            | _ -> Lwt.return_unit
           )
      )
      l
  in
  iter

let load_fonts ?(size= !default_font_size) ?(dirs= !font_dirs) () =
  Lwt_list.iter_p
    (fun (dir, recur) -> load_fonts_from_dir size recur dir)
    dirs

let string_of_font_desc d =
  Printf.sprintf "%S italic=%b, bold=%b [size=%d]" d.family d.italic d.bold d.size

let font_not_found desc =
  Misc.font_not_found (string_of_font_desc desc)

exception Found of (IBBMap.key * (string * Ttf.font option ref) AttsMap.t)
let find_first_desc p fdmap =
  try
    IBBMap.iter
      (fun a map ->
         if p a then
           raise (Found (a, map))
         else
           ()
      )
      fdmap ;
    None
  with Found (a,map) -> Some (a,map)

let close_fonts () =
  Log.info (fun m -> m "closing fonts");
  SMap.iter
    (fun _ sibmap ->
       IBBMap.iter
         (fun _ attsmap ->
            AttsMap.iter
              (fun _ (_file, ref_fn) ->
                match !ref_fn with
                | None -> ()
                | Some fn -> Ttf.close_font fn; ref_fn := None)
                attsmap
         )
         sibmap
    )
    !fonts

let too_many_open_fonts f =
  Log.err (fun m -> m "Could not load font. Too many open files ?");
  f ()

let rec get ?(may_close_fonts=false) desc =
  Log.debug (fun m -> m "Font.get %s" (string_of_font_desc desc));
  let sibmap =
    match SMap.find_opt desc.family !fonts with
    | Some m -> m
    | None ->
        let fallback_family = "Liberation Sans" in
        Log.warn (fun m -> m "Font %S not found, trying with %S"
           desc.family fallback_family);
        match SMap.find_opt fallback_family !fonts with
        | None -> font_not_found desc
        | Some m -> m
  in
  let sib = (desc.size, desc.italic, desc.bold) in
  match IBBMap.find_opt sib sibmap with
  | None ->
      (
       (* lookup for another size *)
       match find_first_desc
         (fun (_,i,b) -> i = desc.italic && b = desc.bold) sibmap
       with
       | None ->
           (* FIXME: return another flavour of this font rather
              than failing *)
           Log.err (fun m -> m "BLEAH !");
           font_not_found desc
       | Some ((s,i,b), m) ->
           match AttsMap.min_binding_opt m with
           | None -> assert false (* we should at least have one *)
           | Some (_, (file, _fn)) ->
               if load_font desc.size file then
                 get ~may_close_fonts desc
               else
                 if may_close_fonts then
                   (close_fonts () ; get desc)
                 else
                   too_many_open_fonts (fun () -> font_not_found desc)
      )
  | Some amap ->
      let atts = atts_of_desc desc in
      match AttsMap.find_opt atts amap with
      | Some (file, ref_fn) ->
          (
           match !ref_fn with
           | Some fn -> fn
           | None ->
               try
                  let> fn = Ttf.open_font file desc.size in
                  ref_fn := Some fn;
                  fn
               with
               | e ->
                   if may_close_fonts then
                     (close_fonts () ; get desc)
                   else
                      too_many_open_fonts (fun () -> raise e)
          )
      | None ->
          match AttsMap.min_binding_opt amap with
          | None -> assert false (* we should at least have one *)
          | Some (_, (file, _fn)) ->
              let fn =
                try let> fn = Ttf.open_font file desc.size in fn
                with e ->
                    if may_close_fonts then
                      (
                       close_fonts () ;
                       try let> fn = Ttf.open_font file desc.size in fn
                       with e ->
                           too_many_open_fonts (fun () -> raise e)
                      )
                    else
                      too_many_open_fonts (fun () -> raise e)
              in
              Ttf.set_font_kerning fn desc.kerning ;
              Ttf.set_font_outline fn desc.outline ;
              let st = Ttf.get_font_style fn in
              let st =
                (if desc.underline then
                   Ttf.Style.(+)
                 else
                   Ttf.Style.(-)
                ) st Ttf.Style.underline
              in
              let st =
                (if desc.strikethrough then
                   Ttf.Style.(+)
                 else
                   Ttf.Style.(-)
                ) st Ttf.Style.strikethrough
              in
              Ttf.set_font_style fn st ;
              add_atts desc (file, ref (Some fn)) ;
              fn

let get = get ~may_close_fonts:true

let fonts () =
  let f_atts family (size,italic,bold)
    (underline,strikethrough,kerning,outline) _ acc =
      { family ; size ; italic ; bold ;
        underline ; strikethrough ; kerning ; outline } :: acc
  in
  let f_ibb family sib amap acc =
    AttsMap.fold (f_atts family sib) amap acc
  in
  SMap.fold
    (fun f sibmap acc -> IBBMap.fold (f_ibb f) sibmap acc)
    !fonts []