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