采用遗传算法求单一规格矩形下料问题

aimisiyou

qqqincccken 发表于 2018-2-13 09:45

一言难尽？

pengfei2010

aimisiyou 发表于 2018-2-13 11:32

有两个问题，第一，只能排单一矩形料 吗？第二，速度太慢了点，有点 接受不了了

aimisiyou

pengfei2010 发表于 2018-3-8 10:44

问题一：这只是用遗传算法来实现单一规格情形，当然对于多种规格的情形用遗传算法也能实现，只是部分代码要做修改；
问题二：虽然还可以做些优化，但总体运行效率肯定不高，与其他语言运行效率不可比。

总之，本来是想在论坛搜遗传算法的实例，但寥寥无几，于是自己就照猫画虎的写了这个拙作，仅供算法参考。

aimisiyou

为了加速收敛，可采取以下措施：
   (setq fitlst (mapcar '(lambda (x) (fitfun x)) poplst))
   (setq ffitlst (mapcar '(lambda (x) (apply '+ (mapcar '(lambda (y) (/ x 1.0 y))  fitlst))) fitlst))
   (setq sum_fitlst (apply '+ ffitlst))
   (setq fitlst (mapcar '(lambda (x) (/ (* x 1.0) sum_fitlst)) ffitlst))

aimisiyou

(defun fitfun (en)               ;;;en为个体，如en=(1 0 0 1 0 1 0 1 1)
       (apply '+ en)              ;;; 确定适应度函数         
)
(defun distfun (poplst)
    (mapcar '(lambda (x) (apply '+ (mapcar '(lambda (y) (apply '+ (mapcar '(lambda (a b) (abs (+ a b -1.0))) x y))) poplst)))  poplst)
  )
(setq poplst '((1 0 1 1)(1 0 0 1)(0 1 0 1)(0 0 0 1)(1 0 1 0)))
(setq fitlst (mapcar '(lambda (x) (fitfun x)) poplst))
(setq ffitlst (mapcar '(lambda (a b) (/ a b)) fitlst (distfun poplst)))
(setq sum_fitlst (apply '+ ffitlst))
(setq fitlst (mapcar '(lambda (x) (/ (* x 1.0) sum_fitlst)) ffitlst))

aimisiyou

aimisiyou 发表于 2018-2-11 22:31
命令: tt
请输入母材短边DB长度=:69
请输入母材长边DA长度=:77

;;;找到原因了。
;;;前面第二行应设置(setq  newslst slst)
(defun drawfun (pt slst)
   (setq i 0 n (length slst) flag t newslst slst )
   (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
)

aimisiyou

根据小生境技术，首先要确定小生境个数和半径。先假定小生境半径为r=DA*DB/(a*b)-max{(DA/a)*(DB/b),(DA/b)*(DB/a)}。初始种群根据小生境半径划分为多个小生境，每个小生境中的个体按适应值大小进行淘汰，保留最优个体，即保留多个区域的峰值，然后进行遗传运算，保留种群的多样性，避免早熟趋于其中一个极值点，最后获得也是多个极值点（包含最大极值点）。小生境半径定得过大，会漏掉其中一些峰值；定得过小，会大大增加运算量。

aimisiyou

根据小生境半径和海明距离将初始种群划分为多个小生境。
(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))
    )
)
(setq poplst nil)
(repeat 20
  (setq plst (ff 10))
  (setq poplst (cons plst poplst))
)
FF
nil
((0 1 1 0 1 1 1 1 1 1) (1 1 0 1 1 1 0 1 1 0) (0 1 1 1 1 1 1 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 1 1 0 0 0 0) (0 0 1 1 1 1 0 0 1 0) (1 0 1 0 0 1 1 0 1 1) (1 0 0 1 1 0 1 0 1 1) (1 1 1 1 1 1 1 1 0 1) (1 1 1 1 0 1 1 0 1 1) (0 1 1 1 1 0 1 0 0 0) (1 0 1 0 1 0 1 1 0 1) (0 1 1 1 0 1 1 1 0 0) (1 1 0 0 1 1 0 1 1 0) (1 1 1 1 1 0 1 1 1 0) (1 0 1 0 0 1 1 1 1 1) (1 1 0 0 0 1 1 1 1 0) (1 0 0 0 1 1 1 1 1 1) (1 0 0 1 1 0 1 1 0 1))
_$

定义r=3,将poplst按小生境半径r进行划分多个小生境。

aimisiyou

_$  (defun ff (r lst)
   (if (< (length lst) 2)
       (if (= (length lst) 1)
           (setq va (list lst))
           (setq va lst)
        )
       (progn
            (if (= (length  lst) 2)
                (if (<= (abs (- (cadr lst) (car lst)))  r )
                     (setq va (list lst))
                     (setq va (list (list (car lst)) (list (cadr lst))))
                )
                (progn
                      (setq lst1 (list (car lst))  lst2 nil)
                      (mapcar '(lambda (x)
                                    (if (<= (abs (- x (car lst))) r)
                                         (setq lst1 (cons x lst1))
                                         (setq lst2 (cons x lst2))
                                     )
                               )  
                               (cdr lst)
                       )   
                       (setq va (cons (reverse lst1) (ff r (reverse lst2))))
                  )
             )
        )
   )
)
FF
_$  (ff 3 '(3 7 5 9 11 13 21 18 19))
((3 5) (7 9) (11 13) (21 18 19))
_$ (ff 5 '(3 7 5 9 11 13 21 18 19))
((3 7 5) (9 11 13) (21 18 19))
_$ (ff 7 '(3 7 5 9 11 13 21 18 19))
((3 7 5 9) (11 13 18) (21 19))
_$  (ff 8 '(3 7 5 9 11 13 21 18 19))
((3 7 5 9 11) (13 21 18 19))
_$

aimisiyou

_$ (defun hmdis (ea eb)
   (apply '+ (mapcar '(lambda (x y) (boole 6 x y)) ea eb))
)
(defun xsfun (r lst)
   (if (< (length lst) 2)
       (if (= (length lst) 1)
           (setq va (list lst))
           (setq va lst)
        )
       (progn
            (if (= (length  lst) 2)
                (if (<= (hmdis (cadr lst) (car lst))  r )
                     (setq va (list lst))
                     (setq va (list (list (car lst)) (list (cadr lst))))
                )
                (progn
                      (setq lst1 (list (car lst))  lst2 nil)
                      (mapcar '(lambda (x)
                                    (if (<= (hmdis  x (car lst)) r)
                                         (setq lst1 (cons x lst1))
                                         (setq lst2 (cons x lst2))
                                     )
                               )  
                               (cdr lst)
                       )   
                       (setq va (cons (reverse lst1) (xsfun r (reverse lst2))))
                  )
             )
        )
   )
)
HMDIS
XSFUN
_$ (xsfun 5 '((0 1 1 0 1 1 1 1 1 1) (1 1 0 1 1 1 0 1 1 0) (0 1 1 1 1 1 1 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 1 1 0 0 0 0) (0 0 1 1 1 1 0 0 1 0) (1 0 1 0 0 1 1 0 1 1) (1 0 0 1 1 0 1 0 1 1) (1 1 1 1 1 1 1 1 0 1) (1 1 1 1 0 1 1 0 1 1) (0 1 1 1 1 0 1 0 0 0) (1 0 1 0 1 0 1 1 0 1) (0 1 1 1 0 1 1 1 0 0) (1 1 0 0 1 1 0 1 1 0) (1 1 1 1 1 0 1 1 1 0) (1 0 1 0 0 1 1 1 1 1) (1 1 0 0 0 1 1 1 1 0) (1 0 0 0 1 1 1 1 1 1) (1 0 0 1 1 0 1 1 0 1)))
(((0 1 1 0 1 1 1 1 1 1) (1 1 0 1 1 1 0 1 1 0) (0 1 1 1 1 1 1 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 1 1 0 0 0 0) (0 0 1 1 1 1 0 0 1 0) (1 0 1 0 0 1 1 0 1 1) (1 1 1 1 1 1 1 1 0 1) (1 1 1 1 0 1 1 0 1 1) (0 1 1 1 1 0 1 0 0 0) (1 0 1 0 1 0 1 1 0 1) (0 1 1 1 0 1 1 1 0 0) (1 1 0 0 1 1 0 1 1 0) (1 1 1 1 1 0 1 1 1 0) (1 0 1 0 0 1 1 1 1 1) (1 1 0 0 0 1 1 1 1 0) (1 0 0 0 1 1 1 1 1 1)) ((1 0 0 1 1 0 1 0 1 1) (1 0 0 1 1 0 1 1 0 1)))
_$
_$  (xsfun 3 '((0 1 1 0 1 1 1 1 1 1) (1 1 0 1 1 1 0 1 1 0) (0 1 1 1 1 1 1 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 1 1 0 0 0 0) (0 0 1 1 1 1 0 0 1 0) (1 0 1 0 0 1 1 0 1 1) (1 0 0 1 1 0 1 0 1 1) (1 1 1 1 1 1 1 1 0 1) (1 1 1 1 0 1 1 0 1 1) (0 1 1 1 1 0 1 0 0 0) (1 0 1 0 1 0 1 1 0 1) (0 1 1 1 0 1 1 1 0 0) (1 1 0 0 1 1 0 1 1 0) (1 1 1 1 1 0 1 1 1 0) (1 0 1 0 0 1 1 1 1 1) (1 1 0 0 0 1 1 1 1 0) (1 0 0 0 1 1 1 1 1 1) (1 0 0 1 1 0 1 1 0 1)))

(((0 1 1 0 1 1 1 1 1 1) (0 1 1 1 1 1 1 1 0 1) (1 1 1 1 1 1 1 1 0 1) (1 0 1 0 0 1 1 1 1 1) (1 0 0 0 1 1 1 1 1 1)) ((1 1 0 1 1 1 0 1 1 0) (1 1 0 0 1 1 0 1 1 0) (1 1 1 1 1 0 1 1 1 0) (1 1 0 0 0 1 1 1 1 0)) ((0 1 0 0 0 0 0 1 0 1) (0 1 0 0 0 0 0 1 0 1)) ((0 1 0 0 1 1 0 0 0 0)) ((0 0 1 1 1 1 0 0 1 0)) ((1 0 1 0 0 1 1 0 1 1) (1 1 1 1 0 1 1 0 1 1)) ((1 0 0 1 1 0 1 0 1 1) (1 0 0 1 1 0 1 1 0 1)) ((0 1 1 1 1 0 1 0 0 0) (0 1 1 1 0 1 1 1 0 0)) ((1 0 1 0 1 0 1 1 0 1)))
_$

aimisiyou

接着对每个小生境中的个体取适应值最大的个体（仅存在一个时），若适应值最大个体存在多个，则选取其中共享适应度最大的个体（因为它周边的未知区域较大，而共享适应度较低的个体周边已知个体较多，我们更关心未知区域），这样做一方面是保存各区域峰值的精英保留策略，另一方面是加快未知区域的探索。如图，第一个小生境内取B点的个体，第二个小生境内取C点的个体。

aimisiyou

(defun fitfun (en)               ;;;en为个体，如en=(1 0 0 1 0 1 0 1 1)
       (apply '+ en)              ;;; 确定适应度函数         
)
(defun xshig (poplst)
   (setq firfitlst (vl-sort (mapcar '(lambda (x) (cons (fitfun x) x)) poplst) '(lambda (e1 e2)(> (car e1) (car e2)) )  ))  
   (setq vamax (car (car firfitlst)) )
   (setq vamaxlst (vl-remove nil (mapcar '(lambda (x) (if (= vamax (car x)) (cdr x))) firfitlst) ))
   (if (= (length vamaxlst) 1)
       (setq va (car  vamaxlst))
       (progn
            (setq lasfitlst (vl-sort
                                           (mapcar 'cons (mapcar '(lambda (x) (apply '+ (mapcar '(lambda (y) (apply '+ (mapcar '(lambda (a b) (abs (+ a b -1.0))) x y))) poplst)))  vamaxlst)  vamaxlst )                                  
                                                                '(lambda (e1 e2) (> (car e1) (car e2)) )
                              )
                        )  
          (setq  va  (cdr (car lasfitlst)))
        )
     )
)
(setq poplst '((0 1 1 0 1 1 1 1 1 1) (1 1 0 1 1 1 0 1 1 0) (0 1 1 1 1 1 1 1 1 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 1 1 0 0 0 0) (0 0 1 1 1 1 0 0 1 0) (1 0 1 0 0 1 1 0 1 1) (1 1 1 1 1 1 1 1 0 1) (1 1 1 1 0 1 1 0 1 1) (0 1 1 1 1 0 1 0 0 0) (1 0 1 0 1 0 1 1 0 1) (0 1 1 1 0 1 1 1 0 0) (1 1 0 0 1 1 0 1 1 0) (1 1 1 1 1 0 1 1 1 0) (1 0 1 0 0 1 1 1 1 1) (1 1 0 0 0 1 1 1 1 0) (1 0 0 0 1 1 1 1 1 1)) )
(xshig poplst)
FITFUN
XSHIG
((0 1 1 0 1 1 1 1 1 1) (1 1 0 1 1 1 0 1 1 0) (0 1 1 1 1 1 1 1 1 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 1 1 0 0 0 0) (0 0 1 1 1 1 0 0 1 0) (1 0 1 0 0 1 1 0 1 1) (1 1 1 1 1 1 1 1 0 1) (1 1 1 1 0 1 1 0 1 1) (0 1 1 1 1 0 1 0 0 0) (1 0 1 0 1 0 1 1 0 1) (0 1 1 1 0 1 1 1 0 0) (1 1 0 0 1 1 0 1 1 0) (1 1 1 1 1 0 1 1 1 0) (1 0 1 0 0 1 1 1 1 1) (1 1 0 0 0 1 1 1 1 0) (1 0 0 0 1 1 1 1 1 1))
(0 1 1 1 1 1 1 1 1 1)
_$

aimisiyou

(setq poplst '(((0 1 1 0 1 1 1 1 1 1) (0 1 1 1 1 1 1 1 0 1) (1 1 1 1 1 1 1 1 0 1) (1 0 1 0 0 1 1 1 1 1) (1 0 0 0 1 1 1 1 1 1)) ((1 1 0 1 1 1 0 1 1 0) (1 1 0 0 1 1 0 1 1 0) (1 1 1 1 1 0 1 1 1 0) (1 1 0 0 0 1 1 1 1 0)) ((0 1 0 0 0 0 0 1 0 1) (0 1 0 0 0 0 0 1 0 1)) ((0 1 0 0 1 1 0 0 0 0)) ((0 0 1 1 1 1 0 0 1 0)) ((1 0 1 0 0 1 1 0 1 1) (1 1 1 1 0 1 1 0 1 1)) ((1 0 0 1 1 0 1 0 1 1) (1 0 0 1 1 0 1 1 0 1)) ((0 1 1 1 1 0 1 0 0 0) (0 1 1 1 0 1 1 1 0 0)) ((1 0 1 0 1 0 1 1 0 1))))
(mapcar 'xshig poplst)
(((0 1 1 0 1 1 1 1 1 1) (0 1 1 1 1 1 1 1 0 1) (1 1 1 1 1 1 1 1 0 1) (1 0 1 0 0 1 1 1 1 1) (1 0 0 0 1 1 1 1 1 1)) ((1 1 0 1 1 1 0 1 1 0) (1 1 0 0 1 1 0 1 1 0) (1 1 1 1 1 0 1 1 1 0) (1 1 0 0 0 1 1 1 1 0)) ((0 1 0 0 0 0 0 1 0 1) (0 1 0 0 0 0 0 1 0 1)) ((0 1 0 0 1 1 0 0 0 0)) ((0 0 1 1 1 1 0 0 1 0)) ((1 0 1 0 0 1 1 0 1 1) (1 1 1 1 0 1 1 0 1 1)) ((1 0 0 1 1 0 1 0 1 1) (1 0 0 1 1 0 1 1 0 1)) ((0 1 1 1 1 0 1 0 0 0) (0 1 1 1 0 1 1 1 0 0)) ((1 0 1 0 1 0 1 1 0 1)))
((1 1 1 1 1 1 1 1 0 1) (1 1 1 1 1 0 1 1 1 0) (0 1 0 0 0 0 0 1 0 1) (0 1 0 0 1 1 0 0 0 0) (0 0 1 1 1 1 0 0 1 0) (1 1 1 1 0 1 1 0 1 1) (1 0 0 1 1 0 1 0 1 1) (0 1 1 1 0 1 1 1 0 0) (1 0 1 0 1 0 1 1 0 1))
_$

aimisiyou

算法流程如下：
1、设定种群容量N，交叉概率n_cross，变异概率n_change，遗传代数M，构造初始种群poplst，并令xs_poplst=poplst。
2、假定小生境半径为r=DA*DB/(a*b)-max{(DA/a)*(DB/b),(DA/b)*(DB/a)}。
3、按照适应值大小将xs_poplst降序排列，并根据小生境半径将降序排列后的xs_poplst划分为多个小生境，每个小生境内选取共享适应度最大的个体，最后得到xs_poplst。
4、种群poplst进行选择、交叉、变异，生成下一代种群poplst。新的xs_poplst=poplst+xs_poplst。
5、跳转到步骤3。
6、终止条件，遗传代数达到M。(car xs_poplst)即为目前寻到的最优解,最优解可能有多个。

aimisiyou

(defun c:tt()
  (setq DB (getint "请输入母材短边DB长度=:"))
  (setq DA (getint "请输入母材长边DA长度=:"))
  (setq a (getint "请输入矩形零件长边a长度=:"))
  (setq b (getint "请输入矩形零件短边b长度=:"))
  (setq n_tol 0 xs_r (max (- (/ (* DB DA) (* a b)) (* (/ DA a)(/ DB b)))  (- (/ (* DB DA) (* a b)) (* (/ DA b)(/ DB a)))))
  (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))   
          )                     
  )
(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)
  (setq n_tol 0 flag t)
  (setq slst (list (list 0 0 DB DA)))
  (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
  )

(defun distfun (poplst)
    (mapcar '(lambda (x) (apply '+ (mapcar '(lambda (y) (apply '+ (mapcar '(lambda (a b) (abs (+ a b -1.0))) x y))) poplst)))  poplst)
  )

;;;选择函数
(defun selct (poplst)
   (setq ni 0 ga_num  (length poplst) new_poplst nil dd_sum 0 dd_lst nil)
   (setq fitlst (mapcar '(lambda (x y) (/ (fitfun x) y)) poplst (distfun poplst)))
   (setq sum_fitlst (apply '+ fitlst))
   (setq ffitlst (mapcar '(lambda (x) (/ (* x 1.0) sum_fitlst)) fitlst))
   (while (< ni ga_num)
          (setq ll_sum (+ dd_sum (nth ni ffitlst)))
          (setq dd_lst (cons (list dd_sum ll_sum) dd_lst))
          (setq dd_sum  ll_sum)
          (setq ni (+ ni 1))
   )
   (setq dd_lst (reverse dd_lst))
   (repeat ga_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)) dd_lst)) 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.8 n_cross (rnd))           ;;;设定交叉概率为0.8
(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.15 n_change (rnd))      ;;;设定变异概率为0.15
  (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 xshig (poplst)
   (setq firfitlst (vl-sort (mapcar '(lambda (x) (cons (fitfun x) x)) poplst) '(lambda (e1 e2)(> (car e1) (car e2)) )  ))  
   (setq vamax (car (car firfitlst)) )
   (setq vamaxlst (vl-remove nil (mapcar '(lambda (x) (if (= vamax (car x)) (cdr x))) firfitlst) ))
   (if (= (length vamaxlst) 1)
       (setq va (car  vamaxlst))
       (progn
            (setq lasfitlst (vl-sort
                                           (mapcar 'cons (mapcar '(lambda (x) (apply '+ (mapcar '(lambda (y) (apply '+ (mapcar '(lambda (a b) (abs (+ a b -1.0))) x y))) poplst)))  vamaxlst)  vamaxlst )                                 
                                                                '(lambda (e1 e2) (> (car e1) (car e2)) )
                              )
                        )  
          (setq  va  (cdr (car lasfitlst)))
        )
     )
)
(defun hmdis (ea eb)
   (apply '+ (mapcar '(lambda (x y) (boole 6 x y)) ea eb))
)
(defun xsfun (xs_r lst)
   (if (< (length lst) 2)
       (if (= (length lst) 1)
           (setq va (list lst))
           (setq va lst)
        )
       (progn
            (if (= (length  lst) 2)
                (if (<= (hmdis (cadr lst) (car lst))  xs_r )
                     (setq va (list lst))
                     (setq va (list (list (car lst)) (list (cadr lst))))
                )
                (progn
                      (setq lst1 (list (car lst))  lst2 nil)
                      (mapcar '(lambda (x)
                                    (if (<= (hmdis  x (car lst)) xs_r)
                                         (setq lst1 (cons x lst1))
                                         (setq lst2 (cons x lst2))
                                     )
                               )  
                               (cdr lst)
                       )   
                       (setq va (cons (reverse lst1) (xsfun xs_r (reverse lst2))))
                  )
             )
        )
   )
)

(defun gafun (n_length n_in n_ga xs_r)
     (setq poplst nil)
     (repeat n_in
            (setq plst (ff n_length))
            (setq poplst (cons plst poplst))
      )
         (setq xspoplst (pick (mapcar 'xshig (xsfun xs_r poplst )) 0 0))
     (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 xspoplst (pick (mapcar 'xshig (xsfun xs_r (append xspoplst poplst))) 0 0) )                 
           )
       )
     (car xspoplst)
)

(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 (mlst)
   (setq ih 0 vmlst nil nk (length mlst) )
   (while (< ih nk)
        (setq a_i (nth ih mlst) jh 0 sumh 0 hflag t)
        (while (and hflag (< jh nk))
           (setq b_j (nth jh mlst))
           (if (and (<= (car b_j)  (car a_i) )
                    (<= (cadr b_j) (cadr a_i))
                    (<= (+ (car a_i) (caddr a_i) ) (+ (car b_j) (caddr b_j) ))
                    (<= (+ (cadr a_i) (cadddr a_i) ) (+ (cadr b_j) (cadddr b_j) ))
               )
              (setq sumh (+ 1 sumh))
            )
           (setq jh (+ jh 1))
           (if (> sumh 1) (setq hflag nil))
         )
       (if hflag (setq vmlst (cons a_i vmlst)))
       (setq ih (+ ih 1))
  )
  (reverse vmlst)
)
(defun sortfun (juxlst)
   (vl-sort juxlst
             '(lambda (ea eb)
                      (if  (= (cadr ea) (cadr eb))
                           (<= (car ea) (car eb))
                           (< (cadr ea) (cadr eb))
                        )
              )
    )
)
(defun drawfun (pt slst ifdraw)
   (setq i 0 n (length slst) flag t  newslst slst)
   (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 ea slst
                             (setq vlst (append  (fenfun ea 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
)
  (setq ifdraw nil)
  (setq p_best (gafun (/ (* DB DA) (* a b)) 30 30 xs_r))
  (setq ifdraw t)
  (fitfun p_best)
)
命令: tt
请输入母材短边DB长度=:59
请输入母材长边DA长度=:48
请输入矩形零件长边a长度=:10
请输入矩形零件短边b长度=:7
38