一个另类的数值表平均分组

wrf610051 · 发表于 2021-10-23 11:55:57

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;2021.10.05我在明经cad上发了这个文件，由于我的不小心，当时错传了文件(误传了试验过程中的文件)。在此感谢大师(小菜123)发现我的错误。
;;http://bbs.mjtd.com/forum.php?mo ... mp;extra=#pid898914
;;现在发在晓东论谈上，不知是否违规，若违规请提醒我删除。

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

;;函数:(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_new ( n lst / su a n li lst_out ll offset )
(setq su (apply '+ lst))
(setq a (/ su (* n 1.0)))
(while (> n 0)
(setq li (H_L lst a))
(setq lst_out (cons li lst_out))
(setq ll (cadr li))
(while ll
(setq lst (XD::List:RemoveE (car ll) lst nil))
(setq ll (cdr ll))
)
(setq n (- n 1))
)
(setq lst_out (l-sort lst_out))
(setq offset (- (car (car (reverse lst_out))) (car (car lst_out))))
(cons offset lst_out)
)
(defun wrf3upp ( n i lst / l1 l2 l3 su1 su2 su3 ll
minterm li sui newterm offset lll
)

(setq lst (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))
)

(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_new 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 anyx ( lst / sumlst lst)
(setq sumlst nil)
(while lst
(setq sumlst (cons (apply '+ (car lst)) sumlst))
(setq lst (cdr lst))
)
(setq sumlst (reverse sumlst))
)

(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)
)
(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)
  )
)
(defun findterm ( l1 l2 a / n m ll sn fu yn ni mi snlst )

(cond ((and (= (length l1) 1) (= (length l2) 1))
nil)
((= a 0)
nil)
(T
(setq n (length l1))
(setq m (length l2))
(setq ll l1)
(setq sn (fix (/ 60 (length l2))))
(if (<= sn 4) (setq sn 4))
(setq sn 4)
(setq fu (/ a sn 1.0))
(setq yn T)
(setq snlst (crlst5 sn))
(while (and yn snlst)
(setq ll l1)
(while (and ll yn)
(if (xd::list:position-fuzz (+ (car ll) (* fu (car snlst))) l2 (* fu 0.9))
(progn
(setq ni (- n (length ll)))
(setq mi (xd::list:position-fuzz (+ (car ll) (* fu (car snlst))) l2 (* fu 0.9)))
(setq yn nil)
)
)
(setq ll (cdr ll))
)
(setq snlst (cdr snlst))
)
(if yn
nil
(list ni mi)
)
)
)
)
(defun changeterm ( l1 l2 a / n m ll sn fu yn l1_new l2_new snlst )

(cond ((and (= (length l1) 1) (= (length l2) 1))
nil)
((= a 0)
nil)
(T
(setq n (length l1))
(setq m (length l2))
(setq ll l1)
(setq sn (fix (/ 60 (length l2))))
(if (<= sn 4) (setq sn 4))
(setq sn 4)
(setq fu (/ a sn 1.0))
(setq yn T)
(setq snlst (crlst5 sn))
(while (and yn snlst)
(setq ll l1)
(while (and ll yn)

(if (setq ls_z (findr_fu_k (+ (car ll) (* fu (car snlst)))
l2
(* fu 0.9)
))
(progn

(setq l1_new (append (XD::List:RemoveE (car ll) l1 nil) ls_z))
(setq l1_new (reverse (wrf::list:sort l1_new)))

(while ls_z
(setq l2 (XD::List:RemoveE (car ls_z) l2 nil))
(setq ls_z (cdr ls_z))
)
(setq l2_new (cons (car ll) l2))
(setq l2_new (reverse (wrf::list:sort l2_new)))
(setq yn nil)
)
)
(setq ll (cdr ll))
)
(setq snlst (cdr snlst))
)
(if yn
nil
(progn
(setq ll (list l1_new l2_new))

(setq ll (list (anyx ll) ll))
(apply 'mapcar (cons 'list ll))
)
)
)
)
)

(defun youhua ( 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 (wrf::list:sort new_lmin)))
(setq new_lmax (reverse (wrf::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 (wrf::list:sort new_lmin)))
(setq new_lmax (reverse (wrf::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 (wrf::list:sort new_lmin)))
(setq new_lmax (reverse (wrf::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 youhua_new ( 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 (changeterm lmin lmax (/ a 2.0)))

(setq ll (cons (car nm)(reverse (cons (cadr nm) (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 (changeterm lmin lmax (/ a 2.0)))

(setq ll (cons (car nm) (reverse (cons (cadr nm) (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 (changeterm lmin lmax (/ a 2.0)))

(setq ll (cons (car ll) (cons (car nm) (reverse (cons (cadr nm) (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 crlst5 ( i / n ll )
(setq n (* i 2))
(while (> n 0)
(setq ll (cons n ll))
(setq n (- n 1))
)
(setq ll (append (reverse (XD::List:N-M ll 1 i)) (XD::List:N-M ll (+ i 1) (- (length ll) 1))))
)
(defun findtwo ( r lst / lst2 lstsu ll i lstr )

(setq lst2 (apply 'mapcar (cons 'list (list lst (cdr lst)))))
(setq lstsu (mapcar '(lambda (x) (apply '+  x)) lst2))
(if (setq ll (member r lstsu))
(progn
(setq i (- (length lst) (length ll)))
(setq lstr (XD::List:N-M lst i (+ i (- 2 1))))
)
nil
)
)
(defun findthr ( r lst / lst2 lstsu i ll lstr )

(setq lst2 (apply 'mapcar (cons 'list (list lst (cdr lst) (cddr lst)))))
(setq lstsu (mapcar '(lambda (x) (apply '+  x)) lst2))
(if (setq ll (member r lstsu))
(progn
(setq i (- (length lst) (length ll) 1))
(setq lstr (XD::List:N-M lst i (+ i (- 3 1))))
)
nil
)
)
(defun powerset (L)
  (if (null L)
(list nil)
(apply (function (lambda (a) (append (mapcar '(lambda (x) (append (list (car L)) x)) a) a)))
         (list (powerset (cdr L)))
)
  )
)
(defun findr ( r lst / lst2 lstsu ll i lstr )
(setq lst2 (cdr (reverse (powerset lst))))
(setq lstsu (mapcar '(lambda (x) (apply '+  x)) lst2))
(if (setq ll (member r lstsu))
(progn
(setq i (- (length lstsu)(length ll)))
(setq lstr (nth i lst2))
)
nil
)
)
(defun findr_k ( r lst / ll)
(cond ((setq ll (member r lst))
(list (car ll)))
((setq ll (findtwo r lst))
ll)
((setq ll (findthr r lst))
ll)
(T
nil)
)
)
(defun findtwo_fu ( r lst fu / lst2 lstsu i lstr )

(setq lst2 (apply 'mapcar (cons 'list (list lst (cdr lst)))))
(setq lstsu (mapcar '(lambda (x) (apply '+  x)) lst2))
(if (setq i (xd::list:position-fuzz r lstsu fu))
(progn
(setq lstr (XD::List:N-M lst (+ i 1) (+ i 2)))
)
nil
)
)
(defun findthr_fu ( r lst fu / lst2 lstsu i lstr )

(setq lst2 (apply 'mapcar (cons 'list (list lst (cdr lst) (cddr lst)))))
(setq lstsu (mapcar '(lambda (x) (apply '+  x)) lst2))
(if (setq i (xd::list:position-fuzz r lstsu fu))
(progn
(setq lstr (XD::List:N-M lst (+ i 1) (+ i 3)))
)
nil
)
)
(defun powerset (L)
  (if (null L)
(list nil)
(apply (function (lambda (a) (append (mapcar '(lambda (x) (append (list (car L)) x)) a) a)))
         (list (powerset (cdr L)))
)
  )
)
(defun findr_fu ( r lst fu / lst2 lstsu i lstr )
(setq lst2 (cdr (reverse (powerset lst))))
(setq lstsu (mapcar '(lambda (x) (apply '+  x)) lst2))
(if (setq i (xd::list:position-fuzz r lstsu fu))
(progn
(setq lstr (nth i lst2))
)
nil
)
)
(defun findr_fu_k ( r lst fu / i ll )
(cond ((setq i (xd::list:position-fuzz r lst fu))
(list (nth i lst)))
((setq ll (findtwo_fu r lst fu))
ll)
((setq ll (findthr_fu r lst fu))
ll)
(T
nil)
)
)
(defun H_L (lst L)

  (setq i -1)
  (setq lst1 (mapcar '(lambda (x y)
   (progn
(setq i (+ i 1))
(list (if (> (+ x y) L) x (+ x y))
y
(if  (> (+ x y) L)
   (list x)
   (list  x y)
)
)
   )
)
                  (reverse (cdr (reverse lst)))
                  (cdr lst)
            )
)

  (while (cdr lst1)
   (setq lst1 (mapcar '(lambda (x y)
   (if (> (+ (car x) (cadr y)) L)
   (if (>= (car x)  (car y))
   (list (car x)
(cadr y)
(last x)
)
y
)
   (if (> (+ (car x) (cadr y)) (car y))
   (list (+ (car x) (cadr y))
(cadr y)
(cons (cadr y) (last x))
)
y
   )
)
)
                        (reverse (cdr (reverse lst1)))
                        (cdr lst1)
)
   )

)
  (cons (car (car lst1))(list (last (car lst1))))

)

(defun wrf::list:sort ( L / L1 LL)
(setq L1 (vl-sort-i L '<))
(setq LL nil)
(while L1
(setq LL (cons (nth (car L1) L) LL))
(setq L1 (cdr L1))
)
(reverse LL)
)

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

tzfcn · 发表于 2021-10-23 18:10:27

好代码，值得学习一下。

账号		自动登录	找回密码
密码			立即注册

[原创] 一个另类的数值表平均分组

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。