Topology

[Attention, this code is not included in the code site!]

The blog has become a little messy and I will try to clean it up. These simple implementations of sets and groups are limited but interesting. I believe in the idea of bundles on a stack, but the data stack is not perfect for the purpose: for the sake of portability the data stack can only be manipulated with a restricted number of words. With a special stack for bundles, stack manipulations can be made much more efficient.

While going on with the current implementation for a while, I will try to find out a faster implementation. With better algorithms: until now I have used sloppy straight forward brutal force algorithms or worse! Also the implementation of permutations and groups must be enhanced.

Topological spaces

Topology is very easy to understand in spite of it's often formalistic presentation for the students. In set theory the question is: does an element belong to the set or not. In topology the question is if the element is close to the set or not.

That's what a topological structure λ on a set X submit, the possibility to decide whether a point x in X belongs to the closure of a subset A of X or not. The set λ of open subsets of X brings the method: the point x is in the closure of A if and only if every open set O in λ that contain x, also contain a point in A.

Two subsets of X are obligatory in λ and that's ø and X. Beyond that there are two rules for λ to be a topology on X. (1) Given a subset B of λ, then the union of all sets in B should belong to λ. (2) given two sets O,Ô in λ, then the intersection of O and Ô should belong to λ.

Examples:

• The topology of the real numbers (a topology which is a necessary part of the definition of the set of real numbers) consists of all unions of limited open intervalls, that is, open intervalls of the type {x|a<x<b} for real numbers a,b. Any union of such intervalls belongs to this topology. The point 1 belongs to the closure of {x|0<x<1}, without actually being a member of that set, because every open set that contains 1 also contains a point in {x|0<x<1}.
• The set {ø,X} is a topology on X called the trivial topology and the set of all subsets of X is a topology called the discrete topology.
• Any infinite set X has an obvious topology consisting of all complements of finite subsets of X plus the empty set.
• Any set of subsets of a set X generates a minimal topology on X which contain those subsets.

A subset C of X is said to be closed if X\C is open, that is belong to λ. The closure of a subset A of X is the smallest closed set C such that A is a subset of C. The most interesting infinite topological spaces are the Hausdorff spaces, where all singleton sets {x} are closed. But for finite topological spaces all Hausdorff spaces are discrete. Finite spaces are determined by the closure function of all the singleton sets, because with that function it's possible to decide which points that are close to which sets.

In stack diagram for setcup s is a set of sets and s' is a set of points. And s" is the set of the unions of all elements of s ans s':

{ { 1 2 } { 2 3 4 } } { 3 4 5 } setcup cr set.
{{1,2,3,4,5},{2,3,4,5}} ok

: setcup ( s s' -- s")
  >>xst 0 >yst foreach
  ?do nxst@ union fence yst>> union >>yst
  loop nxstdrop yst>> ;


Similar for the word:

: setcap ( s s' -- s")
  >>xst 0 >yst foreach
  ?do nxst@ intersection fence yst>> union >>yst
  loop nxstdrop yst>> ;

The word capgen generates all intersections:

: capgen ( s -- s')
  ndup >>yst ndup >>xst foreach
  ?do nyst@ nswap setcap xst>> union >>xst
  loop nystdrop xst>> ;

The word cupgen generates the set of all unions os s. When first apply capgen and then cupgen all the non trivial open sets in the smallest topology that includes s are generated. And the word topology completes with ø and X, which might or might not be generated by capgen and cupgen.

: cupgen ( s -- s' )
  ndup >>yst ndup >>xst foreach
  ?do nyst@ nswap setcup xst>> union >>xst
  loop nystdrop xst>> ;

{ { 1 2 } { 2 3 4 } { 3 4 5 } } capgen ndup cr set.
{{2},0,{3,4},{1,2},{2,3,4},{3,4,5}} ok
cupgen ndup cr set.
{{1,2,3,4},{1,2,3,4,5},{2,3,4,5},{2},0,{3,4},{1,2},{2,3,4},{3,4,5}} ok
{ 1 2 3 4 5 } { { 1 2 } { 2 3 4 } { 3 4 5 } } topology cr set.
{{1,2,3,4},{2,3,4,5},{2},{3,4},{1,2},{2,3,4},{3,4,5},{1,2,3,4,5},0} ok

: topology \ X s -- λ
  nover nswap capgen
  cupgen nswap incl 0 incl ;

In the figure the rectangle correspond to X and the colored shapes to the set of sets generating a topology. The colored surfaces are the primitive intersections, and the topology is the set of all combinations of unions of those intersections.

The next word computes the closure to the singleton {x}.

: singlecl \ λ x -- s  
  0 false loc{ x y flag } >>yst 0 >xst
  nyst@ nunion foreach
  ?do to y true to flag nyst@ foreach
     ?do ndup y member
        if x member 0=
           if false to flag then
        else ndrop
        then
     loop flag if xst>> y incl >>xst then
  loop nystdrop xst>> ;

And the λ-closure for any set:

: closure ( λ s -- s')
  nswap >>xst 0 >yst foreach
  ?do >r nxst@ r> singlecl yst>> union >>yst
  loop nxstdrop yst>> ;

{ 1 2 3 4 5 } { { 1 2 } { 2 3 4 } { 3 4 5 } } topology   ok
{ 1 3 5 } closure cr set.
{1,4,3,5} ok

So except for the members 1,3,5 also 4 is close to {1,3,5}.
The word opsubs computes all open sets that are subsets of s.

: opsubs ( λ s -- s' )
  >>yst 0 >xst foreach
  ?do ndup nyst@ subset
     if fence xst>> union >>xst
     else ndrop
     then
  loop nystdrop xst>> ;

The interior of a set s is the set of all points which are members of an open set that is a subset of s. That is, s' is the union of all open subsets of s.

: interior ( λ s --- s')
  opsubs nunion ;

{ 1 2 3 4 5 } { { 1 2 } { 2 3 4 } { 3 4 5 } } topology ndup  ok
{ 1 3 5 } interior cr set.
0  ok
{ 2 3 } interior cr set.
{2} ok

A conjecture about groups

[Attention, this code is not included in the code site!]

First I want to make a reform, since I want the {}-brackets for sets:

: loc{ [compile] { ; immediate

I have changed this all over.

: { depth >xst ; 

: } depth xst> - negate >set ;

See Mathematics Stack Exchange

The composition of sets of permutations is performed by the word 

pset* ( s1 s2 -- s3 )


: go xst clst ndup >>xst ;

: gen. ( s -- s')  ndup set. nxst@ pset* ;

The word gen. multiply the top set on the data stack with the set on the xst stack and leave the result on the data stack without changing the xst stack. Now the conjecture can be tested.

{ 2143 1234 } { 3412 2143 4321 1234 } pnormal . -1  ok

So the smaller set is a normal subgroup of the bigger set, and therefore the quotient is a group:

{ 3412 2143 4321 1234 } { 2143 1234 }  ok

pquotient set. {{3412,4321},{2143,1234}} ok

This set is a group under pset* and is generated by {3412,4321}:

{ 4321 3412 } go  ok

gen. {4321,3412} ok

gen. {2143,1234} ok

gen. {4321,3412} ok

ndrop  ok

As always with the set elements in quotient groups they have the same number of elements.

Now take a random set of 4-permutations:

{ 2431 2341 } go  ok

gen. {2431,2341} ok

gen. {4132,3142,4312,3412} ok

gen. {1234,1243,3214,4213,1324,1423,3124,4123} ok

gen. {2413,2314,3421,4321,1423,1324,2341,2431,2143,2134,3241,4231, 1243,1234} ok

gen. {4123,3124,4321,3421,2143,2134,4132,3142,4213,3214,4231,3241, 3412,4312,1432,1342,2413,2314,2431,2341} ok

gen. {4231,3241,1234,1243,3214,4213,1432,1342,1324,1423,2134,2143, 2314,2413,4123,3124,4321,3421,4132,3142,4312,3412} ok

gen. {3412,4312,2314,2413,2341,2431,2143,2134,4321,3421,3241,4231, 1342,1432,3142,4132,1234,1243,3214,4213,1324,1423,3124,4123} ok

gen. {4123,3124,3142,4132,3412,4312,1432,1342,3214,4213,2413,2314, 3421,4321,1423,1324,2341,2431,2143,2134,3241,4231,1243,1234} ok

ndrop  ok

In this case the series 

A, A*A, A*A*A,... 

grows until it stagnates in a loop (which is a group), in this case the trivial group generated by the set of the symmetric group of 4-permutations.

More about subgroups

[Attention, this code is not included in the code site!]

My first try to compute the set of subgroups of a group was to compute the set of subsets and test which subsets that was groups. But Sym(4), the group of all permutations of 1234, has 16777216 subsets. My next thought was to divide the set of subsets P(S) into subsets of equal cardinality P(S,k). This works for small k but

|P(Sym(4),12)|=24!/((24-12)!*12!)=2704156.

Not very efficient thinking nor code so far! But even a blind dog can follow a track and I think that following algorithm is correct and "efficient":

1. set Subs={{123..}}, the set of the set of the identity
2. for each x in S include x in all sets in a copy of Subs and compute the set of subgroups generated by the sets in the copy
3. set Subs=Subs+copy (union)

Repetition of some set words and group words.

• fence ( x -- {x} ) and x could be an integer or a set
• nfence ( s -- s') any object in s' is a fenced object of s
• incl ( s x -- su{x}) the object x is included to s
• nincl ( s x -- s') the elements in s' is the sets that are elements of s where x is included
• generate ( s -- s') s' is the group generated by the permutations in s

A set on the stack is represented by a negative-counted bundle on the stack and the count specifies the number of integers in the bundle. A semiotic word foreach prepares for processing of the elements in a do-loop:

: foreach ( s -- x1...xn n 0 )

  ndup               \ s s  duplicates the bundle

  card               \ s n  computes n=|s|

  nip 0 ;            \ drop the bundle count and prepare for do loop

  

: ngenerate ( s -- s')

  0 >>yst            \ empty set on yst stack

  foreach            \ for each element in the set s

  do generate        \ the sets in s generates cyclic groups

     fence           \ fence the group

     yst>> union >>yst

  loop yst>> ;

Here s' is the set of groups generated by the sets of permutations that are elements of s.

And now finally the set of all subgroups

: psubs ( s -- s')
  over numb identity fence fence >>yst  \ {{123...}} pushed to yst
  foreach
  do >r yst>> ndup r> nincl ngenerate union >>yst
  loop yst>> ;

4 sym psubs cr set. 

{{1234},{2134,1234},{3412,1234},{4123,3412,2341,1234},{1423,1342,1234},{4213,3241,1234},{4321,1234},{3142,2413,4321,1234},{4231,1234},{1243,1234},{1324,1234},{4321,4231,1324,1234},{1432,1234},{1423,1342,1243,1324,1432,1234},{3214,1234},{4213,3241,4231,1243,3214,1234},{3412,1432,3214,1234},{2314,3124,1234},{2134,2314,1324,3214,3124,1234},{2431,4132,1234},{2134,2431,4231,1432,4132,1234},{2143,1234},{3421,4312,2143,1234},{3412,4321,2143,1234},{2134,1243,2143,1234},{2134,3412,3421,4312,4321,1243,2143,1234},{3412,3142,2413,4321,4231,1324,2143,1234},{4123,3412,2341,4321,1432,3214,2143,1234},{3412,4213,1423,1342,2314,2431,3241,4321,3124,4132,2143,1234},{4123,2134,3412,4213,1423,2341,3421,3142,4312,2413,1342,2314,2431,3241,4321,4231,1243,1324,1432,3214,3124,4132,2143,1234}}

The normal subgroups:

: pnsubs ( s -- s')
  ndup >>xst
  0 >>yst
  psubs foreach
  do ndup nxst@ pnormal
     if fence yst>> union >>yst else ndrop then
  loop nxstdrop yst>> ;

4 sym pnsubs cr set.
{{1234},{3412,4321,2143,1234},{3412,4213,1423,1342,2314,2431,3241,4321,3124,4132,2143,1234},{4123,2134,3412,4213,1423,2341,3421,3142,4312,2413,1342,2314,2431,3241,4321,4231,1243,1324,1432,3214,3124,4132,2143,1234}} ok

Some reflections and facts:

Any finite group is isomorphic to a subgroup of Sym(n) for some n. For all n>2, Sym(n) can be generated by two permutations. A consequence of the Structure Theorem for Abelian Groups, (a group where ab=ba for all a and b in the group) is that for any positive number m there is an Abelian group that can be generated by m but not by m-1 elements. So for n big enough, Sym(n) can be generated by 2 elements, but has subgroups needing m>2 generators.

Subsets and subgroups

[Attention, this code is not included in the code site!]

For finite sets there is a recursive method to compute the set of all subsets of a certain order which is an analogy to Pascals rule for binomial coefficients:

From Wikipedia about binomial coefficient.

Suppose A is a set (with n elements for the analogy), that f is a choice function on all finite sets and that p(A,k) is the set of all subsets of A with k elements. For a set of sets S, define S%x to be the set consisting of all sets X in S where x have been included. Then

p(A,k)=p(A\{f(A)},k)+(p(A\{f(A)},k-1)%f(A))

where + stands for union of two disjoint sets: non of the sets in the first set include f(A), which every set in the second set do.

The choice function here is the topmost element on the stack where the set is pushed. This will work because the order of the sets in the computation not will be changed.

: nfence ( s -- s' ) 
  ndup card nip 0 tuck 
  do >>yst fence yst>> nswap incl loop ; 

The word nfence fence all the elements in the set s, for example:

{1,2,{3,4},0} --> {{1},{2},{{3,4}},{0}}

: power# ( s n -- s' ) 
  >r ndup card r@ = if rdrop fence exit then 
  r@ 1 = if rdrop nfence exit then 
  nsplit obj>xst ndup r@ recurse 
  nswap r> 1- recurse xst>obj nincl union ; 

3 sym 3 power# cr set.
{{132,321,231},{132,321,213},{321,231,213},{132,231,213},{132,321,312},{321,231,312},{132,231,312},{231,213,312},{321,213,312},{132,213,312},{132,321,123},{321,231,123},{132,231,123},{231,213,123},{321,213,123},{132,213,123},{213,312,123},{231,312,123},{321,312,123},{132,312,123}} ok

The next word make calculations for words computing subgroups and normal subgroups.

: presub ( s n -- s' ) 
  >r nsplit >yst r> 1- power# yst> nincl ; 

Using recursion has the disadvantage that it normally doesn't give partial outputs, but merely the whole output package in the end. The word psub# first use power# (in presub) to (try to) find the subsets of s and then tests which of the subsets that are groups. Since the identity permutation (at the top) must belong to every subgroup this is first excluded from s and then included in the end.

: psub# ( s n -- s' )
  presub ndup card nip 0 tuck
  do >>yst ndup pgr
     if fence yst>> union
     else ndrop yst>>
     then
  loop ;

4 alt 3 psub# cr set.
{{4132,2431,1234},{4213,3241,1234},{2314,3124,1234},{1342,1423,1234}} ok
4 alt 4 psub# cr set.
{{4321,2143,3412,1234}} ok

And pnsub# calculate the set of all normal subgroups of s with n elements:

: pnsub# ( s n -- s' )
  >r >>xst nxst@ r> presub
  ndup card nip 0 tuck
  do >>yst ndup pgr
     if ndup nxst@ pnormal
        if fence yst>> union
        else ndrop yst>>
        then
     else ndrop yst>>
     then
  loop nxstdrop ;

4 alt 2 pnsub# cr set. 
0  ok

4 alt 3 pnsub# cr set.
0  ok

4 alt 4 pnsub# cr set.

{{4321,2143,3412,1234}} ok

4 alt 6 pnsub# cr set.

0  ok

The last do only works on GForth Androids and GForth 32 bit Windows. (SP-Forth if the stack is resized). It make overflow on the stack on the other systems. I'll had to make much more efficient routines, presumable with iteration instead of recursion.

Anyway, this shows that the group Alt(4), of order 12, only has one normal subgroup: {4321,2143,3412,1234} and only one quotient group:

4 alt ndup 4 pnsub# nunion pquote cr set.

{{4213,1342,2431,3124},{3241,4132,2314,1423},{4321,2143,3412,1234}} ok

Permutation groups

[Attention, this code is not included in the code site!]

First, the code in the previous post about sets had to be enhanced. The bundle stack manipulation words have been replaced with more efficient coding and the xst/yst stacks has got 8 times more memory allocated. Still only very small sets (and groups) can be handled.

Also an other set operation is included:

: nunion ( s -- s' )
  ndup card nip 0 tuck ?do union loop ;

that compute the union on all sets in the set s (which is supposed to have only sets as elements).



The permutations of a list of distinct symbols can be thought of as bijective functions: 52314 then represent the bijection where 

1 maps to 5, 2 maps to 2, 3 maps to 3, 4 maps to 1 and 5 maps to 4.

The combination of two permutations, i.e. f=52314 and g=23451 is the composition of the corresponding bijections:

g◦f=23451◦52314=13425

1. composition of bijections are bijections
2. composition of functions is associative
3. the non permutation (i.e. 12345) is an identity to right and left
4. every permutation has a backward permutation (inverse)

To find the inverse of 52314, take the position of 1 to be the first figure 4, the position of 2 to be the next figure 42 etc: 42351.

Permutations was the kind of groups known to Évariste Galois when he developed his theory that showed that there was no general solution to solve fifth degree (or higher) equations by radicals, and thereby solved a problem standing for 350 years. Later on the concept of abstract groups was defined by the axioms:

It can be proved that any finite abstract group is virtually the same as (isomorphic to) some subset of permutations (Cayley's Theorem). Therefore, by using the figures 1 to 9 for permutations, positive numbers on the stack represent group elements in a concrete and simple way. Also in 32 bit systems 987654321 is a positive single integer.

The symmetric group Sym(S) is the group of all permutations (all bijections) of the elements in S. Here Sym(n) is the group of all permutations of n figures. Sym(9) has 9!=362880 elements and is far too big for the implementation in this blog. But several subgroups of Sym(9) can be studied.

The word numb gives the number of figures in the permutation f

: numb ( f -- n )  0 <# #s #> nip ;

and maps is the action of f on i

: maps ( i f -- j )  0 <# #s #> drop + 1- c@ 48 - ;

The composition of two permutations is given by

: pcomp loc{ g f -- g◦f }
  0                           \ the start value
  f numb 1+ 1
  do 10 * i f maps g maps +
  loop ;

Given a permutation f, repeated compositions results in the serie

f, f◦f, f◦f◦f, ... 

which because of the group axioms must repeat itself. If then

f◦...◦f = f (n times)

then composition with the inverse f' gives

f◦...◦f = e (n-1 times)

Each permutation f generates a cyclic group (f) and n-1 above is the order of that group - the number of permutations in the group. The word gen generates the set of the elements of the cyclic group (g):

: gen loc{ g -- f1...fn -n }
  g dup numb ufaculty 1+ 1
  do dup g pcomp dup g =
     if drop i negate leave then
  loop ;

Now groups can be generated:

2345671 gen cr set.
{2345671,3456712,4567123,5671234,6712345,7123456,1234567} ok

The order of the cyclic group (2345671) is 7, a prime. It can be proved that the order of a subgroup must divide the order of it's main group. So the only subgroups of (2345671) are (1234567) and (2345671) itself. Also, this is why the do-loop in gen is from 1 to m! where m is the number of figures: (g) is a subgroup of Sym(m). Though, the loop is left when

g◦...◦g = g (n times).

Some words to generate non cyclic groups: 

: prco ( s n -- s' )
  loc{ n } >>xst xst> abs 0 tuck
  ?do xst> n pcomp fence cup
  loop ;

To generate right co-sets of a set of permutations prco is used. A right co-set of a set s of permutations is the set of all permutations in s composed to the right with the permutation n. Given a set of permutations A={p1,...,pn} and a permutation p, then A◦r={p1◦p,...,pn◦p} is the right co-set:

{ 4231 2341 } 3412 prco cr set.
{3142,4123} ok

: plco ( n s -- s' )
  >>xst { n } xst> abs 0 tuck
  ?do n xst> pcomp fence cup
  loop ;

Similar for the left co-set plco. The word pset* computes the set of all combinations of all elements in two sets: 

{f1,...fn}◦{g1,...,gm}={f1◦g1,...,fi◦gj,...,fn◦gm}

: pset* ( s1 s2 -- s3 )
  >>xst >>yst yst> abs 0 tuck
  ?do nxst@ yst> prco cup
  loop nxstdrop ;

{ 4312 2341 2314 } { 1234 3124 } pset* cr set.

{4312,4231,2341,1243,2314,1234} ok

The word pgr checks if a set of permutations is a group:

: pgr ( s -- flag )
  ndup ndup pset* set= ;

{ 4312 2341 2314 } { 1234 3124 } pset* pgr . 0  ok

The only thing that needs to be checked is that the composition of any two permutations in the set is a permutation in the set.

s" 123456789" create id$ here swap dup allot move align

: identity ( n -- m )
  >r 0. id$ r> >number drop 2drop ;

The word identity gives the identity permutation with n figures:

5 identity . 12345  ok

: generate ( s -- s' )
  over numb identity incl
  begin >>yst nyst@ nyst@ pset*
     yst>> nover set=
  until ;

And now how to generate non cyclic permutation groups:

{ 234561 321654 } generate cr ndup pgr . cr set.
-1
{654321,561234,456123,165432,543216,612345,345612,216543,432165,234561,321654,123456} ok

Given a subgroup H of G. Define G/H to be the set of all right co-sets H◦g where g is an element of G. Any right co-set in G/H has the same number of elements as H and the co-sets are an equivalence class division of G with o(G)=o(H)o(G/H).

Let G be the group generated by {234561,321654}, that is, G={654321,561234,456123,165432,543216,612345,345612,216543,432165,234561,321654,123456} and let H be the subgroup generated by 561234, that is H={561234,345612,123456}. Then G/H={{654321,216543,432165},{612345,456123,234561},{543216,165432,321654},{561234,345612,123456}}.

Now, if for all g in G it holds that H◦g=g◦H, then H is said to be a normal subgroup of G and then it holds for all co-sets that

(H◦a)◦(H◦b)=H◦(a◦b) and the co-sets forms a group G/H, a quotient group.

: pnormal ( s s' -- flag ) 
  true loc{ flag } nswap dup -1 =
  if ndrop ndrop true exit then
  >>yst abs 0
  do dup >r nyst@ plco nyst@ r> prco set= 0=
     if false to flag then
  loop nystdrop flag ;

: pquotient ( s s' -- s/s' )
  >>yst abs 0 dup >xst
  do nyst@ plco fence xst>> union >>xst
  loop nystdrop xst>> ;

Now testing:

561234 gen n{ 234561 321654 }n generate pnormal . -1  ok

So G/H should be a group:

{ 234561 321654 } generate ndup cr set.
{654321,561234,456123,165432,543216,612345,345612,216543,432165,234561,321654,123456} ok
561234 gen ndup cr set.
{561234,345612,123456} ok
pquotient set. {{654321,216543,432165},{612345,456123,234561},{543216,165432,321654},{561234,345612,123456}} ok
{ 654321 216543 432165 } { 612345 456123 234561 } pset* cr set.
{321654,165432,543216} ok

Obviously the composition of the two co-sets is a co-set itself (the third set in G/H but with an other order. And the same should be true for any combination of co-sets.

Next some words to permute permutations:

: circ$ { ad n -- }
  ad n + 1- c@ ad dup 1+ n 1- move ad c! ; 

The permutation number at ad is circular shifted one step rightward. 

: circ ( f -- g )
  0 0 rot 0 <# #s #> 2dup circ$ >number drop 2drop ;

1234567 circ . 7123456  ok

The word circ/ prepare for partial shifts.

: circ/ ( m n -- k r q )
  over swap
  10 rot numb rot - **
  tuck /mod ;

Partial shift of the n first numbers in the permutation m. The rightmost figures are left unchanged:

: lcirc ( m n -- m' )
  circ/ circ
  rot * + ;

Partial shift of the most rightward numbers in the permutation m, Where the n leftmost figures are left unchanged:

: rcirc ( m n -- m' )
  circ/ swap circ swap
  rot * + ;


These partial shifts are used to create some standard groups:

: sym ( n -- s )
  dup 2 < if -1 exit then
  identity dup 2 lcirc swap circ -2 generate ;

5 sym set. {12453,21453,54321,43215,21543,54312,24531,14532,34215,23514,32514,25413,24153,32154,15432,14253,43125,13524,12543,42531,15423,52413,45312,45321,42153,35142,25143,54132,41532,34125,31524,35214,31254,35241,25431,25314,54231,24135,53124,53214,23154,53142,21534,51423,51432,41325,15324,41253,15243,52143,45132,45231,42135,35124,42315,41352,31245,32145,31542,31425,15342,14235,14325,13254,53241,12534,52431,21435,51324,52314,21354,51243,51342,41235,53421,42351,43251,32541,32415,25341,24315,14352,13245,23145,13542,12435,13425,12354,52341,24513,53412,43152,43521,32451,31452,35421,24351,34251,23541,23415,13452,14523,54213,43512,42513,35412,34152,34521,23451,25134,54123,41523,45213,34512,15234,52134,45123,21345,51234,12345} ok

This take some time, from 5 seconds on SP-Forth and more on the others.

Any permutation can be factorized in simple so called 2-cycles: (nm) where n maps to m and m maps to n. Example: 231=(12)(13). 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.

: alt ( n -- s )
  dup 3 < if drop 1 -1 exit then
  dup 3 = if drop 231 gen exit then
  dup 1 and
  if identity dup 3 lcirc swap circ
  else identity dup 3 lcirc swap 1 rcirc
  then -2 generate ;

5 alt cr set.

{32154,52143,42135,43215,21543,13254,21435,21354,53241,15432,54321,41325,32541,15243,14235,24315,14352,13542,32415,51342,23514,25413,54132,52431,42351,43152,35142,43521,35421,25341,34125,24153,13425,12453,31524,51423,35214,54213,53412,41253,41532,31452,45231,34251,24531,23451,12534,15324,14523,52314,42513,45312,34512,23145,25134,53124,45123,31245,51234,12345} ok

For some reason the system crash for 6 sym and 6 alt. 

Next a very straightforward word supposed to compute the set of all subgroups of a group. It is very inefficient with memory but works for small sets.

: psubs ( s -- s' )
  ndup card >r
  powerset 0 excl drop
  2 r> ** 1- 0 tuck
  do >>yst generate fence yst>> union
  loop ;

3 sym psubs cr set.
{{123},{132,123},{321,123},{213,123},{231,312,123},{132,321,231,213,312,123}} ok

A better way to do this is to use that all subgroups has orders that divide the order of the group and only create and test those subsets. I hope I can manage to do that later on.

A nice text book on elementary theory of finite groups

Dynamic sets

[Attention, this code is not included in the code site!]

A sequence of integers on the stack can be thought of as a bundle if the top integer is interpreted as the number of integers in the bundle. A list is such a bundle where it is possible to decide whether a number on the stack is a bundle counter or a bundle member. By restricting the members to non negative integers with non positive numbers as counters this is achieved. 

The bitstring 0 is allowed to have an ambiguous interpretation: to be an integer and to be the counter belonging to an empty list (in fact being a whole sequence interpreted as an empty list). In that way lists can be interpreted having lists as members and can then be interpreted as a finite set of natural numbers (including zero) and finite sets of finite depth, i.e there is a positive number n such that for a sequence s1,...,sn it can't be true that: 

s1 is a member of s2 that is a member of ... that is a member of sn.

Two bundles are equal if they are identical sequences. Two lists are equal if they are equal as bundles. Two sets are equal if any element in one of the sets is a member of the other. Elements can be sets and the definitions of the membership relation and the equality relation depend on each others.

Dynamic programming using stacks in Forth style is as simple as it can be and the word drop is the main word for garbage collection.

Extra stacks

cell negate constant -cell

1 13 lshift cells allocate throw dup constant xst dup !

: >xst ( n -- )  xst cell over +! @ ! ;
: xst> ( -- n )  xst dup @ @ -cell rot +! ;
: >xst> ( n -- m )  xst dup @ @ -rot @ ! ;
: xst@ ( -- n )  xst @ @ ;
: xst! ( n -- )  xst @ ! ;

: xst+! ( n -- )  xst @ +! ;

: >>xst ( xn ... x1 -n -- )  >r r@ abs 0 ?do >xst loop r> >xst ;

: xst>> ( -- x1 ... xn -n )  xst@ >r xst> abs 0 ?do xst> loop r> ;

1 13 lshift cells allocate throw dup constant yst dup ! 

: >yst ( n -- )  yst cell over +! @ ! ;

: yst> ( -- n )  yst dup @ @ -cell rot +! ;

: >yst> ( n -- m )  yst dup @ @ -rot @ ! ;

: yst@ ( -- n )  yst @ @ ;

: yst! ( n -- )  yst @ ! ;

: yst+! ( n -- )  yst @ +! ;

: >>yst ( xn ... x1 -n -- )  >r r@ abs 0 ?do >yst loop r> >yst ;

: yst>> ( -- x1 ... xn -n )  yst@ >r yst> abs 0 ?do yst> loop r> ; 

The >> words store an recall bundles on the stacks. 

: >>xyst ( x1...xn -n -- )

  >r r@ abs 0

  ?do dup >xst >yst

  loop r@ >xst r> >yst ;

>>xyst store a copy of the top bundle on the stack to both xst stack and yst stack.

cell 1- log~ constant cellshift  \ for fast cellshifts

: stdepth ( ad -- n )  dup @ swap - cellshift rshift ;

: clst ( ad -- )  dup ! ;

: stempty ( ad -- flag )  dup @ = ;

\ example: xst stempty

Bundles

?def 0> [if] : 0> ( n -- flag )  0 > ; [then]

: ndup ( s1 -- s1 s1 )
  dup abs loc{ n } n 1+ 0
  do n pick loop ;

: nover ( s1 s2 -- s1 s2 s1 )
  dup abs dup >r 1+ pick abs r> over + 1+ loc{ m } 1+ 0
  do m pick loop ;

: nswap ( s1 s2 --s2 s1 )
  dup abs dup >r 1+ pick abs r> over + 1+ loc{ m } 1+ 0
  do m roll loop ;

: ndrop ( s1 -- )  abs drops ;
: nnip ( s1 s2 -- s2 )  nswap ndrop ;
: ntuck ( s1 s2 -- s2 s1 s2 )  nswap nover ;

: nrot ( s1 s2 s3 -- s2 s3 s1 )
  dup abs dup >r
  1+ pick abs r> + dup >r
  2 + pick abs r> over + 2 + loc{ m } 1+ 0
  do m roll loop ;

: nxst@ ( -- s )

  xst@ dup >r abs 1+ 1 ?do xst @ i cells - @ loop r> ;

: nyst@ ( -- s )

  yst@ dup >r abs 1+ 1 ?do yst @ i cells - @ loop r> ;

: nxstdrop ( -- )
  xst@ 1- cells xst +! ;

: nystdrop ( -- )
  yst@ 1- cells yst +! ;

: nmerge ( s1 s2 -- s3 )

  >>xst xst@ + >r xst>> drop r> ;

: .bundle ( x1...xn -n -- )
  dup abs 1+ 0
  ?do dup abs i - pick . loop ;

: .bundles

  0 loc{ n }

  begin depth

  while dup 0> 0=

  while cr .bundle >>yst n 1+ to n

  again then then n 0

  ?do yst>> loop ;

: n[ depth >xst ;            \ multi input

: ]n depth xst> - negate ;   \ end of multi input

\ n[ 1 2 n[ 3 4 ]n 2 n[ 3 4 ]n ]n 

Printing lists

0 value ad1

: ad1- ( -- )  ad1 1- to ad1 ;

: fillad$ ( addr n -- )
  dup 1- negate ad1 + dup to ad1 swap move ad1- ;

: n>ad1 ( n -- )  0 <# #s #> fillad$ ;
: a>ad1 ( c -- )  ad1 c! ad1- ;

\ the number of objects (numbers or lists) in list

: card ( n1...nk -k -- n ) 

  dup 0= if exit then

  abs 0 loc{ m n }

  begin dup 0<

      if abs dup >r drops m r> - 1- to m 

      else drop m 1- to m

      then n 1+ to n m 0> 0=

  until n ;
\ this word could be outsmarted by a word analyzing the stack

0 value openp

0 value closep

\ recursive word building the string to be printed

: list$ ( n1...nk -k ad -- adr n ) 

  dup to ad1 false loc{ ad2 flag }

  closep a>ad1

  ndup card nip 0 

  do flag if [char] , a>ad1 then dup 0<

     if ad1 recurse 2drop

     else n>ad1

     then flag 0= if true to flag then 

  loop openp a>ad1

  ad1 1+ ad2 over - 1+ ; 

: list. ( n1...nk -k -- )

  [char] [ to openp

  [char] ] to closep

  dup 0=

  if .                         \ the empty list

  else pad 2000 + list$ type

  then ; 

Some list words

\ create the sublist of numbers

: simple-part ( n1...nk -k -- x1...xs -j )
  0 loc{ s } ndup card nip 0
  ?do dup 0<
     if abs drops
     else >xst s 1- to s
     then
  loop s >xst xst>> ;

\ check if an object is a non empty list

: ncheck ( x -- x flag )  dup 0< ;

\ split a list into the first object and the rest of the list

: nsplit ( s -- s' x )

  >r dup 0<

  if dup abs 1+ r> + >r >>xst r> xst>> 

  else r> 1+ swap

  then ;

Set equality

\ n member in list of only numbers?

: member1 ( s n -- flag ) 

  0 false loc{ m n k flag } m abs 0

  ?do k 1+ to k n =

     if true to flag leave then

  loop k m + ndrop flag ;

0 value 'subset 
: subset ( s s' -- flag )  'subset execute ;

: set= ( s s' -- flag ) 

  nover nover subset

  if nswap subset

  else ndrop ndrop false

  then ; 

\ general membership

: member ( s x -- flag )

  ncheck 0=                           \ x is a number?

  if >r simple-part r> member1 exit

  then >>yst                          \ the set x to yst

  begin ncheck                        \ set not empty?

  while nsplit ncheck                 \ element is a set?

     if nyst@ set= 

        if nystdrop ndrop true exit then

     else drop

     then 

  repeat drop nystdrop false ;

\ execution code for subset 

: xsubset ( s s' -- flag )

  ?dup 0=

  if ncheck >r ndrop r> 0= exit    \ true if both sets are empty

  then >>xst                       \ non empty s' to xst

  begin ncheck                     \ set is not empty?

  while nsplit ncheck              \ object is a set?

     if nxst@ nswap member 0=

        if nxstdrop ndrop false exit then

     else >r nxst@ simple-part r> member1 0=

        if nxstdrop ndrop false exit then

     then

  repeat drop nxstdrop true ; ' xsubset to 'subset

Sets

The basic words for set calculations.

: fence ( x -- {x} ) 

  ncheck if dup 1- else -1 then ; 

\ reduce list from equal elements

: >set ( s -- s' ) 

  0 >xst

  ndup card nip 0

  ?do fence nxst@ nover drop member

     if ndrop

     else xst>> nmerge >>xst

     then

  loop xst>> ;

: union ( s s' -- s" )  nmerge >set ;

: cup union ;

: intersection ( s s' -- s" )

  0 >xst >>yst ndup card nip 0

  ?do fence nyst@ nover drop member

      if xst>> union >>xst else ndrop then

  loop nystdrop xst>> ;

: cap intersection ;

: set. ( n1...nk -k -- )

  [char] { to openp

  [char] } to closep

  >set dup 0= 

  if . 

  else pad 2000 + list$ type 

  then ;

: { depth >xst ; 

: } depth xst> - negate >set ;

An object could be a positive number or a set.

: obj= ( x x' -- flag )  fence >>xst fence xst>> set= ;

: objdup ( x -- x x )  ncheck if ndup else dup then ;

: objdrop ( x -- n )  ncheck

  if dup >r ndrop r> abs 1+

  else drop 1

  then ; \ n is the number of dropped integers

: incl ( s x -- s u{x} )  fence union ;

: excl ( s x -- s\{x} )

  ncheck if >set then

  fence >>yst >set

  ndup card swap 0 loc{ m n } 0

  ?do objdup nyst@ drop obj=

     if objdrop m + to m

     else n 1+ to n ncheck

        if >>xst else >xst then

     then

  loop nystdrop n 0

  ?do xst@ 0< if xst>> else xst> then loop m ;

: complement ( s s' -- s\s' ) 

  nswap >>xst

  ndup card nip 0

  ?do fence xst>> nswap drop excl >>xst

  loop xst>> ;

: diff complement ;

{ 0 1 { 2 { 3 4 } 5 } 6 7 0 }  ok

ndup list. [0,1,[2,[3,4],5],6,7,0] ok

set. {1,{2,{3,4},5},6,7,0} ok

This implementation of sets is rather general but too limited for other purposes than demonstrations and experiments. My idea is to become more familiar with finite permutations groups, finite topologies and matroids.

Also include power set and later on maybe Cartesian product:

\ push object on xst stack
: obj>xst ( x -- )  ncheck if >>xst else >xst then ;

\ pull object from ast stack
: xst>obj ( -- x )  xst@ 0< if xst>> else xst> then ;

\ read top object on xst stack
: xst@obj ( -- x )  xst>obj objdup obj>xst ;

\ s is a set of sets
\ in each element in s x is included
: nincl ( s x -- s' )
  obj>xst
  0 >yst                      \ empty set to yst
  ndup card nip 0
  do xst@obj incl fence
     yst>> union >>yst
  loop xst>obj objdrop drop
  yst>> ;

{ { 1 } { 2 3 } { 4 5 6 } } { 0 } nincl  ok
set.  {{1,{0}},{2,3,{0}},{4,5,6,{0}}} ok

{ 0 { 2 3 } { 4 5 6 } } 7 nincl  ok
set. {{7},{2,3,7},{4,5,6,7}} ok

: powerset ( s -- s' )
  ncheck 0= if -1 exit then   \ returns {0}
  nsplit obj>xst recurse ndup
  xst>obj nincl union ; 

{ } ndup set. 0  ok
powerset ndup set. {0} ok
powerset ndup set. {0,{0}} ok
powerset ndup set. {0,{0},{{0}},{0,{0}}} ok
powerset ndup set. {0,{0},{{0}},{0,{0}},{{{0}}},{0,{{0}}},{{0},{{0}}},{0,{0},{{0}}},{{0,{0}}},{0,{0,{0}}},{{0},{0,{0}}},{0,{0},{0,{0}}},{{{0}},{0,{0}}},{0,{{0}},{0,{0}}},{{0},{{0}},{0,{0}}},{0,{0},{{0}},{0,{0}}}} ok