遗传算法

aimisiyou · 发表于 2018-2-8 22:54:22

本帖最后由 aimisiyou 于 2018-2-8 22:56 编辑

;;; 适应度函数
(defun fitfun (en)             ;;;en为个体，如en=(1 0 0 1 0 1 0 1 1)
   (apply '+ en)             ;;; 确定适应度函数
)

;;;选择函数
(defun selct (poplst)
(setq i 0 num  (length poplst) new_poplst nil d_sum 0 d_lst nil)
(setq fitlst (mapcar '(lambda (x) (fitfun x)) poplst))
(setq sum_fitlst (apply '+ fitlst))
(setq fitlst (mapcar '(lambda (x) (/ (* x 1.0) sum_fitlst)) fitlst))
(while (< i num)
      (setq l_sum (+ d_sum (nth i fitlst)))
      (setq d_lst (cons (list d_sum l_sum) d_lst))
      (setq d_sum  l_sum)
      (setq i (+ i 1))
)
(setq d_lst (reverse d_lst))
(repeat num
      (setq num_rnd (rnd))
      (setq new_poplst (cons
                           (nth (vl-position t (mapcar '(lambda (x) (if (and (<= (car x) num_rnd) (< num_rnd (cadr x)) ) t nil)) d_lst)) poplst)                                                             new_poplst
                        )
      )
)
new_poplst
)

aimisiyou · 发表于 2018-2-8 23:10:57

本帖最后由 aimisiyou 于 2018-2-8 23:16 编辑

检测下遗传算法在仅有选择算子情况下的运行结果
(defun rnd ()
  (*(rem (getvar "cputicks") 1e4) 1e-4)
)
(defun pick (lst i j)
(setq count (length lst) nc 0 picklst nil)
(while (<= nc j)
   (if (<= i nc)
         (setq picklst (cons (nth nc lst) picklst))
   )
   (setq nc (+ nc 1))
)
(reverse picklst)
)
(defun ff (n)
(setq lst '((0 5 1)(5 10 0)) vlst nil)
(repeat n
      (setq num (fix (rem (getvar "CPUTICKS") 11)))
      (setq vlst (cons (car (vl-remove nil (mapcar '(lambda (x) (if (<= (car x) num (cadr x)) (last x) nil)) lst))) vlst))
)
)

;;; 适应度函数
(defun fitfun (en)             ;;;en为个体，如en=(1 0 0 1 0 1 0 1 1)
   (apply '+ en)          ;;; 确定适应度函数
)

;;;选择函数
(defun selct (poplst)
(setq i 0 num  (length poplst) new_poplst nil d_sum 0 d_lst nil)
(setq fitlst (mapcar '(lambda (x) (fitfun x)) poplst))
(setq sum_fitlst (apply '+ fitlst))
(setq fitlst (mapcar '(lambda (x) (/ (* x 1.0) sum_fitlst)) fitlst))
(while (< i num)
      (setq l_sum (+ d_sum (nth i fitlst)))
      (setq d_lst (cons (list d_sum l_sum) d_lst))
      (setq d_sum  l_sum)
      (setq i (+ i 1))
)
(setq d_lst (reverse d_lst))
(repeat num
      (setq num_rnd (rnd))
      (setq new_poplst (cons
                           (nth (vl-position t (mapcar '(lambda (x) (if (and (<= (car x) num_rnd) (< num_rnd (cadr x)) ) t nil)) d_lst)) poplst)                                        new_poplst
                        )
      )
)
new_poplst
)
(setq poplst nil)
(repeat 100
  (setq plst (ff 20))
  (setq poplst (cons plst poplst))
)
(repeat 200 (setq poplst (selct poplst)))

结果为((0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0) (0 1 1 1 1 0 1 1 1 1 1 1 0 0 1 0 1 1 1 0))
_$

可见得到的是局部最优解（且种群为100个同样个体，换句话说无法跳出局部区域），离全局最优解(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)有点距离，还算差强人意。

aimisiyou · 发表于 2018-2-9 00:01:24

本帖最后由 aimisiyou 于 2018-2-9 07:44 编辑

;;;交叉函数
(defun cross (poplst)
  (defun pick (lst i j)
   (setq count (length lst) nc 0 picklst nil)
   (while (<= nc j)
      (if (<= i nc)
         (setq picklst (cons (nth nc lst) picklst))
      )
   (setq nc (+ nc 1))
   )
   (reverse picklst)
  )
(defun twocross (tolst)
(setq me (car tolst))
(setq fe (cadr tolst))
(setq n_dna (length me))
(setq num_point (fix (rem (getvar "CPUTICKS") n_dna)))
(list
      (append (pick me 0 num_point) (pick fe (+ 1 num_point) (- n_dna 1 )))
      (append (pick fe 0 num_point) (pick me (+ 1 num_point) (- n_dna 1 )))
   )
  )
(defun cp (poplst) ;;;注意确保种群容量为偶数
(setq n_pop (length poplst))
(mapcar '(lambda (x y) (list x y)) (pick poplst 0 (/ (- n_pop 2) 2)) (pick poplst (/ n_pop  2) (- n_pop 1)))
  )
  (setq cp_poplst (cp poplst) num_cross 0.6 n_cross (rnd))          ;;;设定交叉概率为0.6
(if (< n_cross num_cross )
   (setq pbplst (apply 'append (mapcar '(lambda (x) (twocross  x)) cp_poplst)))
   (setq pbplst  poplst)
  )
  pbplst
)

aimisiyou · 发表于 2018-2-9 00:25:49

本帖最后由 aimisiyou 于 2018-2-9 07:47 编辑

;;;变异函数
(defun change (poplst)
(defun pick (lst i j)
   (setq count (length lst) nc 0 picklst nil)
   (while (<= nc j)
      (if (<= i nc)
         (setq picklst (cons (nth nc lst) picklst))
      )
      (setq nc (+ nc 1))
   )
   (reverse picklst)
)
  (setq num_change 0.05 n_change (rnd))    ;;;设定变异概率为0.05
  (if (< n_change num_change)
   (setq poplst  (mapcar '(lambda (x)
                                 (progn
                                    (setq n_dna (length x))
                                    (setq num_point (fix (rem (getvar "CPUTICKS") n_dna)))
                                    (list
                                          (append (pick x 0 (- num_point 1))
                                                   (list (- 1 (car (pick x num_point num_point))))
                                                   (pick x (+ 1 num_point) (- n_dna 1 ))
                                             )
                                       )
                                 )
                           )
                     poplst
                     )
      )
)
poplst
)

aimisiyou · 发表于 2018-2-9 01:03:13

本帖最后由 aimisiyou 于 2018-2-9 01:09 编辑

(setq poplst nil)
(repeat 100
  (setq plst (ff 20))
  (setq poplst (cons plst poplst))
)
(repeat 500
(progn
   (setq poplst (change (jiaocha (selct poplst))))
   (if (listp (car (car poplst)))
         (setq poplst (apply 'append (mapcar '(lambda (x) x) poplst)))
      )
;;;奇怪了没有if函数重复运行  poplst会出现(((0 0 1 1 1 1 1 1 1 0 1 0 1 1 0 1 0 0 1 1)) ((1 0 1 1 1 1 1 1 1 0 1 1 0 0 1 1 0 0 1 1)))情况，运行会出错
;;;为了消除运行故障，故加上if函数
   )
)

aimisiyou · 发表于 2018-2-9 02:06:59

(defun pf (plst DB DA a b)
(defun fenfun (s r)
  (cond
   ((and (= (car r) (car s))
         (= (cadr r) (cadr s))
         (= (caddr r) (caddr s))
         (= (cadddr r) (cadddr s))
      )
      (setq va nil)
   )
   ((and (<= (car r) (car s))
         (<= (cadr r) (cadr s))
         (< (car s) (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (< (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
      )
      (setq va (list
                     (list (car s) (+ (cadr r) (cadddr r)) (caddr s) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
                     (list (+ (car r) (caddr r)) (cadr s)  (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
               )
      )
   )
   ((and (= (car r) (car s))
         (< (cadr r) (cadr s))
         (< (caddr r) (caddr s))
         (< (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
      )
      (setq va (list
                     (list (car s) (+ (cadr r) (cadddr r)) (caddr s) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
                     (list (+ (car r) (caddr r)) (cadr s)  (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
               )
      )
   )
   ((and (< (car s ) (car r ) (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (< (cadr r) (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
      )
      (setq va (list
                     (list (car s) (cadr s) (- (car r)(car s)) (cadddr s) )
                     (list (car s) (+ (cadr r) (cadddr r)) (caddr s)  (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))))
                     (list (+ (car r) (caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
               )
      )
   )
   ((and (< (car s ) (car r ) (+ (car s) (caddr s)) )
         (<= (+ (car s) (caddr s)) (+ (car r) (caddr r)) )
         (< (cadr r) (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
      )
      (setq va (list
                     (list (car s) (cadr s) (- (car r) (car s))(cadddr s) )
                     (list (car s) (+ (cadr r) (cadddr r))  (caddr s)  (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))))
               )
      )
   )
   ((and (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)) )
         (<= (car r ) (car s ) )
         (< (car s)  (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (<= (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (+ (car r) (caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s) )
               )
      )
   )
   ((and (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)) )
         (< (car s ) (car r ) (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (< (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (cadr s ) (- (car r) (car s))(cadddr s) )
                     (list (+ (car r) (caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s) )
               )
      )
   )
   ((and (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)) )
         (< (car s ) (car r )  (+ (car s) (caddr s)))
         (<= (cadr s) (+ (car r) (caddr r)))
         (< (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (cadr s ) (- (car r) (car s))(cadddr s) )
               )
      )
   )
   ((and (< (car s ) (car r )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
         (< (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
         (= (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (cadr s ) (- (car r) (car s))(cadddr s) )
                     (list (car s ) (+ (cadr r)(cadddr r)) (caddr s)(- (cadddr s)(cadddr r)))
               )
      )
   )
   ((and (<= (car r ) (car s )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
         (< (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
         (= (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (+ (cadr r)(cadddr r)) (caddr s) (- (cadddr s)(cadddr r)))
               )
      )
   )
   ((and (< (car r ) (car s ) (+ (car r) (caddr r)) (+ (car s) (caddr s)) )
         (< (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
         (= (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (+ (cadr r)(cadddr r)) (caddr s) (- (cadddr s)(cadddr r)))
                     (list (+ (car r) (caddr r)) (cadr s ) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
               )
      )
   )
   ((and (< (car s ) (car r ) (+ (car s) (caddr s)) (+ (car r) (caddr r)) )
         (< (cadr s ) (cadr r ) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)) )
      )
      (setq va (list
                     (list (car s)(cadr s)(caddr s) (- (cadr r) (cadr s)) )
                     (list (car s)(cadr s) (- (car r) (car s)) (cadddr s))
                     (list (car s)(+ (cadr r) (cadddr r)) (caddr s ) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
               )
      )
   )
   ((and (<= (car r ) (car s) (+ (car s) (caddr s)) (+ (car r) (caddr r)) )
         (< (cadr s ) (cadr r ) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)) )
      )
      (setq va (list
                     (list (car s)(cadr s)(caddr s) (- (cadr r) (cadr s)) )
                     (list (car s)(+ (cadr r) (cadddr r)) (caddr s ) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
               )
      )
   )
   ((and (< (car r ) (car s ) (+ (car r) (caddr r)) (+ (car s) (caddr s)) )
         (< (cadr s ) (cadr r ) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)) )
      )
      (setq va (list
                     (list (car s)(cadr s)(caddr s) (- (cadr r) (cadr s)) )
                     (list (+ (car r)(caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
                     (list (car s)(+ (cadr r) (cadddr r)) (caddr s ) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
               )
      )
   )
   ((and (< (car s ) (car r )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
         (< (cadr s ) (cadr r ))
         (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)))
      )
      (setq va (list
                     (list (car s ) (cadr s )(- (car r) (car s))(cadddr s) )
                     (list (car s ) (cadr s )(caddr s)(- (cadr r) (cadr s)) )
               )
      )
   )
   ((and (<= (car r ) (car s )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
         (< (cadr s ) (cadr r ))
         (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)))
      )
      (setq va (list
                     (list (car s ) (cadr s )(caddr s)(- (cadr r) (cadr s)) )
               )
      )
   )
   ((and (< (car r ) (car s )  (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (< (cadr s ) (cadr r ))
         (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)))
      )
      (setq va (list
                     (list (car s ) (cadr s )(caddr s)(- (cadddr s) (cadddr r)) )
                     (list (+ (car r)(caddr r)) (cadr s) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) (cadddr s) )
               )
      )
   )
   (t (setq va (list s)))
)
)
(defun hefun (lst)
(setq i 0 vlst nil n (length lst) )
(while (< i n)
      (setq a (nth i lst) j 0 sum 0 flag t)
      (while (and flag (< j n))
         (setq b (nth j lst))
         (if (and (<= (car b)  (car a) )
                  (<= (cadr b) (cadr a))
                  (<= (+ (car a) (caddr a) ) (+ (car b) (caddr b) ))
                  (<= (+ (cadr a) (cadddr a) ) (+ (cadr b) (cadddr b) ))
            )
            (setq sum (+ 1 sum))
         )
         (setq j (+ j 1))
         (if (> sum 1) (setq flag nil))
      )
   (if flag (setq vlst (cons a vlst)))
   (setq i (+ i 1))
  )
  (reverse vlst)
)
(defun sortfun (juxlst)
(vl-sort juxlst
         '(lambda (a b)
                  (if  (= (cadr a) (cadr b))
                        (<= (car a) (car b))
                        (< (cadr a) (cadr b))
                     )
            )
)
)
(defun drawfun (pt slst)
(setq i 0 n (length slst) flag t)
(while (and flag (< i n))
         (setq sg (nth i slst))
         (if (and (<= (car pt) (caddr sg)) (<= (cadr pt) (cadddr sg)) )
            (progn
                  (setq flag nil)
                  (setq r (list (car sg) (cadr sg) (car pt) (cadr pt)) vlst nil)
                  (foreach a slst
                           (setq vlst (append  (fenfun a r) vlst))
                  )
                  (setq newslst (sortfun (hefun vlst )))
                  (entmake
                           (list
                              '(0 . "LWPOLYLINE")
                              '(100 . "AcDbEntity")
                              '(100 . "AcDbPolyline")
                              '(90 . 4)
                              '(70 . 1)
                              (cons 10 (list (car sg) (cadr sg)))
                              (cons 10 (list (+ (car sg) (car pt)) (cadr sg) ))
                              (cons 10 (list (+ (car sg) (car pt)) (+ (cadr sg) (cadr pt)) ))
                              (cons 10 (list (car sg) (+ (cadr sg) (cadr pt)) )  )
                              (cons 210 '(0 0 1))
                           )
                  )
            )
            (setq i (+ 1 i))
         )
)
  newslst
)
(defun ff (L a b flag)
(setq i 0 flst nil)
(while (<= (* a i) L)
         (setq flst (cons (list i (/ (- L (* i a)) b) (rem (- L (* i a)) b)) flst))
         (setq i (+ i 1))
)
(setq lst (vl-sort flst '(lambda (x y)  (<= (caddr x) (caddr y)) ) ) )
(setq nmin (caddr (car lst)))
(if flag
   (progn
         (setq flst (vl-remove-if-not '(lambda (x) (= (caddr x) nmin)) lst) )
         (setq flst (vl-sort flst '(lambda (x y) (> (car x) (car y)) ) ) )
         (setq va (car flst))
         (if (= (car va) 0)
            (progn
               (setq flst (vl-remove-if '(lambda (x) (= (caddr x) nmin)) lst))
               (setq nmin (caddr (car flst)))
               (setq flst (vl-remove-if-not '(lambda (x) (= (caddr x) nmin)) flst) )
               (setq flst (vl-sort flst '(lambda (x y) (> (car x) (car y)) ) ))
               (setq va (car flst))
            )
         )
      )
   (progn
         (setq lst (vl-remove-if-not '(lambda (x) (= (caddr x) nmin)) lst) )
         (setq lst (vl-sort lst '(lambda (x y) (> (car x) (car y)) ) ) )
         (setq va (car lst))
      )
   )
   va
)
  (setq slst (list (list 0 0  DB  DA)))
  (entmake
      (list
            '(0 . "LWPOLYLINE")
            '(100 . "AcDbEntity")
            '(100 . "AcDbPolyline")
            '(90 . 4)
            '(70 . 1)
            (cons 10 (list (car (car slst)) (cadr (car slst))))
            (cons 10 (list (+ (car (car slst)) (caddr (car slst))) (cadr (car slst)) ))
            (cons 10 (list (+ (car (car slst)) (caddr (car slst))) (+ (cadr (car slst)) (cadddr (car slst))) ))
            (cons 10 (list (car (car slst)) (+ (cadr (car slst)) (cadddr (car slst))) )  )
            (cons 210 '(0 0 1))
      )
  )
  (setq ptlst (mapcar '(lambda (x) (if (= x 0)
                                             (list a b)
                                             (list b a)
                                 )
                     )
                     (reverse plst)
            )
)
  (foreach bb ptlst
      (setq slst (drawfun bb slst))
  )
)

aimisiyou · 发表于 2018-2-9 08:20:44

本帖最后由 aimisiyou 于 2018-2-9 09:24 编辑

(defun rnd ()
  (*(rem (getvar "cputicks") 1e4) 1e-4)
)
(defun pick (lst i j)
(setq count (length lst) nc 0 picklst nil)
(while (<= nc j)
   (if (<= i nc)
         (setq picklst (cons (nth nc lst) picklst))
   )
   (setq nc (+ nc 1))
)
(reverse picklst)
)
(defun ff (n)
(setq lst '((0 5 1)(5 10 0)) vlst nil)
(repeat n
      (setq num (fix (rem (getvar "CPUTICKS") 11)))
      (setq vlst (cons (car (vl-remove nil (mapcar '(lambda (x) (if (<= (car x) num (cadr x)) (last x) nil)) lst))) vlst))
)
)

;;;选择函数
(defun selct (poplst)
(setq i 0 num  (length poplst) new_poplst nil d_sum 0 d_lst nil)
(setq fitlst (mapcar '(lambda (x) (fitfun x)) poplst))
(setq sum_fitlst (apply '+ fitlst))
(setq fitlst (mapcar '(lambda (x) (/ (* x 1.0) sum_fitlst)) fitlst))
(while (< i num)
      (setq l_sum (+ d_sum (nth i fitlst)))
      (setq d_lst (cons (list d_sum l_sum) d_lst))
      (setq d_sum  l_sum)
      (setq i (+ i 1))
)
(setq d_lst (reverse d_lst))
(repeat num
      (setq num_rnd (rnd))
      (setq new_poplst (cons
                           (nth (vl-position t (mapcar '(lambda (x) (if (and (<= (car x) num_rnd) (< num_rnd (cadr x)) ) t nil)) d_lst)) poplst)                                        new_poplst
                        )
      )
)
new_poplst
)

;;;交叉函数
(defun cross (poplst)
  (defun pick (lst i j)
   (setq count (length lst) nc 0 picklst nil)
   (while (<= nc j)
      (if (<= i nc)
         (setq picklst (cons (nth nc lst) picklst))
      )
   (setq nc (+ nc 1))
   )
   (reverse picklst)
  )
(defun twocross (tolst)
(setq me (car tolst))
(setq fe (cadr tolst))
(setq n_dna (length me))
(setq num_point (fix (rem (getvar "CPUTICKS") n_dna)))
(list
      (append (pick me 0 num_point) (pick fe (+ 1 num_point) (- n_dna 1 )))
      (append (pick fe 0 num_point) (pick me (+ 1 num_point) (- n_dna 1 )))
   )
  )
(defun cp (poplst) ;;;注意确保种群容量为偶数
(setq n_pop (length poplst))
(mapcar '(lambda (x y) (list x y)) (pick poplst 0 (/ (- n_pop 2) 2)) (pick poplst (/ n_pop  2) (- n_pop 1)))
  )
  (setq cp_poplst (cp poplst) num_cross 0.6 n_cross (rnd))          ;;;设定交叉概率为0.6
(if (< n_cross num_cross )
   (setq pbplst (apply 'append (mapcar '(lambda (x) (twocross  x)) cp_poplst)))
   (setq pbplst  poplst)
  )
  pbplst
)

;;;变异函数
(defun change (poplst)
(defun pick (lst i j)
   (setq count (length lst) nc 0 picklst nil)
   (while (<= nc j)
      (if (<= i nc)
         (setq picklst (cons (nth nc lst) picklst))
      )
      (setq nc (+ nc 1))
   )
   (reverse picklst)
)
  (setq num_change 0.05 n_change (rnd))    ;;;设定变异概率为0.05
  (if (< n_change num_change)
   (setq poplst  (mapcar '(lambda (x)
                                 (progn
                                    (setq n_dna (length x))
                                    (setq num_point (fix (rem (getvar "CPUTICKS") n_dna)))
                                    (list
                                          (append (pick x 0 (- num_point 1))
                                                   (list (- 1 (car (pick x num_point num_point))))
                                                   (pick x (+ 1 num_point) (- n_dna 1 ))
                                             )
                                       )
                                 )
                           )
                     poplst
                     )
      )
)
poplst
)

;;; 适应度函数
(defun fitfun (en)             ;;;en为个体，如en=(1 0 0 1 0 1 0 1 1)
   (apply '+ en)          ;;; 确定适应度函数
)

(defun gafun (n_length n_in n_ga)
   (setq poplst nil)
   (repeat n_in
         (setq plst (ff n_length))
         (setq poplst (cons plst poplst))
   )
   (setq fitlst (mapcar '(lambda (x) (fitfun x)) poplst))
   (setq p_best  (car (vl-sort (mapcar '(lambda (x y) (cons x y)) fitlst poplst)
                              '(lambda (e1 e2)  (> (car e1) (car e2)) )
                     )
                  )
   )
   (repeat n_ga
      (progn
            (setq poplst (change (cross (selct poplst))))
            (if (listp (car (car poplst)))
                  (setq poplst (apply 'append (mapcar '(lambda (x) x) poplst)))
               )
            (setq fitlst (mapcar '(lambda (x) (fitfun x)) poplst))
            (setq p_bestnew  (car (vl-sort (mapcar '(lambda (x y) (cons x y)) fitlst poplst)
                                          '(lambda (e1 e2)  (> (car e1) (car e2)) )
                                 )
                              )
               )
            (if (> (car p_bestnew) (car p_best) )
                  (setq  p_best p_bestnew)
               )
         )
   )
   p_best
)
_$ (gafun 20 100 50)
(20 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
_$

aimisiyou · 发表于 2018-2-9 09:32:03

_$ (gafun 50 100 50)
(43 1 1 0 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 0 1 1)
_$ (gafun 50 100 100)
(44 1 1 1 1 0 1 1 0 1 1 1 0 1 0 1 1 1 1 1 1 0 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
_$ (gafun 50 100 200)
(48 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
_$ (gafun 50 100 300)
(47 1 1 1 1 1 1 1 0 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1)
_$ (gafun 50 100 300)
(49 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
_$ (gafun 50 100 300)
(46 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0)
_$ (gafun 50 100 500)
(50 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
_$

可以看出增加遗传代数不一定离最优解靠近，适当同时增加种群容量和遗传代数，可得全局最优解。

aimisiyou · 发表于 2018-2-9 12:48:16

本帖最后由 aimisiyou 于 2018-2-9 12:53 编辑

(defun ff (n)
(setq lst '((0 5 1)(5 10 0)) vlst nil)
(repeat n
      (setq num (fix (rem (getvar "CPUTICKS") 11)))
      (setq vlst (cons (car (vl-remove nil (mapcar '(lambda (x) (if (<= (car x) num (cadr x)) (last x) nil)) lst))) vlst))
)
  )

(defun fenfun (s r)
  (cond
   ((and (= (car r) (car s))
         (= (cadr r) (cadr s))
         (= (caddr r) (caddr s))
         (= (cadddr r) (cadddr s))
      )
      (setq va nil)
   )
   ((and (<= (car r) (car s))
         (<= (cadr r) (cadr s))
         (< (car s) (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (< (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
      )
      (setq va (list
                     (list (car s) (+ (cadr r) (cadddr r)) (caddr s) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
                     (list (+ (car r) (caddr r)) (cadr s)  (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
               )
      )
   )
   ((and (= (car r) (car s))
         (< (cadr r) (cadr s))
         (< (caddr r) (caddr s))
         (< (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
      )
      (setq va (list
                     (list (car s) (+ (cadr r) (cadddr r)) (caddr s) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
                     (list (+ (car r) (caddr r)) (cadr s)  (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
               )
      )
   )
   ((and (< (car s ) (car r ) (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (< (cadr r) (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
      )
      (setq va (list
                     (list (car s) (cadr s) (- (car r)(car s)) (cadddr s) )
                     (list (car s) (+ (cadr r) (cadddr r)) (caddr s)  (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))))
                     (list (+ (car r) (caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
               )
      )
   )
   ((and (< (car s ) (car r ) (+ (car s) (caddr s)) )
         (<= (+ (car s) (caddr s)) (+ (car r) (caddr r)) )
         (< (cadr r) (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
      )
      (setq va (list
                     (list (car s) (cadr s) (- (car r) (car s))(cadddr s) )
                     (list (car s) (+ (cadr r) (cadddr r))  (caddr s)  (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))))
               )
      )
   )
   ((and (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)) )
         (<= (car r ) (car s ) )
         (< (car s)  (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (<= (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (+ (car r) (caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s) )
               )
      )
   )
   ((and (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)) )
         (< (car s ) (car r ) (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (< (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (cadr s ) (- (car r) (car s))(cadddr s) )
                     (list (+ (car r) (caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s) )
               )
      )
   )
   ((and (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)) )
         (< (car s ) (car r )  (+ (car s) (caddr s)))
         (<= (cadr s) (+ (car r) (caddr r)))
         (< (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (cadr s ) (- (car r) (car s))(cadddr s) )
               )
      )
   )
   ((and (< (car s ) (car r )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
         (< (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
         (= (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (cadr s ) (- (car r) (car s))(cadddr s) )
                     (list (car s ) (+ (cadr r)(cadddr r)) (caddr s)(- (cadddr s)(cadddr r)))
               )
      )
   )
   ((and (<= (car r ) (car s )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
         (< (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
         (= (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (+ (cadr r)(cadddr r)) (caddr s) (- (cadddr s)(cadddr r)))
               )
      )
   )
   ((and (< (car r ) (car s ) (+ (car r) (caddr r)) (+ (car s) (caddr s)) )
         (< (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
         (= (cadr r) (cadr s) )
      )
      (setq va (list
                     (list (car s ) (+ (cadr r)(cadddr r)) (caddr s) (- (cadddr s)(cadddr r)))
                     (list (+ (car r) (caddr r)) (cadr s ) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
               )
      )
   )
   ((and (< (car s ) (car r ) (+ (car s) (caddr s)) (+ (car r) (caddr r)) )
         (< (cadr s ) (cadr r ) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)) )
      )
      (setq va (list
                     (list (car s)(cadr s)(caddr s) (- (cadr r) (cadr s)) )
                     (list (car s)(cadr s) (- (car r) (car s)) (cadddr s))
                     (list (car s)(+ (cadr r) (cadddr r)) (caddr s ) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
               )
      )
   )
   ((and (<= (car r ) (car s) (+ (car s) (caddr s)) (+ (car r) (caddr r)) )
         (< (cadr s ) (cadr r ) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)) )
      )
      (setq va (list
                     (list (car s)(cadr s)(caddr s) (- (cadr r) (cadr s)) )
                     (list (car s)(+ (cadr r) (cadddr r)) (caddr s ) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
               )
      )
   )
   ((and (< (car r ) (car s ) (+ (car r) (caddr r)) (+ (car s) (caddr s)) )
         (< (cadr s ) (cadr r ) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)) )
      )
      (setq va (list
                     (list (car s)(cadr s)(caddr s) (- (cadr r) (cadr s)) )
                     (list (+ (car r)(caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
                     (list (car s)(+ (cadr r) (cadddr r)) (caddr s ) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
               )
      )
   )
   ((and (< (car s ) (car r )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
         (< (cadr s ) (cadr r ))
         (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)))
      )
      (setq va (list
                     (list (car s ) (cadr s )(- (car r) (car s))(cadddr s) )
                     (list (car s ) (cadr s )(caddr s)(- (cadr r) (cadr s)) )
               )
      )
   )
   ((and (<= (car r ) (car s )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
         (< (cadr s ) (cadr r ))
         (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)))
      )
      (setq va (list
                     (list (car s ) (cadr s )(caddr s)(- (cadr r) (cadr s)) )
               )
      )
   )
   ((and (< (car r ) (car s )  (+ (car r) (caddr r)) (+ (car s) (caddr s)))
         (< (cadr s ) (cadr r ))
         (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)))
      )
      (setq va (list
                     (list (car s ) (cadr s )(caddr s)(- (cadddr s) (cadddr r)) )
                     (list (+ (car r)(caddr r)) (cadr s) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) (cadddr s) )
               )
      )
   )
   (t (setq va (list s)))
  )
)
(defun hefun (lst)
(setq i 0 vlst nil n (length lst) )
(while (< i n)
      (setq a (nth i lst) j 0 sum 0 flag t)
      (while (and flag (< j n))
         (setq b (nth j lst))
         (if (and (<= (car b)  (car a) )
                  (<= (cadr b) (cadr a))
                  (<= (+ (car a) (caddr a) ) (+ (car b) (caddr b) ))
                  (<= (+ (cadr a) (cadddr a) ) (+ (cadr b) (cadddr b) ))
            )
            (setq sum (+ 1 sum))
         )
         (setq j (+ j 1))
         (if (> sum 1) (setq flag nil))
      )
   (if flag (setq vlst (cons a vlst)))
   (setq i (+ i 1))
  )
  (reverse vlst)
)
(defun sortfun (juxlst)
(vl-sort juxlst
         '(lambda (a b)
                  (if  (= (cadr a) (cadr b))
                        (<= (car a) (car b))
                        (< (cadr a) (cadr b))
                     )
            )
)
)

(defun drawfun (pt slst ifdraw)
(setq i 0 n (length slst) flag t)
(while (and flag (< i n))
         (setq sg (nth i slst))
         (if (and (<= (car pt) (caddr sg)) (<= (cadr pt) (cadddr sg)) )
            (progn
                  (setq flag nil)
                  (setq r (list (car sg) (cadr sg) (car pt) (cadr pt)) vlst nil)
                  (foreach a slst
                           (setq vlst (append  (fenfun a r) vlst))
                  )
                  (setq newslst (sortfun (hefun vlst )))
                                    (if ifdraw
                     (entmake
                           (list
                              '(0 . "LWPOLYLINE")
                              '(100 . "AcDbEntity")
                              '(100 . "AcDbPolyline")
                              '(90 . 4)
                              '(70 . 1)
                              (cons 10 (list (car sg) (cadr sg)))
                              (cons 10 (list (+ (car sg) (car pt)) (cadr sg) ))
                              (cons 10 (list (+ (car sg) (car pt)) (+ (cadr sg) (cadr pt)) ))
                              (cons 10 (list (car sg) (+ (cadr sg) (cadr pt)) )  )
                              (cons 210 '(0 0 1))
                           )
                                             )
                  )
                  (setq n_tol (+ n_tol 1))
            )
            (setq i (+ 1 i))
         )
)
  newslst
)

(defun fitfun (en)
  (setq DB 41 DA 44 a 10 b 7 n_tol 0 flag t)
  (setq slst (list (list 0 0 DB DA)))
  (if ifdraw
   (entmake
      (list
            '(0 . "LWPOLYLINE")
            '(100 . "AcDbEntity")
            '(100 . "AcDbPolyline")
            '(90 . 4)
            '(70 . 1)
            (cons 10 (list (car (car slst)) (cadr (car slst))))
            (cons 10 (list (+ (car (car slst)) (caddr (car slst))) (cadr (car slst)) ))
            (cons 10 (list (+ (car (car slst)) (caddr (car slst))) (+ (cadr (car slst)) (cadddr (car slst))) ))
            (cons 10 (list (car (car slst)) (+ (cadr (car slst)) (cadddr (car slst))) )  )
            (cons 210 '(0 0 1))
      )
   )
  )
  (setq ptlst (mapcar '(lambda (x) (if (= x 0)
                                             (list a b)
                                             (list b a)
                                 )
                     )
                     en
            )
)
  (foreach bb ptlst
         (setq slst (drawfun bb slst ifdraw))
)
n_tol
  ) (fitfun (ff (/ (* DB DA) (* a b))))

aimisiyou · 发表于 2018-6-20 23:02:30

转

遗传算法小生境技术简介https://blog.csdn.net/u013587472/article/details/34421457
2014年06月25日 10:45:58阅读数：3455

   生物学上，小生境是指特定环境下的一种组织结构。在自然界中，往往特征，形状相似的物种相聚在一起，并在同类中交配繁衍后代。在SGA 中，交配完全是随机的，在进化的后期，大量的个体集中于某一极值点上，在用遗传算法求解多峰值问题时，经常只能找到个别的几个最优值，甚至往往得到是局部最优解。利用小生境我们可以找到全部最优解。
   小生境技术就是将每一代个体划分为若干类，每个类中选出若干适应度较大的个体作为一个类的优秀代表组成一个群，再在种群中，以及不同种群中之间，杂交，变异产生新一代个体群。同时采用预选择机制和排挤机制或分享机制完成任务。基于这种小生境的遗传算法（Niched Genetic Algorithms，NGA），可以更好的保持解的多样性，同时具有很高的全局寻优能力和收敛速度，特别适合于复杂多峰函数的优化问题。
模拟小生境技术主要建立在常规选择操作的改进之上。Cavichio 在1970年提出了基于预选择机制的选择策略，其基本做法是：当新产生的子代个体的适应度超过其父代个体的适应度时，所产生的子代才能代替其父代而遗传到下一代群体中去，否则父代个体仍保留在下一代群体中。由于子代个体和父代个体之间编码结构的相似性，所以替换掉的只是一些编码结构相似的个体，故它能够有效的维持群体的多样性，并造就小生境的进化环境。De Jong在1975年提出基于排挤机制的选择策略，其基本思想源于在一个有限的生存环境中，各种不同的生物为了能够延续生存，他们之间必须相互竞争各种有限的生存资源。因此，在算法中设置一个排挤因子CF（一般取CF=2或3），由群体中随机选取的1/CF 个个体组成排挤成员，然后依据新产生的的个体与排挤成员的相似性来排挤一些与预排挤成员相类似的个体，个体之间的相似性可用个体编码之间的海明距离来度量。随着排挤过程的进行，群体中的个体逐渐被分类，从而形成一个个小的生成环境，并维持群体的多样性。
   Goldberg等在1987年提出了基于共享机制（Sharing）的小生境实现方法。这种实现方法的基本思想是：通过反映个体之间的相似程度的共享函数来调节群体中各个个体的适应度，从而在这以后的群体进化过程中，算法能够依据这个调整后的新适应度来进行选择运算，以维持群体的多样性，创造出小生境的进化环境。
   共享函数（Sharing Function）是表示群体中两个个体之间密切关系程度的一个函数，可记为S（d ）其中表示个体i和j之间的关系。例如，个体基因型之间的海明距离就可以为一种共享函数。这里，个体之间的密切程度主要体现为个体基因型的相似性或个体表现型的相似性上。当个体之间比较相似时，其共享函数值就比较大；反之，当个体之间不太相似时，其共享函数值比较小。
共享度是某个个体在群体中共享程度的一中度量，它定义为该个体与群体内其它各个个体之间的共享函数值之和，用S 表示：
S = （i=1，，M）
在计算出了群体中各个个体的共享度之后，依据下式来调整各个个体的适应度：
F （X）=F （X）/S （i=1，，M）
由于每个个体的遗传概率是由其适应度大小来控制的，所以这种调整适应度的方法就能够限制群体中个别个体的大量增加，从而维护了群体的多样性，并造就了一种小生境的进化环境。

下面介绍一个基于小生境概念的遗传算法。这个算法的基本思想是：首先两两比较群体中各个个体之间的距离，若这个距离在预先的距离L 之内的话，在比较两者之间的适应度大小，并对其中适应值较低的个体施加一个较强的罚函数，极大地降低其适应度，这样，对于在预先指定的某一距离L之内的两个个体，其中较差的个体经处理后其适应度变得更差，他在后面的进化过程被淘汰的概率就极大。也就是说，在距离L 内将只存在一个优良个体，从而既维护了群体的多样性，又使得各个个体之间保持一定的距离，并使得个体能够在整个约束的空间中分散开来，这样就实现了一种小生境遗传算法。

这个小生境算法的描述如下：

算法 NicheGA （1）设置进化代数计数器；随机生成M个初始群体P（t），并求出各个个体的适应度F （i=1，2，M）。（2）依据各个个体的适应度对其进行降序排列，记忆前N个个体（N<M）.(3) 选择算法。对群体P（t）进行比例选择运算，得到P （t）。（4）交叉选择。对选择的个体集合P （t）作单点交叉运算，得到P （t）。（5）变异运算。对P （t）作均匀变异运算，得到P （t）。（6）小生境淘汰运算。将第（5）步得到的M个个体和第（2）步所记忆的N个个体合并在一起，得到一个含有M+N 个个体的新群体；对着M+N个个体，按照下式得到两个个体x 和x 之间的海明距离：|| x - x ||= ( )当|| x - x ||<L时，比较个体x 和个体x 的适应度大小，并对其中适应度较低的个体处以罚函数： Fmin(x ，x )=Penalty（7）依据这M+N个个体的新适应度对各个个体进行降序排列，记忆前N个个体。（8）终止条件判断。若不满足终止条件，则：更新进化代数记忆器t t+1，并将第（7）步排列中的前M个个体作为新的下一代群体P(t),然后转到第（3）步：若满足终止条件，则：输出计算结果，算法结束。

[例] Shubert 函数的全局最优化计算。
min f(x , x )={ } { }
s.t. -10 x 10（i=1，2）
上述函数共有760个局部最优点，其中有18个是全局最优点，全局最优点处的目标函数值是f （x ， x ）=-186.731。
用上述小生境遗传算法求解该例题时，可用下式进行目标函数值到个体适应度的变换处理：
F（x ， x ）=
L=202（二进制编码串长度，其中每个变量用10位二进制编码来表示）
M=50
T=500
p =0.1
p =0.1
L=0.5(小生境之间的距离参数)
Penlty=10 （罚函数）
使用上述参数进行了50次，试算，每次都可得到许多全局最优解下表为其中一次运算所得到的最好的18个个体。从该表可以看出，从小生境的角度来数，该算法得到了一个较好的结果。上述算法的特点保证了在一个函数峰内只存在一个较优的个体，这样每一个函数峰就是一个小生境。
基于小生境遗传算法的Shubert函数优化算法计算结果
个体标号  x x f（x ， x ）
1  5.4828  4.8581  -186.731
2  5.4830  -7.7083 -186.731
3  4.8581  5.4831 -186.731
4  4.8581  -7.0838  -186.731
5  -4.4252  -7.4983  -186.731
6  -7.0832  -7.0838  -186.731
7  5.4827  -1.4249  -186.731
8  0.8580  5.4831  -186.731
9  4.8580  -0.8009  -186.730
10  -0.8009  -7.7084  -186.730
11  -0.8009  4.8581  -186.730
12  -7.7088  -0.7999  -186.730
13  -7.7088  -7.0831  -186.730
14  -1.4256  -0.8009  -186.730
15  -0.8011  -1.4252  -186.730
16  -7.7075  5.4834  -186.730
17  -7.7088  4.8579  -186.730
18  -7.0825  -1.4249  -186.730
下面再介绍一种隔离小生境技术的遗传算法
　隔离小生境技术的基本概念及进化策略依照自然界的地理隔离技术,将遗传算法的初始群体分为几个子群体,子群体之间独立进化,各个子群体的进化快慢及规模取决于各个子群体的平均适应水平.由于隔离后的子群体彼此独立,界限分明,可以对各个子群体的进化过程灵活控制。生物界中,竞争不仅存在于个体之间,种群作为整体同样存在着竞争,适者生存的法则在种群这一层次上同样适用.在基于隔离的小生境技术中,是通过将种群的规模同种群个体平均适应值相联系来实现优胜劣汰、适者生存这一机制的.子群体平均适应值高,则其群体规模就大,反之,群体规模就小.生物界在进化过程中,适应环境的物种能得到更多的繁殖机会,其后代不断地增多,但这种增加不是无限制的,否则就会引起生态环境的失衡.在遗传算法中,群体的总体规模是一定的,为了保证群体中物种的多样性,就必须限制某些子群体的规模,称子群体中所允许的最大规模为子群体最大允许规模(maximum allowed scale),记为S .生物界中同样会出现某些物种因不适应环境数量逐渐减少,直至灭绝的现象.在隔离小生境机制中,为了保持群体的多样性,有时需要有意识地保护某些子群体,使之不会过早地被淘汰,并保持一定的进化能力.子群体的进化能力是和子群体的规模相联系的,要保证子群体的进化能力,必须规定每一子群体生存的最小规模,称为子群体最小生存规模(minimum live scale),记为S .在群体进化过程中,如果某一子群体在规定的代数内,持续表现最差,应该使这个子**,代之以搜索空间的新解,这一最劣子**的机制,定义为劣种不活(the worst die).子群体在进化过程中,如果出现两个子群体相似或相同的现象,则去掉其中的一个,代之以搜索空间的新解,这种策略称为同种互斥或种内竞争(intraspecific competition).解群中出现的新的子群体,在进化的初期往往无法同已经得到进化的其它子群体相竞争,如果不对此施加保护,这些新解往往在进化的初期就被淘汰掉,这显然是我们所不希望的.为了解决这个问题,必须对新产生的解加以保护,这种保护新解的策略叫幼弱保护(immature protection).子群体在进化过程中,如果收敛到或接近局部最优解,会出现进化停滞的现象,此时应当以某种概率将该子群体去掉,代之以搜索空间的新解,此种策略称为新老更替(the new superseding the old).在进化过程中,表现最优的个体进化为最优解的概率最大,应当使它充分进化,故新老更替策略不能用于最优子群体,这种做法称为优种保留(the best live).优种保留可以作用于最好的一个子群体,也可以作用于最好的几个子群体.
基于隔离小生境技术的遗传算法步骤
1)编码:针对具体问题,选择合适的编码方案,完成问题解空间向遗传算法解空间的转化.
2)产生初始群体:随机产生N个初始个体.
3)初始群体隔离:将N个初始个体均分给K个子群体,每个子群体含有的个体数均为N/K.
4)计算适应值:计算群体中所有个体的适应值.并保存适应值最高的个体.
5)确定子群体规模:子群体的规模同子群体的平均适应值相关,子群体的平均适应值越大,其在下一代中拥有的个体就越多;反之,在下一代中拥有的个体就少.但数目必须满足最大允许规模和最小保护规模的限制,即第t+1代第k个子群体的规模n (t+1)满足S ≤n (t+1) ≤S .
确定子群体规模的具体方法如下,首先给每个子群体都预分配S 个个体,剩下的个体根据子群体的平均适应值利用赌轮法选择,直到总的群体数量达到N为止.子群体的平均适应值一般可简单取为f (t)= (1)
式中f (t)为t代第k个子群体的平均适应值;f (t)为t代第k个子群体中第i个个体的适应值; n (t+1)为t代第k个子群体的规模.子群体k第t+1代的规模n (t+1)为：　　
n (t+1)=N . f (t)/ （2）
子群体规模的确定也可以根据其平均适应水平用赌轮法确定.
6)保护解除判定:对群体中施加保护的群体,进行保护解除判定,对满足保护解除条件的,撤除保护.
7)劣种不活判定:对解群中没有保护而连续几代表现又最差的群体,予以剔除并产生等规模的新子群体.
8)同种互斥判定:随机挑选出两个子群体,依据某种原则判定其相似程度,对满足相似条件的两个子群体,去掉其中的一个,产生同等规模的新解.
9)新老更替判定:判定解群中是否存在已经进化停滞的子群体,如果有,进行新老更替,产生同等规模的新解,但对包含最优个体的子群体要保留(最优保留机制).
10)重新计算适应值:对新产生的子群体计算适应性值,并施加幼弱保护措施.
11)子群体进化:由于子群体的规模同其在群体中的平均表现水平相联系,故子群体的规模是不断变化的.
根据公式(2)确定的规模,选择出子群体的繁殖个体,利用交叉和变异算子产生下一代解群.
12)收敛性判定,如果满足收敛性条件,或已经进化了规定的代数,则结束进化过程;否则返回第4步。
除了上面的还有下面几种常用的的小生境算法：
1 确定性拥挤算法
确定性拥挤（Deterministic crowding, DC）算法由Mahfoud 提出。该算法属于拥挤算法范畴，采用子个体与父个体直接进行竞争的模式，竞争的内容包括适应值和个体之间的距离。算法的过程如下：
确定性拥挤算法（重复G 代）
重复下列步骤N/2次：
（1）用放回的方式随机选择两个父个体p 和p 。
（2）对其进行杂交和变异，产生两个个体c 和c 。
（3）如果[d(p ，c )+d(p ，c )] [d(p ，c )+d(p ，c )]，则
如果f（c ）>f（p ）,则用c 代替p ，否则保留p 。
如果f（c ）>f（p ），则用c 替换p ，否则保留p 。
如果f（c ）>f（p ），则用c 替换p ，否则保留p 。
如果f（c ）>f（p ），则用c 替换p ，否则保留p 。
其中，N 是种群规模，的d（i，j）是个体i 和个体j 之间的距离。
2 限制锦标赛算法
限制锦标赛选择（Restricted tournament selection RTS）算法由Harik 提出。该算法属于拥挤算法范畴，采用了个体与种群中其它个体进行竞争的模式，竞争的内容包括适应值和个体之间的距离。该算法的过程如下：
限制锦标赛算法（重复G代）
重复下列步骤N/2次：
（1）  用有放回的方式随机选择两个父个体p 和p 。
（2）  对其进行杂夹和变异，产生两个子个体c 和才c 。
（3）  分别为c 和c从当前的种群中随机的选择出w个个体。
（4）不失一般性，设d 和d 分别是w个个体的中与c 和c 距离最近的两个个体。
（5）如果f（c ）>f（d ），则用c 替d 换，否则保留d 。
如果f（c ）>f（d ），则用c 替换d ，否则保留d 。
3多小生境拥挤算法
多小生境拥挤算法（Multi-niche crowding，MNC）由Cedeno提出。该算法属拥挤算法的范畴，采用种群中的若干个体相互竞争的模式，竞争的内容包括适应值和个体之间的距离。竞争选择出的老个体被新个体产生的子个体替换。算法的过程如下：
多小生境拥挤算法（重复G 代）
重复下列步骤N/2次：
（1）  用有放回的方式随机选父个体p 。
（2）  从种群中随机选择C 个体作为p 的交配候选集，从中选出与p 最接近的个体p 。
（3）  对p 和p 进行杂交和变异，产生两个个体c 和c 。
（4）  分别为c 和c 从中当前种群中各随机选择出C 群个体，每群个体包含w个个体。
（5）  每一群个体都选出一个与对应字个体距离最近的个体。这样就为每个个体产生了C 个替换候选个体。
（6）  不失一般性，设d 和d 是两个替换候选集中适应值最低的个体。
（7）  用c 替换d ，用c 替换d 。
Cedeno 还给出了C ，w和C 的最优参数值。C 应该在区间[2，4]内，C 和w至少应该两倍于用户希望找到的全局峰个数。该算法的步骤2提出了一中基于试探性的方法的限制交配策略。
4 标准适应值共享算法
标准适应值共享算法（Standard fitness sharing SH）由Goldberg 和Richardson 提出。该算法属于适应值共享算法范畴，事先需要给出解空间中小生境的半径，并假设解空间中峰半径均相同。算法的过程如下：
标准的适应值共享算法（重复G 代）
（1）  计算种群中个体之间的共享函数值sh（d ）
sh（d ）=
其中，是事先给出的峰半径，d 是个体i和个体j之间的距离，是控制共享函数形状的参数，一般取 =1（线形共享函数）。两个个体之间共享函数值越大，则两个个体越接近。
（2）  计算种群中个体的小生境数m
m =
其中，N 是种群规模。个体的小生境数越大，则该个体周围绕着越多其它个体。
（3）  计算种群中个体共享后的适应值f
f =f / m
（4）  用个体共享后的适应值进行选择，杂交和变异出新的个体，生成新一代种群。
Deb和Goldberg 在假设解空间中峰均匀分布并且峰半径相同的前提下，提出计算峰半径的计算公式。此外它们还提供了一种基于峰半径的限制交配策略，从而保证所有的杂交均在同一物种进行，确保了后代和父母的均属于同一小生境。标准适应值共享算法计算距离的时间复杂度为O（N ）。
5 清除算法
清除（Clearing）算法由Petrowski 提出。该算法属于适应值共性算法范畴，事先需要给出解空间的小生境半径（重要参数）和小生境的容量（次要参数），并假设解空间中峰值半径均相同。算法的过程如下：
清除算法（G）
（1）  按照适应值对个体进行降序排列。
（2）  将第一个体指定为第一个小生境中心。
（3）  从第二个个体开始顺序执行下列步骤到最后一个个体：
（3.1）如果当前个体到所有已指定小生境中心的距离均大于，则该个体被指定为一个新的小生境中心。该个成为优胜者。
（3.2）如果当前个体到某个已指定的小生境中心的距离小于，并且该小生境个数小于，则该个体加入到该小生境中去，该小生境的个体总数增加1。该个体成为优胜者。
（3.3）其它个体均为失败者。
（3.4）维持所有优胜者的适应度不变，将所有失败者的适应值置为0。
（4）用个体修改后的适应值进行选择，杂交和变异出新个体，生成新一代种群。
清除算法计算距离的时间复杂度为O（kN），其中k是该算法维持的小生境数量。如果将优胜者的小生境数看为一，而将失败者的小生境看作无穷大，则清除算法也可看作标准适应值共享算法的改进。
6 结合适应值共享的自适应k均值聚类算法
结合适应值共享的自适应算法k均值聚类算法（Adaptive k-mean clustering with fitness sharing）算法由Yin 和German提出。该算法属于适应值共性算法范畴，事先需要给出解空间中小生境中新建的最小距离和小生境中的个体到该小生境中心之间的最大距离。解空间中峰半径可能不相同。算法的过程如下：结合适应值共享的自适应k均值均类算法（重复G代）
（1）  按照适应值对个体进行降序排列。
（2）产生在[1，N]之间的随机整数k（初始小生境个数）。
（3）  将前k个个体分别放入不同的小生境中并成为小生境中心。确保所有小生境中心间距离大于，如果不能满足这一条件，则合并小生境，新的小生境中心就是该小生境中所有个体的中心。
（4）  对于其它N-k个个体中的每一个，计算其与当前所有想生境中心之间的距离。如果距离大于，则生成新的小生境，该个体成为新小生境的中心。否则将该个体安排到距离最近的小生境中去。据需要确保所有小生境中心间的距离均大于，如果不能满足这一条件，则需要合并小生境。
（5）  所有个体均被安置完毕后，固定小生境的中心，将所有个体按照最小
距离原则安排到最近的小生境中去。
（6）  计算计算种群个体的小生境数m
m =n - n （d /2 ）若x C
其中，n 是第c个小生境中包含个个体总数，d 是个体i与它归属的小生境中心之间的距离，x 是第i个个体，C 第c 个小生境的个体基，是控制函数形状的参数，通常 =1。
（7）  用公式计算个体共享后的适应值。
（8）  用个体共享后的适应值进行选择，杂交和变异出新的个体，生成新一代个体种群。
结合适应值共享的自适应性k均值聚类算法计算距离的时间复杂度为O（Kn）。
7 动态小生境共享算法
动态小生境共享算方法（Dynamic niche sharing）是由Miller和Shaw 提出。该算法属于适应值共享算法范畴，事先需要给出解空间中小生境的半径和小生境的数量k。算法的过程如下；
动态小生境共享算法（重复G代）
（1）  按照适应值对个体进行降序排列。
（2）  将第一个个体指定为第一个小生境中心。
（3）  从第二个个体开始顺序执行下列步骤到最后一个个体：
（3.1）如果当前个体与所有已指定的小生境中心之间的距离大于，而且已指定的小生境数量小于k，则形成一个新的小生境，该个体成为新小生境的中心。
（3.2）如果当前个体与所有小生境中心之间的距离均大于，而且已指定的小生境数量不小于k，则该个体成为独立个体。
（4）对于那些属于某个小生境的个体，其小生境数就是它所属的小生境中个体的数量。对于那些独立个体，采用公式计算小生境数。
（5）用公式计算个体共享后的适应值。
（6）用共享后的适应值进行选择，杂交和变异出新的个体，生成新一代种群。动态小生境共享算法计算距离的时间复杂度为O（Kn）。
8 自适应小生境算法
自适应小生境算法（Adaptive nicking）由Goldberg 和 Wang 提出。该算法属于适应值共享算法范畴，事先需要给出解空间中小生境的半径和小生境的数量k。算法包含两个分别被称为顾客和商家的个体群，利用这两个个体群的共同演化实现多峰优化的目的。顾客群类似于其它适应值共享算法中的种群，而商家群则代表搜索空间中峰的集合。商家群的个体数量k略大于其它适应值共享算法中的小生境树立功能。顾客群中的个体的适应值与其它适应值共享算法中个体的适应值相同，而商家群中的个体的适应值是属于该商家所有顾客的适应值之和。
算法需要首先在搜索空间中随机放置商家群的个体，其余的过程如下；
自适应小生境算法（重复G 代）
（1）  将每一个顾客群中的个体都安排到最近的商家中去。
（2）  计算所有顾客的小生境数（其归属的商家所拥有的顾客数量）。
（3）  用公式计算顾客群的个体共享后的适应值。
（4）  用顾客群中个体共享后的适应值尽心选择，杂交和变异出新的个体，生成新一代顾客群。
（5）  顺序选择每一个商家群中的个体并对其进行变异操作以产生新的商家。如果新商家的适应值比老商家的适应高，而且与其它商家之间的距离均小于，则新商家代替老商家。否则进行另外一次变异操作，直到产生可以替换的新商家或变异操作的次数超过指定的最大变异为止。
自适应小生境算法计算距离的时间的复杂度为O(Kn).

账号		自动登录	找回密码
密码			立即注册

[研讨] 遗传算法