e041a17d4a41635c8b08a1ced34bc2387b5975a0
[uxul-world.git] / 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 (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))