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

Contents of /system.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 20 - (hide 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 gmilare 1 ;;; -*- Common Lisp -*-
2    
3 gmilare 14 #| Copyright (c) 2007,2008 Gustavo Henrique Milaré
4 gmilare 1
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 gmilare 7 along with The Feebs War. If not, see <http://www.gnu.org/licenses/>.
19 gmilare 1 |#
20    
21    
22 gmilare 14 (in-package :the-feebs-war)
23 gmilare 1
24 gmilare 5
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 gmilare 20 ((direction :accessor object-direction :initarg :direction)
31 gmilare 11 (x-position :accessor object-x-position :initarg :x-position)
32 gmilare 19 (y-position :accessor object-y-position :initarg :y-position)
33 gmilare 20 (lifetime :accessor object-lifetime :initarg :lifetime :initform 0)))
34 gmilare 5
35     (defclass feeb (object)
36     (;; These are structures accessible from behavior functions.
37 gmilare 11 (name :accessor feeb-name :reader name :initarg :name)
38 gmilare 13 (direction :reader facing :initform (random 4) :accessor feeb-facing)
39     (peeking :accessor feeb-peeking :reader peeking :initform nil)
40 gmilare 11 (x-position :reader x-position :accessor feeb-x-position)
41     (y-position :reader y-position :accessor feeb-y-position)
42 gmilare 5 (line-of-sight :accessor feeb-line-of-sight :reader line-of-sight
43 gmilare 14 :initform 0)
44 gmilare 13 (energy-reserve :accessor feeb-energy-reserve :reader energy-reserve)
45 gmilare 5 (ready-to-fire :accessor feeb-ready-to-fire :reader ready-to-fire
46 gmilare 14 :initform t)
47 gmilare 5 (aborted :accessor feeb-aborted :reader aborted)
48     (last-move :accessor feeb-last-move :reader last-move
49 gmilare 14 :initform :dead)
50 gmilare 5
51 gmilare 11 ;; These are available for the system
52 gmilare 5 (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 gmilare 13 (kill-counter :accessor feeb-kill-counter :initform 0)
57 gmilare 5 (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 gmilare 14 :initform (make-array (list (max *maze-y-size* *maze-x-size*))))
62 gmilare 5 (vision-left :accessor feeb-vision-left
63 gmilare 14 :initform (make-array (list (max *maze-y-size* *maze-x-size*))))
64 gmilare 5 (vision-right :accessor feeb-vision-right
65 gmilare 14 :initform (make-array (list (max *maze-y-size* *maze-x-size*))))))
66 gmilare 5
67 gmilare 11 (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 gmilare 5
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 gmilare 14 (delete thing (aref *maze* x y))))
94 gmilare 5
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 gmilare 14 (object-y-position obj))
101 gmilare 5 (place-object obj x y)
102     (setf (object-x-position obj) x
103 gmilare 14 (object-y-position obj) y))
104 gmilare 5
105     (defun get-forward-pos (object)
106     (let ((new-x (+ (forward-dx (object-direction object))
107 gmilare 14 (object-x-position object)))
108     (new-y (+ (forward-dy (object-direction object))
109     (object-y-position object))))
110 gmilare 5 (values (aref *maze* new-x new-y) new-x new-y)))
111    
112 gmilare 7
113    
114 gmilare 5 ;;; --**-- System Rules --**--
115    
116 gmilare 12
117 gmilare 5
118 gmilare 7 ;;; -*- Being Born and Dying -*-
119 gmilare 5
120 gmilare 7 ;;; Creating
121 gmilare 5
122 gmilare 13 (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 gmilare 9 (:method (object x-pos y-pos)
126 gmilare 13 (place-object object x-pos y-pos)
127     (setf (object-x-position object) x-pos
128 gmilare 14 (object-y-position object) y-pos))
129 gmilare 13
130 gmilare 12 (:method ((feeb feeb) x-pos y-pos)
131 gmilare 13 (setf (feeb-last-move feeb) :dead)
132     (push feeb *feebs*)
133     (call-next-method))
134 gmilare 7
135 gmilare 13 (:method ((fireball fireball) x-pos y-pos)
136     (push fireball *fireballs-flying*)
137 gmilare 17 (setf (object-x-position fireball) x-pos
138     (object-y-position fireball) y-pos))) ; don't place it yet, only after first move
139 gmilare 13
140 gmilare 5 ;;; Reincarnating
141    
142 gmilare 12 (defun reincarnate-feeb (feeb)
143     (let ((pos (nth (random *number-of-entry-points*) *entry-points*)))
144     (create-object feeb (car pos) (cdr pos))))
145 gmilare 1
146 gmilare 5 ;;; Dying
147 gmilare 1
148 gmilare 13 (defgeneric destroy-object (object cause)
149     (:documentation "Called when CAUSE destroys OBJECT.
150     CAUSE could be :starve or a fireball (for feebs)
151 gmilare 17 or :dissipate (for fireballs).")
152 gmilare 13 (:method (object cause)
153     (delete-object object (object-x-position object)
154 gmilare 14 (object-y-position object)))
155 gmilare 13
156     (:method ((fireball fireball) cause)
157     (setf *fireballs-flying*
158 gmilare 14 (delete fireball *fireballs-flying*))
159 gmilare 13 (call-next-method))
160    
161 gmilare 9 (:method ((feeb feeb) cause)
162     (setf *dead-feebs* (nconc *dead-feebs* (list feeb))
163 gmilare 14 *feebs* (delete feeb *feebs*))
164 gmilare 12 (let* ((x (feeb-x-position feeb))
165 gmilare 14 (y (feeb-y-position feeb)))
166 gmilare 9 (push (list 0 x y) *carcasses*)
167     (place-object :carcass x y))
168     (call-next-method)))
169 gmilare 1
170    
171 gmilare 5
172 gmilare 12 ;;; -*- Movement Choice -*-
173 gmilare 1
174 gmilare 12 ;;; Lets the feeb or fireball make a choice
175 gmilare 5
176 gmilare 11 (defgeneric make-move-choice (object)
177     (:documentation "Lets object make its move choice.")
178 gmilare 9 (:method ((feeb feeb))
179     (funcall (feeb-brain feeb)
180 gmilare 14 feeb
181     (feeb-proximity feeb)
182     (feeb-vision feeb)
183     (feeb-vision-left feeb)
184     (feeb-vision-right feeb))))
185 gmilare 5
186    
187 gmilare 12
188     ;;; -*- Moving -*-
189    
190 gmilare 9 (defgeneric make-move (object move)
191 gmilare 11 (:documentation "Applies the move MOVE to OBJECT. The MOVE is
192     returned from MAKE-MOVE-CHOICE for the same object.")
193    
194 gmilare 12 (:method (object move)
195 gmilare 17 (warn "Unknown move ~a for object ~a." move object))
196 gmilare 12
197 gmilare 9 (:method (object (move (eql :turn-right)))
198     (setf (object-direction object)
199 gmilare 14 (right-of (object-direction object))))
200 gmilare 5
201 gmilare 13 (:method (object (move (eql :turn-left)))
202     (setf (object-direction object)
203 gmilare 14 (left-of (object-direction object))))
204 gmilare 13
205 gmilare 9 (:method (object (move (eql :turn-around)))
206     (setf (object-direction object)
207 gmilare 14 (behind (object-direction object))))
208 gmilare 5
209 gmilare 9 (:method (object (move (eql :move-forward)))
210     (multiple-value-bind (stuff new-x new-y)
211 gmilare 14 (get-forward-pos object)
212 gmilare 13 (unless (wallp stuff)
213 gmilare 17 (change-object-pos object new-x new-y)
214     t)))
215 gmilare 1
216 gmilare 12 (:method ((fireball fireball) (move (eql :dissipate)))
217 gmilare 13 (destroy-object fireball :dissipate))
218 gmilare 1
219 gmilare 9 (:method ((feeb feeb) (move (eql :flame)))
220 gmilare 13 (setf (feeb-turns-since-flamed feeb) 0)
221     (create-object
222     (make-instance 'fireball :direction (feeb-facing feeb)
223 gmilare 14 :owner feeb)
224 gmilare 13 (feeb-x-position feeb) (feeb-y-position feeb)))
225 gmilare 5
226 gmilare 9 (:method ((feeb feeb) (move (eql :eat-mushroom)))
227     (let ((x (feeb-x-position feeb))
228 gmilare 14 (y (feeb-y-position feeb)))
229 gmilare 12 (when (find :mushroom (aref *maze* x y))
230 gmilare 14 (delete-object :mushroom x y)
231     t)))
232 gmilare 5
233 gmilare 9 (:method ((feeb feeb) (move (eql :eat-carcass)))
234 gmilare 13 (when (find :carcass (aref *maze* (feeb-x-position feeb)
235 gmilare 14 (feeb-y-position feeb)))
236 gmilare 13 t))
237 gmilare 5
238 gmilare 13 (: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 gmilare 5
246 gmilare 9 ) ; end of make-move generic function
247 gmilare 14
248 gmilare 19 (defmethod make-move :after (object move)
249     (incf (object-lifetime object)))

  ViewVC Help
Powered by ViewVC 1.1.5