pairs
verec
(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
Pascal J. Bourguignon
> 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__
Gene
It's not clear to me what unique-pairs is trying to do. For inputs
other than 4-elements, it returns NIL.
??
Thanks
Alan Crowe
> 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))
> 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
John Thingstad
> 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
Gene
> På Mon, 26 May 2008 21:35:37 +0200, skrev Gene <gene.ress...@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.
Gene
;;; 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
[...]
> 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
Alan Crowe
>
> 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
Gene
[ 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)))
Gene
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)))
WJ
> verec <ve...@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.
>
Using Scheme:
(define (pairs x)
(if (< (length x) 2)
'()
(cons (take x 2) (pairs (cddr x)))))
(pairs (iota 15))
==> ((0 1) (2 3) (4 5) (6 7) (8 9) (10 11) (12 13))