数字表平均分配遗传算法

kkq0305

1. (defun divlst (lst n / f1 f2 divmun lst1 ai nx)
   
2.           ;数字列表平均分配，遗传算法
   
3.           ;lst:纯数字表，n，平均分配个数
   
4.           ;例：(divlst ’(100 51 51 49 23 99 98 23 22 18 15 98 95 66 17) 3)
   
5.           ;    ((100.0 51.0 51.0 49.0 23.0) (99.0 98.0 23.0 22.0 18.0 15.0) (98.0 95.0 66.0 17.0))
   
6.   (setq  f1
   
7.    (lambda (x)
   
8.      (if (> x 0)
   
9.        (cons (/ (rem (getvar "CPUTICKS") 1000) 1000.0) (f1 (1- x)))
   
10.      )
    
11.    )
    
12.   )          ;生成随机种子表，元素个数为x
    
13.   (setq divmun (/ (apply '+ lst) n 1.0)) ;计算平均数
    
14.   (setq lst1 '())
    
15.   (repeat 4 (setq lst1 (cons (f1 (length lst)) lst1)))
    
16.           ;生成4个种子表lst1，元素个数为lst长度
    
17.   (setq  f2        ;lst：按照随机种子排序之后的lst
    
18.           ;key：t对随机种子求与平均数绝对差值的和 nil求随机种子对应的切分表
    
19.    (lambda (lst key / nn lst2 lst3)
    
20.      (setq nn   0
    
21.      lst3 '()
    
22.      )        ;初始化数据，n 记录切分表长度，lst3 切分表
    
23.      (while (< (setq nn (1+ nn)) n)
    
24.           ;当切分表长度等于n-1时停止切割
    
25.        (setq lst2 '())    ;lst2 记录切分表
    
26.       (while (and lst (< (+ (car lst) (apply '+ lst2)) divmun))                                        ;当切分表lst2的和加上要加入的lst元素大于平均值停止加入lst2
    
27.                (setq lst2 (cons (car lst) lst2)
    
28.                      lst  (cdr lst)
    
29.                )
    
30.              )
    
31.              (if lst
    
32.              (setq lst2        (cons (car lst) lst2)
    
33.                    lst        (cdr lst)
    
34.                    lst3        (cons lst2 lst3)
    
35.              )
    
36.                (setq lst3 (cons lst2 lst3)));将切分好的lst2存入lst3
    
37.            )
    
38.            (if lst
    
39.              (setq lst3 (cons lst lst3))
    
40.              (setq lst3 (cons '(1000) lst3)));lst剩余元素并入lst3
    
41.      (if key
    
42.        (apply '+
    
43.         (mapcar '(lambda (x) (abs (- divmun (apply '+ x)))) lst3)
    
44.        )        ;对随机种子求与平均数绝对差值的和
    
45.        (mapcar '(lambda (x / sa)
    
46.       (setq sa (vlax-make-safearray
    
47.            vlax-vbdouble
    
48.            (cons 0 (1- (length x)))
    
49.          )
    
50.       )
    
51.       (vlax-safearray-fill sa x)
    
52.       (mapcar  '(lambda (a) (vlax-safearray-get-element sa a))
    
53.         (vl-sort-i x '>)
    
54.       )
    
55.           )
    
56.          lst3
    
57.        )        ;求随机种子对应的切分表
    
58.      )
    
59.    )
    
60.   )
    
61.   (setq  ai 1
    
62.   nx 0
    
63.   )          ;初始化数据
    
64.           ;ai 与平均数绝对差值的和初始值不能为0
    
65.           ;nx 遗传次数
    
66.   (while (not (or (= ai 0) (= (setq nx (1+ nx)) 1000)))
    
67.           ; 与平均数绝对差值的和为0或遗传次数到达1000停止
    
68.     (setq ai (car (mapcar 'cdr
    
69.         (setq  lst1
    
70.          (vl-sort
    
71.            (mapcar
    
72.              'cons
    
73.              lst1
    
74.              (mapcar
    
75.                '(lambda  (x)
    
76.             (f2 (mapcar
    
77.             'cdr
    
78.             (vl-sort
    
79.               (mapcar 'cons x lst)
    
80.               '(lambda (a b) (< (car a) (car b)))
    
81.             )
    
82.                 )
    
83.           ;按照随机种子表(lst1的元素)对lst排序
    
84.                 t
    
85.             )
    
86.           ;排序后的lst切割求对应的绝对差值
    
87.           )
    
88.                lst1
    
89.              )
    
90.            )
    
91.            '(lambda (a b) (< (cdr a) (cdr b)))
    
92.           ;按照对应的绝对差值大小对随机种子表lst3排序更新排序后lst1
    
93.          )
    
94.         )
    
95.       )
    
96.        )
    
97.     )          ;计算与平均数绝对差值的和的最小值ai
    
98.     (setq lst1 (mapcar 'car lst1))  ;更新排序后lst1
    
99.     (setq lst1
    
100.      (list
     
101.        (car lst1)      ;最优种子
     
102.        (f1 (length lst))
     
103.        (f1 (length lst))    ;新加入两个随机种子
     
104.        (mapcar
     
105.          '(lambda  (a b)
     
106.       (if (> 0.5 (/ (rem (getvar "CPUTICKS") 1000) 1000.0))
     
107.         a
     
108.         b
     
109.       )
     
110.     )
     
111.          (car lst1)
     
112.          (cadr lst1)
     
113.        )        ;最优种子与次优种子杂交
     
114.      )
     
115.     )
     
116.   )
     
117.   (f2 (mapcar 'cdr
     
118.         (vl-sort (mapcar 'cons (car lst1) lst)
     
119.            '(lambda (a b) (< (car a) (car b)))
     
120.         )
     
121.       )
     
122.       nil
     
123.   )          ;输出最终结果
     
124. )

(defun divlst (lst n / f1 f2 divmun lst1 ai nx)<br />           ;数字列表平均分配，遗传算法<br />           ;lst:纯数字表，n，平均分配个数<br />           ;例：(divlst ’(100 51 51 49 23 99 98 23 22 18 15 98 95 66 17) 3)<br />           ;    ((100.0 51.0 51.0 49.0 23.0) (99.0 98.0 23.0 22.0 18.0 15.0) (98.0 95.0 66.0 17.0))<br />   (setq  f1<br />    (lambda (x)<br />      (if (> x 0)<br />        (cons (/ (rem (getvar "CPUTICKS") 1000) 1000.0) (f1 (1- x)))<br />      )<br />    )<br />   )          ;生成随机种子表，元素个数为x<br />   (setq divmun (/ (apply '+ lst) n 1.0)) ;计算平均数<br />   (setq lst1 '())<br />   (repeat 4 (setq lst1 (cons (f1 (length lst)) lst1)))<br />           ;生成4个种子表lst1，元素个数为lst长度<br />   (setq  f2        ;lst：按照随机种子排序之后的lst<br />           ;key：t对随机种子求与平均数绝对差值的和 nil求随机种子对应的切分表<br />    (lambda (lst key / nn lst2 lst3)<br />      (setq nn   0<br />      lst3 '()<br />      )        ;初始化数据，n 记录切分表长度，lst3 切分表<br />      (while (< (setq nn (1+ nn)) n)<br />           ;当切分表长度等于n-1时停止切割<br />        (setq lst2 '())    ;lst2 记录切分表<br />       (while (and lst (< (+ (car lst) (apply '+ lst2)) divmun))                                        ;当切分表lst2的和加上要加入的lst元素大于平均值停止加入lst2<br />                (setq lst2 (cons (car lst) lst2)<br />                      lst  (cdr lst)<br />                )<br />              )<br />              (if lst<br />              (setq lst2        (cons (car lst) lst2)<br />                    lst        (cdr lst)<br />                    lst3        (cons lst2 lst3)<br />              )<br />                (setq lst3 (cons lst2 lst3)));将切分好的lst2存入lst3<br />            )<br />            (if lst<br />              (setq lst3 (cons lst lst3))<br />              (setq lst3 (cons '(1000) lst3)));lst剩余元素并入lst3<br />      (if key<br />        (apply '+<br />         (mapcar '(lambda (x) (abs (- divmun (apply '+ x)))) lst3)<br />        )        ;对随机种子求与平均数绝对差值的和<br />        (mapcar '(lambda (x / sa)<br />       (setq sa (vlax-make-safearray<br />            vlax-vbdouble<br />            (cons 0 (1- (length x)))<br />          )<br />       )<br />       (vlax-safearray-fill sa x)<br />       (mapcar  '(lambda (a) (vlax-safearray-get-element sa a))<br />         (vl-sort-i x '>)<br />       )<br />           )<br />          lst3<br />        )        ;求随机种子对应的切分表<br />      )<br />    )<br />   )<br />   (setq  ai 1<br />   nx 0<br />   )          ;初始化数据<br />           ;ai 与平均数绝对差值的和初始值不能为0<br />           ;nx 遗传次数<br />   (while (not (or (= ai 0) (= (setq nx (1+ nx)) 1000)))<br />           ; 与平均数绝对差值的和为0或遗传次数到达1000停止<br />     (setq ai (car (mapcar 'cdr<br />         (setq  lst1<br />          (vl-sort<br />            (mapcar<br />              'cons<br />              lst1<br />              (mapcar<br />                '(lambda  (x)<br />             (f2 (mapcar<br />             'cdr<br />             (vl-sort<br />               (mapcar 'cons x lst)<br />               '(lambda (a b) (< (car a) (car b)))<br />             )<br />                 )<br />           ;按照随机种子表(lst1的元素)对lst排序<br />                 t<br />             )<br />           ;排序后的lst切割求对应的绝对差值<br />           )<br />                lst1<br />              )<br />            )<br />            '(lambda (a b) (< (cdr a) (cdr b)))<br />           ;按照对应的绝对差值大小对随机种子表lst3排序更新排序后lst1<br />          )<br />         )<br />       )<br />        )<br />     )          ;计算与平均数绝对差值的和的最小值ai<br />     (setq lst1 (mapcar 'car lst1))  ;更新排序后lst1<br />     (setq lst1<br />      (list<br />        (car lst1)      ;最优种子<br />        (f1 (length lst))<br />        (f1 (length lst))    ;新加入两个随机种子<br />        (mapcar<br />          '(lambda  (a b)<br />       (if (> 0.5 (/ (rem (getvar "CPUTICKS") 1000) 1000.0))<br />         a<br />         b<br />       )<br />     )<br />          (car lst1)<br />          (cadr lst1)<br />        )        ;最优种子与次优种子杂交<br />      )<br />     )<br />   )<br />   (f2 (mapcar 'cdr<br />         (vl-sort (mapcar 'cons (car lst1) lst)<br />            '(lambda (a b) (< (car a) (car b)))<br />         )<br />       )<br />       nil<br />   )          ;输出最终结果<br /> )

taoyi0727

(divlst '(1 2 3 4 5 6 7 8 9) 4)
这个要出错

kkq0305

taoyi0727 发表于 2021-10-3 11:58
(divlst '(1 2 3 4 5 6 7 8 9) 4)
这个要出错

少想了两种情况  打上补丁了   感谢 ！！

mahuan1279

_$ (divlst '(1 2 3 4 5 6 -7 8 -9) 4)
((5.0 2.0 -7.0) (4.0) (8.0 6.0 -9.0) (3.0 1.0))
_$ (divlst '(1 2 3 4 5 6 7 8 -9) 4)
((8.0 6.0 1.0 -9.0) (4.0 3.0) (5.0 2.0) (7.0))
_$

mahuan1279

遗传算法还可以优化。

kkq0305

mahuan1279 发表于 2021-10-4 20:55
遗传算法还可以优化。

增加种子数和 遗传次数可以  不过算法优化 还没有想出来

wrf610051

;;思路：粗分组=>优化(单项对调、多项对调)
;;优点：速度快
;;缺点：不一定能得到最优解

;;函数wrf3upp 分组数 优化次数 数字表)
;;返回：(极差 (sum1 lst1)(sum2 lst2)...)

;;(wrf3upp 3 7 '(5.4 5.0 4.8 4.2 2.8 2.8 2.8 2.8 2.8 2.8))
;;(1.4 (11.2 (2.8 2.8 2.8 2.8)) (12.4 (5.4 4.2 2.8)) (12.6 (5.0 4.8 2.8)))


;;例子：
;;出题目：(setq lst (createlst4 1000 3 100)) ;;将实数1000按离散度为100随机分成拆成3组
;; (wrf3upp 3 7 lst)
;; (wrf3upp 3 7 (createlst4 1000 3 100))

;;=============================
;;对实数表lst,均分成n组
;;分组数n----n应大于等于3
;;优化次数i---i取9
;;(wrf3upp n i lst) ;;(fuzz (su1 lst1)(su2 lst2) ... (sun lstn)
(defun wrf3upp ( n i lst / l1 l2 l3 su1 su2 su3 ll
                                        minterm li sui newterm offset lll
                        )
        (setq lst (reverse (XD::list:sort lst '<)))
       
        ;;====粗分组
        (setq ll (createlst1 n))
        (while lst
                (setq minterm (car ll))
                (setq li (reverse (cons (car lst) (reverse (cadr minterm)))))
                (setq sui (+ (car minterm) (car lst)))
                (setq newterm (list sui li))
                (setq ll (cons newterm (cdr ll)))
                (setq ll (l-sort ll))
                (setq lst (cdr lst))
        )
       
        ;;=================================
        ;;开始优化ll表
        ;(setq lll nil) ;;记录全解
        (setq offset (- (car (car (reverse ll))) (car (car ll))))
        (setq lll (cons (cons offset ll) lll))
        (repeat i
                (if (< (car (car ll)) (car (car (reverse ll))))
                        (progn
                                (setq ll (youhua_ll ll))
                                (setq offset (- (car (car (reverse ll))) (car (car ll))))
                                (setq lll (cons (cons offset ll) lll))
                        )
                )
        )
        ;;=========================
        (setq lll (l-sort lll))
        (setq lll (XD:ist:DelSame lll))
        (setq ll (car lll))
)
;;主程序结束
;;========================

       
                               
;;==========================
;;专用表排序
(defun l-sort ( L / L1 LL)
        (defun foo1 (a b)
                (cond ((<= (car a) (car b))
                                        )
                                (T
                                        nil)
                )
        )
        (setq li (vl-sort-i l 'foo1))
        (while Li
                (setq LL (cons (nth (car Li) L) LL))
                (setq Li (cdr Li))
        )
        (reverse LL)
)


;;===================================
;;支持容差的 vl-positon
;(xd::list:position-fuzz 4 '(1 2 3 4.021 5 6 7) 1e-1) ;;=>3
(defun xd::list:position-fuzz (e l fuzz)
  (if (atom e)
    (vl-position
      (xd::list:car-member-if '(lambda (x) (equal e x fuzz)) l)
      l
    )
  (vl-position e l)
  )
)


;;======================
;;在lmin和lmax中找符合条件(大a)的对调项(单项对调)
(defun findterm ( l1 l2 a / n m ll yn ni mi )
        (setq n (length l1))
        (setq m (length l2))
        (setq ll l1)
        (setq yn T)
        (while (and ll yn)
                (if (member (+ (car ll) a) l2)
                        (progn
                                (setq ni (- n (length ll)))
                                (setq mi (- m (length (member (+ (car ll) a) l2))))
                                (setq yn nil))
                        )
                (setq ll (cdr ll))
        )

        (if yn
                (progn
                        (setq ll l1)
                        (while (and ll yn)
                                (if (xd::list:position-fuzz (+ (car ll) a) l2 (* a 0.25))
                                        (progn
                                                (setq ni (- n (length ll)))
                                                (setq mi (xd::list:position-fuzz (+ (car ll) a) l2 (* a 0.25)))
                                                (setq yn nil)
                                        )
                                )
                                (setq ll (cdr ll))
                        )
                )
        )
        (if yn
                (progn
                        (setq ll l1)
                        (while (and ll yn)
                                (if (xd::list:position-fuzz (+ (car ll) (* a 0.75)) l2 (* a 0.25))
                                        (progn
                                                (setq ni (- n (length ll)))
                                                (setq mi (xd::list:position-fuzz (+ (car ll) (* a 0.5)) l2 (* a 0.25)))
                                                (setq yn nil)
                                        )
                                )
                                (setq ll (cdr ll))
                        )
                )
        )
        (if yn
                (progn
                        (setq ll l1)
                        (while (and ll yn)
                                (if (xd::list:position-fuzz (+ (car ll) (* a 0.5)) l2 (* a 0.25))
                                        (progn
                                                (setq ni (- n (length ll)))
                                                (setq mi (xd::list:position-fuzz (+ (car ll) (* a 0.5)) l2 (* a 0.25)))
                                                (setq yn nil)
                                        )
                                )
                                (setq ll (cdr ll))
                        )
                )
        )
        (if yn
                (progn
                        (setq ll l1)
                        (while (and ll yn)
                                (if (xd::list:position-fuzz (+ (car ll) (* a 0.25)) l2 (* a 0.25))
                                        (progn
                                                (setq ni (- n (length ll)))
                                                (setq mi (xd::list:position-fuzz (+ (car ll) (* a 0.25)) l2 (* a 0.25)))
                                                (setq yn nil)
                                        )
                                )
                                (setq ll (cdr ll))
                        )
                )
        )
        (if yn
                (progn
                        (setq ll l1)
                        (while (and ll yn)
                                (if (xd::list:position-fuzz (+ (car ll) (* a 1.25)) l2 (* a 0.25))
                                        (progn
                                                (setq ni (- n (length ll)))
                                                (setq mi (xd::list:position-fuzz (+ (car ll) (* a 1.25)) l2 (* a 0.25)))
                                                (setq yn nil)
                                        )
                                )
                                (setq ll (cdr ll))
                        )
                )
        )
        (if yn
                (progn
                        (setq ll l1)
                        (while (and ll yn)
                                (if (xd::list:position-fuzz (+ (car ll) (* a 1.5)) l2 (* a 0.25))
                                        (progn
                                                (setq ni (- n (length ll)))
                                                (setq mi (xd::list:position-fuzz (+ (car ll) (* a 1.5)) l2 (* a 0.25)))
                                                (setq yn nil)
                                        )
                                )
                                (setq ll (cdr ll))
                        )
                )
        )
        (if yn
                (progn
                        (setq ll l1)
                        (while (and ll yn)
                                (if (xd::list:position-fuzz (+ (car ll) (* a 1.75)) l2 (* a 0.25))
                                        (progn
                                                (setq ni (- n (length ll)))
                                                (setq mi (xd::list:position-fuzz (+ (car ll) (* a 1.75)) l2 (* a 0.25)))
                                                (setq yn nil)
                                        )
                                )
                                (setq ll (cdr ll))
                        )
                )
        )
       


       
        (if yn
                nil
                (list ni mi)
        )
)



       
;;=================================
;;优化ll表
(defun youhua_ll ( ll / minterm maxterm a lmin lmax nm
                                term_min term_max new_lmin_h new_lmin_t
                                new_lmax_h new_lmax_t
                                new_lmin new_lmax minterm maxterm
                                )
        (cond ((setq lmin (car (cdr (car ll)))
                                        lmax (car (cdr (car (reverse ll))))
                                        a (- (car (car (reverse ll))) (car (car ll)))
                                        nm (findterm lmin lmax (/ a 2.0)))
                                (setq term_min (nth (car nm) lmin))
                                (setq term_max (nth (cadr nm) lmax))
                                (setq new_lmin_h (XD:ist:N-M lmin 1 (car nm)))
                                (setq new_lmin_t (XD:ist:N-M lmin (+ (car nm) 2) (length lmin)))
                                (setq new_lmax_h (XD:ist:N-M lmax 1 (cadr nm)))
                                (setq new_lmax_t (XD:ist:N-M lmax (+ (cadr nm) 2) (length lmax)))
                                (setq new_lmin (append new_lmin_h (cons term_max new_lmin_t)))
                                (setq new_lmax (append new_lmax_h (cons term_min new_lmax_t)))
                                (setq new_lmin (reverse (XD::list:sort new_lmin '<)))
                                (setq new_lmax (reverse (XD::list:sort new_lmax '<)))
                                (setq minterm (list (apply '+ new_lmin) new_lmin))
                                (setq maxterm (list (apply '+ new_lmax) new_lmax))
                               
                                (setq ll (cons minterm (reverse (cons maxterm (cdr (reverse (cdr ll)))))))
                                (setq ll (l-sort ll)) ;;为了保险重算一次
                        )
                        ((setq lmin (car (cdr (car ll)))
                                        lmax (car (cdr (cadr (reverse ll))))
                                        a (- (car (cadr (reverse ll))) (car (car ll)))
                                        nm (findterm lmin lmax (/ a 2.0)))
                                (setq term_min (nth (car nm) lmin))
                                (setq term_max (nth (cadr nm) lmax))
                                (setq new_lmin_h (XD:ist:N-M lmin 1 (car nm)))
                                (setq new_lmin_t (XD:ist:N-M lmin (+ (car nm) 2) (length lmin)))
                                (setq new_lmax_h (XD:ist:N-M lmax 1 (cadr nm)))
                                (setq new_lmax_t (XD:ist:N-M lmax (+ (cadr nm) 2) (length lmax)))
                                (setq new_lmin (append new_lmin_h (cons term_max new_lmin_t)))
                                (setq new_lmax (append new_lmax_h (cons term_min new_lmax_t)))
                                (setq new_lmin (reverse (XD::list:sort new_lmin '<)))
                                (setq new_lmax (reverse (XD::list:sort new_lmax '<)))
                                (setq minterm (list (apply '+ new_lmin) new_lmin))
                                (setq maxterm (list (apply '+ new_lmax) new_lmax))
                               
                                (setq ll (cons minterm (reverse (cons maxterm (cons (car (reverse ll)) (cddr (reverse (cdr ll))))))))
                                (setq ll (l-sort ll)) ;;为了保险重算一次
                        )
                        ((setq lmin (car (cdr (cadr ll)))
                                        lmax (car (cdr (car (reverse ll))))
                                        a (- (car (car (reverse ll))) (car (cadr ll)))
                                        nm (findterm lmin lmax (/ a 2.0)))
                                (setq term_min (nth (car nm) lmin))
                                (setq term_max (nth (cadr nm) lmax))
                                (setq new_lmin_h (XD:ist:N-M lmin 1 (car nm)))
                                (setq new_lmin_t (XD:ist:N-M lmin (+ (car nm) 2) (length lmin)))
                                (setq new_lmax_h (XD:ist:N-M lmax 1 (cadr nm)))
                                (setq new_lmax_t (XD:ist:N-M lmax (+ (cadr nm) 2) (length lmax)))
                                (setq new_lmin (append new_lmin_h (cons term_max new_lmin_t)))
                                (setq new_lmax (append new_lmax_h (cons term_min new_lmax_t)))
                                (setq new_lmin (reverse (XD::list:sort new_lmin '<)))
                                (setq new_lmax (reverse (XD::list:sort new_lmax '<)))
                                (setq minterm (list (apply '+ new_lmin) new_lmin))
                                (setq maxterm (list (apply '+ new_lmax) new_lmax))
                               
                                (setq ll (cons (car ll) (cons minterm (reverse (cons maxterm (cdr (reverse (cddr ll))))))))
                                (setq ll (l-sort ll)) ;;为了保险重算一次
                        )
                        (T
                                ll
                        )

        )
       
       
)


(defun createlst1 ( n / ll)
        (repeat n (setq ll (cons (list 0 nil) ll)))
)


(defun createlst2 ( n / ll)
        (repeat n (setq ll (cons (list 0 "" nil nil) ll)))
)

(defun createlst3 ( r n m / ll su a)
        (setq r (* r 1.0))
        (repeat n
                (setq ll (cons (XD::math:rand 1 m) ll))
        )
        (setq su (apply '+ ll))
        (setq a (/ r su))
        (setq ll (mapcar '(lambda (x) (* x a)) ll))
)

(defun createlst4 ( r n m / ll )
        (repeat n
                (setq ll (append (createlst3 r (XD::math:rand 4 30) m) ll))
        )
)

(defun XD:ist:DelSame (l)
  (if l
   (cons (car l) (XD:ist:DelSame (vl-remove (car l) l)))
)
)

kkq0305

wrf610051 发表于 2021-10-5 07:57
;;思路：粗分组=>优化(单项对调、多项对调)
;;优点：速度快
;;缺点：不一定能得到最优解

我的 遗传 算法结合 你的 算法 出来 就差不多了

mahuan1279

遗传算法有些不伦不类。