;徐光华 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