(defun list-solutions (m n lbd ubd)
(cond ((not (<= (* lbd n) m (* ubd n))) ())
((= n 1) `((,m)))
(t
(loop for i from lbd to ubd nconc
(mapl (lambda (l) (push i (car l)))
(list-solutions (- m i) (1- n) (1+ i) ubd))))))
(defun group-solutions (m n lbd ubd)
(loop with sols = (list-solutions m n lbd ubd)
for i from 1
for s1 = sols then s2
for s2 = (member i s1 :key #'car :test #'/=)
while s1 collect (cons i (ldiff s1 s2))))
(defun disjoint (l1 l2) ; l1, l2 must be sorted
(declare (optimize (speed 3) (safety 0)))
(or (null l1)
(null l2)
(let ((a (car l1)) (b (car l2)))
(declare (fixnum a b))
(cond ((> a b) (disjoint l1 (cdr l2)))
((< a b) (disjoint (cdr l1) l2))
(t nil)))))
(defun merge-list (l1 l2) ; l1, l2 must be sorted
(do* ((head (cons () ()))
(tail head (cdr tail)))
(())
(cond ((endp l1) (setf (cdr tail) l2) (return (cdr head)))
((endp l2) (setf (cdr tail) l1) (return (cdr head)))
(t
(let ((a (car l1)) (b (car l2)))
(cond ((> a b)
(setf (cdr tail) (list b)
l2 (cdr l2)))
((< a b)
(setf (cdr tail) (list a)
l1 (cdr l1)))
(t
(setf (cdr tail) (list a)
l1 (cdr l1)
l2 (cdr l2)))))))))
(defun count-choices (n lists ex)
(if (= n 1)
(loop for x in (cdar lists) count (disjoint x ex))
(loop for x in (cdar lists) if (disjoint x ex) sum
(count-choices (1- n)
(remove-if (lambda (a) (member (car a) x)) (cdr lists))
(merge-list x ex)))))
(defun count-partitions (n)
(count-choices n (group-solutions (/ (* n (1+ (* n n))) 2) n 1 (* n n)) ()))
kozima
#4833()
[
Common Lisp
]
Rating2/2=1.00
枝刈りしようとしたらわけがわからなくなったので Common Lisp で書き直し。
最初に組み合わせを求めた後で「1を含む組」「1を含まなくて2を含む組」「1, 2を含まなくて3を含む組」……と分類します。こうすると、グループごとに探索の対象とするかしないかを決めることができてかなり範囲が狭まるようです。
disjoint がボトルネックになるようなのでここだけ最適化をかけています。実行時間は SBCL で 28 秒でした。
(defun list-solutions (m n lbd ubd) (cond ((not (<= (* lbd n) m (* ubd n))) ()) ((= n 1) `((,m))) (t (loop for i from lbd to ubd nconc (mapl (lambda (l) (push i (car l))) (list-solutions (- m i) (1- n) (1+ i) ubd)))))) (defun group-solutions (m n lbd ubd) (loop with sols = (list-solutions m n lbd ubd) for i from 1 for s1 = sols then s2 for s2 = (member i s1 :key #'car :test #'/=) while s1 collect (cons i (ldiff s1 s2)))) (defun disjoint (l1 l2) ; l1, l2 must be sorted (declare (optimize (speed 3) (safety 0))) (or (null l1) (null l2) (let ((a (car l1)) (b (car l2))) (declare (fixnum a b)) (cond ((> a b) (disjoint l1 (cdr l2))) ((< a b) (disjoint (cdr l1) l2)) (t nil))))) (defun merge-list (l1 l2) ; l1, l2 must be sorted (do* ((head (cons () ())) (tail head (cdr tail))) (()) (cond ((endp l1) (setf (cdr tail) l2) (return (cdr head))) ((endp l2) (setf (cdr tail) l1) (return (cdr head))) (t (let ((a (car l1)) (b (car l2))) (cond ((> a b) (setf (cdr tail) (list b) l2 (cdr l2))) ((< a b) (setf (cdr tail) (list a) l1 (cdr l1))) (t (setf (cdr tail) (list a) l1 (cdr l1) l2 (cdr l2))))))))) (defun count-choices (n lists ex) (if (= n 1) (loop for x in (cdar lists) count (disjoint x ex)) (loop for x in (cdar lists) if (disjoint x ex) sum (count-choices (1- n) (remove-if (lambda (a) (member (car a) x)) (cdr lists)) (merge-list x ex))))) (defun count-partitions (n) (count-choices n (group-solutions (/ (* n (1+ (* n n))) 2) n 1 (* n n)) ()))Rating2/2=1.00-0+