;徐光华 2009/1/15
;为了学习遗传算法和scheme编程语言，编写此程序。
;编写过程中，主要的困难来自于scheme的side-effect （即副作用），一度出些莫名其妙的结果，让我快要崩溃，以下是当时随意写下的一些过程。
;vector-set!()的使用引入了副作用。
;快崩溃了，exchange有问题，但不知道是什么问题。难道还是因为side-effect?看来是的，只能不用引起side-effect的东西了。
;还是不明白到底那里有问题，每个函数看来都没错。
;每此运行结果后来为什么都是整数的平均适应度？除非每次突变对所有染色体造成同样结果。但为什么会这样呢？
;select 和exchange或 mutate结合后就造成了这样的问题，他们本身都没有问题。
;真的不明白是什么问题了，难道还是因为side-effect?也只有这种可能了。
;2008/11/29, 重新编写exchang()和mutate()，全部去除side-effect，只使用函数返回值，终于成功了！
;程序如下：
;;初始化一个向量，其值为随机0,1。作为一个染色体的表示。      
(define (gen-chromosome n)
  (cond ((= n 0) '())
    (else (cons (random 2) (gen-chromosome (- n 1))))))

;生成染色体组，以list形式；num为染色体数，leng为每个染色体长度。
(define (gen-chroms num leng)
  (cond ((= num 0) '())
    (else (cons (gen-chromosome leng) (gen-chroms (- num 1) leng)))))
;生成染色体组，共4个染色体，长度为8。
;(define Chroms (gen-chroms 4 8))

;计算染色体组的适应度，以和为适应度。
(define (cal-fitness chroms)
  (map (lambda (x) (apply + x))  chroms))
;计算染色体组平均适合度
(define (cal-average-fitness chroms)
  (/ (apply + (cal-fitness chroms)) (length chroms)))

;;子代染色体选择,按概率选择最适应的
;选择函数,从一组染色体chroms中按照各染色体适应值values的大小，随机选取一个染色体。
(define (comp rand values chroms)
  (cond ((null? chroms) '())
    ((< rand (car values)) (car chroms))
    (else (comp (- rand (car values)) (cdr values) (cdr chroms)))))
;随机选择函数，从染色体组中选取一次，得到一个子代。
(define (select-once values chroms)
  (let ((rand (random (apply + values))))
    (comp rand values chroms)))
;总的选择函数,选择多次，使子代与父代有同样多的染色体，生成子代染色体,子代染色体独立于父代。
(define (select chroms)
  (let ((values (cal-fitness chroms))
    (leng (length chroms)))
    (letrec ((sel (lambda (count values_ chroms_)
            (cond ((= count 0) '())
              (else (cons (select-once values_ chroms_) (sel (- count 1) values_ chroms_)))))))
      (sel leng values chroms))));count的初始值为leng.
;;;;
;;交换,由于之前的选择是随机的，只要相邻的两个染色体交换即可。
;;但是交换问题有点复杂，包括交换概率，交换位点选择。

;先写一个函数可以起类似list-tail功能，但提取的是前面部分。其功能与list-tail互补。
(define (list-head lis n)
  (cond ((> n 0)
     (cond ((pair? lis)
        (cons (car lis) (list-head (cdr lis) (- n 1))))
           (else 'error)))
    (else '())))
   
;list-head 功能演示：
;guile> (let ((lis '(1 2 3 4))
;         (n 2))
;     (append (list-head lis n) (list-tail lis n)))
;(1 2 3 4)

;没有副作用的determ-exchange。ch1，ch2表示两个染色体，locus为位点。
(define (determ-exchange ch1 ch2 locus)
  (cond ((null? ch1) '())
    ( (or (< locus 0) (> locus (length ch1)))
      "locus impropor.")
    (else (list (append (list-head ch1 locus) (list-tail ch2 locus))
            (append (list-head ch2 locus) (list-tail ch1 locus))))))


;给定概率和随机位点的交换,交换概率为p。
(define (rand-exchange p ch1 ch2)
  (cond ((> p (random 1.0)) ;达到交换概率时发生交换
     (let ((locus (random (length ch1))))
       (determ-exchange ch1 ch2 locus)))
    (else (list ch1 ch2)))) ;否则不发生交换
;我们所需要的交换函数,染色体组内的各相邻染色体两两进行rand-exchange,并重新连成一个染色体组list.
(define (exchange p chrom)
  (cond ((null?  chrom) '())
    ((null? (cdr chrom)) '());防止染色体组含单数个染色体的情况。
    (else     (append (rand-exchange p (car chrom) (cadr chrom))
            (exchange p (cddr chrom))))))

;;
;;突变,每个染色体都有一个概率在某个位点发生突变。跟交换差不多，但简单些。
;首先是固定位点的突变，定义一个无副作用的determ-mutate函数。ch表示染色体，locus为位点。
(define (determ-mutate ch locus)
  (cond ((null? ch) '())
    ((or (< locus 0) (> locus (- (length ch) 1)))
     "error")
    (else
     (append (list-head ch locus )
         (cons (random 2)
               (list-tail ch (+ 1 locus)))))))

;然后给定概率的随机位点突变
(define (rand-mutate p ch)
  (cond ((> p (random 1.0))
     (let ((locus (random (length ch))))
       (determ-mutate ch locus)))
    (else ch)))
;我们所需要的突变函数。
(define (mutate p chroms)
  (cond ((null? chroms) '())
    (else (cons (rand-mutate p (car chroms))
            (mutate p (cdr chroms))))))

;OK,所有准备都完成，写最后的函数。
;genetic函数表示整个遗传算法，两个参数：n为算法迭代次数，chroms为初始染色体组。
(define (genetic n chroms)
    (cond ((> n 0)
       (begin
         (display (cal-average-fitness chroms))
         (display " ")
         (genetic (- n 1) (mutate 0.02  (exchange 0.6 (select chroms))))))
      (else '())))
     
;进行演示。
(let ((K (gen-chroms 20 10)))
  (genetic 50 K))

转载本文请联系原作者获取授权，同时请注明本文来自徐光华科学网博客。
链接地址：https://blog.sciencenet.cn/blog-109151-210241.html


下一篇：一个linux下好用的笔记软件Xournal