X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fgacela_mobs.scm;h=5e159075b945586567e7154096dd4386de42b53e;hb=023823491bfe1a64e136bcc2d47c6ec5803f23bf;hp=de527bdf7f3a93ad28f718d5550a58fa901fa90c;hpb=8f832dbff1875ba4a6ba73974e1016378218a9c4;p=gacela.git diff --git a/src/gacela_mobs.scm b/src/gacela_mobs.scm index de527bd..5e15907 100755 --- a/src/gacela_mobs.scm +++ b/src/gacela_mobs.scm @@ -15,97 +15,154 @@ ;;; along with this program. If not, see . -(use-modules (srfi srfi-1)) +;;; Mobs Factory -;;; Actions for mobs +(define show-mob-hash #f) +(define hide-mob-hash #f) +(define get-active-mobs #f) +(define mobs-changed? #f) -(define-macro (define-action name attr . code) - `(define (,name mob-attr) - (let ,attr +(let ((active-mobs (make-hash-table)) (changed #f)) + (set! show-mob-hash + (lambda (key mob) + (hash-set! active-mobs key mob) + (set! changed #t))) + + (set! hide-mob-hash + (lambda (key) + (hash-remove! key) + (set! changed #t))) + + (set! get-active-mobs + (lambda* (#:optional (refreshed #t)) + (set! changed (not refreshed)) + (hash-map->list (lambda (k v) v) active-mobs))) + + (set! mobs-changed? + (lambda () changed))) + + +(define-macro (show-mob mob) + `(show-mob-hash ',mob (lambda (option) (,mob option)))) + +(define-macro (hide-mob mob) + `(hide-mob-hash ',mob)) + +(define (run-mob-actions mobs) + (for-each (lambda (m) (m 'run-actions)) mobs)) + +(define (render-mobs mobs) + (for-each (lambda (m) (m 'render)) mobs)) + + +;;; Actions and looks for mobs + +(define (get-attr list name default) + (let ((value (assoc-ref list name))) + (cond (value (car value)) + (else default)))) + +(define (attr-def attr) + (let ((name (car attr)) + (value (cadr attr))) + `(,name (get-attr attributes ',name ',value)))) + +(define (attr-save attr) + (let ((name (car attr))) + `(set! attributes (assoc-set! attributes ',name (list ,name))))) + +(define-macro (define-action action-head . code) + (let ((name (car action-head)) (attr (cdr action-head))) + `(define ,name + (lambda-action ,attr ,@code)))) + +(define-macro (lambda-action attr . code) + `(lambda (attributes) + (let ,(map attr-def attr) ,@code - ,(cons 'begin (map #'attribute-save (reverse attr))) - mob-attr))) - -(defun attribute-save (attribute) - (let* ((name (cond ((listp attribute) (car attribute)) - (t attribute))) - (pname (attribute-name name))) - `(setf (getf object-attr ,pname) ,name))) - - - -;;; Mob Factory - -(define-macro (makemob name . methods) - `(define* (,name . args) - (let ((option (car args))) - ,(lset-union eq? - `(case option - (:on (mob-on ',name)) - (:off (mob-off ',name))) - (define (options m) - (let ((option (car m)) (body (cadr m))) - (cond ((null? m) '()) - (else (cons (list option `(apply ,body (cdr args))) (options (cddr m))))))) - (options methods))))) - -(define-macro (makemob name . methods) - (define (options m) - (cond ((null? m) '((else #f))) + ,(cons 'begin (map attr-save attr)) + attributes))) + +(define-macro (lambda-look attr . look) + (define (process-look look) + (cond ((null? look) (values '() '())) (else - (let ((option (caar m)) (body (cadar m))) - (cons `((,option) (apply ,body (cdr args))) (options (cdr m))))))) - (let ((m (options methods))) - `(define (,name . args) - (let ((option (car args))) - (case option - ((#:on) (mob-on ',name)) - ((#:off) (mob-off ',name)) - ,@m))))) - - -(define mob-on #f) -(define run-mobs #f) -(define mob-off #f) -(define refresh-running-mobs #f) -(define quit-all-mobs #f) - -(let ((running-mobs '()) (mobs-to-add '()) (mobs-to-quit '())) - (set! mob-on - (lambda (mob) - (push mob mobs-to-add))) - - (set! run-mobs - (lambda* (option #:key args function) - (define (run-mobs-rec mobs) - (cond ((null? mobs) #f) - (else - (cond (function (function))) - (catch #t (lambda () (apply (car mobs) (cons option args))) (lambda (key . args) #f)) - (or #t (run-mobs-rec (cdr mobs)))))) - (run-mobs-rec running-mobs))) - - (set! mob-off - (lambda (mob) - (push mob mobs-to-quit))) - - (set! refresh-running-mobs - (lambda () - (do ((mob (pop mobs-to-add) (pop mobs-to-add))) ((null? mob)) - (push mob running-mobs) - (catch #t (lambda () (mob #:init)) (lambda (key . args) #f))) - (set! running-mobs (reverse (lset-difference eq? running-mobs mobs-to-quit))) - (set! mobs-to-quit '()))) - - (set! quit-all-mobs - (lambda () - (set! running-mobs '()) - (set! mobs-to-add '()) - (set! mobs-to-quit '())))) - - -(define (logic-mobs) - (run-mobs #:logic)) - -(define (render-mobs) - (run-mobs #:render #:function (lambda () (glLoadIdentity)))) + (let ((line (car look))) + (receive (lines images) (process-look (cdr look)) + (cond ((string? line) + (let ((var (gensym))) + (values (cons `(draw-texture ,var) lines) + (cons `(,var (load-texture ,line)) images)))) + (else + (values (cons line lines) + images)))))))) + + (receive (look-lines look-images) (process-look look) + `(let ,look-images + (lambda (attributes) + (let ,(map attr-def attr) + (glPushMatrix) + ,@look-lines + (glPopMatrix)))))) + + +;;; Making mobs + +(define-macro (define-mob mob-head . look) + (let ((name (car mob-head)) (attr (cdr mob-head))) + `(define ,name + (lambda-mob ,attr ,@look)))) + +(define-macro (lambda-mob attr . look) + `(let ((mob #f)) + (set! mob + (let ((attr ',attr) (actions '()) (looks '())) + (lambda (option . params) + (case option + ((get-attr) + attr) + ((set-attr) + (if (not (null? params)) (set! attr (car params)))) + ((get-actions) + actions) + ((set-actions) + (if (not (null? params)) (set! actions (car params)))) + ((get-looks) + looks) + ((set-looks) + (if (not (null? params)) (set! looks (car params)))) + ((run-actions) + (for-each + (lambda (action) + (set! attr ((cdr action) attr))) + actions)) + ((render) + (for-each + (lambda (look) + ((cdr look) attr)) + looks)))))) + (cond ((not (null? ',look)) + (mob 'set-looks + (list (cons + 'default-look + (lambda-look ,attr ,@look)))))) + mob)) + +(define (get-mob-attr mob var) + (let ((value (assoc-ref (mob 'get-attr) var))) + (if value (car value) #f))) + +(define (set-mob-attr! mob var value) + (mob 'set-attr (assoc-set! (mob 'get-attr) var (list value)))) + +(define (add-mob-action mob name action) + (mob 'set-actions (assoc-set! (mob 'get-actions) name action))) + +(define (quit-mob-action mob name) + (mob 'set-actions (assoc-remove! (mob 'get-actions) name))) + +(define (add-mob-look mob name look) + (mob 'set-looks (assoc-set! (mob 'get-looks) name look))) + +(define (quit-mob-look mob name) + (mob 'set-looks (assoc-remove! (mob 'get-looks) name)))