geometra/scripts/gen_sprite_map.ml

119 lines
2.8 KiB
OCaml

module Sexp = Sexplib.Sexp
type clip = {
name : string;
x : int;
y : int;
w : int;
h : int;
ox : int;
oy : int;
}
let sexp_of_clip c =
Sexp.List (
Atom c.name ::
List.map Sexplib.Conv.sexp_of_int
[c.x; c.y; c.w; c.h; c.ox; c.oy])
let sexp_of_sprite_map clips =
Sexp.List (
Atom "map" ::
(List.sort (fun a b -> compare b.name a.name) clips |>
List.rev_map sexp_of_clip))
let svg v = ("http://www.w3.org/2000/svg", v)
let ink v = ("http://www.inkscape.org/namespaces/inkscape", v)
let sodi v = ("http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd", v)
type s = {
mutable depth : int;
mutable height : int;
mutable origins : (string * (int * int)) list;
mutable clips : clip list;
mutable clips_g : int;
}
let extract_clips xml =
let s = {
depth = 0;
height = 0;
origins = [];
clips = [];
clips_g = Int.max_int;
} in
let el_start tag atrs =
s.depth <- s.depth + 1;
if tag = svg "svg" then
begin
let height = List.assoc ("", "height") atrs |> int_of_string in
s.height <- height
end;
if tag = svg "g" then
begin
let label = List.assoc_opt (ink "label") atrs in
if label = Some "clips" then
s.clips_g <- min s.clips_g s.depth
end;
if tag = sodi "guide" then
begin
let label = List.assoc_opt (ink "label") atrs in
match label with
| None | Some "" -> ()
| Some name ->
let pos = List.assoc ("", "position") atrs in
let[@warning "-8"] [ x; y ] = String.split_on_char ',' pos in
let x = int_of_string x in
let y = s.height - int_of_string y in
s.origins <- (name, (x, y)) :: s.origins
end;
if s.clips_g < s.depth &&
tag = svg "rect" &&
List.mem_assoc (ink "label") atrs
then
begin
let name = List.assoc (ink "label") atrs in
let x = List.assoc ("", "x") atrs |> int_of_string in
let y = List.assoc ("", "y") atrs |> int_of_string in
let w = List.assoc ("", "width") atrs |> int_of_string in
let h = List.assoc ("", "height") atrs |> int_of_string in
let ox, oy = try List.assoc name s.origins
with Not_found -> (x, y)
in
s.clips <- { name; x; y; w; h; ox; oy } :: s.clips
end;
true
in
let el_end () =
s.depth <- s.depth - 1;
if s.depth < s.clips_g then s.clips_g <- Int.max_int;
s.depth > 0
in
while
match Xmlm.input xml with
| `Dtd _ | `Data _ -> true
| `El_start (tag, atrs) -> el_start tag atrs
| `El_end -> el_end ()
do () done;
s.clips
let gen_sprite_map ic oc =
let sprite_map =
Xmlm.make_input (`Channel ic) |>
extract_clips
in
Format.kasprintf (output_string oc) "%a\n"
Sexp.pp_hum (sexp_of_sprite_map sprite_map)
let () =
gen_sprite_map stdin stdout