wip generating fonts

scripts/dune

@@ -2,3 +2,8 @@
  (name gen_sprite_map)
  (modules gen_sprite_map)
  (libraries xmlm sexplib))
+
+(executable
+ (name gen_glyph_map)
+ (modules gen_glyph_map)
+ (libraries yojson sexplib))

scripts/gen_fonts.sh

@@ -0,0 +1,28 @@
+#!/usr/bin/env bash
+
+msdf="msdf-atlas-gen"
+gen_glyph_map="dune exec --no-print-directory --display=quiet scripts/gen_glyph_map.exe"
+
+out_dir=assets/fonts/
+
+mkdir -p $out_dir
+
+function gen() {
+    echo "$1..."
+
+    dst_png=$out_dir/$1.png
+    dst_map=$out_dir/$1.map
+    src=$(find /usr/share/fonts -name $2)
+    emsize=$3
+
+    [[ "$src" -nt "$dst_png" ]] &&
+        ($msdf \
+             -font $src \
+             -imageout $dst_png \
+             -json >($gen_glyph_map > $dst_map) \
+             -size $emsize \
+             -yorigin top \
+             | exit 1)
+}
+
+gen liberation LiberationMono-Regular.ttf 64

scripts/gen_glyph_map.ml

@@ -0,0 +1,123 @@
+[@@@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)