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
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
|
;;; Lisp Game Jam 2018
;;; Copyright © 2018 David Thompson <davet@gnu.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (engine node)
#:use-module (chickadee)
#:use-module (chickadee sdl)
#:use-module (chickadee math matrix)
#:use-module (chickadee math quaternion)
#:use-module (chickadee math vector)
#:use-module (chickadee scripting)
#:use-module (ice-9 match)
#:use-module (oop goops)
#:use-module ((srfi srfi-1) #:prefix srfi-1:)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:export (<node>
name
parent
children
started?
active?
visible?
agenda
rank
each-child
activate
deactivate
update
update/children
draw
draw/children
on-start
on-enter
on-exit
on-quit
on-key-press
on-text-edit
child-ref
node-let
attach
detach
populate
root-node
set-root-node!
reset-root-node!
run-node))
(define-syntax-rule (cons! item var)
(set! var (cons item var)))
(define-class <node> ()
(name #:accessor name #:init-form (gensym "anonymous-") #:init-keyword #:name)
(parent #:accessor parent #:init-form #f)
(children #:accessor children #:init-form '())
(children-map #:getter children-map #:init-form (make-hash-table))
(started? #:accessor started? #:init-form #f)
(active? #:accessor active? #:init-form #f)
(visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?)
(agenda #:getter agenda #:init-form (make-agenda))
(rank #:getter rank #:init-value 0 #:init-keyword #:rank))
(define (visit proc node)
"Apply PROC to NODE and all child nodes, recursively."
(with-agenda (agenda node) (proc node))
(for-each (cut visit proc <>) (children node)))
(define (visit-while proc node)
"Apply PROC to NODE and all child nodes, recursively, stopping when
PROC returns #f."
(and (with-agenda (agenda node) (proc node))
(let loop ((children (children node)))
(match children
(() #t)
((head . tail)
(and (visit-while proc head)
(loop tail)))))))
(define (each-child proc node)
"Apply PROC to each child of NODE."
(for-each proc (children node)))
(define-method (update/children (node <node>) dt)
"Update NODE, then update all children. DT is the time-delta since
the last update."
;; Update children first.
(each-child (cut update/children <> dt) node)
;; Update script, then "physics" (or whatever the update method is
;; doing).
(with-agenda (agenda node)
(update-agenda 1)
(update node dt)))
(define-method (draw/children (node <node>) alpha)
"Draw NODE, then draw all children. ALPHA is a number between 0 and
1 representing how far in between two updates the drawing is taking
place."
(when (visible? node)
(draw node alpha)
(each-child (cut draw/children <> alpha) node)))
(define-method (activate (node <node>))
"Start scripts for NODE and all its children."
(with-agenda (agenda node)
(unless (started? node)
(on-start node)
(set! (started? node) #t))
(on-enter node)
(set! (active? node) #t))
(each-child activate node))
(define-method (deactivate (node <node>))
"Stop scripts for NODE and all its children."
(on-exit node)
(set! (active? node) #f)
(with-agenda (agenda node)
(reset-agenda))
(each-child deactivate node))
(define-method (update (node <node>) dt) #t)
(define-method (draw (node <node>) alpha) #t)
(define-method (on-start (node <node>)) #t)
(define-method (on-enter (node <node>)) #t)
(define-method (on-exit (node <node>)) #t)
(define-method (on-quit (node <node>)) #t)
(define-method (on-key-press (node <node>) key modifiers repeat?) #t)
(define-method (on-text-edit (node <node>) text) #t)
(define-method (child-ref (node <node>) child-path)
"Return child node of NODE named CHILD-NAME, or #f if there isn't
one."
(define (lookup node child-name)
(hashq-ref (children-map node) child-name))
(match child-path
((or (child-name) (? symbol? child-name))
(lookup node child-name))
((child-name . rest)
(child-ref (lookup node child-name) rest))))
(define-syntax-rule (node-let node ((var child-name) ...) body ...)
(let ((var (child-ref node 'child-name)) ...)
body ...))
(define-method (attach (new-parent <node>) . new-children)
"Attach NEW-CHILDREN to NEW-PARENT."
;; Validate all children first, then add them to the parent node.
(for-each (lambda (child)
(when (parent child)
(error "node already has a parent:" child))
(when (child-ref new-parent (name child))
(error "node name taken:" (name child))))
new-children)
(set! (children new-parent)
(sort (append new-children (children new-parent))
(lambda (a b)
(< (rank a) (rank b)))))
(for-each (lambda (child)
(set! (parent child) new-parent)
(when (active? new-parent)
(activate child))
(hashq-set! (children-map new-parent) (name child) child))
new-children))
(define-method (detach . nodes)
"Detach NODE from its parent."
(for-each (lambda (node)
(let ((parent (parent node)))
(unless parent
(error "node has no parent" node))
(set! (children parent) (delq node (children parent)))
(hashq-remove! (children-map parent) (name node))
(when (active? node)
(deactivate node)))
(set! (parent node) #f))
nodes))
(define-method (populate (node <node>))
'())
(define-method (initialize (node <node>) args)
(let ((children (let loop ((args args))
(match args
(() '())
((#:children children . _)
children)
((key value . rest)
(loop rest))))))
(next-method)
(apply attach node (append (populate node) children))))
;;;
;;; State management
;;;
(define *root-node* #f)
(define (root-node)
"Return the current root node."
*root-node*)
(define (set-root-node! new-root)
"Change the root node to NEW-ROOT."
(set! *root-node* new-root)
(activate new-root))
(define (reset-root-node!)
"Restart the currently active node."
(deactivate (root-node))
(set-root-node! (root-node)))
(define* (run-node make-root-node
#:key
(window-title "Chickadee Engine")
(window-width 640)
(window-height 480)
window-fullscreen?
(update-hz 60))
(run-game #:window-title window-title
#:window-width window-width
#:window-height window-height
#:window-fullscreen? window-fullscreen?
#:update-hz update-hz
#:load
(lambda ()
(set-root-node! (make-root-node)))
#:draw
(cut draw/children *root-node* <>)
#:update
(cut update/children *root-node* <>)
#:quit
(lambda ()
(visit-while (cut on-quit <>) *root-node*))
#:key-press
(lambda (key sc mods repeat?)
(visit-while (cut on-key-press <> key mods repeat?)
*root-node*))
#:text-input
(lambda (text)
(visit-while (cut on-text-edit <> text)
*root-node*))))
|
