1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
(in-package :the-price-of-a-cup-of-coffee)
(defun make-keyword-symbol (s)
"Makes a keyword from a string or symbol."
(let ((s (format nil "~a" s)))
(read-from-string
(format nil ":~a"
(substitute #\- #\Space s)))))
(defmacro def-normal-class (name super &rest slots)
"Defines a class with the given name and slots, with accessors and initargs for each slot."
`(defclass ,name ,super
(,@(loop :for slot :in slots
:when (consp slot)
:collect (list (car slot)
:accessor (car slot)
:initform (cadr slot)
:initarg (make-keyword-symbol (car slot)))
:else
:collect (list slot
:accessor slot
:initform nil
:initarg (make-keyword-symbol slot))))))
(defmacro let-cond (&body forms)
(let ((tmp-var (gensym)))
`(let (,tmp-var)
(cond
,@(loop :for (var test . body) :in forms
:if (eq var t)
:collect (list* t (cons test body))
:else
:collect `((setf ,tmp-var ,test)
(let ((,var ,tmp-var))
,@body)))))))
(defmacro match-key (key &body clauses)
"Each clause is of the form (:scancode-xxx expr1 expr2 ...)"
`(cond ,@(loop :for (scancode . actions) :in clauses
:collect `((sdl2:scancode= ,key ,scancode) ,@actions))))
(defmacro let-when ((var test) &body body)
`(let ((,var ,test))
(when ,var ,@body)))
(defmacro let-if ((var test) then &optional else)
`(let ((,var ,test))
(if ,var ,then ,else)))
(defmacro $ (f &rest args)
(let* ((new-args (loop :for a :in args :when (eql a '_) :collect (gensym)))
(copy-new (copy-seq new-args))
(call-args (loop :for a :in args
:when (eql a '_) :collect (pop copy-new)
:else :collect a)))
`(lambda ,new-args (funcall ,f ,@call-args))))
(defmacro with-surface-from-file ((var path) &body body)
`(let ((,var (sdl2-image:load-image ,path)))
(unwind-protect
(progn ,@body)
(sdl2:free-surface ,var))))
(defmacro with-surface ((var surf) &body body)
`(let ((,var ,surf))
(unwind-protect
(progn ,@body)
(sdl2:free-surface ,var))))
|
