Functional programming - permutations

[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]

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

[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]

Code: Select all

(if (nil? items)
  nil
  (apply list ...

change to:

Code: Select all

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

[cormullion]

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

:)

[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]

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!

[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))

[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]

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.

[Lutz]

see my last post in this thread:

Code: Select all

(replace element (begin items))

Lutz

[rickyboy]

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. :-)

[rickyboy]

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:

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?

[Lutz]

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]

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]

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.

[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))

[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?

[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.

[abaddon1234]

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

[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]

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]

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]

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.