diff --git a/src/main.ml b/src/main.ml index 2a0a694..4e5edeb 100644 --- a/src/main.ml +++ b/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 diff --git a/src/n2/import.ml b/src/n2/import.ml index 0cd62e4..4ed6ec5 100644 --- a/src/n2/import.ml +++ b/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 diff --git a/src/n2/n2.ml b/src/n2/n2.ml index 18a7727..f77e7e3 100644 --- a/src/n2/n2.ml +++ b/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 diff --git a/src/n2/scene.ml b/src/n2/scene.ml index b990e2c..fcfca9f 100644 --- a/src/n2/scene.ml +++ b/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 <...>) *) + +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 <...>) *) + +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 )" + | sexp -> + of_sexp_error "bad argument to label" sexp + +(* (object [] <...>) *) + +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