geometra/scripts/gen_sprite_map.ml

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

type sprite_map = {
  dpi : string;
  clips : clip list;
}

let sexp_of_sprite_map s =
  Sexp.List [
    Atom "map";
    List [Atom "dpi"; Atom s.dpi];
    List (
      Atom "frames" ::
      (List.sort (fun a b -> compare b.name a.name) s.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 = {
    dpi = Sys.argv.(1);
    clips =
      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