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