]> git.jsancho.org Git - gacela.git/blob - gacela_misc.lisp
(no commit message)
[gacela.git] / gacela_misc.lisp
1 ;;; Gacela, a GNU Common Lisp extension for fast games development
2 ;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation, either version 3 of the License, or
7 ;;; (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16
17
18 (eval-when (compile load eval)
19            (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
20            (in-package 'gacela :nicknames '(gg) :use '(lisp)))
21
22
23 (defconstant INFINITY MOST-POSITIVE-LONG-FLOAT)
24
25 (defun append-if (new test tree &key (key #'first) (test-if #'equal))
26   (cond ((atom tree) tree)
27         (t (append-if-1
28             new
29             test
30             (mapcar (lambda (x) (append-if new test x :key key :test-if test-if)) tree)
31             :key key
32             :test-if test-if))))
33
34 (defun append-if-1 (new test tree &key (key #'first) (test-if #'equal))
35   (cond ((funcall test-if (funcall key tree) test) (append tree new))
36         (t tree)))
37
38 (defun car+ (var)
39   (if (listp var) (car var) var))
40
41 (defun avg (&rest numbers)
42   (let ((total 0))
43     (dolist (n numbers) (incf total n))
44     (/ total (length numbers))))
45
46 (defun neg (num)
47   (* -1 num))
48
49 (defun signum+ (num)
50   (let ((sig (signum num)))
51     (cond ((= sig 0) 1)
52           (t sig))))
53
54 (defmacro destructure (destructuring-list &body body)
55   (let ((lambda-list nil) (exp-list nil))
56     (dolist (pair destructuring-list)
57       (setq exp-list (cons (car pair) exp-list))
58       (setq lambda-list (cons (cadr pair) lambda-list)))
59     `(destructuring-bind ,lambda-list ,(cons 'list exp-list) ,@body)))
60
61 (defun match-pattern (list pattern)
62   (cond ((and (null list) (null pattern)) t)
63         ((and (consp list) (consp pattern))
64          (and (match-pattern (car list) (car pattern)) (match-pattern (cdr list) (cdr pattern))))
65         ((and (atom list) (atom pattern))
66          (cond ((or (numberp list) (numberp pattern)) (and (numberp list) (numberp pattern)))
67                (t t)))))
68
69 (defun nearest-power-of-two (n)
70   (labels ((power (p n)
71                   (cond ((> (* p 2) n) p)
72                         (t (power (* p 2) n)))))
73           (power 1 n)))
74
75 (defmacro secure-block (output-stream &rest forms)
76   (let ((error-handler #'si::universal-error-handler))
77     `(block secure
78        (defun si::universal-error-handler (error-name correctable function-name continue-format-string error-format-string &rest args)
79          ,(when output-stream
80             `(write-line
81               (cond ((eq error-name :WRONG-TYPE-ARGUMENT) (string error-name))
82                     (t error-format-string))
83               ,output-stream))
84          (setf (symbol-function 'si::universal-error-handler) ,error-handler)
85          (return-from secure))
86        (let (result-eval)
87          (setq result-eval (progn ,@forms))
88          (setf (symbol-function 'si::universal-error-handler) ,error-handler)
89          result-eval))))
90
91 (defmacro persistent-let (name vars &rest forms)
92   (labels ((get-vars (vars)
93                      (cond ((null vars) nil)
94                            (t (cons (if (consp (car vars)) (caar vars) (car vars))
95                                     (get-vars (cdr vars)))))))
96    
97           `(let ,(cond ((functionp name)
98                         (let ((old-vars (funcall name)))
99                           (cond ((equal (get-vars vars) (get-vars old-vars)) old-vars)
100                                 (t vars))))
101                        (t vars))
102              (defun ,name ()
103                ,(let ((lvars (get-vars vars)))
104                   `(mapcar (lambda (x y) (list x y)) ',lvars ,(cons 'list lvars))))
105              ,@forms)))
106
107 ;Geometry
108 (defun dotp (dot)
109   (match-pattern dot '(0 0)))
110
111 (defun vectorp (vector)
112   (match-pattern vector '(0 0)))
113
114 (defun circlep (circle)
115   (match-pattern circle '((0 0) 0)))
116
117 (defun polygonp (polygon)
118   (cond ((consp polygon)
119          (and (dotp (car polygon))
120               (if (null (cdr polygon)) t (polygonp (cdr polygon)))))))
121
122 (defun make-dot (x y)
123   `(,x ,y))
124
125 (defun make-vector (x y)
126   `(,x ,y))
127
128 (defun make-line (dot1 dot2)
129   `(,dot1 ,dot2))
130
131 (defun make-rectangle (x1 y1 x2 y2)
132   `((,x1 ,y1) (,x2 ,y1) (,x2 ,y2) (,x1 ,y2)))
133
134 (defun polygon-center (polygon)
135   (apply #'mapcar #'avg polygon))
136
137 (defun dots-distance (dot1 dot2)
138   (destructure ((dot1 (x1 y1))
139                 (dot2 (x2 y2)))
140                (sqrt (+ (expt (- x2 x1) 2)
141                         (expt (- y2 y1) 2)))))
142
143 (defun dot-line-distance (dot line)
144   (destructure ((line ((ax ay) (bx by)))
145                 (dot (cx cy)))
146                (let* ((r-numerator (+ (* (- cx ax) (- bx ax)) (* (- cy ay) (- by ay))))
147                       (r-denomenator (+ (expt (- bx ax) 2) (expt (- by ay) 2)))
148                       (r (/ r-numerator r-denomenator)))
149                  (values
150                   (* (abs (/ (- (* (- ay cy) (- bx ax)) (* (- ax cx) (- by ay)))
151                              r-denomenator))
152                      (sqrt r-denomenator))
153                   r))))
154
155 (defun dot-segment-distance (dot segment)
156   (multiple-value-bind
157    (dist r) (dot-line-distance dot segment)
158         (cond ((and (>= r 0) (<= r 1)) dist)
159               (t (let ((dist1 (dots-distance dot (car segment)))
160                        (dist2 (dots-distance dot (cadr segment))))
161                    (if (< dist1 dist2) dist1 dist2))))))
162
163 (defun perpendicular-line (dot line)
164   (destructure ((line ((ax ay) (bx by))))
165                (multiple-value-bind
166                 (dist r) (dot-line-distance dot line)
167                 (make-line dot
168                            (make-dot (+ ax (* r (- bx ax)))
169                                      (+ ay (* r (- by ay))))))))
170
171 (defun line-angle (line)
172   (destructure ((line ((ax ay) (bx by))))
173                (let ((x (- bx ax)) (y (- by ay)))
174                  (if (and (= x 0) (= y 0)) 0 (atan y x)))))
175
176 (defun inverse-angle (angle)
177   (cond ((< angle pi) (+ angle pi))
178         (t (- angle pi))))
179
180 (defun translate-dot (dot dx dy)
181   (destructure ((dot (x y)))
182                (list (+ x dx) (+ y dy))))
183
184 (defun translate-circle (circle dx dy)
185   (destructure ((circle (center radius)))
186                (list (translate-dot center dx dy) radius)))
187
188 (defun translate-polygon (pol dx dy)
189   (mapcar (lambda (dot)
190             (translate-dot dot dx dy))
191           pol))
192
193 (defun polygon-edges (pol)
194   (mapcar (lambda (v1 v2) (list v1 v2))
195           pol
196           (union (cdr pol) (list (car pol)))))
197
198 (defun polygon-dot-intersection (polygon dot)
199 ;Eric Haines algorithm
200   (let ((edges (polygon-edges
201                 (translate-polygon polygon (neg (car dot)) (neg (cadr dot)))))
202         (counter 0))
203     (dolist (edge edges)
204       (destructure ((edge ((x1 y1) (x2 y2))))
205                    (cond ((/= (signum+ y1) (signum+ y2))
206                           (cond ((and (> x1 0) (> x2 0)) (incf counter))
207                                 ((and (or (> x1 0) (> x2 0))
208                                       (> (- x1 (* y1 (/ (- x2 x1) (- y2 y1)))) 0))
209                                  (incf counter)))))))
210     (not (evenp counter))))
211
212 (defun circle-segment-intersection (circle segment)
213   (destructure ((circle (center radius)))
214                (<= (dot-segment-distance center segment) radius)))
215
216 (defun circle-edges-intersection (circle polygon)
217   (let ((edges (polygon-edges polygon))
218         (edges-i nil))
219     (dolist (edge edges)
220       (cond ((circle-segment-intersection circle edge) (setq edges-i (cons edge edges-i)))))
221     edges-i))
222
223 (defun circle-polygon-intersection (circle polygon)
224   (or (polygon-dot-intersection polygon (car circle))
225       (circle-edges-intersection circle polygon)))
226
227 (defun circle-circle-intersection (circle1 circle2)
228   (destructure ((circle1 (center1 radius1))
229                 (circle2 (center2 radius2)))
230                (<= (dots-distance center1 center2) (+ r1 r2))))