/[the-feebs-war]/system.lisp
ViewVC logotype

Contents of /system.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 20 - (show annotations)
Wed Aug 4 00:17:55 2010 UTC (3 years, 8 months ago) by gmilare
File size: 8145 byte(s)
Small bug fix.
1 ;;; -*- Common Lisp -*-
2
3 #| Copyright (c) 2007,2008 Gustavo Henrique Milaré
4
5 This file is part of The Feebs War.
6
7 The Feebs War is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
11
12 The Feebs War is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with The Feebs War. If not, see <http://www.gnu.org/licenses/>.
19 |#
20
21
22 (in-package :the-feebs-war)
23
24
25 ;;; We start defining the main system rules by defining the classes
26
27 ;;; This class is used by the system
28
29 (defclass object ()
30 ((direction :accessor object-direction :initarg :direction)
31 (x-position :accessor object-x-position :initarg :x-position)
32 (y-position :accessor object-y-position :initarg :y-position)
33 (lifetime :accessor object-lifetime :initarg :lifetime :initform 0)))
34
35 (defclass feeb (object)
36 (;; These are structures accessible from behavior functions.
37 (name :accessor feeb-name :reader name :initarg :name)
38 (direction :reader facing :initform (random 4) :accessor feeb-facing)
39 (peeking :accessor feeb-peeking :reader peeking :initform nil)
40 (x-position :reader x-position :accessor feeb-x-position)
41 (y-position :reader y-position :accessor feeb-y-position)
42 (line-of-sight :accessor feeb-line-of-sight :reader line-of-sight
43 :initform 0)
44 (energy-reserve :accessor feeb-energy-reserve :reader energy-reserve)
45 (ready-to-fire :accessor feeb-ready-to-fire :reader ready-to-fire
46 :initform t)
47 (aborted :accessor feeb-aborted :reader aborted)
48 (last-move :accessor feeb-last-move :reader last-move
49 :initform :dead)
50
51 ;; These are available for the system
52 (brain :accessor feeb-brain :initarg :brain)
53 (graphics :accessor feeb-graphics :initarg :graphics)
54 (time :accessor feeb-time :initform 0)
55 (last-score :accessor feeb-last-score :initform 0)
56 (kill-counter :accessor feeb-kill-counter :initform 0)
57 (score :accessor feeb-score :initform 0)
58 (turns-since-flamed :accessor feeb-turns-since-flamed :initform 0)
59 (proximity :accessor feeb-proximity :initform (make-proximity))
60 (vision :accessor feeb-vision
61 :initform (make-array (list (max *maze-y-size* *maze-x-size*))))
62 (vision-left :accessor feeb-vision-left
63 :initform (make-array (list (max *maze-y-size* *maze-x-size*))))
64 (vision-right :accessor feeb-vision-right
65 :initform (make-array (list (max *maze-y-size* *maze-x-size*))))))
66
67 (defclass fireball (object)
68 ((owner :accessor fireball-owner :initarg :owner)
69 (x-position :accessor fireball-x-position)
70 (y-position :accessor fireball-y-position)
71 (direction :accessor fireball-direction)))
72
73 (declaim
74 (inline fireball-p feeb-p))
75
76 (defun fireball-p (x)
77 (typep x 'fireball))
78
79 (defun feeb-p (x)
80 (typep x 'feeb))
81
82
83
84 ;;; Place and delete
85
86 (defun create-mushroom (x y)
87 (unless (member :mushroom (aref *maze* x y))
88 (place-object :mushroom x y)
89 t))
90
91 (defun delete-object (thing x y)
92 (setf (aref *maze* x y)
93 (delete thing (aref *maze* x y))))
94
95 (defun place-object (thing x j)
96 (push thing (aref *maze* x j)))
97
98 (defun change-object-pos (obj x y)
99 (delete-object obj (object-x-position obj)
100 (object-y-position obj))
101 (place-object obj x y)
102 (setf (object-x-position obj) x
103 (object-y-position obj) y))
104
105 (defun get-forward-pos (object)
106 (let ((new-x (+ (forward-dx (object-direction object))
107 (object-x-position object)))
108 (new-y (+ (forward-dy (object-direction object))
109 (object-y-position object))))
110 (values (aref *maze* new-x new-y) new-x new-y)))
111
112
113
114 ;;; --**-- System Rules --**--
115
116
117
118 ;;; -*- Being Born and Dying -*-
119
120 ;;; Creating
121
122 (defgeneric create-object (object x-pos y-pos)
123 (:documentation "Creates OBJECT and places it in position (X-POS,Y-POS)
124 in the maze, except for fireballs, which are placed only the next turn.")
125 (:method (object x-pos y-pos)
126 (place-object object x-pos y-pos)
127 (setf (object-x-position object) x-pos
128 (object-y-position object) y-pos))
129
130 (:method ((feeb feeb) x-pos y-pos)
131 (setf (feeb-last-move feeb) :dead)
132 (push feeb *feebs*)
133 (call-next-method))
134
135 (:method ((fireball fireball) x-pos y-pos)
136 (push fireball *fireballs-flying*)
137 (setf (object-x-position fireball) x-pos
138 (object-y-position fireball) y-pos))) ; don't place it yet, only after first move
139
140 ;;; Reincarnating
141
142 (defun reincarnate-feeb (feeb)
143 (let ((pos (nth (random *number-of-entry-points*) *entry-points*)))
144 (create-object feeb (car pos) (cdr pos))))
145
146 ;;; Dying
147
148 (defgeneric destroy-object (object cause)
149 (:documentation "Called when CAUSE destroys OBJECT.
150 CAUSE could be :starve or a fireball (for feebs)
151 or :dissipate (for fireballs).")
152 (:method (object cause)
153 (delete-object object (object-x-position object)
154 (object-y-position object)))
155
156 (:method ((fireball fireball) cause)
157 (setf *fireballs-flying*
158 (delete fireball *fireballs-flying*))
159 (call-next-method))
160
161 (:method ((feeb feeb) cause)
162 (setf *dead-feebs* (nconc *dead-feebs* (list feeb))
163 *feebs* (delete feeb *feebs*))
164 (let* ((x (feeb-x-position feeb))
165 (y (feeb-y-position feeb)))
166 (push (list 0 x y) *carcasses*)
167 (place-object :carcass x y))
168 (call-next-method)))
169
170
171
172 ;;; -*- Movement Choice -*-
173
174 ;;; Lets the feeb or fireball make a choice
175
176 (defgeneric make-move-choice (object)
177 (:documentation "Lets object make its move choice.")
178 (:method ((feeb feeb))
179 (funcall (feeb-brain feeb)
180 feeb
181 (feeb-proximity feeb)
182 (feeb-vision feeb)
183 (feeb-vision-left feeb)
184 (feeb-vision-right feeb))))
185
186
187
188 ;;; -*- Moving -*-
189
190 (defgeneric make-move (object move)
191 (:documentation "Applies the move MOVE to OBJECT. The MOVE is
192 returned from MAKE-MOVE-CHOICE for the same object.")
193
194 (:method (object move)
195 (warn "Unknown move ~a for object ~a." move object))
196
197 (:method (object (move (eql :turn-right)))
198 (setf (object-direction object)
199 (right-of (object-direction object))))
200
201 (:method (object (move (eql :turn-left)))
202 (setf (object-direction object)
203 (left-of (object-direction object))))
204
205 (:method (object (move (eql :turn-around)))
206 (setf (object-direction object)
207 (behind (object-direction object))))
208
209 (:method (object (move (eql :move-forward)))
210 (multiple-value-bind (stuff new-x new-y)
211 (get-forward-pos object)
212 (unless (wallp stuff)
213 (change-object-pos object new-x new-y)
214 t)))
215
216 (:method ((fireball fireball) (move (eql :dissipate)))
217 (destroy-object fireball :dissipate))
218
219 (:method ((feeb feeb) (move (eql :flame)))
220 (setf (feeb-turns-since-flamed feeb) 0)
221 (create-object
222 (make-instance 'fireball :direction (feeb-facing feeb)
223 :owner feeb)
224 (feeb-x-position feeb) (feeb-y-position feeb)))
225
226 (:method ((feeb feeb) (move (eql :eat-mushroom)))
227 (let ((x (feeb-x-position feeb))
228 (y (feeb-y-position feeb)))
229 (when (find :mushroom (aref *maze* x y))
230 (delete-object :mushroom x y)
231 t)))
232
233 (:method ((feeb feeb) (move (eql :eat-carcass)))
234 (when (find :carcass (aref *maze* (feeb-x-position feeb)
235 (feeb-y-position feeb)))
236 t))
237
238 (:method ((feeb feeb) (move (eql :peek-left)))
239 (unless (wallp (get-forward-pos feeb))
240 (setf (feeb-peeking feeb) move)))
241
242 (:method ((feeb feeb) (move (eql :peek-right)))
243 (unless (wallp (get-forward-pos feeb))
244 (setf (feeb-peeking feeb) move)))
245
246 ) ; end of make-move generic function
247
248 (defmethod make-move :after (object move)
249 (incf (object-lifetime object)))

  ViewVC Help
Powered by ViewVC 1.1.5