game-object.lisp

   1 ;;; Copyright 2009-2011 Christoph Senjak
   2
   3 (in-package :uxul-world)
   4
   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
   9
  10 ;; We changed the api, and added stuff from Collision-Rectangle (which
  11 ;; explains some documentation about it)
  12
  13 (defclass game-object (xy-coordinates)
  14   ((width :initarg :width
  15           :initform 0
  16           :accessor width
  17           :type fixnum
  18           :documentation "The width of that rectangle")
  19    (height :initarg :height
  20            :initform 0
  21            :accessor height
  22            :type fixnum
  23            :documentation "The height of that rectangle")
  24    (listen-to :initarg :listen-to
  25               :initform NIL
  26               :accessor listen-to
  27               :documentation "List of rectangles and game-objects to
  28               check for collisions at movement")
  29    (colliding :initarg :colliding
  30               :initform T
  31               :accessor colliding
  32 ;             :type boolean
  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
  37               listen-to-lists")
  38    (visible :initarg :visible
  39             :initform T
  40             :accessor visible
  41 ;           :type boolean
  42             :documentation "Should this Object be drawn?")
  43    (redraw :initarg :redraw
  44            :initform T
  45            :accessor 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
  58            the engine.
  59
  60 **********************FIXME: DOESNT WORK ATM**********************
  61
  62 ")
  63    (active :initarg :active
  64            :initform NIL
  65            :accessor active
  66 ;          :type boolean
  67             :documentation "Will the Invoke-Function be called?")
  68    (object-id :initarg :object-id
  69               :initform NIL
  70               :accessor 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." ))
  75
  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: ")
  79   (write obj)
  80   (sdl:push-quit-event))
  81
  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: ")
  85   (write obj)
  86   (sdl:push-quit-event))
  87
  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."))
  92
  93 (defmethod half-width ((obj game-object))
  94   (/ (width obj) 2))
  95 (defmethod (setf half-width) (x (obj game-object))
  96   (setf (width obj) (* x 2)))
  97 (defmethod half-height ((obj game-object))
  98   (/ (height obj) 2))
  99 (defmethod (setf half-height) (x (obj game-object))
 100   (setf (height obj) (* x 2)))
 101
 102 (defmethod mid-x ((obj game-object))
 103   (+ (x obj) (half-width obj)))
 104
 105 (defmethod mid-y ((obj game-object))
 106   (+ (y obj) (half-height obj)))
 107
 108 (defmethod (setf mid-x) (x (obj game-object))
 109   (setf (x obj) (- x (half-width obj))))
 110
 111 (defmethod (setf mid-y) (y (obj game-object))
 112   (setf (y obj) (- y (half-height obj))))
 113
 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)))))
 121
 122
 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)))))
 127
 128
 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)
 134   ;;                    :color sdl:*BLACK*)
 135 )
 136
 137 (defun collide-blocks (moving-rectangle standing-rectangle collision)
 138   "as MANY collision-methods need to move the moving-object around the
 139 standing-object, we will write a function for doing that. IMPORTANT:
 140 moving-rectangle MUST have a dont-ignore-property"
 141   (declare (ignore standing-rectangle))
 142   (directly-with-all-accessors collision collision
 143     (setf (x moving-rectangle) (x pos))
 144     (setf (y moving-rectangle) (y pos))
 145     (cond
 146       ((or (eq direction :left) (eq direction :right))
 147        (move-about moving-rectangle (make-xy 0 (truncate (* (- 1 collision-time) (y desired-movement))))))
 148       ((or (eq direction :up) (eq direction :down))
 149        (move-about moving-rectangle (make-xy (truncate (* (- 1 collision-time) (x desired-movement))) 0)))
 150       (T ;; diagonal - argh! lets try to move up/down. if this fails,
 151        ;; lets try to move left/right. we're setting our
 152        ;; dont-ignore-flag to nil for that
 153        (let ((current-y (y moving-rectangle))
 154              (current-x (x moving-rectangle)))
 155          (setf (dont-ignore moving-rectangle) nil)
 156          (move-about moving-rectangle (make-xy (truncate (* (- 1 collision-time) (x desired-movement))) 0))
 157          (if (not (= current-x (x moving-rectangle)))
 158              (progn
 159                (setf (x moving-rectangle) current-x)
 160                (setf (dont-ignore moving-rectangle) T)
 161                ;; now really move it!
 162                (move-about moving-rectangle (make-xy (truncate (* (- 1 collision-time) (x desired-movement))) 0)))
 163                                         ;else - it cannot move in x-direction...
 164              (progn
 165                (move-about moving-rectangle (make-xy 0 (truncate (* (- 1 collision-time) (y desired-movement)))))
 166                (when (not (= current-y (y moving-rectangle)))
 167                  (setf (y moving-rectangle) current-y)
 168                  (setf (dont-ignore moving-rectangle) T)
 169                  ;; now really move it!
 170                  (move-about moving-rectangle (make-xy 0 (truncate (* (- 1 collision-time) (y desired-movement)))))))))))))