]> git.jsancho.org Git - gacela.git/blob - src/system.scm
5a70cb5010e34f7db8c0905efd22cbc9b91794f3
[gacela.git] / src / system.scm
1 ;;; Gacela, a GNU Guile extension for fast games development
2 ;;; Copyright (C) 2013 by Javier Sancho Fernandez <jsf at jsancho dot org>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation, either version 3 of the License, or
7 ;;; (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16
17
18 (define-module (gacela system)
19   #:use-module (ice-9 receive)
20   #:use-module (srfi srfi-1)
21   #:use-module (srfi srfi-9)
22   #:use-module (srfi srfi-9 gnu))
23
24
25 ;;; Component definitions
26
27 (define (symbol-concatenate . args)
28   (string->symbol
29    (string-concatenate
30     (map (lambda (a) (if (symbol? a) (symbol->string a) a)) args))))
31
32 (define-syntax define-component
33   (lambda (x)
34     (define (concat . args)
35       (datum->syntax x
36         (apply symbol-concatenate
37           (map (lambda (a)
38                  (if (string? a)
39                      a
40                      (syntax->datum a)))
41                args))))
42     (syntax-case x ()
43       ((_ name field ...)
44        (with-syntax ((make-name (concat "make-" #'name))
45                      (name? (concat #'name "?"))
46                      ((field-getter ...) (map (lambda (f) (concat #'name "-" f)) #'(field ...)))
47                      ((field-setter ...) (map (lambda (f) (concat "set-" #'name "-" f "!")) #'(field ...))))
48          #'(begin
49              (define-record-type name
50                (make-name field ...)
51                name?
52                (field field-getter field-setter)
53                ...)
54              (set-record-type-printer! name
55                (lambda (record port)
56                  (format port "#<[~a]" 'name)
57                  (format port " ~a: ~a" 'field (field-getter record))
58                  ...
59                  (format port ">")))
60              'name))))))
61
62 (define (export-component component)
63   (let ((name (record-type-name component))
64         (m (current-module)))
65     (module-export! m (list
66                        (symbol-concatenate "make-" name)
67                        (symbol-concatenate name "?")))
68     (for-each
69      (lambda (a)
70        (module-export! (current-module)
71                        (list
72                         (symbol-concatenate name "-" a)
73                         (symbol-concatenate "set-" name "-" a "!"))))
74      (record-type-fields component))))
75
76 (define (get-component-type component)
77   (record-type-name (record-type-descriptor component)))
78
79 (export define-component
80         export-component
81         get-component-type)
82
83
84 ;;; Entities and components
85
86 (define (normalize-components components)
87   (map
88    (lambda (c)
89      (if (record? c)
90          `(,(get-component-type c) . ,c)
91          c))
92    components))
93
94 (define (register-components entity components clist)
95   (cond ((null? components) clist)
96         (else
97          (let* ((type (car components))
98                 (elist (assoc-ref clist type)))
99            (register-components entity (cdr components)
100              (assoc-set! clist type
101                (cond (elist
102                       (lset-adjoin eq? elist entity))
103                      (else
104                       (list entity)))))))))
105
106 (define (unregister-components entity components clist)
107   (cond ((null? components) clist)
108         (else
109          (let* ((type (car components))
110                 (elist (lset-difference eq? (assoc-ref clist type) (list entity))))
111            (unregister-components entity (cdr components)
112              (cond ((null? elist)
113                     (assoc-remove! clist type))
114                    (else
115                     (assoc-set! clist type elist))))))))
116
117 (define (new-entity . new-components)
118   (lambda (entities components)
119     (let ((key (gensym))
120           (nc (normalize-components new-components)))
121       (values
122        (acons key nc entities)
123        (register-components key
124                             (map (lambda (c) (car c)) nc)
125                             components)
126        (cons key nc)))))
127
128 (define (remove-entity key)
129   (lambda (entities components)
130     (let ((clist (map (lambda (c) (car c)) (assoc-ref entities key)))
131           (entity (assoc key entities)))
132       (values
133        (assoc-remove! entities key)
134        (unregister-components key clist components)
135        entity))))
136
137 (define (set-entity key . new-components)
138   (lambda (entities components)
139     (let* ((nc (normalize-components new-components))
140            (clist (map (lambda (c) (car c)) (assoc-ref entities key)))
141            (nclist (map (lambda (c) (car c)) nc)))
142       (values
143        (assoc-set! entities key nc)
144        (register-components key (lset-difference eq? nclist clist)
145                             (unregister-components key (lset-difference eq? clist nclist) components))
146        (cons key nc)))))
147
148 (define (set-entity-components key . new-components)
149   (lambda (entities components)
150     (let ((nc (normalize-components new-components))
151           (clist (alist-copy (assoc-ref entities key))))
152       (for-each
153        (lambda (c)
154          (assoc-set! clist (car c) (cdr c)))
155        nc)
156       (values
157        (assoc-set! entities key clist)
158        (register-components key (map (lambda (c) (car c)) nc) components)
159        (cons key clist)))))
160
161 (define (remove-entity-components key . old-components)
162   (lambda (entities components)
163     (let ((clist (alist-copy (assoc-ref entities key))))
164       (for-each
165        (lambda (c)
166          (assoc-remove! clist c))
167        old-components)
168       (values
169        (assoc-set! entities key clist)
170        (unregister-components key old-components components)
171        (cons key clist)))))
172
173 (define (modify-entities changes entities components)
174   (cond ((null? changes)
175          (values entities components))
176         (else
177          (receive (e c) ((car changes) entities components)
178            (modify-entities (cdr changes) e c)))))
179
180 (export new-entity
181         remove-entity
182         set-entity
183         set-entity-components
184         remove-entity-components
185         modify-entities)
186
187
188 ;;; Making systems
189
190 (define-record-type entities-changes-type
191   (entities-changes changes)
192   entities-changes?
193   (changes get-entities-changes))
194
195 (define* (find-entities-by-components c t)
196   (cond ((null? t) '())
197         (else
198          (let* ((e (assoc-ref c (car t)))
199                 (e* (if e e '())))
200            (cond ((null? (cdr t)) e*)
201                  (else
202                   (lset-intersection eq? e* (find-entities-by-components c (cdr t)))))))))
203
204 (define-syntax make-system
205   (syntax-rules ()
206     ((_ ((name (component-type ...)) ...) form ...)
207      (lambda (entities components)
208        (let ((name (map (lambda (x)
209                           (cons (car x)
210                                 (filter (lambda (x)
211                                           (memq (car x) '(component-type ...)))
212                                         (cdr x))))
213                         (map (lambda (x)
214                                (assoc x entities))
215                              (find-entities-by-components components '(component-type ...)))))
216              ...)
217          (let ((res (begin form ...)))
218            (lambda* (#:optional (entities2 #f) (components2 #f))
219              (let ((e (if (and entities2 components2) entities2 entities))
220                    (c (if (and entities2 components2) components2 components)))
221                (modify-entities (if (entities-changes? res) (get-entities-changes res) '()) e c)))))))))
222
223 (define-syntax define-system
224   (syntax-rules ()
225     ((_ system-name ((name (component-type ...)) ...) form ...)
226      (define system-name
227        (make-system ((name (component-type ...)) ...)
228          form
229          ...)))))
230
231 (define (join-systems . systems)
232   (lambda (entities components)
233     (let ((changes
234            (let run ((s systems) (e (alist-copy entities)) (c (alist-copy components)) (res '()))
235              (cond ((null? s)
236                     res)
237                    (else
238                     (let ((r ((car s) e c)))
239                       (receive (e2 c2) (r)
240                         (run (cdr s) e2 c2 (cons r res)))))))))
241       (lambda* (#:optional (entities2 #f) (components2 #f))
242         (let modify ((e (if (and entities2 components2) entities2 entities))
243                      (c (if (and entities2 components2) components2 components))
244                      (ch (reverse changes)))
245           (cond ((null? ch)
246                  (values e c))
247                 (else
248                  (receive (e2 c2) ((car ch) e c)
249                    (modify e2 c2 (cdr ch))))))))))
250
251 (define (threaded-systems . systems)
252   (lambda (entities components)
253     (let ((changes
254            (let run-wait ((thd
255                            (map (lambda (s)
256                                   (call-with-new-thread
257                                    (lambda () (s entities components))))
258                                 systems))
259                           (res '()))
260              (cond ((null? thd)
261                     res)
262                    (else
263                     (run-wait (cdr thd) (cons (join-thread (car thd)) res)))))))
264       (lambda* (#:optional (entities2 #f) (components2 #f))
265         (let modify ((e (if (and entities2 components2) entities2 entities))
266                      (c (if (and entities2 components2) components2 components))
267                      (ch changes))
268           (cond ((null? ch)
269                  (values e c))
270                 (else
271                  (receive (e2 c2) ((car ch) e c)
272                    (modify e2 c2 (cdr ch))))))))))
273
274 (define (group-systems . systems)
275   (cond ((null? systems)
276          (make-system ()))
277         ((= (length systems) 1)
278          (car systems))
279         (else
280          (apply join-systems systems))))
281
282 (export entities-changes
283         entities-changes?
284         get-entities-changes
285         find-entities-by-components
286         define-system
287         make-system
288         join-systems
289         threaded-systems
290         group-systems)
291
292
293 ;;; Entities and components access inside systems
294
295 (define (get-key entity)
296   (car entity))
297
298 (define (get-component component-name entity)
299   (assoc-ref (cdr entity) component-name))
300
301 (export get-key
302         get-component)