;;; Behaviours of objects
(defmacro make-behaviour (name attr &rest code)
- `(defun ,(get-behaviour-fun-name name) (object)
+ `(defun ,(get-behaviour-fun-name name) (object-attr)
(let ,(mapcar #'attribute-definition attr)
,@code
,(cons 'progn (mapcar #'attribute-save (reverse attr)))
- object)))
+ object-attr)))
(defun get-behaviour-fun-name (name)
- (intern (concatenate 'string "BEHAVIOUR-" (string name)) 'gacela))
+ (intern (concatenate 'string "BEHAVIOUR-" (string-upcase (string name))) 'gacela))
(defun attribute-name (attribute)
(intern (string attribute) 'keyword))
(t attribute)))
(pname (attribute-name name))
(value (cond ((listp attribute) (cadr attribute)))))
- `(,name (getf object ,pname ,value))))
+ `(,name (getf object-attr ,pname ,value))))
(defun attribute-save (attribute)
(let* ((name (cond ((listp attribute) (car attribute))
(t attribute)))
(pname (attribute-name name)))
- `(setf (getf object ,pname) ,name)))
+ `(setf (getf object-attr ,pname) ,name)))
(let (active-objects objects-to-add objects-to-kill)
(defun add-object (object)
- (push object objects-to-add))
+ (pushnew object objects-to-add))
(defun kill-object (object)
- (push object objects-to-kill))
+ (pushnew object objects-to-kill))
(defun kill-all-objects ()
(setq active-objects nil objects-to-add nil objects-to-kill nil))
(setq active-objects (reverse (set-difference active-objects objects-to-kill)))
(setq objects-to-kill nil))))
- (defun render-boxes ()
- (labels ((render (l)
- (cond (l (funcall (render-fun-name (car l)))
- (render (cdr l))))))
- (render visible-boxes))))
+ (defun bhv-objects ()
+ (dolist (o active-objects) (funcall o :action)))
+ (defun render-objects ()
+ (dolist (o active-objects) (funcall o :render))))
-(defmacro make-box (name attr &rest code)
- `(progn
- (let ,(union '((rx 0) (ry 0) (rz 0)) attr)
- (defun ,(render-fun-name name) () ,@code)
- (defun ,(get-props-fun-name name) () (list :rx rx :ry ry :rz rz)))
- (add-box ',name)))
-
-(defmacro make-object (name &key attr bhv look)
- `(let ((object '(:name ,name)))
- (union object
- (union ,(make-object-attributes attr)
- (union ,(make-object-behaviour bhv)
- ,(make-object-look look))))))
-(defun make-object-attributes (attr))
-
-(defun make-object-behaviour (bhv))
+(defmacro make-object (name attr bhv &body look)
+ `(progn
+ (let ((attr ,(cond (attr (cons 'list (make-object-attributes attr)))))
+ (bhv ,(cond (bhv (cons 'list (make-object-behaviour bhv))))))
+ (defun ,name (option &rest param)
+ (case option
+ (:action (dolist (b bhv t) (setq attr (funcall (get-behaviour-fun-name b) attr))))
+ (:get-attr attr)
+ (:get-bhv bhv)
+ (:set-bhv (setq bhv (car param)))
+ (:render (glPushMatrix)
+ ,@(mapcar (lambda (x) (if (stringp x) `(draw-image ,x) x)) look)
+ (glPopMatrix)))))
+ (add-object ',name)
+ ',name))
+
+(defun make-object-attributes (attr)
+ (cond ((or (null attr) (atom attr)) nil)
+ (t (let ((rest (make-object-attributes (cdr attr)))
+ (this (object-attribute-definition (car attr))))
+ (setf (getf rest (car this)) (cadr this))
+ rest))))
+
+(defun object-attribute-definition (attribute)
+ (let* ((name (cond ((listp attribute) (car attribute))
+ (t attribute)))
+ (pname (attribute-name name))
+ (value (cond ((listp attribute) (cadr attribute)))))
+ `(,pname ,value)))
-(defun make-object-look (look))
+(defun make-object-behaviour (bhv)
+ (cond ((null bhv) nil)
+ ((atom bhv) (list bhv))
+ (t bhv)))