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

Contents of /main.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 14 - (show annotations)
Sat Feb 16 19:59:50 2008 UTC (6 years, 2 months ago) by gmilare
File size: 7992 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
26 ;;; Parameters
27
28 (let ((parameters (make-hash-table :test 'eq)))
29
30 (defun def-feeb-parm (name value &optional doc)
31 (aif (gethash name parameters)
32 (progn
33 (warn "Change parameter ~a to ~a: ~
34 parameter already existed with value ~a." name value (car it))
35 (setf (gethash name parameters) (cons value (or doc (cdr it)))))
36 (setf (gethash name parameters) (cons value doc)))
37 (export name)
38 name)
39
40 (defun get-feeb-parm (name)
41 (car (gethash name parameters)))
42
43 (defun change-feeb-parm (name value)
44 (unless *playing-feeb*
45 (setf (car (gethash name parameters)) value)))
46
47 (defmethod documentation (name (type (eql 'feeb-parameter)))
48 (cdr (gethash name parameters)))
49
50 (defun list-parameter-settings ()
51 (let (params)
52 (maphash #'(lambda (key value)
53 (push (list key (car value) (cdr value)) params))
54 parameters)
55 params)))
56
57
58 ;;; Characteristics of the maze:
59
60 (def-feeb-parm 'maze-x-size *maze-x-size*
61 "Horizontal size of the maze.")
62
63 (def-feeb-parm 'maze-y-size *maze-y-size*
64 "Vertical size of the maze.")
65
66 (def-feeb-parm 'may-get-maze-map-p t
67 "Tells if the function (get-maze-map) returns the map layout
68 instead of nil during the game.")
69
70
71
72 ;;; The maze
73
74 ;;; Changing the maze
75 (defun change-layout (layout)
76 "Changes the layout of the map. See variables
77 *maze-0* throw *maze-5* for examples (or options) of layouts."
78 (when *feebs-to-be*
79 (warn "There are some feebs that have already been defined.
80 They could have used (get-maze-map). Those are they:
81 ~a." (loop for feeb in *feebs-to-be* collect (first feeb))))
82 (let ((x (length layout))
83 (y (length (car layout))))
84 (loop for string in layout do
85 (if (/= (length string) y)
86 (error "Not all the strings in ~a have the same size." layout)))
87 (setf *layout* layout
88 *maze-y-size* (change-feeb-parm 'maze-y-size y)
89 *maze-x-size*(change-feeb-parm 'maze-x-size x)))
90 (init-maze))
91
92 (defun get-maze-map ()
93 "Gets the current maze in the map. It returns an array
94 of *maze-x-size* by *maze-y-size*. Each element of the
95 array is one of these:
96 :rock - a wall
97 :mushroom-place - place where mushrooms can grow up
98 :feeb-entry-place -place where a feeb can reincarnate
99 nil - nothing special
100 Just remember that if *may-get-maze-map-p* is nil,
101 this function return nil."
102 (and (get-feeb-parm 'may-get-maze-map-p)
103 (let ((new-maze (make-array (list *maze-x-size* *maze-y-size*))))
104 (dotimes (x *maze-x-size*)
105 (dotimes (y *maze-y-size*)
106 (setf (aref new-maze x y) (aref *fake-maze* x y))))
107 new-maze)))
108
109 (defun init-maze ()
110 (setf *maze* (make-array (list *maze-x-size* *maze-y-size*))
111 *fake-maze* (make-array (list *maze-x-size* *maze-y-size*))
112 *entry-points* nil
113 *mushroom-sites* nil
114 *number-of-mushroom-sites* 0
115 *number-of-entry-points* 0)
116 (do ((rows *layout* (cdr rows))
117 (y (1- *maze-y-size*) (1- y))) ; inverting the y axis
118 ((null rows))
119 (let ((str (car rows)))
120 (dotimes (x (length str))
121 (setf (aref *maze* x y) nil
122 (aref *fake-maze* x y) nil)
123 (case (schar str x)
124 (#\X
125 (setf (aref *fake-maze* x y) :rock
126 (aref *maze* x y) (list :rock)))
127 (#\*
128 (setf (aref *fake-maze* x y) :mushroom-place)
129 (incf *number-of-mushroom-sites*)
130 (push (cons x y) *mushroom-sites*))
131 (#\e
132 (setf (aref *fake-maze* x y)
133 :feeb-entry-place)
134 (incf *number-of-entry-points*)
135 (push (cons x y) *entry-points*))
136 (#\space nil)
137 (t
138 (error "Unknown spec in maze: ~C." (schar str x))))))))
139
140 (eval-when (:load-toplevel)
141 (init-maze))
142
143 (defun initialize-feebs ()
144 (setf *feebs* ()
145 *dead-feebs* ()
146 *fireballs-flying* ()
147 *mushroom-sites* ()
148 *carcasses* ()
149 *playing-feeb* nil)
150 (init-maze)
151 (create-feebs)) ; The feebs are defined here
152
153
154
155 ;;; Define-Feeb builds a list of feebs to create. Create-Feebs actually
156 ;;; builds the feebs on this list.
157
158 (defvar *feebs-to-be* nil)
159
160 (defun define-feeb (name brain &key graphics (class 'feeb))
161 "Defines a feeb with name NAME, behavior function BRAIN.
162 If there is another feeb with the same name, overwrites it
163 with a case sensitive test."
164 (when (find name *feebs-to-be* :key #'car
165 :test #'string=)
166 (delete-feeb name)
167 (warn "Feeb ~s already exists, deleting..." name))
168 (push (list name brain graphics class) *feebs-to-be*)
169 name)
170
171 (defun delete-feeb (name)
172 "Deletes the feeb which has name NAME, causing it not to
173 be created when the game begins. Does not work for feebs
174 already in the game."
175 (setf *feebs-to-be*
176 (remove name *feebs-to-be* :key #'car :test #'string=))
177 nil)
178
179 (defun list-of-feebs ()
180 "Returns a copy of the list of feebs that will be created
181 when the game begins."
182 (loop for (name . rest) in *feebs-to-be*
183 collect name))
184
185 (defun delete-all-feebs ()
186 "Deletes all feebs that are to be defined when the game begins."
187 (setf *feebs-to-be* nil))
188
189 (defun create-feebs ()
190 (flet ((create-feeb (x-pos y-pos name brain graphs class)
191 (let ((feeb (make-instance class
192 :name name
193 :brain brain
194 :graphics graphs
195 :x-position x-pos
196 :y-position y-pos)))
197 (if (and x-pos y-pos)
198 (create-object feeb x-pos y-pos)
199 (push feeb *dead-feebs*)))))
200 (let ((entries (sort (copy-list *entry-points*) ; random positions
201 #'(lambda (x y)
202 (declare (ignore x y))
203 (zerop (random 2))))))
204 (setf *feebs* nil)
205 (dolist (feeb-spec *feebs-to-be*)
206 (let ((pos (pop entries)))
207 (apply #'create-feeb (car pos) (cdr pos) feeb-spec))))))
208
209
210
211 ;;; The Game
212
213 (let ((mushrooms 1))
214
215 (defun number-of-mushrooms (n)
216 (setf mushrooms n))
217
218 (defun play-one-turn ()
219 ;; This is defined by rules:
220 (start-turn) ; possible call to number-of-mushrooms
221 ;; Maybe grow up mushrooms:
222 (let ((m-sites (sort (copy-list *mushroom-sites*)
223 #'(lambda (x y)
224 (declare (ignore x y))
225 (zerop (random 2))))))
226 (dotimes (i mushrooms)
227 (let ((site (pop m-sites)))
228 (unless (find-if #'fireball-p
229 (aref *maze* (car site) (cdr site)))
230 (create-mushroom (car site) (cdr site))))))
231 ;; Maybe rot some carcasses
232 (dolist (carc (prog1 *carcasses*
233 (setf *carcasses* nil)))
234 (if (rot-carcass-p (first carc))
235 (progn
236 (delete-object :carcass (second carc) (third carc))
237 (reincarnate-feeb (pop *dead-feebs*)))
238 (progn
239 (incf (first carc))
240 (push carc *carcasses*))))
241 ;; Move some fireballs:
242 (dolist (fireball *fireballs-flying*)
243 (make-move fireball (make-move-choice fireball)))
244 (dolist (feeb *feebs*)
245 ;; Starve the feeb:
246 (when (<= (decf (feeb-energy-reserve feeb)) 0)
247 (destroy-object feeb :starve)))
248 (dolist (*playing-feeb* *feebs*)
249 ;; Compute vision for the feeb:
250 (compute-vision *playing-feeb*)
251 (incf (feeb-turns-since-flamed *playing-feeb*))
252 ;; Lets the feeb make a choice
253 (setf (feeb-last-move *playing-feeb*)
254 (make-move-choice *playing-feeb*)
255 (feeb-peeking *playing-feeb*) nil))
256 ;; binds the variable to the current playing feeb
257 (dolist (feeb *feebs*)
258 ;; Collect the feeb's move
259 (make-move feeb (feeb-last-move feeb))))
260
261 ) ; end of let ((mushrooms 1))

  ViewVC Help
Powered by ViewVC 1.1.5