gacela_procs.lisp

   1 (defmacro defproc (name type variables init logic motion)
   2   `(let ((make-name ',(intern (concatenate 'string "MAKE-" (string name)))))
   3      (setf (symbol-function make-name)
   4            (make-proc-constructor ,type ,variables ,init ,logic ,motion))
   5      make-name))
   6
   7 (defmacro make-proc-constructor (type variables init logic motion)
   8   `(lambda
   9      ,(if (null variables) () (cons '&key variables))
  10      (proc-structure ,type ,variables ,init ,logic ,motion)))
  11
  12 (defmacro proc-structure (type variables init logic motion)
  13   `(list
  14     :type ,type
  15     :init (lambda () ,init)
  16     :logic (lambda () ,logic)
  17     :motion (lambda () ,motion)
  18     :context (lambda ()
  19                ,(if variables
  20                     `(mapcar #'list
  21                              ',(mapcar #'car+ variables)
  22                              (multiple-value-list
  23                               (values-list ,(cons 'list (mapcar #'car+ variables)))))
  24                   nil))))
  25
  26 (defun proc-value (proc label)
  27   (car (cdr (assoc label (funcall (getf proc :context))))))
  28
  29 (defun proc-type (proc)
  30   (getf proc :type))
  31
  32 (defun init-proc (proc)
  33   (funcall (getf proc :init)))
  34
  35 (defun logic-proc (proc)
  36   (funcall (getf proc :logic)))
  37
  38 (defun motion-proc (proc)
  39   (funcall (getf proc :motion)))
  40
  41 (let ((active-procs nil) (procs-to-add nil) (procs-to-quit nil))
  42
  43   (defun add-proc (proc)
  44     (push proc procs-to-add))
  45
  46   (defun logic-procs ()
  47     (dolist (proc active-procs) (logic-proc proc)))
  48
  49   (defun motion-procs ()
  50     (dolist (proc active-procs) (motion-proc proc)))
  51
  52   (defun funcall-procs (func)
  53     (dolist (proc active-procs) (funcall func proc)))
  54
  55   (defun filter-procs (test)
  56     (intersection (mapcar (lambda (p) (cond ((funcall test p) p))) active-procs) active-procs))
  57
  58   (defun quit-proc (proc)
  59     (push proc procs-to-quit))
  60
  61   (defun refresh-active-procs ()
  62     (do ((proc (pop procs-to-add) (pop procs-to-add))) ((null proc))
  63         (push proc active-procs)
  64         (init-proc proc))
  65     (do ((proc (pop procs-to-quit) (pop procs-to-quit))) ((null proc))
  66         (setq active-procs (reverse (set-difference active-procs (list proc) :test #'equal)))))
  67
  68   (defun quit-all-procs ()
  69     (setq active-procs nil)
  70     (setq procs-to-add nil)
  71     (setq procs-to-quit nil)))