311 lines
9.9 KiB
Common Lisp
311 lines
9.9 KiB
Common Lisp
(in-package :de.anvi.croatoan.test)
|
|
|
|
;; Example from "Land of Lisp", Copyright by Conrad Barski.
|
|
;; Source: http://landoflisp.com/evolution.lisp
|
|
;; Unknown licence.
|
|
|
|
(defparameter *width* 100)
|
|
(defparameter *height* 30)
|
|
(defparameter *jungle* '(45 10 10 10))
|
|
(defparameter *plant-energy* 80)
|
|
(defparameter *plants* (make-hash-table :test #'equal))
|
|
(defparameter *reproduction-energy* 200)
|
|
|
|
(defstruct animal x y energy dir genes)
|
|
|
|
|
|
(defun random-plant (left top width height)
|
|
(let ((pos (cons (+ left (random width))
|
|
(+ top (random height)))))
|
|
(setf (gethash pos *plants*) t)))
|
|
|
|
(defun add-plants ()
|
|
;; First one in the jungle.
|
|
(apply #'random-plant *jungle*)
|
|
;; Then one in the rest of the world.
|
|
(random-plant 0 0 *width* *height*))
|
|
|
|
;; Define one starting animal.
|
|
(defparameter *animals*
|
|
(list (make-animal :x (ash *width* -1)
|
|
:y (ash *height* -1)
|
|
:energy 1000
|
|
:dir 0
|
|
:genes (loop repeat 8 collect (1+ (random 10))))))
|
|
|
|
(defun move- (animal)
|
|
(let ((dir (animal-dir animal))
|
|
(x (animal-x animal))
|
|
(y (animal-y animal)))
|
|
|
|
;; If x>width, wrap around the world border with the mod function.
|
|
(setf (animal-x animal)
|
|
(mod (+ x (cond ((and (>= dir 2) (< dir 5)) 1)
|
|
((or (= dir 1) (= dir 5)) 0)
|
|
(t -1))
|
|
*width*)
|
|
*width*))
|
|
|
|
;; Down is +1, up is -1.
|
|
(setf (animal-y animal)
|
|
(mod (+ y (cond ((and (>= dir 0) (< dir 3)) -1)
|
|
((and (>= dir 4) (< dir 7)) 1)
|
|
(t 0))
|
|
*height*)
|
|
*height*))
|
|
|
|
(decf (animal-energy animal))))
|
|
|
|
(defun turn (animal)
|
|
(let ((x (random (apply #'+ (animal-genes animal)))))
|
|
(labels ((angle (genes x)
|
|
(let ((xnu (- x (car genes))))
|
|
(if (< xnu 0)
|
|
0
|
|
(1+ (angle (cdr genes) xnu))))))
|
|
|
|
(setf (animal-dir animal)
|
|
(mod (+ (animal-dir animal)
|
|
(angle (animal-genes animal) x))
|
|
8)))))
|
|
|
|
(defun eat (animal)
|
|
(let ((pos (cons (animal-x animal) (animal-y animal))))
|
|
(when (gethash pos *plants*)
|
|
(incf (animal-energy animal) *plant-energy*)
|
|
(remhash pos *plants*))))
|
|
|
|
(defun reproduce (animal)
|
|
(let ((e (animal-energy animal)))
|
|
(when (>= e *reproduction-energy*)
|
|
(setf (animal-energy animal) (ash e -1))
|
|
(let ((animal-nu (copy-structure animal))
|
|
(genes (copy-list (animal-genes animal)))
|
|
(mutation (random 8)))
|
|
;; mutate a random gene by +1 or -1.
|
|
(setf (nth mutation genes)
|
|
(max 1 (+ (nth mutation genes) (random 3) -1)))
|
|
;; deep copy of the gene list.
|
|
(setf (animal-genes animal-nu) genes)
|
|
;; push the new animal to the list.
|
|
(push animal-nu *animals*)))))
|
|
|
|
(defun update-world ()
|
|
;; Remove dead animals.
|
|
(setf *animals*
|
|
(remove-if (lambda (animal) (<= (animal-energy animal) 0))
|
|
*animals*))
|
|
;; Do what animals do.
|
|
(mapc (lambda (animal)
|
|
(turn animal)
|
|
(move- animal)
|
|
(eat animal)
|
|
(reproduce animal))
|
|
*animals*)
|
|
;; Grow plants.
|
|
(add-plants))
|
|
|
|
;;; simple non-ncurses version from LOL, prints to REPL.
|
|
(defun draw-world ()
|
|
(loop for y
|
|
below *height*
|
|
do (progn (fresh-line)
|
|
;; beginning of the line.
|
|
(princ "|")
|
|
(loop for x
|
|
below *width*
|
|
do (princ (cond
|
|
;; if there is one or more animals, print a M.
|
|
((some (lambda (animal) (and (= (animal-x animal) x)
|
|
(= (animal-y animal) y)))
|
|
*animals*)
|
|
#\M)
|
|
;; if there is a plant, print *
|
|
((gethash (cons x y) *plants*) #\*)
|
|
;; if there is neithe a plant nor an animal, print a space.
|
|
(t #\space))))
|
|
;; end of the line.
|
|
(princ "|"))))
|
|
|
|
;; enter a recursive infinite loop as the programs main loop.
|
|
(defun evolution ()
|
|
(draw-world)
|
|
;; add an empty line between worlds.
|
|
(fresh-line)
|
|
(let ((str (read-line)))
|
|
(cond ((equal str "quit") ())
|
|
(t (let ((x (parse-integer str :junk-allowed t)))
|
|
(if x
|
|
(loop for i
|
|
below x
|
|
do (update-world)
|
|
if (zerop (mod i 1000))
|
|
do (princ #\.))
|
|
(update-world))
|
|
(evolution))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; instead of using princ to draw to stdout, use add-string to draw to the curses screen.
|
|
;; the screen has to be initialized first in the main function evolve.
|
|
(defun draw-world-croatoan (scr)
|
|
(loop
|
|
for y
|
|
from 0
|
|
below *height*
|
|
do (loop
|
|
for x
|
|
from 0
|
|
below *width*
|
|
do (add-string scr
|
|
(format nil "~A"
|
|
(cond
|
|
;; if there is one or more animals, print a M.
|
|
((some (lambda (animal) (and (= (animal-x animal) x)
|
|
(= (animal-y animal) y)))
|
|
*animals*)
|
|
#\M)
|
|
;; if there is a plant, print *
|
|
((gethash (cons x y) *plants*) #\*)
|
|
;; if there is neithe a plant nor an animal, print a space.
|
|
(t #\space)))
|
|
:y y
|
|
:x x)))
|
|
;; refresh the physical screen to dsplay the drawn changes.
|
|
(refresh scr))
|
|
|
|
;; enter a recursive infinite loop as the programs main loop.
|
|
(defun evolve ()
|
|
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
|
(clear scr)
|
|
(setf (background scr) (make-instance 'complex-char :color-pair '(:green :white)))
|
|
|
|
(setq *width* (width scr))
|
|
(setq *height* (height scr))
|
|
|
|
(loop
|
|
initially
|
|
(draw-world-croatoan scr)
|
|
|
|
for ch = (get-char scr)
|
|
|
|
while (or (= ch -1) (not (equal (code-char ch) #\q)))
|
|
do
|
|
(update-world)
|
|
(sleep 0.001)
|
|
(draw-world-croatoan scr))))
|
|
|
|
;; uses tagbody to separate between event handling and body.
|
|
(defun evolve2 ()
|
|
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
|
(clear scr)
|
|
(setf (background scr) (make-instance 'complex-char :color-pair '(:green :white)))
|
|
|
|
(setq *width* (width scr))
|
|
(setq *height* (height scr))
|
|
|
|
(draw-world-croatoan scr)
|
|
(refresh scr)
|
|
|
|
(loop
|
|
(tagbody
|
|
|
|
;; read a char.
|
|
(let ((ch (get-char scr)))
|
|
|
|
;; if it is -1, just execute the body.
|
|
;; this is a special event when there is no event.
|
|
(cond ((= ch -1) (go evolution-body))
|
|
|
|
;; And from here we have real key/character events.
|
|
((equal (code-char ch) #\q) (return))))
|
|
|
|
evolution-body
|
|
|
|
(update-world)
|
|
(sleep 0.001)
|
|
(draw-world-croatoan scr)
|
|
(refresh scr)))))
|
|
|
|
;; uses key-pressed-p to separate between events and the body, instead of loop and tagbody used in 1 and 2.
|
|
(defun evolve3 ()
|
|
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
|
(clear scr)
|
|
;(setf (background scr) (make-instance 'complex-char :color-pair '(:green :white)))
|
|
|
|
(setq *width* (width scr))
|
|
(setq *height* (height scr))
|
|
|
|
(draw-world-croatoan scr)
|
|
|
|
(loop
|
|
(if (key-pressed-p scr)
|
|
(let ((ch (get-char scr)))
|
|
(cond ((equal (code-char ch) #\q) (return))))
|
|
(progn
|
|
(update-world)
|
|
(sleep 0.001)
|
|
(draw-world-croatoan scr) )))))
|
|
|
|
(defun evolve4 ()
|
|
"Uses get-event to separate between events and the body, instead of key-pressed-p."
|
|
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
|
(clear scr)
|
|
;(setf (background scr) (make-instance 'complex-char :color-pair '(:green :white)))
|
|
|
|
(setq *width* (width scr))
|
|
(setq *height* (height scr))
|
|
|
|
(draw-world-croatoan scr)
|
|
|
|
(loop
|
|
(let ((event (get-event scr)))
|
|
(if event
|
|
(case event
|
|
(#\q (return)))
|
|
(progn
|
|
(update-world)
|
|
(sleep 0.001)
|
|
(draw-world-croatoan scr) ))))))
|
|
|
|
(defun evolve5 ()
|
|
"Use the event-case macro for event handling."
|
|
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
|
(clear scr)
|
|
|
|
(setq *width* (width scr))
|
|
(setq *height* (height scr))
|
|
|
|
(draw-world-croatoan scr)
|
|
|
|
(event-case (scr event)
|
|
(#\q (return-from event-case))
|
|
((nil)
|
|
(update-world)
|
|
(sleep 0.001)
|
|
(draw-world-croatoan scr)))))
|
|
|
|
(defun update-game-state (win event)
|
|
"Main game state update function for evolve6, called during the nil event handling."
|
|
(declare (ignore event))
|
|
(update-world)
|
|
(draw-world-croatoan win))
|
|
|
|
(defun evolve6 ()
|
|
"Use the run-event-loop for event handling."
|
|
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
|
(clear scr)
|
|
|
|
(setq *width* (width scr))
|
|
(setq *height* (height scr))
|
|
|
|
(bind scr #\q 'exit-event-loop)
|
|
(bind scr nil 'update-game-state)
|
|
|
|
;; For the same effect, set :input-blocking to 1 milisecond.
|
|
(setf (frame-rate scr) 1000)
|
|
|
|
;; Draw the world once before entering the main loop.
|
|
(draw-world-croatoan scr)
|
|
|
|
(run-event-loop scr)))
|