Source file font.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

open Misc
open Tsdl_ttf

[@@@warning "-69"]

type font_handle = {
    font : Ttf.font ;
    rw_ops : Tsdl.Sdl.rw_ops ;
    contents : string ;
  }

[@@@warning "+69"]

type font = int

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 ;
  }

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]


type font_entry = {
    mutable fe_used : bool;
    fe_desc : font_desc ;
    mutable fe_font : font_handle option ;
  }

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 home_dir = match Sys.getenv_opt "HOME" with
  | None | Some "" -> None
  | x -> x

let usr_local_fonts = match home_dir with
  | None -> None
  | Some d -> Some (Printf.sprintf "%s/.local/share/fonts" d)

let font_exts = ref [".ttf"]
let font_dirs = ref
  ((Filename.current_dir_name, false) ::
    (match usr_local_fonts with
     | None -> []
     | Some d -> [d, true]) @
    [
      "/usr/share/fonts", true ;
      "/usr/local/share/fonts", true ;
    ]
  )

let read_file file =
  try
    let ic = open_in_bin file in
    let len = in_channel_length ic in
    try
      let str = really_input_string ic len in
      close_in ic;
      Ok str
    with Sys_error msg -> Error (`Msg msg)
  with Sys_error msg -> Error (`Msg msg)

let open_font file size =
  match read_file file with
  | (Error (`Msg msg)) as e ->
      Log.err (fun m -> m "Font.open_font %s: %s" file msg);
      e
  | Ok str ->
      match Tsdl.Sdl.rw_from_const_mem str with
      | (Error (`Msg msg)) as e ->
          Log.err (fun m -> m "rw_from_const_mem %s: %s" file msg);
          e
      | Ok rw ->
          match Ttf.open_font_rw rw 0 size with
          | (Error (`Msg msg)) as e ->
              Log.err (fun m -> m "open_font_rw %s: %s" file msg);
              e
          | Ok font ->
              let f = { font ; rw_ops = rw ; contents = str } in
              Gc.finalise (fun f ->
                 Ttf.close_font f.font;
                 let> () = Tsdl.Sdl.rw_close f.rw_ops in
                 ()
              ) f;
              Ok f

let fonts = ref Smap.empty

let used_fonts = Dynarray.create ()

let mutex = Mutex.create ()

let add_font_entry desc font =
  let e = match font with
    | None -> { fe_used = false ; fe_desc = desc ; fe_font = None }
    | Some font -> { fe_used = true ; fe_desc = desc ; fe_font = Some font }
  in
  let i = Dynarray.length used_fonts in
  Dynarray.add_last used_fonts e ;
  i

let get_font_entry i = Dynarray.get used_fonts i


let add_font =
  let go ?(keep=false) size file font =
    let family = Ttf.font_face_family_name font.font in
    let style = Ttf.font_face_style_name font.font in
    let st = Ttf.get_font_style font.font 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 font.font ;
        outline = Ttf.get_font_outline font.font ;
      }
    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 font = if keep then Some font else None in
          let i = add_font_entry desc font in
          let amap = AttsMap.singleton atts (file, i) in
          Some (IBBMap.add sib amap sibmap)
      | Some amap ->
          match AttsMap.find_opt atts amap with
          | None ->
              let font = if keep then Some font else None in
              let i = add_font_entry desc font in
              let amap = AttsMap.add atts (file, i) amap in
              Some (IBBMap.add sib amap sibmap)
          | Some _ ->
              None
    with
    | None ->
        [%debug "Ignoring file %s with font %s %s already added"
           file family style];
        None
    | Some sibmap ->
        Log.info (fun m -> m "Adding font %s %S [size=%d]" family style size);
        fonts := Smap.add family sibmap !fonts;
        Some desc
  in
  fun ?keep size file fn ->
    Mutex.protect mutex (fun () -> go ?keep size file fn)

let add_atts =
  let go desc file_i =
    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 must call add_atts only if this font desc is already in fonts *)
        assert false
    | Some sibmap ->
        match IBBMap.find_opt sib sibmap with
        | None -> assert false
        | Some amap ->
            let amap = AttsMap.add atts file_i amap in
            let sibmap = IBBMap.add sib amap sibmap in
            fonts := Smap.add desc.family sibmap !fonts
  in
  fun desc file_fn ->
    Mutex.protect mutex (fun () -> go desc file_fn)

let load_font ?keep size file =
  try
    [%debug "opening font file %S [%d]" file size];
    let> font = open_font file size in
    add_font ?keep size file font;
  with e ->
      Log.err (fun m -> m "%s" (Printexc.to_string e));
      None

let may_load_font size file =
  if List.mem (Filename.extension file) !font_exts then
    load_font ~keep:false size file
  else
    None

let load_fonts_from_dir =
  let rec iter ~checked acc size recur dir =
    let%lwt continue =
      match checked with
      | true -> Lwt.return_true
      | false ->
          match%lwt Lwt_unix.stat dir with
          | exception Unix.Unix_error (e,_,s2) ->
              [%debug "Loading fonts: %s %s" (Unix.error_message e) s2];
              Lwt.return_false
          | { Unix.st_kind = S_DIR } -> Lwt.return_true
          | _ ->
              [%debug "Loading fonts: %s is not a directory" dir];
              Lwt.return_false
    in
    if continue then
      (
       [%debug "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.fold_left_s
         (fun acc e ->
            if e = Filename.parent_dir_name ||
              e = Filename.current_dir_name
            then
              Lwt.return acc
            else
              (
               let e = Filename.concat dir e in
               match%lwt Lwt_unix.stat e with
               | exception _ -> Lwt.return acc
               | { Unix.st_kind = S_REG } ->
                     (match may_load_font size e with
                        | None -> Lwt.return acc
                        | Some desc -> Lwt.return (desc :: acc)
                     )
               | { st_kind = S_DIR } ->
                   if recur then
                     iter ~checked:true acc size recur e
                   else
                     Lwt.return acc
                | _ -> Lwt.return acc
              )
         )
         acc l
      )
    else
      Lwt.return acc
  in
  iter ~checked:false

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

let load_fonts_from_dir ?(size= !default_font_size) ?(recur=true) dir =
  load_fonts_from_dir [] size recur dir

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)
let could_not_load_font desc =
  Misc.could_not_load_font (string_of_font_desc desc)

exception Found of (IBBMap.key * (string * int) 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_unused_fonts () =
  [%debug "closing unused fonts"];
  let count = ref 0 in
  Dynarray.iter (fun e ->
     match e.fe_used, e.fe_font with
     | false, Some _ ->
         e.fe_font <- None;
         incr count ;
     | _ -> e.fe_used <-false)
    used_fonts;
  if !count > 0 then
     [%debug "closing unused fonts: %d fonts forgotten" !count]

let close_unused_delay = 10.
let init () =
  let () = add_fallback_font 0x1f600 0x1f64f "DejaVu Sans" in
  let rec loop_close_unused () =
    let%lwt () = Lwt_unix.sleep close_unused_delay in
    close_unused_fonts ();
    Gc.full_major();
    loop_close_unused ()
  in
  Lwt.async loop_close_unused


let family_is_available family =
  match Smap.find_opt family !fonts with
  | None -> false
  | _ -> true

let rec get desc =
  [%debug "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 ->
           if desc.italic || desc.bold then
             ( (* try with no italic and no bold *)
              Log.warn (fun m -> m "Font family %S not available with italic=%b and bold=%b"
                 desc.family desc.italic desc.bold);
              get { desc with italic = false ; bold = false }
             )
           else
             (
              (* FIXME: fallback to another font ? *)
              Log.err (fun m -> m "Font family %S not available with italic=%b and bold=%b"
                 desc.family desc.italic desc.bold);
              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, _i)) ->
               match load_font desc.size file with
               | Some _ -> get desc
               | None -> could_not_load_font desc
           )
      )
  | Some amap ->
      let atts = atts_of_desc desc in
      match AttsMap.find_opt atts amap with
      | Some (file, i) ->
          (
           let e = get_font_entry i in
           match e.fe_font with
           | Some _font -> e.fe_used <- true ; i
           | None ->
               let> font = open_font file desc.size in
               e.fe_used <- true;
               e.fe_font <- Some font;
               i
          )
      | None ->
          match AttsMap.min_binding_opt amap with
          | None -> assert false (* we should at least have one *)
          | Some (_, (file, _i)) ->
              let> font = open_font file desc.size in
              let fn = font.font 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 ;
              let i = add_font_entry desc (Some font) in
              add_atts desc (file, i) ;
              i

let get = get

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 []

let rec sdl_font i =
  let e = get_font_entry i in
  let f = match e.fe_font with
    | None -> sdl_font (get e.fe_desc)
    | Some f -> e.fe_used <- true; f.font
  in
  f

let font_metrics i =
  let f = sdl_font i in
  { 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 ;
  }

let glyph_is_provided font = Ttf.glyph_is_provided (sdl_font font)
let glyph_metrics font = Ttf.glyph_metrics (sdl_font font)
let get_font_hinting font = Ttf.get_font_hinting (sdl_font font)
let get_font_kerning_size font = Ttf.get_font_kerning_size (sdl_font font)
let font_height font = Ttf.font_height (sdl_font font)
let font_ascent font = Ttf.font_ascent (sdl_font font)
let font_descent font = Ttf.font_descent (sdl_font font)
let font_line_skip font = Ttf.font_line_skip (sdl_font font)
let get_font_kerning font = Ttf.get_font_kerning (sdl_font font)
let font_faces font = Ttf.font_faces (sdl_font font)
let font_face_is_fixed_width font = Ttf.font_face_is_fixed_width (sdl_font font)
let font_face_family_name font = Ttf.font_face_family_name (sdl_font font)
let font_face_style_name font = Ttf.font_face_style_name (sdl_font font)
let size_utf8 font = Ttf.size_utf8 (sdl_font font)

let glyph_is_provided font = Ttf.glyph_is_provided (sdl_font font)

let finalise_surface_result = function
| (Ok s) as ok -> Gc.finalise
    (fun s ->
       (*prerr_endline "Font:freeing surface";*)
       Tsdl.Sdl.free_surface s) s; ok
| e -> e

let render_glyph_blended font g color =
  finalise_surface_result (Ttf.render_glyph_blended (sdl_font font) g color)

let render_utf8_blended font text color =
  finalise_surface_result (Ttf.render_utf8_blended (sdl_font font) text color)