1 ;;; Copyright 2009 Christoph Senjak
3 (in-package :uxul-world)
5 (defvar *current-translation-x* 0)
6 (defvar *current-translation-y* 0)
7 (defmacro with-translation-* ((x y) &body body)
8 `(let ((*current-translation-x* (+ ,x *current-translation-x*))
9 (*current-translation-y* (+ ,y *current-translation-y*)))
12 (defmacro with-translation ((translation) &body body)
13 `(with-translation-* ((x ,translation) (y ,translation)) ,@body))
15 (defmacro with-negative-translation-* ((x y) &body body)
16 `(with-translation-* ((- ,x) (- ,y)) ,@body))
18 (defmacro with-negative-translation ((translation) &body body)
19 `(with-negative-translation-* ((x ,translation) (y ,translation)) ,@body))
21 (defmacro directly-with-accessors (accessors objname &body body)
24 (dolist (arg accessors args)
25 (push (list arg arg) args))))
28 (defun class-all-readers (class)
29 (nconc (loop for superclass in
30 (closer-mop:class-direct-superclasses class)
31 nconc (class-all-readers superclass))
32 (loop for direct-slot in
33 (closer-mop:class-direct-slots class)
35 (closer-mop:slot-definition-readers direct-slot))))
37 (defmacro directly-with-all-accessors (classname objname &body body)
38 `(directly-with-accessors (,@(class-all-readers (find-class classname)))
41 (defmacro defvars (&rest vars)
44 (dolist (var vars ret)
45 (push `(defvar ,var) ret)))))
48 (defmacro let-accessor (((accessor object) value) &body body)
49 "Temporarily set an Accessor to another value."
50 (let ((symbol (gensym)))
51 `(let ((,symbol (,accessor ,object)))
53 (progn (setf (,accessor ,object) ,value) ,@body)
54 (setf (,accessor ,object) ,symbol)))))
56 (defmacro let-accessors ((&rest bindings) &body body)
57 "Temporarily set Accessors to other values."
58 (let ((cbind (car bindings)))
61 ((,(first (first cbind)) ,(second (first cbind))) ,(second cbind))
62 (let-accessors (,@(cdr bindings)) ,@body))