梦中的橄榄树分享 http://blog.sciencenet.cn/u/xsplendor

博文

最简单遗传算法的scheme语言实现

已有 4767 次阅读 2009-1-15 14:54 |个人分类:计算机|系统分类:科研笔记|关键词:遗传算法,scheme| 遗传算法, scheme

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

http://blog.sciencenet.cn/blog-109151-210241.html


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

0

发表评论 评论 (0 个评论)

数据加载中...
扫一扫,分享此博文

相关博文

Archiver|手机版|科学网 ( 京ICP备14006957 )

GMT+8, 2019-10-22 11:58

Powered by ScienceNet.cn

Copyright © 2007- 中国科学报社

返回顶部