## Friday, February 12, 2016

### Nested sets

[Some errors are corrected and some other changes is done]

The previous posts about sets are obsolete from now and are removed from the code site, namely: Dynamic sets, Permutation groups, Subsets and subgroups, Moore about subgroups, A conjecture about groups, Topology.

The implementation of sets is similar to the previous, but now the sets are handled by the three implemented stacks xst, yst and zst, where zst is the parameterstack for sets. An other difference is that the bundles are coded to permit vectors as elements.

{ 0 1 2 3 ( 4 5 6 6 ) { 7 { 8 8 } } 9 0 } cr showz cr zet.
1 2 3 4 5 6 6 -9 7 8 -2 -6 9 0 -28
{1,2,3,(4,5,6,6),{7,{8}},9,0} ok

Negative integers indicate a bundle count, even for sets and odd for vectors. If the absolute value of these numbers are divided by 2 the number of integers in the bundle is obtained.

### Stacks

Implementation of the three stacks:

: cs negate 2/ ;
: listflag 1 and ;

: objsize \ bc -- n
dup 0< if cs 1+ else drop 1 then ;

cell negate constant -cell
: >stack ( n ad -- )  cell over +! @ ! ;
: stack> ( ad -- n )  dup @ @ -cell rot +! ;
: >stack> ( n ad -- m )  dup @ @ -rot @ ! ;
: stack@ ( ad -- n )  @ @ ;
: stack! ( n ad -- )  @ ! ;
: stack+! ( n ad -- )  @ +! ;

cell 1- log~ constant cellshift
: stack-depth ( ad -- n )  dup @ swap - cellshift rshift ;
: stack-cl ( ad -- )  dup ! ;
: stack-empty ( ad -- flag )  dup @ = ;

1 16 lshift cells allocate throw dup constant xst dup !
: >xst ( n -- )  xst >stack ;
: xst> ( -- n )  xst stack> ;
: >xst> ( n -- m )  xst >stack> ;
: xst@ ( -- n )  xst @ @ ;
: xst! ( n -- )  xst @ ! ;
: xst+! ( n -- )  xst @ +! ;

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

1 20 lshift cells allocate throw dup constant yst dup !
: >yst ( n -- )  yst >stack ;
: yst> ( -- n )  yst stack> ;
: >yst> ( n -- m )  yst >stack> ;
: yst@ ( -- n )  yst @ @ ;
: yst! ( n -- )  yst @ ! ;
: yst+! ( n -- )  yst @ +! ;

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

1 21 lshift cells allocate throw dup constant zst dup !
: >zst ( n -- )  zst >stack ;
: zst> ( -- n )  zst stack> ;
: >zst> ( n -- m )  zst >stack> ;
: zst@ ( -- n )  zst @ @ ;
: zst! ( n -- )  zst @ ! ;
: zst+! ( n -- )  zst @ +! ;

: >>zst ( xn ... x1 bc -- )  >r r@ cs 0 ?do >zst loop r> >zst ;
: zst>> ( -- x1 ... xn -n )  zst@ >r zst> cs 0 ?do zst> loop r> ;

: showx xst stack-depth if xst> >r recurse r> dup . >xst then ;
: showy yst stack-depth if yst> >r recurse r> dup . >yst then ;
: showz zst stack-depth if zst> >r recurse r> dup . >zst then ;

: >zet ( s -- | -- s)
>>yst yst> dup >r cs 0
?do yst> >zst loop r> >zst ;

: zet> ( -- s | s -- )

zst> dup >r cs 0
?do zst> >xst loop r> >xst xst>> ;

The word >>xst moves a bundle from the datastack to xst and xst>> do the reverse. But the order of the elements will be reversed. The words >zet and zet> from moves bundles between the datastack and the zst-stack without reversing the order.

All words beginning with set is called with one or two stack addresses.

dup @ @ cs cells cell+ negate swap +! ;

>r
r@ @ @ cs cells                 \ n'
r@ @ over -                     \ n' ad1
rot cell+ dup r> +! cmove ;

dup >r @ @ cs cells cell+       \ nr of bytes 1'st set
r@ @ swap -                     \ ad to 2'nd set
dup @ cs cells cell+ dup >r -   \ ad to 3'rd set
cell+ r> r@ @ cell+             \ ad to move to
swap dup r> +! cmove ;

ad1 @ @ cs cells             \ n'

swap dup rot setcopy setdrop ;

The three words below gets the addresses and the counts for the first, second and third sets on the zst-stack.

: adn1 zst@ cs cells zst @ over - swap cell+ ;
: adn2 adn1 drop cell- dup @ cs cells tuck - swap cell+ ;
: adn3 adn2 drop cell- dup @ cs cells tuck - swap cell+ ;

All words beginning with z acts on the zst-stack, and the words below manipulates sets.

: zdup  zst setdup ;
: zdrop  zst setdrop ;
: zover  adn2 tuck zst @ cell+ swap cmove zst +! ;
: znip  zswap zdrop ;
: ztuck  zswap zover ;
: zrot  zst>> zswap >>zst zswap ;

### Output of sets

The output is built up backwards in a buffer which is printed out.

0 <# #s #> fillad\$ ;

Defining the cardinality here for the definition of foreach that removes the fences around the top set on the zst-stack and prepare for a do-loop.

: cardinality \ -- n | s --
zst> cs dup >xst 0
?do zst@ 0<
if zst@ dup cs negate xst+! >r zdrop r> cs 1+
else zst> drop 1
then
+loop xst> ;

: foreach \ -- n 0 | s -- z1...zn
zdup cardinality zst> drop 0 ;

: closep \ -- bc asc
zst@ dup listflag if [char] ) else [char] } then ;

: openp \ bc -- asc
listflag if [char] ( else [char] { then ;

foreach
do flag if [char] , a>addr1 then zst@ 0<
then flag 0= if true to flag then

\ Corrected code:
1 20 lshift dup allocate throw swap cell - + constant printbuf

: zet. \ -- | s --   prints top set on zst stack
zst@ 0=
if zst> .
else printbuf list\$ type
then ;

: set. \ ad --  prints top set on xst or yst stack
zst setcopy zet. ;

### Analyzing sets

The next word analyse a bundle cell: 0 integer, 1 vector, 2 set.

: ?obj \ x -- 0,1,2
dup 0<
if listflag
if 1 else 2 then
else drop 0
then ;

Splitting a set is to put the top element at top of stack just before the rest of the set, which eventually is the empty set 0.

dup >r @ cell- @ 0< 0=
if r@ stack> 2 + r@ stack> swap r@ >stack r> >stack exit then
r@ stack>
r@ xst setmove
xst@ cs 1+ 2* + r@ >stack
xst r> setmove ;

: ysplit \ -- | s -- s' x  in yst stack
yst _split ;

: zsplit \ -- | s -- s' x
zst _split ;

### Set equal, subset and membership

The word zet= is defined by subset, member is defined by zet= and subset is defined by member, by recursion. Next word examines if the integer n is a member of the set s.

A change is made in this section. All sets of integers are sorted and smember use that for faster exit when 'not member'.

: zetmerge \ -- | s s' -- s"
zst yst setmove
yst@ zst> +
yst zst setmove
zst! ;

: vmerge \ -- | v v'-- v"
zst yst setmove
yst@ zst> + 1+
yst zst setmove
zst! ;

: _fence \ ad -- | x -- {x}
dup >r stack@ ?obj
case 0 of -2 r@ >stack endof
1 of r@ stack@ 1- r@ >stack endof
2 of r@ stack@ 2 - r@ >stack endof
endcase rdrop ;

: xfence xst _fence ;
: yfence yst _fence ;
: zfence zst _fence ;

: set-sort \ -- | s -- n1...nk -2k
0 loc{ counter } 0 >xst 0 >yst
foreach
?do zst@ ?obj
case 0 of counter 1+ to counter zst> endof
1 of zfence xst zst setmove zetmerge zst xst setmove endof
2 of zfence yst zst setmove zetmerge zst yst setmove endof
endcase
loop counter sort 2* negate >zet

xst zst setmove zetmerge
yst zst setmove zetmerge ;

: smember \ n -- flag | s --
zst@ cs false loc{ m flag }
foreach
?do zst@ 0<
if m zst@ cs 1+ - to m zdrop
else m 1- to m dup zst> 2dup >
if false to flag 2drop
m cells negate zst +! leave
then =
if true to flag
m cells negate zst +! leave
then
then
loop drop flag ;

Equality for vectors:

: vect= \ s -- flag | s' --
\ non empty list not including non empty sets
dup zst@ = 0=
if zdrop cs 0 ?do drop loop false exit
then true loc{ flag } zst> drop cs 0
?do flag
if zst> = 0= if false to flag then
else zst> 2drop
then
loop flag ;

: vector= \ -- flag | s s' --
zet> vect= ;

Examines if the vector s is a member in the set s':

: vmember \ -- flag | s s' --
zswap zst yst setmove
zst@ cs false loc{ m flag }
foreach
?do zst@ ?obj
case 0 of m 1 - to m zst> drop endof
1 of m zst@ cs 1+ - to m
yst zst setcopy vector=
if true to flag
m cells negate zst +! leave
then endof
2 of m zst@ cs 1+ - to m
zst@ cs 1+ cells negate zst +! endof
endcase
loop yst setdrop flag ;

Get the count/integer of the second object of the zst-stack:

zst @ zst@ 0< if zst@ cs 1+ cells - else cell - then ;

Move the second object of zst-stack to datastack:

: routout \ -- x | x s -- s
p @ swap dup cell+ swap zst@ cs 1+ cells move
zst> drop ;

0 value 'subset
: subset \ -- flag | s s' --
'subset execute ;

: zet= \ -- flag | s s' --
zover zover subset
if zswap subset
else zdrop zdrop false
then ;

Examines if s is a set-member:

: zet-member \ -- flag | s s' --
zswap zst yst setmove
begin zst@                         \ set not empty?
while zsplit zst@ ?obj 2 =         \ element is a set?
if yst zst setcopy zet=
if yst setdrop zdrop true exit then
else zst@ ?obj if zdrop else zst> drop then
then
repeat yst setdrop zdrop false ;

: member \ -- flag | x s --
case 0 of routout smember endof
1 of vmember endof
2 of zet-member endof
endcase ;

:noname \ -- flag | s s' --          \ the subset code
zst @ cell - 2@ or 0=
if zdrop zdrop true exit then      \ true if both sets are empty
zswap zst yst setmove
begin yst@                         \ set is not empty?
while ysplit yst@ ?obj
if yst zst setmove zover member
else yst> zdup smember
then 0= if yst setdrop zdrop false exit then
repeat yst> drop zdrop true ; to 'subset

Merge two sets on zst-stack:

: zetmerge \ -- | s s' -- s"
zst yst setmove
yst@ zst> +
yst zst setmove
zst! ;

Merge two vectors on zst-stack:

: vmerge \ -- | v v'-- v"
zst yst setmove
yst@ zst> + 1+
yst zst setmove
zst! ;

: _fence \ ad -- | x -- {x}
dup >r stack@ ?obj
case 0 of -2 r@ >stack endof
1 of r@ stack@ 1- r@ >stack endof
2 of r@ stack@ 2 - r@ >stack endof
endcase rdrop ;

: xfence xst _fence ;
: yfence yst _fence ;
: zfence zst _fence ;

The important word that reduce multiple members in a set at top of zst-stack:

: reduce \ -- | s -- s'
0 >yst foreach
?do zfence zdup zst> drop
yst zst setcopy member
if zdrop
else yst zst setmove
zetmerge zst yst setmove
then
loop yst zst setmove ;

### Input of sets

0 create match ,
true value sort?

: { \ --
1 match +! depth >xst true to sort? ;

\ Integer sorting is included
: } \ x1...xk --
depth xst> - 2* negate
-1 match +! >zet sort?

if set-sort then reduce match @
if zet> then true to sort? ;

Next word resets everything and should be automatic on error somehow.

: q  xst stack-cl yst stack-cl zst stack-cl 0 match ! abort ;

: (  { ;

: ) \ x1...xk --
depth xst> - 2* 1+ negate
-1 match +! >zet match @ if zet> then ;

### Integer conditions

\ n -- flag
: pairprime dup prime over 2 + prime rot 2 - prime or and ;
: odd 1 and ;  \ n -- flag
: 1mod4 4 mod 1 = ;  \ n -- flag
: 3mod4 4 mod 3 = ;  \ n -- flag
: sqr dup sqrtf dup * = ;
: all dup = ;
: sqrfree dup radical = ;     \ square free test
: semiprime bigomega 2 = ;    \ number is product of two primes?
: uniprime smallomega 1 = ;   \ number is power of single prime?
: biprime smallomega 2 = ;    \ number has two different pfactors?

: 2sqrsum dup 0               \ number sum of two squares?
?do dup i dup * - dup
0< if drop false leave then
sqr if true leave then

loop nip ;

: | \ m n -- x1...xk
swap ' loc{ xt }
?do i xt execute if i then

loop false to sort? ;

{ 10000 20000 | pairprime } cardinality . 274  ok
53 >zst { 1 100 | prime } member . -1 ok
{ 100 200 | pairprime } { 100 200 | prime } subset . -1  ok
{ 1000 2000 | sqrfree } cardinality . 607  ok
{ 2000 3000 | sqrfree } cardinality . 609  ok
{ 3000 4000 | sqrfree } cardinality . 609  ok
{ 8000 9000 | sqrfree } cardinality . 608  ok
( 1 1 ) { { 0 } ( 1 1 ) } member . -1  ok
{ 1 100 | prime } cr zet.
{2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97} ok
{ 1 100 | uniprime } { 1 100 | semiprime } union cr zet.
{2,3,4,5,6,7,8,9,10,11,13,14,15,16,17,19,21,22,23,25,26,27,29,31,32,33,34,35,37,38,39,41,43,46,47,49,51,53,55,57,58,59,61,62,64,65,67,69,71,73,74,77,79,81,82,83,85,86,87,89,91,93,94,95,97} ok

1. 2. 