数字表平均分配遗传算法
本帖最后由 kkq0305 于 2021-10-3 21:24 编辑(defun divlst (lst n / f1 f2 divmun lst1 ai nx)
;数字列表平均分配，遗传算法
;lst:纯数字表，n，平均分配个数
;例：(divlst ’(100 51 51 49 23 99 98 23 22 18 15 98 95 66 17) 3)
; ((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))
(setqf1
(lambda (x)
(if (> x 0)
(cons (/ (rem (getvar "CPUTICKS") 1000) 1000.0) (f1 (1- x)))
)
)
) ;生成随机种子表，元素个数为x
(setq divmun (/ (apply '+ lst) n 1.0)) ;计算平均数
(setq lst1 '())
(repeat 4 (setq lst1 (cons (f1 (length lst)) lst1)))
;生成4个种子表lst1，元素个数为lst长度
(setqf2 ;lst：按照随机种子排序之后的lst
;key：t对随机种子求与平均数绝对差值的和 nil求随机种子对应的切分表
(lambda (lst key / nn lst2 lst3)
(setq nn 0
lst3 '()
) ;初始化数据，n 记录切分表长度，lst3 切分表
(while (< (setq nn (1+ nn)) n)
;当切分表长度等于n-1时停止切割
(setq lst2 '()) ;lst2 记录切分表
(while (and lst (< (+ (car lst) (apply '+ lst2)) divmun)) ;当切分表lst2的和加上要加入的lst元素大于平均值停止加入lst2
(setq lst2 (cons (car lst) lst2)
lst(cdr lst)
)
)
(if lst
(setq lst2 (cons (car lst) lst2)
lst (cdr lst)
lst3 (cons lst2 lst3)
)
(setq lst3 (cons lst2 lst3)));将切分好的lst2存入lst3
)
(if lst
(setq lst3 (cons lst lst3))
(setq lst3 (cons '(1000) lst3)));lst剩余元素并入lst3
(if key
(apply '+
(mapcar '(lambda (x) (abs (- divmun (apply '+ x)))) lst3)
) ;对随机种子求与平均数绝对差值的和
(mapcar '(lambda (x / sa)
(setq sa (vlax-make-safearray
vlax-vbdouble
(cons 0 (1- (length x)))
)
)
(vlax-safearray-fill sa x)
(mapcar'(lambda (a) (vlax-safearray-get-element sa a))
(vl-sort-i x '>)
)
)
lst3
) ;求随机种子对应的切分表
)
)
)
(setqai 1
nx 0
) ;初始化数据
;ai 与平均数绝对差值的和初始值不能为0
;nx 遗传次数
(while (not (or (= ai 0) (= (setq nx (1+ nx)) 1000)))
; 与平均数绝对差值的和为0或遗传次数到达1000停止
(setq ai (car (mapcar 'cdr
(setqlst1
(vl-sort
(mapcar
'cons
lst1
(mapcar
'(lambda(x)
(f2 (mapcar
'cdr
(vl-sort
(mapcar 'cons x lst)
'(lambda (a b) (< (car a) (car b)))
)
)
;按照随机种子表(lst1的元素)对lst排序
t
)
;排序后的lst切割求对应的绝对差值
)
lst1
)
)
'(lambda (a b) (< (cdr a) (cdr b)))
;按照对应的绝对差值大小对随机种子表lst3排序更新排序后lst1
)
)
)
)
) ;计算与平均数绝对差值的和的最小值ai
(setq lst1 (mapcar 'car lst1));更新排序后lst1
(setq lst1
(list
(car lst1) ;最优种子
(f1 (length lst))
(f1 (length lst)) ;新加入两个随机种子
(mapcar
'(lambda(a b)
(if (> 0.5 (/ (rem (getvar "CPUTICKS") 1000) 1000.0))
a
b
)
)
(car lst1)
(cadr lst1)
) ;最优种子与次优种子杂交
)
)
)
(f2 (mapcar 'cdr
(vl-sort (mapcar 'cons (car lst1) lst)
'(lambda (a b) (< (car a) (car b)))
)
)
nil
) ;输出最终结果
) (divlst '(1 2 3 4 5 6 7 8 9) 4)
这个要出错 taoyi0727 发表于 2021-10-3 11:58
(divlst '(1 2 3 4 5 6 7 8 9) 4)
这个要出错
少想了两种情况打上补丁了 感谢 ！！ _$ (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 发表于 2021-10-4 20:55
遗传算法还可以优化。
增加种子数和 遗传次数可以不过算法优化 还没有想出来 ;;思路：粗分组=>优化(单项对调、多项对调)
;;优点：速度快
;;缺点：不一定能得到最优解
;;函数:(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::List: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::List:N-M lmin 1 (car nm)))
(setq new_lmin_t (XD::List:N-M lmin (+ (car nm) 2) (length lmin)))
(setq new_lmax_h (XD::List:N-M lmax 1 (cadr nm)))
(setq new_lmax_t (XD::List: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::List:N-M lmin 1 (car nm)))
(setq new_lmin_t (XD::List:N-M lmin (+ (car nm) 2) (length lmin)))
(setq new_lmax_h (XD::List:N-M lmax 1 (cadr nm)))
(setq new_lmax_t (XD::List: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::List:N-M lmin 1 (car nm)))
(setq new_lmin_t (XD::List:N-M lmin (+ (car nm) 2) (length lmin)))
(setq new_lmax_h (XD::List:N-M lmax 1 (cadr nm)))
(setq new_lmax_t (XD::List: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::List:DelSame (l)
(if l
(cons (car l) (XD::List:DelSame (vl-remove (car l) l)))
)
)
wrf610051 发表于 2021-10-5 07:57
;;思路：粗分组=>优化(单项对调、多项对调)
;;优点：速度快
;;缺点：不一定能得到最优解
我的 遗传 算法结合 你的 算法 出来 就差不多了 遗传算法有些不伦不类。
页:
[1]