Add tests for systems

modules/ces/system.scm

@@ -66,7 +66,7 @@
                entity-removed-hook
                name))
 
-(define (system-applicable-to-entity? entity system)
+(define (system-applicable-to-entity? system entity)
   (and (game-entity? entity)
        (system? system)
        ((system-predicate? system) entity)))
@@ -83,13 +83,12 @@ process proceedure."
     wrapped-proc))
 
 (define (run-system-on-entity! system dt entity . entities)
-  (if (system? system)
-      (unless (null? entity)
-        (let ((run-proc (system-process-entity system))
-              (wants-entity? (system-predicate? system)))
-          (when (wants-entity? entity)
-            (run-proc entity dt))
-          (when (list? entities)
-            (run-system-on-entity! system dt (car entities) (cdr entities)))))
+  (if (and (system? system)
+           (game-entity? entity))
+      (let ((run-proc (system-process-entity system)))
+        (when (system-applicable-to-entity? system entity)
+          (run-proc entity dt))
+        (unless (eqv? entities '())
+          (apply run-system-on-entity! system dt entities)))
       (error "Invalid inputs passed to system:run-system-on-entity!"
              system entity dt)))

test/tests/system-tests.scm

@@ -1,16 +1,119 @@
 (import (srfi srfi-64)
-        (test-runner)
         (scheme base)
         (scheme write)
 
         (ces system)
-        (hoot hashtables)
-        (logging))
+        (ces component)
+        (ces entity)
+        (ces entity-manager)
+        (game-core)
+        (logging)
+        (test-runner)
+
+        (hoot debug)
+        (hoot hashtables))
+
+(define (const val)
+  (lambda (_ . rest) val))
+
+;; Returns an entity, a system, and a proceedure to activate the system by
+;; running the system with the entitiy and a dt. System-proc must take two arguments,
+;; an entity and an integer. The predicate for the system is true only if passed
+;; the entity returned by this proc.
+(define (instrumented-system-constructor system-proc)
+  (let ((entity (create-entity 7))
+        (result 'not-run))
+    (values entity
+            (create-system
+             (lambda (x) (eq? entity x))
+             (lambda (e dt)
+               (set! result (system-proc e dt)))
+             'test-system)
+            (lambda () result))))
+
+;; Creates a system which accepts entities only with every named component
+;; The system-proc is just a lambda which does nothing and returns true
+(define (create-component-focused-system c-one c-two)
+  (create-system
+   (lambda (e)
+     (and (has-component? e c-one)
+          (has-component? e c-two)))
+   (lambda (e dt) #t)
+   'component-test-system))
 
 
 (test-runner-factory game-engine-test-runner)
 
 (test-begin "test-system")
-(test-begin "test-system")
+
+;; Checking 'system-applicable-to-entity?'
+(let-values (((entity sys results) (instrumented-system-constructor (const 'ran))))
+
+  (test-begin "system-applicable-to-entity?")
+  (test-assert "fixed-entity-true-when-passed-entity" (system-applicable-to-entity? sys entity))
+  (test-eq "fixed-entity-false-when-passed-other-entity" #f
+           (system-applicable-to-entity? sys (copy-entity entity)))
+
+  (let ((entity-with-components (create-entity 10 '((first . v)
+                                                    (second . v2))))
+        (component-system (create-component-focused-system 'first 'second)))
+    
+    (test-assert "true-when-matching-components"
+      (system-applicable-to-entity? component-system entity-with-components))
+    (test-assert "additional-component-does-not-affect-subset-selection"
+      (system-applicable-to-entity?
+       component-system
+       (set-component entity-with-components 'third 'huzzah))))
+  (test-end)
+
+  (test-begin "run-system-on-entity!")
+  
+  (let-values (((entity sys results) (instrumented-system-constructor (const 'ran))))
+    (test-eq "compatable-entity-get-executed" 'ran
+             (begin
+               (run-system-on-entity! sys 0 entity)
+               (results))))
+
+  (let-values (((entity sys results)
+                (instrumented-system-constructor
+                 (lambda (e dt)
+                   (let ((e-manager (get-entity-manager)))
+                     (if e-manager
+                         (begin
+                           (add-entity! e-manager entity)
+                           'em-exists)
+                         'em-not-found))))))
+
+    ;; Internal test to make sure the instrumentation is correct
+    (test-eq "%does-nothing-when-entity-manager-not-found%"
+      'em-not-found
+      (begin
+        (run-system-on-entity! sys 0 entity)
+        (results)))
+
+    (parameterize ((*entity-manager-parameter* (create-entity-manager)))
+      (test-eq "%runs-when-entity-manager-parameter-set%"
+        'em-exists
+        (begin
+          (run-system-on-entity! sys 0 entity)
+          (results)))) 
+
+    (parameterize ((*entity-manager-parameter* (create-entity-manager)))
+      (test-eq "system-can-add-entity-to-parameterized-entity-manager" 1
+               (begin
+                 (run-system-on-entity! sys 0 entity)
+                 (vector-length (get-updated-entities (get-entity-manager))))))
+
+    ;; We want to make sure that the entity-manager-parameter system
+    ;; works for system calls.
+    (test-eq "system-does-not-affect-non-parameterized-entity-manager" 0
+             (parameterize ((*entity-manager-parameter* (create-entity-manager)))
+               (parameterize ((*entity-manager-parameter* (create-entity-manager)))
+                 (run-system-on-entity! sys 0 entity))
+               (vector-length (get-updated-entities (get-entity-manager))))))
+
+  (test-end))
+
+(test-end "test-system")
 
 #t