In article <····················@crc.ricoh.com> ·····@crc.ricoh.com (Jamey Graham) writes:
>I am trying to find an implementation of Cy,x (the combination calculation)
>preferrably in common lisp so that I do not have to write it myself.
Here's what I use; it's intended to be efficient, so I'd appreciate any
corrections and improvements. Here (factorial n) = n! and (choose n m)
= C(n, m), except when n < 0 or m < 0 they return 0 rather than an error.
; ~/lisp/combinatorics.lsp
(provide "combinatorics")
(defmacro swapf (place-1 place-2)
`(rotatef ,place-1 ,place-2))
(defun factorial (n)
(declare (integer n))
(when (minusp n)
(return-from factorial 0))
(if (zerop n)
1 ; 0! = 1
; n! = n * (n-1) * ... * 2:
(do ((result (the integer n)))
((<= n 2) result)
(setq result (* result (decf n))))))
(defun choose (n m)
(declare (integer n m))
(when (or (minusp n) (minusp m) (> m n))
(return-from choose 0))
(let ((term (- (the integer n) (the integer m))))
; (choose n m) = (choose n (- n m)) efficiency hack:
(when (> m (/ n 2))
(swapf m term))
; choose(n, m) = (n * (n-1) * ... * (n - m + 1)) / m!
(do ((numerator 1))
((= n term) (/ numerator (factorial m)))
(setq numerator (* numerator n))
(decf n))))
--
Kevin Rodgers ········@cs.colorado.edu
Department of Computer Science (303) 492-8425
University of Colorado GO BUFFS!
Boulder CO 80309-0430 USA
In article <······················@colorado.edu>, ········@tigger.Colorado.EDU (Kevin Rodgers) writes:
> In article <····················@crc.ricoh.com> ·····@crc.ricoh.com (Jamey Graham) writes:
>>I am trying to find an implementation of Cy,x (the combination calculation)
>>preferrably in common lisp so that I do not have to write it myself.
>
> Here's what I use; it's intended to be efficient, so I'd appreciate any
> corrections and improvements. Here (factorial n) = n! and (choose n m)
> = C(n, m), except when n < 0 or m < 0 they return 0 rather than an error.
>
> ; ~/lisp/combinatorics.lsp
>
> (provide "combinatorics")
>
> (defmacro swapf (place-1 place-2)
> `(rotatef ,place-1 ,place-2))
>
> (defun factorial (n)
> (declare (integer n))
> (when (minusp n)
> (return-from factorial 0))
> (if (zerop n)
> 1 ; 0! = 1
> ; n! = n * (n-1) * ... * 2:
> (do ((result (the integer n)))
> ((<= n 2) result)
> (setq result (* result (decf n))))))
>
> (defun choose (n m)
> (declare (integer n m))
> (when (or (minusp n) (minusp m) (> m n))
> (return-from choose 0))
> (let ((term (- (the integer n) (the integer m))))
> ; (choose n m) = (choose n (- n m)) efficiency hack:
> (when (> m (/ n 2))
> (swapf m term))
> ; choose(n, m) = (n * (n-1) * ... * (n - m + 1)) / m!
> (do ((numerator 1))
> ((= n term) (/ numerator (factorial m)))
> (setq numerator (* numerator n))
> (decf n))))
The following is a little faster in MCL 2.0 on a Macintosh IIcx
(defun factorial (n &aux (result 1))
(declare (integer n result))
(do ()
((zerop n) result)
(setf result (* result n))
(decf n)))
(defun permutation (n m &aux (result 1))
(declare (integer n m result))
(setf m (- n m))
(do ()
((= n m) result)
(setf result (* result n))
(decf n))
)
(defun choose (n m)
(declare (integer n m))
(if (< (- n m) m) (choose n (- n m))
(/ (permutation n m) (factorial m))))
The following tests seem to show faster speeds for small n and m.
Less improvement is shown at larger values of n and m.
> (Dotimes (I 1000) (Choose 9 4)) (0.950 seconds)
> (Dotimes (I 1000) (Choose 9 4)) (0.940 seconds)
> (Dotimes (I 1000) (Choose 9 2)) (0.715 seconds)
> (Dotimes (I 1000) (Choose 9 2)) (0.716 seconds)
> (Dotimes (I 1000) (Choose 9 7)) (0.720 seconds)
> (Dotimes (I 1000) (Choose 9 7)) (0.715 seconds)
> (Dotimes (I 1000) (Choose 30 17)) (3.390 seconds)
> (Dotimes (I 1000) (Choose 30 17)) (3.346 seconds)
(Dotimes (I 1000) (Choose 9 4)) (0.521 seconds)
(Dotimes (I 1000) (Choose 9 4)) (0.521 seconds)
(Dotimes (I 1000) (Choose 9 2)) (0.363 seconds)
(Dotimes (I 1000) (Choose 9 2)) (0.364 seconds)
(Dotimes (I 1000) (Choose 9 7)) (0.421 seconds)
(Dotimes (I 1000) (Choose 9 7)) (0.422 seconds)
(Dotimes (I 1000) (Choose 30 17)) (3.251 seconds)
(Dotimes (I 1000) (Choose 30 17)) (3.303 seconds)
Even though this wasn't the answer to the original question, I'll just
make a few comments about how to speed up factorial and permutation.
········@ciit85.ciit.nrc.ca writes:
>The following is a little faster in MCL 2.0 on a Macintosh IIcx
>(defun factorial (n &aux (result 1))
> (declare (integer n result))
> (do ()
> ((zerop n) result)
> (setf result (* result n))
> (decf n)))
>(defun permutation (n m &aux (result 1))
> ....
Both factorial and permutation suffer from similar problems. You
didn't code them to minimize the overhead of bignum arithmetic. (If
you expect the arguments to be numbers such that n! and m! are always
fixnums, then my comments are superfluous, but since at least one of
your examples was (choose 30 17), I assume that wasn't the case.)
The key point to remember is that fixnum MULTIPLYs are much more
efficient than bignum multiplications, and that BIGNUM-BIGNUM
multiplications get more expensive the larger the multiplicands get.
One trick is to do the multiplication from the lower numbers up, since
that means that you can do many more fixnum multiplications before
doing bignum MULTIPLYs.
(defun factorial-1 (n &aux (result 1))
(declare (integer n result))
(do ((i 2))
((> i n) result)
(setf result (* result i))
(incf n)))
Imagine evaluating (factorial 100). After the first 5 or so terms in
your implementation every multiplication involves a bignum - including
the final multiplications by 2 and then by 1. In factorial-1, the
first M multiplications are fixnum MULTIPLYs, until result is a
bignum.
In fact, though, this doesn't give much of an improvement, since after
a small number of multiplications you are multiplying bignums anyway.
A better approach is to multiply adjacent numbers first, and then
collect the products up in a tree. The number of multiplications
remains the same, you are just associating the product in a different
way. The branching factor in the tree should be such that the lowest
level subtrees should multiply out to a fixnum.
(defun slightly-faster-factorial (n)
(let ((branching-factor (max 1 (floor (log most-positive-fixnum 2)
(log n 2)))))
(labels
((mult (low-bound upper-bound spread)
(if (> spread branching-factor)
(let* ((new-spread (floor spread 2))
(midpoint (+ low-bound new-spread)))
(* (mult lower-bound midpoint new-spread)
(mult (1+ mid-point) (- spread new-spread) upper-bound)))
(do* ((subterm low-bound)
(low-bound (1+ low-bound) (1+ low-bound)))
((> low-bound upper-bound) subterm)
(setf subterm (* subterm low-bound))))))
(mult 1 n (- n 1)))))
If you're worried about the (log xxx 2), convert it to (integer-length xxx 2).
If you're worried about the (floor spread 2), convert it to (ash xxx -1).
If you're worried about the extra overhead of the procedure calls, you should
realize that they're probably cheaper than the overhead you are saving of
consing bignums and multiplying ever-larger bignums.
A similar implementation of permutation would be appropriate.
As for "choose", it would be much more efficient if you intermixed the
multiplications and divisions, to avoid the excessive bignum
operations. The trick is to do this while still avoiding rational
operations. An efficient way of doing this is to use a sieve-like
trick to eliminate the factors in the denominator one-by-one. Or, if
you want to avoid this overhead and hairiness, simply use a bunch of
special purpose tricks. For example, first use all of the even
numbers in the denominator to cancel the even numbers in the numerator
- automatically halving each before beginning the computation.
(Remember to make sure there's an equal number of even-numbers in
each, it can be off by one.)
This last will speed up choose, even for small arguments.
>In article <····················@crc.ricoh.com> ·····@crc.ricoh.com (Jamey Graham) writes:
>>I am trying to find an implementation of Cy,x (the combination calculation)
>>preferrably in common lisp so that I do not have to write it myself.
>From: ········@tigger.Colorado.EDU (Kevin Rodgers)
>
>Here's what I use; it's intended to be efficient, so I'd appreciate any
>corrections and improvements. Here (factorial n) = n! and (choose n m)
>= C(n, m), except when n < 0 or m < 0 they return 0 rather than an error.
>
>; ~/lisp/combinatorics.lsp
>
...
oops, i failed to make myself clear. alas, what i am actually after is the
expansion of the items represented by Cy,x. y represents the length of the
set of items and x represents the size of the groupings you are interested
in. i am looking for the source code which produces all possible list
combinations, not the number of combinations. ex:
set: (A B C D E)
y=5, x=4
Cy,x = 5
results: (A B C D) (A B C E) (A B D E) (A C D E) (B C D E)
thus, the input might be the set of items (of which y could be determined)
and the x value. thanx.
Jamey Graham (·····@crc.ricoh.com) Ricoh California Research Center
·····@crc.ricoh.com (Jamey Graham) writes:
>>I am trying to find an implementation of Cy,x (the combination
>>calculation) preferrably in common lisp so that I do not have to write
>>it myself.
...
oops, i failed to make myself clear. alas, what i am actually after is the
expansion of the items represented by Cy,x. y represents the length of the
set of items and x represents the size of the groupings you are interested
in. i am looking for the source code which produces all possible list
combinations, not the number of combinations. ex:
set: (A B C D E)
y=5, x=4
Cy,x = 5
results: (A B C D) (A B C E) (A B D E) (A C D E) (B C D E)
thus, the input might be the set of items (of which y could be determined)
and the x value. thanx.
Here's a recursive version:
(defun choose-rec (l n)
(cond ((= n 1)
(mapcar #'list l))
((< (length l) n)
nil)
(t ; else
(append (choose-rec (cdr l) n)
(mapcar #'(lambda (x) (cons (car l) x))
(choose-rec (cdr l) (1- n)))))))
> (choose-rec '(a b c d e) 4)
((B C D E) (A C D E) (A B D E) (A B C D) (A B C E))
An iterative version would probably be considerably less clean, due to the
double recursion.
Note that the recursive version above over-CONSes. The APPEND could be NCONC,
and the last MAPCAR could be redone destructively also. Minor efficiency
might be gained by computing the length of the list ("y") once and passing it
down to recursive calls via an &optional parameter.
Enjoy.
Bruce Krulwich
········@ils.nwu.edu
········@zowie.ils.nwu.edu (Bruce Krulwich) writes:
>Here's a recursive version:
>(defun choose-rec (l n)
> (cond ((= n 1)
> (mapcar #'list l))
> ((< (length l) n)
> nil)
> (t ; else
> (append (choose-rec (cdr l) n)
> (mapcar #'(lambda (x) (cons (car l) x))
> (choose-rec (cdr l) (1- n)))))))
>An iterative version would probably be considerably less clean, due to the
>double recursion.
>Note that the recursive version above over-CONSes. The APPEND could be NCONC,
>and the last MAPCAR could be redone destructively also. Minor efficiency
>might be gained by computing the length of the list ("y") once and passing it
>down to recursive calls via an &optional parameter.
Depending on what the original requestor wanted, you might implement
something even more efficient (in term of consing, and the overhead
thereof (including GC)). If the requestor simply wanted to map over
every possibility, then choose-rec could take a third argument called
function, and apply function to each possibility, thus avoid consing
anything.
(You could do this a lot more cleanly, and still save the consing in
an implementation that supported stack-consing (i.e. stack-let, or
dynamic-extent, or whatever))
(defun choose (list n function)
(let ((choice (make-list n)))
;; choices are items remaining to choose from
;; c-length is the length of choices
;; tail is the tail of choice that has yet to be filled in with valid
;; values
;; t-length is the number of items to choose from choice, and should be
;; = to the length of tail.
(labels ((choose-1 (choices c-length tail t-length)
(if (null tail)
(funcall function choice)
(when (>= c-length t-length)
(do ((l choices (cdr choices))
(item (car choices) (car choices))
(i (1- c-length) (1- i)))
((< i t-length))
(setf (car tail) item)
(choose-1 l i (cdr tail) (1- t-length)))))))
(choose-1 list (length list) choice n))))
(If you are using an implementation that conses lexical closures (even
downward ones), then you can explicitly pass CHOICE and FUNCTION to
CHOOSE-1)
Of course, you achieve similar results to CHOOSE-REC with this version:
(defun print-em (list n)
(choose list n #'print))
(defun collect-em (list n)
(let ((choices nil))
(choose list n #'(lambda (choice)
(push (copy-list choice) choices)))
choices))
Unfortunately, I don't have any lisp implementation handy, so I might
have screwed up the implementation of choose, but the idea should be
clear.
········@Neon.Stanford.EDU (Michael Greenwald) writes:
>Unfortunately, I don't have any lisp implementation handy, so I might
>have screwed up the implementation of CHOOSE, but the idea should be
>clear.
I had a chance to play with it for a minute, and therefore fix
the typos/brainos, if anyone really cares:
(defun choose (list n function)
(let ((choice (make-list n)))
;; choices are items remaining to choose from
;; c-length is the length of choices
;; tail is the tail of choice that has yet to be filled in with valid
;; values
;; t-length is the number of items to choose from choice, and should be
;; = to the length of tail.
(labels ((choose-1 (choices c-length tail t-length)
(if (null tail)
(funcall function choice)
(when (>= c-length t-length)
(do* ((l choices (cdr l))
(item (car l) (car l))
(i c-length (1- i)))
((< i t-length))
(setf (car tail) item)
(choose-1 (cdr l) (1- i) (cdr tail) (1- t-length)))))))
(choose-1 list (length list) choice n))))
(defun print-em (list n)
(choose list n #'print))
(defun collect-em (list n)
(let ((choices nil))
(choose list n #'(lambda (choice) (push (copy-list choice) choices)))
choices))