1 ;;; Gacela, a GNU Common Lisp extension for fast games development
2 ;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
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.
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.
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/>.
17 (defconstant INFINITY MOST-POSITIVE-LONG-FLOAT)
19 (defun append-if (new test tree &key (key #'first) (test-if #'equal))
20 (cond ((atom tree) tree)
24 (mapcar (lambda (x) (append-if new test x :key key :test-if test-if)) tree)
28 (defun append-if-1 (new test tree &key (key #'first) (test-if #'equal))
29 (cond ((funcall test-if (funcall key tree) test) (append tree new))
33 (if (listp var) (car var) var))
35 (defun avg (&rest numbers)
37 (dolist (n numbers) (incf total n))
38 (/ total (length numbers))))
44 (let ((sig (signum num)))
48 (defmacro destructure (destructuring-list &body body)
49 (let ((lambda-list nil) (exp-list nil))
50 (dolist (pair destructuring-list)
51 (setq exp-list (cons (car pair) exp-list))
52 (setq lambda-list (cons (cadr pair) lambda-list)))
53 `(destructuring-bind ,lambda-list ,(cons 'list exp-list) ,@body)))
55 (defun match-pattern (list pattern)
56 (cond ((and (null list) (null pattern)) t)
57 ((and (consp list) (consp pattern))
58 (and (match-pattern (car list) (car pattern)) (match-pattern (cdr list) (cdr pattern))))
59 ((and (atom list) (atom pattern))
60 (cond ((or (numberp list) (numberp pattern)) (and (numberp list) (numberp pattern)))
63 (defun nearest-power-of-two (n)
65 (cond ((> (* p 2) n) p)
66 (t (power (* p 2) n)))))
69 (defmacro secure-block (output-stream &rest forms)
70 (let ((error-handler #'si::universal-error-handler))
72 (defun si::universal-error-handler (error-name correctable function-name continue-format-string error-format-string &rest args)
74 `(format ,output-stream
75 (cond ((eq error-name :WRONG-TYPE-ARGUMENT) (string error-name))
76 (t error-format-string))))
77 (setf (symbol-function 'si::universal-error-handler) ,error-handler)
80 (setq result-eval (progn ,@forms))
81 (setf (symbol-function 'si::universal-error-handler) ,error-handler)
84 (defmacro persistent-let (name vars &rest forms)
85 (labels ((get-vars (vars)
86 (cond ((null vars) nil)
87 (t (cons (if (consp (car vars)) (caar vars) (car vars))
88 (get-vars (cdr vars)))))))
90 `(let ,(cond ((functionp name)
91 (let ((old-vars (funcall name)))
92 (cond ((equal (get-vars vars) (get-vars old-vars)) old-vars)
96 ,(let ((lvars (get-vars vars)))
97 `(mapcar (lambda (x y) (list x y)) ',lvars ,(cons 'list lvars))))
102 (match-pattern dot '(0 0)))
104 (defun vectorp (vector)
105 (match-pattern vector '(0 0)))
107 (defun circlep (circle)
108 (match-pattern circle '((0 0) 0)))
110 (defun polygonp (polygon)
111 (cond ((consp polygon)
112 (and (dotp (car polygon))
113 (if (null (cdr polygon)) t (polygonp (cdr polygon)))))))
115 (defun make-dot (x y)
118 (defun make-vector (x y)
121 (defun make-line (dot1 dot2)
124 (defun make-rectangle (x1 y1 x2 y2)
125 `((,x1 ,y1) (,x2 ,y1) (,x2 ,y2) (,x1 ,y2)))
127 (defun polygon-center (polygon)
128 (apply #'mapcar #'avg polygon))
130 (defun dots-distance (dot1 dot2)
131 (destructure ((dot1 (x1 y1))
133 (sqrt (+ (expt (- x2 x1) 2)
134 (expt (- y2 y1) 2)))))
136 (defun dot-line-distance (dot line)
137 (destructure ((line ((ax ay) (bx by)))
139 (let* ((r-numerator (+ (* (- cx ax) (- bx ax)) (* (- cy ay) (- by ay))))
140 (r-denomenator (+ (expt (- bx ax) 2) (expt (- by ay) 2)))
141 (r (/ r-numerator r-denomenator)))
143 (* (abs (/ (- (* (- ay cy) (- bx ax)) (* (- ax cx) (- by ay)))
145 (sqrt r-denomenator))
148 (defun dot-segment-distance (dot segment)
150 (dist r) (dot-line-distance dot segment)
151 (cond ((and (>= r 0) (<= r 1)) dist)
152 (t (let ((dist1 (dots-distance dot (car segment)))
153 (dist2 (dots-distance dot (cadr segment))))
154 (if (< dist1 dist2) dist1 dist2))))))
156 (defun perpendicular-line (dot line)
157 (destructure ((line ((ax ay) (bx by))))
159 (dist r) (dot-line-distance dot line)
161 (make-dot (+ ax (* r (- bx ax)))
162 (+ ay (* r (- by ay))))))))
164 (defun line-angle (line)
165 (destructure ((line ((ax ay) (bx by))))
166 (let ((x (- bx ax)) (y (- by ay)))
167 (if (and (= x 0) (= y 0)) 0 (atan y x)))))
169 (defun inverse-angle (angle)
170 (cond ((< angle pi) (+ angle pi))
173 (defun translate-dot (dot dx dy)
174 (destructure ((dot (x y)))
175 (list (+ x dx) (+ y dy))))
177 (defun translate-circle (circle dx dy)
178 (destructure ((circle (center radius)))
179 (list (translate-dot center dx dy) radius)))
181 (defun translate-polygon (pol dx dy)
182 (mapcar (lambda (dot)
183 (translate-dot dot dx dy))
186 (defun polygon-edges (pol)
187 (mapcar (lambda (v1 v2) (list v1 v2))
189 (union (cdr pol) (list (car pol)))))
191 (defun polygon-dot-intersection (polygon dot)
192 ;Eric Haines algorithm
193 (let ((edges (polygon-edges
194 (translate-polygon polygon (neg (car dot)) (neg (cadr dot)))))
197 (destructure ((edge ((x1 y1) (x2 y2))))
198 (cond ((/= (signum+ y1) (signum+ y2))
199 (cond ((and (> x1 0) (> x2 0)) (incf counter))
200 ((and (or (> x1 0) (> x2 0))
201 (> (- x1 (* y1 (/ (- x2 x1) (- y2 y1)))) 0))
203 (not (evenp counter))))
205 (defun circle-segment-intersection (circle segment)
206 (destructure ((circle (center radius)))
207 (<= (dot-segment-distance center segment) radius)))
209 (defun circle-edges-intersection (circle polygon)
210 (let ((edges (polygon-edges polygon))
213 (cond ((circle-segment-intersection circle edge) (setq edges-i (cons edge edges-i)))))
216 (defun circle-polygon-intersection (circle polygon)
217 (or (polygon-dot-intersection polygon (car circle))
218 (circle-edges-intersection circle polygon)))
220 (defun circle-circle-intersection (circle1 circle2)
221 (destructure ((circle1 (center1 radius1))
222 (circle2 (center2 radius2)))
223 (<= (dots-distance center1 center2) (+ r1 r2))))