diff options
| -rw-r--r-- | entity.scm | 97 | ||||
| -rw-r--r-- | prefabs.scm | 2 | ||||
| -rw-r--r-- | tests/entity-test.scm | 37 | ||||
| -rw-r--r-- | tests/input-test.scm | 12 | ||||
| -rw-r--r-- | tests/physics-test.scm | 2 | ||||
| -rw-r--r-- | tests/prefabs-test.scm | 3 | ||||
| -rw-r--r-- | tests/world-test.scm | 6 |
7 files changed, 68 insertions, 91 deletions
@@ -7,8 +7,11 @@ ;; Entities = plists with shared keys (#:type, #:x, #:y, #:width, #:height, ...). - (define (entity-ref entity key #!optional default) - (get-keyword key entity (if (procedure? default) default (lambda () default)))) +(define (make-entity x y w h) + (list #:type 'none #:x x #:y y #:width w #:height h)) + +(define (entity-ref entity key #!optional default) + (get-keyword key entity (if (procedure? default) default (lambda () default)))) (define (entity-type entity) (entity-ref entity #:type #f)) @@ -36,57 +39,43 @@ (let ((skips (entity-ref entity #:skip-pipelines '()))) (and (pair? skips) (memq step skips)))) - ;; er-macro-transformer so (rename 'entity-skips-pipeline?) captures the - ;; binding from THIS module — works across compiled unit boundaries. - ;; - ;; Syntax: - ;; (define-pipeline (name skip-sym) (entity-formal ...) - ;; guard: guard-expr ;; optional — entity returned unchanged when #f - ;; body ...) - (define-syntax define-pipeline - (er-macro-transformer - (lambda (form rename _compare) - (let* ((name-skip (cadr form)) - (name (car name-skip)) - (skip (cadr name-skip)) - (formals (caddr form)) - (f1 (car formals)) - (rest (cdddr form)) - (has-guard? (and (pair? rest) (pair? (cdr rest)) - (eq? (car rest) guard:))) - (guard-expr (and has-guard? (cadr rest))) - (body (if has-guard? (cddr rest) rest)) - (%define (rename 'define)) - (%if (rename 'if)) - (%let (rename 'let)) - (%not (rename 'not)) - (%quote (rename 'quote)) - (%skip? (rename 'entity-skips-pipeline?))) - (if has-guard? - `(,%define (,name ,@formals) - (,%if (,%skip? ,f1 (,%quote ,skip)) - ,f1 - (,%if (,%not ,guard-expr) - ,f1 - (,%let () ,@body)))) - `(,%define (,name ,@formals) - (,%if (,%skip? ,f1 (,%quote ,skip)) - ,f1 - (,%let () ,@body)))))))) +;; er-macro-transformer so (rename 'entity-skips-pipeline?) captures the +;; binding from THIS module — works across compiled unit boundaries. +;; +;; Syntax: +;; (define-pipeline (name skip-sym) (entity-formal ...) +;; guard: guard-expr ;; optional — entity returned unchanged when #f +;; body ...) +(define-syntax define-pipeline + (er-macro-transformer + (lambda (form rename _compare) + (let* ((name-skip (cadr form)) + (name (car name-skip)) + (skip (cadr name-skip)) + (formals (caddr form)) + (f1 (car formals)) + (rest (cdddr form)) + (has-guard? (and (pair? rest) (pair? (cdr rest)) + (eq? (car rest) guard:))) + (guard-expr (and has-guard? (cadr rest))) + (body (if has-guard? (cddr rest) rest)) + (%define (rename 'define)) + (%if (rename 'if)) + (%let (rename 'let)) + (%not (rename 'not)) + (%quote (rename 'quote)) + (%skip? (rename 'entity-skips-pipeline?))) + (if has-guard? + `(,%define (,name ,@formals) + (,%if (,%skip? ,f1 (,%quote ,skip)) + ,f1 + (,%if (,%not ,guard-expr) + ,f1 + (,%let () ,@body)))) + `(,%define (,name ,@formals) + (,%if (,%skip? ,f1 (,%quote ,skip)) + ,f1 + (,%let () ,@body)))))))) - (define (make-player-entity x y width height) - (list #:type 'player - #:x x - #:y y - #:width width - #:height height - #:vx 0 - #:vy 0 - #:gravity? #t - #:on-ground? #f - #:tile-id 29 - #:input-map '((left . (-2 . 0)) - (right . ( 2 . 0)) - (down . ( 0 . 2))))) -) +) ;; End of entity diff --git a/prefabs.scm b/prefabs.scm index 585d4b5..798375a 100644 --- a/prefabs.scm +++ b/prefabs.scm @@ -114,7 +114,7 @@ (if (not entry) #f ;; instance fields prepended → highest priority - (let* ((base (append (list #:x x #:y y #:width w #:height h) + (let* ((base (append (make-entity x y w h) (cdr entry))) (hook-val (entity-ref base #:on-instantiate #f)) (handler diff --git a/tests/entity-test.scm b/tests/entity-test.scm index 795aa1c..270555c 100644 --- a/tests/entity-test.scm +++ b/tests/entity-test.scm @@ -29,6 +29,15 @@ 42 (entity-ref entity #:x (lambda () 42))))) +;; Test: make-player-entity creates valid player entity +(test-group "make-entity" + (let ((player (make-entity 50 75 16 16))) + (test-assert "returns a list" (list? player)) + (test-equal "has correct x" 50 (entity-ref player #:x)) + (test-equal "has correct y" 75 (entity-ref player #:y)) + (test-equal "has correct width" 16 (entity-ref player #:width)) + (test-equal "has correct height" 16 (entity-ref player #:height)))) + ;; Test: entity-type extracts type from entity (test-group "entity-type" (let ((player '(#:type player #:x 100)) @@ -38,19 +47,8 @@ (let ((no-type '(#:x 100 #:y 200))) (test-equal "returns #f for entity without type" - #f - (entity-type no-type)))) - -;; Test: make-player-entity creates valid player entity -(test-group "make-player-entity" - (let ((player (make-player-entity 50 75 16 16))) - (test-assert "returns a list" (list? player)) - (test-equal "has correct type" 'player (entity-ref player #:type)) - (test-equal "has correct x" 50 (entity-ref player #:x)) - (test-equal "has correct y" 75 (entity-ref player #:y)) - (test-equal "has correct width" 16 (entity-ref player #:width)) - (test-equal "has correct height" 16 (entity-ref player #:height)) - (test-equal "has initial tile-id" 29 (entity-ref player #:tile-id)))) + #f + (entity-type no-type)))) ;; Test: complex entity with multiple properties (test-group "complex-entity" @@ -100,19 +98,6 @@ (let ((e (entity-update '(#:x 10 #:y 20) #:x (lambda (v) (* v 2))))) (test-equal "length is 4" 4 (length e))))) -;; Test: make-player-entity velocity fields -(test-group "make-player-entity-velocity-fields" - (let* ((p (make-player-entity 5 10 16 16)) - (imap (entity-ref p #:input-map #f))) - (test-equal "vx defaults to 0" 0 (entity-ref p #:vx)) - (test-equal "vy defaults to 0" 0 (entity-ref p #:vy)) - (test-assert "input-map is present" imap) - ;; Each entry is (action . (dvx . dvy)); assq returns (action . (dvx . dvy)) - (test-equal "left dvx" -2 (car (cdr (assq 'left imap)))) - (test-equal "left dvy" 0 (cdr (cdr (assq 'left imap)))) - (test-equal "right dvx" 2 (car (cdr (assq 'right imap)))) - (test-equal "right dvy" 0 (cdr (cdr (assq 'right imap)))))) - (test-group "entity-skips-pipeline?" (test-assert "absent skip list" (not (entity-skips-pipeline? '(#:type a) 'gravity))) diff --git a/tests/input-test.scm b/tests/input-test.scm index 2173f61..44af6e8 100644 --- a/tests/input-test.scm +++ b/tests/input-test.scm @@ -125,35 +125,35 @@ (test-equal "entity returned as-is" e out))) (test-group "no actions held: velocity is zero" - (let* ((e (make-player-entity 0 0 16 16)) + (let* ((e (make-entity 0 0 16 16)) (out (apply-input-to-entity e (lambda (a) #f)))) (test-equal "vx is 0" 0 (entity-ref out #:vx)) (test-equal "vy is 0" 0 (entity-ref out #:vy)))) (test-group "right held: vx=2 vy=0" - (let* ((e (make-player-entity 0 0 16 16)) + (let* ((e (make-entity 0 0 16 16)) (out (apply-input-to-entity e (lambda (a) (eq? a 'right))))) (test-equal "vx is 2" 2 (entity-ref out #:vx)) (test-equal "vy is 0" 0 (entity-ref out #:vy)))) (test-group "right+down held: vx=2 vy unchanged" - (let* ((e (make-player-entity 0 0 16 16)) + (let* ((e (make-entity 0 0 16 16)) (out (apply-input-to-entity e (lambda (a) (memv a '(right down)))))) (test-equal "vx is 2" 2 (entity-ref out #:vx)) (test-equal "vy is unchanged (input handler does not set vy)" 0 (entity-ref out #:vy)))) (test-group "right held: facing set to 1" - (let* ((e (make-player-entity 0 0 16 16)) + (let* ((e (make-entity 0 0 16 16)) (out (apply-input-to-entity e (lambda (a) (eq? a 'right))))) (test-equal "facing is 1" 1 (entity-ref out #:facing 0)))) (test-group "left held: facing set to -1" - (let* ((e (make-player-entity 0 0 16 16)) + (let* ((e (make-entity 0 0 16 16)) (out (apply-input-to-entity e (lambda (a) (eq? a 'left))))) (test-equal "facing is -1" -1 (entity-ref out #:facing 0)))) (test-group "no key held: facing retains previous value" - (let* ((e (entity-set (make-player-entity 0 0 16 16) #:facing 1)) + (let* ((e (entity-set (make-entity 0 0 16 16) #:facing 1)) (out (apply-input-to-entity e (lambda (a) #f)))) (test-equal "facing stays 1 when vx=0" 1 (entity-ref out #:facing 0))))) diff --git a/tests/physics-test.scm b/tests/physics-test.scm index 6d1da86..88ddcce 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -341,7 +341,7 @@ (solid-row (make-list 15 1)) (rows (append (make-list 24 empty-row) (list solid-row))) (tm (make-test-tilemap rows)) - (e0 (make-player-entity 182 350.5 16 16))) + (e0 (make-entity 182 350.5 16 16))) ;; Should not crash (let loop ((e e0) (n 5)) (if (= n 0) diff --git a/tests/prefabs-test.scm b/tests/prefabs-test.scm index 8a1e5b0..f8cec0a 100644 --- a/tests/prefabs-test.scm +++ b/tests/prefabs-test.scm @@ -31,6 +31,9 @@ (import downstroke-ai) ;; Load module under test +(include "entity.scm") +(import downstroke-entity) + (include "prefabs.scm") (import downstroke-prefabs) diff --git a/tests/world-test.scm b/tests/world-test.scm index 48f492a..557a121 100644 --- a/tests/world-test.scm +++ b/tests/world-test.scm @@ -110,7 +110,7 @@ ;; Test: scene with entities and tilemap (test-group "scene-with-data" - (let* ((player (make-player-entity 100 100 16 16)) + (let* ((player (make-entity 100 100 16 16)) (enemy '(#:type enemy #:x 200 #:y 200)) (tilemap "mock-tilemap") (scene (make-scene entities: (list player enemy) @@ -128,7 +128,7 @@ ;; Test: scene-add-entity adds entity to scene (test-group "scene-add-entity" - (let* ((player (make-player-entity 100 100 16 16)) + (let* ((player (make-entity 100 100 16 16)) (scene (make-scene entities: (list player) tilemap: #f camera-target: #f)) (enemy '(#:type enemy #:x 200 #:y 200))) @@ -194,7 +194,7 @@ ;; Test: scene chaining (was mutation test) (test-group "scene-chaining" (let* ((scene (make-scene entities: '() tilemap: #f camera-target: #f)) - (player (make-player-entity 10 20 16 16)) + (player (make-entity 10 20 16 16)) (scene (scene-add-entity scene player))) (test-equal "entity added" 1 (length (scene-entities scene))) |