Land of Lisp 第10章

evolution.lisp

(defparameter *width* 100)
(defparameter *height* 30)
(defparameter *jungle* '(45 10 10 10))
(defparameter *plant-energy* 80)
;; key => (x座標 . y座標), value => t 
;; コンスセルを比較するにはequalが必要となる為、:test #'equalとしている
(defparameter *plants* (make-hash-table :test #'equal))
(defparameter *reproduction-energy* 200)

(defstruct animal x y energy dir genes)
(defparameter *animals*
  (list (make-animal :x      (ash *width*  -1) ;; マップ横座標の半分
		     :y      (ash *height* -1) ;; マップ縦座標の半分
		     :energy 1000
		     :dir    0
		     :genes  (loop repeat 8
				   collecting (1+ (random 10))))))

;; dir 動物の進行方向
;; 0 1 2
;; 7   3
;; 6 5 4

;; genes 各方向へと向きを変える確率
;; e.g. (1 1 4 10 1 1 1 1)
;; 0  1  2  3  4  5  6  7
;; 1  1  4 10  1  1  1  1

(defun random-plant (left top width height)
  (let ((pos (cons (+ left (random width)) (+ top (random height)))))
    (setf (gethash pos *plants*) t)))

(defun add-plants ()
  (apply #'random-plant *jungle*) ;; ジャングルを対象に草を生やす
  (random-plant 0 0 *width* *height*)) ;; map全体(ジャングルを含む)を対象に草を生やす

;; 動物を動かす
(defun move (animal)
  (let ((dir (animal-dir animal))
	(x (animal-x animal))
	(y (animal-y animal)))
    ;; マップは上下左右が繋がっているのでmodを使って剰余を求め*width*内に収まるようにしている
    (setf (animal-x animal) (mod (+ x  
				    (cond ((and (>= dir 2) (< dir 5)) 1)
					  ((or (= dir 1) (= dir 5)) 0)
					  (t -1)))
				 *width*))
    (setf (animal-y animal) (mod (+ y
				    (cond ((and (>= dir 0) (< dir 3)) -1)
					  ((and (>= dir 4) (< dir 7)) 1)
					  (t 0)))
				 *height*))
    ;; 移動したらenergeを1消費する
    (decf (animal-energy animal))))
	 
;; 動物の向きを変える
(defun turn (animal)
  ;; 遺伝子の総和を求めそれより小さい非負整数をランダムに選択する
  (let ((x (random (apply #'+ (animal-genes animal)))))
    (labels ((angle (genes x)
	       ;; 現在見ている遺伝子の値を減算
	       (let ((xnu (- x (car genes))))
		 ;; 結果がゼロか負ならxは現在見ている遺伝子のスロットを選択したという事
		 (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))
      ;; 単にcopy-structureで構造体をコピーするだけ
      ;; しかしcopy-structureは浅いコピーを行うのでリスト等のデータが共有されてしまう。
      ;; そこで、genesではcopy-listを使ってlistを複製しコピーした構造体に改めてsetfしている。
      (let ((animal-nu (copy-structure animal))
	    (genes     (copy-list (animal-genes animal)))
	    (mutation  (random 8)))
	;; (max 1 (+ 遺伝子 (random 3) -1))では、まず1/0/-1をランダムに得て加算している。
	;; これはつまり1/3の確率で一つ増える・変わらない・一つ減るになるという事。
	;; 0以下になっては困るのでmax関数を使って1以上の値になるようにしている。
	(setf (nth mutation genes) (max 1 (+ (nth mutation genes) (random 3) -1)))
	(setf (animal-genes animal-nu) genes)
	(push animal-nu *animals*)))))
	
;; 一日をシュミレート	       
(defun update-world ()
  (setf *animals* (remove-if (lambda (animal)
			       (<= (animal-energy animal) 0))
			     *animals*))
  (mapc (lambda (animal)
	  (turn animal)
	  (move animal)
	  (eat animal)
	  (reproduce animal))
	*animals*)
  (add-plants))
	
;; 描画する
(defun draw-world ()
  (loop for y
	below *height*
	do (progn (fresh-line)
		  (princ "|")
		  (loop for x
			below *width*
			do (princ (cond ((some (lambda (animal)
						 (and (= (animal-x animal) x)
						      (= (animal-y animal) y)))
					       *animals*)
					 #\M)
					((gethash (cons x y) *plants*) #\*)
					(t #\space))))
		  (princ "|"))))

;; ユーザインタフェースとなる関数
;; 経過させたい日数を入力すると、その日数分シュミレートを進められる。
(defun evolution ()
  (draw-world)
  (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))))))

(evolution)

Loopコマンドによるループと前章で学んだジェネリックプログラミング（構造体やハッシュテーブルとか）

clisp -i evolution.lispでrepl環境で事前にロードしつつREPLを起動できる。
500万日とか経過させてみた後に"quit"を打ち込んでみて_animals_を確認すると、遺伝子にちょっとした特徴が・・