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

aimisiyou

;;;考虑运行时间问题，本程序设定种群容量为30，遗传代数为30，所得结果可能与最优解偏差稍大
;;;如果想得出离最优解偏差较小的解，可适当增大种群容量和遗传代数，但运行时间将会较长（请慎重）

(defun c:tt()
  (setq DB (getint "请输入母材短边DB长度=:"))
  (setq DA (getint "请输入母材长边DA长度=:"))
  (setq a (getint "请输入矩形零件长边a长度=:"))
  (setq b (getint "请输入矩形零件短边b长度=:"))
  (setq n_tol 0)
  (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 selct (poplst)
   (setq k 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 (< k num)
          (setq l_sum (+ d_sum (nth k fitlst)))
          (setq d_lst (cons (list d_sum l_sum) d_lst))
          (setq d_sum  l_sum)
          (setq k (+ k 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))         
(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))     
  (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)))
                                        (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 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
)
(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 (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  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 )))
                     (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 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
  )
  (setq ifdraw nil)
  (setq p_best (gafun (/ (* DB DA) (* a b)) 30 30))
  (setq ifdraw t)
  (fitfun (cdr p_best))
)

aimisiyou

命令: tt
请输入母材短边DB长度=:69
请输入母材长边DA长度=:87
请输入矩形零件长边a长度=:10
请输入矩形零件短边b长度=:7
80

理论下料个数为（69*87）/(10*7)=85
程序运行了约十分钟，得到80个零件的排版图。

Lisphk

顶楼主，楼主一直在研究下料，看来颇有心得了。

aimisiyou

Lisphk 发表于 2018-2-11 12:46

心得谈不上，就是想如何将一种算法用lisp表现出来，不弄出来如鲠在喉。当然运行效率可能差强人意。

Lisphk

aimisiyou 发表于 2018-2-11 12:49

不知道是在什么地方看到的，说，最重要的是先实现它，其次才是优化。

ynhh

虽然很费时间
但大师的付出是值得大家敬佩的
终于看到成果了

Lisphk

ynhh 发表于 2018-2-11 13:40

做你这个范围的，多少时间啊？

ynhh

Lisphk 发表于 2018-2-11 13:50

好几分钟吧
如有个进度条就好了
就是太费时间

aimisiyou

命令: tt
请输入母材短边DB长度=:69
请输入母材长边DA长度=:77
请输入矩形零件长边a长度=:10
请输入矩形零件短边b长度=:7
71


奇怪了，当设置容量为30，遗传代数为50，运行约12分钟结果怎么出现零件相交的情况？先标记下。

aimisiyou

命令: tt
请输入母材短边DB长度=:47
请输入母材长边DA长度=:59
请输入矩形零件长边a长度=:10
请输入矩形零件短边b长度=:7
38


此次将交叉概率由0.6调到0.8，变异概率由0.05调至0.25，样本容量和遗传代数仍为30 、30，运行结果与理论值39很接近，算是比较满意的结果。
可见适当调整交叉概率、变异概率、样本容量和遗传代数的组合，有意想不到的效果。
直观感觉当理论值较大时，大幅提高交叉概率和变异概率，增加前期的搜索范围，而当理论值较小时，适当调小交叉概率和变异概率，避免频繁的交叉、变异跳过最优解。

ynhh

大师这个太花时间了
这个也是能布80个

aimisiyou

ynhh 发表于 2018-2-12 12:28

采取一些措施可以进行优化，减少运行时间。如母材长宽都除以零件长宽的最小公倍数，对所得的余数进行运算，减少运算量。

ynhh

aimisiyou 发表于 2018-2-12 14:39

大师这排法更牛啊
你这都成精了

434939575

必须顶，感谢分享！

qqqincccken

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