refactor: improve ergonomics of query syntax

claby2 · Jan 8, 2025 · 89b675c · 89b675c
1 parent d742257
commit 89b675c
Show file tree

Hide file tree

Showing 16 changed files with 105 additions and 84 deletions.
diff --git a/bench/bench_ecs.ml b/bench/bench_ecs.ml
@@ -46,7 +46,7 @@ let t3 =
       fun () ->
         let results =
           World.query world
-            Query.(Required (module Foo.C) ^^ Required (module Bar.C) ^^ QNil)
+            Query.(Req (module Foo.C) @ Req (module Bar.C) @ Nil)
         in
         assert (List.length results = param))
 

diff --git a/examples/bounce.ml b/examples/bounce.ml
@@ -27,13 +27,11 @@ end
 
 let simulate_ball =
   let query w =
-    let _, (b, (t, ())) =
-      World.query w
-        Query.(
-          Required (module Transform.C) ^^ Required (module Ball.C) ^^ QNil)
+    let _, (t, (b, ())) =
+      World.query w Query.(Req (module Transform.C) @ Req (module Ball.C) @ Nil)
       |> List.hd
     in
-    (b, t)
+    (t, b)
   in
   let dt = 0.00000005 in
   let simulate (transform, ball) =
@@ -57,13 +55,10 @@ let simulate_ball =
 let restart_ball =
   let query w =
     let _, (k, ()) =
-      World.query w Query.(Required (module Input.Keyboard.C) ^^ QNil)
-      |> List.hd
+      World.query w Query.(Req (module Input.Keyboard.C) @ Nil) |> List.hd
     in
     let _, (t, (b, ())) =
-      World.query w
-        Query.(
-          Required (module Transform.C) ^^ Required (module Ball.C) ^^ QNil)
+      World.query w Query.(Req (module Transform.C) @ Req (module Ball.C) @ Nil)
       |> List.hd
     in
     (k, t, b)

diff --git a/examples/first_person.ml b/examples/first_person.ml
@@ -13,8 +13,7 @@ let setup_window =
   System.make
     (fun w ->
       let _, (c, ()) =
-        World.query w Query.(Required (module Graphics.Context.C) ^^ QNil)
-        |> List.hd
+        World.query w Query.(Req (module Graphics.Context.C) @ Nil) |> List.hd
       in
       c)
     (System.Query
@@ -37,12 +36,11 @@ let handle_keyboard =
   let query w =
     let _, (t, ()) =
       World.query ~filter:(Query.Filter.With FirstPersonCamera.C.id) w
-        Query.(Required (module Transform.C) ^^ QNil)
+        Query.(Req (module Transform.C) @ Nil)
       |> List.hd
     in
     let _, (k, ()) =
-      World.query w Query.(Required (module Input.Keyboard.C) ^^ QNil)
-      |> List.hd
+      World.query w Query.(Req (module Input.Keyboard.C) @ Nil) |> List.hd
     in
     (t, k)
   in
@@ -76,11 +74,11 @@ let handle_mouse =
   let query w =
     let _, (t, ()) =
       World.query ~filter:(Query.Filter.With FirstPersonCamera.C.id) w
-        Query.(Required (module Transform.C) ^^ QNil)
+        Query.(Req (module Transform.C) @ Nil)
       |> List.hd
     in
     let _, (mm, ()) =
-      World.query w Query.(Required (module Input.Mouse.Motion_event.C) ^^ QNil)
+      World.query w Query.(Req (module Input.Mouse.Motion_event.C) @ Nil)
       |> List.hd
     in
     (t, mm)

diff --git a/examples/move.ml b/examples/move.ml
@@ -15,12 +15,11 @@ let move_ball =
   let query w =
     let transforms =
       World.query ~filter:(Query.Filter.With Ball.C.id) w
-        Query.(Required (module Transform.C) ^^ QNil)
+        Query.(Req (module Transform.C) @ Nil)
       |> List.map (fun (_, (t, ())) -> t)
     in
     let _, (k, ()) =
-      World.query w Query.(Required (module Input.Keyboard.C) ^^ QNil)
-      |> List.hd
+      World.query w Query.(Req (module Input.Keyboard.C) @ Nil) |> List.hd
     in
     (transforms, k)
   in

diff --git a/examples/shapes.ml b/examples/shapes.ml
@@ -17,7 +17,7 @@ let rotate =
   let query w =
     let transforms =
       World.query ~filter:(Query.Filter.With Shape.C.id) w
-        Query.(Required (module Transform.C) ^^ QNil)
+        Query.(Req (module Transform.C) @ Nil)
       |> List.map (fun (_, (t, ())) -> t)
     in
     transforms

diff --git a/examples/spawn.ml b/examples/spawn.ml
@@ -26,8 +26,7 @@ let add_random_ball w =
 let handle_spawn =
   let query w =
     let _, (mb, ()) =
-      World.query w Query.(Required (module Input.Mouse.Button.C) ^^ QNil)
-      |> List.hd
+      World.query w Query.(Req (module Input.Mouse.Button.C) @ Nil) |> List.hd
     in
     mb
   in

diff --git a/lib/ecs/event.ml b/lib/ecs/event.ml
@@ -29,9 +29,7 @@ end) : S with type event = B.t = struct
   end)
 
   let querier w =
-    let _, (t, ()) =
-      World.query w Query.(Required (module C) ^^ QNil) |> List.hd
-    in
+    let _, (t, ()) = World.query w Query.(Req (module C) @ Nil) |> List.hd in
     t
 
   let clear_system =

diff --git a/lib/ecs/query.ml b/lib/ecs/query.ml
@@ -7,7 +7,6 @@ module Filter = struct
     | Or of t * t
     | Wildcard
 
-  (* Returns true if the given component set matches the filter *)
   let matches f components =
     let rec aux f components =
       match f with
@@ -22,18 +21,15 @@ module Filter = struct
 end
 
 type _ term =
-  | Required : (module Component.S with type t = 'a) -> 'a term
-  | Optional : (module Component.S with type t = 'a) -> 'a option term
+  | Req : (module Component.S with type t = 'a) -> 'a term
+  | Opt : (module Component.S with type t = 'a) -> 'a option term
 
-type _ t = QNil : unit t | QCons : 'a term * 'b t -> ('a * 'b) t
-(* TODO: ALTERNATIVELY
-type _ t = QSingle : 'a term -> 'a t | QCons : 'a term * 'b t -> ('a * 'b) t*)
+type _ t = Nil : unit t | Cons : 'a term * 'b t -> ('a * 'b) t
 
-let rec required : type a. a t -> _ = function
-  | QNil -> Id.ComponentSet.empty
-  | QCons (Required (module C), rest) ->
-      Id.ComponentSet.add C.id (required rest)
-  | QCons (Optional (module C), rest) -> required rest
+let rec required_ids : type a. a t -> _ = function
+  | Nil -> Id.ComponentSet.empty
+  | Cons (Req (module C), rest) -> Id.ComponentSet.add C.id (required_ids rest)
+  | Cons (Opt (module C), rest) -> required_ids rest
 
 let evaluate : type a.
     ?filter:Filter.t -> a t -> Archetype.t list -> (Id.Entity.t * a) list =
@@ -42,13 +38,13 @@ let evaluate : type a.
    fun q a e ->
     let get_component = Archetype.query a e in
     match q with
-    | QNil -> ()
-    | QCons (Required (module C), rest) ->
+    | Nil -> ()
+    | Cons (Req (module C), rest) ->
         let c =
           get_component C.id |> Option.get |> Component.unpack (module C)
         in
         (c, fetch rest a e)
-    | QCons (Optional (module C), rest) ->
+    | Cons (Opt (module C), rest) ->
         (* TODO: Rethink this maybe *)
         let c =
           get_component C.id
@@ -57,9 +53,9 @@ let evaluate : type a.
         in
         (c, fetch rest a e)
   in
-  let required = required query in
+  let required_ids = required_ids query in
   let is_candidate a =
-    Id.ComponentSet.subset required (Archetype.components a)
+    Id.ComponentSet.subset required_ids (Archetype.components a)
     && Filter.matches filter (Archetype.components a)
   in
 
@@ -70,8 +66,4 @@ let evaluate : type a.
 
   archetypes |> List.filter is_candidate |> List.concat_map build_result
 
-type _ set =
-  | Single : 'a. 'a t -> (Id.Entity.t * 'a) list set
-  | Cons : 'a t * 'b set -> ('a t * 'b) set
-
-let ( ^^ ) comp rest = QCons (comp, rest) (* Infix for QCons *)
+let ( @ ) comp rest = Cons (comp, rest) (* Infix for QCons *)
diff --git a/lib/ecs/query.mli b/lib/ecs/query.mli
@@ -0,0 +1,35 @@
+(** Construct and evaluate queries. *)
+
+(** A filter that can be used to filter entities based on their components. *)
+module Filter : sig
+  type t =
+    | With of Id.Component.t
+    | Without of Id.Component.t
+    | Not of t
+    | And of t * t
+    | Or of t * t
+    | Wildcard
+
+  val matches : t -> Id.ComponentSet.t -> bool
+  (** Returns true if the given component set matches the filter. *)
+end
+
+(** A query term that can be used to construct queries. *)
+type 'a term =
+  | Req : (module Component.S with type t = 'a) -> 'a term
+      (** A required component must be present in an entity. *)
+  | Opt : (module Component.S with type t = 'a) -> 'a option term
+      (** An optional component will be None if an entity does not have it. *)
+
+(** The type of a query. *)
+type 'a t = Nil : unit t | Cons : 'a term * 'b t -> ('a * 'b) t
+
+val required_ids : 'a t -> Id.ComponentSet.t
+(** Returns the set of required component IDs for the given query. *)
+
+val evaluate :
+  ?filter:Filter.t -> 'a t -> Archetype.t list -> (Id.Entity.t * 'a) list
+(** Evaluates the given query on the given archetypes. *)
+
+val ( @ ) : 'a term -> 'b t -> ('a * 'b) t
+(** Composes query terms. *)
diff --git a/lib/ecs/system.mli b/lib/ecs/system.mli
@@ -0,0 +1,18 @@
+(** Define systems that query and operate on the world. *)
+
+(** An operation that can be performed on the world. *)
+type ('world, 'a) operation =
+  | Query of ('a -> unit)
+  | Immediate of ('world -> 'a -> unit)
+
+type 'world t
+(** The type of a system. *)
+
+val make : ('world -> 'a) -> ('world, 'a) operation -> 'world t
+(** Make a system from a querier and an operation. *)
+
+val task : ('world, unit) operation -> 'world t
+(** Make a system that does not query the world. *)
+
+val run : 'world -> 'world t -> unit
+(** Run a system on the world. *)
diff --git a/lib/ecs/world.ml b/lib/ecs/world.ml
@@ -126,7 +126,7 @@ let add_system w schedule system =
   Scheduler.register w.scheduler schedule system
 
 let query ?(filter = Query.Filter.Wildcard) w (query : 'a Query.t) =
-  let required = Query.required query in
+  let required_ids = Query.required_ids query in
   let intersection_opt acc c =
     let set =
       match Hashtbl.find_opt w.component_index c with
@@ -138,14 +138,14 @@ let query ?(filter = Query.Filter.Wildcard) w (query : 'a Query.t) =
     | None -> Some set
   in
   let candidate_archetypes =
-    if Id.ComponentSet.is_empty required then
+    if Id.ComponentSet.is_empty required_ids then
       (* There are no required components, so the candidate archetypes is the set of all archetypes *)
       Hashtbl.to_seq_values w.archetype_index |> List.of_seq
     else
       (* There are required components, so the candidate archetypes is the intersection of the sets
          of archetypes that contain each required component *)
       (* TODO: Check this *)
-      required |> Id.ComponentSet.to_list
+      required_ids |> Id.ComponentSet.to_list
       |> List.fold_left intersection_opt None
       |> Option.value ~default:ArchetypeHashSet.empty
       |> ArchetypeHashSet.to_list

diff --git a/lib/graphics/graphics.ml b/lib/graphics/graphics.ml
@@ -14,7 +14,7 @@ let initialize ~gl =
     (fun w ->
       let open Ecs in
       let _, (c, ()) =
-        World.query w Query.(Required (module Context.C) ^^ QNil) |> List.hd
+        World.query w Query.(Req (module Context.C) @ Nil) |> List.hd
       in
       c)
     (Ecs.System.Query
@@ -28,7 +28,7 @@ let render =
     (fun w ->
       let open Ecs in
       let _, (c, ()) =
-        World.query w Query.(Required (module Context.C) ^^ QNil) |> List.hd
+        World.query w Query.(Req (module Context.C) @ Nil) |> List.hd
       in
       c)
     (Ecs.System.Query
@@ -42,10 +42,8 @@ let handle_events =
   Ecs.System.make
     (fun w ->
       let open Ecs in
-      let c = World.query w Query.(Required (module Context.C) ^^ QNil) in
-      let we =
-        World.query w Query.(Required (module Input.Window_event.C) ^^ QNil)
-      in
+      let c = World.query w Query.(Req (module Context.C) @ Nil) in
+      let we = World.query w Query.(Req (module Input.Window_event.C) @ Nil) in
       ( List.nth_opt c 0 |> Option.map (fun (_, (c, ())) -> c),
         List.nth_opt we 0 |> Option.map (fun (_, (we, ())) -> we) ))
     (Ecs.System.Query
@@ -77,9 +75,9 @@ let cleanup =
     (fun w ->
       let open Ecs in
       let c_entity, (c, ()) =
-        World.query w Query.(Required (module Context.C) ^^ QNil) |> List.hd
+        World.query w Query.(Req (module Context.C) @ Nil) |> List.hd
       in
-      let m3d = World.query w Query.(Required (module Mesh3d.C) ^^ QNil) in
+      let m3d = World.query w Query.(Req (module Mesh3d.C) @ Nil) in
       (c_entity, c, List.map (fun (_, (m3d, ())) -> m3d) m3d))
     (Ecs.System.Immediate
        (fun w ->

diff --git a/lib/graphics/shader/normal.ml b/lib/graphics/shader/normal.ml
@@ -36,15 +36,11 @@ let query w =
   let open Ecs in
   let cameras =
     World.query ~filter:(Query.Filter.With Camera.Camera3d.C.id) w
-      Query.(
-        Required (module Camera.Projection.C)
-        ^^ Optional (module Transform.C)
-        ^^ QNil)
+      Query.(Req (module Camera.Projection.C) @ Opt (module Transform.C) @ Nil)
   in
   let entities =
     World.query ~filter:(Query.Filter.With C.id) w
-      Query.(
-        Required (module Mesh3d.C) ^^ Optional (module Transform.C) ^^ QNil)
+      Query.(Req (module Mesh3d.C) @ Opt (module Transform.C) @ Nil)
   in
   ( List.map (fun (_, (c, (t, ()))) -> (c, t)) cameras,
     List.map (fun (_, (m, (t, ()))) -> (m, t)) entities )

diff --git a/lib/input/button_state.ml b/lib/input/button_state.ml
@@ -58,10 +58,10 @@ module Make (B : Button.S) (E : Ecs.Event.S with type event = B.t) :
     let query w =
       let open Ecs in
       let _, (event, ()) =
-        World.query w Query.(Required (module E.C) ^^ QNil) |> List.hd
+        World.query w Query.(Req (module E.C) @ Nil) |> List.hd
       in
       let _, (state, ()) =
-        World.query w Query.(Required (module C) ^^ QNil) |> List.hd
+        World.query w Query.(Req (module C) @ Nil) |> List.hd
       in
       (event, state)
     in

diff --git a/lib/input/input.ml b/lib/input/input.ml
@@ -33,18 +33,16 @@ let write_events =
   let query w =
     let open Ecs in
     let _, (ke, ()) =
-      World.query w Query.(Required (module Key_event.C) ^^ QNil) |> List.hd
+      World.query w Query.(Req (module Key_event.C) @ Nil) |> List.hd
     in
     let _, (we, ()) =
-      World.query w Query.(Required (module Window_event.C) ^^ QNil) |> List.hd
+      World.query w Query.(Req (module Window_event.C) @ Nil) |> List.hd
     in
     let _, (mb, ()) =
-      World.query w Query.(Required (module Mouse.Button_event.C) ^^ QNil)
-      |> List.hd
+      World.query w Query.(Req (module Mouse.Button_event.C) @ Nil) |> List.hd
     in
     let _, (mm, ()) =
-      World.query w Query.(Required (module Mouse.Motion_event.C) ^^ QNil)
-      |> List.hd
+      World.query w Query.(Req (module Mouse.Motion_event.C) @ Nil) |> List.hd
     in
     (ke, we, mb, mm)
   in