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   (dolist (item item-list)
 109     (let ((y (car item))
 110           (x (cadr item))
 111           (type (caddr item)))
 112       (cond
 113         ((eq type 'uxul)
 114          (setf (x player) (* 128 x))
 115          (setf (y player) (* 128 y))
 116          (add-object player room))
 117         ((eq type 'tulip)
 118          (add-object (make-instance 'tulip
 119                                     :x (* 128 x)
 120                                     :y (* 128 y)) room))
 121         ((eq type 'brown-stone)
 122          (add-object (make-instance 'stone
 123                                     :animation (make-animation 0 |brown_stone|)
 124                                     :x (* 128 x)
 125                                     :y (* 128 y)) room))
 126         ((eq type 'gray-stone)
 127          (add-object (make-instance 'stone
 128                                     :animation (make-animation 0 |gray_stone|)
 129                                     :x (* 128 x)
 130                                     :y (* 128 y)) room))
 131         ((eq type 'nasobem)
 132          (add-object (make-instance 'simple-enemy
 133                                     :x (* 128 x)
 134                                     :y (* 128 y)) room))
 135         ((eq type 'blue-nasobem)
 136          (add-object (make-instance 'flying-nasobem
 137                                     :x (* 128 x)
 138                                     :y (* 128 y)) room))
 139         (T
 140          (add-object (make-instance type
 141                                  :x (* 128 x)
 142                                  :y (* 128 y)) room)))))
 143   room))