geometra/scripts/gen_glyph_map.ml

[@@@warning "-32-69"]

module Sexp = Sexplib.Sexp
module Json = Yojson.Basic

type atlas = {
  size : int;
  width : int;
  height : int;
  y_origin : [`bottom | `top];
}

(* type metrics = { *)
(*   line_height : float; *)
(*   ascender : float; *)
(*   descender : float; *)
(*   underline_y : float; *)
(* } *)

type bounds = {
  left : float;
  bottom : float;
  right : float;
  top : float;
}

type glyph = {
  unicode : int;
  advance : float;
  plane_bounds : bounds option;
  atlas_bounds : bounds option;
}

type msdf = {
  atlas : atlas;
  glyphs : glyph list;
}

let invalid_json f x =
  invalid_arg (f ^ ": unexpected json: " ^ Json.to_string x)

let int_of_json = function `Int i -> i |
  x -> invalid_json "int_of_json" x
let float_of_json = function `Int i -> float_of_int i | `Float f -> f |
  x -> invalid_json "float_of_json" x
let string_of_json = function `String s -> s |
  x -> invalid_json "string_of_json" x
let list_of_json = function `List l -> l |
  x -> invalid_json "list_of_json" x
let json_assoc_opt k = function
  | `Assoc kv -> List.assoc_opt k kv
  | x -> invalid_json "json_assoc" x
let json_assoc k js = match json_assoc_opt k js with
  | Some v -> v
  | None -> invalid_arg ("no key " ^ k)

let atlas_of_json = function
  | `Assoc kv ->
    let size = int_of_json (List.assoc "size" kv) in
    let width = int_of_json (List.assoc "width" kv) in
    let height = int_of_json (List.assoc "height" kv) in
    let y_origin = match List.assoc "yOrigin" kv with
      | `String "bottom" -> `bottom
      | `String "top" -> `top
      | x -> invalid_json "yOrigin" x
    in
    { size; width; height; y_origin }
  | x -> invalid_json "atlas_of_json" x

let bounds_of_json js =
  let left = float_of_json (json_assoc "left" js) in
  let right = float_of_json (json_assoc "right" js) in
  let top = float_of_json (json_assoc "top" js) in
  let bottom = float_of_json (json_assoc "bottom" js) in
  { left; right; top; bottom }

let glyph_of_json js =
  let unicode = int_of_json (json_assoc "unicode" js) in
  let advance = float_of_json (json_assoc "advance" js) in
  let plane_bounds = Option.map bounds_of_json (json_assoc_opt "planeBounds" js) in
  let atlas_bounds = Option.map bounds_of_json (json_assoc_opt "atlasBounds" js) in
  { unicode; advance; plane_bounds; atlas_bounds }

let msdf_of_json js =
  let atlas = atlas_of_json (json_assoc "atlas" js) in
  let glyphs = List.map glyph_of_json (list_of_json (json_assoc "glyphs" js)) in
  { atlas; glyphs }

let sexp_of_bounds b =
  Sexp.List [
    Atom (Printf.sprintf "%.4f" b.left);
    Atom (Printf.sprintf "%.4f" b.top);
    Atom (Printf.sprintf "%.4f" b.right);
    Atom (Printf.sprintf "%.4f" b.bottom);
  ]

let sexp_of_glyph g =
  let chr = Char.chr g.unicode in
  Sexp.List (
    Atom "glyph" ::
    Atom (String.make 1 chr) ::
    List [Atom "advance"; Atom (Printf.sprintf "%.4f" g.advance)] ::
    (
      (g.plane_bounds |> Option.map sexp_of_bounds |> Option.to_list) @
      (g.atlas_bounds |> Option.map sexp_of_bounds |> Option.to_list)
    )
  )

let sexp_of_msdf msdf =
  Sexp.List (
    Atom "msdf" ::
    List.map sexp_of_glyph
      (List.sort (fun a b -> compare a.unicode b.unicode)
         msdf.glyphs)
  )

let () =
  let inp = Json.from_channel stdin in
  let msdf = msdf_of_json inp in
  if msdf.atlas.y_origin <> `top then
    failwith "origin must be top";
  Format.printf "%a\n"
    Sexp.pp_hum (sexp_of_msdf msdf)