Heaven's Kitchen

目を覚ませ自分。

授業の課題でGA(Genetic Algorithm)を実装しろというのが出て，使う言語はなんでもいいと書いてあったので，SICP読み会でお近づきになりつつあるSchemeでやってみました。(ちなみにGAは，2時間教科書を読んだだけのど素人です。ごめんなさい。)

予定の倍ぐらい時間かかって自分の無力さを痛感…。ていうかHaskellなら標準でこういう関数あるのになぁとかいうところが多々…。リストまわりぐらい名前統一されないかな。まあ無理か…。

f(x)=10-8x-x^2 

の(0<=x<=10)の範囲内での最大値をGAで求めるというのが課題で，

以下のがコード(たぶんgaucheでしか動きません)。英語のコメントはかなり適当です（汗

ツッコミ歓迎。

(use srfi-1)          ; take, fold, etc ...
(use math.mt-random)  ; mt-random-real, mt-random-integer

;; convert binary list to decimal
;; ex. (1 0 1 1) -> 11
(define (bin2dec xs)
  (define (iter msb remain accum)
    (let ((ans (+ msb (* 2 accum))))
      (if (null? remain)
	  ans
	  (iter (car remain) (cdr remain) ans))))
  (iter (car xs) (cdr xs) 0))

;; random seed 
(define m (make <mersenne-twister> :seed (sys-time)))

;; make binary list randomly
(define (generate-random-boolean)
  (mt-random-integer m 2))

;; this is utility function.
;; this makes 'len' length list using generator defined by the user.
;; ex. (list-from-generator (lambda () 1) 4) -> (1 1 1 1)
(define (list-from-generator gen len)
  (define (iter accum count)
    (if (= count len)
	accum
	(iter (cons (gen) accum) (+ 1 count))))
  (iter '() 0))

;; calculate sum of numeric list
;; ex. (sum '(1 2 3)) -> 6
(define sum (pa$ fold + 0))

;; calculate average of numeric list
(define (ave xs)
  (let ((len (length xs))
	(sumval (sum xs)))
    (/ sumval len)))

;; this function corresponds to Haskell's concatMap function
(define concat-map
  (compose concatenate map))

;; this function corresponds to Haskell's List.scanl function
(define (scan f init xs)
  (if (null? xs) 
      (cons init '())
      (let ((val (f init (car xs))))
	(cons init (scan f val (cdr xs))))))

;; make 'population' size chromosomes each bit size equals bits-num.
(define (make-random-chromosomes bits-num poplation)
  (define (make-random-chromosome num)
    (list-from-generator generate-random-boolean num))
  (list-from-generator 
   (lambda () (make-random-chromosome bits-num))
   poplation))

;; fitness function for this assignment
(define (fitness-function x)
  (- 8 (* 10 x) (* x x)))

;; print chromesome and newline code.
(define (print-chromosome xs)
  (map display xs)
  (display "\n") xs)

;; assuming xs's length equals ys's length
(define (crossover xs ys)
  (let* ((bound (length xs))
	 (cross-point (mt-random-integer m bound)))
    (values (append (take xs cross-point) (drop ys cross-point))
	    (append (take ys cross-point) (drop xs cross-point)))))

;; mutate chromosome
(define (mutation xs)
  (define (flip-integer i)
    (if (= i 0)	1 0))
  (let* ((bound (length xs))
	 (position (mt-random-integer m bound)))
    (receive (bef aft) (split-at xs position)
	     (append bef (cons (flip-integer (car aft)) (cdr aft))))))

;; set bias to list of fitness function's values.
(define (bias xs)
  (let ((minval (apply min xs)))
    (if (> 0 minval)
	(map (pa$ + (- minval) 0.1) xs)
	xs)))

(define (select-parent xs)
  (define (decide-index)
    (define (iter r ls count)
      (if (<= r (car ls))
	  (- count 1)
	  (iter r (cdr ls) (+ 1 count))))
    (let* ((borders (scan + 0.0 (bias xs)))
	   (bound (last borders))
	   (ratio (* bound (mt-random-real m))))
	  (iter ratio borders 0)))
  (cons (decide-index) (decide-index)))

(define (select-parents xs n)
  (list-from-generator (pa$ select-parent xs) n))

(define (mate xs ys probability)
  (let ((r (mt-random-real m)))
    (if (< r probability)
	(crossover xs ys)
	(values xs ys))))

(define (mutate xs probability)
  (define (mut x)
    (let ((r (mt-random-real m)))
      (if (< r probability)
	  (mutation x)
	  x)))
  (map mut xs))

(define calc-fitness 
  (compose fitness-function
	   (lambda (x) (* 10 (/ x 255.0))) bin2dec))

(define (display-results values)
  (map display (list (apply max values) " "
		     (ave values) "\n")))

(define (ga pop cross-rate mutate-rate generation-limit)
  (define (iter xs count)
    (define (make-children parents-indexes)
      (let ((father (ref xs (car parents-indexes)))
	    (mother (ref xs (cdr parents-indexes))))
	(receive (c1 c2) (mate father mother cross-rate)
		 (list c1 c2))))
    (if (= count generation-limit) #t
	(let* ((fitnesses (map calc-fitness xs))
	       (parents (select-parents fitnesses (/ pop 2))))
	  (display-results fitnesses)
	  (iter (mutate (concat-map make-children parents)
			mutate-rate)
		(+ count 1)))))
  (let ((initials (make-random-chromosomes 8 pop)))
    (iter initials 0)))

(ga 50 0.7 0.001 1000)

"27時間テレビ"っていうキーワードが，mixiのキーワードランキングには出てなくて，はてなの注目キーワードには出てる．

自動キーワード抽出では"27時間テレビ"は出てこないよなぁ．