2013/03/23

Land of Lisp 10章のシミュレーション

画像は Land of Lisp 10 章で作るシミュレーションの世界にて100万日が経過した状態。

遺伝子とエネルギーを持った動く動物が、草と森がある世界で動きまわって食事をし、無性生殖で繁殖する世界のシミュレーション。動物は遺伝情報に従い特定の動きを見せ、動くことでエネルギーを消費する。草を食べることでエネルギーを補充、繁殖でエネルギーを大幅に消費、エネルギーが足りないと繁殖できない、エネルギーが切れると死ぬ、というもの。

ライフゲームも似たようなもんだよね。

プログラムの大部分は本に載っているCommon Lispのコードと翻訳者であるshiroさんが公開されているGaucheによるコードを基に、少し改造していくつかの条件をパラメータで渡せるコマンドにしてみたもの。

パラメータをいじって30万日くらい動かすと結果が違って楽しい。動作はコマンドを実行してEnterを押すごとに世界が1日進む。300000などの数値を打ち込んでEnterを押すとその分日数が経過する。

#!/usr/local/bin/gosh
;;; 本とshiroさんのコードを写経しつつ少し改造してあります。
;;; https://github.com/shirok/Gauche-LoL/blob/master/evolution.scm
;;; https://github.com/shirok/Gauche-LoL/blob/master/evolution-color.scm
(use srfi-1) ; list-tabulate
(use srfi-27) ; random-integer
(use gauche.parameter)
(use gauche.record)
(use gauche.sequence)
(use gauche.process)
(use gauche.parseopt)
(define-constant +GENES_LENGTH+ 8)
(define *plants* (make-hash-table 'equal?))
(define *width* (make-parameter 100))
(define *height* (make-parameter 30))
(define *jungle* (make-parameter '(45 10 10 10)))
(define *plant-energy* (make-parameter 80) )
(define (random-plant! left top width height)
(let1 pos (cons (+ left (random-integer width))
(+ top (random-integer height)))
(hash-table-put! *plants* pos #t)))
(define (add-plants!)
(apply random-plant! (*jungle*))
(random-plant! 0 0 (*width*)(*height*)))
(define-record-type animal #t #t
(x)(y)(energy)(dir)(genes))
(define *animals*
(list (make-animal
(ash (*width*) -1)
(ash (*height*) -1)
1000
0
(list-tabulate
+GENES_LENGTH+
(^_ (+ 1 (random-integer 10)))))))
(define (move! animal)
(let ((dir (animal-dir animal))
(x (animal-x animal))
(y (animal-y animal)))
(set! (animal-x animal)
(modulo (+ x (cond ((and (>= dir 2)(< dir 5)) 1)
((or (= dir 1)(= dir 5)) 0)
(else -1))
(*width*))
(*width*)))
(set! (animal-y animal)
(modulo (+ y (cond ((and (>= dir 0)(< dir 3)) -1)
((and (>= dir 4)(< dir 7)) 1)
(else 0))
(*height*))
(*height*)))
(dec! (animal-energy animal))))
(define (turn! animal)
(let1 x (random-integer (apply + (animal-genes animal)))
(define (angle genes x)
(let rec ((genes genes)(x x)(acc 0))
(let1 xnu (- x (car genes))
(if (< xnu 0)
acc
(rec (cdr genes) xnu (+ acc 1))))))
(set! (animal-dir animal)
(modulo (+ (animal-dir animal)
(angle (animal-genes animal) x))
+GENES_LENGTH+))))
(define (eat! animal)
(let1 pos (cons (animal-x animal)(animal-y animal))
(when (hash-table-get *plants* pos #f)
(inc! (animal-energy animal)(*plant-energy*))
(hash-table-delete! *plants* pos))))
(define *reproduction-energy* (make-parameter 200))
(define (reproduce! animal)
(let1 e (animal-energy animal)
(when (>= e (*reproduction-energy*))
(set! (animal-energy animal)(ash e -1))
(let ((animal-nu (make-animal (animal-x animal)
(animal-y animal)
(animal-energy animal)
(animal-dir animal)
(list-copy
(animal-genes animal))))
(mutation (random-integer +GENES_LENGTH+)))
(update! (~ animal-nu 'genes mutation)
(^v (max 1 (+ v (random-integer 3) -1))))
(push! *animals* animal-nu)))))
(define (update-world!)
(set! *animals* (remove! (^(animal)(<= (animal-energy animal) 0))
*animals*))
(dolist (animal *animals*)
(turn! animal)
(move! animal)
(eat! animal)
(reproduce! animal))
(add-plants!))
(define (draw-world)
(dotimes (y (*height*))
(newline)
(display "|")
(dotimes (x (*width*))
(display (cond ((find (^(animal) (and (= (animal-x animal) x)
(= (animal-y animal) y)))
*animals*)
=> (^a (with-color #\M (animal-genes a))))
((hash-table-get *plants* (cons x y) #f) #\*)
(else #\space))))
(display "|")
))
(define *hue-vecs*
'((255 0 0)
(255 191 0)
(128 255 0)
(0 255 64)
(0 255 255)
(0 64 255)
(128 0 255)
(255 0 191)))
(define *terminal-colors*
'(((0 0 0) "30")
((205 0 0) "31")
((0 205 0) "32")
((205 205 0) "33")
((0 0 238) "34")
((205 0 205) "35")
((0 205 205) "36")
((229 229 229) "37")
((127 127 127) "30;1")
((255 0 0) "31;1")
((0 255 0) "32;1")
((255 255 0) "33;1")
((92 92 255) "34;1")
((255 0 255) "35;1")
((0 255 255) "36;1")
((255 255 255) "37;1")))
(define (gene-color gene)
(let1 factor (/. (apply + gene))
(define (col picker)
(clamp (reduce + 0 (map (^(c g)(*. (picker c) g factor))
*hue-vecs* gene))
0 255))
(list (col car) (col cadr) (col caddr))))
(define (find-closest-terminal-color color)
(define (distance c1 c2)
(apply + (map (^p (expt (- (p c1) (p c2)) 2)) (list car cadr caddr))))
(find-min *terminal-colors* :key (^e (distance (car e) color))))
(define (with-color char gene)
(let1 entry (find-closest-terminal-color (gene-color gene))
(format "\u001b[~am~a\u001b[0m" (cadr entry) char)))
(random-source-randomize! default-random-source)
(define (evolution :optional
(width #f)(height #f)(jungle #f)(plant-energy #f)
(reproduction-energy #f))
(parameterize ((*width* (or width (*width*)))
(*height* (or height (*height*)))
(*jungle* (or jungle (*jungle*)))
(*plant-energy* (or plant-energy (*plant-energy*)))
(*reproduction-energy* (or reproduction-energy (*reproduction-energy*))))
(read-line)
(let loop ()
(draw-world)
(newline)
(let1 str (read-line)
(unless (equal? str "quit")
(if-let1 x (string->number str)
(dotimes (i x)
(update-world!)
(when (zero? (modulo i 1000))
(display #\.)(flush)))
(update-world!))
(loop))))))
(define (tput . args)
(run-process `(tput ,@args)))
(define (get-tput-val . args)
(process-output->string `(tput ,@args)))
(define (usage cmd)
(print "usage: " cmd "[option ...]")
(print " options:")
(print " w|width : world width (default: terminal width - 2)")
(print " h|height : world height (default: terminal height - 1)")
(print " j|jungle : jungle location and size (top left width height)")
(print " (default (45 10 10 10)) ")
(print " p|plant-energy : (default 80)")
(print " r|reproduction-energy : (default 200)")
(exit))
(define (main args)
(let-args (cdr args)
((help "h|help" => (cut usage (car args)))
(width "w|width=i" (- (string->number (get-tput-val 'cols)) 2))
(height "h|height=i" (- (string->number (get-tput-val 'lines)) 1))
(jungle "j|jungle=e" '(45 10 10 10))
(plant-energy "p|plant-energy=i" 80)
(reproduction-energy "r|reproduction-energy=i" 200)
(else (opt . _)
(print "Unknown option : " opt)
(usage (car args)))
. rest)
(evolution width height jungle plant-energy reproduction-energy)))
view raw evolution.scm hosted with ❤ by GitHub

さて、読んでいてよくわからなかったのが、P.202の turn 手続きで移動方向を決める部分。説明を読んでもいまいち意味がわからなかった。angle 手続きを呼び出す辺り。angle の定義はこれ。

(define (angle genes x)
  (let1 xnu (- x (car genes))
    (if (< xnu 0)
        0
        (+ 1 (angle (cdr genes) xnu)))))

自分なりに書きなおしてみたのはこれ。

(define (angle genes x)
  (let rec ((genes genes)(x x)(acc 0))
    (let1 xnu (- x (car genes))
      (if (< xnu 0)
          acc
          (rec (cdr genes) xnu (+ acc 1))))))

angle 手続き事態は難しくないけど、これを使って何をやってるのかがわからなかった。

angle の仕事は、引数 x を基に、引数 genes（リスト）から一つ要素を選び、選ばれた要素のインデックスを返すこと。例えば、genes が (1 1 10 5 2 1 1 1) だった場合、合計が22なので x は0〜21のランダムな数値（angle を呼び出す側で決められる）で束縛される。angle の評価結果として出現する頻度が最も高いのが2、次が3、その次が4。

絵に書くとこんな感じか。絵の上の行の数値が x 、下が選択される要素。

今この絵を描いていて思いついたけど、以下のようなリストからランダムに選ぶのと同じってことだな。

(use srfi-27)
(let1 genes '(1 1 10 5 2 1 1 1)
  (apply append
         (map (^(g i)
                (iota g i 0))
              genes
              (iota (length genes)))))
;; => (0 1 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 4 4 5 6 7)

ということで、angle 手続きは下記のようなものでも良いということか。

(define (angle genes x)
  (~ (apply append
            (map (^(g i)
                   (iota g i 0))
                 genes
                 (iota (length genes))))
     x))

余談

これ、条件をちゃんと考えたら「ライフメーカーの掟」のプロローグ部分（ロボットがバグって進化し始める）のシミュレーション作れるんじゃないの。 （「ロボットがバグって進化し始める」っていう説明ではすごくちゃちなものに聞こえてしまうな。これをホーガン氏が書くとどえらい壮大なことになるんだよなあ。） このシミュレーションプログラムを有性生殖にして工場を作るだけでも近いものになりそうだな、という話。


written by time:
labels : , , ,

0 件のコメント:

コメントを投稿

登録: コメントの投稿 (Atom)