1 ;;; Copyright 2009 Christoph Senjak
3 (in-package :uxul-world)
5 (declaim (optimize (speed 3))
6 (inline rectangles-overlap is-horizontal is-vertical turn90
9 (defun rectangles-overlap (x1 y1 x2 y2 x3 y3 x4 y4)
10 "Does the rectangle with diagonal points (x1,y1) and (x2, y2)
11 overlap with (x3, y3),(x4,y4)? Assuming x1<x2, x3<x4, y same. We dont
12 add the limits to the rectangle, we only see the interior points."
20 (defun symbol-prename (symbol &optional (charnum 1))
21 "Returns just the first <charnum> Characters of the name of that symbol"
22 (subseq (symbol-name symbol) 0 charnum))
24 (defun symbol-index (symbol &optional (charnum 1))
25 "Removes the first (or charnum) character(s) of a Symbol and parses
26 the rest into an integer, i.e. makes 1 out of :R1"
27 (parse-integer (subseq (symbol-name symbol) charnum)))
29 (defun is-horizontal (direction)
30 (or (eq direction :LEFT) (eq direction :RIGHT)))
32 (defun is-vertical (direction)
33 (or (eq direction :UP) (eq direction :DOWN)))
35 (defun turn90 (direction)
37 ((eq direction :LEFT) :UP)
38 ((eq direction :RIGHT) :DOWN)
39 ((eq direction :UP) :RIGHT)
40 ((eq direction :DOWN) :LEFT)))
42 (defun turn270 (direction)
44 ((eq direction :LEFT) :DOWN)
45 ((eq direction :RIGHT) :UP)
46 ((eq direction :UP) :LEFT)
47 ((eq direction :DOWN) :RIGHT)))
49 (defun string-ends-with (str1 str2)
50 (let ((length1 (length str1))
51 (length2 (length str2)))
52 (and (>= length1 length2)
53 (string= (subseq str1 (- length1 length2)) str2))))
55 (defun lower-interval-bound (x1 x2 y1 y2)
56 "Find the lower interval-bound of [x1, x2] /\ [y1, y2] or - if
57 disjoint - return NIL."
58 (let ((xmin (min x1 x2))
62 (if (<= xmin ymin xmax) ymin
63 (if (<= ymin xmin ymax) xmin NIL))))
65 (defmacro swapsort (a b)
69 (defun move-collision-rectangle-about-x (moving-object delta-x)
70 "this function is only a helper for a special case of the method
71 move-about for collision-objects, which is invoked iff there is no
72 movement in y-direction AND x is not zero"
73 (let ((current-time 1)
74 (current-collision NIL)
75 (current-standing-object NIL))
76 (dolist (standing-object (listen-to moving-object))
77 (when (and (colliding standing-object) (not (eq standing-object moving-object)))
78 (when (< (* 2 (abs (- (mid-y moving-object) (mid-y standing-object))))
79 (+ (height moving-object) (height standing-object)))
80 ;are the y-coordinates near enough such that a collision *can* occur?
81 (let* ((x-minimal-distance (+ (half-width moving-object) (half-width standing-object)))
82 (x-distance (- (mid-x standing-object) (mid-x moving-object)))
84 (/ (+ x-minimal-distance x-distance) delta-x))
86 (/ (- x-distance x-minimal-distance) delta-x))
87 (x-minimal-collide-time (min x-collide-time-1 x-collide-time-2)))
88 (when (<= 0 x-minimal-collide-time current-time)
89 ;an earlier collision can only
90 ;occur between 0 and the
91 ;current-time which is <1 and
92 ;maybe was set before.
93 (setf current-time x-minimal-collide-time)
94 (setf current-collision
97 :desired-movement (make-xy delta-x 0)
98 :pos (make-xy (+ (truncate (* current-time delta-x)) (x moving-object)) (y moving-object))
99 :collision-time current-time
100 :direction (if (> delta-x 0) :right :left)))
101 (setf current-standing-object standing-object))))))
102 (if current-collision ;if a collision occured, this must be the first now
103 (on-collision moving-object current-standing-object current-collision)
104 (incf (x moving-object) delta-x)))
105 ;; (move-collision-rectangle-about-xy moving-object delta-x 0)
109 (defun move-collision-rectangle-about-y (moving-object delta-y)
110 "this function is only a helper for a special case of the method
111 move-about for collision-objects, which is invoked iff there is no
112 movement in y-direction AND x is not zero"
113 (let ((current-time 1)
114 (current-collision NIL)
115 (current-standing-object NIL))
116 (dolist (standing-object (listen-to moving-object))
117 (when (and (colliding standing-object) (not (eq standing-object moving-object)))
118 (when (< (abs (* 2 (- (mid-x moving-object) (mid-x standing-object))))
119 (+ (width moving-object) (width standing-object)))
120 ;are the y-coordinates near enough such that a collision *can* occur?
121 (let* ((y-minimal-distance (+ (half-height moving-object) (half-height standing-object)))
122 (y-distance (- (mid-y standing-object) (mid-y moving-object)))
124 (/ (+ y-minimal-distance y-distance) delta-y))
126 (/ (- y-distance y-minimal-distance) delta-y))
127 (y-minimal-collide-time (min y-collide-time-1 y-collide-time-2)))
128 (when (<= 0 y-minimal-collide-time current-time)
129 ;an earlier collision can only occur between 0 and the current-time
130 ;which is <1 and maybe was set before.
131 (setf current-time y-minimal-collide-time)
132 (setf current-collision
135 :desired-movement (make-xy 0 delta-y)
136 :pos (make-xy (x moving-object) (+ (truncate (* current-time delta-y)) (y moving-object)))
137 :collision-time current-time
138 :direction (if (> delta-y 0) :down :up)))
139 (setf current-standing-object standing-object))))))
140 (if current-collision ;if a collision occured, this must be the first now
141 (on-collision moving-object current-standing-object current-collision)
142 (incf (mid-y moving-object) delta-y)))
143 ;; (move-collision-rectangle-about-xy moving-object 0 delta-y)
149 (defun rational-= (n1 d1 n2 d2)
150 (= (* n1 d2) (* n2 d1)))
152 #|(defun rational-< (n1 d1 n2 d2 &rest args)
153 "Compare rationals even if the denominators are zero. Behaviour for
154 0/0 is not specified and may change."
157 (< (signum n1) (signum n2))
159 (< (* n1 (abs d2) (signum d1)) (* n2 (abs d1) (signum d2))))
161 (apply #'rational-< n2 d2 args))))|#
164 #|(defun rational-<= (n1 d1 n2 d2 &rest args)
165 "Compare rationals even if the denominators are zero. Behaviour for
166 0/0 is not specified and may change."
169 (<= (signum n1) (signum n2))
171 (<= (* n1 (abs d2) (signum d1)) (* n2 (abs d1) (signum d2))))
173 (apply #'rational-<= n2 d2 args))))|#
175 (defun rational-<= (n1 d1 n2 d2 &rest args)
177 (<= (* n1 (abs d2) (signum d1)) (* n2 (abs d1) (signum d2)))
180 (apply #'rational-<= n2 d2 args))))
182 (defun rational-< (n1 d1 n2 d2 &rest args)
184 (< (* n1 (abs d2) (signum d1)) (* n2 (abs d1) (signum d2)))
187 (apply #'rational-< n2 d2 args))))
189 (defun rational-> (n1 d1 n2 d2 &rest args)
190 (and (rational-< n2 d2 n1 d1)
192 (apply #'rational-> n2 d2 args))))
194 (defun rational->= (n1 d1 n2 d2 &rest args)
195 (and (rational-<= n2 d2 n1 d1)
197 (apply #'rational->= n2 d2 args))))
199 #|FIIIIIIIIXMEEEEEEEEEEE!!!!!!!!!1111111!!!!!!!!!111
201 (defun move-collision-rectangle-about-xy (moving-object x y)
202 "GIANT ugly but faster implementation than before..."
203 (declare (type fixnum x y)
204 (type game-object moving-object))
205 (let* ((current-time-num 1)
206 (current-time-denom 1)
207 (collision-with-x nil)
208 (collision-with-y nil)
209 (current-standing-object nil)
210 (wm (width moving-object))
211 (hm (height moving-object))
212 (x1 (x moving-object))
213 (y1 (y moving-object))
216 (declare (type fixnum current-time-num current-time-denom wm x1
218 (type boolean collision-with-x collision-with-y))
219 (dolist (standing-object (listen-to moving-object))
220 (let* ((ws (width standing-object))
221 (hs (height standing-object))
222 (x3 (x standing-object))
223 (y3 (y standing-object))
226 (y-enter (- (sgn y))) ;; gain negative infty for y-enter/0
228 (x-enter (- (sgn x))) ;; gain negative infty for x-enter/0
230 (declare (type fixnum ws hs x3 y3 x4 y4 y-enter y-leave
233 ;; is the object colliding? does the standing object overlap a (huge enough)
234 ;; rectangle around the moving object?
236 (colliding standing-object)
237 #| (rectangles-overlap (- x1 absx)
241 x3 y3 (1+ x4) (1+ y4))|#
247 ;; (format t "x-inside")
248 (macrolet ((calc-x ()
251 (setf x-leave (- x4 x1))
252 (setf x-leave (- x3 x2))))))
257 ;; rectangles do overlap before movement ... do
261 ;; standing-object is over moving-object
264 ;; no collision - wrong direction, or no
268 ;; collision may occur
269 (setf y-enter (- y1 y4))
270 (setf y-leave (- y3 y2))
274 ;; standing-object is below moving-object
277 ;; no collision - wrong direction, or no movement
281 ;; collision may occur
282 (setf y-enter (- y3 y2))
283 (setf y-leave (- y4 y1))
287 ;; standing-rectangle left of moving-rectangle
288 (macrolet ((calc-x ()
290 `(progn (setf x-enter (- x3 x2))
291 (setf x-leave (- x4 x1)))))
294 ;; no collision - wrong direction, or no movement at
298 ;; collision may occur - check y
304 (setf y-leave (if (> y 0) (- y2 y3) (- y1 y4)))
308 ;; standing-object is over moving-object
311 ;; no collision - wrong direction, or no
315 ;; collision may occur
316 (setf y-enter (- y4 y1))
317 (setf y-leave (- y3 y2))
321 ;; standing-object is below moving-object
324 ;; no collision - wrong direction, or no movement
328 ;; collision may occur
329 (setf y-enter (- y3 y2))
330 (setf y-leave (- y4 y1))
334 ;; standing-rectangle right of moving-rectangle
335 (macrolet ((calc-x ()
338 (setf x-leave (- x2 x3))
339 (setf x-enter (- x1 x4)))))
342 ;; no collision - wrong direction, or no movement at
346 ;; collision may occur - check y
351 ;; y-bounds of standing-object lie completely
352 ;; inside y-bounds of moving-object.
353 (setf y-leave (if (> y 0) (- y1 y4) (- y2 y3)))
357 ;; standing-object is over moving-object
360 ;; no collision - wrong direction, or no
364 ;; collision may occur
365 (setf y-enter (- y1 y4))
366 (setf y-leave (- y3 y2))
370 ;; standing-object is below moving-object
373 ;; no collision - wrong direction, or no movement
377 ;; collision may occur
378 (setf y-enter (- y3 y2))
379 (setf y-leave (- y1 y4))
383 ;; collision could occure - find the smallest collision-time
385 (progn (format t "---~%could occure.~%current ~d/~d~%x-enter ~d/~d~%x-leave ~d/~d~%y-enter ~d/~d~%y-leave ~d/~d~%---~%"
386 current-time-num current-time-denom
387 x-enter x x-leave x y-enter y y-leave y) t)
390 ((rational-<= x-enter x y-enter y x-leave x)
391 ;; first collision-time is y-enter/y - check if this is
392 ;; smaller (earlier) than current-time-num/current-time-denom
394 (when (rational-< y-enter y current-time-num current-time-denom)
395 (setf current-standing-object standing-object)
396 (setf current-time-denom y)
397 (setf current-time-num y-enter)
398 (setf collision-with-y t)
399 (setf collision-with-x (rational-<= y-enter y y-enter x y-leave y))))
400 ((rational-<= y-enter y x-enter x y-leave y) ;; first collision-time is x-enter/y
401 (when (rational-< x-enter x current-time-num current-time-denom)
402 (setf current-standing-object standing-object)
403 (setf current-time-denom x)
404 (setf current-time-num x-enter)
405 (setf collision-with-x t)
406 (setf collision-with-y nil)))
409 (current-standing-object
410 (format t "occured~d~%" current-time-num)
411 ; (write (cons current-time-num current-time-denom))
412 ;; a collision occured
413 (on-collision moving-object current-standing-object
414 (make-instance 'collision
415 :desired-movement (make-xy x y)
417 (the rational (/ current-time-num
420 (+ (truncate (* current-time-num x) current-time-denom) x1)
421 (+ (truncate (* current-time-num y) current-time-denom) y1))
422 :direction (if collision-with-x
425 (if (> y 0) :down :up))
426 (if (> x 0) :right :left)))))
428 (setf (x moving-object) (+ x1 x))
429 (setf (y moving-object) (+ y1 y))))))|#
434 (defun move-collision-rectangle-about-xy (moving-object x y)
435 "this function is only a helper for a special case of the method
436 move-about for collision-objects, which is invoked iff both x and y
438 (declare (optimize (debug 0) (safety 0) (space 0) (compilation-speed 0) (speed 3))
440 (type game-object moving-object))
443 (xm (x moving-object))
444 (ym (y moving-object))
445 (wm (width moving-object))
446 (hm (height moving-object))
447 (2*current-time-num 2)
448 (current-time-denom 1)
449 (current-standing-object NIL)
450 (current-direction nil))
451 (declare (type fixnum xm ym wm hm 2*current-time-num
452 current-time-denom absx absy)
453 (type symbol current-direction)
455 (let ((2*mid-x-moving (the fixnum (+ xm xm wm)))
456 (2*mid-y-moving (the fixnum (+ ym ym hm))))
457 (declare (type fixnum 2*mid-x-moving 2*mid-y-moving))
458 (dolist (standing-object (listen-to moving-object))
461 ;;;;;;;;;;;;; BEEEEEEEEEEETTTTTTTTTTEEEEEEEEEEEEEEEEEERRRRRRRRRRRRRRRR!!!!!!!!!!!!!!!!!!
463 (colliding standing-object)
465 #| (rectangles-overlap (- xm absx) (- ym absy) (+ xm wm absy) (+ ym hm absx)
466 (- xs absx) (- ys absy) (+ xs ws absx) (+ ys hs absy))
469 (rectangles-overlap xm ym (+ xm wm) (+ ym hm)
470 xs ys (+ xs hs) (+ ys hs)))|#
472 (not (eq moving-object standing-object))
475 (let* ((xs (x standing-object))
476 (ys (y standing-object))
477 (ws (width standing-object))
478 (hs (height standing-object))
479 (temporary-direction nil)
480 (2*x-minimal-distance (the fixnum (+ wm ws)))
481 (2*y-minimal-distance (the fixnum (+ hm hs)))
482 (2*x-distance (the fixnum (- (+ xs xs ws) 2*mid-x-moving)))
483 (2*y-distance (the fixnum (- (+ ys ys hs) 2*mid-y-moving)))
484 (2*x-collide-time-1 (the fixnum (+ 2*x-minimal-distance 2*x-distance)))
485 (2*x-collide-time-2 (the fixnum (- 2*x-distance 2*x-minimal-distance)))
486 (2*y-collide-time-1 (the fixnum (+ 2*y-minimal-distance 2*y-distance)))
487 (2*y-collide-time-2 (the fixnum (- 2*y-distance 2*y-minimal-distance)))
488 (minimal-collide-time-denom 0)
489 (2*minimal-collide-time-num
492 (if (> 2*x-collide-time-1 2*x-collide-time-2)
493 (rotatef 2*x-collide-time-1 2*x-collide-time-2))
494 (if (< 2*x-collide-time-1 2*x-collide-time-2)
495 (rotatef 2*x-collide-time-1 2*x-collide-time-2)))
497 (if (> 2*y-collide-time-1 2*y-collide-time-2)
498 (rotatef 2*y-collide-time-1 2*y-collide-time-2))
499 (if (< 2*y-collide-time-1 2*y-collide-time-2)
500 (rotatef 2*y-collide-time-1 2*y-collide-time-2)))
502 ((rational-<= 2*x-collide-time-1 x 2*y-collide-time-1 y 2*x-collide-time-2 x)
503 (setf minimal-collide-time-denom y)
504 (setf temporary-direction (if (> y 0) :down :up))
506 ((rational-<= 2*y-collide-time-1 y 2*x-collide-time-1 x 2*y-collide-time-2 y)
507 (setf minimal-collide-time-denom x)
508 (setf temporary-direction (if (> x 0) :right :left))
511 (declare (type fixnum xs ys ws hs 2*x-minimal-distance
512 2*y-minimal-distance 2*x-distance
513 2*y-distance 2*x-collide-time-1
514 2*x-collide-time-2 2*y-collide-time-1
516 2*minimal-collide-time-num
517 minimal-collide-time-denom)
518 (type symbol temporary-direction))
519 (when (and (not (zerop minimal-collide-time-denom))
521 2*minimal-collide-time-num minimal-collide-time-denom
522 2*current-time-num current-time-denom))
523 (setf 2*current-time-num 2*minimal-collide-time-num)
524 (setf current-time-denom minimal-collide-time-denom)
525 (setf current-direction
527 ((or (eq temporary-direction :right)
528 (eq temporary-direction :left))
529 (if (or (rational-= 2*minimal-collide-time-num
530 minimal-collide-time-denom
533 (rational-= 2*minimal-collide-time-num
534 minimal-collide-time-denom
538 temporary-direction))
539 ((or (eq temporary-direction :up)
540 (eq temporary-direction :down))
541 (if (or (rational-= 2*minimal-collide-time-num
542 minimal-collide-time-denom
545 (rational-= 2*minimal-collide-time-num
546 minimal-collide-time-denom
550 temporary-direction))))
551 (setf current-standing-object standing-object)))))
552 (if current-direction
553 (on-collision moving-object current-standing-object
554 (make-instance 'collision
555 :desired-movement (make-xy x y)
556 :collision-time (the rational (/ 2*current-time-num (* 2 current-time-denom)))
559 (truncate (the fixnum (* 2*current-time-num x))
560 (the fixnum (* 2 current-time-denom)))
562 (+ (truncate (the fixnum (* 2*current-time-num y))
563 (the fixnum (* 2 current-time-denom)))
565 :direction current-direction))
567 (setf (x moving-object) (the fixnum (+ (x moving-object) x)))
568 (setf (y moving-object) (the fixnum (+ (y moving-object) y)))
572 (defun old-draw-rectangle (obj &key (r 0) (g 0) (b 0))
573 (sdl:draw-rectangle-* (+ *current-translation-x* (x obj))
574 (+ *current-translation-y* (y obj))
577 :color (sdl:color :r r :g g :b b)))