wip: real ECS scene topology
This commit is contained in:
parent
3818e4f550
commit
74f5d9a3aa
46
src/main.ml
46
src/main.ml
|
|
@ -1,8 +1,6 @@
|
|||
open Adam
|
||||
open S2
|
||||
module TG = N2.Transform_graph
|
||||
module SG = N2.Sprite_graph
|
||||
module Scene = N2.Scene
|
||||
open N2
|
||||
|
||||
include (val Ohlog.logs "Main")
|
||||
|
||||
|
|
@ -13,21 +11,37 @@ let main () =
|
|||
let ren = Renderer.make ~wnd in
|
||||
info (fun m -> m "renderer initialized");
|
||||
|
||||
let sg = SG.make () in
|
||||
SG.register_sprite_map sg "blocks" (Asset.load_sprite_map "blocks" ~dpi:192);
|
||||
SG.register_sprite_map sg "hud" (Asset.load_sprite_map "hud");
|
||||
SG.register_font sg "roman-md" (Asset.load_font "roman-md");
|
||||
SG.register_font sg "mono-sm" (Asset.load_font "mono-sm");
|
||||
debug (fun m -> m "loaded assets");
|
||||
(* 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 tg = TG.make () in
|
||||
let scene = Scene.load "main" ~tg ~sg in
|
||||
let root = Scene.get scene "root" 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 render time =
|
||||
begin
|
||||
let tf = TG.model (Scene.transform root) in
|
||||
let tf = Trans.model root in
|
||||
begin
|
||||
let _ = time in
|
||||
Mat2A.set tf ~tx:512.0 ~ty:400.0 ~sx:1.0 ~sy:1.0
|
||||
|
|
@ -36,8 +50,8 @@ let main () =
|
|||
Renderer.pre_draw ren;
|
||||
Renderer.clear ren (rgb24 0x131321);
|
||||
|
||||
TG.update tg;
|
||||
SG.render sg ~ren;
|
||||
update_transforms ();
|
||||
render ren;
|
||||
|
||||
Renderer.post_draw ren;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
include Adam
|
||||
include S2
|
||||
include (val Ohlog.logs "N2")
|
||||
296
src/n2/n2.ml
296
src/n2/n2.ml
|
|
@ -1,288 +1,10 @@
|
|||
open Adam
|
||||
open S2
|
||||
|
||||
include (val Ohlog.logs "N2")
|
||||
|
||||
module Transform_graph = struct
|
||||
include (val Ohlog.sublogs logger "TG")
|
||||
|
||||
type t = {
|
||||
mutable buffer : node array;
|
||||
mutable size : int;
|
||||
}
|
||||
|
||||
and node =
|
||||
| Null
|
||||
| Node of {
|
||||
idx : int;
|
||||
parent_tf : mat2a option;
|
||||
model_tf : mat2a;
|
||||
world_tf : mat2a;
|
||||
}
|
||||
|
||||
let make () = {
|
||||
buffer = Array.make 64 Null;
|
||||
size = 0;
|
||||
}
|
||||
|
||||
let push t n =
|
||||
let buf = t.buffer in
|
||||
let cap = Array.length buf in
|
||||
if t.size >= cap then
|
||||
t.buffer <-
|
||||
Array.init (cap * 2)
|
||||
(fun i -> if i < cap then buf.(i) else Null);
|
||||
t.buffer.(t.size) <- n;
|
||||
t.size <- t.size + 1
|
||||
|
||||
let add t parent =
|
||||
let model_tf = mat2a () in
|
||||
let parent_tf, world_tf =
|
||||
match parent with
|
||||
| Null -> None, model_tf
|
||||
| Node p -> Some p.world_tf, mat2a ()
|
||||
in
|
||||
let node =
|
||||
Node {
|
||||
idx = t.size;
|
||||
parent_tf;
|
||||
model_tf;
|
||||
world_tf;
|
||||
}
|
||||
in
|
||||
push t node;
|
||||
node
|
||||
|
||||
let update t =
|
||||
let buf = t.buffer in
|
||||
for i = 0 to t.size - 1 do
|
||||
match buf.(i) with
|
||||
| Node { model_tf; world_tf; parent_tf = Some parent_tf; _ } ->
|
||||
Mat2A.multiply world_tf parent_tf model_tf
|
||||
| _ ->
|
||||
()
|
||||
done
|
||||
|
||||
let world = function
|
||||
| Null -> invalid_arg "null"
|
||||
| Node n -> n.world_tf
|
||||
|
||||
let model = function
|
||||
| Null -> invalid_arg "null"
|
||||
| Node n -> n.model_tf
|
||||
end
|
||||
|
||||
module Sprite_graph = struct
|
||||
include (val Ohlog.sublogs logger "SG")
|
||||
|
||||
type t = {
|
||||
sprite_maps : (string, Sprite_map.t) Hashtbl.t;
|
||||
fonts : (string, Font.t) Hashtbl.t;
|
||||
mutable list_rev : node list;
|
||||
mutable list : node list;
|
||||
}
|
||||
|
||||
and node =
|
||||
| Sprites of {
|
||||
tf : mat2a;
|
||||
map : Sprite_map.t;
|
||||
frames : Floatbuffer.t;
|
||||
(* tint : color *)
|
||||
}
|
||||
| Label of {
|
||||
tf : mat2a;
|
||||
font : Font.t;
|
||||
glyphs : Floatbuffer.t;
|
||||
fg : color;
|
||||
}
|
||||
|
||||
let make () = {
|
||||
sprite_maps = Hashtbl.create 32;
|
||||
fonts = Hashtbl.create 32;
|
||||
list_rev = [];
|
||||
list = [];
|
||||
}
|
||||
|
||||
let register_sprite_map t name map =
|
||||
Hashtbl.replace t.sprite_maps name map
|
||||
|
||||
let register_font t name font =
|
||||
Hashtbl.replace t.fonts name font
|
||||
|
||||
let get_sprite_map t name =
|
||||
try Hashtbl.find t.sprite_maps name with
|
||||
Not_found -> Format.kasprintf failwith "no sprite map %S" name
|
||||
|
||||
let get_font t name =
|
||||
try Hashtbl.find t.fonts name with
|
||||
Not_found -> Format.kasprintf failwith "no font %S" name
|
||||
|
||||
let push t node =
|
||||
begin
|
||||
t.list_rev <- node :: t.list_rev;
|
||||
t.list <- [];
|
||||
end
|
||||
|
||||
let add_sprites t ~tf ~map ~sprites =
|
||||
let frames = Floatbuffer.make (List.length sprites * 8) in
|
||||
List.iter (fun (frame, pos) -> Sprite_map.emit_sprite map frames ~frame ~pos) sprites;
|
||||
let node = Sprites { tf; map; frames } in
|
||||
push t node;
|
||||
node
|
||||
|
||||
let add_label t ~tf ~font ~text ~fg =
|
||||
let glyphs = Floatbuffer.make (String.length text * 10) in
|
||||
Font.emit_glyphs font glyphs ~text;
|
||||
let node = Label { tf; font; glyphs; fg } in
|
||||
push t node;
|
||||
node
|
||||
|
||||
let _white = Color.white ()
|
||||
|
||||
let rec render_rec ren = function
|
||||
| [] -> ()
|
||||
| Sprites { tf; map; frames } :: nodes ->
|
||||
Renderer.draw_sprites ren map frames ~tf ~tint:_white;
|
||||
render_rec ren nodes
|
||||
| Label { tf; font; glyphs; fg } :: nodes ->
|
||||
Renderer.draw_text ren font glyphs ~tf ~fg;
|
||||
render_rec ren nodes
|
||||
|
||||
let render t ~ren =
|
||||
if t.list = [] then
|
||||
t.list <- List.rev t.list_rev;
|
||||
render_rec ren t.list
|
||||
end
|
||||
|
||||
module Scene = struct
|
||||
module Sexp = Sexplib0.Sexp
|
||||
open Sexplib0.Sexp_conv
|
||||
|
||||
include (val Ohlog.sublogs logger "Scene")
|
||||
|
||||
type t = {
|
||||
objs : (string, obj) Hashtbl.t;
|
||||
}
|
||||
|
||||
and obj = {
|
||||
name : string option;
|
||||
transform : Transform_graph.node;
|
||||
}
|
||||
|
||||
let get t name = try Hashtbl.find t.objs name
|
||||
with Not_found ->
|
||||
Format.ksprintf failwith "no node %S in scene" name
|
||||
|
||||
let transform obj = obj.transform
|
||||
|
||||
let parse_transform_arg ~(tf : mat2a) = 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
|
||||
|
||||
let parse_sprite_arg ~map = function
|
||||
| Sexp.List [Atom frame; x; y] ->
|
||||
let pos = vec2 (float_of_sexp x) (float_of_sexp y) in
|
||||
frame, pos
|
||||
| Atom frame ->
|
||||
frame, vec2 0.0 0.0
|
||||
| sexp ->
|
||||
of_sexp_error "bad sprite argument" sexp
|
||||
|
||||
let parse_sprites ~sg ~tf = function
|
||||
| Sexp.List (Atom "sprites" :: Atom map :: args) ->
|
||||
let map = Sprite_graph.get_sprite_map sg map in
|
||||
let sprites = List.map (parse_sprite_arg ~map) args in
|
||||
Sprite_graph.add_sprites sg ~tf ~map ~sprites |> ignore
|
||||
| sexp ->
|
||||
of_sexp_error "invalid sprites" sexp
|
||||
|
||||
let parse_label_arg ~(fg : color) = function
|
||||
| Sexp.List [Atom "fg"; rgb] ->
|
||||
Color.set_rgb24 fg (int_of_sexp rgb)
|
||||
| sexp ->
|
||||
of_sexp_error "bad argument to label" sexp
|
||||
|
||||
let parse_label ~sg ~tf = function
|
||||
| Sexp.List (Atom "label" :: Atom font :: Atom text :: args) ->
|
||||
let font = Sprite_graph.get_font sg font in
|
||||
let fg = rgb24 0xffffff in
|
||||
List.iter (parse_label_arg ~fg) args;
|
||||
Sprite_graph.add_label sg ~tf ~font ~text ~fg |> ignore
|
||||
| sexp ->
|
||||
of_sexp_error "invalid label" sexp
|
||||
|
||||
let rec parse_obj t ~tg ~sg ~parent = function
|
||||
| Sexp.List (Atom "object" :: args) ->
|
||||
trace (fun m -> m "parse_obj");
|
||||
let ptgn = match parent with
|
||||
| None -> Transform_graph.Null
|
||||
| Some parent -> parent.transform
|
||||
in
|
||||
let transform = Transform_graph.add tg ptgn in
|
||||
let obj = { name = None; transform } in
|
||||
let obj = parse_obj_args t obj args ~tg ~sg in
|
||||
Option.iter
|
||||
(fun name -> Hashtbl.replace t.objs name obj)
|
||||
obj.name;
|
||||
obj
|
||||
| sexp ->
|
||||
of_sexp_error "invalid object" sexp
|
||||
|
||||
and parse_obj_args t obj ~tg ~sg = function
|
||||
| [] -> obj
|
||||
| arg :: args ->
|
||||
match arg with
|
||||
| Atom name ->
|
||||
trace (fun m -> m "parse_obj_args: name=%S" name);
|
||||
let obj = { obj with name = Some name } in
|
||||
parse_obj_args t obj args ~tg ~sg
|
||||
|
||||
| Sexp.List (Atom "transform" :: tf_args) ->
|
||||
let tf = Transform_graph.model obj.transform in
|
||||
List.iter (parse_transform_arg ~tf) tf_args;
|
||||
trace (fun m -> m "parse_obj_args: tf=%a" Mat2A.pp tf);
|
||||
parse_obj_args t obj args ~tg ~sg
|
||||
|
||||
| Sexp.List (Atom "sprites" :: _) ->
|
||||
let tf = Transform_graph.world obj.transform in
|
||||
parse_sprites arg ~sg ~tf;
|
||||
parse_obj_args t obj args ~tg ~sg
|
||||
|
||||
| Sexp.List (Atom "label" :: _) ->
|
||||
let tf = Transform_graph.world obj.transform in
|
||||
parse_label arg ~sg ~tf;
|
||||
parse_obj_args t obj args ~tg ~sg
|
||||
|
||||
| Sexp.List (Atom "object" :: _) ->
|
||||
trace (fun m -> m "parse_obj_args: begin object");
|
||||
let _child = parse_obj t arg ~tg ~sg ~parent:(Some obj) in
|
||||
trace (fun m -> m "parse_obj_args: end object");
|
||||
parse_obj_args t obj args ~tg ~sg
|
||||
|
||||
| sexp ->
|
||||
of_sexp_error "bad argument to object" sexp
|
||||
|
||||
let of_sexp ~tg ~sg = function
|
||||
| Sexp.List [Atom "scene"; root] ->
|
||||
let t = {
|
||||
objs = Hashtbl.create 128;
|
||||
} in
|
||||
let _root = parse_obj t root ~tg ~sg ~parent:None in
|
||||
t
|
||||
|
||||
| sexp ->
|
||||
of_sexp_error "invalid scene" sexp
|
||||
|
||||
let load name ~tg ~sg =
|
||||
S2.Asset.load_sexp_conv
|
||||
(name ^ ".scene")
|
||||
(of_sexp ~tg ~sg)
|
||||
end
|
||||
type en = Types.en
|
||||
module Entity = Types.Entity
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,38 +1,42 @@
|
|||
open Adam
|
||||
open S2
|
||||
|
||||
module Transform_graph : sig
|
||||
module Entity : sig
|
||||
type t
|
||||
type node
|
||||
|
||||
val make : unit -> t
|
||||
val update : t -> unit
|
||||
|
||||
val model : node -> mat2a
|
||||
val world : node -> mat2a
|
||||
|
||||
(* val add : ?parent:node -> t -> node *)
|
||||
val make : ?name:string -> unit -> t
|
||||
val pp : Format.formatter -> t -> unit
|
||||
end
|
||||
|
||||
module Sprite_graph : sig
|
||||
type t
|
||||
type node
|
||||
|
||||
val make : unit -> t
|
||||
val register_sprite_map : t -> string -> Sprite_map.t -> unit
|
||||
val register_font : t -> string -> Font.t -> unit
|
||||
val render : t -> ren:Renderer.t -> unit
|
||||
end
|
||||
type en = Entity.t
|
||||
|
||||
module Scene : sig
|
||||
type t
|
||||
type obj
|
||||
val load : string -> t
|
||||
|
||||
val load : string ->
|
||||
tg:Transform_graph.t ->
|
||||
sg:Sprite_graph.t ->
|
||||
t
|
||||
|
||||
val get : t -> string -> obj
|
||||
val transform : obj -> Transform_graph.node
|
||||
type context
|
||||
val make_context : unit -> context
|
||||
val register_sprite_map : context -> string -> Sprite_map.t -> unit
|
||||
val register_font : context -> string -> Font.t -> unit
|
||||
end
|
||||
|
||||
module Trans : sig
|
||||
val init : ?parent:en -> en -> unit
|
||||
|
||||
val model : en -> mat2a
|
||||
val world : en -> mat2a
|
||||
end
|
||||
|
||||
module Sprite : sig
|
||||
val init : sprite_map:Sprite_map.t -> en -> unit
|
||||
val clear : en -> unit
|
||||
val add : en -> frame:string -> pos:vec2 -> unit
|
||||
end
|
||||
|
||||
module Label : sig
|
||||
val init : font:Font.t -> en -> unit
|
||||
val set_text : en -> string -> unit
|
||||
end
|
||||
|
||||
val update_transforms : unit -> unit
|
||||
val render : Renderer.t -> unit
|
||||
val build : Scene.context -> Scene.t -> en
|
||||
|
|
|
|||
|
|
@ -0,0 +1,68 @@
|
|||
open! Import
|
||||
open Types
|
||||
|
||||
(* include (val Ohlog.sublogs Import.logger "Render") *)
|
||||
|
||||
let ord = Stack.make ()
|
||||
|
||||
let render ren =
|
||||
Stack.iter (fun f -> f ren) ord
|
||||
|
||||
module Sprite = struct
|
||||
type cv = {
|
||||
sprite_map : Sprite_map.t;
|
||||
sprites : Floatbuffer.t;
|
||||
tint : color;
|
||||
}
|
||||
|
||||
let map = Entity.Map.make ()
|
||||
|
||||
let init ~sprite_map en =
|
||||
let cv = {
|
||||
sprite_map;
|
||||
sprites = Floatbuffer.make 16;
|
||||
tint = Color.white ();
|
||||
} in
|
||||
Entity.Map.set map en cv;
|
||||
Stack.push ord
|
||||
(fun ren ->
|
||||
let tf = Trans.world en in
|
||||
Renderer.draw_sprites ren ~tf ~tint:cv.tint
|
||||
cv.sprite_map cv.sprites)
|
||||
|
||||
let clear en =
|
||||
let cv = Entity.Map.get map en in
|
||||
Floatbuffer.clear cv.sprites
|
||||
|
||||
let add en ~frame ~pos =
|
||||
let cv = Entity.Map.get map en in
|
||||
Sprite_map.emit_sprite cv.sprite_map cv.sprites ~frame ~pos
|
||||
end
|
||||
|
||||
module Label = struct
|
||||
type cv = {
|
||||
font : Font.t;
|
||||
glyphs : Floatbuffer.t;
|
||||
fg : color;
|
||||
}
|
||||
|
||||
let map = Entity.Map.make ()
|
||||
|
||||
let init ~font en =
|
||||
let cv = {
|
||||
font;
|
||||
glyphs = Floatbuffer.make 32;
|
||||
fg = Color.white ();
|
||||
} in
|
||||
Entity.Map.set map en cv;
|
||||
Stack.push ord
|
||||
(fun ren ->
|
||||
let tf = Trans.world en in
|
||||
Renderer.draw_text ren ~tf ~fg:cv.fg
|
||||
cv.font cv.glyphs)
|
||||
|
||||
let set_text en text =
|
||||
let cv = Entity.Map.get map en in
|
||||
Floatbuffer.clear cv.glyphs;
|
||||
Font.emit_glyphs cv.font cv.glyphs ~text
|
||||
end
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
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 register_font cx k v =
|
||||
Hashtbl.replace cx.fonts k v
|
||||
|
||||
type t =
|
||||
context -> en
|
||||
|
||||
let build cx f = f cx
|
||||
|
||||
|
||||
let of_sexp sexp =
|
||||
()
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
open! Import
|
||||
open Types
|
||||
|
||||
(* include (val Ohlog.sublogs Import.logger "Trans") *)
|
||||
|
||||
type cv = {
|
||||
model : mat2a;
|
||||
world : mat2a;
|
||||
parent : mat2a option;
|
||||
}
|
||||
|
||||
let map = Entity.Map.make ()
|
||||
let ord = Stack.make ()
|
||||
|
||||
let model en = (Entity.Map.get map en).model
|
||||
let world en = (Entity.Map.get map en).world
|
||||
|
||||
let init ?parent child =
|
||||
let model = Mat2A.make () in
|
||||
let cv = match parent with
|
||||
| Some parent -> {
|
||||
model;
|
||||
world = Mat2A.make ();
|
||||
parent = Some (world parent);
|
||||
}
|
||||
| None -> {
|
||||
model;
|
||||
world = model;
|
||||
parent = None;
|
||||
}
|
||||
in
|
||||
Entity.Map.set map child cv;
|
||||
Stack.push ord child
|
||||
|
||||
let update en =
|
||||
let cv = Entity.Map.get map en in
|
||||
match cv.parent with
|
||||
| None -> ((* world == parent *))
|
||||
| Some parent -> Mat2A.multiply cv.world parent cv.model
|
||||
|
||||
let update_transforms () =
|
||||
Stack.iter update ord
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
open! Import
|
||||
|
||||
(* entity *)
|
||||
|
||||
type en = {
|
||||
name : string option;
|
||||
id : int;
|
||||
}
|
||||
|
||||
module Entity = struct
|
||||
type t = en
|
||||
let _next_id = ref 0
|
||||
|
||||
let make ?name () =
|
||||
let id = !_next_id in
|
||||
incr _next_id; {
|
||||
name;
|
||||
id;
|
||||
}
|
||||
|
||||
let pp ppf en =
|
||||
let pp_name ppf = Option.iter (Format.fprintf ppf "%s@") in
|
||||
Format.fprintf ppf "{%a%d}" pp_name en.name en.id
|
||||
|
||||
module Map = struct
|
||||
type 'a t = { h : (int, 'a) Hashtbl.t } [@@unboxed]
|
||||
let make ?(size = 1000) () = {h = Hashtbl.create size}
|
||||
let set t en v = Hashtbl.replace t.h en.id v
|
||||
let get t en = try Hashtbl.find t.h en.id
|
||||
with Not_found ->
|
||||
Format.kasprintf failwith "entity %a not in collection" pp en
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
(* stack *)
|
||||
|
||||
module Stack = struct
|
||||
type 'a t = { mutable fwd : 'a list; mutable bwd : 'a list }
|
||||
|
||||
let make () = {fwd = []; bwd = []}
|
||||
let push t x = t.bwd <- x :: t.bwd; t.fwd <- []
|
||||
|
||||
let to_list t =
|
||||
if t.fwd = [] then
|
||||
t.fwd <- List.rev t.bwd;
|
||||
t.fwd
|
||||
|
||||
let iter f t =
|
||||
List.iter f (to_list t)
|
||||
end
|
||||
Loading…
Reference in New Issue