[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: challenge: set partitions and power set
- Subject: Re: challenge: set partitions and power set
- From: adorf@eso.org
- Date: Fri, 4 Mar 94 17:45:09 -0500
- Apparently-to: info-mcl
Hello MCLers,
here is the promised posting of submissions to the set-partition and
power-set problem. There are quite a few very elegant solutions, some of
which are also extremely efficient.
Enjoy!
Hans-Martin Adorf
ST-ECF/ESO
Karl-Schwarzschild-Str. 2
D-85748 Garching b. Muenchen
Germany
Tel: +49-89-32006-261
Fax: +49-89-32006-480
Internet: adorf@eso.org
;;;;----------------------------------------------------------------------
;;;; set partition and power set - submissions to a request for Lisp code
;;;;
;;;; collected by
;;;; Hans-Martin Adorf
;;;; ST-ECF/ESO
;;;; Karl-Schwarzschild-Str. 2
;;;; D-85748 Garching b. Muenchen
;;;; adorf@eso.org
;;;;
;;;; submissions ordered according to their local submission dates/times
;;;;
;;;;----------------------------------------------------------------------
;;;-----------------------------------------------------------------------
;;; Andrew Houghton
;;; (ah0i@andrew.cmu.edu)
;;; 28-02-94 13:07
;;;-----------------------------------------------------------------------
;; POWER-SET
;;
;; Returns the power set of a list.
;; Arguments:
;; lst : a list
;; Result:
;; the power set of the passed list. This does not check sub-lists, so
;; lists within the top-level list will be treated as atomic elements
;; of the set.
;;
;; Method: Imagine a list, set, which
;; contains the symbols A and B. The power-set of set can be defined as
;; appending (first set) to each element of the power-set of (rest set),
;; then appending the resultant set to the power-set of (rest set).
;; So we call (power-set '(a b)).. which calls (power-set '(b)).. which
;; calls (power-set '()).. which returns (NIL). Now, b is appended to NIL
;; giving us (b), and (NIL) is appended, so it returns ((b) NIL). Now a
is
;; appended to each element, giving us ((a b) (a)), which is appended to
the
;; originally returned list, giving us ((a b) (a) (b) NIL).
;; original
(defun ps (lst)
(cond
((endp lst) '(nil))
(t (append
(mapcar #'(lambda (x) (cons (first lst) x)) (ps (rest lst)))
(ps (rest lst))))))
;; slightly reworked syntactically
(defun power-set (lst)
(if (endp lst)
'(nil)
(let ((head (first lst))
(ps (power-set (rest lst))))
(append (mapcar #'(lambda (x) (cons head x))
ps)
ps))))
#|
(with-count (power-set '(a b c d e f)))
|#
;;;-----------------------------------------------------------------------
;;; Espen J. Vestre, espen@coli.uni-sb.de
;;; Universit
;;; Computerlinguistik, Geb
;;; Postfach 1150, tel. +49 (681) 302 4501
;;; D-66041 SAARBRCKEN, Germany fax. +49 (681) 302 4351
;;; 28-02-94 14:26; modification 01-03-94 16:14; power-set 02-03-94
;;;-----------------------------------------------------------------------
;; elegant, brief implementation
(defun partitions (set)
"Compute all partitions of a general n-element set"
(if (= (length set) 1)
(list (list set))
(let ((first-elem (first set))
(partitions-rest (partitions (rest set))))
(append
(mapcar #'(lambda (partition)
(cons (list first-elem) partition))
partitions-rest)
(mapcan #'(lambda (partition)
(mapcar #'(lambda (set)
(subst (cons first-elem set)
set
partition))
partition))
partitions-rest)))))
;; faster, but less elegant implementation
(defun partitions (set)
"Compute all partitions of a general n-element set"
(if (= (length set) 1)
(list (list set))
(let ((first-elem (first set))
(partitions-rest (partitions (rest set))))
(append
(mapcar #'(lambda (partition)
(cons (list first-elem) partition))
partitions-rest)
(mapcan #'(lambda (partition)
(let ((before nil)
(after (rest partition))
(new-partitions nil))
(mapc #'(lambda(set)
(push (cons (cons first-elem set)
(append before after))
new-partitions)
(push set before)
(setf after (rest after)))
partition)
new-partitions))
partitions-rest)))))
#|
(with-count (partitions '(a b c d e f)))
|#
(defun power-set (set)
(sort (2^set (reverse set))
#'(lambda (x y) (< (length x) (length y)))))
(defun 2^set (set)
(let ((ps nil)
(n (length set)))
(dotimes (i (expt 2 n))
(let ((subset nil))
(dotimes (j n)
(when (logbitp j i)
(push (nth j set) subset)))
(push subset ps)))
ps))
|#
(with-count (power-set '(a b c d e f)))
(with-count (power-set '(a b c d e f g h i j k l)))
(with-count (2^set '(a b c d e f)))
|#
;;;-----------------------------------------------------------------------
;;; Dominique Bernardi
;;; Theorie des nombres, Mathematiques
;;; Universite P. et M Curie 4 place Jussieu P-75005 Paris France
;;; bernardi@mathp7.jussieu.fr
;;; 28-02-94 16:07; addition 03-03-94 15:50
;;;-----------------------------------------------------------------------
(defun power-set (s)
(if s
(let ((a (car s))
(b (power-set (cdr s))))
(append (mapcar #'(lambda (x) (cons a x)) b)
b))
'(())))
#|
(with-count (power-set '(a b c d e f)))
|#
(defun part (s)
(if s
(let ((a (car s)) (b (part (cdr s))))
(append (mapcar #'(lambda (x) (cons (list a) x)) b)
(mapcan #'(lambda (x) (amplify a x)) b)))
'(())))
(defun amplify (x s)
(if s
(let ((a (car s)) (b (amplify x (cdr s))))
(cons (cons (cons x a) (cdr s))
(mapcar #'(lambda (y) (cons a y)) b)))))
#|
(with-count (part '(a b c d e f)))
|#
;;;-----------------------------------------------------------------------
;;; Tom Kramer
;;; kramer@cme.nist.gov
;;; 28-02-94 18:19
;;;-----------------------------------------------------------------------
;; original
(defun powerset (liz)
(cond ((null liz)
(list nil))
(t
(let ((bottom (powerset (cdr liz))))
(merge 'list
(mapcar #'(lambda (subset) (cons (first liz) subset))
bottom)
bottom
#'(lambda (set1 set2) (> (length set1) (length
set2))))))))
;; slightly reworked syntactically
(defun power-set (set)
(if (null set)
(list nil)
(let ((bottom (power-set (cdr set))))
(merge 'list
(mapcar #'(lambda (subset) (cons (first set) subset))
bottom)
bottom
#'(lambda (set1 set2) (> (length set1) (length set2)))))))
#|
(with-count (power-set '(a b c d e f)))
|#
;;;-----------------------------------------------------------------------
;;; Geert-Jan van Opdorp
;;; Computer/Law Institute
;;; Vrije Universiteit
;;; Amsterdam, The Netherlands
;;; geertjan@cca.vu.nl
;;; 01-03-94 15:45
;;;
;;; I think for efficiency it is safe to change the append into
;;; nconc, provided that you change the initial-value from
;;; '(()) into (list nil).
;;;-----------------------------------------------------------------------
(defun power-set (set)
(reduce #'(lambda (result new-el)
(append (mapcar #'(lambda (result-elem)
(cons new-el result-elem))
result)
result))
set
:initial-value '(()) ))
;; (with-count (power-set '(a b c d e f)))
;;;-----------------------------------------------------------------------
;;; Phil Chu
;;; Internet: pchu@bbn.com
;;;-----------------------------------------------------------------------
(defun pset (new pset)
"Adjust list of partitions to take into account new element."
(if (null pset)
(list (list (list new)))
(let ((new-pset nil))
(dolist (set pset)
(push (cons (list new) ;case 1: new element is singleton set
set)
new-pset)
(dolist (s set) ;case 2: new element is member of some
subset in a partition
(push (subst (cons new s) s set) new-pset)))
new-pset)))
(defun make-pset (set)
"Given a list of items, return all possible partitions, i.e. a list of
list of lists."
(let ((result nil))
(dolist (item set)
(setq result (pset item result)))
result))
(defun print-pset (set)
"Given a list of items, print all the possible partitions"
(dolist (item (make-pset set))
(print item)))
;;; e.g. (print-pset '(a b c d))
;;;-----------------------------------------------------------------------
;;; Pete Steggles
;;; pjs@upper.ist.co.uk
;;; 02-03-94 14:29
;;;
;;; partition below does not compute all partitions of a set - hma
;;;-----------------------------------------------------------------------
;;; Here is an implementation of powerset and partition which uses an
;;; `abstract data type' to represent sets. Is the order in which
;;; elements are produced important? If so, there probably aren't any
;;; good recursive definitions. If not, this is the easiest recursive
;;; definition I know.
;;; `Abstract Data Type' definition for sets
;;; We use a binary tree representation of sets so that the union
;;; operation is complexity O(1). Note that with this specific
;;; representation there is no empty set -- in general this would
;;; be another constructor.
;;; Number of cons cells required is 2*O(n) where n is the number
;;; of elements in the set.
;;; Constructor functions
(defmacro set-elem (x) `(list 'set-elem ,x))
(defmacro set-union (x y) `(list 'set-union ,x ,y))
;;; Predicate on sets -- does it have more than one element?
(defmacro set-unionp (x) `(eq (car ,x) 'set-union))
;;; Selector functions
(defmacro get-lhs (x) `(cadr ,x))
(defmacro get-rhs (x) `(caddr ,x))
(defmacro get-set-elem (x) `(cadr ,x))
;;; Set counterpart of `mapcar'
(defun mapset (f x)
(if (set-unionp x)
(set-union (mapset f (get-lhs x)) (mapset f (get-rhs x)))
(set-elem (funcall f (get-set-elem x)))))
;;; List the elements of a set from left to right
(defun set2list (x xs)
(if (set-unionp x)
(set2list (get-lhs x) (set2list (get-rhs x) xs))
(cons (get-set-elem x) xs)))
;;; Make powerset, ensuring that the null set is the leftmost element
;;; of the powerset.
;;;
;;; Asymptotic Complexity (n is number of elements in argument):
;;; Time: O(2^n) (you can't do better than this)
;;; Space: O(n*(2^n)) (hard to do better and keep nil on the lhs)
;;;
;;; If space becomes a problem, a better approach is to lazily evaluate
;;; the powerset; but that is more work in Lisp.
(defun powerset (xs)
(if (null xs)
(set-elem nil)
(let ((ps (powerset (cdr xs))))
(set-union ps (mapset #'(lambda (x) (cons (car xs) x)) ps)))))
;;; Make powerset and convert it to a list -- the first element will
;;; be NIL
(defun powerlist (xs)
(set2list (powerset xs) nil))
;;; Make the list of all partitions (partitions x = set2list(powerset x -
{}))
(defun partition (xs)
(cdr (powerlist xs)))
;;; Alternatively, throw away your lisp system and use the lazy
;;; functional language Haskell, where
;;;
;;; powerset [] = [[]]
;;; powerset (x:xs) = ps ++ map (x :) ps where ps = powerset xs
;;;
;;; partition = tail . powerset
;;;
;;; Will do exactly the same job with lazy evaluation thrown in !
;;; You might be interested to know that you can get public-domain
;;; (ie free) implementations of Haskell.
#|
(with-count (powerset '(a b c d e f)))
(with-count (powerlist '(a b c d e f)))
(with-count (partition '(a b c c d e f)))
|#
;;;-----------------------------------------------------------------------
;;; Tom Kramer
;;; kramer@cme.nist.gov
;;; 03-03-94 11:19
;;;-----------------------------------------------------------------------
; all_partitions returns all partitions of a set liz into subsets.
; It concatenates all the partitions of liz with n subsets.
(defun all_partitions (liz)
(do* ((how_long (length liz))
(how_many how_long (1- how_many))
(answer (list (list liz))))
((eq how_many 1) answer)
(nconc answer (partition_into_n liz how_long how_many))))
; partition_into_n returns all partitions of a set liz into how_many
; subsets. The length of liz must be equal to how_long.
; Let A be the first element of liz.
; Observe that all partitions of liz into how_many subsets may be
; divided into two groups: those partitions in which A appears by itself
; in a subset, and those partitions of in which A does not appear
; by itself. The function finds those two groups and concatenates them.
; The first group is formed by finding all the partitions of the rest
; of liz into (how_many minus 1) subsets and adding (A) to each such
; partition.
; The second group is formed by finding all the partitions of the rest
; of liz in how_many subsets and, for each partition P, creating how_many
; new partitions by sticking A into each subset of P, one at a time
; and concatenating the resulting partitions together.
(defun partition_into_n (liz how_long how_many)
(cond ((eq how_many 1)
(list (list liz)))
((eq how_many how_long)
(list (mapcar #'list liz)))
(t
(nconc (mapcar #'(lambda (partition)
(cons (list (first liz)) partition))
(partition_into_n (rest liz)
(1- how_long) (1- how_many)))
(mapcan #'(lambda (partition)
(fill_each_one partition (first liz)))
(partition_into_n (rest liz)
(1- how_long) how_many))))))
; fill_each_one takes a partition and an item and returns a list of
; partitions. If the input partition has m sublists, a list of m partitions
; is returned. Each partition in the returned list is the same as the
; input partition, except that the item has been added to one of the
; sublists.
; example: (fill_each_one '((B C) (D)) 'A) => (((A B C) (D)) ((B C) (A D)))
(defun fill_each_one (partition item)
(do ((partition_list (mapcar #'(lambda (subset) (copy-tree partition))
partition))
(k (1- (length partition)) (1- k))
focus)
((minusp k) partition_list)
(setq focus (nth k (nth k partition_list)))
(rplacd focus (cons (first focus) (rest focus)))
(rplaca focus item)))
#|
(with-count (all_partitions '(a b c d e f)))
|#
;;;-----------------------------------------------------------------------
;;; An auxiliary output function
;;;-----------------------------------------------------------------------
(defmacro with-count (expr)
`(let ((result (time ,expr)))
(values result (length result))))
(defmacro with-count (expr)
`(let ((result (time ,expr)))
(length result)))