遗传算法求TSP问题
本帖最后由 mahuan1279 于 2019-10-3 09:38 编辑(defun c:tt()
(defun rnd ()
(*(rem (getvar "cputicks") 1e4) 1e-4)
)
(defun rnd_n (n)
(fix (* n (rnd)))
)
(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 xipai (n)
(setq i 1 j 0 klst nil)
(while (<= i n)
(setq klst (cons i klst))
(setq i (+ 1 i))
)
(while (<= j 20)
(setq i_pot (rnd_n n))
(setq j_pot (rnd_n n))
(setq nmin (min i_pot j_pot))
(setq nmax (max i_pot j_pot))
(setq klst (append (pick klst(+ 1 nmax) (- n 1)) (pick klst (+ 1 nmin) nmax) (pick klst 0 nmin)))
(setq j (+ j 1))
)
(mapcar '1- klst)
)
(defun fitfun (ptlst)
(apply '+ (mapcar 'distance ptlst (append (cdr ptlst) (list (car ptlst)))))
)
;;;取点函数
(defun fp ()
(setq sn (ssget ":N" '((0 . "point"))))
(setq i 0 n (sslength sn) pts nil)
(while (< i n)
(setq pts (cons (cons i (cdr (assoc 10 (entget (ssname sn i))))) pts))
(setq i (+ i 1))
)
(reverse pts)
)
(setq pts (fp))
(setq poplst nil)
(repeat 100
(setq plst (xipai (length pts)))
(setq poplst (cons plst poplst))
)
(defun n-pt (nlst)
(mapcar '(lambda (x) (cdr (nth x pts))) nlst)
)
(setq p_best(car (vl-sort (mapcar '(lambda (x y) (cons (fitfun (n-pt x)) y))
poplst
poplst
)
'(lambda (e1 e2)(< (car e1) (car e2)) )
)
)
)
(setq p_chane 0.02N_d (* 50 (length pts)) ii 0)
(while (< ii N_d)
(setq vlst nil)
(foreach en poplst
(setq nt (length en))
(setqens en pc1 (nth (rnd_n nt) ens) flag t clst (list pc1))
(while flag
(setq r_rnd (rnd))
(if (< r_rnd p_chane)
(setq pc2 (nth (rnd_n (- nt 1)) (vl-remove pc1 ens)))
(progn
(setq en_rnd (nth (rnd_n nt) poplst))
(if (= pc1 (last en_rnd))
(setq pc2 (car en_rnd))
(setq pc2 (cadr (member pc1 en_rnd)) )
)
)
)
(if (or (= pc2 (cadr (member pc1 ens))) (= pc1 (cadr (member pc2 ens))) )
(setq flag nil)
(progn
(if (member pc2 (member pc1 ens))
(setq ens (append (reverse (member pc1 (reverse ens))) (member pc2 (reverse (cdr (member pc1 ens)))) (cdr (member pc2 ens)) ))
(setq ens (append (reverse (member pc2 (reverse ens))) (member pc1 (reverse (cdr (member pc2 ens)))) (cdr (member pc1 ens)) ))
)
(setq pc1 pc2)
(setq clst (cons pc1 clst))
(if (= (length clst) (- nt 1))
(setq flag nil)
)
)
)
)
(if (< (fitfun (n-pt ens)) (fitfun (n-pt en)))
(setq vlst (cons ens vlst))
(setq vlst (cons envlst))
)
)
(setq ii (+ 1 ii))
(setq poplst vlst)
(setq p_bestnew(car (vl-sort (mapcar '(lambda (x y) (cons (fitfun (n-pt x)) y)) poplst poplst)
'(lambda (e1 e2)(< (car e1) (car e2)) )
)
)
)
(if (< (car p_bestnew) (car p_best) )
(setqp_best p_bestnew)
)
)
(apply 'command (cons "pline" (reverse (cons "c" (reverse (n-pt (cdr p_best)))))))
)
学习一下！ 科普下，这个是干啥用的 gdslqs 发表于 2020-6-8 21:37
科普下，这个是干啥用的
遍历所有点的最短路径 赞一个！
autolsp托管模式下，点数N超过50 会比较郁闷了。。
tsp的各类算法都很耗CPU，进程内ObjARX运行 会造成acad假死停滞。
进程外运行，生成最优路径 ->数据文件 -》cad连线绘图，可能是较佳方案。
算了下5000 点位最优路径 ,用时 85秒，全程跑满单核CPU。（经典遗传tsp算法，c++/gcc O3)
页:
[1]