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 (in-package :gacela)
  18
  19 (defconstant INFINITY MOST-POSITIVE-LONG-FLOAT)
  20
  21 (defun append-if (new test tree &key (key #'first) (test-if #'equal))
  22   (cond ((atom tree) tree)
  23         (t (append-if-1
  24             new
  25             test
  26             (mapcar (lambda (x) (append-if new test x :key key :test-if test-if)) tree)
  27             :key key
  28             :test-if test-if))))
  29
  30 (defun append-if-1 (new test tree &key (key #'first) (test-if #'equal))
  31   (cond ((funcall test-if (funcall key tree) test) (append tree new))
  32         (t tree)))
  33
  34 (defun car+ (var)
  35   (if (listp var) (car var) var))
  36
  37 (defun avg (&rest numbers)
  38   (let ((total 0))
  39     (dolist (n numbers) (incf total n))
  40     (/ total (length numbers))))
  41
  42 (defun neg (num)
  43   (* -1 num))
  44
  45 (defun signum+ (num)
  46   (let ((sig (signum num)))
  47     (cond ((= sig 0) 1)
  48           (t sig))))
  49
  50 (defmacro destructure (destructuring-list &body body)
  51   (let ((lambda-list nil) (exp-list nil))
  52     (dolist (pair destructuring-list)
  53       (setq exp-list (cons (car pair) exp-list))
  54       (setq lambda-list (cons (cadr pair) lambda-list)))
  55     `(destructuring-bind ,lambda-list ,(cons 'list exp-list) ,@body)))
  56
  57 (defun match-pattern (list pattern)
  58   (cond ((and (null list) (null pattern)) t)
  59         ((and (consp list) (consp pattern))
  60          (and (match-pattern (car list) (car pattern)) (match-pattern (cdr list) (cdr pattern))))
  61         ((and (atom list) (atom pattern))
  62          (cond ((or (numberp list) (numberp pattern)) (and (numberp list) (numberp pattern)))
  63                (t t)))))
  64
  65 (defun nearest-power-of-two (n)
  66   (labels ((power (p n)
  67                   (cond ((> (* p 2) n) p)
  68                         (t (power (* p 2) n)))))
  69           (power 1 n)))
  70
  71 (defmacro secure-block (output-stream &rest forms)
  72   (let ((error-handler #'si::universal-error-handler))
  73     `(block secure
  74        (defun si::universal-error-handler (error-name correctable function-name continue-format-string error-format-string &rest args)
  75          ,(when output-stream
  76             `(format ,output-stream
  77                      (cond ((eq error-name :WRONG-TYPE-ARGUMENT) (string error-name))
  78                            (t error-format-string))))
  79          (setf (symbol-function 'si::universal-error-handler) ,error-handler)
  80          (return-from secure))
  81        (let (result-eval)
  82          (setq result-eval (progn ,@forms))
  83          (setf (symbol-function 'si::universal-error-handler) ,error-handler)
  84          result-eval))))
  85
  86 ;Geometry
  87 (defun dotp (dot)
  88   (match-pattern dot '(0 0)))
  89
  90 (defun vectorp (vector)
  91   (match-pattern vector '(0 0)))
  92
  93 (defun circlep (circle)
  94   (match-pattern circle '((0 0) 0)))
  95
  96 (defun polygonp (polygon)
  97   (cond ((consp polygon)
  98          (and (dotp (car polygon))
  99               (if (null (cdr polygon)) t (polygonp (cdr polygon)))))))
 100
 101 (defun make-dot (x y)
 102   `(,x ,y))
 103
 104 (defun make-vector (x y)
 105   `(,x ,y))
 106
 107 (defun make-line (dot1 dot2)
 108   `(,dot1 ,dot2))
 109
 110 (defun make-rectangle (x1 y1 x2 y2)
 111   `((,x1 ,y1) (,x2 ,y1) (,x2 ,y2) (,x1 ,y2)))
 112
 113 (defun polygon-center (polygon)
 114   (apply #'mapcar #'avg polygon))
 115
 116 (defun dots-distance (dot1 dot2)
 117   (destructure ((dot1 (x1 y1))
 118                 (dot2 (x2 y2)))
 119                (sqrt (+ (expt (- x2 x1) 2)
 120                         (expt (- y2 y1) 2)))))
 121
 122 (defun dot-line-distance (dot line)
 123   (destructure ((line ((ax ay) (bx by)))
 124                 (dot (cx cy)))
 125                (let* ((r-numerator (+ (* (- cx ax) (- bx ax)) (* (- cy ay) (- by ay))))
 126                       (r-denomenator (+ (expt (- bx ax) 2) (expt (- by ay) 2)))
 127                       (r (/ r-numerator r-denomenator)))
 128                  (values
 129                   (* (abs (/ (- (* (- ay cy) (- bx ax)) (* (- ax cx) (- by ay)))
 130                              r-denomenator))
 131                      (sqrt r-denomenator))
 132                   r))))
 133
 134 (defun dot-segment-distance (dot segment)
 135   (multiple-value-bind
 136    (dist r) (dot-line-distance dot segment)
 137         (cond ((and (>= r 0) (<= r 1)) dist)
 138               (t (let ((dist1 (dots-distance dot (car segment)))
 139                        (dist2 (dots-distance dot (cadr segment))))
 140                    (if (< dist1 dist2) dist1 dist2))))))
 141
 142 (defun perpendicular-line (dot line)
 143   (destructure ((line ((ax ay) (bx by))))
 144                (multiple-value-bind
 145                 (dist r) (dot-line-distance dot line)
 146                 (make-line dot
 147                            (make-dot (+ ax (* r (- bx ax)))
 148                                      (+ ay (* r (- by ay))))))))
 149
 150 (defun line-angle (line)
 151   (destructure ((line ((ax ay) (bx by))))
 152                (let ((x (- bx ax)) (y (- by ay)))
 153                  (if (and (= x 0) (= y 0)) 0 (atan y x)))))
 154
 155 (defun inverse-angle (angle)
 156   (cond ((< angle pi) (+ angle pi))
 157         (t (- angle pi))))
 158
 159 (defun translate-dot (dot dx dy)
 160   (destructure ((dot (x y)))
 161                (list (+ x dx) (+ y dy))))
 162
 163 (defun translate-circle (circle dx dy)
 164   (destructure ((circle (center radius)))
 165                (list (translate-dot center dx dy) radius)))
 166
 167 (defun translate-polygon (pol dx dy)
 168   (mapcar (lambda (dot)
 169             (translate-dot dot dx dy))
 170           pol))
 171
 172 (defun polygon-edges (pol)
 173   (mapcar (lambda (v1 v2) (list v1 v2))
 174           pol
 175           (union (cdr pol) (list (car pol)))))
 176
 177 (defun polygon-dot-intersection (polygon dot)
 178 ;Eric Haines algorithm
 179   (let ((edges (polygon-edges
 180                 (translate-polygon polygon (neg (car dot)) (neg (cadr dot)))))
 181         (counter 0))
 182     (dolist (edge edges)
 183       (destructure ((edge ((x1 y1) (x2 y2))))
 184                    (cond ((/= (signum+ y1) (signum+ y2))
 185                           (cond ((and (> x1 0) (> x2 0)) (incf counter))
 186                                 ((and (or (> x1 0) (> x2 0))
 187                                       (> (- x1 (* y1 (/ (- x2 x1) (- y2 y1)))) 0))
 188                                  (incf counter)))))))
 189     (not (evenp counter))))
 190
 191 (defun circle-segment-intersection (circle segment)
 192   (destructure ((circle (center radius)))
 193                (<= (dot-segment-distance center segment) radius)))
 194
 195 (defun circle-edges-intersection (circle polygon)
 196   (let ((edges (polygon-edges polygon))
 197         (edges-i nil))
 198     (dolist (edge edges)
 199       (cond ((circle-segment-intersection circle edge) (setq edges-i (cons edge edges-i)))))
 200     edges-i))
 201
 202 (defun circle-polygon-intersection (circle polygon)
 203   (or (polygon-dot-intersection polygon (car circle))
 204       (circle-edges-intersection circle polygon)))
 205
 206 (defun circle-circle-intersection (circle1 circle2)
 207   (destructure ((circle1 (center1 radius1))
 208                 (circle2 (center2 radius2)))
 209                (<= (dots-distance center1 center2) (+ r1 r2))))