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 Adam
|
||||||
open S2
|
open S2
|
||||||
module TG = N2.Transform_graph
|
open N2
|
||||||
module SG = N2.Sprite_graph
|
|
||||||
module Scene = N2.Scene
|
|
||||||
|
|
||||||
include (val Ohlog.logs "Main")
|
include (val Ohlog.logs "Main")
|
||||||
|
|
||||||
|
|
@ -13,21 +11,37 @@ let main () =
|
||||||
let ren = Renderer.make ~wnd in
|
let ren = Renderer.make ~wnd in
|
||||||
info (fun m -> m "renderer initialized");
|
info (fun m -> m "renderer initialized");
|
||||||
|
|
||||||
let sg = SG.make () in
|
(* let ctx = Scene.make_context () in *)
|
||||||
SG.register_sprite_map sg "blocks" (Asset.load_sprite_map "blocks" ~dpi:192);
|
(* Scene.register_sprite_map ctx "blocks" (Asset.load_sprite_map "blocks" ~dpi:192); *)
|
||||||
SG.register_sprite_map sg "hud" (Asset.load_sprite_map "hud");
|
(* Scene.register_sprite_map ctx "hud" (Asset.load_sprite_map "hud"); *)
|
||||||
SG.register_font sg "roman-md" (Asset.load_font "roman-md");
|
(* Scene.register_font ctx "roman-md" (Asset.load_font "roman-md"); *)
|
||||||
SG.register_font sg "mono-sm" (Asset.load_font "mono-sm");
|
(* Scene.register_font ctx "mono-sm" (Asset.load_font "mon-sm"); *)
|
||||||
debug (fun m -> m "loaded assets");
|
(* 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 blocks = Asset.load_sprite_map "blocks" ~dpi:192 in
|
||||||
let scene = Scene.load "main" ~tg ~sg in
|
|
||||||
let root = Scene.get scene "root" in
|
let root = Entity.make () ~name:"scene" in
|
||||||
debug (fun m -> m "loaded scene");
|
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 =
|
let render time =
|
||||||
begin
|
begin
|
||||||
let tf = TG.model (Scene.transform root) in
|
let tf = Trans.model root in
|
||||||
begin
|
begin
|
||||||
let _ = time in
|
let _ = time in
|
||||||
Mat2A.set tf ~tx:512.0 ~ty:400.0 ~sx:1.0 ~sy:1.0
|
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.pre_draw ren;
|
||||||
Renderer.clear ren (rgb24 0x131321);
|
Renderer.clear ren (rgb24 0x131321);
|
||||||
|
|
||||||
TG.update tg;
|
update_transforms ();
|
||||||
SG.render sg ~ren;
|
render ren;
|
||||||
|
|
||||||
Renderer.post_draw 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")
|
include (val Ohlog.logs "N2")
|
||||||
|
type en = Types.en
|
||||||
module Transform_graph = struct
|
module Entity = Types.Entity
|
||||||
include (val Ohlog.sublogs logger "TG")
|
module Scene = Scene
|
||||||
|
let build = Scene.build
|
||||||
type t = {
|
module Trans = Trans
|
||||||
mutable buffer : node array;
|
let update_transforms = Trans.update_transforms
|
||||||
mutable size : int;
|
module Sprite = Render.Sprite
|
||||||
}
|
module Label = Render.Label
|
||||||
|
let render = Render.render
|
||||||
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
|
|
||||||
|
|
|
||||||
|
|
@ -1,38 +1,42 @@
|
||||||
open Adam
|
open Adam
|
||||||
open S2
|
open S2
|
||||||
|
|
||||||
module Transform_graph : sig
|
module Entity : sig
|
||||||
type t
|
type t
|
||||||
type node
|
val make : ?name:string -> unit -> t
|
||||||
|
val pp : Format.formatter -> t -> unit
|
||||||
val make : unit -> t
|
|
||||||
val update : t -> unit
|
|
||||||
|
|
||||||
val model : node -> mat2a
|
|
||||||
val world : node -> mat2a
|
|
||||||
|
|
||||||
(* val add : ?parent:node -> t -> node *)
|
|
||||||
end
|
end
|
||||||
|
|
||||||
module Sprite_graph : sig
|
type en = Entity.t
|
||||||
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
|
|
||||||
|
|
||||||
module Scene : sig
|
module Scene : sig
|
||||||
type t
|
type t
|
||||||
type obj
|
val load : string -> t
|
||||||
|
|
||||||
val load : string ->
|
type context
|
||||||
tg:Transform_graph.t ->
|
val make_context : unit -> context
|
||||||
sg:Sprite_graph.t ->
|
val register_sprite_map : context -> string -> Sprite_map.t -> unit
|
||||||
t
|
val register_font : context -> string -> Font.t -> unit
|
||||||
|
|
||||||
val get : t -> string -> obj
|
|
||||||
val transform : obj -> Transform_graph.node
|
|
||||||
end
|
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