Set algebra

In bundles that represent sets all integers must be sorted, because the word smember stop searching for a single member when reaching an integer less than the integer to be tested. While zetmerge is faster than union it's safer to use union. Never the less, I have tried to replace union with zetmerge as much as possible, with considerable faster code. It seems to work.

: union \ -- | s s' -- sUs'
  zetmerge set-sort reduce ;

: intersection \ -- | s s' -- sΛs'
  0 >xst zst yst setmove
  begin zst@
  while zsplit zfence zdup zst> drop
     yst zst setcopy member
     if xst zst setmove zetmerge zst xst setmove
     else zdrop
     then
  repeat zdrop yst setdrop
  xst zst setmove reduce ;

: diff \ -- | s s' -- s\s'
  0 >xst zst yst setmove
  begin zst@
  while zsplit zfence zdup zst> drop
     yst zst setcopy member
     if zdrop
     else xst zst setmove zetmerge zst xst setmove
     then
  repeat zdrop yst setdrop
  xst zst setmove reduce ;

: multincl \ -- |{s1,...,sn} x -- {s1U{x},...,snU{x}}
  0 >xst zfence zst yst setmove
  begin zst@
  while zsplit yst zst setcopy union zfence
     xst zst setmove zetmerge zst xst setmove
  repeat zdrop yst setdrop xst zst setmove ;

: powerset \ -- | s -- p(s)      Set of all subsets
  zst@ 0= if -2 >zst exit then
  zsplit zfence zst yst setmove recurse
  zdup yst zst setmove zst> drop multincl
  zetmerge ;

: cartprod \ -- | s s' -- s×s'   Cartesian product
  zst yst setmove
  zst xst setcopy xst> drop cardinality 0 0 >zst
  ?do xfence -1 xst+!
     yst setdup
     begin yst@
     while ysplit yfence -1 yst+!
        xst zst setcopy
        yst zst setmove vmerge
        zfence
        zetmerge
     repeat yst> drop xst setdrop
  loop yst setdrop ;

: infence \ -- |{x1,...,xn} -- {{x1},...,{xn}}
  0 >xst foreach
  ?do zfence zfence
     xst zst setmove zetmerge
     zst xst setmove
  loop xst zst setmove ;

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:

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.

\ Set of all subsets with k elements

\ p(A,k)=p(A\{f(A)},k)+(p(A\{f(A)},k-1)%f(A))
: power# \ k -- | s -- p(s,k)
  ?dup 0= if zdrop 0 >zst zfence exit then
  dup 1 = if drop infence exit then
  dup zdup cardinality =
  if drop zfence exit then
  dup 1 = if drop infence exit then
  zsplit zfence zst xst setmove
  dup zdup recurse
  zswap 1- recurse xst zst setmove
  zst> drop multincl
  zetmerge ;

Before trying to calculate p(A,k) it's a good idea to count the number of elements:

|p(A,k)|=choose(|A|,k).

\ http://rosettacode.org/wiki/Evaluate_binomial_coefficients#Forth
: choose \ n k -- nCk
  1 swap 0 ?do over i - i 1+ */ loop nip ;

: multiunion \ -- |{s1,...,sn} -- s1U...Usn
  foreach 0 >zst
  ?do zetmerge
  loop set-sort reduce ;

: zetcup \ -- |{s1,...,sn} s -- {s1Us,...,snUs}

  zst xst setmove 0 >yst foreach
  ?do xst zst setcopy union zfence
     yst zst setmove zetmerge zst yst setmove
  loop xst setdrop yst zst setmove ;

: zetcap \ -- |{s1,...,sn} s' -- {s1Λs',...,snΛs'}

  zst xst setmove 0 >yst foreach
  ?do xst zst setcopy intersection zfence
     yst zst setmove zetmerge zst yst setmove
  loop xst setdrop yst zst setmove ;

: zetunion \ -- |{ s1,...,sn} {t1,...,tm} -- {siUtj}ij
  0 >xst zst yst setmove foreach
  ?do yst zst setcopy
     zswap zetcup
     xst zst setmove union
     zst xst setmove
  loop yst setdrop xst zst setmove ;

The set of functions:

: functions \ -- | s s' -- fun(s,s')

  secobjad @ 0= if zdrop -2 >zst exit then
  secobjad @ -2 = if cartprod infence exit then
  zswap zsplit zfence zst xst setmove
  zover recurse zswap xst zst setmove
  zswap cartprod infence zetunion ;

utime { 1 2 3 } zdup functions 3 power# cardinality cr . utime d- d.
2925 -628052  ok

ZET creates and count this set with 2925 elements in 0.63 seconds.

utime { 1 100000 | prime } utime cr d- d. cardinality .
-6652182 9592  ok
utime { 1 10 | all } powerset utime cardinality cr . d- d.
512 -24502  ok
utime { 1 11 | all } powerset utime cardinality cr . d- d.
1024 -83816  ok
utime { 1 12 | all } powerset utime cardinality cr . d- d.
2048 -251767  ok
utime { 1 13 | all } powerset utime cardinality cr . d- d.
4096 -986219  ok
utime { 1 14 | all } powerset utime cardinality cr . d- d.
8192 -3944057  ok

{ 1 2 3 } zdup functions cr zet.

{{(3,3),(2,3),(1,3)},{(3,2),(2,3),(1,3)},{(3,1),(2,3),(1,3)},{(3,3),(2,2),(1,3)},{(3,2),(2,2),(1,3)},{(3,1),(2,2),(1,3)},{(3,3),(2,1),(1,3)},{(3,2),(2,1),(1,3)},{(3,1),(2,1),(1,3)},{(3,3),(2,3),(1,2)},{(3,2),(2,3),(1,2)},{(3,1),(2,3),(1,2)},{(3,3),(2,2),(1,2)},{(3,2),(2,2),(1,2)},{(3,1),(2,2),(1,2)},{(3,3),(2,1),(1,2)},{(3,2),(2,1),(1,2)},{(3,1),(2,1),(1,2)},{(3,3),(2,3),(1,1)},{(3,2),(2,3),(1,1)},{(3,1),(2,3),(1,1)},{(3,3),(2,2),(1,1)},{(3,2),(2,2),(1,1)},{(3,1),(2,2),(1,1)},{(3,3),(2,1),(1,1)},{(3,2),(2,1),(1,1)},{(3,1),(2,1),(1,1)}} ok