Author Topic: -={ Challenge }=- Get Permutations  (Read 7503 times)

0 Members and 1 Guest are viewing this topic.

irneb

  • Water Moccasin
  • Posts: 1794
  • ACad R9-2016, Revit Arch 6-2016
Re: -={ Challenge }=- Get Permutations
« Reply #30 on: February 25, 2013, 12:14:15 AM »
As usual, some of the greats were already where we're only starting  ;) :
http://autocad.xarch.at/stdlib/COMBINATIONS.LSP
Common sense - the curse in disguise. Because if you have it, you have to live with those that don't.

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Re: -={ Challenge }=- Get Permutations
« Reply #31 on: February 25, 2013, 03:24:19 AM »

Yep, Reini has a lot of people standing on his shoulders :)
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

--> Donate to theSwamp<--

Lee Mac

  • Seagull
  • Posts: 12411
  • London, England
Re: -={ Challenge }=- Get Permutations
« Reply #32 on: February 25, 2013, 09:25:34 AM »
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

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: -={ Challenge }=- Get Permutations
« Reply #33 on: June 19, 2020, 08:47:46 AM »
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.  
« Last Edit: June 19, 2020, 10:12:45 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2412
  • Marko Ribar, architect
Re: -={ Challenge }=- Get Permutations
« Reply #34 on: June 19, 2020, 07:27:11 PM »
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.
« Last Edit: June 24, 2020, 11:32:10 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

MP

  • Seagull
  • Posts: 17748
  • Have thousands of dwgs to process? Contact me.
Re: -={ Challenge }=- Get Permutations
« Reply #35 on: June 19, 2020, 07:32:40 PM »
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 ...
Engineering Technologist CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com http://cadanalyst.slack.com http://linkedin.com/in/cadanalyst

John Kaul (Se7en)

  • Administrator
  • Needs a day job
  • Posts: 9523
Re: -={ Challenge }=- Get Permutations
« Reply #36 on: June 19, 2020, 08:48:54 PM »
If you can find that text make a challenge post from it. Sounds fun.
TheSwamp.org (serving the CAD community since 2003)

Donate to TheSwamp.org

MP

  • Seagull
  • Posts: 17748
  • Have thousands of dwgs to process? Contact me.
Re: -={ Challenge }=- Get Permutations
« Reply #37 on: June 20, 2020, 12:43:01 AM »
OMG :-o

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

Link
Engineering Technologist CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com http://cadanalyst.slack.com http://linkedin.com/in/cadanalyst

Lee Mac

  • Seagull
  • Posts: 12411
  • London, England
Re: -={ Challenge }=- Get Permutations
« Reply #38 on: June 20, 2020, 08:36:57 AM »
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

  • Bull Frog
  • Posts: 243
Re: -={ Challenge }=- Get Permutations
« Reply #39 on: June 20, 2020, 09:12:14 AM »
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

  • Seagull
  • Posts: 17748
  • Have thousands of dwgs to process? Contact me.
Re: -={ Challenge }=- Get Permutations
« Reply #40 on: June 21, 2020, 12:39:12 PM »
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).
Engineering Technologist CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com http://cadanalyst.slack.com http://linkedin.com/in/cadanalyst

VovKa

  • Swamp Rat
  • Posts: 1282
  • Ukraine
Re: -={ Challenge }=- Get Permutations
« Reply #41 on: June 21, 2020, 03:33:25 PM »
being 62 isn't what it used to be ...
now we know the reason for your vast vocabulary... sir ;)
« Last Edit: June 21, 2020, 03:36:41 PM by VovKa »

MP

  • Seagull
  • Posts: 17748
  • Have thousands of dwgs to process? Contact me.
Re: -={ Challenge }=- Get Permutations
« Reply #42 on: June 22, 2020, 02:11:08 PM »
now we know the reason for your vast vocabulary... sir ;)

(not worthy or sarcasm?) Thanks! :laugh:
Engineering Technologist CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com http://cadanalyst.slack.com http://linkedin.com/in/cadanalyst

VovKa

  • Swamp Rat
  • Posts: 1282
  • Ukraine
Re: -={ Challenge }=- Get Permutations
« Reply #43 on: June 22, 2020, 04:08:38 PM »
(not worthy or sarcasm?) Thanks! :laugh:
i guess i am not the only one who loves the way you write (both languages of course)

MP

  • Seagull
  • Posts: 17748
  • Have thousands of dwgs to process? Contact me.
Re: -={ Challenge }=- Get Permutations
« Reply #44 on: June 22, 2020, 05:43:42 PM »
i guess i am the only one who loves the way you write (both languages of course)

Fixed me thinks. :)
Engineering Technologist CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.com http://cadanalyst.slack.com http://linkedin.com/in/cadanalyst