[the-feebs-war-cvs] r9 -
gmilare at common-lisp.net
gmilare at common-lisp.net
Sun Dec 30 22:43:46 UTC 2007
Author: gmilare
Date: Sun Dec 30 17:43:46 2007
New Revision: 9
Modified:
feebs.asd
main.lisp
mazes.lisp
system.lisp
Log:
Modified: feebs.asd
==============================================================================
--- feebs.asd (original)
+++ feebs.asd Sun Dec 30 17:43:46 2007
@@ -15,12 +15,12 @@
:components
(;; source
(:cl-source-file "package")
- (:cl-source-file "rules" :depends-on ("package"))
- (:cl-source-file "system" :depends-on ("rules"))
- (:cl-source-file "main" :depends-on ("rules"))
- (:cl-source-file "extra" :depends-on ("rules"))
-
- (:cl-source-file "mazes" :depends-on ("extra"))
+ (:cl-source-file "system" :depends-on ("package"))
+ (:cl-source-file "main" :depends-on ("system"))
+ (:cl-source-file "rules" :depends-on ("main"))
+
+ (:cl-source-file "extra")
+ (:cl-source-file "mazes")
(:cl-source-file "brains" :depends-on ("extra"))
(:file "graphics" :depends-on ("main"))
Modified: main.lisp
==============================================================================
--- main.lisp (original)
+++ main.lisp Sun Dec 30 17:43:46 2007
@@ -44,7 +44,6 @@
during the game.")
-
;;; Tests that behavior functions might use
(declare (inline feeb-image-p fireball-image-p))
@@ -82,12 +81,11 @@
of *maze-x-size* by *maze-y-size*. Each element of the
array is one of these:
:rock - a wall
- :mushroom-place - here is a place where mushrooms can grow up
- :feeb-entry-place - here is a place where a feeb can reincarnate
+ :mushroom-place - place where mushrooms can grow up
+ :feeb-entry-place -place where a feeb can reincarnate
nil - nothing special
-Just remember that variables can change the behavior of this function,
-like *may-get-maze-map-p* which, if nil, makes this function return
-an array of nils"
+Just remember that if *may-get-maze-map-p* is nil,
+this function return an array of nils"
(let ((new-maze (make-array (list *maze-x-size* *maze-y-size*))))
(dotimes (x *maze-x-size*)
(dotimes (y *maze-y-size*)
@@ -152,14 +150,14 @@
(defvar *feebs-to-be* nil)
-(defun define-feeb (name brain &optional graphics)
+(defun define-feeb (name brain &key graphics (class 'feeb))
"Defines a feeb with name NAME, behavior function BRAIN.
If there is another feeb with the same name, overwrites it
with a case sensitive test."
(when (find name *feebs-to-be* :key #'car
:test #'string= (delete-feeb name))
(warn "Feeb ~s already exists, deleting..." name))
- (push (list name brain graphs) *feebs-to-be*))
+ (push (list name brain graphics class) *feebs-to-be*))
(defun delete-feeb (name)
"Deletes the feeb which has name NAME, causing it not to
@@ -179,8 +177,8 @@
(setf *feebs-to-be* nil))
(defun create-feebs ()
- (flet ((create-feeb (x-pos y-pos name brain graphs)
- (let ((feeb (make-instance 'feeb
+ (flet ((create-feeb (x-pos y-pos name brain graphs class)
+ (let ((feeb (make-instance class
:name name
:brain brain
:direction (random 4)
@@ -206,41 +204,43 @@
(let ((mushrooms 0))
-(defun number-of-mushrooms (n)
- (setf *mushrooms-to-grow* n))
+ (defun number-of-mushrooms (n)
+ (setf *mushrooms-to-grow* n))
-(defun play-one-turn ()
- (setf mushrooms 0) ; restart the count
- ;; This is defined by rules:
- (start-turn)
- ;; Maybe grow up mushrooms:
- (let ((m-sites (sort *mushroom-sites*
- #'(lambda (x y)
- (declare (ignore x y))
- (zerop (random 2))))))
- (dotimes (i mushrooms)
- (let ((site (pop m-sites)))
- (create-mushroom (car site) (cdr site)))))
- ;; Maybe rot some carcasses
- ;; FIXME: put this in rules.lisp with better code
- (loop for carc in *carcasses*
- with ncarcasses do
- (if (rot-carcass-p (first carc))
- (delete-object :carcass (second carc) (third carc)))
- (progn
- (push carc ncarcasses)
- (incf (first carc)))))
- ;; Move some fireballs:
+ (defun play-one-turn ()
+ (setf mushrooms 0) ; restart the count
+ ;; This is defined by rules:
+ (start-turn)
+ ;; Maybe grow up mushrooms:
+ (let ((m-sites (sort *mushroom-sites*
+ #'(lambda (x y)
+ (declare (ignore x y))
+ (zerop (random 2))))))
+ (dotimes (i mushrooms)
+ (let ((site (pop m-sites)))
+ (create-mushroom (car site) (cdr site)))))
+ ;; Maybe rot some carcasses
+ ;; FIXME: Ugly code code, and
+ (loop for carc in *carcasses*
+ with ncarcasses do
+ (if (rot-carcass-p (first carc))
+ (progn
+ (delete-object :carcass (second carc) (third carc))
+ (reincarnate-feeb (pop *dead-feebs*)))
+ (progn
+ (push carc ncarcasses)
+ (incf (first carc)))))
+ ;; Move some fireballs:
(dolist (fireball *fireballs-flying*)
(move-object fireball (make-move-choice fireball)))
- (progn
- ;; Starve the feeb:
- (when (<= (decf (feeb-energy-reserve feeb)) 0)
- (destroy-object feeb :starve))
- ;; Compute vision for the feeb:
- (compute-vision feeb)
- ;; Collect the feeb's move
- (setf (feeb-peeking feeb) nil)
- (move-object feeb (setf (feeb-last-move feeb)
- (make-move-choice feeb)))))))
+ (progn
+ ;; Starve the feeb:
+ (when (<= (decf (feeb-energy-reserve feeb)) 0)
+ (destroy-object feeb :starve))
+ ;; Compute vision for the feeb:
+ (compute-vision feeb)
+ ;; Collect the feeb's move
+ (setf (feeb-peeking feeb) nil)
+ (move-object feeb (setf (feeb-last-move feeb)
+ (make-move-choice feeb)))))))
)
\ No newline at end of file
Modified: mazes.lisp
==============================================================================
--- mazes.lisp (original)
+++ mazes.lisp Sun Dec 30 17:43:46 2007
@@ -18,6 +18,7 @@
along with The Feebs War. If not, see <http://www.gnu.org/licenses/>.
|#
+;;; The mazes were
;;; Created by Jim Healy, July 1987.
;;;
;;; **************************************************
@@ -219,44 +220,114 @@
"X e * X"
"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"))
-;;; Use this template to create new mazes.
-
-#| (defparameter *maze-template*
- '("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
- "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX")) |#
-
-;;; Or this function:
+;;; Use this function to create new mazes
+;;; of any size.
(defun make-template (x-size y-size)
- (loop repeat y-size collect
- (make-string x-size :initial-element #\#)))
+ "Prints map template of the requested size.
+Use this to create new mazes."
+ (dotimes (i y-size)
+ (format t "~@?~a~@?~%"
+ (if (zerop i)
+ "~4t'(\""
+ "~6t\"")
+ (make-string x-size :initial-element #\X)
+ (if (= i y-size)
+ "\")"
+ "\""))))
+
+(defun density (maze)
+ (loop for line in maze summing
+ (float (/ (loop for elt across line counting
+ (char/= #\X elt))
+ (length line) (length maze)))))
+
+(defun bound-random (min avg max)
+ (let ((sort (random 2.0)))
+ (round
+ (if (< sort 1.0)
+ (+ min (* sort (- avg min)))
+ (+ avg (* (1- sort) (- max avg)))))))
+
+(defmacro ensure-bound (elt min max)
+ `(setf ,elt (max ,min (min ,max ,elt))))
+
+(defun horiz-corridor (map y x1 x2)
+ (do ((x x1 (if (< x1 x2) (1+ x) (1- x))))
+ ((= x x2))
+ ;; we need to guarantee that everything in map is
+ ;; corridors, that is, can't have something like
+ ;; XXXXXXXX
+ ;; XXX X
+ ;; X XXX
+ ;; XXXXXXXX
+ ;; that big blank square isn't good due
+ ;; to the limited vision of the feebs
+ (and (not (aref map x (1- y))) ; blank square up
+ (or (and (not (aref map (1+ x) y)) ; blank square to the right
+ (not (aref map (1+ x) (1- y)))) ; blank square up-right
+ (and (not (aref map (1- x) (1- y))) ; blank square up-left
+ (not (aref map (1- x) y)))) ; blank square to the left
+ (return)) ; can't make a blank square here, stop
+ (and (not (aref map x (1+ y))) ; blank square down
+ (if (or (and (not (aref map (1+ x) y)) ; blank square to the right
+ (not (aref map (1+ x) (1+ y)))) ; blank square down-right
+ (and (not (aref map (1- x) (1+ y))) ; blank square down-left
+ (not (aref map (1- x) y)))) ; blank square to the left
+ (return))) ; can't make a blank square here, stop
+ (setf (aref map x y) nil))
+ map)
+
+(defun vert-corridor (map x y1 y2)
+ (do ((y y1 (if (< y1 y2) (1+ y) (1- y))))
+ ((= y y2))
+ (and (not (aref map (1- x) y))
+ (or (and (not (aref map x (1+ y)))
+ (not (aref map (1- x) (1+ y))))
+ (and (not (aref map (1- x) (1- y)))
+ (not (aref map x (1- y)))))
+ (return))
+ (and (not (aref map (1+ x) y))
+ (if (or (and (not (aref map x (1+ y)))
+ (not (aref map (1+ x) (1+ y))))
+ (and (not (aref map (1+ x) (1- y)))
+ (not (aref map x (1- y)))))
+ (return)))
+ (setf (aref map x y) nil))
+ map)
+
+(defun generate-maze (x-size y-size
+ &key (density 0.4)
+ (corridor-x-min 1)
+ (corridor-x-max (- x-size 2))
+ (corridor-x-avg (floor x-size 2))
+ (corridor-y-min 1)
+ (corridor-y-max (- y-size 2))
+ (corridor-y-avg (floor y-size 2)))
+ "Generates a maze of size X-SIZE x Y-SIZE (at least 10x10)
+with no entry points and no mushroom sites.
+DENSITY decides aproximatelly the ratio
+ (blank squares) / (total squares)
+recomended to be between 0.25 and 0.45.
+The horizontal corridors will be between
+CORRIDOR-X-MIN and CORRIDOR-X-MAX with average CORRIDOR-X-AVG;
+similarly for vertical corridors."
+ (if (or (< x 10) (< y 10))
+ (error "Too small - should be at least 10x10."))
+ ;; Certifying the values to be acceptable
+ (ensure-bound density 0.1 0.5)
+ (ensure-bound corridor-x-min 1 (- x-size 2))
+ (ensure-bound corridor-x-avg 2 (- x-size 2))
+ (ensure-bound corridor-x-max 3 (- x-size 2))
+ (ensure-bound corridor-y-min 1 (- y-size 2))
+ (ensure-bound corridor-y-avg 2 (- y-size 2))
+ (ensure-bound corridor-y-max 3 (- y-size 2))
+ ;; Beginning with an array of walls
+ (let ((map (make-array (list x-size y-size)
+ :initial-element t
+ :element-type 'boolean)))
+ (do* ((y 1 (1+ (random (- y-size 1)))) ; position of horizontal corridor
+ (x 1 (1+ (random (- x-size 1)))) ; position of vertical corridor
+ (x1
+ (setf map (horiz-corridor
+ map 1 (1+ (random (- x-size 1)))
\ No newline at end of file
Modified: system.lisp
==============================================================================
--- system.lisp (original)
+++ system.lisp Sun Dec 30 17:43:46 2007
@@ -161,11 +161,8 @@
;;; -*- General Rules -*-
-(defmethod start-round ()
- t)
-
-(defmethod start-turn ()
- t)
+(defgeneric start-turn (&key &allow-other-keys)
+ (:method () t))
@@ -173,32 +170,35 @@
;;; Creating
-(defmethod create-object (object x-pos y-pos)
- (change-object-pos object x-pos y-pos))
+(defgeneric create-object (object x-pos y-pos &key &allow-other-keys)
+ (:method (object x-pos y-pos)
+ (change-object-pos object x-pos y-pos)))
;;; Reincarnating
-(defmethod reincarnate-feeb ((feeb feeb))
- (let ((pos (nth (random *number-of-entry-points*) *entry-points*)))
- (change-object-pos feeb (car pos) (cdr pos)))
- (setf (feeb-facing feeb) (random 4)
- (feeb-dead-p feeb) nil
- (feeb-ready-to-fire feeb) t
- (feeb-energy-reserve feeb) *starting-energy*
- (feeb-last-move feeb) :dead))
+(defgeneric reincarnate-feeb (feeb &key &allow-other-keys)
+ (:method ((feeb feeb))
+ (let ((pos (nth (random *number-of-entry-points*) *entry-points*)))
+ (change-object-pos feeb (car pos) (cdr pos)))
+ (setf (feeb-facing feeb) (random 4)
+ (feeb-dead-p feeb) nil
+ (feeb-ready-to-fire feeb) t
+ (feeb-energy-reserve feeb) *starting-energy*
+ (feeb-last-move feeb) :dead)))
;;; Dying
-(defmethod destroy-object ((feeb feeb) cause)
- (setf *dead-feebs* (nconc *dead-feebs* (list feeb))
- (feeb-dead-p feeb) t)
- (let* ((status (feeb-status feeb))
- (x (feeb-x-position feeb))
- (y (feeb-y-position feeb)))
- (push (list 0 x y) *carcasses*)
- (delete-object (feeb-image feeb) x y)
- (place-object :carcass x y))
- (call-next-method))
+(defgeneric destroy-object (object cause &key &allow-other-keys)
+ (:method ((feeb feeb) cause)
+ (setf *dead-feebs* (nconc *dead-feebs* (list feeb))
+ (feeb-dead-p feeb) t)
+ (let* ((status (feeb-status feeb))
+ (x (feeb-x-position feeb))
+ (y (feeb-y-position feeb)))
+ (push (list 0 x y) *carcasses*)
+ (delete-object (feeb-image feeb) x y)
+ (place-object :carcass x y))
+ (call-next-method)))
@@ -274,84 +274,87 @@
;;; Lets the feeb make a choice
-(defmethod make-move-choice ((feeb feeb))
- (funcall (feeb-brain feeb)
- (feeb-status feeb)
- (feeb-proximity feeb)
- (feeb-vision feeb)
- (feeb-vision-left feeb)
- (feeb-vision-right feeb)))
+(defgeneric make-move-choice (object &key &allow-other-keys)
+ (:method ((feeb feeb))
+ (funcall (feeb-brain feeb)
+ (feeb-status feeb)
+ (feeb-proximity feeb)
+ (feeb-vision feeb)
+ (feeb-vision-left feeb)
+ (feeb-vision-right feeb))))
;;; Moving
-(defmethod make-move (object (move (eql :turn-right)))
- (setf (object-direction object)
- (right-of (object-direction object)))
- t)
-
-(defmethod make-move (object (move (eql :turn-around)))
- (setf (object-direction object)
- (behind (object-direction object)))
- t)
-
-(defmethod make-move (object (move (eql :move-forward)))
- (multiple-value-bind (stuff new-x new-y)
- (get-forward-pos object)
- (when (wallp stuff)
- (return-from make-move nil))
- (change-object-pos object new-x new-y))
- t)
+(defgeneric make-move (object move)
+ (:method (object (move (eql :turn-right)))
+ (setf (object-direction object)
+ (right-of (object-direction object)))
+ t)
+
+ (:method (object (move (eql :turn-around)))
+ (setf (object-direction object)
+ (behind (object-direction object)))
+ t)
+
+ (:method (object (move (eql :move-forward)))
+ (multiple-value-bind (stuff new-x new-y)
+ (get-forward-pos object)
+ (when (wallp stuff)
+ (return-from make-move nil))
+ (change-object-pos object new-x new-y))
+ t)
;;; Fireball
-(defmethod make-move ((fireball fireball) (move (eql :move-forward)))
- (multiple-value-bind (stuff new-x new-y)
- (get-forward-pos fireball)
- (dolist (thing stuff)
- (if (feeb-image-p thing)
- (destroy-object feeb fireball)))))
+ (:method ((fireball fireball) (move (eql :move-forward)))
+ (multiple-value-bind (stuff new-x new-y)
+ (get-forward-pos fireball)
+ (dolist (thing stuff)
+ (if (feeb-image-p thing)
+ (destroy-object feeb fireball)))))
;;; Feeb moves
-(defmethod make-move ((feeb feeb) (move (eql :move-forward)))
- (let ((thing (find-if #'fireball-image-p stuff)))
- (when thing (destroy-object feeb thing)
- (return-from make-move t)))
- (call-next-method))
-
-(defmethod make-move ((feeb feeb) (move (eql :flame)))
- (let ((x (feeb-x-position feeb))
- (y (feeb-y-position feeb))
- (fireball
- (make-fireball-image (feeb-facing feeb)
- feeb x y (forward-dx facing)
- (forward-dy facing))))
- (push fireball *fireballs-flying*)
- t))
-
-(defmethod make-move ((feeb feeb) (move (eql :eat-mushroom)))
- (let ((x (feeb-x-position feeb))
- (y (feeb-y-position feeb)))
- (when (member :mushroom (aref *maze* x y))
- (delete-object :mushroom x y)
- t)))
-
-(defmethod make-move ((feeb feeb) (move (eql :eat-carcass)))
- (let ((x (feeb-x-position feeb))
- (y (feeb-y-position feeb)))
- (when (member :carcass (aref *maze* x y))
- t)))
-
-(defmethod make-move ((feeb feeb) (move (eql :peek-left)))
- (multiple-value-bind (x y stuff)
- (get-forward-pos feeb)
- (unless (wallp stuff)
- (setf (peeking feeb) move)))
- t)
-
-(defmethod make-move ((feeb feeb) (move (eql :peek-right)))
- (multiple-value-bind (x y stuff)
- (get-forward-pos feeb)
- (unless (wallp stuff)
- (setf (peeking feeb) move)))
- t)
+ (:method ((feeb feeb) (move (eql :move-forward)))
+ (let ((thing (find-if #'fireball-image-p stuff)))
+ (when thing (destroy-object feeb thing)
+ (return-from make-move t)))
+ (call-next-method))
+
+ (:method ((feeb feeb) (move (eql :flame)))
+ (let ((x (feeb-x-position feeb))
+ (y (feeb-y-position feeb))
+ (fireball
+ (make-fireball-image (feeb-facing feeb)
+ feeb x y (forward-dx facing)
+ (forward-dy facing))))
+ (push fireball *fireballs-flying*)
+ t))
+
+ (:method ((feeb feeb) (move (eql :eat-mushroom)))
+ (let ((x (feeb-x-position feeb))
+ (y (feeb-y-position feeb)))
+ (when (member :mushroom (aref *maze* x y))
+ (delete-object :mushroom x y)
+ t)))
+
+ (:method ((feeb feeb) (move (eql :eat-carcass)))
+ (let ((x (feeb-x-position feeb))
+ (y (feeb-y-position feeb)))
+ (when (member :carcass (aref *maze* x y))
+ t)))
+
+ (:method ((feeb feeb) (move (eql :peek-left)))
+ (multiple-value-bind (x y stuff)
+ (get-forward-pos feeb)
+ (unless (wallp stuff)
+ (setf (peeking feeb) move)))
+ t)
+
+ (:method make-move ((feeb feeb) (move (eql :peek-right)))
+ (multiple-value-bind (x y stuff)
+ (get-forward-pos feeb)
+ (unless (wallp stuff)
+ (setf (peeking feeb) move)))
+ t)
+ ) ; end of make-move generic function
More information about the The-feebs-war-cvs
mailing list