Support entity groups

2 files changed, 57 insertions, 0 deletions

diff --git a/tests/prefabs-test.scm b/tests/prefabs-test.scm
index 6ccc473..8a1e5b0 100644
--- a/tests/prefabs-test.scm
+++ b/tests/prefabs-test.scm
@@ -152,6 +152,7 @@
                   prefabs:            (list (cons 'proc-hooked
                                                  (list #:type 'proc-hooked
                                                        #:on-instantiate hook-proc)))
+                  group-prefabs:      '()
                   file:               "/dev/null"
                   engine-mixin-table: '()
                   user-hooks:         '()
@@ -215,4 +216,43 @@
     (test-equal "reloaded registry has #:value 42" 42 (entity-ref e2 #:value))
     (test-equal "original registry unchanged after reload" 1 (entity-ref e1 #:value))))
 
+(test-group "group-prefabs"
+  (define (with-group-prefab-data str thunk)
+    (let ((tmp "/tmp/test-group-prefabs.scm"))
+      (with-output-to-file tmp (lambda () (display str)))
+      (thunk (load-prefabs tmp (engine-mixins) '()))))
+
+  (with-group-prefab-data
+    "((mixins) (prefabs)
+      (group-prefabs
+        (two-block #:pose-only-origin? #t #:static-parts? #t #:type-members segment
+          #:parts ((#:local-x 0 #:local-y 0 #:width 10 #:height 8 #:tile-id 1)
+                   (#:local-x 10 #:local-y 0 #:width 10 #:height 8 #:tile-id 2)))))"
+    (lambda (reg)
+      (test-assert "instantiate-group-prefab unknown → #f"
+        (not (instantiate-group-prefab reg 'nope 0 0)))
+      (let ((lst (instantiate-group-prefab reg 'two-block 100 50)))
+        (test-equal "returns list of origin + 2 members" 3 (length lst))
+        (let ((origin (car lst))
+              (a (cadr lst))
+              (b (caddr lst)))
+          (test-equal "pose-only origin skip-render" #t (entity-ref origin #:skip-render))
+          (test-equal "origin group-origin?" #t (entity-ref origin #:group-origin?))
+          (test-equal "member a world x" 100 (entity-ref a #:x))
+          (test-equal "member b world x" 110 (entity-ref b #:x))
+          (test-equal "member a local x" 0 (entity-ref a #:group-local-x))
+          (test-equal "member b local x" 10 (entity-ref b #:group-local-x))
+          (test-equal "shared group-id" (entity-ref origin #:group-id) (entity-ref a #:group-id))))))
+
+  (with-group-prefab-data
+    "((mixins) (prefabs)
+      (group-prefabs
+        (falling-asm #:pose-only-origin? #f #:static-parts? #t #:type-members part
+          #:parts ((#:local-x 0 #:local-y 0 #:width 4 #:height 4 #:tile-id 1)))))"
+    (lambda (reg)
+      (let ((origin (car (instantiate-group-prefab reg 'falling-asm 0 0))))
+        (test-equal "physics origin has gravity" #t (entity-ref origin #:gravity?))
+        (test-assert "physics origin has no #:skip-pipelines (pipelines run)"
+          (eq? 'absent (entity-ref origin #:skip-pipelines 'absent)))))))
+
 (test-end "prefabs")
diff --git a/tests/world-test.scm b/tests/world-test.scm
index b8c1a98..dbae9d9 100644
--- a/tests/world-test.scm
+++ b/tests/world-test.scm
@@ -277,4 +277,21 @@
       (test-equal "returns all friendly entities" 2 (length (scene-find-all-tagged s 'friendly)))
       (test-equal "returns empty list when none match" '() (scene-find-all-tagged s 'boss))))
 
+  (test-group "scene-sync-groups!"
+    (let* ((gid 'g1)
+           (origin (list #:type 'group-origin #:group-origin? #t #:group-id gid
+                         #:x 100 #:y 200 #:width 0 #:height 0))
+           (m1 (list #:type 'part #:group-id gid #:group-local-x 5 #:group-local-y 0
+                     #:x 0 #:y 0 #:width 8 #:height 8))
+           (m2 (list #:type 'part #:group-id gid #:group-local-x 0 #:group-local-y 7
+                     #:x 0 #:y 0 #:width 8 #:height 8))
+           (s (make-scene entities: (list origin m1 m2) tilemap: #f
+                          camera: (make-camera x: 0 y: 0) tileset-texture: #f camera-target: #f)))
+      (scene-sync-groups! s)
+      (let ((es (scene-entities s)))
+        (test-equal "member 1 follows origin" 105 (entity-ref (list-ref es 1) #:x))
+        (test-equal "member 1 y" 200 (entity-ref (list-ref es 1) #:y))
+        (test-equal "member 2 x" 100 (entity-ref (list-ref es 2) #:x))
+        (test-equal "member 2 y" 207 (entity-ref (list-ref es 2) #:y)))))
+
 (test-end "world-module")