Fast generation of the symmetric and alternating groups

From Wikipedia I got this algorithm, how to generate all permutation in alphabetical order:

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!