Functional programming - permutations

For the Compleat Fan
Locked
cormullion
Posts: 2038
Joined: Tue Nov 29, 2005 8:28 pm
Location: latiitude 50N longitude 3W
Contact:

Functional programming - permutations

Post by cormullion »

Back to some functional programming, after all my regex hell. I'm trying to get a permutation example working (which I found at Stanford...

Code: Select all

(define (func element items)
  (map (fn (permutation) (cons element permutation)) 
       (permutations (clean 
                     (fn (f) (= element f)) 
                     items))))

(define (permutations items)
    (if (nil? items) 
        nil
        (apply list 
           (map 
           (fn (f) (func f items))
           items
           ))))

(println (permutations '(1 2 3 4)))

;-> (((1 (2 (3)) (2 (4))) (1 (3 (2)) (3 (4))) (1 (4 (2)) (4 (3)))) ((2 
   (1 (3)) 
   (1 (4))) 
  (2 (3 (1)) (3 (4))) 
  (2 (4 (1)) (4 (3)))) 
 ((3 (1 (2)) (1 (4))) (3 (2 (1)) (2 (4))) (3 (4 (1)) (4 (2)))) 
 ((4 (1 (2)) (1 (3))) (4 (2 (1)) (2 (3))) (4 (3 (1)) (3 (2)))))

It looks like it might work if I tweak it a bit. But there are too many parentheses....

newdep
Posts: 2038
Joined: Mon Feb 23, 2004 7:40 pm
Location: Netherlands

Post by newdep »

hahaha you just beat me with the link ;-) (got it from Lambda the ulitmate)

They have some very nice LOGIC programming theory online too..

http://standish.stanford.edu/bin/search ... k&offset=0
-- (define? (Cornflakes))

Fanda
Posts: 253
Joined: Tue Aug 02, 2005 6:40 am
Contact:

Post by Fanda »

Code: Select all

(define (permutations items)
	(if (empty? items)
		'(())
		(apply append
			(map (lambda (element)
					 (map (lambda (permutation) (cons element permutation))
						 (permutations (clean (fn (x)(= x element)) items))))
			  items))))

Code: Select all

> (permutations '(1 2 3))
((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))

Fanda
Posts: 253
Joined: Tue Aug 02, 2005 6:40 am
Contact:

Post by Fanda »

Code: Select all

(if (nil? items)
  nil
  (apply list ...
change to:

Code: Select all

(if (empty? items)
  '(())
  (apply append ...

cormullion
Posts: 2038
Joined: Tue Nov 29, 2005 8:28 pm
Location: latiitude 50N longitude 3W
Contact:

Post by cormullion »

Thanks Fanda - it's like you wave a magic wand and fix my mistakes...!

:)

Lutz
Posts: 5289
Joined: Thu Sep 26, 2002 4:45 pm
Location: Pasadena, California
Contact:

Post by Lutz »

instead of:

Code: Select all

(clean (fn (x)(= x element)) items)
do:

Code: Select all

(replace element (begin items))
and your code gets about 2 1/2 times faster. The 'begin' block wrapper returns a copy of 'items' and makes 'replace' non-destructive removing all occurences of 'element'.

Lutz

rickyboy
Posts: 607
Joined: Fri Apr 08, 2005 7:13 pm
Location: Front Royal, Virginia

Post by rickyboy »

Lutz wrote:

Code: Select all

(replace element (begin items))
and your code gets about 2 1/2 times faster. The 'begin' block wrapper returns a copy of 'items' and makes 'replace' non-destructive removing all occurences of 'element'.
Sweet!
(λx. x x) (λx. x x)

rickyboy
Posts: 607
Joined: Fri Apr 08, 2005 7:13 pm
Location: Front Royal, Virginia

Post by rickyboy »

A few more changes to the cormullion/Fanda version of permutations yields the following more general function k-permutations.

Code: Select all

(define (k-permutations k multiset)
  (let ((pivots (unique multiset)))
    (if (= k 1)
        (map list pivots)
      (mappend (lambda (p)
                 (map (lambda (k-1-perm) (cons p k-1-perm))
                      (k-permutations (- k 1) (remove1 p multiset))))
               pivots))))
Now you can get permutations of multisets (sets with repeated elements) and permutations of any size k, from 1 to the size of the set.

Code: Select all

> (k-permutations 3 '(1 2 3))
((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))
> (k-permutations 4 '(1 2 3 1))
((1 2 3 1) (1 2 1 3) (1 3 2 1) (1 3 1 2) (1 1 2 3) (1 1 3 2) (2 1 
  3 1) 
 (2 1 1 3) 
 (2 3 1 1) 
 (3 1 2 1) 
 (3 1 1 2) 
 (3 2 1 1))
> (k-permutations 3 '(1 2 3 1))
((1 2 3) (1 2 1) (1 3 2) (1 3 1) (1 1 2) (1 1 3) (2 1 3) (2 1 1) 
 (2 3 1) 
 (3 1 2) 
 (3 1 1) 
 (3 2 1))
> (k-permutations 2 '(1 2 3 1))
((1 2) (1 3) (1 1) (2 1) (2 3) (3 1) (3 2))
> (k-permutations 1 '(1 2 3 1))
((1) (2) (3))
The explanation of why this works was given a couple of years ago at http://www.alh.net/newlisp/phpbb/viewtopic.php?t=553. I still love to rehash it. What fun!

Oh, by the way, you'll need these too.

Code: Select all

(define (mappend) (apply append (apply map (args))))

(define (remove1 elt lst)
  (let ((elt-pos (find elt lst)))
    (if elt-pos (pop lst elt-pos))
    lst))
(λx. x x) (λx. x x)

cormullion
Posts: 2038
Joined: Tue Nov 29, 2005 8:28 pm
Location: latiitude 50N longitude 3W
Contact:

Post by cormullion »

Indeed I was referring to your version at (http://www.tamos.net/~rick/logismoi/) Ricky - but i switched over to the Stanford alternative because I needed a more lengthy commentary..

Now that I have both, perhaps understanding will be doubled!

Presumably you can use the built-in alternative 'remove' that Lutz showed - the Scheme version had to write one specially I think.

rickyboy
Posts: 607
Joined: Fri Apr 08, 2005 7:13 pm
Location: Front Royal, Virginia

Post by rickyboy »

Hey cormullion!

Cool! Can you use the builtin replace to remove just one element (which is what my remove1 is supposed to do)? If so, then great -- I'd love to get rid of remove1. But I couldn't see how. :-(

P.S. -- I really like your webpage formatting code. Keep up the good work.
(λx. x x) (λx. x x)

Lutz
Posts: 5289
Joined: Thu Sep 26, 2002 4:45 pm
Location: Pasadena, California
Contact:

Post by Lutz »

see my last post in this thread:

Code: Select all

(replace element (begin items))
Lutz

rickyboy
Posts: 607
Joined: Fri Apr 08, 2005 7:13 pm
Location: Front Royal, Virginia

Post by rickyboy »

cormullion wrote:Indeed I was referring to your version at (http://www.tamos.net/~rick/logismoi/) Ricky ...
Oops, you caught me. :-) I'm kind of embarassed that I can't keep up a sustained effort with my own blog. Sheesh! I really respect fellows like you, cormullion, who can sustain an effort of good quality blog articles. I've found out that it takes quite a bit of work. (And you've just found out that I may be quite lazy. :-)
(λx. x x) (λx. x x)

rickyboy
Posts: 607
Joined: Fri Apr 08, 2005 7:13 pm
Location: Front Royal, Virginia

Post by rickyboy »

Lutz wrote:see my last post in this thread:

Code: Select all

(replace element (begin items))
Lutz
Oh yeah, I got that. And I liked it -- see my post this thread, in response to your post:
rickyboy wrote:Sweet!
However, it's vitally important for k-permutations to be able to remove just one element from the list. Your usage of replace doesn't do that:

Code: Select all

> (define x '(1 2 1 3 1 1 4))
(1 2 1 3 1 1 4)
> x
(1 2 1 3 1 1 4)
> (replace 1 (begin x))
(2 3 4)
Is there a way to tell replace to remove just one?
(λx. x x) (λx. x x)

Lutz
Posts: 5289
Joined: Thu Sep 26, 2002 4:45 pm
Location: Pasadena, California
Contact:

Post by Lutz »

Ricky wrote:Is there a way to tell replace to remove just one?
oh, I see, yes then the 'pop' approach is the one I would choose too.

Lutz

cormullion
Posts: 2038
Joined: Tue Nov 29, 2005 8:28 pm
Location: latiitude 50N longitude 3W
Contact:

Post by cormullion »

You're right, replace exp list does every one, unlike with strings - must remember that...! i don't think there's a way to do it with match or anything either... So your remove1 is the best at the moment.

Maybe I'm easily impressed, but I just think this type of programming is so cool. It's amazing how something small and modest in size can suddenly explode with activity once it's started, like a bomb or whatever.... The only problem with this type of programming though is that I don't seem to be able to make use of it in the stuff I write. In the 2000-3000 lines of code I've published this year I've barely managed any of this functional programming style, having seen few opportunities to employ it. That's the really clever bit - being able to use these techniques for productive code, rather than simply for learning or exploration.

Thanks for your comments about the newlisp blog - it's just to keep my hands loose and brain ticking over while I'm not more gainfully employed (and when the kids are in bed... :-)

TedWalther
Posts: 608
Joined: Mon Feb 05, 2007 1:04 am
Location: Abbotsford, BC
Contact:

Re: Functional programming - permutations

Post by TedWalther »

If you just want to make combinations (not permutations) here is a function I came up with:

Code: Select all

(define (combinations n k (r '()))
  (if (= (length r) n)
    (list (sort r <))
    (apply append (map (fn (x) (combinations n ((+ 1 $idx) k) (cons x r))) k))))
Careful, it can blow up quickly and eat all your memory. For better memory effiency, I'd use dolist and an accumulator variable. For my purposes, creating all possible poker hands, it worked quickly and well.
Cavemen in bearskins invaded the ivory towers of Artificial Intelligence. Nine months later, they left with a baby named newLISP. The women of the ivory towers wept and wailed. "Abomination!" they cried.

TedWalther
Posts: 608
Joined: Mon Feb 05, 2007 1:04 am
Location: Abbotsford, BC
Contact:

Re: Functional programming - permutations

Post by TedWalther »

Here is a sample of how to call the "combinations" function:

Code: Select all

> (combinations 2 '(a b c))
((a b) (a c) (b c))
Cavemen in bearskins invaded the ivory towers of Artificial Intelligence. Nine months later, they left with a baby named newLISP. The women of the ivory towers wept and wailed. "Abomination!" they cried.

TedWalther
Posts: 608
Joined: Mon Feb 05, 2007 1:04 am
Location: Abbotsford, BC
Contact:

Re: Functional programming - permutations

Post by TedWalther »

I have updated the function, now it doesn't blow up the stack, keeps memory usage within very small bounds:

Code: Select all

;; n is the set of elements
;; k is the number of elements to choose
(define (combinations n k (r '()))
  (if (= (length r) k)
    (list r)
    (let (rlst '())
      (dolist (x n)
        (setq rlst (append rlst
                      (combinations ((+ 1 $idx) n) k (append r (list x))))))
      rlst)))
This version also corrects a problem with the arguments; n is supposed to represent the set, and k the number of elements to "choose". Previous version of the function had this reversed. It is now proper standard behavior.

However, be warned; this new version is 6 times slower than the version that uses up all your ram. Any ideas on how to speed it up?
Cavemen in bearskins invaded the ivory towers of Artificial Intelligence. Nine months later, they left with a baby named newLISP. The women of the ivory towers wept and wailed. "Abomination!" they cried.

TedWalther
Posts: 608
Joined: Mon Feb 05, 2007 1:04 am
Location: Abbotsford, BC
Contact:

Re: Functional programming - permutations

Post by TedWalther »

As an example, the memory efficient version took 77 seconds to calculate all possible poker hands in a deck of cards. The fast version using map took 11 seconds. So, a 7x speed difference.

Now if only there was a way to speed things up. I don't like a 7x speed hit just to stay within memory bounds.
Cavemen in bearskins invaded the ivory towers of Artificial Intelligence. Nine months later, they left with a baby named newLISP. The women of the ivory towers wept and wailed. "Abomination!" they cried.

abaddon1234
Posts: 21
Joined: Mon Sep 14, 2015 3:09 am

Re: Functional programming - permutations

Post by abaddon1234 »

They have some very nice LOGIC programming theory online too..
โหลด royal1688

ralph.ronnquist
Posts: 228
Joined: Mon Jun 02, 2014 1:40 am
Location: Melbourne, Australia

Re: Functional programming - permutations

Post by ralph.ronnquist »

You can gain a magnitude in speed by taking some more care in avoiding copying, as in the following

Code: Select all

(define (permutations items)
  (if (empty? items) '()
    (1 items)
    (let ((e (cons (first items))) (n (length items)))
      (flat (map (fn (p (i -1)) (collect (append (0 (inc i) p) e (i p)) n))
                 (permutations (rest items)))
            1))
    (list items)))
and a similar care to combinations led me to the following variant, which is slim and fast:

Code: Select all

(define (combinations items k)
  (if (<= (length items) k) (list items)
    (= k 1) (map list items)
    (append (combinations (rest items) k)
            (map (curry cons (first items))
                 (combinations (rest items) (dec k))))))

ralph.ronnquist
Posts: 228
Joined: Mon Jun 02, 2014 1:40 am
Location: Melbourne, Australia

Re: Functional programming - permutations

Post by ralph.ronnquist »

I've been time testing permutations function above, using the expression:

Code: Select all

(time (permutations (sequence 1 10)))
The funny thing is, that when repeating this a number of times, the time goes up some 100 ms on each test.
For example, for the first 20 repetitions (clipped to ms), I got: 2854, 2498, 2523, 2589, 2600, 2671, 2752, 2908, 2968, 3132, 3191, 3516, 3752, 4162, 4256, 4556, 4644, 4895, 5005, 5180 ms, in that order,
Then, for the next 20 got: 5340, 5513, 5640, 5880, 6057, 6294, 6412, 6601, 6736, 6910, 7051, 7302, 7485, 7659, 7849, 8111, 8291, 8480, 8730, 8929 ms, in that order.
and so on.

Doing (reset) makes it start again from the beginning.

It looks like it'd be some memory management bug, but I haven't been able to find out where; I'm still scouting.

This concerns newlisp 10.6.4 as of 2015-09-18 5:10pm +10:00, with version line:
newLISP v.10.6.4 32-bit on Linux IPv4/6 UTF-8 libffi.

Lutz
Posts: 5289
Joined: Thu Sep 26, 2002 4:45 pm
Location: Pasadena, California
Contact:

Re: Functional programming - permutations

Post by Lutz »

newLISP frees most memory allocated immediately to the OS. Only unused cell structures are kept in a free-cell list for reuse. This normally leads to faster performance avoiding to call memory allocation and deallocation routines in the OS every time for lisp cells.

The slowdown on repeated execution of a function is extremely rare, normally repeated execution of a program with a mixture of different functions will never slow down. In most cases the cell recycle-list speeds up program execution.

In your specific case you could avoid slow down by inserting a (reset nil) in your function:

Code: Select all

(define (permutations items)
  (if (empty? items) '()
    (begin (reset nil) (1 items))
    (let ((e (cons (first items))) (n (length items)))
      (flat (map (fn (p (i -1)) (collect (append (0 (inc i) p) e (i p)) n))
                 (permutations (rest items)))
            1))
    (list items)))
This destroys the cell recycling pool. This usage of reset is not documented and in my own work, I have never found it to be necessary and have never used it, except for testing the memory system.

ralph.ronnquist
Posts: 228
Joined: Mon Jun 02, 2014 1:40 am
Location: Melbourne, Australia

Re: Functional programming - permutations

Post by ralph.ronnquist »

Right. Yes, as far as I can work it out, it really appears to be due to something deteriorating when the distance between consecutive free cells grows.

I simplified the testing code down to the following (though I'm sure there are better ways):

Code: Select all

(and (setf A (sequence 1 20000000)) true)
(dotimes (j 100) (println (time (dotimes (i 10000) (0 (* 10 i) A)))))
Then I instrumented the code so each time also reports on the number of cells allocated via copyCell, and the sum of the consecutive address distances of the allocated cells. From that I could see that the average distance between memory cells starts of at 3 then grows steadily to around 34000 while the computation time grows from 5s to 15s.

Basically it suggests that when the address distance between consecutive freed cells is large, it takes longer time to allocate; which is what the implicit indexing does. I would guess this is due to some page caching (kernel or processor) becoming ineffective, and there's not much a newlisp user can do about it. Adding (reset nil) fixes the distances, but it takes an awfully long time in itself.

Locked