ECS scene builder

src/main.ml

@@ -11,33 +11,14 @@ let main () =
   let ren = Renderer.make ~wnd in
   info (fun m -> m "renderer initialized");
 
-  (* let ctx = Scene.make_context () in *)
-  (* Scene.register_sprite_map ctx "blocks" (Asset.load_sprite_map "blocks" ~dpi:192); *)
-  (* Scene.register_sprite_map ctx "hud" (Asset.load_sprite_map "hud"); *)
-  (* Scene.register_font ctx "roman-md" (Asset.load_font "roman-md"); *)
-  (* Scene.register_font ctx "mono-sm" (Asset.load_font "mon-sm"); *)
-  (* let scene = Scene.load "main" in *)
-  (* let root = Scene.build scene ctx in *)
-  (* debug (fun m -> m "loaded scene"); *)
-
-  let blocks = Asset.load_sprite_map "blocks" ~dpi:192 in
-
-  let root = Entity.make () ~name:"scene" in
-  Trans.init root;
-
-  begin
-    let en = Entity.make () in
-    Trans.init en ~parent:root;
-    Sprite.init en ~sprite_map:blocks;
-    Sprite.add en ~frame:"Z" ~pos:(vec2 0.0 0.0);
-  end;
-
-  begin
-    let en = Entity.make () in
-    Trans.init en ~parent:root;
-    Sprite.init en ~sprite_map:blocks;
-    Sprite.add en ~frame:"O" ~pos:(vec2 (-32.0) 0.0);
-  end;
+  let ctx = Scene.make_context () in
+  Scene.register_sprite_map ctx "blocks" (Asset.load_sprite_map "blocks" ~dpi:192);
+  Scene.register_sprite_map ctx "hud" (Asset.load_sprite_map "hud");
+  Scene.register_font ctx "roman-md" (Asset.load_font "roman-md");
+  Scene.register_font ctx "mono-sm" (Asset.load_font "mono-sm");
+  let scene = Scene.load "main" in
+  let root = build ctx scene in
+  debug (fun m -> m "loaded scene");
 
   let render time =
     begin

src/n2/import.ml

@@ -1,3 +1,11 @@
 include Adam
 include S2
+
 include (val Ohlog.logs "N2")
+
+let[@tail_mod_cons] rec flat_map f = function
+  | [] -> []
+  | x :: xs -> append_then_flat_map f xs (f x)
+and[@tail_mod_cons] append_then_flat_map f xs = function
+  | [] -> flat_map f xs
+  | y :: ys -> y :: append_then_flat_map f xs ys

src/n2/n2.ml

@@ -1,10 +1,12 @@
-include (val Ohlog.logs "N2")
-type en = Types.en
 module Entity = Types.Entity
+type en = Entity.t
+
 module Scene = Scene
 let build = Scene.build
+
 module Trans = Trans
 let update_transforms = Trans.update_transforms
+
 module Sprite = Render.Sprite
 module Label = Render.Label
 let render = Render.render

src/n2/scene.ml

@@ -15,17 +15,143 @@ let make_context () = {
   trans_parent = None;
 }
 
-let register_sprite_map cx k v =
-  Hashtbl.replace cx.sprite_maps k v
+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 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
 
-let of_sexp sexp =
-  ()
+
+(* 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