blob: cf2896daa144b1a61dbe9ffb286b0a0ac1d7828d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
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)))))))
|
