(no commit message)

[gacela.git] / src / gacela_mobs.scm

diff --git a/src/gacela_mobs.scm b/src/gacela_mobs.scm
index 09e296a4ccbecb9f2f5aedf45e5cc9a57578a836..12a0ef1d8aa90163e40a2469adfda912ac2b4184 100755 (executable)
--- a/src/gacela_mobs.scm
+++ b/src/gacela_mobs.scm
@@ -17,12 +17,31 @@
 
 (use-modules (srfi srfi-1))
 
+;;; Actions for mobs
+
+(define-macro (define-action action-def . code)
+  (let ((name (car action-def)) (attr (cdr action-def)))
+    `(define (,name mob-attr)
+       (let ,(map attribute-definition attr)
+        ,@code
+        ,(cons 'list (map attribute-result attr))))))
+
+(define (attribute-definition attribute)
+  (let ((name (if (list? attribute) (car attribute) attribute))
+       (value (if (list? attribute) (cadr attribute) #f)))
+    `(,name (let ((v (assoc-ref mob-attr ',name))) (if v (cdr v) ,value)))))
+
+(define (attribute-result attribute)
+  (let ((name (if (list? attribute) (car attribute) attribute)))
+    `(list ',name ,name)))
+
+
 ;;; Mob Factory
 
 (define-macro (makemob name . methods)
   `(define* (,name . args)
      (let ((option (car args)))
-       ,(union
+       ,(lset-union eq?
         `(case option
            (:on (mob-on ',name))
            (:off (mob-off ',name)))
@@ -32,6 +51,20 @@
                   (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)))
+         (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)
@@ -51,7 +84,8 @@
                  (else
                   (cond (function (function)))
                   (catch #t (lambda () (apply (car mobs) (cons option args))) (lambda (key . args) #f))
-                  (or #t (run-mobs-rec (cdr mobs))))))))
+                  (or #t (run-mobs-rec (cdr mobs))))))
+         (run-mobs-rec running-mobs)))
 
   (set! mob-off
        (lambda (mob)
@@ -61,7 +95,7 @@
        (lambda ()
          (do ((mob (pop mobs-to-add) (pop mobs-to-add))) ((null? mob))
            (push mob running-mobs)
-           (secure-block nil (mob #:init)))
+           (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 '())))