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

Contents of /system.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (show annotations)
Sat Mar 15 18:56:01 2008 UTC (6 years, 1 month ago) by gmilare
File size: 7991 byte(s)
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
34 (defclass feeb (object)
35 (;; These are structures accessible from behavior functions.
36 (name :accessor feeb-name :reader name :initarg :name)
37 (direction :reader facing :initform (random 4) :accessor feeb-facing)
38 (peeking :accessor feeb-peeking :reader peeking :initform nil)
39 (x-position :reader x-position :accessor feeb-x-position)
40 (y-position :reader y-position :accessor feeb-y-position)
41 (line-of-sight :accessor feeb-line-of-sight :reader line-of-sight
42 :initform 0)
43 (energy-reserve :accessor feeb-energy-reserve :reader energy-reserve)
44 (ready-to-fire :accessor feeb-ready-to-fire :reader ready-to-fire
45 :initform t)
46 (aborted :accessor feeb-aborted :reader aborted)
47 (last-move :accessor feeb-last-move :reader last-move
48 :initform :dead)
49
50 ;; These are available for the system
51 (brain :accessor feeb-brain :initarg :brain)
52 (graphics :accessor feeb-graphics :initarg :graphics)
53 (time :accessor feeb-time :initform 0)
54 (last-score :accessor feeb-last-score :initform 0)
55 (kill-counter :accessor feeb-kill-counter :initform 0)
56 (score :accessor feeb-score :initform 0)
57 (turns-since-flamed :accessor feeb-turns-since-flamed :initform 0)
58 (proximity :accessor feeb-proximity :initform (make-proximity))
59 (vision :accessor feeb-vision
60 :initform (make-array (list (max *maze-y-size* *maze-x-size*))))
61 (vision-left :accessor feeb-vision-left
62 :initform (make-array (list (max *maze-y-size* *maze-x-size*))))
63 (vision-right :accessor feeb-vision-right
64 :initform (make-array (list (max *maze-y-size* *maze-x-size*))))))
65
66 (defclass fireball (object)
67 ((owner :accessor fireball-owner :initarg :owner)
68 (x-position :accessor fireball-x-position)
69 (y-position :accessor fireball-y-position)
70 (direction :accessor fireball-direction)))
71
72 (declaim
73 (inline fireball-p feeb-p))
74
75 (defun fireball-p (x)
76 (typep x 'fireball))
77
78 (defun feeb-p (x)
79 (typep x 'feeb))
80
81
82
83 ;;; Place and delete
84
85 (defun create-mushroom (x y)
86 (unless (member :mushroom (aref *maze* x y))
87 (place-object :mushroom x y)
88 t))
89
90 (defun delete-object (thing x y)
91 (setf (aref *maze* x y)
92 (delete thing (aref *maze* x y))))
93
94 (defun place-object (thing x j)
95 (push thing (aref *maze* x j)))
96
97 (defun change-object-pos (obj x y)
98 (delete-object obj (object-x-position obj)
99 (object-y-position obj))
100 (place-object obj x y)
101 (setf (object-x-position obj) x
102 (object-y-position obj) y))
103
104 (defun get-forward-pos (object)
105 (let ((new-x (+ (forward-dx (object-direction object))
106 (object-x-position object)))
107 (new-y (+ (forward-dy (object-direction object))
108 (object-y-position object))))
109 (values (aref *maze* new-x new-y) new-x new-y)))
110
111
112
113 ;;; --**-- System Rules --**--
114
115
116
117 ;;; -*- Being Born and Dying -*-
118
119 ;;; Creating
120
121 (defgeneric create-object (object x-pos y-pos)
122 (:documentation "Creates OBJECT and places it in position (X-POS,Y-POS)
123 in the maze, except for fireballs, which are placed only the next turn.")
124 (:method (object x-pos y-pos)
125 (place-object object x-pos y-pos)
126 (setf (object-x-position object) x-pos
127 (object-y-position object) y-pos))
128
129 (:method ((feeb feeb) x-pos y-pos)
130 (setf (feeb-last-move feeb) :dead)
131 (push feeb *feebs*)
132 (call-next-method))
133
134 (:method ((fireball fireball) x-pos y-pos)
135 (push fireball *fireballs-flying*)
136 (setf (object-x-position fireball) x-pos
137 (object-y-position fireball) y-pos))) ; don't place it yet, only after first move
138
139 ;;; Reincarnating
140
141 (defun reincarnate-feeb (feeb)
142 (let ((pos (nth (random *number-of-entry-points*) *entry-points*)))
143 (create-object feeb (car pos) (cdr pos))))
144
145 ;;; Dying
146
147 (defgeneric destroy-object (object cause)
148 (:documentation "Called when CAUSE destroys OBJECT.
149 CAUSE could be :starve or a fireball (for feebs)
150 or :dissipate (for fireballs).")
151 (:method (object cause)
152 (delete-object object (object-x-position object)
153 (object-y-position object)))
154
155 (:method ((fireball fireball) cause)
156 (setf *fireballs-flying*
157 (delete fireball *fireballs-flying*))
158 (call-next-method))
159
160 (:method ((feeb feeb) cause)
161 (setf *dead-feebs* (nconc *dead-feebs* (list feeb))
162 *feebs* (delete feeb *feebs*))
163 (let* ((x (feeb-x-position feeb))
164 (y (feeb-y-position feeb)))
165 (push (list 0 x y) *carcasses*)
166 (place-object :carcass x y))
167 (call-next-method)))
168
169
170
171 ;;; -*- Movement Choice -*-
172
173 ;;; Lets the feeb or fireball make a choice
174
175 (defgeneric make-move-choice (object)
176 (:documentation "Lets object make its move choice.")
177 (:method ((feeb feeb))
178 (funcall (feeb-brain feeb)
179 feeb
180 (feeb-proximity feeb)
181 (feeb-vision feeb)
182 (feeb-vision-left feeb)
183 (feeb-vision-right feeb))))
184
185
186
187 ;;; -*- Moving -*-
188
189 (defgeneric make-move (object move)
190 (:documentation "Applies the move MOVE to OBJECT. The MOVE is
191 returned from MAKE-MOVE-CHOICE for the same object.")
192
193 (:method (object move)
194 (warn "Unknown move ~a for object ~a." move object))
195
196 (:method (object (move (eql :turn-right)))
197 (setf (object-direction object)
198 (right-of (object-direction object))))
199
200 (:method (object (move (eql :turn-left)))
201 (setf (object-direction object)
202 (left-of (object-direction object))))
203
204 (:method (object (move (eql :turn-around)))
205 (setf (object-direction object)
206 (behind (object-direction object))))
207
208 (:method (object (move (eql :move-forward)))
209 (multiple-value-bind (stuff new-x new-y)
210 (get-forward-pos object)
211 (unless (wallp stuff)
212 (change-object-pos object new-x new-y)
213 t)))
214
215 (:method ((fireball fireball) (move (eql :dissipate)))
216 (destroy-object fireball :dissipate))
217
218 (:method ((feeb feeb) (move (eql :flame)))
219 (setf (feeb-turns-since-flamed feeb) 0)
220 (create-object
221 (make-instance 'fireball :direction (feeb-facing feeb)
222 :owner feeb)
223 (feeb-x-position feeb) (feeb-y-position feeb)))
224
225 (:method ((feeb feeb) (move (eql :eat-mushroom)))
226 (let ((x (feeb-x-position feeb))
227 (y (feeb-y-position feeb)))
228 (when (find :mushroom (aref *maze* x y))
229 (delete-object :mushroom x y)
230 t)))
231
232 (:method ((feeb feeb) (move (eql :eat-carcass)))
233 (when (find :carcass (aref *maze* (feeb-x-position feeb)
234 (feeb-y-position feeb)))
235 t))
236
237 (:method ((feeb feeb) (move (eql :peek-left)))
238 (unless (wallp (get-forward-pos feeb))
239 (setf (feeb-peeking feeb) move)))
240
241 (:method ((feeb feeb) (move (eql :peek-right)))
242 (unless (wallp (get-forward-pos feeb))
243 (setf (feeb-peeking feeb) move)))
244
245 ) ; end of make-move generic function
246

  ViewVC Help
Powered by ViewVC 1.1.5