1 ;;; Gacela, a GNU Guile extension for fast games development
2 ;;; Copyright (C) 2013 by Javier Sancho Fernandez <jsf at jsancho dot org>
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.
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.
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/>.
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))
25 ;;; Component definitions
27 (define (symbol-concatenate . args)
30 (map (lambda (a) (if (symbol? a) (symbol->string a) a)) args))))
32 (define-syntax define-component
34 (define (concat . args)
36 (apply symbol-concatenate
42 (define (filtered-args args)
43 (let ((datum (map (lambda (a) (syntax->datum a)) args)))
44 (map (lambda (a) (datum->syntax x a))
45 (map (lambda (a) (if (list? a) (car a) a))
46 (filter (lambda (a) (not (keyword? a))) datum)))))
49 (with-syntax ((make-name (concat "make-" #'name))
50 (make-name-record (concat "make-" #'name "-record"))
51 (name? (concat #'name "?"))
52 ((field-name ...) (filtered-args #'(field ...)))
53 ((field-getter ...) (map (lambda (f) (concat #'name "-" f)) (filtered-args #'(field ...))))
54 ((field-setter ...) (map (lambda (f) (concat "set-" #'name "-" f "!")) (filtered-args #'(field ...)))))
56 (define* (make-name field ...)
57 (make-name-record field-name ...))
58 (define-record-type name
59 (make-name-record field-name ...)
61 (field-name field-getter field-setter)
63 (set-record-type-printer! name
65 (format port "#<[~a]" 'name)
66 (format port " ~a: ~a" 'field-name (field-getter record))
71 (define (export-component component)
72 (let ((name (record-type-name component))
74 (module-export! m (list
75 (symbol-concatenate "make-" name)
76 (symbol-concatenate name "?")))
79 (module-export! (current-module)
81 (symbol-concatenate name "-" a)
82 (symbol-concatenate "set-" name "-" a "!"))))
83 (record-type-fields component))))
85 (define (get-component-type component)
86 (record-type-name (record-type-descriptor component)))
88 (export define-component
93 ;;; Entities and components
95 (define (make-entity-set . changes)
97 (cons (make-hash-table) (make-hash-table))
100 (define (entity-list entity-set)
101 (hash-map->list (lambda (k v) (cons k v)) (car entity-set)))
103 (define (entity-count entity-set)
104 (hash-count (const #t) (car entity-set)))
106 (define (normalize-components components)
110 `(,(get-component-type c) . ,c)
114 (define (register-components entity components clist)
115 (cond ((null? components) clist)
117 (let* ((type (car components))
118 (elist (hash-ref clist type)))
119 (hash-set! clist type
121 (lset-adjoin eq? elist entity))
124 (register-components entity (cdr components) clist)))))
126 (define (unregister-components entity components clist)
127 (cond ((null? components) clist)
129 (let* ((type (car components))
130 (elist (lset-difference eq? (hash-ref clist type) (list entity))))
132 (hash-remove! clist type))
134 (hash-set! clist type elist)))
135 (unregister-components entity (cdr components) clist)))))
137 (define (component-names components)
138 (map (lambda (c) (car c)) components))
140 (define (entity-component-names key entity-set)
142 (hash-ref (car entity-set) key)))
144 (define (entity-ref key entity-set)
145 (hash-get-handle (car entity-set) key))
147 (define (new-entity . new-components)
150 (nc (normalize-components new-components)))
151 (hash-set! (car entity-set) key nc)
152 (register-components key (component-names nc) (cdr entity-set))
157 (define (remove-entity key)
159 (let ((clist (entity-component-names key entity-set))
160 (entity (entity-ref key entity-set)))
161 (hash-remove! (car entity-set) key)
162 (unregister-components key clist (cdr entity-set))
167 (define (set-entity key . new-components)
169 (let* ((nc (normalize-components new-components))
170 (clist (entity-component-names key entity-set))
171 (nclist (component-names nc)))
172 (hash-set! (car entity-set) key nc)
173 (register-components key
174 (lset-difference eq? nclist clist)
175 (unregister-components key (lset-difference eq? clist nclist) (cdr entity-set)))
180 (define (set-entity-components key . new-components)
182 (let ((nc (normalize-components new-components))
183 (clist (alist-copy (hash-ref (car entity-set) key))))
186 (set! clist (assoc-set! clist (car c) (cdr c))))
188 (hash-set! (car entity-set) key clist)
189 (register-components key (component-names nc) (cdr entity-set))
194 (define (remove-entity-components key . old-components)
196 (let ((clist (alist-copy (hash-ref (car entity-set) key))))
199 (set! clist (assoc-remove! clist c)))
201 (hash-set! (car entity-set) key clist)
202 (unregister-components key old-components (cdr entity-set))
207 (define (modify-entities entity-set changes)
208 (cond ((null? changes)
211 (modify-entities ((car changes) entity-set) (cdr changes)))))
213 (export make-entity-set
219 set-entity-components
220 remove-entity-components
226 (define-record-type entities-changes-type
227 (entities-changes changes)
229 (changes get-entities-changes))
231 (define (append-changes changes)
234 (map get-entities-changes changes))))
236 (define (find-entities-by-components entity-set clist)
237 (cond ((null? clist) '())
239 (let ((e (hash-ref (cdr entity-set) (car clist) '()))
240 (e* (find-entities-by-components entity-set (cdr clist))))
243 (lset-intersection eq? e e*))))))
245 (define-syntax make-system
247 ((_ ((name (component-type ...)) ...) form ...)
249 (let ((name (map (lambda (x)
252 (memq (car x) '(component-type ...)))
255 (entity-ref x entity-set))
256 (find-entities-by-components entity-set '(component-type ...)))))
261 (define-syntax define-system
263 ((_ system-name ((name (component-type ...)) ...) form ...)
265 (make-system ((name (component-type ...)) ...)
269 (define (composed-systems-result results)
270 (let ((changes (filter (lambda (r) (entities-changes? r)) results)))
271 (cond ((null? changes)
274 (append-changes changes)))))
276 (define (join-systems . systems)
278 (let run ((s systems) (res '()))
280 (composed-systems-result res))
282 (run (cdr s) (cons ((car s) entity-set) res)))))))
284 (define (thread-systems . systems)
288 (call-with-new-thread
289 (lambda () (s entity-set))))
293 (composed-systems-result res))
295 (run-wait (cdr thd) (cons (join-thread (car thd)) res)))))))
297 (export entities-changes
300 find-entities-by-components
307 ;;; Entities and components access inside systems
309 (define (get-key entity)
312 (define (get-component component-name entity)
313 (assoc-ref (cdr entity) component-name))