open! Import
open Types

include (val Ohlog.sublogs Import.logger "Scene")

type context = {
  sprite_maps : (string, Sprite_map.t) Hashtbl.t;
  fonts : (string, Font.t) Hashtbl.t;
  trans_parent : en option;
}

let make_context () = {
  sprite_maps = Hashtbl.create 32;
  fonts = Hashtbl.create 8;
  trans_parent = None;
}

let register_sprite_map cx k v = Hashtbl.replace cx.sprite_maps k v
let get_sprite_map cx k = try Hashtbl.find cx.sprite_maps k
  with Not_found -> Format.kasprintf failwith "no such sprite map %S" k

let register_font cx k v = Hashtbl.replace cx.fonts k v
let get_font cx k = try Hashtbl.find cx.fonts k
  with Not_found -> Format.kasprintf failwith "no such font %S" k

type t =
  context -> en

let build cx f = f cx

let rec each2 fs x y = match fs with
  | [] -> ()
  | [f] -> f x y
  | f :: fs -> f x y; each2 fs x y


(* sexp conv *)

module Sexp = Sexplib0.Sexp
open Sexplib0.Sexp_conv

(* (transform <...>) *)
       
let parse_transform args =
  let tf = mat2a () in
  List.iter
    (function
      | Sexp.List [Atom "tx"; arg] ->
        tf.a2 <- float_of_sexp arg
      | Sexp.List [Atom "ty"; arg] ->
        tf.a5 <- float_of_sexp arg
      | Sexp.List [Atom "sx"; arg] ->
        tf.a0 <- float_of_sexp arg
      | Sexp.List [Atom "sy"; arg] ->
        tf.a4 <- float_of_sexp arg
      | sexp ->
        of_sexp_error "bad argument to transform" sexp)
    args;
  tf

(* (sprites <map> <...>) *)

let rec parse_sprites = function
  | Sexp.List (Atom "sprites" :: Atom map :: args) ->
    let init cx en =
      let sprite_map = get_sprite_map cx map in
      Render.Sprite.init en ~sprite_map
    in
    init :: List.map parse_sprites_arg args

  | sexp ->
    of_sexp_error "invalid sprites" sexp

and parse_sprites_arg = function
  | Sexp.List [Atom frame; x; y] ->
    let pos = vec2 (float_of_sexp x) (float_of_sexp y) in
    fun cx en -> Render.Sprite.add en ~frame ~pos
  | Atom frame ->
    let pos = vec2 0.0 0.0 in
    fun cx en -> Render.Sprite.add en ~frame ~pos
  | sexp ->
    of_sexp_error "bad argument to sprites" sexp

(* (label <font> <text> <...>) *)

let rec parse_label = function
  | Sexp.List (Atom "label" :: Atom font :: Atom text :: args) ->
    let init cx en =
      let font = get_font cx font in
      Render.Label.init en ~font;
      Render.Label.set_text en text
    in
    init :: List.map parse_label_arg args

  | sexp ->
    of_sexp_error "invalid label" sexp

and parse_label_arg = function
  | Sexp.List [Atom "fg"; _rgb] ->
    failwith "TODO: label: (fg <rgb>)"
  | sexp ->
    of_sexp_error "bad argument to label" sexp

(* (object [<name>] <...>) *)

let rec parse_obj = function
  | Sexp.List (Atom "object" :: args) ->
    let name, args = match args with
      | Atom name :: args -> Some name, args
      | args -> None, args
    in
    trace (fun m -> match name with
            | Some n -> m "parse_obj %S" n
            | None -> m "parse_obj %s" "(unnamed)");
    let inits = flat_map parse_obj_arg args in
    fun cx ->
      let en = Entity.make ?name () in
      Trans.init en ?parent:cx.trans_parent;
      each2 inits cx en;
      en

  | sexp ->
    of_sexp_error "invalid object" sexp

and parse_obj_arg = function
    | Sexp.List (Atom "transform" :: args) ->
      let tf = parse_transform args in
      let init _cx en = Mat2A.copy (Trans.model en) ~src:tf in
      [init]

    | Sexp.List (Atom "sprites" :: _) as arg ->
      parse_sprites arg

    | Sexp.List (Atom "label" :: _) as arg ->
      parse_label arg

    | Sexp.List (Atom "object" :: _) as sexp ->
      trace (fun m -> m "parse_obj_args: begin object");
      let build = parse_obj sexp in
      trace (fun m -> m "parse_obj_args: end object");
      let init cx en = build { cx with trans_parent = Some en } |> ignore in
      [init]

    | sexp ->
      of_sexp_error "bad argument to object" sexp

let of_sexp = function
  | Sexp.List [Atom "scene"; root] ->
    parse_obj root

  | sexp ->
    of_sexp_error "invalid scene" sexp

let load name =
  S2.Asset.load_sexp_conv
    (name ^ ".scene")
    of_sexp