blob: 99a6da378d8effb83937308e801b29e2e3c0a572 (
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
|
(define-module (catbird node)
#:use-module (catbird asset)
#:use-module (catbird cached-slots)
#:use-module (catbird config)
#:use-module (catbird mixins)
#:use-module (catbird observer)
#:use-module (chickadee scripting)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 format)
#:use-module (oop goops)
#:export (<node>
in-view?
tree-in-view?
children
for-each-child
on-boot
reboot
child-ref &
attach-to
replace
blink)
#:re-export (agenda
detach
hide
name
parent
on-enter
on-hide
on-exit
on-pause
on-resume
on-show
pause
paused?
rank
render
resume
run-script
show
stop-scripts
visible?
update))
(define-class <node>
(<renderable> <scriptable> <containable> <nameable> <rankable>
<observer> <asset-container>)
;; An integer value that determines priority order for
;; updating/rendering.
(rank #:getter rank #:init-value 0 #:init-keyword #:rank)
;; List of children, sorted by rank.
(children #:accessor children #:init-value '())
;; Children indexed by name for fast lookup.
(children-by-name #:getter children-by-name #:init-thunk make-hash-table))
(define-method (initialize (node <node>) initargs)
(next-method)
(on-boot node))
(define-method (on-boot (node <node>))
#t)
(define-method (reboot (node <node>))
(for-each-child detach node)
(with-agenda (agenda node) (reset-agenda))
(on-boot node))
(define-method (write (node <node>) port)
(define (strip-angle-brackets str)
(let ((start (if (string-prefix? "<" str) 1 0))
(end (if (string-suffix? ">" str)
(- (string-length str) 1)
(string-length str))))
(substring str start end)))
(format port "#<~a name: ~a>"
(strip-angle-brackets
(symbol->string
(class-name (class-of node))))
(name node)))
(define (for-each-child proc node)
(for-each proc (children node)))
(define-method (update/around (node <node>) dt)
(unless (paused? node)
;; Update children first, recursively.
(for-each-child (lambda (child) (update/around child dt)) node)
(next-method)))
(define-method (tree-in-view? (node <node>))
#t)
(define-method (in-view? (node <node>))
#t)
(define-method (render/around (node <node>) alpha)
(when (and (visible? node) (tree-in-view? node))
(next-method)
(for-each-child (lambda (child) (render/around child alpha)) node)))
(define-method (child-ref (parent <node>) name)
(hashq-ref (children-by-name parent) name))
(define-syntax &
(syntax-rules ()
((_ parent child-name)
(child-ref parent 'child-name))
((_ parent child-name . rest)
(& (child-ref parent 'child-name) . rest))))
(define-method (attach-to (new-parent <node>) . new-children)
;; Validate all the nodes first. The whole operation will fail if
;; any of them cannot be attached.
(for-each (lambda (child)
(when (parent child)
(raise-exception
(make-exception-with-message "node already has a parent")))
(when (child-ref new-parent (name child))
(raise-exception
(make-exception-with-message "node name taken"))))
new-children)
;; Add named children to the name index for quick lookup later.
(for-each (lambda (child)
(when (name child)
(hashq-set! (children-by-name new-parent) (name child) child)))
new-children)
;; Add the new children and sort them by their rank so that
;; updating/rendering happens in the desired order.
(set! (children new-parent)
(sort-by-rank/ascending (append new-children (children new-parent))))
;; Attach children to the parent, triggering initial enter/attach
;; hooks.
(for-each (lambda (child)
(attach child new-parent))
new-children))
(define-method (replace (parent-node <node>) . replacements)
(for-each (lambda (replacement)
(let ((old (child-ref parent-node (name replacement))))
(when old
(detach old))))
replacements)
(apply attach-to parent-node replacements))
(define-method (detach (node <node>))
(let ((p (parent node)))
;; Remove child from parent.
(set! (children p) (delq node (children p)))
;; Remove from name index.
(when (name node)
(hashq-remove! (children-by-name p) (name node)))
(next-method)))
(define-method (blink (node <node>) times interval)
(let loop ((i 0))
(when (< i times)
(set! (visible? node) #f)
(sleep interval)
(set! (visible? node) #t)
(sleep interval)
(loop (+ i 1)))))
|
