Topic: -={ Challenge }=- Get Permutations

[irneb]

As usual, some of the greats were already where we're only starting  :
http://autocad.xarch.at/stdlib/COMBINATIONS.LSP

[Kerry]

Yep, Reini has a lot of people standing on his shoulders

[Lee Mac]

There is a very neat way to obtain the k-th permutation or combination in a lexicographic order, so you can pick exactly the item you want, without calculating all the data.

A little explanation here:http://irenes-coding-blog.blogspot.com/2012/07/factorial-base-numbers-and-permutations.html

Absolutely fantastic article Gaston, thank you for sharing that!
I had never encountered 'factoradic numbers' before, but the number system is certainly incredibly useful when applied to permutations!

Here is my code for the 'nth-permutation' function as described in that article:

Code - Auto/Visual Lisp: [Select]

1. ;; Nth Permutation  -  Lee Mac
2. ;; Returns the nth lexicographic permutation of a given list
3. ;; e.g. (nth-permutation 4 '(0 1 2)) -> (2 0 1)
4.  
5. (defun nth-permutation ( n l / i )
6.     (setq i (dec->fac n))
7.     (repeat (- (length l) (length i))
8.         (setq i (cons 0 i))
9.     )
10.     (mapcar '(lambda ( n / x ) (setq x (nth n l) l (vl-remove x l)) x) i)
11. )
12.  
13. ;; Decimal to Factoradic  -  Lee Mac
14. ;; Converts an integer to a list of factoradic digits
15. ;; e.g. (dec->fac 81) -> (3 1 1 1 0)
16.  
17. (defun dec->fac ( n / f )
18.     (defun f ( n b )
19.         (if (< n b)
20.             (list n)
21.             (append (f (/ n b) (1+ b)) (f (rem n b) b))
22.         )
23.     )
24.     (f n 1)
25. )

Now to solve the related Project Euler problem:

Code - Auto/Visual Lisp: [Select]

1. _$ (nth-permutation 999999 '(0 1 2 3 4 5 6 7 8 9))
2. (2 7 8 3 9 1 5 4 6 0)

I very much enjoyed reading that article and writing those functions, thanks!

[ribarm]

Hi there, recently at cadtutor user named Jonathan H. asked a question how to solve problems with recursive routine that operates with large lists - there was an error throwing similar to hard error stack limit reached... If I can recall I stated that each function can be translated from recursive to iterative and opposite... Now this sub is tricky... So my challenge : All subs here posted are recursive and mine too - the task : Can this (permutate) sub be written only iterative in its entirety... My version is half iterative-half recursive and I don't know how to tackle this problem in another way to avoid recursion...

Code - Auto/Visual Lisp: [Select]

1. ;; Permutations, Marko Ribar, d.i.a. (permutate '(0 1 2)) ; (permutate '(0 1 1))
2. (defun permutate ( l / t1 t2 )
3.  
4.   (defun t1 ( l )
5.     (list
6.       (list (car l) (cadr l))
7.       (list (cadr l) (car l))
8.     )
9.   )
10.  
11.   (defun t2 ( l / al ll )
12.     (cond
13.       ( (null l)
14.         nil
15.       )
16.       ( (= (length l) 1)
17.         (list l)
18.       )
19.       ( (= (length l) 2)
20.         (t1 l)
21.       )
22.       ( (= (length l) 3)
23.         (append
24.           (mapcar (function (lambda ( x ) (cons (car l) x))) (t1 (cdr l)))
25.           (mapcar (function (lambda ( x ) (cons (cadr l) x))) (t1 (list (car l) (caddr l))))
26.           (mapcar (function (lambda ( x ) (cons (caddr l) x))) (t1 (list (car l) (cadr l))))
27.         )
28.       )
29.       ( (> (length l) 3)
30.         (apply (function append) (mapcar (function (lambda ( x ) (setq al (cons x al) ll (if (null ll) (cdr l) (cdr ll))) (mapcar (function (lambda ( y ) (cons x y))) (t2 (append (reverse (cdr al)) ll))))) l))
31.       )
32.     )
33.   )
34.  
35.   (t2 l)
36. )
37.  

I didn't wanted to start another topic as this one is also fine and it's also ---={Challenge}=---
Let's see if someone can solve it... I suppose MP would do it, but who knows, maybe my statement was false after all - it's just that I believe that it could be done differently, but I can't think a good way for now...

M.R.

[EDIT : Shorter version added...]

Code - Auto/Visual Lisp: [Select]

1. ;; Permutations, Marko Ribar, d.i.a. (permutate '(0 1 2)) ; (permutate '(0 1 1))
2. (defun permutate ( l / al ll )
3.   (cond
4.     ( (null l)
5.       nil
6.     )
7.     ( (= (length l) 1)
8.       (list l)
9.     )
10.     ( (> (length l) 1)
11.       (apply (function append) (mapcar (function (lambda ( x ) (setq al (cons x al) ll (if (null ll) (cdr l) (cdr ll))) (mapcar (function (lambda ( y ) (cons x y))) (permutate (append (reverse (cdr al)) ll))))) l))
12.     )
13.   )
14. )
15.  

[ribarm]

I solved and iterative approach... So I was right - every function can be written in both ways - iterative or recursive...
Just don't laugh - it looks too complex, but it works well...

Code - Auto/Visual Lisp: [Select]

1. (defun permutate-iterative ( l / factorial kk rr )
2.  
3.   (defun factorial ( n / r nn ) ; n - real number
4.     (setq nn 0 r 1.0)
5.     (while (<= (setq nn (1+ nn)) n)
6.       (setq r (* r nn))
7.     )
8.     (cond
9.       ( (null n)
10.         nil
11.       )
12.       ( (not (numberp n))
13.         nil
14.       )
15.       ( (minusp n)
16.         nil
17.       )
18.       ( (zerop n)
19.         0.0
20.       )
21.       ( t r )
22.     )
23.   )
24.  
25.   (defun permutate-2 ( l / r k n x xx al ll )
26.     (setq r (list (mapcar (function (lambda ( x ) (setq k (if (null k) 0 (1+ k))))) l)))
27.     (setq k nil)
28.     (setq n (factorial (length l)))
29.     (while (/= (length r) n)
30.       (setq x (car r))
31.       (if (equal r (list (mapcar (function (lambda ( x ) (setq k (if (null k) 0 (1+ k))))) l)))
32.         (setq r nil)
33.       )
34.       (setq k nil)
35.       (while (setq xx (car x))
36.         (setq al (cons xx al))
37.         (setq x (cdr x))
38.         (setq ll (append (reverse (cdr al)) x))
39.         (setq r (cons (cons xx ll) r))
40.       )
41.       (setq al nil ll nil)
42.     )
43.     (mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (nth y l))) x))) (vl-sort r (function (lambda ( a b ) (< (atoi (apply (function strcat) (mapcar (function (lambda ( x ) (itoa x))) a))) (atoi (apply (function strcat) (mapcar (function (lambda ( x ) (itoa x))) b))))))))
44.   )
45.  
46.   (setq kk 2)
47.   (repeat (- (length l) 2)
48.     (setq kk (1+ kk))
49.     (eval
50.       (list
51.         'defun (read (strcat "permutate-" (itoa kk)))
52.         '( l / r k n x xx al ll lll )
53.         '(setq r (list (mapcar (function (lambda ( x ) (setq k (if (null k) 0 (1+ k))))) l)))
54.         '(setq k nil)
55.         '(setq n (factorial (length l)))
56.         '(while (/= (length r) n)
57.           (setq x (car r))
58.           (if (equal r (list (mapcar (function (lambda ( x ) (setq k (if (null k) 0 (1+ k))))) l)))
59.             (setq r nil)
60.           )
61.           (setq k nil)
62.           (while (setq xx (car x))
63.             (setq al (cons xx al))
64.             (setq x (cdr x))
65.             (setq ll (append (reverse (cdr al)) x))
66.             (while (vl-position (cons xx ll) r)
67.               (setq lll ((eval (read (strcat "permutate-" (itoa (1- kk))))) ll))
68.               (while (vl-position (cons xx (setq ll (car lll))) r)
69.                 (setq lll (cdr lll))
70.               )
71.             )
72.             (setq r (cons (cons xx ll) r))
73.           )
74.           (setq al nil ll nil)
75.         )
76.         '(mapcar (function (lambda ( x ) (mapcar (function (lambda ( y ) (nth y l))) x))) (vl-sort r (function (lambda ( a b ) (< (atoi (apply (function strcat) (mapcar (function (lambda ( x ) (itoa x))) a))) (atoi (apply (function strcat) (mapcar (function (lambda ( x ) (itoa x))) b))))))))
77.       )
78.     )
79.   )
80.  
81.   (setq kk (length l))
82.   (cond
83.     ( (= kk 1)
84.       (setq rr (list l))
85.     )
86.     ( (> kk 1)
87.       (setq rr ((eval (read (strcat "permutate-" (itoa kk)))) l))
88.     )
89.   )
90.  
91.   (setq kk 1)
92.   (repeat (- (length l) 1)
93.     (setq kk (1+ kk))
94.     (set (read (strcat "permutate-" (itoa kk))) nil)
95.   )
96.   rr
97. )
98.  

M.R.

[MP]

Back in 1999+/-  (not a typ0) Reni Urban posted a challenge on comp.cad.autocad (iirc) to create a function that would take a list of items and return all the permutations. I wrote a function that used integer bit twiddling to arrange the permutations. It was not very speedy for lists sporting more than a dozen items if memory serves. That said, can't remember if it was recursive or iterative. If I wasn't tired I'd revisit - always fun to bash these out - but alas - being 62 isn't what it used to be ...

[JohnK]

If you can find that text make a challenge post from it. Sounds fun.

[MP]

OMG

I found the thread -- 21 years ago -- July 29, 1999 -- combinations -- not permutations -- iterative.

Link

[Lee Mac]

I wrote a function that used integer bit twiddling to arrange the permutations. It was not very speedy for lists sporting more than a dozen items if memory serves. That said, can't remember if it was recursive or iterative. If I wasn't tired I'd revisit - always fun to bash these out - but alas - being 62 isn't what it used to be ...

I think you posted a similar function here.

[Stefan]

Here is an iterative function.

Code - Auto/Visual Lisp: [Select]

1. (defun perm (l n / a b c d f i v s)
2.   (repeat (setq i n)
3.     (setq f (cons (read (strcat "p" (itoa i))) f)
4.           i (1- i)
5.     )
6.   )
7.   (setq f (list 'setq 's (list 'cons (cons 'list f) 's)))
8.   (repeat n
9.     (setq a (read (strcat "p" (itoa n)))
10.           c (read (strcat "l" (itoa n)))
11.           b (read (strcat "p" (itoa (setq n (1- n)))))
12.           d (read (strcat "l" (itoa n)))
13.           v (cons c v)
14.     )
15.     (setq f (list 'foreach a (if (zerop n) '(setq l1 l) (list 'setq c (list 'vl-remove b d))) f))
16.   )
17.   (eval (list 'defun 'f (cons '/ v) f))
18.   (f)
19.   (reverse s)
20. )

Code - Auto/Visual Lisp: [Select]

1. _$ (perm '(1 2 3) 3)
2. ((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))
3. _$ (perm '(1 2 3) 2)
4. ((1 2) (1 3) (2 1) (2 3) (3 1) (3 2))

Of course, because of vl-remove, the input list cannot contain duplicates. I usually don't use this function directly, but on 0...n-1 list, then apply nth of permutation on the original list.
Also, because the results gets bigger with increasing n, I usually send each permutation to a test function, without store it into s list.
For small n, I prefer this recursive function:

Code - Auto/Visual Lisp: [Select]

1. (defun perm (l n / f s)
2.   (defun f (l n r / l1)
3.     (if
4.       (= (length r) n)
5.       (setq s (cons (reverse r) s))
6.       (foreach x l (f (vl-remove x l) n (cons x r)))
7.     )
8.   )
9.   (f (reverse l) n nil)
10.   s
11. )

[MP]

I think you posted a similar function here.

It's bothersome I didn't recall that thread until you pointed it out.



I'll play my "That's what happens when you have > 17000 posts." card (all I have).

[VovKa]

being 62 isn't what it used to be ...

now we know the reason for your vast vocabulary... sir

[MP]

now we know the reason for your vast vocabulary... sir

(not worthy or sarcasm?) Thanks!

[VovKa]

(not worthy or sarcasm?) Thanks!

i guess i am not the only one who loves the way you write (both languages of course)

[MP]

i guess i am the only one who loves the way you write (both languages of course)

Fixed me thinks.