path: root/tests/prefabs-test.scm

;; Base imports
(import scheme
        (chicken base)
        (chicken keyword)
        (chicken port)
        defstruct
        srfi-64)

;; Mock downstroke-entity
(module downstroke-entity *
  (import scheme (chicken base))
  (define (entity-ref entity key #!optional (default #f))
    (let loop ((plist entity))
      (cond
        ((null? plist) (if (procedure? default) (default) default))
        ((eq? (car plist) key) (cadr plist))
        (else (loop (cddr plist))))))
  (define (entity-set entity key val)
    (let loop ((plist entity) (acc '()))
      (cond
        ((null? plist) (reverse (cons val (cons key acc))))
        ((eq? (car plist) key) (append (reverse acc) (list key val) (cddr plist)))
        (else (loop (cddr plist) (cons (cadr plist) (cons (car plist) acc)))))))
  (define (entity-type entity) (entity-ref entity #:type #f)))
(import downstroke-entity)

;; Mock downstroke-ai
(module downstroke-ai *
  (import scheme (chicken base))
  (define (make-enemy-ai-machine) 'mock-ai-machine))
(import downstroke-ai)

;; Load module under test
(include "prefabs.scm")
(import downstroke-prefabs)

(test-begin "prefabs")

(test-group "engine-mixins"
  (let ((m (engine-mixins)))
    (test-assert "returns a list" (list? m))
    (test-assert "physics-body entry exists" (assq 'physics-body m))
    (test-assert "has-facing entry exists"   (assq 'has-facing m))
    (test-assert "animated entry exists"     (assq 'animated m))
    (test-assert "ai-body entry exists"      (assq 'ai-body m))

    (let ((pb (cdr (assq 'physics-body m))))
      (test-equal "physics-body has #:vx 0"       0   (cadr (memq #:vx pb)))
      (test-equal "physics-body has #:gravity? #t" #t  (cadr (memq #:gravity? pb)))
      (test-equal "physics-body has #:on-ground? #f" #f (cadr (memq #:on-ground? pb))))

    (let ((an (cdr (assq 'animated m))))
      (test-equal "animated has #:anim-tick 0" 0 (cadr (memq #:anim-tick an)))
      (test-equal "animated has #:tile-id 0"   0 (cadr (memq #:tile-id an)))
      (test-equal "animated has #:anim-name idle" 'idle (cadr (memq #:anim-name an))))

    (let ((ai (cdr (assq 'ai-body m))))
      (test-equal "ai-body has #:ai-machine #f"     #f (cadr (memq #:ai-machine ai)))
      (test-equal "ai-body has #:disabled #f"       #f (cadr (memq #:disabled ai)))
      (test-equal "ai-body has #:chase-origin-x 0"   0 (cadr (memq #:chase-origin-x ai))))))

(test-group "compose-prefab (via load-prefabs with temp file)"

  ;; Helper: write a temp data file and load it
  (define (with-prefab-data str thunk)
    (let ((tmp "/tmp/test-prefabs.scm"))
      (with-output-to-file tmp (lambda () (display str)))
      (thunk (load-prefabs tmp (engine-mixins) '()))))

  (test-group "mixin merge priority"
    (with-prefab-data
      "((mixins (speed-mixin #:vx 5 #:vy 0))
        (prefabs (runner speed-mixin #:type runner #:vx 99)))"
      (lambda (reg)
        ;; Inline #:vx 99 beats mixin #:vx 5
        (let ((e (instantiate-prefab reg 'runner 0 0 16 16)))
          (test-equal "inline field beats mixin field for same key"
            99
            (entity-ref e #:vx))
          (test-equal "mixin field present when not overridden"
            0
            (entity-ref e #:vy))))))

  (test-group "left-to-right mixin priority"
    (with-prefab-data
      "((mixins (m1 #:key first) (m2 #:key second))
        (prefabs (thing m1 m2 #:type thing)))"
      (lambda (reg)
        ;; m1 listed before m2 → m1's #:key wins
        (let ((e (instantiate-prefab reg 'thing 0 0 8 8)))
          (test-equal "earlier mixin wins over later mixin for same key"
            'first
            (entity-ref e #:key))))))

  (test-group "user mixin overrides engine mixin by name"
    (with-prefab-data
      "((mixins (physics-body #:vx 77 #:vy 88))
        (prefabs (custom-obj physics-body #:type custom-obj)))"
      (lambda (reg)
        ;; User redefined physics-body → user's version wins
        (let ((e (instantiate-prefab reg 'custom-obj 0 0 16 16)))
          (test-equal "user-redefined mixin key overrides engine default"
            77
            (entity-ref e #:vx))))))

  (test-group "unknown mixin raises error"
    (test-error
      (let ((tmp "/tmp/test-prefabs.scm"))
        (with-output-to-file tmp (lambda () (display "((mixins) (prefabs (bad-prefab nonexistent-mixin #:type bad)))")))
        (load-prefabs tmp (engine-mixins) '())))))

(test-group "instantiate-prefab"
  (define (with-simple-registry thunk)
    (let ((tmp "/tmp/test-prefabs-inst.scm"))
      (with-output-to-file tmp
        (lambda ()
          (display "((mixins) (prefabs (box physics-body #:type box #:tile-id 5)))")))
      (thunk (load-prefabs tmp (engine-mixins) '()))))

  (test-assert "returns #f when registry is #f"
    (not (instantiate-prefab #f 'player 0 0 8 8)))

  (with-simple-registry
    (lambda (reg)
      (test-assert "returns #f for unknown type"
        (not (instantiate-prefab reg 'unknown 0 0 8 8)))

      (let ((e (instantiate-prefab reg 'box 10 20 32 48)))
        (test-equal "instance #:x is set"    10  (entity-ref e #:x))
        (test-equal "instance #:y is set"    20  (entity-ref e #:y))
        (test-equal "instance #:width is set"  32  (entity-ref e #:width))
        (test-equal "instance #:height is set" 48  (entity-ref e #:height))
        (test-equal "prefab field #:type present" 'box (entity-ref e #:type))
        (test-equal "mixin field #:vx present"  0  (entity-ref e #:vx))
        (test-equal "mixin field #:gravity? present" #t (entity-ref e #:gravity?))))))

(test-group "hooks"
  (define (with-hook-registry extra-prefabs user-hooks thunk)
    (let ((tmp "/tmp/test-prefabs-hooks.scm"))
      (with-output-to-file tmp
        (lambda ()
          (display (string-append
            "((mixins)"
            " (prefabs " extra-prefabs "))"))))
      (thunk (load-prefabs tmp (engine-mixins) user-hooks))))

  (test-group "procedure value in #:on-instantiate fires directly"
    ;; Build a registry manually with a procedure in #:on-instantiate.
    ;; (Data files only contain symbols; this tests the procedure? branch directly.)
    (let* ((hook-proc (lambda (e) (entity-set e #:proc-fired #t)))
           (reg (make-prefab-registry
                  prefabs:            (list (cons 'proc-hooked
                                                 (list #:type 'proc-hooked
                                                       #:on-instantiate hook-proc)))
                  group-prefabs:      '()
                  file:               "/dev/null"
                  engine-mixin-table: '()
                  user-hooks:         '()
                  hook-table:         '())))
      (let ((e (instantiate-prefab reg 'proc-hooked 0 0 8 8)))
        (test-equal "procedure hook fires and sets #:proc-fired"
          #t
          (entity-ref e #:proc-fired)))))

  ;; Symbol hook: value in data file is a symbol, resolved via hook-table
  (test-group "symbol hook via user-hooks"
    (with-hook-registry
      "(hooked physics-body #:type hooked #:on-instantiate my-hook)"
      `((my-hook . ,(lambda (e) (entity-set e #:initialized #t))))
      (lambda (reg)
        (let ((e (instantiate-prefab reg 'hooked 0 0 8 8)))
          (test-equal "user hook sets #:initialized"
            #t
            (entity-ref e #:initialized))))))

  (test-group "init-enemy-ai engine hook"
    (with-hook-registry
      "(npc ai-body has-facing #:type npc #:on-instantiate init-enemy-ai)"
      '()
      (lambda (reg)
        (let ((e (instantiate-prefab reg 'npc 0 0 16 16)))
          (test-equal "engine hook sets #:ai-machine via make-enemy-ai-machine"
            'mock-ai-machine
            (entity-ref e #:ai-machine))))))

  (test-group "no hook: entity returned unchanged"
    (with-hook-registry
      "(plain physics-body #:type plain)"
      '()
      (lambda (reg)
        (let ((e (instantiate-prefab reg 'plain 0 0 8 8)))
          (test-equal "no hook: type is plain" 'plain (entity-ref e #:type))))))

  (test-group "unknown hook symbol raises error"
    (test-error
      (with-hook-registry
        "(bad-hook #:type bad #:on-instantiate no-such-hook)"
        '()
        (lambda (reg)
          (instantiate-prefab reg 'bad-hook 0 0 8 8))))))

(test-group "reload-prefabs!"
  (let* ((tmp "/tmp/test-prefabs-reload.scm")
         (_ (with-output-to-file tmp
              (lambda ()
                (display "((mixins) (prefabs (box #:type box #:value 1)))"))))
         (reg1 (load-prefabs tmp (engine-mixins) '()))
         (e1   (instantiate-prefab reg1 'box 0 0 8 8))
         ;; Overwrite the file with new value
         (_ (with-output-to-file tmp
              (lambda ()
                (display "((mixins) (prefabs (box #:type box #:value 42)))"))))
         (reg2 (reload-prefabs! reg1))
         (e2   (instantiate-prefab reg2 'box 0 0 8 8)))
    (test-equal "original registry has #:value 1"  1  (entity-ref e1 #:value))
    (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")