## Monday, January 11, 2016

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

: n>ad1 ( n -- )  0 <# #s #> fillad\$ ;

\ 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
ndup card nip 0
do flag if [char] , a>ad1 then dup 0<
then flag 0= if true to flag then

: 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