blob: ef9b5560a13266650de6bfc73493700b4db98c4e (
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
|
(module downstroke-prefabs *
(import scheme
(chicken base)
(chicken keyword)
(chicken port)
defstruct
downstroke-entity
downstroke-ai)
;; Registry struct to hold prefab data
(defstruct prefab-registry
prefabs group-prefabs file engine-mixin-table user-hooks hook-table)
;; 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)
(ai-body #:ai-facing 1 #:ai-machine #f #:chase-origin-x 0 #:disabled #f)))
;; 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 append inline-fields mixin-plists)))
(cons name merged)))
;; Engine-level hooks
(define *engine-hooks*
`((init-enemy-ai . ,(lambda (e) (entity-set e #:ai-machine (make-enemy-ai-machine))))))
;; 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 scene-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 (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 (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 (instantiate-prefab registry type x y w h)
(if (not registry)
#f
(let ((entry (assq type (prefab-registry-prefabs registry))))
(if (not entry)
#f
;; instance fields prepended → highest priority
(let* ((base (append (list #:x x #:y y #:width w #:height 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-group-member part ox oy gid type-members static-parts?)
(let* ((p0 (part-with-group-locals part))
(merged (append 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)))))))
|
