Consider:
(defun pairs (set)
(if (null set) nil
(append
(let ((r)
(e (car set)))
(dolist (x (cdr set) (nreverse r))
(push (list e x) r)))
(pairs (cdr set)))))
(defun unique-pairs (set)
(let ((pairs (pairs set))
(r))
(flet ((sieve (e l)
(if (member e l :test #'equal)
(remove e l :test #'equal)
l)))
(dolist (x pairs r)
(dolist (y pairs)
(unless (equal x y)
;; does x y cover the whole set?
(let ((s (copy-list set)))
(dolist (z (list (car x) (cadr x)
(car y) (cadr y)) s)
(setf s (sieve z s)))
(when (null s)
;; x y is a legal pair, do we have it
;; already?
(let ((xy (list x y))
(yx (list y x)))
(unless (or
(member xy r :test #'equal)
(member yx r :test #'equal))
(push xy r)))))))))
(nreverse r)))
CL-USER 5 > (pairs '(a b c d))
((a b) (a c) (a d) (b c) (b d) (c d))
CL-USER 6 > (unique-pairs '(a b c d))
(((a b) (c d)) ((a c) (b d)) ((a d) (b c)))
If pairs is ugly, unique-pairs is really terrible :-(
It stems from my still-non-lisp-thinking mode.
- the two outer dolists make it run in n^2
- the third dolist is a hack, with embedded knowledge
of the structure ((u v) (w x)) ie, it doesn't scale
to triplets let alone tuples
- this whole sieve construct, togetether with the
copy-list just to prune duplicates
- so is the final xy and yx to actually construct
the result (and doesb't scale either).
- I hate the setf at this point in the code
Can you read that I'm not happy? :-(
While I'm sure that loop/iterate can do wonders I'm
looking more for a "functional" style. Any taker?
Many Thanks
--
JFB
On May 26, 12:04 pm, verec <·····@mac.com> wrote:
> Consider:
>
> (defun pairs (set)
> (if (null set) nil
> (append
> (let ((r)
> (e (car set)))
> (dolist (x (cdr set) (nreverse r))
> (push (list e x) r)))
> (pairs (cdr set)))))
>
> (defun unique-pairs (set)
> (let ((pairs (pairs set))
> (r))
> (flet ((sieve (e l)
> (if (member e l :test #'equal)
> (remove e l :test #'equal)
> l)))
> (dolist (x pairs r)
> (dolist (y pairs)
> (unless (equal x y)
> ;; does x y cover the whole set?
> (let ((s (copy-list set)))
> (dolist (z (list (car x) (cadr x)
> (car y) (cadr y)) s)
> (setf s (sieve z s)))
> (when (null s)
> ;; x y is a legal pair, do we have it
> ;; already?
> (let ((xy (list x y))
> (yx (list y x)))
> (unless (or
> (member xy r :test #'equal)
> (member yx r :test #'equal))
> (push xy r)))))))))
> (nreverse r)))
>
> CL-USER 5 > (pairs '(a b c d))
> ((a b) (a c) (a d) (b c) (b d) (c d))
>
> CL-USER 6 > (unique-pairs '(a b c d))
> (((a b) (c d)) ((a c) (b d)) ((a d) (b c)))
>
> If pairs is ugly, unique-pairs is really terrible :-(
> It stems from my still-non-lisp-thinking mode.
> - the two outer dolists make it run in n^2
> - the third dolist is a hack, with embedded knowledge
> of the structure ((u v) (w x)) ie, it doesn't scale
> to triplets let alone tuples
> - this whole sieve construct, togetether with the
> copy-list just to prune duplicates
> - so is the final xy and yx to actually construct
> the result (and doesb't scale either).
> - I hate the setf at this point in the code
>
> Can you read that I'm not happy? :-(
>
> While I'm sure that loop/iterate can do wonders I'm
> looking more for a "functional" style. Any taker?
>
> Many Thanks
> --
> JFB
It's not clear to me what unique-pairs is trying to do. For inputs
other than 4-elements, it returns NIL.
??
Thanks
P� Mon, 26 May 2008 21:35:37 +0200, skrev Gene <············@gmail.com>:
> It's not clear to me what unique-pairs is trying to do. For inputs
> other than 4-elements, it returns NIL.
>
Seems to me we are talking abot combinations and permutations.
Why restrict yourself to a pair?
--------------
John Thingstad
On May 26, 5:42 pm, "John Thingstad" <·······@online.no> wrote:
> På Mon, 26 May 2008 21:35:37 +0200, skrev Gene <············@gmail.com>:
>
> > It's not clear to me what unique-pairs is trying to do. For inputs
> > other than 4-elements, it returns NIL.
>
> Seems to me we are talking abot combinations and permutations.
> Why restrict yourself to a pair?
My guess is that he wants all possible exact covers by 2-sets.
On May 26, 9:44 pm, Gene <············@gmail.com> wrote:
> On May 26, 5:42 pm, "John Thingstad" <·······@online.no> wrote:
>
> > På Mon, 26 May 2008 21:35:37 +0200, skrev Gene <············@gmail.com>:
>
> > > It's not clear to me what unique-pairs is trying to do. For inputs
> > > other than 4-elements, it returns NIL.
>
> > Seems to me we are talking abot combinations and permutations.
> > Why restrict yourself to a pair?
>
> My guess is that he wants all possible exact covers by 2-sets.
;;; For example,
CL-USER> (defun all-exact-covers-by-2-sets (set)
"Return a list of exact covers by 2-sets of given set with even
length."
(cond ((oddp (length set))
(error "Set ~a does not have even length." set))
((null set) (list nil)) ; The only exact cover has zero 2-sets.
(t (mapcan
(lambda (y)
(let ((pair (list (car set) y)))
(mapcar
(lambda (z) (cons pair z))
(all-exact-covers-by-2-sets (remove y (cdr set))))))
(cdr set)))))
ALL-EXACT-COVERS-BY-2-SETS
CL-USER> (all-exact-covers-by-2-sets '(a b c d e f))
(((A B) (C D) (E F)) ((A B) (C E) (D F)) ((A B) (C F) (D E))
((A C) (B D) (E F)) ((A C) (B E) (D F)) ((A C) (B F) (D E))
((A D) (B C) (E F)) ((A D) (B E) (C F)) ((A D) (B F) (C E))
((A E) (B C) (D F)) ((A E) (B D) (C F)) ((A E) (B F) (C D))
((A F) (B C) (D E)) ((A F) (B D) (C E)) ((A F) (B E) (C D)))
verec <·····@mac.com> writes:
> Consider:
>
> (defun pairs (set)
> (if (null set) nil
> (append
> (let ((r)
> (e (car set)))
> (dolist (x (cdr set) (nreverse r))
> (push (list e x) r)))
> (pairs (cdr set)))))
(defun pairs (set)
"Returns a set of all the pairs in the given SET"
(cond
((null set) '()) ; empty set has no pairs
((null (rest set)) '()) ; neither do singletons.
((null (rest (rest set))) (list set)) ; but pairs contain only one pair
(t (append (mapcar (lambda (y) (list (first set) y)) (rest set))
(pairs (rest set))))))
;; For an easy space optimization, we can replace append by nconc above.
(mapcar (function pairs)
'(()
(a)
(a b)
(a b c)
(a b c d)))
-->
(NIL NIL ((A B)) ((A B) (A C) (B C)) ((A B) (A C) (A D) (B C) (B D) (C D)))
> (defun unique-pairs (set)
I'll provide a nicer version tomorrow ;-)
> Can you read that I'm not happy? :-(
If you could stipulate clearly in English what these functions should
do, you could probably come with a clearer lisp version.
> While I'm sure that loop/iterate can do wonders I'm
> looking more for a "functional" style. Any taker?
Use mapcar, mapcar, etc.
--
__Pascal Bourguignon__
verec <·····@mac.com> writes:
> Consider:
>
> (defun pairs (set)
> (if (null set) nil
> (append
> (let ((r)
> (e (car set)))
> (dolist (x (cdr set) (nreverse r))
> (push (list e x) r)))
> (pairs (cdr set)))))
>
> CL-USER 5 > (pairs '(a b c d))
> ((a b) (a c) (a d) (b c) (b d) (c d))
>
I tried to bring some style to this with
CL-USER> (defmacro defcurry (name arg1 arg2 &body code)
`(defun ,name ,arg1 (lambda ,arg2 ,@code)))
DEFCURRY
CL-USER> (defcurry 2list (x)(y) (list x y))
2LIST
CL-USER> (funcall (2list 3) 4)
(3 4)
CL-USER> (defun pairs (list)
(mapcon (lambda(sublist)
(mapcar (2list (first sublist))
(rest sublist)))
list))
PAIRS
CL-USER> (pairs '(a b c d))
((A B) (A C) (A D) (B C) (B D) (C D))
CL-USER> (pairs '(a b c d e))
((A B) (A C) (A D) (A E) (B C) (B D) (B E) (C D) (C E) (D E))
>
> (defun unique-pairs (set)
> (let ((pairs (pairs set))
> (r))
> (flet ((sieve (e l)
> (if (member e l :test #'equal)
> (remove e l :test #'equal)
> l)))
> (dolist (x pairs r)
> (dolist (y pairs)
> (unless (equal x y)
> ;; does x y cover the whole set?
> (let ((s (copy-list set)))
> (dolist (z (list (car x) (cadr x)
> (car y) (cadr y)) s)
> (setf s (sieve z s)))
> (when (null s)
> ;; x y is a legal pair, do we have it
> ;; already?
> (let ((xy (list x y))
> (yx (list y x)))
> (unless (or
> (member xy r :test #'equal)
> (member yx r :test #'equal))
> (push xy r)))))))))
> (nreverse r)))
>
> CL-USER 6 > (unique-pairs '(a b c d))
> (((a b) (c d)) ((a c) (b d)) ((a d) (b c)))
Now I'm wondering what is unique-pairs supposed to do with
five items? The code looks very hard to follow. I cannot see
an extrapolatable pattern in the single example. I know,
I'll run the code!
CL-USER> (unique-pairs '(a b c d e))
NIL
CL-USER> (unique-pairs '(a b c))
(((A B) (A C)) ((A B) (B C)) ((A C) (B C)))
CL-USER> (unique-pairs '(a b c d e f))
NIL
CL-USER> (unique-pairs '(a b))
NIL
Err, I give in. What is the idea behind unique-pairs? What
is it trying to do? If you can tell me, that might also give
you a clue as to how to tell your REPL.
Alan Crowe
Edinburgh
Scotland
On 2008-05-26 21:04:27 +0100, Alan Crowe <····@cawtech.freeserve.co.uk> said:
[...]
> CL-USER> (defmacro defcurry (name arg1 arg2 &body code)
> `(defun ,name ,arg1 (lambda ,arg2 ,@code)))
> DEFCURRY
>
> CL-USER> (defcurry 2list (x)(y) (list x y))
> 2LIST
>
> CL-USER> (funcall (2list 3) 4)
> (3 4)
>
> CL-USER> (defun pairs (list)
> (mapcon (lambda(sublist)
> (mapcar (2list (first sublist))
> (rest sublist)))
> list))
> PAIRS
>
> CL-USER> (pairs '(a b c d))
> ((A B) (A C) (A D) (B C) (B D) (C D))
>
> CL-USER> (pairs '(a b c d e))
> ((A B) (A C) (A D) (A E) (B C) (B D) (B E) (C D) (C E) (D E))
Wow! :)
[...]
> Now I'm wondering what is unique-pairs supposed to do with
> five items?
Hmmm. Let's see if I can be better at English than I am
at Lisp :)
Pairs is concerned with things that come two at a time,
out of a bigger set. unique-pairs takes a collection of
such pairs and returns the minimal collection such that
every element of that collection is a set of pairs. Each
such element must refer to an individual of the orginal
set exactly once.
The math term must be something like "combination", except
that I am more interested in getting the actual arrangements
than counting them, I think it is pronounced "n chooses k".
and written "C(n, k)"
http://en.wikipedia.org/wiki/Combination
In other words, I wamt the set of things chosen k at a times
from a bigger set of n elements, where the order is non
significant, and where each set of result tuples (pair,
or triplet, or quadruplet, ...) contains each element
of the original set exactly once.
... But I wasn't dreaming of getting to the general case
in one go (ie: tuples) and started to get my feet wet
with pairs to start with...
--
JFB
verec <·····@mac.com> writes:
>
> Hmmm. Let's see if I can be better at English than I am
> at Lisp :)
>
> Pairs is concerned with things that come two at a time,
> out of a bigger set. unique-pairs takes a collection of
> such pairs and returns the minimal collection such that
> every element of that collection is a set of pairs. Each
> such element must refer to an individual of the orginal
> set exactly once.
>
> The math term must be something like "combination", except
> that I am more interested in getting the actual arrangements
> than counting them, I think it is pronounced "n chooses k".
> and written "C(n, k)"
>
> http://en.wikipedia.org/wiki/Combination
>
> In other words, I wamt the set of things chosen k at a times
> from a bigger set of n elements, where the order is non
> significant, and where each set of result tuples (pair,
> or triplet, or quadruplet, ...) contains each element
> of the original set exactly once.
>
> ... But I wasn't dreaming of getting to the general case
> in one go (ie: tuples) and started to get my feet wet
> with pairs to start with...
> --
> JFB
Here is some code which gives a lot of duplicates
(defmacro defcurry (name arg1 arg2 &body code)
`(defun ,name ,arg1 (lambda ,arg2 ,@code)))
(defcurry prefix-by (head)(tail) (cons head tail))
(defun choose (set n)
(cond ((zerop n) (list nil))
((null set) '())
(t (append (mapcar (prefix-by (first set))
(choose (rest set) (- n 1)))
(choose (rest set) n)))))
(defun tuple-cover (set size)
(assert (zerop (mod (length set) size)))
(if (<= (length set) size)
(list (list set))
(mapcan (pick-from set size)
(choose set size))))
(defcurry pick-from (set size)(prefix)
(let ((remainder (set-difference set prefix)))
(mapcar (prefix-by prefix)
(tuple-cover remainder size))))
CL-USER> (tuple-cover '(a b c d e f) 2)
(((A B) (F E) (C D)) ((A B) (F D) (C E)) ((A B) (F C) (D E))
((A B) (E D) (C F)) ((A B) (E C) (D F)) ((A B) (D C) (E F))
((A C) (F E) (B D)) ((A C) (F D) (B E)) ((A C) (F B) (D E))
((A C) (E D) (B F)) ((A C) (E B) (D F)) ((A C) (D B) (E F))
((A D) (F E) (B C)) ((A D) (F C) (B E)) ((A D) (F B) (C E))
((A D) (E C) (B F)) ((A D) (E B) (C F)) ((A D) (C B) (E F))
((A E) (F D) (B C)) ((A E) (F C) (B D)) ((A E) (F B) (C D))
((A E) (D C) (B F)) ((A E) (D B) (C F)) ((A E) (C B) (D F))
((A F) (E D) (B C)) ((A F) (E C) (B D)) ((A F) (E B) (C D))
((A F) (D C) (B E)) ((A F) (D B) (C E)) ((A F) (C B) (D E))
((B C) (F E) (A D)) ((B C) (F D) (A E)) ((B C) (F A) (D E))
((B C) (E D) (A F)) ((B C) (E A) (D F)) ((B C) (D A) (E F))
((B D) (F E) (A C)) ((B D) (F C) (A E)) ((B D) (F A) (C E))
((B D) (E C) (A F)) ((B D) (E A) (C F)) ((B D) (C A) (E F))
((B E) (F D) (A C)) ((B E) (F C) (A D)) ((B E) (F A) (C D))
((B E) (D C) (A F)) ((B E) (D A) (C F)) ((B E) (C A) (D F))
((B F) (E D) (A C)) ((B F) (E C) (A D)) ((B F) (E A) (C D))
((B F) (D C) (A E)) ((B F) (D A) (C E)) ((B F) (C A) (D E))
((C D) (F E) (A B)) ((C D) (F B) (A E)) ((C D) (F A) (B E))
((C D) (E B) (A F)) ((C D) (E A) (B F)) ((C D) (B A) (E F))
((C E) (F D) (A B)) ((C E) (F B) (A D)) ((C E) (F A) (B D))
((C E) (D B) (A F)) ((C E) (D A) (B F)) ((C E) (B A) (D F))
((C F) (E D) (A B)) ((C F) (E B) (A D)) ((C F) (E A) (B D))
((C F) (D B) (A E)) ((C F) (D A) (B E)) ((C F) (B A) (D E))
((D E) (F C) (A B)) ((D E) (F B) (A C)) ((D E) (F A) (B C))
((D E) (C B) (A F)) ((D E) (C A) (B F)) ((D E) (B A) (C F))
((D F) (E C) (A B)) ((D F) (E B) (A C)) ((D F) (E A) (B C))
((D F) (C B) (A E)) ((D F) (C A) (B E)) ((D F) (B A) (C E))
((E F) (D C) (A B)) ((E F) (D B) (A C)) ((E F) (D A) (B C))
((E F) (C B) (A D)) ((E F) (C A) (B D)) ((E F) (B A) (C D)))
CL-USER> (tuple-cover '(a b c d e f) 3)
(((A B C) (F E D)) ((A B D) (F E C)) ((A B E) (F D C)) ((A B F) (E D C))
((A C D) (F E B)) ((A C E) (F D B)) ((A C F) (E D B)) ((A D E) (F C B))
((A D F) (E C B)) ((A E F) (D C B)) ((B C D) (F E A)) ((B C E) (F D A))
((B C F) (E D A)) ((B D E) (F C A)) ((B D F) (E C A)) ((B E F) (D C A))
((C D E) (F B A)) ((C D F) (E B A)) ((C E F) (D B A)) ((D E F) (C B A)))
Looks like you've got yourself a tricky puzzle there.
Alan Crowe
Edinburgh
Scotland
On May 27, 12:56 pm, Alan Crowe <····@cawtech.freeserve.co.uk> wrote:
> verec <·····@mac.com> writes:
>
> > Hmmm. Let's see if I can be better at English than I am
> > at Lisp :)
>
> > Pairs is concerned with things that come two at a time,
> > out of a bigger set. unique-pairs takes a collection of
> > such pairs and returns the minimal collection such that
> > every element of that collection is a set of pairs. Each
> > such element must refer to an individual of the orginal
> > set exactly once.
>
> > The math term must be something like "combination", except
> > that I am more interested in getting the actual arrangements
> > than counting them, I think it is pronounced "n chooses k".
> > and written "C(n, k)"
>
> >http://en.wikipedia.org/wiki/Combination
>
> > In other words, I wamt the set of things chosen k at a times
> > from a bigger set of n elements, where the order is non
> > significant, and where each set of result tuples (pair,
> > or triplet, or quadruplet, ...) contains each element
> > of the original set exactly once.
>
> > ... But I wasn't dreaming of getting to the general case
> > in one go (ie: tuples) and started to get my feet wet
> > with pairs to start with...
> > --
> > JFB
>
> Here is some code which gives a lot of duplicates
>
> (defmacro defcurry (name arg1 arg2 &body code)
> `(defun ,name ,arg1 (lambda ,arg2 ,@code)))
>
> (defcurry prefix-by (head)(tail) (cons head tail))
>
> (defun choose (set n)
> (cond ((zerop n) (list nil))
> ((null set) '())
> (t (append (mapcar (prefix-by (first set))
> (choose (rest set) (- n 1)))
> (choose (rest set) n)))))
>
> (defun tuple-cover (set size)
> (assert (zerop (mod (length set) size)))
> (if (<= (length set) size)
> (list (list set))
> (mapcan (pick-from set size)
> (choose set size))))
>
> (defcurry pick-from (set size)(prefix)
> (let ((remainder (set-difference set prefix)))
> (mapcar (prefix-by prefix)
> (tuple-cover remainder size))))
>
> CL-USER> (tuple-cover '(a b c d e f) 2)
> (((A B) (F E) (C D)) ((A B) (F D) (C E)) ((A B) (F C) (D E))
[ output trimmed ]
>
> Looks like you've got yourself a tricky puzzle there.
Alan, this defcurry is quite beautiful. I'm hooked.
[But I wonder if it causes optimizers to miss opportunities because
the generated closure is not obviously a constant at compile time...?]
To finish up what you started, you need only to declare a canonical
representation for tuples and covers. Lexicographic order (based on
the orginal list order) will work. Then note that to generate
canonical reps, it is sufficient to _always_ choose the first thus-far-
unchosen element to be the first of each tuple.
It's also necessary to define your own order-preserving (canonical)
set-difference operator because the library function is liable to
scramble things.
(defcurry prefix-by (head) (tail) (cons head tail))
(defun choices (set n)
(cond ((zerop n) (list nil))
((null set) '())
(t (append (mapcar (prefix-by (first set))
(choices (rest set) (- n 1)))
(choices (rest set) n)))))
(defun canonical-choices (set n)
(assert (and set (plusp n)))
(mapcar (prefix-by (first set))
(choices (rest set) (1- n))))
(defun tuple-cover (set size)
(assert (zerop (mod (length set) size)))
(if (<= (length set) size)
(list (list set))
(mapcan (pick-from set size)
(canonical-choices set size))))
(defun ordered-set-difference (a b)
(cond ((null a) nil)
((null b) a)
((eq (first a) (first b))
(ordered-set-difference (rest a) (rest b)))
(t (cons (first a)
(ordered-set-difference (rest a) b)))))
(defcurry pick-from (set size) (prefix)
(let ((remainder (ordered-set-difference set prefix)))
(mapcar (prefix-by prefix)
(tuple-cover remainder size))))
CL-USER> (tuple-cover '(a b c d e f) 2)
(((A B) (C D) (E F)) ((A B) (C E) (D F)) ((A B) (C F) (D E))
((A C) (B D) (E F)) ((A C) (B E) (D F)) ((A C) (B F) (D E))
((A D) (B C) (E F)) ((A D) (B E) (C F)) ((A D) (B F) (C E))
((A E) (B C) (D F)) ((A E) (B D) (C F)) ((A E) (B F) (C D))
((A F) (B C) (D E)) ((A F) (B D) (C E)) ((A F) (B E) (C D)))
CL-USER> (tuple-cover '(a b c d e f) 3)
(((A B C) (D E F)) ((A B D) (C E F)) ((A B E) (C D F)) ((A B F) (C D
E))
((A C D) (B E F)) ((A C E) (B D F)) ((A C F) (B D E)) ((A D E) (B C
F))
((A D F) (B C E)) ((A E F) (B C D)))
On May 28, 12:07 am, Gene <············@gmail.com> wrote:
> On May 27, 12:56 pm, Alan Crowe <····@cawtech.freeserve.co.uk> wrote:
>
>
>
>
>
> > verec <·····@mac.com> writes:
>
> > > Hmmm. Let's see if I can be better at English than I am
> > > at Lisp :)
>
> > > Pairs is concerned with things that come two at a time,
> > > out of a bigger set. unique-pairs takes a collection of
> > > such pairs and returns the minimal collection such that
> > > every element of that collection is a set of pairs. Each
> > > such element must refer to an individual of the orginal
> > > set exactly once.
>
> > > The math term must be something like "combination", except
> > > that I am more interested in getting the actual arrangements
> > > than counting them, I think it is pronounced "n chooses k".
> > > and written "C(n, k)"
>
> > >http://en.wikipedia.org/wiki/Combination
>
> > > In other words, I wamt the set of things chosen k at a times
> > > from a bigger set of n elements, where the order is non
> > > significant, and where each set of result tuples (pair,
> > > or triplet, or quadruplet, ...) contains each element
> > > of the original set exactly once.
>
> > > ... But I wasn't dreaming of getting to the general case
> > > in one go (ie: tuples) and started to get my feet wet
> > > with pairs to start with...
> > > --
> > > JFB
>
> > Here is some code which gives a lot of duplicates
>
> > (defmacro defcurry (name arg1 arg2 &body code)
> > `(defun ,name ,arg1 (lambda ,arg2 ,@code)))
>
> > (defcurry prefix-by (head)(tail) (cons head tail))
>
> > (defun choose (set n)
> > (cond ((zerop n) (list nil))
> > ((null set) '())
> > (t (append (mapcar (prefix-by (first set))
> > (choose (rest set) (- n 1)))
> > (choose (rest set) n)))))
>
> > (defun tuple-cover (set size)
> > (assert (zerop (mod (length set) size)))
> > (if (<= (length set) size)
> > (list (list set))
> > (mapcan (pick-from set size)
> > (choose set size))))
>
> > (defcurry pick-from (set size)(prefix)
> > (let ((remainder (set-difference set prefix)))
> > (mapcar (prefix-by prefix)
> > (tuple-cover remainder size))))
>
> > CL-USER> (tuple-cover '(a b c d e f) 2)
> > (((A B) (F E) (C D)) ((A B) (F D) (C E)) ((A B) (F C) (D E))
>
> [ output trimmed ]
>
>
>
> > Looks like you've got yourself a tricky puzzle there.
>
> Alan, this defcurry is quite beautiful. I'm hooked.
>
> [But I wonder if it causes optimizers to miss opportunities because
> the generated closure is not obviously a constant at compile time...?]
>
> To finish up what you started, you need only to declare a canonical
> representation for tuples and covers. Lexicographic order (based on
> the orginal list order) will work. Then note that to generate
> canonical reps, it is sufficient to _always_ choose the first thus-far-
> unchosen element to be the first of each tuple.
>
> It's also necessary to define your own order-preserving (canonical)
> set-difference operator because the library function is liable to
> scramble things.
>
> (defcurry prefix-by (head) (tail) (cons head tail))
>
> (defun choices (set n)
> (cond ((zerop n) (list nil))
> ((null set) '())
> (t (append (mapcar (prefix-by (first set))
> (choices (rest set) (- n 1)))
> (choices (rest set) n)))))
>
> (defun canonical-choices (set n)
> (assert (and set (plusp n)))
> (mapcar (prefix-by (first set))
> (choices (rest set) (1- n))))
>
> (defun tuple-cover (set size)
> (assert (zerop (mod (length set) size)))
> (if (<= (length set) size)
> (list (list set))
> (mapcan (pick-from set size)
> (canonical-choices set size))))
>
> (defun ordered-set-difference (a b)
> (cond ((null a) nil)
> ((null b) a)
> ((eq (first a) (first b))
> (ordered-set-difference (rest a) (rest b)))
> (t (cons (first a)
> (ordered-set-difference (rest a) b)))))
>
> (defcurry pick-from (set size) (prefix)
> (let ((remainder (ordered-set-difference set prefix)))
> (mapcar (prefix-by prefix)
> (tuple-cover remainder size))))
>
> CL-USER> (tuple-cover '(a b c d e f) 2)
> (((A B) (C D) (E F)) ((A B) (C E) (D F)) ((A B) (C F) (D E))
> ((A C) (B D) (E F)) ((A C) (B E) (D F)) ((A C) (B F) (D E))
> ((A D) (B C) (E F)) ((A D) (B E) (C F)) ((A D) (B F) (C E))
> ((A E) (B C) (D F)) ((A E) (B D) (C F)) ((A E) (B F) (C D))
> ((A F) (B C) (D E)) ((A F) (B D) (C E)) ((A F) (B E) (C D)))
If you clean this up a bit with another Curried function, it's even
cooler:
(defmacro defcurry (name arg1 arg2 &body code)
`(defun ,name ,arg1 (lambda ,arg2 ,@code)))
(defcurry prefix-by (head) (tail) (cons head tail))
(defun choices (set n)
(cond ((zerop n) (list nil))
((null set) '())
(t (append (canonical-choices set n)
(choices (rest set) n)))))
(defun canonical-choices (set n)
(assert (and set (plusp n)))
(mapcar (prefix-by (first set))
(choices (rest set) (1- n))))
(defun tuple-cover (set size)
(assert (zerop (mod (length set) size)))
(if (<= (length set) size)
(list (list set))
(mapcan (pick-from set size)
(canonical-choices set size))))
(defcurry is-member (set) (item) (member item set))
(defcurry pick-from (set size) (prefix)
(mapcar (prefix-by prefix)
(tuple-cover (remove-if (is-member prefix) set) size)))