1 ;;; Copyright 2009 Christoph Senjak
3 (in-package :uxul-world)
5 ;; Define a class for the Standard Game-Object which has a draw-Method
6 ;; which will be called at every frame, and a Collision-Box, and has a
7 ;; unique (x, y)-Coordinate with translations for both the Drawable
8 ;; Object and the collision-box
10 ;; We changed the api, and added stuff from Collision-Rectangle (which
11 ;; explains some documentation about it)
13 (defclass game-object (xy-coordinates)
14 ((width :initarg :width
18 :documentation "The width of that rectangle")
19 (height :initarg :height
23 :documentation "The height of that rectangle")
24 (listen-to :initarg :listen-to
27 :documentation "List of rectangles and game-objects to
28 check for collisions at movement")
29 (colliding :initarg :colliding
33 :documentation "Throw Collisions with this
34 Collision-Rectangle to other Collision-Rectangles? (this
35 makes it a bit easier to \"turn off\" Objects, i.e. you
36 dont always have to remove them from the
38 (visible :initarg :visible
42 :documentation "Should this Object be drawn?")
43 (redraw :initarg :redraw
46 :documentation "If set to nil, this object will be painted
47 once onto the Background of the Level and then never be
48 painted again (except when needed), i.e. the engine first
49 paints it onto its background-surface, and then it keeps
50 using its background-surface for all further images. This
51 makes drawing faster. It should be set to NIL whenever
52 possible, however, if the Object will change its place or
53 look different in the future, or should be painted over
54 some other object that can move or change its look, then it
55 must be set to T, because it must be redrawn. NOTICE: It is
56 not specified, what happens, if this Value changes during
57 runtime. It should not be set manually after it is used by
60 **********************FIXME: DOESNT WORK ATM**********************
63 (active :initarg :active
67 :documentation "Will the Invoke-Function be called?")
68 (object-id :initarg :object-id
71 :documentation "To identify an object, a room may give it an id."))
72 (:documentation "Define a Class for all Game-Objects. This class
73 has an invoke-, a draw- and an on-collide Function, which do
74 nothing per default." ))
76 (defmethod draw ((obj game-object))
77 "To be called when drawing the object - does nothing per default, except throwing a warning."
78 (format t "waring: draw-method not overridden. Object: ")
80 (sdl:push-quit-event))
82 (defmethod invoke ((obj game-object))
83 "To be called when invoking the object - does nothing per default, except throwing a warning."
84 (format t "warning: invoke-method not overridden. Object: ")
86 (sdl:push-quit-event))
88 (defmethod on-collision ((moving-object game-object) (standing-object game-object) (collision collision))
89 "To be called if a Collision occurs. May have more than one overriding declaration, to use the dispatcher."
90 (declare (ignore standing-object moving-object collision))
91 (format t "warning: on-collision-method not overridden."))
93 (defmethod half-width ((obj game-object))
95 (defmethod (setf half-width) (x (obj game-object))
96 (setf (width obj) (* x 2)))
97 (defmethod half-height ((obj game-object))
99 (defmethod (setf half-height) (x (obj game-object))
100 (setf (height obj) (* x 2)))
102 (defmethod mid-x ((obj game-object))
103 (+ (x obj) (half-width obj)))
105 (defmethod mid-y ((obj game-object))
106 (+ (y obj) (half-height obj)))
108 (defmethod (setf mid-x) (x (obj game-object))
109 (setf (x obj) (- x (half-width obj))))
111 (defmethod (setf mid-y) (y (obj game-object))
112 (setf (y obj) (- y (half-height obj))))
114 (defmethod move-about ((moving-rectangle game-object) (translation xy-struct))
115 (if (= (x translation) 0)
116 (when (not (= (y translation) 0))
117 (move-collision-rectangle-about-y moving-rectangle (y translation)))
118 (if (= (y translation) 0)
119 (move-collision-rectangle-about-x moving-rectangle (x translation))
120 (move-collision-rectangle-about-xy moving-rectangle (x translation) (y translation)))))
123 (defmethod move-to ((moving-rectangle game-object) (translation xy-struct))
124 "This is highly inefficient and should be replaced"
125 (move-about moving-rectangle
126 (make-xy (- (x translation) (x moving-rectangle)) (- (y translation) (y moving-rectangle)))))
129 (defmethod draw-bounds ((obj game-object))
130 "This function draws a rectangle with the Object's Bounds. May be useful for some debug-spam"
131 (sdl:draw-rectangle-* (+ (x obj) *current-translation-x*)
132 (+ (y obj) *current-translation-y*)
133 (width obj) (height obj)
136 (defun collide-blocks (moving-rectangle standing-rectangle collision)
137 "as MANY collision-methods need to move the moving-object around the
138 standing-object, we will write a function for doing that. IMPORTANT:
139 moving-rectangle MUST have a dont-ignore-property"
140 (declare (ignore standing-rectangle))
141 (directly-with-all-accessors collision collision
142 (setf (x moving-rectangle) (x pos))
143 (setf (y moving-rectangle) (y pos))
145 ((or (eq direction :left) (eq direction :right))
146 (move-about moving-rectangle (make-xy 0 (truncate (* (- 1 collision-time) (y desired-movement))))))
147 ((or (eq direction :up) (eq direction :down))
148 (move-about moving-rectangle (make-xy (truncate (* (- 1 collision-time) (x desired-movement))) 0)))
149 (T ;; diagonal - argh! lets try to move up/down. if this fails,
150 ;; lets try to move left/right. we're setting our
151 ;; dont-ignore-flag to nil for that
152 (let ((current-y (y moving-rectangle))
153 (current-x (x moving-rectangle)))
154 (setf (dont-ignore moving-rectangle) nil)
155 (move-about moving-rectangle (make-xy (truncate (* (- 1 collision-time) (x desired-movement))) 0))
156 (if (not (= current-x (x moving-rectangle)))
158 (setf (x moving-rectangle) current-x)
159 (setf (dont-ignore moving-rectangle) T)
160 ;; now really move it!
161 (move-about moving-rectangle (make-xy (truncate (* (- 1 collision-time) (x desired-movement))) 0)))
162 ;else - it cannot move in x-direction...
164 (move-about moving-rectangle (make-xy 0 (truncate (* (- 1 collision-time) (y desired-movement)))))
165 (when (not (= current-y (y moving-rectangle)))
166 (setf (y moving-rectangle) current-y)
167 (setf (dont-ignore moving-rectangle) T)
168 ;; now really move it!
169 (move-about moving-rectangle (make-xy 0 (truncate (* (- 1 collision-time) (y desired-movement)))))))))))))