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))
7 (defmacro make-proc-constructor (type variables init logic motion)
9 ,(if (null variables) () (cons '&key variables))
10 (proc-structure ,type ,variables ,init ,logic ,motion)))
12 (defmacro proc-structure (type variables init logic motion)
15 :init (lambda () ,init)
16 :logic (lambda () ,logic)
17 :motion (lambda () ,motion)
21 ',(mapcar #'car+ variables)
23 (values-list ,(cons 'list (mapcar #'car+ variables)))))
26 (defun proc-value (proc label)
27 (car (cdr (assoc label (funcall (getf proc :context))))))
29 (defun proc-type (proc)
32 (defun init-proc (proc)
33 (funcall (getf proc :init)))
35 (defun logic-proc (proc)
36 (funcall (getf proc :logic)))
38 (defun motion-proc (proc)
39 (funcall (getf proc :motion)))
41 (let ((active-procs nil) (procs-to-add nil) (procs-to-quit nil))
43 (defun add-proc (proc)
44 (push proc procs-to-add))
47 (dolist (proc active-procs) (logic-proc proc)))
49 (defun motion-procs ()
50 (dolist (proc active-procs) (motion-proc proc)))
52 (defun funcall-procs (func)
53 (dolist (proc active-procs) (funcall func proc)))
55 (defun filter-procs (test)
56 (intersection (mapcar (lambda (p) (cond ((funcall test p) p))) active-procs) active-procs))
58 (defun quit-proc (proc)
59 (push proc procs-to-quit))
61 (defun refresh-active-procs ()
62 (do ((proc (pop procs-to-add) (pop procs-to-add))) ((null proc))
63 (push proc active-procs)
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)))))
68 (defun quit-all-procs ()
69 (setq active-procs nil)
70 (setq procs-to-add nil)
71 (setq procs-to-quit nil)))