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.

: setdrop \ ad --
  dup @ @ cs cells cell+ negate swap +! ;

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

: setover \ ad --
  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 ;

: setcopy loc{ ad1 ad2 -- }
  ad1 @ @ cs cells             \ n'
  ad1 @ over - swap cell+      \ ad1-n' n
  ad2 @ cell+ over ad2 +! swap cmove ;

: setmove \ ad1 ad2 --
  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 +! ;
: zswap  zover adn2 adn3 rot + move zdrop ;
: 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 value addr1

: addr1- \ --
  addr1 1- to addr1 ;

: fillad$ \ addr n --
  dup 1- negate addr1 + dup to addr1 swap move addr1- ;

: n>addr1 \ n --
  0 <# #s #> fillad$ ;

: a>addr1 \ c --
  addr1 c! addr1- ;

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 ;

: list$ \ n1...nk -k ad -- ad n
  dup to addr1 false loc{ addr2 flag }
  closep a>addr1
  foreach
  do flag if [char] , a>addr1 then zst@ 0<
     if addr1 recurse 2drop
     else zst> n>addr1
     then flag 0= if true to flag then
  loop openp a>addr1
  addr1 1+ addr2 over - 1+ ;

\ 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.

: _split \ ad --   ad=yst,zst
  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:

: secobjad \ -- ad | x y -- x y
  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
  secobjad dup @ 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 --
  secobjad @ ?obj
  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