## Friday, February 19, 2016

### 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

#### 1 comment:

1. If you need your ex-girlfriend or ex-boyfriend to come crawling back to you on their knees (no matter why you broke up) you gotta watch this video
right away...

(VIDEO) Have your ex CRAWLING back to you...?