Some groups

First, I have improved the word psubgroups. Stupidly enough it calculated the whole (known) group. Now it works 5-10 times faster and calculate the set of subgroups of Sym(4) in a second. To calculate the set of subgroups to Sym(5) takes about 30 minutes, though, so enhancements must still be made.

Now handling groups with order around 100 and subgroups of groups with order around 30 is okay. A little more with a fast system...

Some finite groups

\ cyclic group of permutations of 1...n
: cyc \ n -- | -- s
  pcirc pgen ;

6 cyc zet. {(6,1,2,3,4,5),(5,6,1,2,3,4),(4,5,6,1,2,3),(3,4,5,6,1,2),(2,3,4,5,6,1),(1,2,3,4,5,6)} ok

\ symetric group of permutations of 1...n, n<6
: sym \ n -- | -- s
  dup 2 >
  if dup pcirc zfence proll zfence zmerge generate
  else 2 = if ( 2 1 ) pgen else ( 1 ) pgen then
  then ;

The n-th symmetry group is the set of all bijections of {1,...,n}.

4 sym cr zet.
{(4,2,3,1),(1,2,3,4),(1,3,4,2),(2,3,4,1),(2,4,3,1),(1,4,3,2),(2,1,3,4),(4,1,3,2),(3,4,1,2),(2,4,1,3),(3,4,2,1),(1,4,2,3),(3,1,4,2),(2,1,4,3),(3,2,4,1),(1,2,4,3),(4,3,1,2),(2,3,1,4),(4,2,1,3),(3,2,1,4),(4,3,2,1),(1,3,2,4),(4,1,2,3),(3,1,2,4)} ok

\ dihedral group of permutations of 1...n
: dih \ n -- | -- s
  dup >r pcirc zfence
  ( 1 r> ?do i -1 +loop ) zfence
  zetmerge generate ;

6 dih cr zet.
{(6,5,4,3,2,1),(6,1,2,3,4,5),(2,1,6,5,4,3),(2,3,4,5,6,1),(4,5,6,1,2,3),(4,3,2,1,6,5),(3,2,1,6,5,4),(3,4,5,6,1,2),(5,4,3,2,1,6),(5,6,1,2,3,4),(1,2,3,4,5,6),(1,6,5,4,3,2)} ok

There is also an other tradition where the dihedral group is denoted after the order of the group, but I think it's more consequent to denote it after the number of permutation elements.

Any permutation can be factorized in simple so called 2-cycles: (n m) where n maps to m and m maps to n. Example: (2,3,1)=(1 2)(1 3). Certain permutations can be factorized in an even number of 2-cycles and some can not. The product of even permutations is of course an even permutation and those permutation forms a subgroup Alt(S) of Sym(S). Both Sym(S) and Alt(S) can be generated by two elements, while their subgroups might not.

\ alternating group of permutations of 1...n, n<6
: alt \ n -- | -- s   n>2
  dup 3 = if drop ( 2 3 1 ) pgen exit then
  dup 1 and
  if >r
     { r@ pcirc
     ( r@ 2 - 1 do i loop r@ 1- r@ r> 2 - )
     } generate
  else >r
     { ( r@ 2 do i loop 1 r@ )
     ( r@ 2 - 1 do i loop r@ 1- r@ r> 2 - )
     } generate
  then ;

4 alt cr zet.
{(3,4,1,2),(3,1,2,4),(3,2,4,1),(4,1,3,2),(2,1,4,3),(1,3,4,2),(2,4,3,1),(1,4,2,3),(2,3,1,4),(4,3,2,1),(1,2,3,4),(4,2,1,3)} ok

\ quaternion group Q8={±1,±i,±j,±k} as group of permutations of 1..8
\ q8 \ -- s
: { ( 2 4 6 7 3 8 1 5 ) ( 3 5 4 8 7 2 6 1 ) } generate ;

The product of two permutation groups given as a permutation group

\ extend, to the right, bijection v to permute n elements 
: rext \ n -- | v -- v'
  >r ( r> zst@ cs do i 1+ loop )
  1 zst+! zswap 1 zst+! zswap zmerge -1 zst+! ;

\ extend to the left
: lext \ n -- | v -- v'
  dup >r ( r> zst@ cs - 1+ 1 do i loop ) 1 zst+!
  zswap zst@ tuck cs - loc{ x y }
  1 zst+! foreach
  do zst> y + loop x 1+ >>zst
  zmerge -1 zst+! ;

\ extend all functions in a set to the right 
: multirext \ n -- | s -- s'
  0 >xst foreach
  do dup rext zfence xzmerge
  loop drop xst zst setmove ;

3 sym 4 multirext cr zet.
{(3,2,1,4),(1,2,3,4),(2,3,1,4),(1,3,2,4),(3,1,2,4),(2,1,3,4)} ok

\ extend all to the left 
: multilext \ n -- | s -- s'
  0 >xst foreach
  do dup lext zfence xzmerge
  loop drop xst zst setmove ;

5 cyc 6 multilext cr zet.
{(1,2,3,4,5,6),(1,3,4,5,6,2),(1,4,5,6,2,3),(1,5,6,2,3,4),(1,6,2,3,4,5)} ok

\ the product of two groups s and s'
: gprod \ s s' -- sxs'
  ord zswap ord +
  dup multirext zswap
  multilext union generate ;

2 cyc zdup gprod zet. {(2,1,3,4),(1,2,3,4),(1,2,4,3),(2,1,4,3)} ok

3 cyc 4 alt gprod cr zet.
{(2,3,1,4,5,6,7,8,9,10,11,15,12,14,13),(2,3,1,4,5,6,7,8,9,10,11,15,14,13,12),(2,3,1,4,5,6,7,8,9,10,11,12,14,15,13),(2,3,1,4,5,6,7,8,9,10,11,13,14,12,15),(2,3,1,4,5,6,7,8,9,10,11,14,15,12,13),(2,3,1,4,5,6,7,8,9,10,11,13,12,15,14),(2,3,1,4,5,6,7,8,9,10,11,14,12,13,15),(2,3,1,4,5,6,7,8,9,10,11,13,15,14,12),(2,3,1,4,5,6,7,8,9,10,11,12,15,13,14),(2,3,1,4,5,6,7,8,9,10,11,14,13,15,12),(2,3,1,4,5,6,7,8,9,10,11,12,13,14,15),(1,2,3,4,5,6,7,8,9,10,11,12,14,15,13),(1,2,3,4,5,6,7,8,9,10,11,12,15,13,14),(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15),(1,2,3,4,5,6,7,8,9,10,11,14,15,12,13),(1,2,3,4,5,6,7,8,9,10,11,13,15,14,12),(1,2,3,4,5,6,7,8,9,10,11,15,12,14,13),(1,2,3,4,5,6,7,8,9,10,11,13,14,12,15),(1,2,3,4,5,6,7,8,9,10,11,15,14,13,12),(1,2,3,4,5,6,7,8,9,10,11,13,12,15,14),(1,2,3,4,5,6,7,8,9,10,11,14,12,13,15),(1,2,3,4,5,6,7,8,9,10,11,14,13,15,12),(3,1,2,4,5,6,7,8,9,10,11,12,14,15,13),(3,1,2,4,5,6,7,8,9,10,11,12,15,13,14),(3,1,2,4,5,6,7,8,9,10,11,12,13,14,15),(3,1,2,4,5,6,7,8,9,10,11,14,15,12,13),(3,1,2,4,5,6,7,8,9,10,11,13,15,14,12),(3,1,2,4,5,6,7,8,9,10,11,15,12,14,13),(3,1,2,4,5,6,7,8,9,10,11,13,14,12,15),(3,1,2,4,5,6,7,8,9,10,11,15,14,13,12),(3,1,2,4,5,6,7,8,9,10,11,13,12,15,14),(3,1,2,4,5,6,7,8,9,10,11,14,12,13,15),(3,1,2,4,5,6,7,8,9,10,11,15,13,12,14),(3,1,2,4,5,6,7,8,9,10,11,14,13,15,12),(2,3,1,4,5,6,7,8,9,10,11,15,13,12,14),(1,2,3,4,5,6,7,8,9,10,11,15,13,12,14)} ok

Pseudo isomorphism test

\ the set of cyclic subgroups of the group s
: pcsubs \ s -- s'
  0 >xst
  foreach
  do pgen zfence xzmerge
  loop xst zst setmove reduce ;

\ flag true if not equal cardinality
: card<> \ -- flag | s s' -- s s'
  zover cardinality zdup cardinality = 0= ;

\ sort a list of non-negative integers
: vect-sort \ v -- v'
  set-sort zst> 1- > zst ;

\ compute vector of orders of all cyclic subgroups in s
: pscan \ s -- v
  0 foreach do cardinality swap 1+ loop
  sort 2* 1+ negate >zet ;

: pseudoiso \ -- flag | s s' --
  card<>
  if zdrop zdrop false exit then
  pcsubs zswap pcsubs card<>
  if zdrop zdrop false exit then
  pscan zswap pscan vector= ;

4 dih pcsubs pscan zet. (1,2,2,2,2,2,4) ok

4 dih 8 cyc pseudoiso . 0  ok

3 sym 3 dih pseudoiso . -1  ok

Due to Mathematics Stack Exchange the psudoiso test holds for all subgroups of Sym(7) but already in Sym(8) there are counterexamples. A counterexample in Sym(16) is also:

4 cyc zdup gprod 2 cyc q8 gprod pseudoiso . -1  ok