(module downstroke-prefabs *
(import scheme
        (chicken base)
        (chicken keyword)
        (chicken port)
	(chicken format)
	srfi-1
        defstruct
        downstroke-entity)

;; Registry struct to hold prefab data
(defstruct prefab-registry
  prefabs group-prefabs file engine-mixin-table user-hooks hook-table)

(define (ensure-balanced-plist plist)
  (when (> (modulo (length plist) 2) 0)
    (error "Given plist has odd number of items - not a valid plist!")))

(define (has-keyword? key plist)
  (not (eq? (get-keyword key plist (lambda () 'undefined)) 'undefined)))

(define (plist-merge plist1 . plists)
  "Merge two PLIST1 and PLIST2 into a single one, elements of PLIST1 will overwrite those of PLIST2 etc.."
  (let ((meta-list (concatenate plists)))
    (ensure-balanced-plist plist1)
    (ensure-balanced-plist meta-list)
    (if (= (length meta-list) 0)
	plist1
	(let loop ((key (car meta-list))
		   (value (cadr meta-list))
		   (rest (if (> (length meta-list) 2) (cddr meta-list) '()))
		   (acc plist1))
	  (let ((new-acc (if (has-keyword? key acc)
			     acc
			     (append (list key value) acc))))
	    (if (null? rest)
		new-acc
		(loop (car rest) (cadr rest) (if (> (length rest) 2) (cddr rest) '()) new-acc)))))))

;; Return engine's built-in mixin table
(define (engine-mixins)
  '((physics-body #:vx 0 #:vy 0 #:ay 0 #:gravity? #t #:solid? #t #:on-ground? #f)
    (has-facing   #:facing 1)
    (animated     #:anim-name idle #:anim-frame 0 #:anim-tick 0 #:tile-id 0 #:animations #t)))

;; Compose a prefab entry with mixin table
;; Returns (name . merged-plist)
(define (compose-prefab entry mixin-table)
  (let* ((name (car entry))
         (rest (cdr entry))
         (split (let loop ((lst rest) (mixins '()))
                  (if (or (null? lst) (keyword? (car lst)))
                      (cons (reverse mixins) lst)
                      (loop (cdr lst) (cons (car lst) mixins)))))
         (mixin-names  (car split))
         (inline-fields (cdr split))
         (mixin-plists
          (map (lambda (mname)
                 (let ((m (assq mname mixin-table)))
                   (if m (cdr m) (error "Unknown mixin" mname))))
               mixin-names))
         ;; inline-fields prepended → first-match semantics give them highest priority
         (merged (apply plist-merge inline-fields mixin-plists)))
    (cons name merged)))

(define *engine-hooks* '())

;; Lookup a hook symbol in the hook table
(define (lookup-hook hook-table hook-sym)
  (let ((entry (assq hook-sym hook-table)))
    (if entry
        (cdr entry)
        (error "Unknown prefab hook" hook-sym))))

;; Group prefab entry: (name . plist) with #:parts = list of part plists.
;; Part offsets may use #:local-x / #:local-y or #:group-local-x / #:group-local-y.
(define (compose-group-prefab entry)
  (cons (car entry) (cdr entry)))

;; Optional profiles (enabled per group via #:pose-only-origin? / #:static-parts? in data).
;; Pose-only origin: tweened or scripted leader, invisible, does not run physics pipelines.
(define +pose-only-group-origin-defaults+
  (list #:solid? #f #:gravity? #f #:skip-render #t
        #:skip-pipelines '(jump acceleration gravity velocity-x velocity-y
				tile-collisions-x tile-collisions-y on-solid entity-collisions)))

;; Physics-driving origin: invisible point mass; members follow via sync-groups.
(define +physics-group-origin-defaults+
  (list #:solid? #f #:gravity? #t #:skip-render #t
        #:vx 0 #:vy 0 #:on-ground? #f))

;; Static rigid parts: no integration; world pose comes from the origin each frame.
(define +static-group-member-defaults+
  (list #:gravity? #f #:vx 0 #:vy 0 #:on-ground? #f
        #:solid? #t #:immovable? #t
        #:skip-pipelines '(jump acceleration gravity velocity-x velocity-y
				tile-collisions-x tile-collisions-y on-solid)))

(define (part-with-group-locals part)
  (let* ((p part)
         (p (if (entity-ref p #:group-local-x #f) p
                (entity-set p #:group-local-x (entity-ref p #:local-x 0))))
         (p (if (entity-ref p #:group-local-y #f) p
                (entity-set p #:group-local-y (entity-ref p #:local-y 0)))))
    p))

(define (load-prefabs file engine-mixin-table user-hooks)
  (let* ((data (with-input-from-file file read))
         (mixin-section  (if (assq 'mixins data) (cdr (assq 'mixins data)) '()))
         (prefab-section (cdr (assq 'prefabs data)))
         (group-section  (cond ((assq 'group-prefabs data) => cdr) (else '())))
         ;; user mixins first → user wins on assq lookup (overrides engine mixin by name)
         (user-mixin-table (if (null? mixin-section) '() (map (lambda (m) (cons (car m) (cdr m))) mixin-section)))
         (merged-mixin-table (append user-mixin-table engine-mixin-table))
         ;; user-hooks first → user wins on assq lookup (overrides engine hooks by name)
         (hook-table (append user-hooks *engine-hooks*))
         (prefab-table (map (lambda (entry) (compose-prefab entry merged-mixin-table))
                            prefab-section))
         (group-table (map compose-group-prefab group-section)))
    (make-prefab-registry
     prefabs:            prefab-table
     group-prefabs:      group-table
     file:               file
     engine-mixin-table: engine-mixin-table
     user-hooks:         user-hooks
     hook-table:         hook-table)))

(define (reload-prefabs! registry)
  (load-prefabs (prefab-registry-file               registry)
                (prefab-registry-engine-mixin-table registry)
                (prefab-registry-user-hooks         registry)))

(define (plist->alist plist)
  (if (> (modulo (length plist) 2) 0)
      (error "Invalid plist!")
      (let loop ((n1 (car plist))
		 (n2 (cadr plist))
		 (rest (if (> (length plist) 2) (cddr plist) '())))
	(if (null? rest)
	    (list (cons n1 n2))
	    (cons (cons n1 n2) (loop (car rest) (cadr rest) (cddr rest)))))))

(define (do-instantiate-prefab registry entry x y w h)
  (let* ((base (entity-set-many (make-entity x y w h)
				(plist->alist (cdr entry))))
         (hook-val (entity-ref base #:on-instantiate #f))
         (handler
          (cond
           ((procedure? hook-val) hook-val)
           ((symbol?    hook-val)
            (lookup-hook (prefab-registry-hook-table registry) hook-val))
           (else #f))))
    (if handler (handler base) base)))


(define (instantiate-prefab registry type x y w h)
  (if (not registry)
      #f
      (let ((entry (assq type (prefab-registry-prefabs registry))))
        (if (not entry)
            #f
            (do-instantiate-prefab registry entry x y w h)))))

(define (instantiate-group-member part ox oy gid type-members static-parts?)
  (let* ((p0 (part-with-group-locals part))
         (merged (plist-merge p0 (if static-parts? +static-group-member-defaults+ '())))
         (lx (entity-ref merged #:group-local-x 0))
         (ly (entity-ref merged #:group-local-y 0))
         (typ (entity-ref merged #:type type-members))
         (with-type (entity-set merged #:type typ))
         (g1 (entity-set with-type #:group-id gid))
         (g2 (entity-set g1 #:group-local-x lx))
         (g3 (entity-set g2 #:group-local-y ly))
         (g4 (entity-set g3 #:x (+ ox lx))))
    (entity-set g4 #:y (+ oy ly))))

;; Instantiate a group prefab: one origin entity (pose) + members with #:group-local-x/y.
;; Returns (origin member ...) or #f. Each instance gets a fresh gensym #:group-id.
(define (instantiate-group-prefab registry type ox oy)
  (if (not registry)
      #f
      (let ((entry (assq type (prefab-registry-group-prefabs registry))))
        (if (not entry)
            #f
            (let* ((spec (cdr entry))
                   (gid (gensym (symbol->string type)))
                   (parts (entity-ref spec #:parts '()))
                   (type-members (entity-ref spec #:type-members 'group-part))
                   (pose-only? (entity-ref spec #:pose-only-origin? #f))
                   (static-parts? (entity-ref spec #:static-parts? #f))
                   (ow (entity-ref spec #:origin-width 0))
                   (oh (entity-ref spec #:origin-height 0))
                   (ot (entity-ref spec #:origin-type 'group-origin))
                   (origin-fields
                    (append
                     (list #:type ot #:group-id gid #:group-origin? #t
                           #:x ox #:y oy #:width ow #:height oh)
                     (if pose-only?
                         +pose-only-group-origin-defaults+
                         +physics-group-origin-defaults+)))
                   (origin origin-fields)
                   (members
                    (map (lambda (part)
                           (instantiate-group-member
                            part ox oy gid type-members static-parts?))
                         parts)))
              (cons origin members)))))))