1. Find the largest index k such that a[k]<a[k+1]. If no such index

exists, the permutation is the last.

2. Find the largest index l greater than k such that a[k]<a[l].

3. Swap the value of a[k] with that of a[l].

4. Reverse the sequence from a[k+1] up to and including the final

element a[n].

First a word that reverse the order of all n characters starting at address ad.

: reverse-string \ ad n --

2dup + 1- loc{ ad1 n ad2 } n 2/ 0

?do ad1 i + c@ ad2 i - c@

ad1 i + c! ad2 i - c!

loop ;

Then the 1'st part of the algorithm, returning the address corresponding to the index k if it exists or else return 0.

: lex-perm1 \ ad n -- a1

0 loc{ a1 } 2 - over +

do i c@ i 1+ c@ <

if i to a1 leave then -1

+loop a1 ;

Find the largest address a2 greater than a1 such that [a1]<[a2].

: lex-perm2 \ ad n a1 -- a2

0 loc{ a1 a2 } 1- over +

do a1 c@ i c@ <

if i to a2 leave then -1

+loop a2 ;

Swap the values at addresses a1 and a2.

: lex-perm3 \ a1 a2 --

over c@ over c@

swap rot c!

swap c! ;

Reverse the order of the last characters, from address a1 to the end.

: lex-perm4 \ ad n a1 --

reverse from a1+1 to ad+n-1

1+ -rot \ a1+1 ad n

+ over - \ a1+1 ad+n-(a1+1)

reverse-string ;

Calculate the next permutation:

: nextp \ ad n --

2dup 2dup \ ad n ad n ad n

lex-perm1 dup 0=

if 2drop 2drop drop exit

then dup >r \ ad n ad n a1

lex-perm2 r> \ ad n a2 a1

tuck swap \ ad n a1 a1 a2

lex-perm3 \ ad n a1

lex-perm4 ;

Create the string 123...n:

: n>str \ n -- ad n

dup 0 do i 49 + pad i + c! loop pad swap ;

Create a vector on the z-stack from the string.

: str>vect \ ad n -- | -- s

loc{ ad n } n dup 0

do ad i + c@ 15 and >zst loop 2* 1+ negate >zst ;

Fast calculation of the symmetry group of n! permutations.

: sym \ n -- | -- s

n>str loc{ ad n }

n dup ufaculty dup 0

do ad n str>vect

ad n nextp

loop swap 1+ * 2* negate >zst ;

utime 7 sym cardinality . utime d- d. 5040 -3931 ok

What would take hours with straight forward generation is now done in 4 milliseconds.

Next word calculates how many components in the vector s that is greater than the number m:

: perm> \ m -- n | s --

loc{ m } 0

foreach do zst> m > + loop negate ;

This is used to calculate the number of pairs of components in the vector s that is unsorted:

: #perm \ -- n | s --

0

begin zst@ -3 <

while zsplit zst> zdup perm> +

repeat zdrop ;

Which determine if the vector correspond to an odd permutation:

: oddperm \ -- flag | s --

#perm 1 and ;

: alt \ n -- | -- s

n>str loc{ ad n }

n dup ufaculty dup 0

do ad n str>vect zdup oddperm

if zdrop then ad n nextp

loop swap 1+ * negate >zst ;

utime 7 alt cardinality . utime d- d. 2520 -35424 ok

To filter out the odd permutations takes some time, so the alternating group of n!/2 even permutations runs in 35 ms.

What is left is to figure out how to generate general groups fast. And to write a manual!

## No comments:

## Post a Comment