room.lisp

   1 ;;; Copyright 2009 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 (caddddr item)))
 122         (cond
 123           ((eq type 'uxul)
 124            (setf (x player) (* 128 x))
 125            (setf (y player) (* 128 y))
 126            (add-object player room))
 127           ((eq type 'tulip)
 128            (add-object (make-instance 'tulip
 129                                       :x (* 128 x)
 130                                       :y (* 128 y)) room))
 131           ((eq type 'brown-stone)
 132            (add-object (make-instance 'stone
 133                                       :animation (make-animation 0 |brown_stone|)
 134                                       :x (* 128 x)
 135                                       :y (* 128 y)) room))
 136           ((eq type 'gray-stone)
 137            (add-object (make-instance 'stone
 138                                       :animation (make-animation 0 |gray_stone|)
 139                                       :x (* 128 x)
 140                                       :y (* 128 y)) room))
 141           ((eq type 'nasobem)
 142            (add-object (make-instance 'simple-enemy
 143                                       :x (* 128 x)
 144                                       :y (* 128 y)) room))
 145           ((eq type 'blue-nasobem)
 146            (add-object (make-instance 'flying-nasobem
 147                                       :x (* 128 x)
 148                                       :y (* 128 y)) room))
 149           (T
 150            (add-object (make-instance type
 151                                       :x (* 128 x)
 152                                       :y (* 128 y)) room)))))
 153     room))