From 74f5d9a3aa210343d1b9c63d3262fb8879ac703b Mon Sep 17 00:00:00 2001
From: milo <iitalics@gmail.com>
Date: Mon, 5 Feb 2024 15:44:26 -0500
Subject: [PATCH] wip: real ECS scene topology

---
 src/main.ml      |  46 +++++---
 src/n2/import.ml |   3 +
 src/n2/n2.ml     | 296 ++---------------------------------------------
 src/n2/n2.mli    |  58 +++++-----
 src/n2/render.ml |  68 +++++++++++
 src/n2/scene.ml  |  31 +++++
 src/n2/trans.ml  |  42 +++++++
 src/n2/types.ml  |  51 ++++++++
 8 files changed, 265 insertions(+), 330 deletions(-)
 create mode 100644 src/n2/import.ml
 create mode 100644 src/n2/render.ml
 create mode 100644 src/n2/scene.ml
 create mode 100644 src/n2/trans.ml
 create mode 100644 src/n2/types.ml

diff --git a/src/main.ml b/src/main.ml
index ae91e49..2a0a694 100644
--- a/src/main.ml
+++ b/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;
 
diff --git a/src/n2/import.ml b/src/n2/import.ml
new file mode 100644
index 0000000..0cd62e4
--- /dev/null
+++ b/src/n2/import.ml
@@ -0,0 +1,3 @@
+include Adam
+include S2
+include (val Ohlog.logs "N2")
diff --git a/src/n2/n2.ml b/src/n2/n2.ml
index 222dcf5..18a7727 100644
--- a/src/n2/n2.ml
+++ b/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
diff --git a/src/n2/n2.mli b/src/n2/n2.mli
index 2e1d15b..59eb895 100644
--- a/src/n2/n2.mli
+++ b/src/n2/n2.mli
@@ -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
diff --git a/src/n2/render.ml b/src/n2/render.ml
new file mode 100644
index 0000000..bde9dcf
--- /dev/null
+++ b/src/n2/render.ml
@@ -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
diff --git a/src/n2/scene.ml b/src/n2/scene.ml
new file mode 100644
index 0000000..b990e2c
--- /dev/null
+++ b/src/n2/scene.ml
@@ -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 =
+  ()
diff --git a/src/n2/trans.ml b/src/n2/trans.ml
new file mode 100644
index 0000000..3acbf54
--- /dev/null
+++ b/src/n2/trans.ml
@@ -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
diff --git a/src/n2/types.ml b/src/n2/types.ml
new file mode 100644
index 0000000..51b7aa8
--- /dev/null
+++ b/src/n2/types.ml
@@ -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