Re-format

1 files changed, 221 insertions, 221 deletions

diff --git a/prefabs.scm b/prefabs.scm
index ac9d5d0..35c8180 100644
--- a/prefabs.scm
+++ b/prefabs.scm
@@ -1,222 +1,222 @@
 (module (downstroke prefabs) *
-(import scheme
-        (chicken base)
-        (only (chicken keyword) keyword?)
-	    srfi-1
-        (only (list-utils alist) plist->alist)
-        defstruct
-        (downstroke entity))
-
-;; Registry struct to hold prefab data
-(defstruct prefab-registry
-  prefabs group-prefabs file engine-mixin-table user-hooks hook-table)
-
-;; Private: internal prefab composition helper.
-;; Merge alists left-to-right; earlier occurrences of a key win.
-;; Returns a fresh alist.
-(define (alist-merge . alists)
-  (fold (lambda (alist acc)
-          (fold (lambda (pair acc)
-                  (if (assq (car pair) acc)
-                      acc
-                      (cons pair acc)))
-                acc
-                alist))
-        '()
-        alists))
-
-;; Keys whose values are lists-of-plists in user data files and must be
-;; deep-converted to lists-of-alists after the top-level plist->alist pass.
-(define +nested-plist-list-keys+ '(#:animations #:parts))
-
-(define (convert-nested-plist-values alist)
-  (map (lambda (pair)
-         (if (memq (car pair) +nested-plist-list-keys+)
-             (cons (car pair) (map plist->alist (cdr pair)))
-             pair))
-       alist))
-
-;; 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 a mixin-table of alists.
-;; `entry` is the raw user plist-shaped entry: (name mixin-name ... #:k v #:k v ...)
-;; `mixin-table` maps mixin-name → alist (already converted in load-prefabs).
-;; Returns (name . merged-alist).
-(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))
-         (inline-alist (plist->alist inline-fields))
-         (mixin-alists
-          (map (lambda (mname)
-                 (let ((m (assq mname mixin-table)))
-                   (if m (cdr m) (error "Unknown mixin" mname))))
-               mixin-names))
-         ;; inline-alist first → highest priority (earlier-wins)
-         (merged (apply alist-merge (cons inline-alist mixin-alists))))
-    (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))))
-
-;; 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+
-  '((#: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+
-  '((#: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+
-  '((#: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 '())))
-         ;; Convert engine mixin-table bodies (plists) to alists.
-         (engine-mixin-alist-table
-          (map (lambda (m) (cons (car m) (plist->alist (cdr m))))
-               engine-mixin-table))
-         ;; user mixins first → user wins on assq lookup (overrides engine mixin by name)
-         (user-mixin-table
-          (map (lambda (m) (cons (car m) (plist->alist (cdr m))))
-               mixin-section))
-         (merged-mixin-table (append user-mixin-table engine-mixin-alist-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)
-                 (let* ((composed (compose-prefab entry merged-mixin-table))
-                        (converted (convert-nested-plist-values (cdr composed))))
-                   (cons (car composed) converted)))
-               prefab-section))
-         (group-table
-          (map (lambda (entry)
-                 (let* ((name (car entry))
-                        (alist-fields (plist->alist (cdr entry)))
-                        (converted (convert-nested-plist-values alist-fields)))
-                   (cons name converted)))
-               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 (do-instantiate-prefab registry entry x y w h)
-  (let* ((base (entity-set-many (make-entity x y w h) (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 (alist-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
-                    (alist-merge
-                     `((#: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)))))))
+  (import scheme
+          (chicken base)
+          (only (chicken keyword) keyword?)
+	      srfi-1
+          (only (list-utils alist) plist->alist)
+          defstruct
+          (downstroke entity))
+
+  ;; Registry struct to hold prefab data
+  (defstruct prefab-registry
+    prefabs group-prefabs file engine-mixin-table user-hooks hook-table)
+
+  ;; Private: internal prefab composition helper.
+  ;; Merge alists left-to-right; earlier occurrences of a key win.
+  ;; Returns a fresh alist.
+  (define (alist-merge . alists)
+    (fold (lambda (alist acc)
+            (fold (lambda (pair acc)
+                    (if (assq (car pair) acc)
+                        acc
+                        (cons pair acc)))
+                  acc
+                  alist))
+          '()
+          alists))
+
+  ;; Keys whose values are lists-of-plists in user data files and must be
+  ;; deep-converted to lists-of-alists after the top-level plist->alist pass.
+  (define +nested-plist-list-keys+ '(#:animations #:parts))
+
+  (define (convert-nested-plist-values alist)
+    (map (lambda (pair)
+           (if (memq (car pair) +nested-plist-list-keys+)
+               (cons (car pair) (map plist->alist (cdr pair)))
+               pair))
+         alist))
+
+  ;; 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 a mixin-table of alists.
+  ;; `entry` is the raw user plist-shaped entry: (name mixin-name ... #:k v #:k v ...)
+  ;; `mixin-table` maps mixin-name → alist (already converted in load-prefabs).
+  ;; Returns (name . merged-alist).
+  (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))
+           (inline-alist (plist->alist inline-fields))
+           (mixin-alists
+            (map (lambda (mname)
+                   (let ((m (assq mname mixin-table)))
+                     (if m (cdr m) (error "Unknown mixin" mname))))
+                 mixin-names))
+           ;; inline-alist first → highest priority (earlier-wins)
+           (merged (apply alist-merge (cons inline-alist mixin-alists))))
+      (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))))
+
+  ;; 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+
+    '((#: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+
+    '((#: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+
+    '((#: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 '())))
+           ;; Convert engine mixin-table bodies (plists) to alists.
+           (engine-mixin-alist-table
+            (map (lambda (m) (cons (car m) (plist->alist (cdr m))))
+                 engine-mixin-table))
+           ;; user mixins first → user wins on assq lookup (overrides engine mixin by name)
+           (user-mixin-table
+            (map (lambda (m) (cons (car m) (plist->alist (cdr m))))
+                 mixin-section))
+           (merged-mixin-table (append user-mixin-table engine-mixin-alist-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)
+                   (let* ((composed (compose-prefab entry merged-mixin-table))
+                          (converted (convert-nested-plist-values (cdr composed))))
+                     (cons (car composed) converted)))
+                 prefab-section))
+           (group-table
+            (map (lambda (entry)
+                   (let* ((name (car entry))
+                          (alist-fields (plist->alist (cdr entry)))
+                          (converted (convert-nested-plist-values alist-fields)))
+                     (cons name converted)))
+                 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 (do-instantiate-prefab registry entry x y w h)
+    (let* ((base (entity-set-many (make-entity x y w h) (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 (alist-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
+                      (alist-merge
+                       `((#: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)))))))