Hello LISP gurus
I was creating a small function to return all the permutation of a
list:
(defun perm (prefix suffix)
(if (not suffix) (return-from perm prefix))
(loop for x in suffix
collect (perm (cons x prefix) (remove x suffix :count 1))))
Everything is working:
(perm NIL '(1 2 3))
> ((((3 2 1)) ((2 3 1))) (((3 1 2)) ((1 3 2))) (((2 1 3)) ((1 2 3))))
Expect each recursion level add its own level of ().
Naturally, I can add a global variable and push each permutation to
it, but I find it ugly.
There must be a better way!
Thanks
Tzach
··············@gmail.com writes:
> Hello LISP gurus
> I was creating a small function to return all the permutation of a
> list:
>
> (defun perm (prefix suffix)
> (if (not suffix) (return-from perm prefix))
> (loop for x in suffix
> collect (perm (cons x prefix) (remove x suffix :count 1))))
>
> Everything is working:
> (perm NIL '(1 2 3))
> > ((((3 2 1)) ((2 3 1))) (((3 1 2)) ((1 3 2))) (((2 1 3)) ((1 2 3))))
>
> Expect each recursion level add its own level of ().
> Naturally, I can add a global variable and push each permutation to
> it, but I find it ugly.
> There must be a better way!
That is very nice code. Making PERM a two argument function works
beautifully.
You need APPEND instead of COLLECT. You'll need to change
the base case too.
If you put the loop in the else leg of the IF you don't need
the RETURN-FROM
Alan Crowe
Edinburgh
Scotland
On Oct 6, 10:41 pm, Alan Crowe <····@cawtech.freeserve.co.uk> wrote:
> ··············@gmail.com writes:
> > Hello LISP gurus
> > I was creating a small function to return all the permutation of a
> > list:
>
> > (defun perm (prefix suffix)
> > (if (not suffix) (return-from perm prefix))
> > (loop for x in suffix
> > collect (perm (cons x prefix) (remove x suffix :count 1))))
>
> > Everything is working:
> > (perm NIL '(1 2 3))
> > > ((((3 2 1)) ((2 3 1))) (((3 1 2)) ((1 3 2))) (((2 1 3)) ((1 2 3))))
>
> > Expect each recursion level add its own level of ().
> > Naturally, I can add a global variable and push each permutation to
> > it, but I find it ugly.
> > There must be a better way!
>
> That is very nice code. Making PERM a two argument function works
> beautifully.
>
> You need APPEND instead of COLLECT. You'll need to change
> the base case too.
>
> If you put the loop in the else leg of the IF you don't need
> the RETURN-FROM
>
> Alan Crowe
> Edinburgh
> Scotland
Thanks Alan
Using APPEND all the time will not do.
I took your advice and use it in all cases but the almost last
iteration:
(defun perm (prefix suffix)
(if suffix
(loop for x in suffix
for res = (perm (cons x prefix) (remove x suffix :count 1))
for almost_last = (eq (length suffix) 1)
if almost_last collect res
else append res)
prefix))
Which solve the problem:
(perm NIL '(1 2 3))
>((3 2 1) (2 3 1) (3 1 2) (1 3 2) (2 1 3) (1 2 3))
Thanks
Tzach
On Oct 7, 2:50 pm, ··············@gmail.com wrote:
> On Oct 6, 10:41 pm, Alan Crowe <····@cawtech.freeserve.co.uk> wrote:
>
>
>
>
>
> > ··············@gmail.com writes:
> > > Hello LISP gurus
> > > I was creating a small function to return all the permutation of a
> > > list:
>
> > > (defun perm (prefix suffix)
> > > (if (not suffix) (return-from perm prefix))
> > > (loop for x in suffix
> > > collect (perm (cons x prefix) (remove x suffix :count 1))))
>
> > > Everything is working:
> > > (perm NIL '(1 2 3))
> > > > ((((3 2 1)) ((2 3 1))) (((3 1 2)) ((1 3 2))) (((2 1 3)) ((1 2 3))))
>
> > > Expect each recursion level add its own level of ().
> > > Naturally, I can add a global variable and push each permutation to
> > > it, but I find it ugly.
> > > There must be a better way!
>
> > That is very nice code. Making PERM a two argument function works
> > beautifully.
>
> > You need APPEND instead of COLLECT. You'll need to change
> > the base case too.
>
> > If you put the loop in the else leg of the IF you don't need
> > the RETURN-FROM
>
> > Alan Crowe
> > Edinburgh
> > Scotland
>
> Thanks Alan
> Using APPEND all the time will not do.
> I took your advice and use it in all cases but the almost last
> iteration:
>
> (defun perm (prefix suffix)
> (if suffix
> (loop for x in suffix
> for res = (perm (cons x prefix) (remove x suffix :count 1))
> for almost_last = (eq (length suffix) 1)
> if almost_last collect res
> else append res)
> prefix))
Often it's easier to reason about invariants if you don't try to do so
much with one loop.
;;; Insert x at all possible positions in lst and return list of
results.
(defun insert (x lst)
(loop for i from 0 to (length lst)
collect `(,.(subseq lst 0 i) ,x ,.(subseq lst i))))
;;; Return a list of all permutations of lst.
(defun perms (lst)
(if (null lst) (list nil)
(loop for perm in (perms (cdr lst))
append (insert (car lst) perm))))
This also avoids the equality test of (remove ), which might be a
problem if the permuted objects were complex.
Cheers,
Gene
I think you probably do not really want to collect the
permutations. this will only work for small lists. the
number of permutations grows very fast with increasing number
of elements. probably what you want to do is do something
to each perumutation, or find the permutations which match
an additional condition. Here is the library i use to
do permutation manipulation.
(defpackage perm-gen
(:use "COMMON-LISP")
(:export "COUNT-PERMUTATIONS"
"LIST-PERMUTATIONS"
"APPLY-PERMUTATIONS"
"FIND-FIRST-PERMUTATION"))
(in-package :perm-gen)
;; Like lconc except that it does not
;; advance the cdr of the conc to the end of the list
;; until necessary. for lconc and tconc the conc structure
;; usually is in a state where (cdr conc) is the last cons
;; cell of the list. in the case of lazy-lconc and lazy-tconc
;; (cdr conc) is just some cons cell but will be advanced to the
;; end on demand whenevery anything needs to be added.
(defun lazy-lconc (conc list)
(let ((ptr (cdr conc)))
(if ptr
(progn
(loop while (cdr ptr)
do (pop ptr))
(setf (cdr ptr) list)
(setf (cdr conc) ptr))
(progn
(setf (car conc) list)
(setf (cdr conc) list)))))
;; Efficiently append a single item descructively to the end
;; of a conc-list.
(defun lazy-tconc (conc item)
(lazy-lconc conc (list item)))
;; Remove the given element the first time it occurs
;; in the list consing as few cells as possible,
;; and only traversing as far as necessary into the list.
;; This function is completely non-destructive.
;; This is done by using tconc to collect the elements
;; of the list until we reach the unwanted item,
;; then using lconc to setf cdr to the remaining elements
;; without traversing any further.
;; An annoying side effect is that if the unwanted element
;; is not found then the entire list is re-allocated and then simply
;; thrown away for the garbage collector.
;; This does not matter for our application because we always
;; call remove-preserving-tail with an item that is for sure in
;; the list, but an in-general a safer implementation would save list
;; and return that value rather than returning nil in case the
;; item is unfound.
(defun remove-preserving-tail (item list)
(declare (list list))
(if (eql item (car list))
(cdr list)
(let ((conc (list nil)))
(declare (list conc))
(loop for sub on list
do (if (eql item (car sub))
(progn (lazy-lconc conc (cdr sub))
(return-from remove-preserving-tail (car conc)))
(lazy-tconc conc (car sub))))
list)))
;; Iteratively calculate all the permutations of LIMIT number
;; of elements from the list OBJECTS, and call the function VISIT
;; on each of them.
(defun apply-permutations (objects limit visit)
(declare (function visit)
(list objects))
(labels ((apply-rec (limit remaining current-perm)
(cond
((plusp limit)
(dolist (i remaining)
(apply-rec (1- limit)
(remove-preserving-tail i remaining)
(cons i current-perm))))
(t
(funcall visit current-perm)))))
(when (<= limit (length objects))
(apply-rec limit objects nil))))
;; Find a permutation of a given list of objects which is a 4 element
;; palindrome.
;; e.g., (find-first-permutation '(1 4 3 5 2 4 1 2)
;; 4
;; (lambda (perm)
;; (equal perm (reverse perm))))
;; --> (1 4 4 1)
(defun find-first-permutation (objects limit predicate)
(apply-permutations objects
limit
(lambda (perm)
(when (funcall predicate perm)
(return-from find-first-permutation perm)))))
;; Count the number of permutations of a given list which make
;; the given predicate TRUE.
;; e.g., count the number of symmetric permutations, (Palindromes)
;; (count-permutations '(1 2 2 3 3 2 2 4 4 1)
;; 5
;; (lambda (perm)
;; (equal perm (reverse perm))))
;; --> 1152
(defun count-permutations (objects limit &optional (predicate
(constantly t)))
(declare (optimize (speed 2))
(function predicate))
(let ((count 0))
(declare (integer count))
(apply-permutations objects
limit
(lambda (perm)
(when (funcall predicate perm)
(incf count))))
count))
(defun list-permutations (objects limit &optional (predicate
(constantly t)))
(let (perms)
(apply-permutations objects
limit
(lambda (perm)
(when (funcall predicate perm)
(push perm perms))))
perms))
;; examples
;; .
;; .
;; .
(defun print-it (obj)
(fresh-line)
(format t "~A" obj)
(force-output))
(defun visit-and-print (objects)
(apply-permutations objects
(length objects)
(lambda (x)
(print-it x)
(read-char))))
On Oct 7, 10:26 pm, Gene <············@gmail.com> wrote:
> On Oct 7, 2:50 pm, ··············@gmail.com wrote:
>
>
>
> > On Oct 6, 10:41 pm, Alan Crowe <····@cawtech.freeserve.co.uk> wrote:
>
> > > ··············@gmail.com writes:
> > > > Hello LISP gurus
> > > > I was creating a small function to return all the permutation of a
> > > > list:
>
··············@gmail.com writes:
> On Oct 6, 10:41 pm, Alan Crowe <····@cawtech.freeserve.co.uk> wrote:
> > ··············@gmail.com writes:
> > > Hello LISP gurus
> > > I was creating a small function to return all the permutation of a
> > > list:
> >
> > > (defun perm (prefix suffix)
> > > (if (not suffix) (return-from perm prefix))
> > > (loop for x in suffix
> > > collect (perm (cons x prefix) (remove x suffix :count 1))))
> >
> > > Everything is working:
> > > (perm NIL '(1 2 3))
> > > > ((((3 2 1)) ((2 3 1))) (((3 1 2)) ((1 3 2))) (((2 1 3)) ((1 2 3))))
> >
> > > Expect each recursion level add its own level of ().
> > > Naturally, I can add a global variable and push each permutation to
> > > it, but I find it ugly.
> > > There must be a better way!
> >
> > That is very nice code. Making PERM a two argument function works
> > beautifully.
> >
> > You need APPEND instead of COLLECT. You'll need to change
> > the base case too.
> >
> > If you put the loop in the else leg of the IF you don't need
> > the RETURN-FROM
> >
> > Alan Crowe
> > Edinburgh
> > Scotland
>
> Thanks Alan
> Using APPEND all the time will not do.
> I took your advice and use it in all cases but the almost last
> iteration:
>
> (defun perm (prefix suffix)
> (if suffix
> (loop for x in suffix
> for res = (perm (cons x prefix) (remove x suffix :count 1))
> for almost_last = (eq (length suffix) 1)
> if almost_last collect res
> else append res)
> prefix))
>
> Which solve the problem:
> (perm NIL '(1 2 3))
> >((3 2 1) (2 3 1) (3 1 2) (1 3 2) (2 1 3) (1 2 3))
That is a big surprise to me because I made sure I had
working code before posting my suggestions :-)
CL-USER> (defun perm (prefix suffix)
(if (not suffix) (list prefix)
(loop for x in suffix
append (perm (cons x prefix)
(remove x suffix :count 1)))))
PERM
CL-USER> (perm nil '(1 2 3))
((3 2 1) (2 3 1) (3 1 2) (1 3 2) (2 1 3) (1 2 3))
That is how I knew to include the hint "You'll need to
change the base case too."
I guess we both did
CL-USER> (defun perm (prefix suffix)
(if (not suffix) prefix
(loop for x in suffix
append (perm (cons x prefix)
(remove x suffix :count 1)))))
PERM
CL-USER> (perm nil '(1 2 3))
(3 2 1 2 3 1 3 1 2 1 3 2 2 1 3 1 2 3)
You can stop append from licking the brackets off the prefix
by switching to collect for the last level of recursion, but
I think wrapping a sacrificial level of brackets around the
suffix is neater.
--
Alan
P.S. Permutations are fun. Try working out how this works:
(defun permutations (start non-start prefix)
(cond ((and non-start (null start)) '())
((null start) (list (reverse prefix)))
(t (append (permutations (append (rest start)
non-start)
'()
(cons (first start)
prefix))
(permutations (rest start)
(cons (first start)
non-start)
prefix)))))
CL-USER> (permutations '(1 2 3) '() '())
((1 2 3) (1 3 2) (2 3 1) (2 1 3) (3 2 1) (3 1 2))
And for lovers of deviant deviousity here is a stepper:
(defun next (perm)
(do ((head (car perm) (car tail))
(tail (cdr perm) (or (cdr tail)(return nil))))
((< head (car tail))
(let* ((prefix (ldiff perm tail))
(place (member (car tail) prefix :test #'>)))
(revappend (cons (shiftf (car place)(car tail))
prefix)
(cdr tail))))))
NEXT
CL-USER> (loop for perm = '(1 2 3) then (next perm)
while perm
do (print perm))
(1 2 3)
(2 1 3)
(1 3 2)
(3 1 2)
(2 3 1)
(3 2 1)
NIL
Thanks Gene and jimka
Both of your suggestions are better than my version.
I'm using this code to find all permutation of a word in an English
dictionary. The motivation is solving crossword puzzle (I do not
consider it cheating ;)
On Oct 9, 5:41 am, ··············@gmail.com wrote:
> Thanks Gene and jimka
> Both of your suggestions are better than my version.
> I'm using this code to find all permutation of a word in an English
> dictionary. The motivation is solving crossword puzzle (I do not
> consider it cheating ;)
For the halibut, here's a version that's not pretty, but shows off how
to solve a problem not so different from your initial one *without*
involving global variables. It's a well-known algorithm, but one that
uses a very imperative style. Common Lisp is good for these sorts of
programs too. :)
(defun permutations (list)
(let* (;; You can avoid a bunch of consing and list traversal by
;; operating (destructively) on a vector copy of LIST.
(vector (coerce list 'vector))
(length (length vector))
;; This is the *lexical* variable you'll push your
;; permutations into.
(bag '()))
(labels (;; Local functions are a good way to hide nitty-gritty
;; details of recursion, and provide access to variables
;; in enoclosing lexical scopes. Use LABELS for recursion.
(swap (i j) (rotatef (aref vector i) (aref vector j)))
(permute-vector (i)
(if (= i length)
(push (coerce vector 'list) bag) ; This collects results.
(loop
:for j :from i :below length
:do (swap i j)
:do (permute-vector (1+ i))
:do (swap i j)))))
(permute-vector 0)
(nreverse bag))))
Cheers,
Pillsy
[Juho's suggestion is best for the OP's particular problem, but just to
demonstrate an aspect of Common Lisp Style on this problem]
* Pillsy <························@v3g2000hsg.XXXXXX> :
| For the halibut, here's a version that's not pretty, but shows off how
| to solve a problem not so different from your initial one *without*
| involving global variables. It's a well-known algorithm, but one that
| uses a very imperative style. Common Lisp is good for these sorts of
| programs too. :)
|
| (defun permutations (list)
| (let* (;; You can avoid a bunch of consing and list traversal by
| ;; operating (destructively) on a vector copy of LIST.
| (vector (coerce list 'vector))
| (length (length vector))
| ;; This is the *lexical* variable you'll push your
| ;; permutations into.
| (bag '()))
| (labels (;; Local functions are a good way to hide nitty-gritty
| ;; details of recursion, and provide access to variables
| ;; in enoclosing lexical scopes. Use LABELS for recursion.
| (swap (i j) (rotatef (aref vector i) (aref vector j)))
| (permute-vector (i)
| (if (= i length)
| (push (coerce vector 'list) bag) ; This collects results.
| (loop
| :for j :from i :below length
| :do (swap i j)
| :do (permute-vector (1+ i))
| :do (swap i j)))))
| (permute-vector 0)
| (nreverse bag))))
You can turn it around slightly pretty easily: In cases where you do not
want to cons up a big list of permutations but merely want to use each
permutation -- in the tradition of map* functions:
(defun permutations-f (list f)
"Call F repeatedly on a list containing in turn each permutation of
the given list LIST."
(let* ((vector (coerce list 'vector))
(length (length vector)))
(labels ((swap (i j) (rotatef (aref vector i) (aref vector j)))
(permute-vector (i)
(if (= i length)
(funcall f (coerce vector 'list)) ; XXX copy before call
(loop for j from i below length do
(swap i j) (permute-vector (1+ i)) (swap i j)))))
(permute-vector 0))))
This can be quickly be wrapped up in a macro:
(defmacro for-as-permutation-of ((var bag &optional RESULT) &body body)
"WITH-PERMUTATION (VAR BAG) &BODY. Execute BODY with VAR bound
to each of all permutations of the sequence BAG. Returns RESULT"
(let ((body-name (gensym)))
`(block nil
(flet ((,body-name (,var) ,@body))
(permutations-f ,BAG #',body-name)
,result))))
;; Ideally one would be able to extend LOOP with a
;; FOR x AS PERMUTATION-OF list
;; clause but that is wishful thinking :(
;; And your user code would look like this:
(for-as-permutation-of (x '(1 2 3 4))
(print x))
--
Madhu
··············@gmail.com writes:
> Thanks Gene and jimka
> Both of your suggestions are better than my version.
> I'm using this code to find all permutation of a word in an English
> dictionary. The motivation is solving crossword puzzle (I do not
> consider it cheating ;)
There's a nice way of doing that without generating all the
permutations of the word. First create a hash-table from the words in
your dictionary where the keys are produced by sorting the characters
in each word, and the values are lists of words:
(let ((table (make-hash-table :test 'equal)))
(dolist (word words)
(let ((key (sort (copy-seq words) #'char<)))
(push word (gethash key table))))
Then to get a list of all permutations of FOO in the dictionary you
just sort it and look up the result in the table:
(gethash (sort (copy-seq foo) #'char<) table)
[ Code just for illustration, not tested ]
--
Juho Snellman