遗传算法求单一规格矩形下料问题
;;;考虑运行时间问题（理论个数最好不超过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 0DBDA)))
(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_suml_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_pop2) (- 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) (twocrossx)) cp_poplst)))
(setq pbplstpoplst)
)
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) )
(setqp_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 tnewslst 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))
)
琴剑江山_10184 发表于 2019-1-20 20:44
考滤下料间隙
3-5MM
靠边留料10-15 MM
将零件的长宽均增加大缝隙的一半长度，运行后得出的图形再缩回就是了。 命令: tt
请输入母材短边DB长度=:59
请输入母材长边DA长度=:69
请输入矩形零件长边a长度=:10
请输入矩形零件短边b长度=:7
54
运行约三分钟。
mahuan1279 发表于 2019-1-19 22:31
命令: tt
请输入母材短边DB长度=:59
请输入母材长边DA长度=:69
考滤下料间隙
3-5MM
靠边留料10-15 MM 谢谢! mahuan1279 分享程序!!!!!!! lisp版的遗传算法效率太低了……还是得C++来写 {:1_1:}厉害厉害，LISP版解决了画图问题，时间也不是很长啊，只有15分钟内就OK
太费时间
电脑不动以为死机了 mahuan1279 发表于 2019-1-20 22:25
将零件的长宽均增加大缝隙的一半长度，运行后得出的图形再缩回就是了。
这思路666的很啊 楼主优秀，，顶一下
页:
[1]
2