X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fsystem.scm;h=2bf05208fefb215eec76c28e3075ce0a3f56e218;hb=c62dceb1471afb94efa57eef5506fbdf6f2ef679;hp=587fc066c339a134e874ddfd4efa6f1718584bf4;hpb=d521b9e605e8153096a377b60b412514f7adbdfd;p=gacela.git diff --git a/src/system.scm b/src/system.scm index 587fc06..2bf0520 100644 --- a/src/system.scm +++ b/src/system.scm @@ -18,7 +18,8 @@ (define-module (gacela system) #:use-module (ice-9 receive) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9)) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu)) ;;; Component definitions @@ -28,19 +29,35 @@ (string-concatenate (map (lambda (a) (if (symbol? a) (symbol->string a) a)) args)))) -(define-macro (define-component name . args) - `(begin - (use-modules (srfi srfi-9) (srfi srfi-9 gnu)) - (define-record-type ,name - (,(symbol-concatenate "make-" name) ,@args) - ,(symbol-concatenate name "?") - ,@(map (lambda (a) (list a (symbol-concatenate name "-" a) (symbol-concatenate "set-" name "-" a "!"))) args)) - (set-record-type-printer! ,name - (lambda (record port) - (format port "#<[~a]" ',name) - ,@(map (lambda (a) `(format port " ~a: ~a" ',a (,(symbol-concatenate name "-" a) record))) args) - (format port ">"))) - ',name)) +(define-syntax define-component + (lambda (x) + (define (concat . args) + (datum->syntax x + (apply symbol-concatenate + (map (lambda (a) + (if (string? a) + a + (syntax->datum a))) + args)))) + (syntax-case x () + ((_ name field ...) + (with-syntax ((make-name (concat "make-" #'name)) + (name? (concat #'name "?")) + ((field-getter ...) (map (lambda (f) (concat #'name "-" f)) #'(field ...))) + ((field-setter ...) (map (lambda (f) (concat "set-" #'name "-" f "!")) #'(field ...)))) + #'(begin + (define-record-type name + (make-name field ...) + name? + (field field-getter field-setter) + ...) + (set-record-type-printer! name + (lambda (record port) + (format port "#<[~a]" 'name) + (format port " ~a: ~a" 'field (field-getter record)) + ... + (format port ">"))) + 'name)))))) (define (export-component component) (let ((name (record-type-name component)) @@ -106,14 +123,16 @@ (register-components key (map (lambda (c) (car c)) nc) components) - key)))) + (cons key nc))))) (define (remove-entity key) (lambda (entities components) - (let ((clist (map (lambda (c) (car c)) (assoc-ref entities key)))) + (let ((clist (map (lambda (c) (car c)) (assoc-ref entities key))) + (entity (assoc key entities))) (values (assoc-remove! entities key) - (unregister-components key clist components))))) + (unregister-components key clist components) + entity)))) (define (set-entity key . new-components) (lambda (entities components) @@ -123,7 +142,8 @@ (values (assoc-set! entities key nc) (register-components key (lset-difference eq? nclist clist) - (unregister-components key (lset-difference eq? clist nclist) components)))))) + (unregister-components key (lset-difference eq? clist nclist) components)) + (cons key nc))))) (define (set-entity-components key . new-components) (lambda (entities components) @@ -135,7 +155,8 @@ nc) (values (assoc-set! entities key clist) - (register-components key (map (lambda (c) (car c)) nc) components))))) + (register-components key (map (lambda (c) (car c)) nc) components) + (cons key clist))))) (define (remove-entity-components key . old-components) (lambda (entities components) @@ -146,7 +167,8 @@ old-components) (values (assoc-set! entities key clist) - (unregister-components key old-components components))))) + (unregister-components key old-components components) + (cons key clist))))) (define (modify-entities changes entities components) (cond ((null? changes) @@ -173,26 +195,33 @@ (cond ((null? (cdr t)) e*) (else (lset-intersection eq? e* (find-entities-by-components c (cdr t))))))))) - -(define-macro (make-system component-types system-func) - `(let ((func ,system-func)) +(define-syntax make-system + (syntax-rules () + ((_ ((name (component-type ...)) ...) form ...) (lambda (entities components) - (let* ((e (find-entities-by-components components ',component-types)) - (e* (map (lambda (x) (assoc x entities)) e)) - (e** (map (lambda (x) (cons (car x) (filter (lambda (x) (memq (car x) ',component-types)) (cdr x)))) e*)) - (res (func e**))) - (lambda* (#:optional (entities2 #f) (components2 #f)) - (let ((e (if (and entities2 components2) entities2 entities)) - (c (if (and entities2 components2) components2 components))) - (modify-entities res e c))))))) - - -(define-macro (define-system head system-func) - (let ((name (car head)) - (component-types (cdr head))) - `(define ,name (make-system ,component-types ,system-func)))) - + (let ((name (map (lambda (x) + (cons (car x) + (filter (lambda (x) + (memq (car x) '(component-type ...))) + (cdr x)))) + (map (lambda (x) + (assoc x entities)) + (find-entities-by-components components '(component-type ...))))) + ...) + (let ((res (begin form ...))) + (lambda* (#:optional (entities2 #f) (components2 #f)) + (let ((e (if (and entities2 components2) entities2 entities)) + (c (if (and entities2 components2) components2 components))) + (modify-entities res e c))))))))) + +(define-syntax define-system + (syntax-rules () + ((_ system-name ((name (component-type ...)) ...) form ...) + (define system-name + (make-system ((name (component-type ...)) ...) + form + ...))))) (define (join-systems . systems) (lambda (entities components) @@ -203,7 +232,6 @@ (receive (e2 c2) (((car s) e c)) (run (cdr s) e2 c2))))))) - (define (threaded-systems . systems) (lambda (entities components) (let run-wait ((thd @@ -219,12 +247,20 @@ (receive (e2 c2) ((join-thread (car thd)) e c) (run-wait (cdr thd) e2 c2))))))) +(define (group-systems . systems) + (cond ((null? systems) + (make-system ())) + ((= (length systems) 1) + (car systems)) + (else + (join-systems systems)))) (export find-entities-by-components define-system make-system join-systems - threaded-systems) + threaded-systems + group-systems) ;;; Entities and components access inside systems @@ -235,6 +271,5 @@ (define (get-component component-name entity) (assoc-ref (cdr entity) component-name)) - (export get-key get-component)