geometra/scripts/gen_glyph_map.ml

124 lines
3.4 KiB
OCaml
Raw Normal View History

2024-01-20 07:34:29 +00:00
[@@@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)