room.lisp

   1 ;;; Copyright 2009-2011 Christoph Senjak
   2
   3 (in-package :uxul-world)
   4
   5 (defvar *current-room*)
   6
   7 (declaim (inline get-by-index))
   8
   9 (defun get-by-index (index array)
  10   (svref array index))
  11
  12 (defun create-object-array ()
  13   (make-array (list (length +class-indices+))
  14               :element-type 'list
  15               :initial-element nil
  16               :adjustable nil))
  17
  18 (defun add-object-of-class (object array)
  19   (dolist (class (c2mop:class-precedence-list (class-of object)))
  20     (let ((index (position (class-name class) +class-indices+)))
  21       (if index
  22           (pushnew object (svref array index))))))
  23
  24 (defun get-objects-of-class (class-name array)
  25   (get-by-index (position class-name +class-indices+) array))
  26
  27
  28 (define-compiler-macro get-objects-of-class (&whole form class-name array)
  29    (if (constantp class-name)
  30        `(get-by-index ,(position (eval class-name) +class-indices+) ,array)
  31        form))
  32
  33 (defun get-objects (room class)
  34   (get-objects-of-class class (object-array room)))
  35
  36 (define-compiler-macro get-objects (&whole form room class-name)
  37   (format t "Compiler Macro for get-objects...")
  38   (print (if (constantp class-name)
  39       `(get-by-index ,(position (eval class-name) +class-indices+) (object-array ,room))
  40       form
  41       )))
  42
  43 (defclass room ()
  44   ((key-down-function :initform
  45                       #'(lambda (key) (declare (ignore key)))
  46                       :accessor key-down-function
  47                       :initarg :key-down-function
  48                       :documentation "Function to call in case of a
  49                       key-down event.")
  50    (key-up-function :initform
  51                     #'(lambda (key) (declare (ignore key)))
  52                     :accessor key-up-function
  53                     :initarg :key-up-function
  54                     :documentation "Function to call in case of a
  55                     key-up event.")
  56    (object-array :initform (create-object-array)
  57                  :accessor object-array
  58                  :initarg :object-array
  59                  :documentation "Array of Objects indexed by class.")
  60    (key-listener :initarg :key-listener
  61                  :accessor key-listener
  62                  :documentation "An Object with Methods on-key-up and
  63                  on-key-down, to which key-events are passed.")
  64    (graphic-centralizer :initarg :graphic-centralizer
  65                         :accessor graphic-centralizer)
  66    (background-surface :initarg :background-surface
  67                        :accessor background-surface)
  68    (background-surface-drawn :initarg :background-surface-drawn
  69                              :accessor background-surface-drawn
  70                              :initform nil)
  71    (invocation-function :initform nil
  72                         :accessor invocation-function
  73                         :documentation "Will be called, if not nil, by
  74    invoke, so 'overriding' the invoke-method for room (implemented for
  75    Pausings, etc.). Set to nil, the normal invoke-method will be
  76    called again.")
  77    (width :initarg :width :accessor width)
  78    (height :initarg :height :accessor height)
  79    (position-table :initarg :position-table :accessor position-table
  80                    :initform (make-hash-table :test 'eql)
  81                    :documentation ":tblabla-Symbols in
  82    make-tiled-room are pushed as keys with the associated
  83    positions to this table.")))
  84
  85 (defmethod on-key-down ((obj room) key)
  86   (on-key-down (key-listener obj) key))
  87
  88 (defmethod on-key-up ((obj room) key)
  89   (on-key-up (key-listener obj) key))
  90
  91 (defmethod invoke ((obj room))
  92   (if (invocation-function obj)
  93       (funcall (invocation-function obj) obj)
  94       (dolist (invoker (get-objects obj 'uxul-world::game-object))
  95         (if (active invoker) (invoke invoker)))))
  96
  97 (defun create-room-from-item-list (item-list)
  98   (let*
  99       ((player (make-instance 'player
 100                                 :active t
 101                                 :visible t
 102                                 :redraw t))
 103        (room (make-instance 'room :width 0 :height 0
 104                             :graphic-centralizer player
 105                             :key-listener player
 106                             :key-up-function #'(lambda (key) (on-key-up player key))
 107                             :key-down-function #'(lambda (key) (on-key-down player key))))
 108        (anchor-table (make-hash-table :test 'equal)))
 109     (dolist (item item-list)
 110       (let ((y (car item))
 111             (x (cadr item))
 112             (type (caddr item))
 113             (arg1 (cadddr item)))
 114         (when (eq type 'anchor)
 115           (setf (gethash arg1 anchor-table) (cons x y)))))
 116     (dolist (item item-list)
 117       (let ((y (car item))
 118             (x (cadr item))
 119             (type (caddr item))
 120             (arg1 (cadddr item))
 121             (arg2 (car (cddddr item))))
 122         (cond
 123           ((eq type 'anchor))
 124           ((eq type 'uxul)
 125            (setf (x player) (* 128 x))
 126            (setf (y player) (* 128 y))
 127            (add-object player room))
 128           ((eq type 'tulip)
 129            (add-object (make-instance 'tulip
 130                                       :x (* 128 x)
 131                                       :y (* 128 y)) room))
 132           ((eq type 'brown-stone)
 133            (add-object (make-instance 'stone
 134                                       :animation (make-animation 0 |brown_stone|)
 135                                       :x (* 128 x)
 136                                       :y (* 128 y)) room))
 137           ((eq type 'gray-stone)
 138            (add-object (make-instance 'stone
 139                                       :animation (make-animation 0 |gray_stone|)
 140                                       :x (* 128 x)
 141                                       :y (* 128 y)) room))
 142           ((eq type 'nasobem)
 143            (add-object (make-instance 'simple-enemy
 144                                       :x (* 128 x)
 145                                       :y (* 128 y)) room))
 146           ((eq type 'blue-nasobem)
 147            (add-object (make-instance 'flying-nasobem
 148                                       :x (* 128 x)
 149                                       :y (* 128 y)) room))
 150           ((eq type 'key)
 151            (add-object (make-instance 'key
 152                                       :x (* 128 x)
 153                                       :y (* 128 y)
 154                                       :dungeon arg1) room))
 155           ((eq type 'door)
 156            (add-object (make-instance 'door
 157                                       :x (* 128 x)
 158                                       :y (* 128 y)
 159                                       :dungeon arg1) room))
 160           ((eq type 'burning-marshmallow)
 161            (add-object (make-instance 'burning-marshmallow
 162                                       :x (* 128 x)
 163                                       :y (* 128 y)
 164                                       :inner-rectangle
 165                                       (and (not (string= arg1 "")) (not (string= arg2 ""))
 166                                            (list
 167                                             (* 128 (car (gethash arg1 anchor-table)))
 168                                             (* 128 (cdr (gethash arg1 anchor-table)))
 169                                             (* 128 (1+ (car (gethash arg2 anchor-table))))
 170                                             (* 128 (1+ (cdr (gethash arg2 anchor-table))))))) room))
 171           (T
 172            (add-object (make-instance type
 173                                       :x (* 128 x)
 174                                       :y (* 128 y)) room)))))
 175     room))
 176
 177 (defparameter *additional-testing-room*
 178   '((14 8 NASOBEM "" "") (3 9 BURNING-MARSHMALLOW "" "")
 179     (5 10 DOOR "" "")
 180     (5 14 BROWN-STONE "" "") (5 13 BROWN-STONE "" "") (5 12 BROWN-STONE "" "")
 181     (5 11 BROWN-STONE "" "") (5 6 BROWN-STONE "" "") (5 9 BROWN-STONE "" "")
 182     (5 8 BROWN-STONE "" "") (5 7 BROWN-STONE "" "") (7 14 TULIP "" "")
 183     (1 2 KEY "" "") (1 1 TULIP "" "") (2 3 DOOR "" "") (3 4 BROWN-STONE "" "")
 184     (2 4 BROWN-STONE "" "") (1 4 BROWN-STONE "" "") (2 2 BROWN-STONE "" "")
 185     (2 1 BROWN-STONE "" "") (4 3 BROWN-STONE "" "") (4 2 BROWN-STONE "" "")
 186     (7 6 DOOR "" "") (11 3 DOOR "" "") (5 1 KEY "" "") (5 3 BROWN-STONE "" "")
 187     (5 2 DOOR "" "") (5 4 BROWN-STONE "" "") (5 5 BROWN-STONE "" "")
 188     (6 5 BROWN-STONE "" "") (7 5 BROWN-STONE "" "") (7 3 BROWN-STONE "" "")
 189     (6 1 BROWN-STONE "" "") (7 2 BROWN-STONE "" "") (7 1 TULIP "" "")
 190     (9 3 BROWN-STONE "" "") (9 2 BROWN-STONE "" "") (11 1 BROWN-STONE "" "")
 191     (11 2 BROWN-STONE "" "") (13 9 BROWN-STONE "" "") (11 5 DOOR "" "")
 192     (9 14 KEY "" "") (9 12 KEY "" "") (8 14 BROWN-STONE "" "")
 193     (9 13 BROWN-STONE "" "") (8 13 BROWN-STONE "" "") (7 13 BROWN-STONE "" "")
 194     (7 12 BROWN-STONE "" "") (7 11 BROWN-STONE "" "") (7 10 BROWN-STONE "" "")
 195     (7 9 BROWN-STONE "" "") (7 8 BROWN-STONE "" "") (7 7 BROWN-STONE "" "")
 196     (8 7 BROWN-STONE "" "") (9 7 BROWN-STONE "" "") (9 6 BROWN-STONE "" "")
 197     (9 5 BROWN-STONE "" "") (9 4 BROWN-STONE "" "") (10 4 BROWN-STONE "" "")
 198     (11 4 BROWN-STONE "" "") (11 6 BROWN-STONE "" "") (11 7 BROWN-STONE "" "")
 199     (11 8 BROWN-STONE "" "") (10 10 KEY "" "") (10 11 BROWN-STONE "" "")
 200     (9 11 BROWN-STONE "" "") (9 10 BROWN-STONE "" "") (9 9 BROWN-STONE "" "")
 201     (10 9 BROWN-STONE "" "") (11 9 BROWN-STONE "" "") (12 12 KEY "" "")
 202     (11 14 BROWN-STONE "" "") (11 13 BROWN-STONE "" "") (11 12 BROWN-STONE "" "")
 203     (11 11 BROWN-STONE "" "") (12 11 BROWN-STONE "" "") (13 13 BROWN-STONE "" "")
 204     (13 12 BROWN-STONE "" "") (13 11 BROWN-STONE "" "") (13 10 BROWN-STONE "" "")
 205     (13 8 BROWN-STONE "" "") (13 7 BROWN-STONE "" "") (13 6 BROWN-STONE "" "")
 206     (13 5 BROWN-STONE "" "") (13 4 BROWN-STONE "" "") (13 3 BROWN-STONE "" "")
 207     (13 2 BROWN-STONE "" "") (14 1 UXUL "" "") (0 14 BROWN-STONE "" "")
 208     (0 13 BROWN-STONE "" "") (0 12 BROWN-STONE "" "") (0 11 BROWN-STONE "" "")
 209     (0 10 BROWN-STONE "" "") (0 9 BROWN-STONE "" "") (0 8 BROWN-STONE "" "")
 210     (0 7 BROWN-STONE "" "") (0 6 BROWN-STONE "" "") (0 5 BROWN-STONE "" "")
 211     (0 4 BROWN-STONE "" "") (0 3 BROWN-STONE "" "") (0 2 BROWN-STONE "" "")
 212     (0 1 BROWN-STONE "" "") (0 0 BROWN-STONE "" "") (1 0 BROWN-STONE "" "")
 213     (2 0 BROWN-STONE "" "") (3 0 BROWN-STONE "" "") (6 0 BROWN-STONE "" "")
 214     (5 0 BROWN-STONE "" "") (4 0 BROWN-STONE "" "") (7 0 BROWN-STONE "" "")
 215     (8 0 BROWN-STONE "" "") (9 0 BROWN-STONE "" "") (10 0 BROWN-STONE "" "")
 216     (11 0 BROWN-STONE "" "") (12 0 BROWN-STONE "" "") (13 0 BROWN-STONE "" "")
 217     (14 0 BROWN-STONE "" "") (8 15 BROWN-STONE "" "") (7 15 BROWN-STONE "" "")
 218     (5 15 BROWN-STONE "" "") (6 15 BROWN-STONE "" "") (4 15 BROWN-STONE "" "")
 219     (3 15 BROWN-STONE "" "") (2 15 BROWN-STONE "" "") (1 15 BROWN-STONE "" "")
 220     (0 15 BROWN-STONE "" "") (9 15 BROWN-STONE "" "") (10 15 BROWN-STONE "" "")
 221     (11 15 BROWN-STONE "" "") (12 15 BROWN-STONE "" "") (13 15 BROWN-STONE "" "")
 222     (14 15 BROWN-STONE "" "") (15 15 BROWN-STONE "" "") (15 14 BROWN-STONE "" "")
 223     (15 13 BROWN-STONE "" "") (15 12 BROWN-STONE "" "") (15 11 BROWN-STONE "" "")
 224     (15 10 BROWN-STONE "" "") (15 9 BROWN-STONE "" "") (15 8 BROWN-STONE "" "")
 225     (15 7 BROWN-STONE "" "") (15 6 BROWN-STONE "" "") (15 5 BROWN-STONE "" "")
 226     (15 4 BROWN-STONE "" "") (15 3 BROWN-STONE "" "") (15 2 BROWN-STONE "" "")
 227     (15 1 BROWN-STONE "" "") (15 0 BROWN-STONE "" "")))
 228 (defun make-additional-testing-room ()
 229   (let
 230       ((room (create-room-from-item-list *additional-testing-room*)))
 231     (add-object (make-instance 'teleporter
 232                                :next-room-function #'make-testing-room
 233                                :x (* 128 9) :y (* 128 14)
 234                                :active nil :redraw T :visible T :colliding T) room)
 235     room))