ViewVC logotype

Diff of /main.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1 by gmilare, Wed Dec 19 20:36:51 2007 UTC revision 5 by gmilare, Thu Dec 20 20:16:44 2007 UTC
# Line 23  Line 23 
24  ;;; Some functions  ;;; Some functions
26  (defmacro def-feeb-parm (name value doc)  (defmacro define-parameter (name value doc)
27    `(progn    `(progn
28      (defvar ,name ,value ,doc)      (defvar ,name ,value ,doc)
29        (export ,name)
30      (pushnew ',name *feeb-parameters*)))      (pushnew ',name *feeb-parameters*)))
32  (defun list-parameter-settings ()  (defun list-parameter-settings ()
# Line 34  Line 35 
35        (push (cons parm (symbol-value parm)) settings))        (push (cons parm (symbol-value parm)) settings))
36      settings))      settings))
 (defun chance (ratio)  
   (< (random (denominator ratio)) (numerator ratio)))  
 ;;; General game parameters:  
 (def-feeb-parm *game-length* 320  
   "Number of cycles in the simulation.")  
 (def-feeb-parm *number-of-auto-feebs* 0  
   "Number of dumb system-provided feebs.")  
 (def-feeb-parm *slow-feeb-noop-switch* nil  
   "If non-null, each feeb has a chance of having its orders aborted in  
    proportion to the time it takes to produce them.  
    See *slow-feeb-noop-factor*.")  
 (def-feeb-parm *slow-feeb-noop-factor* 1/4  
   "If *slow-feeb-noop-switch* is non-null, a feeb's orders will be aborted  
    with probability equal to the product of this factor times the time  
    taken by this feeb divided by *reference-time*, if non-nil, or  
    the total time taken by all feebs this turn otherwise.")  
 (def-feeb-parm *reference-time* nil  
   "Time taken by reference if non-nil. See *slow-feeb-noop-factor*.")  
 (def-feeb-parm *sense-location-p* t  
   "If non-null, x-position and y-position will return nil when  
    some a behavior function tries to invoke it.")  
 ;;(def-feeb-parm *sense-facing-p* t  
 ;;  "If non-null, facing will return nil when one tries to  
 ;;   invoke it.")  
 ;;; Scoring:  
 (def-feeb-parm *points-for-killing* 5  
   "Added to one's score for killing an opponent.")  
 (def-feeb-parm *points-for-dying* -3  
   "Added to one's score for being killed or starving.")  
 (def-feeb-parm *points-for-slow-down* -1  
   "Points earned when a feeb's move is aborted due to slowness.")  
 ;;; Cheating  
 (def-feeb-parm *exclude-cheater-p* nil  
   "Tells if a feeb is excluded from the game when a cheating is done.")  
 (def-feeb-parm *warn-when-cheating-p* t  
   "Tells if a continuable error must be signaled when a cheating is done.")  
39  ;;; Characteristics of the maze:  ;;; Characteristics of the maze:
41  (def-feeb-parm *may-get-maze-map-p* t  (define-parameter *may-get-maze-map-p* t
42    "Tells if the function (get-maze-map) returns the map layout of nil    "Tells if the function (get-maze-map) returns the map layout of nil
43     during the game.")     during the game.")
 (def-feeb-parm *maze-x-size* 32  
   "Number of columns in the maze.")  
 (def-feeb-parm *maze-y-size* 32  
   "Number of rows in the maze.")  
 (def-feeb-parm *number-of-mushrooms* 8  
   "Average number of mushrooms in the maze at any given time.")  
46  ;;; Energies:  ;;; Energies:
 (def-feeb-parm *flame-energy* 10  
   "Energy used when a feeb flames.")  
49  (def-feeb-parm *mushroom-energy* 50  ;;; Carcasses:
   "Energy gained when a mushroom is eaten.")  
 (def-feeb-parm *carcass-energy* 30  
   "Energy gained by feeding on a carcass.")  
 (def-feeb-parm *maximum-energy* 100  
   "The most energy a feeb can accumulate.")  
 (def-feeb-parm *starting-energy* 50  
   "Smallest amount of energy a feeb will start with.")  
52  ;;; Carcasses:  ;;; Fireballs:
 (def-feeb-parm *carcass-guaranteed-lifetime* 5  
   "Minimum number of turns a carcass will hang around.")  
 (def-feeb-parm *carcass-rot-probability* 1/3  
   "Chance of a carcass rotting away each turn after its guaranteed lifetime.")  
56    ;;; Tests that behavior functions might use
58  ;;; Fireballs:  (declare (inline feeb-image-p fireball-image-p))
60  (def-feeb-parm *fireball-dissipation-probability* 1/5  (defun feeb-image-p (thing)
61    "Chance that a fireball will dissipate each turn after it is fired.")    (typep thing 'feeb))
63  (def-feeb-parm *fireball-reflection-probability* 2/3  (defun fireball-image-p (thing)
64    "Chance that a fireball will reflect when it hits a wall.")    (typep thing 'fireball))
 (def-feeb-parm *flame-recovery-probability* 1/3  
   "Chance a feeb will regain its ability to flame each turn after flaming once.")  
68  ;;; Structures:  ;;; The maze
 ;;; The Feeb structure contains all of the info relevant to a particular feeb.  
 ;;; The info available to the brain function is in the Status sub-structure.  
 (defstruct (feeb  
              (:print-function print-feeb)  
              (:constructor make-feeb (id brain)))  
   (dead-p nil)  
   (turns-since-flamed 0)  
   (vision (make-array (max *maze-x-size* *maze-y-size*)))  
   (vision-left (make-array (max *maze-x-size* *maze-y-size*)))  
   (vision-right (make-array (max *maze-x-size* *maze-y-size*))))  
 (defstruct (status  
             (:conc-name nil)  
             (:constructor make-status (name graphics)))  
   (name "" :read-only t)  
   (energy-reserve *starting-energy*)  
   (score 0)  
   (kills 0)  
   (ready-to-fire t)  
   (aborted nil)  
   (last-move :dead))  
 (defun print-feeb (structure stream depth)  
   (declare (ignore depth))  
   (format stream "#<Feeb ~S>"  
           (name (feeb-status structure))))  
 (defstruct (proximity  
             (:conc-name nil))  
 ;;; These image structures are used to represent feebs and fireballs in  
 ;;; the sensory displays of other feebs.  
 (defstruct (feeb-image  
             (:print-function print-feeb-image)  
             (:constructor make-feeb-image (name feeb)))  
   (name "" :read-only t)  
   (feeb nil :read-only t)  
 (defun print-feeb-image (structure stream depth)  
   (declare (ignore depth))  
   (format stream "#<Feeb-Image of ~S facing ~S>"  
           (feeb-image-name structure)  
           (feeb-image-facing structure)))  
 (defstruct (fireball-image  
             (:print-function print-fireball-image)  
             (:constructor make-fireball-image (direction owner x y dx dy)))  
   (new t))  
 (defun print-fireball-image (structure stream depth)  
   (declare (ignore depth))  
   (format stream "#<Fireball moving ~S>"  
           (fireball-image-direction structure)))  
 (defstruct (pos (:constructor make-pos (x y)))  
70  ;;; Changing the maze  ;;; Changing the maze
71  (defun change-layout (layout)  (defun change-layout (layout)
72      "Changes the layout of the map. See variables
73    *maze-0* throw *maze-5* for examples (or options) of layouts"
74    (when *feebs-to-be*    (when *feebs-to-be*
75      (warn "There are some feebs that have already been defined.      (warn "There are some feebs that have already been defined.
76  They could have used (get-maze-map). Those are they:  They could have used (get-maze-map). Those are they:
# Line 246  They could have used (get-maze-map). Tho Line 82  They could have used (get-maze-map). Tho
82                (error "Not all the strings in ~a have the same size." layout)))                (error "Not all the strings in ~a have the same size." layout)))
83      (setf *layout* layout      (setf *layout* layout
84            *maze-y-size* y            *maze-y-size* y
85            *maze-x-size* x)))            *maze-x-size* x))
86      (init-maze))
88  (defun get-maze-map ()  (defun get-maze-map ()
89    (when *may-get-maze-map-p*    "Gets the current maze in the map. It returns an array
90      (unless (and *maze* *fake-maze*)  of *maze-x-size* by *maze-y-size*. Each element of the
91        (init-maze))  array is one of these:
92      (let ((new-maze (make-array (list *maze-x-size* *maze-y-size*))))   :rock - a wall
93        (dotimes (x *maze-x-size*)   :mushroom-place - here is a place where mushrooms can grow up
94          (dotimes (y *maze-y-size*)   :feeb-entry-place - here is a place where a feeb can reincarnate
95            (setf (aref new-maze x y) (aref *fake-maze* x y))))   nil - nothing special
96        new-maze)))  Just remember that variables can change the behavior of this function,
97    like *may-get-maze-map-p* which, if nil, makes this function return
98    an array of nils"
99      (let ((new-maze (make-array (list *maze-x-size* *maze-y-size*))))
100        (dotimes (x *maze-x-size*)
101          (dotimes (y *maze-y-size*)
102            (setf (aref new-maze x y) (aref *fake-maze* x y))))
103        new-maze)))
105  (defun init-maze ()  (defun init-maze ()
106    (setf *maze* (make-array (list *maze-x-size* *maze-y-size*))    (setf *maze* (make-array (list *maze-x-size* *maze-y-size*))
107          *fake-maze* (make-array (list *maze-x-size* *maze-y-size*))          *fake-maze* (make-array (list *maze-x-size* *maze-y-size*))
108          *entry-points* nil)          *entry-points* nil
109            *mushroom-sites* nil
110            *number-of-mushroom-sites* 0
111            *number-of-entry-points* 0)
112    (do ((rows *layout* (cdr rows))    (do ((rows *layout* (cdr rows))
113         (i (1- *maze-y-size*) (1- i)))         (i (1- *maze-y-size*) (1- i)))
114        ((null rows))        ((null rows))
# Line 271  They could have used (get-maze-map). Tho Line 118  They could have used (get-maze-map). Tho
118                (aref *fake-maze* j i) nil)                (aref *fake-maze* j i) nil)
119          (case (schar str j)          (case (schar str j)
120            (#\X            (#\X
121             (setf (aref *maze* j i) :rock             (setf (aref *fake-maze* j i) (and *may-get-maze-map-p* :rock)
122                   (aref *fake-maze* j i) :rock))                   (aref *maze* j i) :rock))
123            (#\*            (#\*
124             (setf (aref *fake-maze* j i) :mushroom-place)             (setf (aref *fake-maze* j i) (and *may-get-maze-map-p*
125                                                 :mushroom-place))
126               (incf *number-of-mushroom-sites*)
127             (push (make-pos j i) *mushroom-sites*))             (push (make-pos j i) *mushroom-sites*))
128            (#\e            (#\e
129             (setf (aref *fake-maze* j i) :feeb-entry-place)             (setf (aref *fake-maze* j i) (and *may-get-maze-map-p*
130                                                 :feeb-entry-place))
131               (incf *number-of-entry-points*)
132             (push (make-pos j i) *entry-points*))             (push (make-pos j i) *entry-points*))
133            (#\space nil)            (#\space nil)
134            (t            (t
# Line 294  They could have used (get-maze-map). Tho Line 145  They could have used (get-maze-map). Tho
145          *static-parameters*          *static-parameters*
146           (loop for (symbol . value) in (list-parameter-settings)           (loop for (symbol . value) in (list-parameter-settings)
147                 collect value))                 collect value))
   (setf *number-of-mushroom-sites* (length *mushroom-sites*)  
         *number-of-entry-points*   (length *entry-points*))  
148    (create-feebs)) ; The feebs are defined here    (create-feebs)) ; The feebs are defined here
 (defun create-mushrooms ()  
   (dotimes (i (- *number-of-mushrooms* (length *mushrooms-alive*) (random 3)))  
     (do ((site (nth (random *number-of-mushroom-sites*) *mushroom-sites*)  
                (nth (random *number-of-mushroom-sites*) *mushroom-sites*)))  
         ((null (aref *maze* (pos-x site) (pos-y site)))  
          (setf (aref *maze* (pos-x site) (pos-y site)) :mushroom)))))  
 ;;; Setting up the feebs.  
152  (defvar *feebs* nil  ;;; Setting up the feebs.
   "A list of all the feebs in the current game.")  
154  (defvar *next-feeb-id* 0  (defvar *feebs* nil)
   "A counter used to assign a unique numerical code to each feeb.")  
156  ;;; Define-Feeb builds a list of feebs to create.  Create-Feebs actually  ;;; Define-Feeb builds a list of feebs to create.  Create-Feebs actually
157  ;;; builds the feebs on this list.  ;;; builds the feebs on this list.
159  (defvar *feebs-to-be* nil)  (defvar *feebs-to-be* nil)
161  (defun define-feeb (name brain &optional prepare graphs)  (defun define-feeb (name brain &optional initializer graphs)
162    (if (delete-feeb name)    "Defines a feeb with name NAME, behavior function BRAIN.
163    The INITIALIZER key option must be either a function that
164    will be called in the very start of the game, or nil.
165    If there is another feeb with the same name, overwrites it
166    with a case sensitive test"
167      (when (find name *feebs-to-be* :key #'car
168                  :test #'string= (delete-feeb name))
169        (warn "Feeb ~s already exists, deleting..." name))        (warn "Feeb ~s already exists, deleting..." name))
170    (push (list name brain prepare graphs) *feebs-to-be*))    (push (list name brain prepare graphs) *feebs-to-be*))
172  (defun delete-feeb (name)  (defun delete-feeb (name)
173    (not    "Deletes the feeb which has name NAME, causing it not to
174     (equal *feebs-to-be*  be created when the game begins. Does not work for feebs in
175            (setf *feebs-to-be*  the game"
176                  (remove name *feebs-to-be* :key #'car :test #'string=)))))    (setf *feebs-to-be*
177            (remove name *feebs-to-be* :key #'car :test #'string=)))
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))
185    (defun delete-all-feebs ()
186      "Deletes all feebs that are to be defined when the game begins."
187      (setf *feebs-to-be* nil))
189  (defun create-feebs ()  (defun create-feebs ()
190    (flet ((create-feeb (name brain prepare graphs)    (let ((entries (sort *entry-points* #'(lambda (x y)
191             (let ((pos (pick-random-entry-point))                                            (declare (ignore x y))
192                   (feeb (make-feeb *next-feeb-id* brain)))                                            (zerop (random 2))))))
193               (incf *next-feeb-id*)      (setf *feebs* nil)
194               (setf (feeb-image feeb)      (dolist (feeb-spec *feebs-to-be*)
195                      (make-feeb-image name feeb)        (let ((pos (pop entries)))
196                     (feeb-status feeb)          (apply 'create-feeb (car pos) (cdr pos) feeb-spec)))))
197                      (make-status name nil); (sdl:load-and-convert-image graphs))  
198                     (feeb-proximity feeb)  
199                      (make-proximity))  (defun play-one-turn ()
200               (change-feeb-pos feeb (pos-x pos) (pos-y pos))    ;; This is defined by rules
201               (change-feeb-facing feeb (random 4))    (start-turn)
202               (push feeb *feebs*)    ;; Maybe grow up mushrooms
203               (place-object (feeb-image feeb) (pos-x pos) (pos-y pos))    (let ((m-sites (sort *mushroom-sites*
204               (when prepare                         #'(lambda (x y)
205                 (let (*static-parameters* *fake-maze*)                             (declare (ignore x y))
206                   (funcall prepare))                             (zerop (random 2))))))
207                 (check-cheating name)))))      (dotimes (i *mushrooms-to-grow*)
208      (setf *feebs* nil        (let ((site (pop m-sites)))
209            *next-feeb-id* 0)          (create-mushroom (car site) (cdr site)))))
210      (dolist (feeb-spec (reverse *feebs-to-be*))    ;; Rot some carcasses:
211        (apply #'create-feeb feeb-spec))))    (loop for carc in *carcasses*
212            with ncarcasses do
213  ;;; Start at some randomly chosen entry point.  If this one is occupied,      (unless (rot-carcass (second carc) (third carc) (first carc))
214  ;;; scan successive entry points until a winner is found.  Circle back        (push carc ncarcasses)
215  ;;; to start of list if necessary.        (incf (first carc))
216          (reincarnate-feeb (pop *dead-feebs*))))
217  (defun pick-random-entry-point ()    ;; Move some fireballs:
218    (do ((points (nth (random *number-of-entry-points*) *entry-points*)    (dolist (fireball *fireballs-flying*)
219                 (nth (random *number-of-entry-points*) *entry-points*)))      (move-fireball fireball))
220        (nil)    ;; Playing with the feebs:
221      (when (null (aref *maze* (pos-x points)    (dolist (feeb *feebs*)
222                        (pos-y points)))      (unless (feeb-dead-p feeb)
223        (return points))))        ;; Starve the feeb:
224          (when (<= (decf (feeb-energy-reserve feeb)) 0)
225  ;;; Movement interface.          (kill-feeb feeb :starve))
226          ;; Compute vision for the feeb:
227  (defun delete-object (thing x y)        (compute-vision feeb)
228    (when (eq thing :mushroom)        ;; Collect the feeb's move
229      (decf *mushrooms-alive*))        (make-move-choice feeb)))
230    (setf (aref *maze* x y)    ;; Do all the feebs' moves.
231          (delete thing (aref *maze* x y))))    (dolist (feeb *feebs*)
232        (unless (feeb-dead-p feeb)
233  (defun place-object (thing x j)        (setf (feeb-peeking feeb) nil)
234    (when (eq thing :mushroom)        (move-feeb feeb (feeb-last-move feeb)))))
     (incf *mushrooms-alive*))  
   (push thing (aref *maze* x j)))  
 ;;; Functions to change optional structure in status  
 (defun change-feeb-pos (feeb x y)  
   (setf (feeb-x-position feeb) x  
         (feeb-y-position feeb) y)  
   (if *sense-location-p*  
       (setf (x-position (feeb-status feeb)) x  
             (y-position (feeb-status feeb)) y)))  
 (defun change-feeb-facing (feeb facing)  
   (setf (feeb-facing feeb)  
 ;;      ;; use this code to make *sense-facing-p* available  
 ;;      ;; but be carefull - it does not really work  
 ;;      (if (or *sense-location-p* *sense-facing-p*)  
 ;;          (setf (facing (feeb-status feeb))  
 ;;                facing)  
 ;;          facing)  
         (setf (facing (feeb-status feeb))  
               (setf (feeb-image-facing (feeb-image feeb))  
 (defun kill-feeb (feeb)  
   (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*)  
     (incf (score status) *points-for-dying*)  
     (delete-object (feeb-image feeb) x y)  
     (place-object :carcass x y)))  

Removed from v.1  
changed lines
  Added in v.5

  ViewVC Help
Powered by ViewVC 1.1.5