Hi everyone,
I'm still new to Lisp. I'm doing this program to permute a given list.
This is how the program should run:
CL-USER> (permute '(a b))
((A B) (B A))
CL-USER> (permute '(a b c))
((A B C) (B A C) (B C A) (A C B) (C A B) (C B A))
CL-USER> (permute '(a b c d))
((A B C D) (B A C D) (B C A D) (B C D A) (A C B D) (C A B D) (C B A D)
(C B D A) (A C D B) (C A D B)
(C D A B) (C D B A) (A B D C) (B A D C) (B D A C) (B D C A) (A D B C)
(D A B C) (D B A C) (D B C A)
(A D C B) (D A C B) (D C A B) (D C B A))
This is my program. However, I feel that it's both lengthy and
verbose. Could you please shed some lights and insights. Thank you.
(defun insert-all (e l)
"Return a list of the first element inserted to every position"
(insert-all-aux e l nil))
(defun insert-all-aux (e l sofar)
(cond ((null l) (cons (append sofar (cons e l)) nil))
(t (cons (append sofar (cons e l))
(insert-all-aux e (rest l) (append sofar
(list (first l))))))))
; apply insert-all to a list being insertED-all
(defun insert-over (e l)
(if l
(append (insert-all e (first l))
(insert-over e (rest l)))))
;
(defun permute (l)
(if l
(append (insert-over (first l)
(permute (rest l))))
(list nil)))
Mark.
On Sep 25, 2:23 pm, mark <·············@gmail.com> wrote:
> Hi everyone,
>
> I'm still new to Lisp. I'm doing this program to permute a given list.
> This is how the program should run:
>
> CL-USER> (permute '(a b))
> ((A B) (B A))
> CL-USER> (permute '(a b c))
> ((A B C) (B A C) (B C A) (A C B) (C A B) (C B A))
> CL-USER> (permute '(a b c d))
> ((A B C D) (B A C D) (B C A D) (B C D A) (A C B D) (C A B D) (C B A D)
> (C B D A) (A C D B) (C A D B)
> (C D A B) (C D B A) (A B D C) (B A D C) (B D A C) (B D C A) (A D B C)
> (D A B C) (D B A C) (D B C A)
> (A D C B) (D A C B) (D C A B) (D C B A))
>
> This is my program. However, I feel that it's both lengthy and
> verbose. Could you please shed some lights and insights. Thank you.
This sounds like it might be homework, but your solution works, and is
the straightforward way to do it. There are some ways to make it more
concise.
> (defun insert-all (e l)
> "Return a list of the first element inserted to every position"
> (insert-all-aux e l nil))
>
> (defun insert-all-aux (e l sofar)
> (cond ((null l) (cons (append sofar (cons e l)) nil))
> (t (cons (append sofar (cons e l))
> (insert-all-aux e (rest l) (append sofar
> (list (first l))))))))
You can get rid of a function here by using an &optional variable, or
using labels:
;; with &optional variables, note, the default value
(defun insert-all (e l &optional (sofar ())) ;; or ... &optional
sofar)
...contents of insert-all-aux, but calls to insert-all-aux
replaced with calls to insert-all...)
;; with labels
(defun insert-all (e l)
(labels ((insert-all-aux (e l sofar)
...code for insert-all-aux...))
...code for insert-all...))
> ; apply insert-all to a list being insertED-all
> (defun insert-over (e l)
> (if l
> (append (insert-all e (first l))
> (insert-over e (rest l)))))
This is a use for mapcan[1]:
(defun insert-over (e l)
(mapcan #'(lambda (l) (insert-all e l)) l))
> (defun permute (l)
> (if l
> (append (insert-over (first l)
> (permute (rest l))))
> (list nil)))
It looks like you're applying append to a single argument here, which
is odd and unnecessary.
If you're not afraid of loop, you can do something like this:
(defun permute (list)
(cond
((endp list) list) ; no permutations of ()
((endp (cdr list)) (list list)) ; one permutation of (x)
(t (loop :for subpermutation :in (permute (cdr list)) :nconc
(loop :for i :from 0 :to (length subpermutation)
:collecting (append (subseq subpermutation 0 i)
(cons (car list) (subseq subpermutation i))))))))
Note the use of nconc when possible, to save some memory. This version
will still do a lot of consing from all the calls to append, but if
memory is an issue, it probably makes more sense to redesign the
algorithm.
//J
[1] http://www.lisp.org/HyperSpec/Body/fun_mapccm_ma_istcm_mapcon.html
Here is the library i normally use to do permutation calculations.
If anyone wants to give me feed-back or suggestions, i'll be happy
to hear them.
(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))))
jimka wrote:
> Here is the library i normally use to do permutation calculations.
> If anyone wants to give me feed-back or suggestions, i'll be happy
> to hear them.
Here is the code I use to generate permutations. It's
written in Scheme, but I suspect that Common Lisp is
also capable of expressing the algorithm, which is due
to someone named Zaks. Although the code written
below generates all of the permutations in batch mode,
the algorithm is more naturally expressed as a generator
that repeatedly cycles through all permutations of x [1].
(define (permutations x)
(let ((x x)
(perms (list x)))
(define (P n)
(if (> n 1)
(do ((j (- n 1) (- j 1)))
((zero? j)
(P (- n 1)))
(P (- n 1))
(F n))))
(define (F n)
(set! x (revloop x n (list-tail x n)))
(set! perms (cons x perms)))
(define (revloop x n y)
(if (zero? n)
y
(revloop (cdr x)
(- n 1)
(cons (car x) y))))
(define (list-tail x n)
(if (zero? n)
x
(list-tail (cdr x) (- n 1))))
(P (length x))
perms))
Will
[1] http://www.ccs.neu.edu/home/will/Twobit/src/perm9.scm
On Sep 25, 2:42 pm, Joshua Taylor <···········@gmail.com> wrote:
> On Sep 25, 2:23 pm, mark <·············@gmail.com> wrote:
>
>
>
> > Hi everyone,
>
> > I'm still new to Lisp. I'm doing this program to permute a given list.
> > This is how the program should run:
>
> > CL-USER> (permute '(a b))
> > ((A B) (B A))
> > CL-USER> (permute '(a b c))
> > ((A B C) (B A C) (B C A) (A C B) (C A B) (C B A))
> > CL-USER> (permute '(a b c d))
> > ((A B C D) (B A C D) (B C A D) (B C D A) (A C B D) (C A B D) (C B A D)
> > (C B D A) (A C D B) (C A D B)
> > (C D A B) (C D B A) (A B D C) (B A D C) (B D A C) (B D C A) (A D B C)
> > (D A B C) (D B A C) (D B C A)
> > (A D C B) (D A C B) (D C A B) (D C B A))
>
> > This is my program. However, I feel that it's both lengthy and
> > verbose. Could you please shed some lights and insights. Thank you.
>
> This sounds like it might be homework, but your solution works, and is
> the straightforward way to do it. There are some ways to make it more
> concise.
>
> > (defun insert-all (e l)
> > "Return a list of the first element inserted to every position"
> > (insert-all-aux e l nil))
>
> > (defun insert-all-aux (e l sofar)
> > (cond ((null l) (cons (append sofar (cons e l)) nil))
> > (t (cons (append sofar (cons e l))
> > (insert-all-aux e (rest l) (append sofar
> > (list (first l))))))))
>
> You can get rid of a function here by using an &optional variable, or
> using labels:
>
> ;; with &optional variables, note, the default value
> (defun insert-all (e l &optional (sofar ())) ;; or ... &optional
> sofar)
> ...contents of insert-all-aux, but calls to insert-all-aux
> replaced with calls to insert-all...)
>
> ;; with labels
>
> (defun insert-all (e l)
> (labels ((insert-all-aux (e l sofar)
> ...code for insert-all-aux...))
> ...code for insert-all...))
>
> > ; apply insert-all to a list being insertED-all
> > (defun insert-over (e l)
> > (if l
> > (append (insert-all e (first l))
> > (insert-over e (rest l)))))
>
> This is a use for mapcan[1]:
>
> (defun insert-over (e l)
> (mapcan #'(lambda (l) (insert-all e l)) l))
>
> > (defun permute (l)
> > (if l
> > (append (insert-over (first l)
> > (permute (rest l))))
> > (list nil)))
>
> It looks like you're applying append to a single argument here, which
> is odd and unnecessary.
>
> If you're not afraid of loop, you can do something like this:
>
> (defun permute (list)
> (cond
> ((endp list) list) ; no permutations of ()
> ((endp (cdr list)) (list list)) ; one permutation of (x)
> (t (loop :for subpermutation :in (permute (cdr list)) :nconc
> (loop :for i :from 0 :to (length subpermutation)
> :collecting (append (subseq subpermutation 0 i)
> (cons (car list) (subseq subpermutation i))))))))
>
> Note the use of nconc when possible, to save some memory. This version
> will still do a lot of consing from all the calls to append, but if
> memory is an issue, it probably makes more sense to redesign the
> algorithm.
>
> //J
>
> [1]http://www.lisp.org/HyperSpec/Body/fun_mapccm_ma_istcm_mapcon.html
Hi,
Thanks for the help. I'll need to look at your answer and think more
about it. By the way, this is not a homework. I'm just learning Lisp
by myself. The book I'm using is The Common Lisp's Companion. It's a
very concise one. Reading it is a bit like reading "A Gentle
Introduction to Symbolic Computation."
Mark.