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

mahuan1279

;;;考虑运行时间问题（理论个数最好不超过60，当然越大运行越慢），本程序设定种群容量为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))
)

mahuan1279

琴剑江山_10184 发表于 2019-1-20 20:44
考滤下料间隙
3-5MM
靠边留料10-15 MM

将零件的长宽均增加大缝隙的一半长度，运行后得出的图形再缩回就是了。

mahuan1279

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

运行约三分钟。

琴剑江山_10184

mahuan1279 发表于 2019-1-19 22:31
命令: tt
请输入母材短边DB长度=:59
请输入母材长边DA长度=:69

考滤下料间隙
3-5MM
靠边留料10-15 MM

yoyoho

谢谢! mahuan1279 分享程序!!!!!!!

zixuan203344

lisp版的遗传算法效率太低了……还是得C++来写

李钊伟2012

厉害厉害，LISP版解决了画图问题，时间也不是很长啊，只有15分钟内就OK

ynhh

太费时间
电脑不动以为死机了

写不完的日记

mahuan1279 发表于 2019-1-20 22:25
将零件的长宽均增加大缝隙的一半长度，运行后得出的图形再缩回就是了。

这思路666的很啊

999999

楼主优秀，，顶一下