X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Fgacela_mobs.scm;h=5e159075b945586567e7154096dd4386de42b53e;hb=023823491bfe1a64e136bcc2d47c6ec5803f23bf;hp=6081cb4af4cbd6ca683693bcaa8205dd11683696;hpb=34606554273af331e082fc09331ee5c52909650a;p=gacela.git diff --git a/src/gacela_mobs.scm b/src/gacela_mobs.scm index 6081cb4..5e15907 100755 --- a/src/gacela_mobs.scm +++ b/src/gacela_mobs.scm @@ -15,65 +15,154 @@ ;;; along with this program. If not, see . -(use-modules (srfi srfi-1)) - -;;; Mob Factory - -(define-macro (makemob name . methods) - `(define* (,name . args) - (let ((option (car args))) - ,(union - `(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 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))) - (secure-block #f (apply (car mobs) (cons option args))) - (or #t (run-mobs-rec (cdr 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) - (secure-block nil (mob #:init))) - (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)))) +;;; Mobs Factory + +(define show-mob-hash #f) +(define hide-mob-hash #f) +(define get-active-mobs #f) +(define mobs-changed? #f) + +(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 attr-save attr)) + attributes))) + +(define-macro (lambda-look attr . look) + (define (process-look look) + (cond ((null? look) (values '() '())) + (else + (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)))