[LISP函数]：水果装蓝算法研究

chlh_jd

;|问题的提出：
有5种水果依次为梨、苹果、橙子、桃子、李子.
每种水果的数量依次为10,11,12,13,14;
最小重量依次为0.5、0.45、0.4、0.35、0.3kg;
同类水果的重量均从最小重量按0.05kg递增,如梨子的重量分别为(0.5 0.55 0.6 0.65 0.7 0.75 0.8 0.85 0.9 0.95);
分别取每种水果中的1个放入5个篮子内，篮子重量为0；
篮子次序同前述水果品种次序，要求装完水果后的篮子重量前者大于后者(如 (0.5 0.45 0.4 0.35 0.3)。
如何最快得出可行装蓝的所有方案？|;

(defun c:test (/ str1 off str2 lst)
  (setq
    str1 (getstring
           "请输入梨、苹果、橙子、桃子、李子...的最小重量，用,号隔开:"
         )
  )
  (setq off (getreal "请输入水果重量级差:"))
  (setq str2 (getstring "请依次输入前述水果的数量....，用,号隔开:"))
  (setq lst (main-fun str1 str2 off))
  (vl-file-delete "c:\\test.txt")
  (setq f_test (open "c:\\test.txt" "w"))
  (write-line
    (strcat "李子、桃子、橙子、苹果、梨...的装蓝方法共有"
            (rtos (length lst) 2 0)
            "种，如下:"
    )
    f_test
  )
  (prin1 lst f_test)
  (close f_test)
(princ "水果装蓝计算结束，结果请看c:\\test.txt")
(princ " 高山流水敬请指导，QQ：56454300，Email：chlh_jd@126.com")
)
;;;======================
(defun main-fun        (str1            str2       off          /             lst
                 ret            mid1       mid2          i  get-Ndim-IA-lst
                 get-Ndim-IA-lst-ACP get-Ndim-IA-lst-PS get-Ndim-IA-lst-Dctm
                )
  (defun string->lst (str / lst n s1 cha)
    (setq s1 ""
          n  0
    )
    (repeat (strlen str)
      (setq cha (substr str (setq n (1+ n)) 1))
      (if (= "," cha)
        (progn
          (if (/= s1 "")
            (setq lst (cons (atof s1) lst))
          )
          (setq s1 "")
        )
        (setq s1 (strcat s1 cha))
      )
    )
    (if        (/= s1 "")
      (setq lst (cons (atof s1) lst))
    )
    (REVERSE lst)
  )
;;;-------------------------
;;;普及串行算法(Universal serial algorithm)
  (defun get-Ndim-IA-lst
                         (ret / a b c d e i)
    (if        (< (length ret) 2)
      ret
      (progn
        (setq a        nil
              i        1
        )
        (while (setq b (nth i ret))
          (if (null a)
            (setq a (car ret))
          )
          (setq e nil)
          (foreach c b
            (foreach d a
              (if (filter (if (eq (type c) 'list)
                            (car c)
                            c
                          )
                          (if (eq (type d) 'list)
                            (car d)
                            d
                          )
                  )
                (setq e
                       (cons
                         (if (and (/= (listp c) 'list) (= (type d) 'list))
                           (cons c d)
                           (if (and (/= (type c) 'list) (/= (type d) 'list))
                             (list c d)
                             (append c d)
                           )
                         )
                         e
                       )
                )
              )
            )
          )
          (setq a e)
          (setq i (1+ i))
        )
        a
      )
    )
  )
  ;;;------------------------
  ;;;层叠加速并行算法(accelerated cascading parallel algorithm)
  ;;;只需O(N)计算时间的层叠加速并行算法;在VLISP由于超长链表间导致失败
  (defun get-Ndim-IA-lst-ACP (ret / len log_len i bl-lst mid_lst pre_lst end_lst)
    (setq len (length ret))
    (if        (< len 8)
      (get-Ndim-IA-lst ret)
      (progn ;_(setq len 30)       
        (setq log_len (fix (log len))
              i              1
              bl-lst  nil
              mid_lst nil
        )
        (repeat        len
          (setq mid_lst (cons (1- i) mid_lst))
          (if (= (rem i log_len) 0)
            (progn
              (setq bl-lst (cons (reverse mid_lst) bl-lst))
              (setq mid_lst nil)
            )
          )
          (setq i (1+ i))
        )
        (if (/= mid_lst nil)
          (setq bl-lst (cons (reverse mid_lst) bl-lst))
        )
        (setq bl-lst (reverse bl-lst))
        (setq i        1
              mid_lst nil
        )
        (foreach a bl-lst ;_(setq a (car bl-lst))
          (setq pre_lst nil)
          (foreach b a
            (setq pre_lst (cons (nth b ret) pre_lst))
          )
          (setq        mid_lst        (cons
                          (get-Ndim-IA-lst (reverse pre_lst))
                          mid_lst
                        )
          )
        )       
        (setq end_lst (get-Ndim-IA-lst (reverse mid_lst)))
      )
    )
  )
;;;--------------------
  ;;;原始分组算法
(defun get-Ndim-IA-lst-PS
                         (ret / new_ret_list new_mid_list mid item)
    (setq new_ret_list (car ret))
    (setq ret (cdr ret))
    (setq new_mid_list nil)
    (foreach mid (setq item (car ret))
      (foreach mid_list        new_ret_list
        (if (filter mid mid_list)
          (setq        new_mid_list
                 (cons (list mid mid_list) new_mid_list)
          )
        )
      )
    )
    (setq new_ret_list new_mid_list)
    (setq ret (cdr ret))
    (while (setq item (car ret))
      (setq ret (cdr ret))
      (setq new_mid_list nil)
      (foreach mid item
        (foreach mid_list new_ret_list
          (if (filter mid (car mid_list))
            (setq new_mid_list
                   (cons (cons mid mid_list) new_mid_list)
            )
          )
        )
      )
      (setq new_ret_list new_mid_list)
      (princ)
    )
    new_ret_list
  )
;;;--------------------
;;;二分并行法
  (defun get-Ndim-IA-lst-Dctm
         (ret / len len/2 new_ret_list new_mid_list mid item)
    (setq len          (length ret)
          mid_len (fix (log len))
          len/2          (fix (/ len 2))
    )
    (setq i 0
          bl-lst nil
    )
    (repeat len/2
      (setq i (1+ i))
      (setq bl-lst (cons (strcat "bl" (rtos i 2 0)) bl-lst))
    )
    (setq bl-lst (reverse bl-lst))
    (setq i 0)
    (repeat len/2
      (set (read (nth i bl-lst)) nil)
      (setq i (1+ i))
    )
    (setq i 0)
    (repeat len/2
      (setq mid_lst1 nil
            mid_lst2 nil
            new_mid_list
             nil
      )
      (setq mid_lst1 (nth (* 2 i) ret)
            mid_lst2 (nth (1+ (* 2 i)) ret)
      )
      (foreach mid mid_lst2
        (foreach mid_list mid_lst1
          (if (filter mid mid_list)
            (setq new_mid_list
                   (cons (list mid mid_list) new_mid_list)
            )
          )
        )
      )
      (set (read (nth i bl-lst)) new_mid_list);_bl1 bl2 bl3 bl4 bl5
      (setq i (1+ i))
    )
    (setq bl-lst (reverse bl-lst)
          i         1
    );_(setq i 1)
    (if        (= (/ len 2) len/2)
      (setq new_mid_list (eval (read (car bl-lst))))
      (progn
        (setq new_mid_list (eval (read (car bl-lst))))
        (setq new_ret           new_mid_list
              last_ret           (last ret)
              new_mid_list nil
        )
        (foreach mid last_ret
          (foreach mid_list new_ret
            (if        (filter mid (car mid_list))
              (setq new_mid_list
                     (cons (cons mid mid_list) new_mid_list)
              )
            )
          )
        )
      )
    )
    (while (< i len/2)
      (setq mid-lst2 (eval (read (nth i bl-lst))))
      (setq new_ret nil)
      (foreach mid new_mid_list ;_(setq mid (car new_mid_list))
        (foreach mid_list mid-lst2 ;_(setq mid_list (car mid-lst2))(append '(0.1 0.15) '(0.2 0.3))
          (if (filter (last mid) (car mid_list))
            (setq new_ret
                   (cons (append mid mid_list) new_ret)
            )
          )
        )
      )
      (setq new_mid_list new_ret)
      (setq i (1+ i))
    )
    (princ)
    new_mid_list
  )
;;;-------------------------
;;;获取等距差值列表
  (defun get-CVO-lst (val1 n off / lst val_mid)
    (setq lst          (list val1)
          val_mid val1
    )
    (repeat n
      (setq val_mid (+ val_mid off))
      (setq lst (cons val_mid lst))
    )
  )
  ;;;------------------
  ;;;过滤器
  (defun filter        (a1 a2)
    (< a1 a2)
  )
;;;------------------  
  (setq lst1 (string->lst str1))
  (setq lst2 (string->lst str2))
  (setq        i   0
        lst nil
        ret nil
  )
  (repeat (length lst1)
    (setq mid1 (nth i lst1)
          mid2 (nth i lst2)
    )
    (setq lst (get-cvo-lst mid1 (fix (1- mid2)) off))
    (setq ret (cons lst ret))
    (setq i (1+ i))
  )
  (setq ret (reverse ret))
  ;;(setq lst (get-Ndim-IA-lst ret));_与ps相同，只是代码少些，但速度次之
  ;;(setq lst (get-Ndim-IA-lst-PS ret));_目前最快，在小数量时比原始(While..(While...慢
  ;;(setq lst (get-Ndim-IA-lst-Dctm ret));_二分法，未体现优势，基本最慢
  (setq lst (get-Ndim-IA-lst-ACP ret));_并行似乎有些问题，无法体现优势，变成了自动多分法，推荐改进
)
;;;测试：：：：
;|(setq str1 "0.7,0.65,0.6,0.55,0.5,0.45,0.4,0.35,0.3,0.25,0.2,0.15,0.1,0.05"
      str2 "10,11,12,13,14,15,16,17,18,19,20,21,22,23,24"
      off 0.05)|; ;|15种水果|;
;|(setq str1 "0.5,0.45,0.4,0.35,0.3,0.25,0.2,0.15,0.1,0.05"
      str2 "13,14,15,16,17,18,19,20,21,22"
      off 0.05)|; ;|10种水果|;
;|(setq str1 "0.6,0.55,0.5,0.45,0.4,0.35,0.3,0.25,0.2,0.15,0.1,0.05"
      str2 "11,12,13,14,15,16,17,18,19,20,21,22"
      off 0.05)|; ;|12种水果|;
;|
(progn
(setq times 1)
(setq t1 (getvar "date"))
(repeat times (setq mid (main-fun str1 str2 off)))
  (setq t2 (getvar "date"))
  (princ (menucmd (strcat "M=$(edtime,"
                          (rtos (- t2 t1) 2 16)
                          ",HH:MM:SS:MSEC)"
                  )
         )
  )
)
(length mid)
(vl-file-delete "c:\\test.txt")
(setq f_test (open "c:\\test.txt" "w"))
  (prin1 mid f_test)
  (close f_test)|;

七叶

不错，能细说一下算法吗

高山流水

@七叶
抱歉，现在才看您的发帖。
由于是获取水果装篮的全部方案（组合问题），所以需要全局遍历，具体算法在帖中已有分述。
值得一提的是，在WIN7 64位系统 ACAD2011测试，似乎对Foreach函数进行了改进，貌似采用了多线程运算，编译后其效率极高。
另外，俄罗斯VLISP大师 ElpanovEvgeniy，有个函数非常经典，也与此相关，贴出来以供参考：

2. 
   
3. ;;;元素不重复排列组合
   
4. (defun get-nIA-lst  (l / f1 f2)
   
5.   ;;by ElpanovEvgeniy
   
6.   ;;from [url=http://www.theswamp.org/index.php?topic=34086.msg394120#msg394120]http://www.theswamp.org/index.php?topic=34086.msg394120#msg394120[/url]
   
7.   ;; 非常经典，有望改进 get-ialst
   
8.   ;; (get-nia-lst '(1 2 3 4))
   
9.   (setq f1 (lambda (a b)
   
10.       (if b
    
11.         (cons (append a (cdr b))
    
12.        (f1 (append a (list (car b))) (cdr b))
    
13.        ))))
    
14.   (setq f2 (lambda (l)
    
15.       (if l
    
16.         (cons (car l) (f2 (vl-remove (car l) (cdr l))))
    
17.         )))
    
18.   (if (cdr l)
    
19.     (f2
    
20.       (apply
    
21. (function append)
    
22. (mapcar
    
23.    (function (lambda (a b)
    
24.         (mapcar (function (lambda (b) (cons a b)))
    
25.          (get-nIA-lst b)
    
26.          )))
    
27.    l
    
28.    (f1 nil l))))
    
29.     (list l)))
    

<br /> ;;;元素不重复排列组合<br /> (defun get-nIA-lst  (l / f1 f2)<br />   ;;by ElpanovEvgeniy<br />   ;;from [url=http://www.theswamp.org/index.php?topic=34086.msg394120#msg394120]http://www.theswamp.org/index.php?topic=34086.msg394120#msg394120[/url]<br />   ;; 非常经典，有望改进 get-ialst<br />   ;; (get-nia-lst '(1 2 3 4)) <br />   (setq f1 (lambda (a b)<br />       (if b<br />         (cons (append a (cdr b))<br />        (f1 (append a (list (car b))) (cdr b))<br />        ))))<br />   (setq f2 (lambda (l)<br />       (if l<br />         (cons (car l) (f2 (vl-remove (car l) (cdr l))))<br />         )))<br />   (if (cdr l)<br />     (f2<br />       (apply<br /> (function append)<br /> (mapcar<br />    (function (lambda (a b)<br />         (mapcar (function (lambda (b) (cons a b)))<br />          (get-nIA-lst b)<br />          )))<br />    l<br />    (f1 nil l))))<br />     (list l)))<br />