我也写了一个另类的数字表平均分组法

wrf610051

;;由于我的不小心，当时错传了文件(误传了试验过程中的文件)。在此感谢发现错误的大师。
;;2021.10.23重新覆盖上传下面内容

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

;;函数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:ist: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:ist: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:ist:RemoveE (car ll) l1 nil) ls_z))
                                                                (setq l1_new (reverse (wrf::list:sort l1_new)))
                                                               
                                                                (while ls_z
                                                                        (setq l2 (XD:ist: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: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 (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: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 (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: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 (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:ist:N-M ll 1 i)) (XD:ist: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:ist: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:ist: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:ist: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:ist: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:ist:DelSame (l)
  (if l
   (cons (car l) (XD:ist:DelSame (vl-remove (car l) l)))
)
)

小菜123

试了一下，结果不对，不知道是不是哪个函数对不上
(wrf3upp 3 7 '(5.4 5.0 4.8 4.2 2.8 2.8 2.8 2.8 2.8 2.8))
(2.2 (2.8 (2.8)) (4.8 (4.8)) (5.0 (5.0)))

wrf610051

小菜123 发表于 2021-10-5 20:52
试了一下，结果不对，不知道是不是哪个函数对不上
(wrf3upp 3 7 '(5.4 5.0 4.8 4.2 2.8 2.8 2.8 2.8 2.8 2 ...

;;====================
;;最外层只用了5个函数,在加载源文件后，分别试一下：
;;(xd::list:position-fuzz 4 '(1 2 3 4.021 5 6 7) 1e-1) ;;=>3
;;验证:XD:list:car-member-if和vl-position

;;(l-sort (list '(30 (10 10 10)) '(20 (10 10)) '(10 (10)));=>((10 (10)) (20 (10 10)) (30 (10 10 10)))
;;验证vl-sort-i

;(XD:ist:N-M '(2334 556 33 44 66 77 22) 3 5);=>(33 44 66)

;(XD:ist:sort '(5 4 2 0) '<);=>

;(XD:ist:DelSame '(0 1 2 3 2 3 4 5 0));=>(0 1 2 3 4 5)
;验证vl-remove

;(XD::math:rand 4 30);;应该不会出问题

;;如果上面没问题，可试一下：
;;(findterm '(76 71 45 9) '(92 73 48 10 3) 1.0) ;;(3 3)
;;(findterm '(76 71 45 9) '(92 73 48 10 3) 2.0) ;;(1 1)
;;(findterm '(76 71 45 9) '(92 73 48 10 3) 3.0) ;;(2 2)
;;(findterm '(76 71 45 9) '(92 73 48 10 3) 4.0) ;;(2 2)
;;(findterm '(76 71 45 9) '(92 73 48 10 3) 5.0) ;;(2 2)
;;(findterm '(76 71 45 9) '(92 73 48 10 3) 6.0) ;;(2 2)
;;(findterm '(76 71 45 9) '(92 73 48 10 3) 9.0) ;;nil

小菜123

createlst3和createlst4只是测试用，没有用到
(setq lst (reverse (XD::list:sort lst '<)))这句有点奇怪，为什么不直接 '>
有个函数有误，修改以后
这几个对不上：
(findterm '(76 71 45 9) '(92 73 48 10 3) 4.0) => (2 nil)
(findterm '(76 71 45 9) '(92 73 48 10 3) 6.0) => (1 1)
(findterm '(76 71 45 9) '(92 73 48 10 3) 9.0) => (2 2)

(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 (10.4 (5.4 5.0)) (11.2 (2.8 2.8 2.8 2.8)) (11.8 (4.8 4.2 2.8)))

wrf610051

最近我打不开明经CAD平台。感谢小菜123发现了我的错误，原来我上传文件时误传了调试过程中的文件。我已在1楼改正了。请你重新复制1楼的代码，再试一下。给大家带来了不便，表示歉意！

小菜123

谢谢楼主的源码，虽然看不懂，结果还不错。
youhua这个函数似乎不用了？wrf3upp_new这个函数也不知道有什么用，用它算出的结果也不对。前面的测试函数结果对不上的有：(findterm '(76 71 45 9) '(92 73 48 10 3) 9.0) => (2 2)
(findterm '(76 71 45 9) '(92 73 48 10 3) 6.0) => (1 1)

wrf610051

小菜123 发表于 2021-10-23 18:01
谢谢楼主的源码，虽然看不懂，结果还不错。
youhua这个函数似乎不用了？wrf3upp_new这个函数也不知道有什 ...

1. 当时想找到最优解，准备一个wrf3upp_new函数，结果难度大，放弃了。没有写成功。
2. 写findterm函数时，前后思路不同，追求最大获利与见利就收。目前代码中下面结果可以获利：
(findterm '(76 71 45 9) '(92 73 48 10 3) 9.0) => (2 2)
(findterm '(76 71 45 9) '(92 73 48 10 3) 6.0) => (1 1)

小菜123

那我的结果就是对的了，谢谢！