tag:blogger.com,1999:blog-53097757361312967252024-03-27T01:15:11.465-07:00Forth & mathBigZ - computational mathematics, big integers and sets
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.comBlogger34125tag:blogger.com,1999:blog-5309775736131296725.post-28700358876132215282021-06-30T14:29:00.000-07:002021-06-30T14:29:53.086-07:00Polynomials in Z[X]<span style="font-family: "courier new" , "courier" , monospace;">The separate stacks xst, yst and zst used for the implementation of nested sets, can also be used to dynamical allocation of arrays, here arrays for the coefficients of polynomials. Defining a non nested list of integers</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">( 3 0 -2 7 -3 1 ) ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">works as long as the list not is interpreted as nested, when the negative numbers signalize a count. (All number elements of nested sets or lists must be non negative.)</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Interpreted as non nested linear lists all set stack manipulation words works, so the administration of these polynomials works as usual in Forth. The list above correspond to the polynomial</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">( 3 0 -2 7 -3 1 ) poly. 3-2x²+7x³-3x⁴+x⁵ ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ Polynomials</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: >da \ vect -- vect ad n </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zst @ zst@ cs tuck cells - swap ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ Gives the address to the first coefficient plus the count</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ of the polynomial at top of stack</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: >da2 \ vect2 vect1 -- vect2 vect1 ad2 n2 </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> adn2 cell- cell / ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ Gives address and count to the second polynomial of stack</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: >zst+ \ vect1 m -- vect2 </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zst> swap >zst 2 - >zst ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ Add item to the list</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: da \ -- vect ad </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> -1 >zst zst @ ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ Initiate an empty list </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: da. \ vect -- </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> >da 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do dup i cells + @ .</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> l</span><span style="font-family: "courier new" , "courier" , monospace;">oop zdrop drop ;</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ print the coefficients</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">The word Z. cannot be used since it interpret the list as nested.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">( 3 0 -2 7 -3 1 ) da. 3 0 -2 7 -3 1 ok</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
Some systems can write exponents:</div>
<div>
<br /></div>
<div>
\ Printing polynomials</div>
<div>
<br /></div>
<div>
<div>
create potence </div>
<div>
s" " s, s" x" s, s" x²" s, s" x³" s, s" x⁴" s, </div>
<div>
s" x⁵" s, s" x⁶" s, s" x⁷" s, s" x⁸" s, s" x⁹" s, </div>
<div>
s" x¹⁰" s, s" x¹¹" s, s" x¹²" s, s" x¹³" s, s" x¹⁴" s, </div>
<div>
<br /></div>
<div>
true value lowterm </div>
<div>
: .term \ i n -- </div>
<div>
?dup 0= if drop exit then</div>
<div>
dup 0<</div>
<div>
if ." -"</div>
<div>
else lowterm 0= if ." +" then</div>
<div>
then abs dup 1 > 2 pick 0= or</div>
<div>
if 0 <# #s #> type </div>
<div>
else drop </div>
<div>
then false to lowterm </div>
<div>
cells potence + count type ; </div>
<div>
<br /></div>
<div>
: poly. \ vect --</div>
<div>
true to lowterm</div>
<div>
>da 0 </div>
<div>
do i over i cells + @ .term</div>
<div>
loop zdrop drop ;</div>
</div>
<div>
<br /></div>
<div>
Since BigZ is limited to non negative integers greatest common divisor is defined for unsigned integers UGCD and a word GCD for all integers have to be defined:</div>
<div>
<br /></div>
<div>
<div>
: gcd \ n1 n2 -- n \ Greatest common divisor</div>
<div>
2dup or 0= </div>
<div>
if 2drop 1 exit then </div>
<div>
abs swap abs </div>
<div>
2dup u< if swap then \ smallest of a b on top of stack</div>
<div>
?dup 0= if exit then \ return second value if tos is zero</div>
<div>
begin tuck \ y x y first time b a b</div>
<div>
0 swap um/mod \ y x 0 y --> y r q</div>
<div>
drop dup 0= \ y r [r=0]</div>
<div>
until drop ; \ y</div>
<div>
<br /></div>
<div>
: multgcd \ k1...kn n -- gcd</div>
<div>
1 do gcd loop ;</div>
</div>
<div>
\ Gives multiple greatest common device</div>
<div>
<br /></div>
<div>
\ Calculation with polynomials</div>
<div>
<br /></div>
<div>
<div>
: polynom \ ad n m -- m' </div>
<div>
locals| m | cells over + cell- </div>
<div>
dup @ -rot cell- </div>
<div>
?do m * i @ + -cell +loop ; </div>
<div>
\ m' is the evaluation of m with polynomial at ad n</div>
<div>
<br /></div>
<div>
: polyn \ vect m -- vect m'</div>
<div>
>da rot polynom ;</div>
<div>
\ m' is the evaluation of m with the polynomial vect</div>
<div>
<br /></div>
<div>
: gcoeff \ vect -- vect n</div>
<div>
zst @ cell - @ ;</div>
<div>
\ Gives the coefficient of the greatest power</div>
<div>
<br /></div>
<div>
: rrzs \ vect1 -- vect2 "reduce right zeroes"</div>
<div>
begin gcoeff 0= </div>
<div>
while zst> zst> drop 2 + >zst</div>
<div>
repeat ;</div>
<div>
\ Eliminate leading coefficient equal to zero</div>
<div>
<br /></div>
<div>
: poly* \ ad1 n1 ad2 n2 -- vect </div>
<div>
locals| n2 ad2 n1 ad1 | da drop </div>
<div>
n1 n2 + 1- 0 </div>
<div>
do 0 i 1+ 0 </div>
<div>
do j i - 0 n2 within i n1 < and</div>
<div>
if i cells ad1 + @ </div>
<div>
j i - cells ad2 + @ * + </div>
<div>
then</div>
<div>
loop >zst+</div>
<div>
loop rrzs ; </div>
<div>
\ Multiply polynomials given by arrays</div>
<div>
<br /></div>
<div>
: p* \ vect1 vect2 -- vect3 </div>
<div>
>da2 >da poly*</div>
<div>
znip znip ;</div>
<div>
\ Multiply polynomials</div>
<div>
<br /></div>
<div>
<div>
( 0 -1 2 1 ) zdup poly. -x+2x²+x³ ok</div>
<div>
( 2 0 2 3 ) zdup poly. 2+2x²+3x³ ok</div>
<div>
p* poly. -2x+4x²+x⁴+8x⁵+3x⁶ ok</div>
</div>
<div>
<br /></div>
<div>
: p+ \ vect1 vect2 -- vect3 </div>
<div>
adn2 nip adn1 nip < if zswap then </div>
<div>
adn2 drop locals| ad | </div>
<div>
zst>> cs 0 </div>
<div>
do ad i cells + +! </div>
<div>
loop rrzs ;</div>
<div>
\ Add polynomials</div>
<div>
<br /></div>
<div>
: pnegate \ vect1 -- vect2</div>
<div>
adn1 cell- 0</div>
<div>
do dup i + dup @ negate swap ! cell</div>
<div>
+loop drop ;</div>
<div>
\ Negate a polynomial</div>
<div>
<br /></div>
<div>
: p- \ vect1 vect2 -- vect3</div>
<div>
pnegate p+ ;</div>
<div>
\ Subtract polynomials</div>
<div>
<br /></div>
<div>
: ps/ \ vect1 n -- vect2</div>
<div>
locals| n |</div>
<div>
>da cells over + swap</div>
<div>
do i @ n / i ! cell +loop ;</div>
</div>
<div>
\ Divide polynomial with integer</div>
<div>
<br /></div>
<div>
<div>
: makepoly \ vect ad n -- name of polynomial</div>
<div>
cr ." : " type space </div>
<div>
zst> zst> .</div>
<div>
cs 1- 1</div>
<div>
do ." over * " zst> . ." + "</div>
<div>
loop ." * " zst> . ." + ; " ;</div>
</div>
<div>
\ Prints the definition of a polynomial to be pasted</div>
<div>
<br /></div>
<div>
( 3 0 -2 7 -3 1 ) s" poly1" makepoly</div>
<div>
<div>
: poly1 1 over * -3 + over * 7 + over * -2 + over * 0 + * 3 + ; ok</div>
</div>
<div>
<br /></div>
<div>
Copying and pasting the output easy define the polynomial POLY1, eventually after some cleaning.</div>
<div>
<br /></div>
<div>
There is a nice theory of integer-valued polynomials by Pólya. That is, polynomial with rational coefficients that gives integer outputs for integer inputs. The set of these polynomials is a subring of Q[X], the ring of all rational polynomials. This subring is denoted int(Z).</div>
<div>
<br /></div>
<div class="separator" style="clear: both; text-align: center;">
<a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEhRN-I-PrGhyphenhyphenW6UHtHPT7AoJ7kSnqHXfOT9AS3C0AeZ8wD4OVTE6WFliGFeP8-h4DVhg98crv7BRUcWJ-mdqt8qCdWaaG2rXcYzheA_Du-JiHEomzyPfmlQ6k-Gbh_riV7_M39VmaINRGcr/s1600/poloya.jpg" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" data-original-height="210" data-original-width="490" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEhRN-I-PrGhyphenhyphenW6UHtHPT7AoJ7kSnqHXfOT9AS3C0AeZ8wD4OVTE6WFliGFeP8-h4DVhg98crv7BRUcWJ-mdqt8qCdWaaG2rXcYzheA_Du-JiHEomzyPfmlQ6k-Gbh_riV7_M39VmaINRGcr/s1600/poloya.jpg" /></a></div>
<div>
<br /></div>
</span><span style="font-family: "courier new" , "courier" , monospace;"><div>
This can be used to calculate the fixed prime divisors of polynomials with integer coefficients. Even if the coefficients of a polynomial in Z[X] has the greatest common divisor 1, all the outputs of the polynomial might be divisible by a fixed number. For example the polynomial </div>
<div>
<br /></div>
<div>
6-9x-2x²+5x⁴ </div>
<div>
<br /></div>
<div>
always give an output that is divisible by 6, and therefore have the fixed prime divisors 2 and 3.</div>
<div>
<br /></div>
<div>
<div>
\ Integer valued polynomials </div>
<div>
<br /></div>
<div>
: bin*sum \ ad k -- sum </div>
<div>
locals| k ad |</div>
<div>
k 0= if 1 exit then 0 k 0 </div>
<div>
?do i cells ad + @ </div>
<div>
k i choose * + </div>
<div>
loop ; </div>
<div>
\ Calculate the sum in the figure above</div>
<div>
<br /></div>
<div>
: polyacoeff \ ad1 n1 -- vect </div>
<div>
da locals| ad2 n1 ad1 |</div>
<div>
ad1 @ >zst+ </div>
<div>
n1 1</div>
<div>
?do ad1 n1 i polynom </div>
<div>
ad2 i bin*sum - >zst+</div>
<div>
loop ; </div>
<div>
\ Calculate the vector (c0,...,cn) from </div>
<div>
\ integer polynomial at ad1 n1</div>
<div>
<br /></div>
<div>
: polya \ ad n m -- m'</div>
<div>
swap -rot locals| m ad | 0 swap 0</div>
<div>
?do i cells ad + @ </div>
<div>
m i choose * +</div>
<div>
loop ;</div>
<div>
\ m' is the evaluation of m with the pólya function at ad n</div>
<div>
<br /></div>
<div>
: coeffgcd \ vect -- n</div>
<div>
zst>> cs \ CS transform set count into stack count<br />
multgcd ;<br />
<br />
<br />
<div style="-webkit-text-stroke-width: 0px; color: black; font-family: "courier new", courier, monospace; font-size: medium; font-style: normal; font-variant-caps: normal; font-variant-ligatures: normal; font-weight: 400; letter-spacing: normal; orphans: 2; text-align: start; text-decoration-color: initial; text-decoration-style: initial; text-indent: 0px; text-transform: none; white-space: normal; widows: 2; word-spacing: 0px;">
</div>
<br />
<div style="-webkit-text-stroke-width: 0px; color: black; font-family: "courier new", courier, monospace; font-size: medium; font-style: normal; font-variant-caps: normal; font-variant-ligatures: normal; font-weight: 400; letter-spacing: normal; orphans: 2; text-align: start; text-decoration-color: initial; text-decoration-style: initial; text-indent: 0px; text-transform: none; white-space: normal; widows: 2; word-spacing: 0px;">
<div style="margin: 0px;">
: fixdiv \ vect -- vect n</div>
<div style="margin: 0px;">
>da \ get address and count for polynomial</div>
<div style="margin: 0px;">
polyacoeff \ calculate Pólya's coefficients</div>
<div style="margin: 0px;">
coeffgcd ;</div>
</div>
\ The multiple GCD of c0,...,cn is the fixed divisor of the</div>
</div>
<div>
\ corresponding original polynomial with integer coefficients</div>
<div>
<br />
<u>Eisensteins criteria</u>: If there exist a prime number p which not divides an but a0,...,an-1, and p² not divide a0, then<br />
a0+a1*x+a2*x²+...+an*x^n is irreducible over the rational numbers.<br />
<br /></div>
<div>
\ Eisenstein's criteria</div>
<div>
<br /></div>
<div>
<div>
: iseisenstein \ vect -- vect flag "is an Eisenstein polynomial?"</div>
<div>
zdup zst> 2 + zst> abs false 0 locals| p flag an |</div>
<div>
>zst zst>> cs multgcd abs primes ?dup</div>
<div>
if 0</div>
<div>
do to p flag 0=</div>
<div>
if an p umod 0= 0=</div>
<div>
>da drop @ abs p ^2 umod 0= 0= and</div>
<div>
to flag </div>
<div>
then</div>
<div>
loop </div>
<div>
then flag ;</div>
</div>
<div>
<br /></div>
<div>
Most polynomial are irreducible but very few are Eisenstein.<br />
<br />
<u>Theorem 1 (Chen & al)</u>: If the polynomial f(X) in Z[X] is reducible then the number of positive primes of the form f(a) is less then or equal the degree of f(X). For all degrees n there is a reducible polynomial f(X) with different a1,...,an such that f(ai) is a positive prime.<br />
<br />
So finding a polynomial giving primes for n+1 different values is finding an irreducible polynomial. But a lot of polynomials have a fixed divisor greater than one, and those can't be proved irreducible by the theorem above. A more relevant test is therefore to combine theorem 1 with the Pólya fix divisor test.<br />
<br />
: ischen \ vect -- vect flag "false may be and true is irreducible"<br />
fixdiv 1 > if false exit then<br />
degree locals| n |<br />
0 bits n / 2e s>f f** f>s 1000 min 0<br />
do i polyn dup 0><br />
if isprime -<br />
dup n > if leave then<br />
else drop<br />
then<br />
i negate polyn dup 0><br />
if isprime -<br />
dup n > if leave then<br />
else drop<br />
then<br />
loop n > ;<br />
<br />
\ Polynomials<br />
<br />
\ Dynamical allocation of arrays<br />
<br />
: >da \ vect -- vect ad n<br />
zst @ zst@ cs tuck cells - swap ;<br />
\ Gives the address to the first coefficient plus the count<br />
\ of the polynomial at top of stack<br />
<br />
: >da2 \ vect2 vect1 -- vect2 vect1 ad2 n2 <br />
adn2 cell- cell / ;<br />
\ Gives address and count to the second polynomial of stack<br />
<br />
: >xst+ \ vect1 m -- vect2<br />
xst> swap >xst 2 - >xst ;<br />
\ Add item to the xst list<br />
<br />
: >zst+ \ vect1 m -- vect2<br />
zst> swap >zst 2 - >zst ;<br />
\ Add item to the zst list<br />
<br />
: da \ -- vect ad <br />
-1 >zst zst @ ;<br />
\ Initiate an empty list<br />
<br />
: da. \ vect --<br />
>da 0<br />
do dup i cells + @ .<br />
loop zdrop drop ;<br />
\ print the coefficients<br />
<br />
\ Printing polynomials<br />
\ 64 bits systems only<br />
<br />
create potence<br />
s" " s, s" x" s, s" x²" s, s" x³" s, s" x⁴" s,<br />
s" x⁵" s, s" x⁶" s, s" x⁷" s, s" x⁸" s, s" x⁹" s,<br />
s" x¹⁰" s, s" x¹¹" s, s" x¹²" s, s" x¹³" s, s" x¹⁴" s,<br />
s" x¹⁵" s, s" x¹⁶" s, s" x¹⁷" s, s" x¹⁸" s, s" x¹⁹" s,<br />
<br />
true value lowterm<br />
: .term \ i n --<br />
?dup 0= if drop exit then<br />
dup 0<<br />
if ." -"<br />
else lowterm 0= if ." +" then<br />
then abs dup 1 > 2 pick 0= or<br />
if 0 <# #s #> type<br />
else drop<br />
then false to lowterm<br />
cells potence + count type ;<br />
<br />
: p. \ vect --<br />
true to lowterm<br />
>da 0<br />
do i over i cells + @ .term<br />
loop zdrop drop ;<br />
<br />
\ Greatest common divisors for multiple integers<br />
<br />
: multgcd \ k1...kn n -- gcd<br />
dup 0= if exit then<br />
swap abs swap 1<br />
?do swap abs ugcd loop ;<br />
\ Gives multiple greatest common device<br />
<br />
\ Calculation with polynomials<br />
<br />
: polynom \ ad n m -- m'<br />
locals| m | cells over + cell-<br />
dup @ -rot cell-<br />
?do m * i @ + -cell +loop ;<br />
\ m' is the evaluation of m with polynomial at ad n<br />
<br />
: sbs* \ sb m -- sb*m<br />
dup 0< xs> xor >xs abs bs* ;<br />
<br />
: s>sb \ n -- sb<br />
dup abs s>b 0< >xs ;<br />
<br />
: sbpolynom \ ad n m -- sb<br />
locals| m | cells over + cell-<br />
dup @ s>sb cell-<br />
?do m sbs* i @ s>sb sb+ -cell +loop ;<br />
\ single input and big output<br />
<br />
: polyn \ vect m -- vect m'<br />
>da rot polynom ;<br />
\ m' is the evaluation of m with the polynomial vect<br />
<br />
: sbpolyn \ vect m -- vect sb<br />
>da rot sbpolynom ;<br />
\ m' is the evaluation of m with the polynomial vect<br />
<br />
: gcoeff \ vect -- vect n<br />
zst @ cell - @ ;<br />
\ Gives the coefficient of the greatest power<br />
<br />
: lcoeff \ vect -- vect n<br />
>da drop @ ;<br />
\ Gives the coefficient of the constant term<br />
<br />
: rrzs \ vect1 -- vect2 "reduce right zeroes"<br />
begin gcoeff 0=<br />
while zst> zst> drop 2 + >zst<br />
repeat ;<br />
\ Eliminate leading coefficient equal to zero<br />
<br />
: poly* \ ad1 n1 ad2 n2 -- vect<br />
locals| n2 ad2 n1 ad1 | da drop<br />
n1 n2 + 1- 0<br />
do 0 i 1+ 0<br />
do j i - 0 n2 within i n1 < and<br />
if i cells ad1 + @<br />
j i - cells ad2 + @ * +<br />
then<br />
loop >zst+<br />
loop rrzs ;<br />
\ Multiply polynomials given by arrays<br />
<br />
: p* \ vect1 vect2 -- vect3<br />
>da2 >da poly*<br />
znip znip ;<br />
\ Multiply polynomials<br />
<br />
: v+ \ vect1 vect2 -- vect3<br />
adn2 nip adn1 nip < if zswap then<br />
adn2 drop locals| ad |<br />
zst>> cs 0<br />
do ad i cells + +!<br />
loop ;<br />
\ Add vectors<br />
<br />
: p+ \ vect1 vect2 -- vect3<br />
v+ rrzs ;<br />
\ Add polynomials<br />
<br />
: ps* \ vect1 n -- vect2<br />
locals| n |<br />
>da cells over + swap<br />
do i @ n * i ! cell +loop ;<br />
\ Multiply polynomial with integer<br />
<br />
: pnegate \ vect1 -- vect2<br />
-1 ps* ;<br />
<br />
false [if]<br />
: pnegate \ vect1 -- vect2<br />
adn1 cell- 0<br />
do dup i + dup @ negate swap ! cell<br />
+loop drop ;<br />
\ Negate a polynomial<br />
[then]<br />
<br />
: p- \ vect1 vect2 -- vect3<br />
pnegate p+ ;<br />
\ Subtract polynomials<br />
<br />
: v- \ vect1 vect2 -- vect3<br />
pnegate v+ ;<br />
\ Subtract vectors<br />
<br />
: ps/ \ vect1 n -- vect2<br />
locals| n |<br />
>da cells over + swap<br />
do i @ n / i ! cell +loop ;<br />
\ Divide polynomial with integer<br />
<br />
: degree \ vect -- vect n<br />
zst@ cs 1- ;<br />
<br />
\ long division<br />
<br />
: vcutr \ vect1 n -- vect2<br />
degree swap 1- -<br />
>r zst>> cs r@ - >xs<br />
r> drops xs> 2* 1+ negate >>zst ;<br />
\ vect2 is the n rightmost coefficients of vect1<br />
<br />
: vshiftr \ vect1 -- vect2<br />
zst> zst> drop 2 + >zst ;<br />
\ drop the rightmost coefficient<br />
<br />
: getcoeff \ xvect i -- xvect n<br />
cells xst @ cell - swap - @ ;<br />
<br />
: vor \ vect -- flag<br />
zst>> cs 1 ?do or loop ;<br />
<br />
: ldivide \ -- q r<br />
zst> zst@ swap >zst<br />
yst> yst@ swap >yst<br />
/mod swap ;<br />
<br />
: lclean \ --<br />
xst setdrop yst setdrop ;<br />
<br />
: lbuild \ v n q -- v' n+1<br />
dup >xs 1 under+<br />
yst zst setcopy ps* v- ;<br />
<br />
: lnodiv \ --<br />
drop 0<br />
?do xsdrop loop false ;<br />
<br />
: p/ \ v1 v2 -- v1/v2 flag<br />
false locals| flag |<br />
degree zst yst setmove<br />
degree zst xst setcopy<br />
over 1+ vcutr \ w<br />
2 + 2 under+ swap 0 -rot<br />
do ldivide<br />
if true to flag leave then<br />
lbuild<br />
vshiftr ( i getcoeff ) zswap vmerge \ w'<br />
loop flag if lclean lnodiv exit then<br />
ldivide if lclean lnodiv exit then<br />
lbuild vor lclean<br />
( over 0 ?do xs> loop ) nip 0= ;<br />
\ flag is true if v2 divides v1<br />
\ else result is irrelevant<br />
<br />
\ auto definition of polynomial<br />
: makepoly \ vect ad n -- name of polynomial<br />
cr ." : " type space<br />
zst> zst> .<br />
cs 1- 1<br />
do ." over * " zst> . ." + "<br />
loop ." * " zst> . ." + ; " ;<br />
\ Prints the definition of a polynomial to be<br />
\ copied and pasted<br />
<br />
\ Integer valued polynomials<br />
<br />
: bin*sum \ ad k -- sum<br />
locals| k ad |<br />
k 0= if 1 exit then 0 k 0<br />
?do i cells ad + @<br />
k i choose * +<br />
loop ;<br />
<br />
: polyacoeff \ ad1 n1 -- vect<br />
da locals| ad2 n1 ad1 |<br />
ad1 @ >zst+<br />
n1 1<br />
?do ad1 n1 i polynom<br />
ad2 i bin*sum - >zst+<br />
loop ;<br />
\ Calculate the vector (c0,...,cn) from<br />
\ integer polynomial at ad1 n1<br />
<br />
: polya \ ad n m -- m'<br />
swap -rot locals| m ad | 0 swap 0<br />
?do i cells ad + @<br />
m i choose * +<br />
loop ;<br />
\ m' is the evaluation of m with the pólya function at ad n<br />
<br />
: coeffgcd \ vect -- n<br />
zst>> cs \ CS transform set count into stack count<br />
multgcd ;<br />
\ GCD of the coefficients<br />
<br />
: fixdiv \ vect -- vect n<br />
>da \ get address and count for polynomial<br />
polyacoeff \ calculate Pólya's coefficients<br />
coeffgcd ;<br />
\ The multiple GCD of c0,...,cn is the fixed divisor of the<br />
\ corresponding original polynomial with integer coefficients<br />
<br />
: divcofac \ vect -- vect'<br />
zdup coeffgcd ps/ ;<br />
<br />
: iseisenstein \ vect -- vect flag<br />
zdup zst> 2 + zst> abs false 0 locals| p flag an |<br />
>zst coeffgcd dup an ugcd 1 <><br />
if zdrop drop false exit then<br />
primes ?dup<br />
if 0<br />
do to p flag 0=<br />
if an p umod 0= 0=<br />
>da drop @ abs p ^2 umod 0= 0= and<br />
to flag<br />
then<br />
loop<br />
then flag ;<br />
<br />
2000 value xlim<br />
<br />
: isirr \ vect -- vect flag<br />
iseisenstein if true exit then<br />
degree 0= if gcoeff isp exit then<br />
degree 1 = if zdup coeffgcd 1 = exit then<br />
fixdiv degree 0 0 locals| posp negp n d |<br />
0 sbpolyn d bs/mod drop bisprime<br />
if xs@ if negp 1+ to negp else posp 1+ to posp then<br />
then xsdrop<br />
xlim 1<br />
do i sbpolyn d bs/mod drop bisprime<br />
if xs@ if negp 1+ to negp else posp 1+ to posp then<br />
then xsdrop<br />
i negate sbpolyn d bs/mod drop bisprime<br />
if xs@ if negp 1+ to negp else posp 1+ to posp then<br />
then xsdrop<br />
posp n > negp n > or if leave then<br />
loop posp n > negp n > or ;<br />
<br />
: nopsqr \ x p -- x' p|x<br />
begin 2dup /mod swap 0=<br />
while -rot nip<br />
repeat drop * ;<br />
<br />
: negate? \ |n| -- n<br />
2 random if negate then ;<br />
<br />
: pickprime \ n -- p<br />
primes dup >r 1 max random<br />
pick r> drops ;<br />
<br />
: geteis0 \ u -- vect p<br />
( )<br />
2 - 1 max random 2 +<br />
dup pickprime<br />
tuck nopsqr negate? >zst+ ;<br />
<br />
: x/p^n \ an p -- an'<br />
begin 2dup mod 0=<br />
while tuck / swap<br />
repeat drop ;<br />
<br />
: geteisvar \ n u -- vect<br />
dup geteis0 locals| p u | 1- 1 max random 1+ 0<br />
?do u p / random 1+ p * negate? >zst+<br />
loop u 1+ random 1+ p x/p^n dup 0= or<br />
negate? >zst+<br />
divcofac ;<br />
<br />
: dupderiv \ vect -- vect vect'<br />
( >da swap locals| ad | 1<br />
do ad i cells + @ i * loop ) ;<br />
<br />
: deriv \ vect -- vect'<br />
dupderiv znip ;<br />
<br />
\ p(x) --> p(x+d)<br />
<br />
: mtransl \ k d ak -- vect<br />
locals| ak d k |<br />
( k 1+ 0<br />
do k i choose d i ** * ak *<br />
loop ) ;<br />
<br />
: zerovect \ n -- vect<br />
>r ( r> 0<br />
do 0 loop ) ;<br />
<br />
: ptransl \ vect1 d -- vect2<br />
locals| d |<br />
>da 0 over zerovect<br />
do i over i cells + @ d swap<br />
mtransl p+<br />
loop drop znip ;<br />
<br />
\ Rational roots<br />
<br />
: q* \ a b c d -- ac/(ac,bd) bd/(ac,bd)<br />
rot * >r * r> \ ac bd<br />
2dup abs swap abs<br />
ugcd tuck \ ac gcd bd gcd<br />
/ >r / r> ;<br />
<br />
: q/ 2swap q* ;<br />
<br />
: q+ \ a b c d -- (ad+bc)/gcd bd/gcd<br />
dup 3 pick * >r \ a b c d r: bd<br />
-rot * -rot * + \ a*d+b*c r: bd<br />
dup abs r@ abs<br />
ugcd r> over \ a*d+b*c gcd bd gcd<br />
/ >r / r> ;<br />
<br />
: q- negate q+ ;<br />
<br />
: qpolynom \ ad n a b -- a' b'<br />
locals| b a | cells over + cell-<br />
dup @ >r cell- r> 1 2swap<br />
do a b q* i @ 1 q+ -cell +loop ;<br />
<br />
: getpospairs \ vect -- vect set<br />
lcoeff abs gcoeff abs divz divz<br />
cartprod ;<br />
<br />
: getypair \ yset -- yset' y x<br />
yst> drop yst> yst> ;<br />
<br />
: haverationalroots \ vect -- vect flag<br />
lcoeff 0= if true exit then<br />
getpospairs zst yst setmove<br />
begin yst@<br />
while ysplit<br />
getypair 2dup ugcd 1 =<br />
if >da 2over qpolynom drop 0=<br />
if yst setdrop 2drop true exit then<br />
>r negate >r<br />
>da r> r> qpolynom drop 0=<br />
if yst setdrop true exit then<br />
else 2drop<br />
then<br />
repeat yst> ;<br />
<br />
: setofroots \ vect -- vect set<br />
lcoeff 0= if true exit then<br />
getpospairs<br />
zst yst setmove xst @<br />
begin yst@<br />
while ysplit<br />
getypair 2dup ugcd 1 =<br />
if >da 2over qpolynom drop 0=<br />
if ( 2dup ) zst xst setmove then<br />
swap negate swap<br />
>da 2over qpolynom drop 0=<br />
if ( 2dup ) zst xst setmove then<br />
then 2drop<br />
repeat yst> drop<br />
xst @ - cell / 2* >xst<br />
xst zst setmove ;<br />
<br />
: .root \ b a -- "a/b"<br />
dup 0= if . drop exit then<br />
over abs 1 = if . drop exit then<br />
. 8 emit ." /" . ;<br />
<br />
: .roots \ set --<br />
zst> cs 3 / 0<br />
do zst> drop zst> zst> .root space loop<br />
;<br />
<br />
: isirreducible \ vect -- vect flag<br />
haverationalroots degree 1 > and<br />
if false else isirr then ;</div>
<div>
<br /></div>
</span></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-54192777299075698252020-01-18T06:42:00.000-08:002020-01-20T12:12:27.711-08:00About Pollard rho<span style="font-family: "courier new" , "courier" , monospace; font-size: large;">The Pollard rho algorithm factorize a composite number n in a time proportional to √p, where p is the smallest prime that divides n. In worst case p≈√n so the algorithm factorize proportional to ∜n. Compare with trial-and-error that factorize proportional to √n.</span><br />
<span style="font-size: large;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The algorithm is easy to implement and is built upon an the greatest common divisor gcd (which can be calculated by the algorithm of Euclide) and a polynomial P(x) of degree >1. Most common polynomial to use is P(x)=x²+1. Let Pn(x)=P(x) mod n, that is the rest when P(x) is divided by n. Pn is a function Pn:ℕ→ℤn, where ℤn={0,1,2,...,n-1}. The function Pn will act like a simple pseudo random generator in the algorithm.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace; font-size: large;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace; font-size: large;">Define Xi+</span>1<span style="font-family: "courier new" , "courier" , monospace; font-size: large;">=Pn(Xi). Since ℤn is a finite set there are smallest i,j such that Xi=Xi+j, when the sequence start to repeat itself. Mostly the sequence Xi isn't cyclic from the start Xo, but later on at some Xi. There is at trick to find out if Xi is in the loop or not. It's like sending away a turtle and a hare on the same track at the same time. When the hare again is comming besides the turtle they must both be in the loop.</span><br />
<span style="font-family: "courier new" , "courier" , monospace; font-size: large;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace; font-size: large;">Therefore, define a second sequence Yi+</span>1<span style="font-family: "courier new" , "courier" , monospace; font-size: large;">=Pn(Pn(Yi)), where Xo=Yo. When Yi=Xi, i>0, Xi and Yi are in the cycle. But for Pollard rho the real important sequences are the uncalculated sequences Vi+</span>1<span style="font-family: "courier new" , "courier" , monospace; font-size: large;">=Pm(Vi) and Wi+</span>1<span style="font-family: "courier new" , "courier" , monospace; font-size: large;">=Pm(Pm(Wi)) where Vo=Wo=Xo and m|n (which aren't calculated since we don't know any m|n yet). When Wi=Vi, i>0, then m|Xi-Yi and gcd(Xi-Yi,n)=m. If m=1 the result is neglected and the process go on with Xi+</span>1<span style="font-family: "courier new" , "courier" , monospace; font-size: large;"> and Yi+</span>1<span style="font-family: "courier new" , "courier" , monospace; font-size: large;">.</span><br />
<div class="separator" style="clear: both; text-align: center;">
<span style="font-family: "courier new" , "courier" , monospace; margin-left: 1em; margin-right: 1em;"><img height="368" src="https://upload.wikimedia.org/wikipedia/commons/4/47/Pollard_rho_cycle.jpg" width="400" /></span></div>
<span style="font-size: large;">
<span style="font-family: "courier new" , "courier" , monospace;">If m=n the start values Xo=Yo is said to fail and may be increamented by 1 for an other try. Now, gcd(Xi-Yi,n)=n when Xi and Yi become equal before any of the uncalculated sequences Vi and Wi become equal for some non trivial divisor m>1 of n. There could still be non trivial divisors to obtain for gcd(Xj-Yj,n) for j>i when Xi=Yi, but there is no guarranty and Xi=Yi is a natural terminal case.</span></span><br />
<span style="font-size: large;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">An example with P(x)=x²+1 that is factorized while continuing after failure for Xo=2 is n=4294952621. An example that can't be factorized after failure with Xo=2 but with Xo=3 is n=4294939069.</span></span><br />
<span style="font-size: large;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Increasing Xo after termination when gcd(Xi-Yi,n)=n will always find a factor of n, because if m is a non trivial factor of n, then Xo=m immediately gives m as a factor. That is, for </span></span><span style="font-family: "courier new" , "courier" , monospace; font-size: large;">P(x)=x²+1.</span><br />
<br />Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-57281280628697160912017-09-01T14:25:00.005-07:002017-09-01T23:55:41.627-07:00BigZ - new top level instructions<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">I've reorganized and extended some top level words: </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">create-set \ m n xt -- set </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">filter-set \ set1 xt -- set2 </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">build-set \ m n xt -- set </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">transform-set \ set1 xt -- set2 </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">This words should be used with the word :| to define and form sets. </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">1 10 :| b a | a ^2 b ^2 + isprime ; create-set zdup cr zet. </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">{(1,1),(2,1),(4,1),(6,1),(1,2),(3,2),(5,2),(7,2),(2,3),(8,3),(1,4),(5,4),(9,4),(2,5),(4,5),(6,5),(8,5),(1,6),(5,6),(2,7),(8,7),(3,8),(5,8),(7,8),(4,9)} ok </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">:| b a | a ^2 b ^2 + ; transform-set zdup cr zet.
{2,5,13,17,29,37,41,53,61,73,89,97,113} ok </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">:| n | n 4 mod 3 = ; filter-set zet. 0 ok </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">The word :| define a nameless word and count the number of parameters.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">: bl# \ ad n -- m count the number of spaces in the string<br /> over + swap 0 -rot<br /> do i c@ bl = -<br /> loop ;<br /><br />variable loc# \ the number of parameters<br />variable sta# \ the number of outputs on the stack<br /><br />: locals# \ -- <br /> >in @ >r<br /> [char] | parse bl# loc# !<br /> r> >in ! <br /> 1 sta# ! ; immediate<br /><br />: :| \ -- <br /> :noname<br /> postpone locals#<br /> postpone locals| ;</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">The nameless words, represented by xt on stack, could be of two types:</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">1. Taking parameters and leaving a flag.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">2. Taking parameters and leaving a non negative integer.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">In the first case a set with the "dimension" stated by the parameters is the result. This works with CREATE-SET and FILTER-SET.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">In the second case a set of values is the result. This works with BUILD-SET and TRANSFORM-SET. </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">1 10 :| x | x ^2 ; build-set cr zet.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">{1,4,9,16,25,36,49,64,81} ok</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">Normally these nameless words leave one integer on the stack, but for TRANSFORM-SET there is an option (using 2; instead of ;) when the word leaves two non negative integers on the stack</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">{ 0 10 | all } </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">creates the set {0,1,2,3,4,5,6,7,8,9} which can be transformed to a two dimensional set</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">:| n | n n ^2 2; transform-set cr zet. <br />{(0,0),(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81)} ok</span></span><br />
<br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">The purpose with this words is to be able to quickly inspect conjectures and Diophantine equations. </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">a and b are coprime if there exists values x and y such that </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">ax+by=1</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">Since BigZ just deals with sets of non negative numbers we can search x and y in the equation</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">ax-by=1</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">1 10 :| b a y x | a x * b y * - 1 = ; create-set cr zet.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">{(2,1,1,1),(3,2,1,1),(4,3,1,1),(5,4,1,1),(6,5,1,1),(7,6,1,1),(8,7,1,1),(9,8,1,1),(1,1,2,1),(2,3,2,1),(3,5,2,1),(4,7,2,1),(5,9,2,1),(1,2,3,1),(2,5,3,1),(3,8,3,1),(1,3,4,1),(2,7,4,1),(1,4,5,1),(2,9,5,1),(1,5,6,1),(1,6,7,1),(1,7,8,1),(1,8,9,1),(3,1,1,2),(5,2,1,2),(7,3,1,2),(9,4,1,2),(1,1,3,2),(3,4,3,2),(5,7,3,2),(1,2,5,2),(3,7,5,2),(1,3,7,2),(1,4,9,2),(4,1,1,3),(7,2,1,3),(2,1,2,3),(5,3,2,3),(8,5,2,3),(1,1,4,3),(4,5,4,3),(7,9,4,3),(2,3,5,3),(5,8,5,3),(1,2,7,3),(4,9,7,3),(2,5,8,3),(5,1,1,4),(9,2,1,4),(3,2,3,4),(7,5,3,4),(1,1,5,4),(5,6,5,4),(3,5,7,4),(1,2,9,4),(6,1,1,5),(3,1,2,5),(8,3,2,5),(2,1,3,5),(7,4,3,5),(4,3,4,5),(9,7,4,5),(1,1,6,5),(6,7,6,5),(3,4,7,5),(2,3,8,5),(4,7,9,5),(7,1,1,6),(5,4,5,6),(1,1,7,6),(7,8,7,6),(8,1,1,7),(4,1,2,7),(5,2,3,7),(2,1,4,7),(9,5,4,7),(3,2,5,7),(6,5,6,7),(1,1,8,7),(8,9,8,7),(4,5,9,7),(9,1,1,8),(3,1,3,8),(5,3,5,8),(7,6,7,8),(1,1,9,8),(5,1,2,9),(7,3,4,9),(2,1,5,9),(4,3,7,9),(8,7,8,9)} ok</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">The vectors in the set are of the form (x,y,a,b), that is the opposite of its appearance as parameters. (Which is logical in Forth with postfix notations and values on a stack, but still a bit awkward).</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">The idea is a one row code and for that purpose there is a need of short words:</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">: isp isprime ; \ n -- flag<br />: isq sqr ; \ is perfect square: n -- flag<br />: isqf sqrfree ; \ is square free: n -- flag<br />: isem bigomega 2 = ; \ is semi prime: n -- flag<br />: ispp smallomega 1 = ; \ is prime power: n -- flag<br /><br />: 2sqs 2sqsum ; \ square sum: a b -- sum<br />: 3sqs 3sqsum ; \ square sum: a b c -- sum<br />: 4sqs 4sqsum ; \ square sum: a b c d -- sum<br /><br />: cop coprime ; \ are coprime: m n -- flag<br />: div swap mod 0= ; \ divides: m n -- flag<br /><br />: << \ i j k -- flag i<j<k<br /> over > -rot < and ;<br /><br />: <<= \ i j k -- flag i<=j<=k<br /> over >= -rot <= and ;</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">: z. zet. ; </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">: fi postpone else postpone false postpone then ; immediate <br />\ a short version of ELSE FALSE THEN.<br /><br />When inspecting a Diophantine equation there might be symmetries and trivial cases to weed out.<br /><br />1 100 :| c b a | a b c << a b cop and if a b 2sqs c ^2 = else false then ; create-set<br /><br />can be shortened to<br /><br />1 100 :| c b a | a b c << a b cop and if a b 2sqs c ^2 = fi ; create-set </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">cr zet. <br />{(3,4,5),(5,12,13),(8,15,17),(7,24,25),(20,21,29),(12,35,37),(9,40,41),(28,45,53),(11,60,61),(33,56,65),(16,63,65),(48,55,73),(36,77,85),(13,84,85),(39,80,89),(65,72,97)} ok </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">Experimenting with sets gives a great opportunity to find and test conjectures:</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">1 50 :| b a | a b 2sqsum isprime ; create-set ok <br />:| b a | a b + ; transform-set cr z. <br />{2,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,63,65,67,69,71,73,75,77,79,83,85,87,89,91,93,95} ok</span><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"> </span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">This suggests that all odd numbers larger than 1 can be written as a sum a+b where a²+b² is prime.</span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">Define </span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">: sqeq \ m n a b -- ma²+nb²<br /> dup * rot * -rot<br /> dup * * + ;</span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">and the set {a+b<50|a,b>0 & </span></span><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">ma²+nb² is prime} for some different values of m and n</span></span></span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span></span></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">5 value m</span></span></span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">7 value n</span></span></span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">1 50 :| b a | m n a b sqeq isprime ; create-set</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">:| b a | a b + ; transform-set cr zet.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">{5,7,11,13,17,19,23,25,29,31,35,37,41,43,47,49,53,55,59,61,65,67,71,73,77,79,83,85,89,91} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">3 to m</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">4 to n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">1 50 :| b a | m n a b sqeq isprime ; create-set</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">:| b a | a b + ; transform-set cr zet.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">{2,3,4,5,6,8,9,10,11,12,13,15,16,17,18,19,20,22,23,24,25,26,27,29,30,31,32,33,34,36,37,38,39,40,41,43,44,45,46,47,48,50,51,52,53,54,55,57,58,59,60,61,62,64,65,66,67,68,69,71,72,73,74,75,76,78,79,80,81,82,83,86,87,88,89,93,94,95,96} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">This will show a pattern which suggest that </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">{a+b|a,b>0 & </span></span><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">ma²+nb² is prime}={k>1|gcd(k,m+n)=1}</span></span></span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">However, further tests will show that some changes are needed:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<div class="separator" style="clear: both; text-align: center;">
<a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEgBrUJvRgBcL4JHp7Urmo5M6sUtg5ggU-JyjR9L5X8bADl47Crh2w1COyM-UTE7qO3a5SPnwGqUkAGW8t_zAxPXg2GkJj1AjSEuHO7l9sIBYpM2sW3GSeuE3SETFGuPSYnSOOTS71r_fOl5/s1600/conjecture01.png" imageanchor="1" style="clear: left; float: left; margin-bottom: 1em; margin-right: 1em;"><img border="0" data-original-height="651" data-original-width="679" height="613" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEgBrUJvRgBcL4JHp7Urmo5M6sUtg5ggU-JyjR9L5X8bADl47Crh2w1COyM-UTE7qO3a5SPnwGqUkAGW8t_zAxPXg2GkJj1AjSEuHO7l9sIBYpM2sW3GSeuE3SETFGuPSYnSOOTS71r_fOl5/s640/conjecture01.png" width="640" /></a></div>
<span style="font-family: "courier new" , "courier" , monospace;">Routines to check the conjecture and print the table:</span><br />
<br />
<span style="font-family: "courier new" , "courier" , monospace;">: prime_partition \ m n k -- flag<br /> false locals| flag k |<br /> k 1<br /> ?do 2dup k i - i sqeq isprime<br /> if true to flag leave then<br /> loop 2drop flag ;<br /><br />\ 100000 value nx Gives the same table as<br />1000 value nx<br /><br />: </span><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">maximal_exception</span> \ m n -- mx <br /> 2dup + 1 locals| mx m+n n m |<br /> nx 3<br /> do m+n i coprime<br /> if m n i </span><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">prime_partition</span> 0=<br /> if i to mx then<br /> then<br /> loop mx ;<br /><br />: table \ m2 n2 --<br /> locals| n2 | cr<br /> 2 spaces dup 1 do i 3 .r loop 1 <br /> do n2 1 cr i 2 .r<br /> do j i coprime<br /> if j i </span><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">maximal_exception</span></span> </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> else 0<br /> then 3 .r<br /> loop <br /> loop ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The source code for BigZ can be loaded here:</span><br />
<br />
<span style="font-family: "courier new" , "courier" , monospace;"><a href="https://github.com/Lehs/BigZ/blob/master/bigzet.txt" target="_blank">https://github.com/Lehs/BigZ/blob/master/bigzet.txt</a></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-35172467256111246612017-05-30T03:09:00.002-07:002017-06-10T00:07:43.904-07:00Karatsuba multiplication<span style="font-family: "courier new" , "courier" , monospace;">The time for direct multiplication is proportional to n² where n is the number of figures in the multiplicands x,y. When choosing a big base B=2ⁿ and and writing</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">xy=(x0+B*x1)(y0+B*y1)=x0y0 + (x0*y1+x1*y0)B + x1*y1*B²</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">there are four multiplications of smaller numbers, also here the calculation time is proportional to n². However</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">(x0*y1+x1*y0)=(x0+x1)(y0+y1)-x0*y0-x1*y1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">why it's enough to calculate three smaller multiplications </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">x0*y0, x1*y1 and (x0+x1)(y0+y1). </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The multiplication with B are fast left shifting and if the shifting and the addition where cost free, the recursive Karatsuba multiplication would be very efficient</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<div class="separator" style="clear: both; text-align: center;">
<a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEgoBo9J-GEZIOH-pQGrzRRARojlbeiOa4ni6jc-Ep1u86sMC4Q4h_aLuoYMtGhLCu3HTG4AaxmBBBsOj1C8moyayS5q86fK83rIGsV04r2zi0a-NFBFE-03Y39XqdU3cxqDiRQ0q0txMoRZ/s1600/i-55ceb115228c359caafc1c4ad2377011-karatsuba-1.gif" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><span style="font-family: "courier new" , "courier" , monospace;"><img border="0" data-original-height="180" data-original-width="180" height="200" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEgoBo9J-GEZIOH-pQGrzRRARojlbeiOa4ni6jc-Ep1u86sMC4Q4h_aLuoYMtGhLCu3HTG4AaxmBBBsOj1C8moyayS5q86fK83rIGsV04r2zi0a-NFBFE-03Y39XqdU3cxqDiRQ0q0txMoRZ/s200/i-55ceb115228c359caafc1c4ad2377011-karatsuba-1.gif" width="200" /></span></a></div>
<div class="separator" style="clear: both; text-align: center;">
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div class="separator" style="clear: both; text-align: left;">
<span style="font-family: "courier new" , "courier" , monospace;">but unfortunately the extra math (and in Forth also some stack juggling) takes a lot of time and the method is efficient only for rather big numbers. For very big numbers, however, it's very efficient.</span></div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span><span style="font-family: "courier new" , "courier" , monospace;">Here is the way I implemented it in ANS Forth:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: bcells* \ big m -- big*C^m</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> cells top$ locals| n ad mb |</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ad ad mb + n move</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ad mb erase</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> mb bvp @ +! ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ C is the number of digits in a cell</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: bcells/ \ big m -- big/C^m</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> cells top$ locals| n ad mb |</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ad mb + ad n move</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> mb negate bvp @ +! ;</span><br />
<div>
<br /></div>
<span style="font-family: "courier new" , "courier" , monospace;">: bsplit \ w ad -- u v </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup nextfree < </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if bvp @ dup @ vp+ bvp @ ! ! </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> else drop bzero</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ A big number is split on the big stack at address ad</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: btransmul \ x y -- x0 x1 y0 y1 m B=2^bits </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> len1 len2 max cell + lcell 1+ rshift \ m</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup >r cells </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> >bx first over + bsplit </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> bx> first + bsplit r> ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span>
<span style="font-family: "courier new" , "courier" , monospace;"></span></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ x=x0+x1*B^m y=y0+y1*B^m </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">0x84 value karalim \ break point byte length for termination.</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: b* \ x y -- xy</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
len1 len2 max karalim < </div>
<div>
if b* exit then</div>
<div>
btransmul >r \ x0 x1 y0 y1</div>
<div>
3 bpick 2 bpick recurse >bx \ bx: x0*y0</div>
<div>
2 bpick 1 bpick recurse >bx \ bx: x0*y0 x1*y1</div>
<div>
b+ >bx b+ bx> recurse \ (x0+x1)(y0+y1)</div>
<div>
bx b- by b- r@ bcells* \ z1*C^m</div>
<div>
bx> r> 2* bcells* bx> b+ b+ <top ;</div>
<div>
\ Karatsuba multiplication</div>
<div>
<br /></div>
</span></div>
<div>
<br /></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-64497133987936959402017-05-29T02:53:00.000-07:002017-05-29T02:53:02.725-07:00How to use BigZ - part 3<h4>
<span style="font-family: "courier new" , "courier" , monospace;">The binomial coefficient<span style="color: #222222;"><span style="background-color: white;">s for big integers</span></span></span></h4>
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="background-color: white; font-family: "courier new" , "courier" , monospace;">The number of possibilities to choose k objects from n objects soon get to big for a single cell number. The word <b>bschoose</b> gives a big integer result for single cell inputs.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="background-color: white;"><br /></span></span>
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="background-color: white;">: bschoose \ n k -- b</span></span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="background-color: white; font-family: "courier new" , "courier" , monospace;"> bone 0</span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="background-color: white; font-family: "courier new" , "courier" , monospace;"> ?do dup i - bs*</span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="background-color: white; font-family: "courier new" , "courier" , monospace;"> i 1+ bs/mod drop</span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="background-color: white; font-family: "courier new" , "courier" , monospace;"> loop drop ;</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="background-color: white;"><br /></span></span>
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;"> ok</span></span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace; font-size: 14px;">2000 500 bschoose cr b.</span></span><br />
<span style="color: #222222; font-size: 14px;"><span style="font-family: "courier new" , "courier" , monospace;">5648284895675941420424412140748481039502890353942825357221051675360331984776743417002364625179991976070068866284527555107208940603781511988000970130381311935878493235111594076219803768997324618773852975824828528735285833615310777764160933348372329757027402537319600321600269195597902747298520883357267710485334098751949232380773741897267988881873218260056305793069941805234442045890109611836653468404129012879905442075185208447514284775689056520318572740750419026192611832748925888424320 ok</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-size: 14px;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="color: #222222; font-size: 14px;"><span style="font-family: "courier new" , "courier" , monospace;">This word produce big integers with single cell factors that can be analysed by the word </span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-size: 14px;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="color: #222222; font-size: 14px;"><span style="font-family: "courier new" , "courier" , monospace;">sfacset \ b -- b' set</span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-size: 14px;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="color: #222222; font-size: 14px;"><span style="font-family: "courier new" , "courier" , monospace;">2000 1000 bschoose sfacset bdrop cr zet.</span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-size: 14px;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;">{2,5,7,11,13,17,19,23,37,41,43,53,59,67,73,79,101,103,113,127,131,149,151,167,173,179,181,211,251,257,263,269,271,277,281,283,337,347,349,353,359,367,373,379,383,389,397,503,509,521,523,541,547,557,563,569,571,577,587,593,599,601,607,613,617,619,631,641,643,647,653,659,661,1009,1013,1019,1021,1031,1033,1039,1049,1051,1061,1063,1069,1087,1091,1093,1097,1103,1109,1117,1123,1129,1151,1153,1163,1171,1181,1187,1193,1201,1213,1217,1223,1229,1231,1237,1249,1259,1277,1279,1283,1289,1291,1297,1301,1303,1307,1319,1321,1327,1361,1367,1373,1381,1399,1409,1423,1427,1429,1433,1439,1447,1451,1453,1459,1471,1481,1483,1487,1489,1493,1499,1511,1523,1531,1543,1549,1553,1559,1567,1571,1579,1583,1597,1601,1607,1609,1613,1619,1621,1627,1637,1657,1663,1667,1669,1693,1697,1699,1709,1721,1723,1733,1741,1747,1753,1759,1777,1783,1787,1789,1801,1811,1823,1831,1847,1861,1867,1871,1873,1877,1879,1889,1901,1907,1913,1931,1933,1949,1951,1973,1979,1987,1993,1997,1999} ok</span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;"><br /></span></span>
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;">The word <b>bsetprod</b> calculates the big product of the singles in set</span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;"><br /></span></span></span>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;">: bsetprod \ set -- b</span></span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace; font-size: 14px;"> bone \ big one</span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace; font-size: 14px;"> foreach \ make ready for do-loop</span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace; font-size: 14px;"> ?do zst> bs* loop ;</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;"><br /></span></span>
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;">and can be used to calculate the radical for big integers with single cell factors:</span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;"><br /></span></span>
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;">: bsradical \ b -- b'</span></span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace; font-size: 14px;"> sfacset bdrop </span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace; font-size: 14px;"> bsetprod ;</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;"><br /></span></span>
<span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;">50 25 bschoose bsradical cr b.</span></span></span><br />
<span style="color: #222222; font-family: "courier new" , "courier" , monospace; font-size: 14px;">1504888171878 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="color: #222222; font-family: "courier new" , "courier" , monospace;"><span style="font-size: 14px;"><br /></span></span>
<span style="background-color: white;"><span style="font-family: "courier new" , "courier" , monospace;">Erdős squarefree conjecture (proved 1996) states that the central binomial coefficient (2n)Cn is not squarefree if n>4. The word </span><b style="font-family: "Courier New", Courier, monospace;">sqrfacset</b><span style="font-family: "courier new" , "courier" , monospace;"> calculates the set of all factors that occurs more than once: </span></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="background-color: white;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="background-color: white;"><span style="font-family: "courier new" , "courier" , monospace;">: sqrfacset \ b -- set</span></span></span><br />
<span style="background-color: white;"><span style="font-family: "courier new" , "courier" , monospace;"> bdup bsradical b/</span></span><br />
<span style="background-color: white;"><span style="font-family: "courier new" , "courier" , monospace;"> sfacset bdrop ;</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="background-color: white;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;">20000 10000 bschoose sqrfacset cr zet.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">{2,3,7,11,23,29,41,47,53,61,71,73,79,109,127,137,139} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The word</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: maxel \ set -- n non e</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zst> zst@ swap >zst zdrop ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">gives the maximal element in a set of integers.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: erdprime \ n -- p</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup 2* swap bschoose</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> sqrfacset maxel ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-43102154374804714942017-03-18T04:28:00.002-07:002017-03-18T08:54:08.815-07:00How to use BigZ - part 2<span style="font-family: "courier new" , "courier" , monospace;"><b>Gaps in increasing sequences of natural numbers</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Strictly increasing sequences as</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">(1,2,3,...), (2,3,5,7,11,13,...) and (1,2,4,8,16,...)</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">can partly be represented as sorted sets in BigZ. Differences of sequences is an analogy to differentiation of functions. </span><span style="font-family: "courier new" , "courier" , monospace;">When defining a function gapz, to be the sorted set of all gaps between consecutive numbers of a set, also gapz become an analogy of the derivative of functions.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Apply gapz on an arithmetic sequence gives a set with a single element. If n times apply gapz on an increasing polynomial series of degree n gives a singleton set. On a sequence of exponential function with base two does nothing to the infinite set.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: gapz \ s -- s'</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 locals| n | \ counts the number of gaps in s'</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> foreach 1+ \ prepare elements of s for the do-loop</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do zst> zst@ - >xst \ the gap between the largest consecutive's</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> n 1+ to n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop zst> drop \ drop the smallest element of s</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> n 2* negate >xst \ calculate the set-count for s'</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> xst zst setmove \ move the set to zst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> set-sort reduce ; \ sort and eliminate copies</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 1000 | prime } gapz cr zet.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">{1,2,4,6,8,10,12,14,18,20} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>Partitions of a number <i>n</i> into distinct primes</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: collincl \ s n -- s'</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 >xst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> begin zst@</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> while zsplit </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup >zst zfence zmerge</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> set-sort reduce zfence</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> xst zst setmove zmerge</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zst xst setmove</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> repeat zdrop drop</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> xst zst setmove</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> reduce ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ include n in all sets in s</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: xunion \ set --</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> xst zst setmove union </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zst xst setmove ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ Union of the top sets on the xst- and zst-stacks</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ is put on the xst-stack</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: primeset \ m -- set</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> pi dup 1+ 1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ?do i pnr@ >zst </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop 2* negate >zst ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ Create the set of all primes < m+1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: memb \ s n -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> false swap</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> adn1 over + swap</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ?do dup i @ =</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if -1 under+ leave then cell</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> +loop drop ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ Faster test if n is a member in the sorted number set s</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">For T being the set of primes:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<div class="separator" style="clear: both; text-align: center;">
<a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEj8eWRdPyUhsrTl6VNFMnLLUkgWzHFYavVPoWIXGUG3W-U0HhYOaM_ACWraJa9ZACGA43SqTkANsifzXejk1bYTqbNG_vTVRok2ZgBdZVotNRlx5PckzQwd34zssVvjkaqEMN8qFwyLAZ5M/s1600/Algorithm1.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" height="82" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEj8eWRdPyUhsrTl6VNFMnLLUkgWzHFYavVPoWIXGUG3W-U0HhYOaM_ACWraJa9ZACGA43SqTkANsifzXejk1bYTqbNG_vTVRok2ZgBdZVotNRlx5PckzQwd34zssVvjkaqEMN8qFwyLAZ5M/s400/Algorithm1.png" width="400" /></a></div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The algorithm can be used with corrections for n=2p.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: termcase \ n -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> case 2 of true endof</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 3 of true endof</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 11 of true endof</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup of false endof</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> endcase ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ terminal cases: prime numbers without additional partitions</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">I have no proof that there are additional partitions for all primes greater than 11, but as far as the algorithm will go the terminal cases above are correct.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: z2@ \ set -- set n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zst> zst@ swap >zst ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ read the largest element in the set</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: lowlim \ set n -- set p</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 swap adn1 over + swap</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ?do i @ under+ 2dup < 0= </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if 2drop i @ leave then cell</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> +loop ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ p is the smallest prime such that 2+3+5+...+p > n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: setsum \ set -- sum</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 foreach ?do zst> + loop ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ The sum of all elements in set</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: sumcorr \ s n -- s'</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> locals| n |</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 >xst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> begin zst@ </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> while zsplit zdup setsum n =</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if zfence xunion</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> else zdrop</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> repeat zst> drop </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> xst zst setmove ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ Removes all partitions from s such that the sum < n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: dps \ n -- set</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup 2 < if drop 0 >zst exit then </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup termcase if >zst -2 >zst -4 >zst exit then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 >xst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup primeset</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup lowlim locals| low n |</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> begin zst@ </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if z2@ low <</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if false else true then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> else false </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> while zsplit n zst> dup >r - ?dup </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if recurse</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zst@ </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if r> collincl n sumcorr xunion </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> else zst> drop r> drop </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> else { { r> } } xunion </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> repeat zdrop</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> xst zst setmove </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> set-sort reduce ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ The set of partitions of n>0 into distinct primes</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">20 dps cr zet.</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{{2,7,11},{2,5,13},{7,13},{3,17}} ok</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">50 dps cr zet.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{{2,7,11,13,17},{2,5,11,13,19},{7,11,13,19},{2,5,7,17,19},{3,11,17,19},{2,5,7,13,23},{3,11,13,23},{2,3,5,17,23},{3,7,17,23},{3,5,19,23},{2,3,5,11,29},{3,7,11,29},{3,5,13,29},{2,19,29},{3,5,11,31},{2,17,31},{19,31},{2,11,37},{13,37},{2,7,41},{2,5,43},{7,43},{3,47}} ok</span></div>
</div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
: A000586 \ n -- </div>
<div>
." 1," 1+ 1 </div>
<div>
?do i dps cardinality 0</div>
<div>
<# [char] , hold #s #> type </div>
<div>
loop ;</div>
<div>
\ List <a href="https://oeis.org/A000586" target="_blank">A000586</a> </div>
<div>
<br />
100 a000586 cr<br />
1,0,1,1,0,2,0,2,1,1,2,1,2,2,2,2,3,2,4,3,4,4,4,5,5,5,6,5,6,7,6,9,7,9,9,9,11,11,11,13,12,14,15,15,17,16,18,19,20,21,23,22,25,26,27,30,29,32,32,35,37,39,40,42,44,45,50,50,53,55,57,61,64,67,70,71,76,78,83,87,89,93,96,102,106,111,114,119,122,130,136,140,147,150,156,164,170,178,183,188,198, ok<br />
<br /></div>
<div>
<br /></div>
<div>
<b>Partitions of a number <i>n</i> into distinct non composites</b></div>
<div>
<br /></div>
<div>
A variant of the above.</div>
<div>
<br /></div>
<div>
<div>
<div>
: termcase1 \ n -- flag</div>
<div>
case 1 of true endof</div>
<div>
2 of true endof</div>
<div>
dup of false endof</div>
<div>
endcase ; </div>
</div>
<div>
<br /></div>
<div>
: dps1 \ n -- set</div>
<div>
dup 0= if >zst exit then </div>
<div>
dup termcase1 if >zst -2 >zst -4 >zst exit then</div>
<div>
0 >xst</div>
<div>
dup { 1 } primeset zmerge</div>
<div>
dup lowlim locals| low n |</div>
<div>
begin zst@ </div>
<div>
if z2@ low <</div>
<div>
if false else true then</div>
<div>
else false </div>
<div>
then</div>
<div>
while zsplit n zst> dup >r - ?dup </div>
<div>
if recurse</div>
<div>
zst@ </div>
<div>
if r> collincl n sumcorr xunion </div>
<div>
else zst> drop r> drop </div>
<div>
then </div>
<div>
else { { r> } } xunion </div>
<div>
then </div>
<div>
repeat zdrop</div>
<div>
xst zst setmove </div>
<div>
set-sort reduce ;</div>
</div>
<div>
<br /></div>
<div>
50 dps1 cr zet. </div>
<div>
{{1,3,5,11,13,17},{2,7,11,13,17},{1,2,3,5,7,13,19},{2,5,11,13,19},{7,11,13,19},{2,5,7,17,19},{1,2,11,17,19},{3,11,17,19},{1,13,17,19},{1,3,5,7,11,23},{2,5,7,13,23},{1,2,11,13,23},{3,11,13,23},{2,3,5,17,23},{1,2,7,17,23},{3,7,17,23},{1,2,5,19,23},{3,5,19,23},{1,7,19,23},{2,3,5,11,29},{1,2,7,11,29},{3,7,11,29},{1,2,5,13,29},{3,5,13,29},{1,7,13,29},{1,3,17,29},{2,19,29},{1,2,5,11,31},{3,5,11,31},{1,7,11,31},{1,2,3,13,31},{1,5,13,31},{2,17,31},{19,31},{1,2,3,7,37},{1,5,7,37},{2,11,37},{13,37},{1,3,5,41},{2,7,41},{2,5,43},{7,43},{1,2,47},{3,47}} ok</div>
<div>
<br /></div>
<div>
<div>
: test \ n -- n>0</div>
<div>
1+ 1 </div>
<div>
?do i dps1 cardinality 0</div>
<div>
<# [char] , hold #s #> type </div>
<div>
loop ;</div>
</div>
<div>
<br /></div>
<div>
100 cr test<br />
1,1,2,1,2,2,2,3,2,3,3,3,4,4,4,5,5,6,7,7,8,8,9,10,10,11,11,11,13,13,15,16,16,18,18,20,22,22,24,25,26,29,30,32,33,34,37,39,41,44,45,47,51,53,57,59,61,64,67,72,76,79,82,86,89,95,100,103,108,112,118,125,131,137,141,147,154,161,170,176,182,189,198,208,217,225,233,241,252,266,276,287,297,306,320,334,348,361,371,386, ok<br />
<br /></div>
</span></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com1tag:blogger.com,1999:blog-5309775736131296725.post-23063895173780095092017-02-13T11:33:00.002-08:002017-02-14T12:10:18.214-08:00How to use BigZ - part 1<span style="font-family: "courier new" , "courier" , monospace;">I've started to use the standard ANS-Forth notation for locals. It's a bit awkward but awkward in a forthish way. When I started this blog I wasn't aware of this notation.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Suppose there are numbers a b c d on the stack, then </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">locals| d c b a | </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">pop the values on the stack and store them in the locals. Normally there is no real need of locals in Forth, when factoring optimally, but when the stack is used for counted number series</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">n1 n2 ... nk k</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">locals is handy. And of course, locals could be used to uncomplicate algorithms.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The Pollard rho factoring routine for single cell numbers is fast, even in 64 bit systems, and can be used to define number theoretical functions. In BigZ the word</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">pollard# \ n -- p1 ... pk k</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">factorize the number and present it in a form that can be sorted by the word </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">sort \ n1 ... nk k -- m1 ... mk k</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: maxprimefactor \ n -- p</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> pollard# sort</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> over >r drops r> ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">drops \ n1 ... nk k --</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The radical of a number can be defined easily by factoring, dropping all copies of prime factors and multiply the rest of the factors:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: radical \ n -- r </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 1 swap \ just a value to be dropped at the end</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> pollard# sort \ p1 ... pk k sorted with largest on top of stack</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 1 swap 0 \ p1 ... pk 1 k 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do undequ \ is two primes eual?</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if nip \ drop the first of them (second on the stack)</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> else * \ multiply single prime </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop nip ; \ drop the number "1" used by undequ</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The word </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">undequ \ a b c -- a b c flag </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">compares the second and the third values on the stack and flag is true if a=b else false.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1000000 1001000 | all } ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">utime function radical transform-set utime d- d. -118123 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">That is, transforming the set of the numbers {1000000,1000001,...,1000999} to the set of their radicals takes about a tenth of a second.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Now zdup cardinality . cr zet. gives</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">1000</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">{10,42,1034,1158,1954,3910,4119, ... ,1000995,1000997,1000999} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">(Non of the numbers appears to have the same radical).</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Also, it is easy to define a test for square free numbers</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: sqrfree \ n -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup radical = ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">that's fairly fast</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">utime { 1 10000 | sqrfree } utime d- d. -2750161 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">zdup cardinality . 6083 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">cr zet.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">{1,2,3,5,6,7,10,11,13,14,15, ... ,9993,9994,9995,9997,9998} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">A nice word to analyse a sorted counted bundle of numbers of the stack is</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: hist \ a1 ... ak k -- a1 ... ai i ak nk </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 2dup 0 locals| n k1 a k |</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> begin dup a = k1 and</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> while n 1+ to n </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> k1 1- to k1 drop</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> repeat k n - a n ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">that counts the uppermost copies of the same number, leaving the remaining counted bundle under the histogram value ak nk on the top of the stack, indicating nk copies of the number ak.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">For example, define a function theta that gives the greatest factor of n that is a sum of two squares. </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Facts:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">any prime of the form 4n+1 can be written as a sum of two squares;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">the product of two squaresums is a squaresum;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">for primes p of the form 4n+3, p^2i is of the form 0²+b².</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The word squsumfac gives the contribution from the prime factor pk.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: squsumfac \ pk nk -- fac fac=a²+b²</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> over 3mod4 </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if dup odd if 1- then </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then ** ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: theta \ n -- m </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup 1 = if exit then </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 1 locals| m |</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> oddpart dup 1 = \ r s flag, where n=s*2^r, s odd.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if swap lshift exit then </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> pollard# sort</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> begin hist squsumfac</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> m * to m dup 0=</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> until drop m swap lshift ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The sets in BigZ can't have big number members (yet) but it might be interesting to create sets of single number factors of big numbers.</span><br />
<div>
<br /></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ testing for small (fast) single number divisors</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ of big number w</span><span style="font-family: "courier new" , "courier" , monospace;"> in the intervall n,m-1</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: sfac \ w -- w ?v | m n -- f </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> beven if 2drop 2 bdup b2/ exit then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 locals| flag | </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> do bdup i pnr@ bs/mod 0= </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> if i pnr@ to flag leave then bdrop</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> loop flag ;</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: sfacset \ b -- set</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> 0 \ count of the number of elements</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> begin pi_plim 1 sfac ?dup </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> while >zst 2 - bnip</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> repeat bdrop >zst reduce ;</span></div>
</div>
<div>
<br /></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Testing a conjecture about divisibility of Fibonacci numbers:</span></div>
<div>
<br /></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: bsfib \ n -- F(n) single input and big output</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> d</span><span style="font-family: "courier new" , "courier" , monospace;">up 2 < if s>b exit then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> bzero bone 1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do btuck b+ loop bnip ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Conjecture:</span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Any prime number p<n divide some Fibonacci number F(m), 0<m≤n.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: fibtest \ m n -- flag</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> false locals| flag |</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> do i pnr@ 1+ 1</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> do j pnr@ i bsfib sfacset smember </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> if true to flag leave then</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> loop<span class="Apple-tab-span" style="white-space: pre;"> </span> flag if leave then </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> loop flag ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">pi_plim . 1077871 ok</span></div>
</div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">utime pi_plim 1 fibtest . utime d- d. -1 -12836944 ok (t<13 sec).</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">That is, the conjecture is true for all primes Pn where n<1077871.</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">__________</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Due to Wikipedia there is a formula:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">p|F(p-i), where i=(5/p), the Legendre symbol.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: test \ p -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup 5 over legendre -</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> bsfib</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> bs/mod bdrop 0= ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">100000 random nextprime test . -1 ok</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">See also <a href="http://forthmath.blogspot.se/2015/11/some-arithmetical-functions.html" target="_blank">Arithmetical functions</a></span></div>
</div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-90812986614183685232016-08-26T22:32:00.001-07:002016-08-26T22:32:59.984-07:00The abc-conjecture 1<span style="font-family: "courier new" , "courier" , monospace;">Suppose a, b and c are natural numbers such that a,b,c are mutual co-prime and a+b=c. Those triples are called abc-triplets. The abc-conjecture concern the unusual possibility that</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span><span style="font-family: "courier new" , "courier" , monospace;">(1) a+b>rad(ab(a+b))</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span><span style="font-family: "courier new" , "courier" , monospace;">where rad is the radical, the product of all unique prime factors of a number. I.e. rad(4)=2, rad(6)=6, rad(60)=30, rad(81)=3, rad(101)=101, ...</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span><span style="font-family: "courier new" , "courier" , monospace;">There is an infinite number of pairs (a,b) as (1), but given a real number epsilon>0 there seems to be only a finite number of abc-triplets (a,b,a+b) such that</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span><span style="font-family: "courier new" , "courier" , monospace;">(2) a+b>rad(ab(a+b))^(1+epsilon) </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span><span style="font-family: "courier new" , "courier" , monospace;">and that's one version of the famous abc-conjecture.</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: abcpair \ a b -- flag</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> locals| b a |</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> a b ugcd 1 =</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> a b + </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> dup a ugcd 1 =</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> swap b ugcd 1 =</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> and and ;</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">test if (a,b,a+b) is a abc-triplet, and</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">:</span><span style="font-family: "courier new", courier, monospace;"> unusual \ a b -- flag</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
locals| b a |</div>
<div>
a b 2dup + * * radical</div>
<div>
a b + < ;</div>
<div>
<br /></div>
<div>
test if a+b>rad(ab(a+b)).</div>
<div>
<br /></div>
<div>
1 1000 condition non create-set zdup cardinality . 999 ok</div>
<div>
<br /></div>
<div>
creates the set {1,...,999}.</div>
<div>
<br /></div>
<div>
zdup cartprod zdup cardinality . 998001 ok</div>
<div>
<br /></div>
</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">create the Cartesian product </span><span style="font-family: "courier new" , "courier" , monospace;">{1,...,999}x</span><span style="font-family: "courier new" , "courier" , monospace;">{1,...,999} and </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">2dim < filter-set zdup cardinality . 498501 ok</span></div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
</div>
<div style="font-family: "Courier New", Courier, monospace;">
filter the set so that the first component is less than the second.</div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
<div>
<div style="font-family: "Courier New", Courier, monospace;">
2dim abcpair filter-set zdup cardinality . 303791 ok</div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
<div style="font-family: "Courier New", Courier, monospace;">
This skip all (a,b) but those where (a,b,a+b) is a abc-triplet.</div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">2dim unusual filter-set zdup cardinality . 32 ok</span></div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
</div>
<div style="font-family: "Courier New", Courier, monospace;">
This is the remaining set of pairs such that (1):</div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
<div>
<div style="font-family: "Courier New", Courier, monospace;">
zdup cr zet.</div>
<div style="font-family: "Courier New", Courier, monospace;">
{(1,8),(1,48),(1,63),(1,80),(1,224),(1,242),(1,288),(1,512),(1,624),(1,675),(1,728),(1,960),(2,243),(3,125),(4,121),(5,27),(5,507),(7,243),(13,243),(25,704),(27,512),(32,49),(32,343),(49,576),(81,175),(81,544),(100,243),(104,625),(169,343),(200,529),(343,625),(640,729)} ok</div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
<div style="font-family: "Courier New", Courier, monospace;">
Considering the pairs as Gaussian integers and transform the set of unusual pairs to their Gaussian norms give:</div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">zdup 2dim gnorm transform-set zdup cardinality . cr zet. 32</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{65,754,2305,3425,3970,6401,14657,15634,37186,50177,58565,59053,59098,59218,69049,82945,118673,146210,257074,262145,262873,302497,319841,334177,389377,401441,455626,496241,508274,529985,921601,941041} ok</span></div>
</div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
</div>
<div style="font-family: "Courier New", Courier, monospace;">
Since the both sets have 32 elements I hasten to raise the conjecture:</div>
<div style="font-family: "Courier New", Courier, monospace;">
<br /></div>
<div style="font-family: "Courier New", Courier, monospace;">
<div style="font-family: "courier new", courier, monospace;">
(3) All (ordered) unusual pairs has unique Gaussian norms. </div>
<div style="font-family: "courier new", courier, monospace;">
<br /></div>
<div style="font-family: "courier new", courier, monospace;">
To test the conjecture for different limits without stack overflow, conj3 works:</div>
<div style="font-family: "courier new", courier, monospace;">
<br /></div>
<span style="font-family: courier new, courier, monospace;">: abcunusual \ ab -- flag</span><br />
<span style="font-family: courier new, courier, monospace;"> 2dup abcpair 0= </span><br />
<span style="font-family: courier new, courier, monospace;"> if 2drop false</span><br />
<span style="font-family: courier new, courier, monospace;"> else unusual</span><br />
<span style="font-family: courier new, courier, monospace;"> then ;</span><br />
<div style="font-family: "courier new", courier, monospace;">
<br /></div>
<span style="font-family: courier new, courier, monospace;">: conj3 \ n -- set flag</span><br />
<span style="font-family: courier new, courier, monospace;"> true locals| flag |</span><br />
<span style="font-family: courier new, courier, monospace;"> 0 >zst<span class="Apple-tab-span" style="white-space: pre;"> </span>\ empty set on zst stack</span><br />
<span style="font-family: courier new, courier, monospace;"> 2 </span><br />
<span style="font-family: courier new, courier, monospace;"> ?do i 1 </span><br />
<span style="font-family: courier new, courier, monospace;"> ?do i j abcunusual </span><br />
<span style="font-family: courier new, courier, monospace;"> if i j gnorm dup zdup smember</span><br />
<span style="font-family: courier new, courier, monospace;"> if false to flag drop i j pad 2! leave</span><br />
<span style="font-family: courier new, courier, monospace;"> else >zst zfence union</span><br />
<span style="font-family: courier new, courier, monospace;"> then</span><br />
<span style="font-family: courier new, courier, monospace;"> then</span><br />
<span style="font-family: courier new, courier, monospace;"> loop flag 0= if leave then</span><br />
<span style="font-family: courier new, courier, monospace;"> loop flag ;</span><br />
<span style="font-family: courier new, courier, monospace;"><br /></span>
<span style="font-family: courier new, courier, monospace;">100 conj3 </span><span style="font-family: "courier new", courier, monospace;">. -1 ok</span><br />
<span style="font-family: "courier new", courier, monospace;"></span><br />
<span style="font-family: courier new, courier, monospace;">zet. {65,754,2305,3425,3970,6401} ok</span><br />
<div>
<br /></div>
<div>
<div>
<div>
<span style="font-family: courier new, courier, monospace;">5000 conj3 . -1 ok</span></div>
<div>
<span style="font-family: courier new, courier, monospace;">zdup cardinality . 87 ok</span></div>
<div>
<span style="font-family: courier new, courier, monospace;">cr zet.</span></div>
<div>
<span style="font-family: courier new, courier, monospace;">{65,754,2305,3425,3970,6401,14657,15634,37186,50177,58565,59053,59098,59218,69049,82945,118673,146210,257074,262145,262873,302497,319841,334177,389377,401441,455626,496241,508274,529985,921601,941041,1048577,1048601,1242793,1476226,1569061,1750393,1837097,2566561,2944705,3067769,3317074,4093154,4101154,4194385,4213625,4484017,4584929,4735097,4783069,4798594,4916545,5303810,5592434,5646001,5760001,5774602,5831545,8977273,8998393,9144577,9439993,9765746,9976306,10185529,11944561,12379505,13302409,13986466,14548594,15108770,15745025,15784466,15818497,15944098,16769026,16777337,16778441,17155426,18548777,19131877,23070401,23660897,23819585,24153953,33667138} ok</span></div>
</div>
<div style="font-family: "courier new", courier, monospace;">
<br /></div>
<div style="font-family: "courier new", courier, monospace;">
True so far. This take some time but I try 10000:</div>
<div style="font-family: "courier new", courier, monospace;">
<br /></div>
<div style="font-family: "courier new", courier, monospace;">
<div>
10000 conj3 . -1 ok</div>
<div>
zdup cardinality . 129 ok</div>
<div>
cr zet.</div>
<div>
{65,754,2305,3425,3970,6401,14657,15634,37186,50177,58565,59053,59098,59218,69049,82945,118673,146210,257074,262145,262873,302497,319841,334177,389377,401441,455626,496241,508274,529985,921601,941041,1048577,1048601,1242793,1476226,1569061,1750393,1837097,2566561,2944705,3067769,3317074,4093154,4101154,4194385,4213625,4484017,4584929,4735097,4783069,4798594,4916545,5303810,5592434,5646001,5760001,5774602,5831545,8977273,8998393,9144577,9439993,9765746,9976306,10185529,11944561,12379505,13302409,13986466,14548594,15108770,15745025,15784466,15818497,15944098,16769026,16777337,16778441,17155426,18548777,19131877,23070401,23660897,23819585,24153953,26040898,31640674,31706945,32283521,33667138,34000562,37515986,37520281,38950162,39052481,39421505,40947202,40985921,43033601,43050817,43445377,44289026,44446210,47045882,47046137,47048690,56811506,64000361,64235537,65713618,66928882,66961570,68374489,68508353,70761674,73260281,73530626,85470281,87890626,88510465,93655426,94008377,96040001,96060226,118771553,123820633,140639489,141533305} ok</div>
<div>
<br /></div>
</div>
<div style="font-family: "courier new", courier, monospace;">
(To be continued)</div>
<div style="font-family: "courier new", courier, monospace;">
<br /></div>
</div>
</div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-24916622120240187492016-08-13T00:23:00.004-07:002016-08-13T00:25:53.559-07:00Instructions to create and manipulate sets<span style="font-family: "courier new" , "courier" , monospace;">The basic words for sets are </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">member \ element set -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">set= \ set1 set2 -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">subset \ set1 set2 -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The parameters on the left sides above are located on the zst-stack. The 'element' could be a single (on the zst-stack) or a set. The flag is true or false on the ordinary stack. To check if a non negative single number on the parameter stack is a member in a set (located on the zst-stack), use the word</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">smember \ n set -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">3 { 1 2 3 4 } smember . -1 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Using member </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">3 >zst { 1 2 3 4 } member . -1 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Except from set operations like</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">union \ s1 s2 -- s3</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">intersection \ s1 s2 -- s3</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">diff \ s1 s2 -- s3</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">powerset \ s1 -- s2 (s2 = set of all subsets of s1)</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">cartprod \ s1 s2 -- s3 (Cartesian product)</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">cardinality \ s1 -- n (n = number of elements in s1)</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">and the possibility to create small sets</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 10 10000 | prime } cardinality . 1225 ok</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">there are a lot of cryptic words to manipulate even rather big sets of non negative integers</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">intcond \ low hi xt -- | -- s "intervall condition"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">setcond \ xt -- | s -- s' "set condition"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">intimage \ low hi xt -- | -- s "intervall image"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">setimage \ xt -- | s -- s' "set image"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">paircond \ xt -- | s -- s'</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">pairimage \ xt -- | s -- s'</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">int2cond \ low hi n xt -- | -- s "intervall two-condition"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">int2image \ low hi n xt -- | -- s "intervall image"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">set2cond \ n xt -- | s -- s' "set condition"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">set2image \ n xt -- | s -- s' "set image"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Inspired by the idea of orthogonal instructions I created a simple syntax just for set manipulations, to summarize and simplify the use of the words above:</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">variable zp</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">variable cf2</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
: condition ' 0 cf2 ! sp@ zp ! ;</div>
<div>
: function ' 2 cf2 ! sp@ zp ! ;</div>
<div>
: 2dim ' -1 cf2 ! sp@ zp ! ;</div>
<div>
: syntax sp@ zp @ - 0= if 0 0 else 1 then cf2 @ ;</div>
<div>
<br /></div>
</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">The word syntax check the number of input parameters and put a dummy parameter on the stack when needed.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">(I have started to use the ANS-Forth notation for locals and will reform the code and the blog. It's awkward, but "forthish" awkward since it loads the parameters in the reversed direction: </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">k l m n locals| n m l k |</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">It has some advantages even if it looks strange.)</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">The ten cryptic words are now squeezed into the three words</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">create-set</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">filter-set</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">transform-set</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ e.g. 1 20 condition < 7 create-set</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: create-set \ m n xt nr -- set</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> syntax locals| cf k nr xt n m |</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
k cf or</div>
<div>
case 0 of m n xt intcond endof</div>
<div>
1 of m n nr xt int2cond endof</div>
<div>
2 of m n xt intimage endof</div>
<div>
3 of m n nr xt int2image endof</div>
<div>
endcase ;</div>
<div>
<br /></div>
<div>
\ e.g. condition > 5 filter-set</div>
<div>
: filter-set \ set xt nr -- set'</div>
<div>
syntax locals| cf k nr xt |</div>
<div>
cf 0< if xt paircond exit then k</div>
<div>
case 0 of xt setcond endof</div>
<div>
1 of nr xt set2cond endof</div>
<div>
endcase ;</div>
<div>
<br /></div>
<div>
\ e.g. 2dim + transform-set</div>
<div>
: transform-set \ set xt nr -- set'</div>
<div>
syntax locals| cf k nr xt |</div>
<div>
cf 0< if xt pairimage exit then k</div>
<div>
case 0 of xt setimage endof</div>
<div>
1 of nr xt set2image endof</div>
<div>
endcase ;</div>
<div>
<br /></div>
</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Creating sets:</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">1 25 condition prime create-set cr zet.</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{2,3,5,7,11,13,17,19,23} ok</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
10 29 condition coprime 6 create-set cr zet.</div>
<div>
{11,13,17,19,23,25} ok</div>
<div>
<br /></div>
</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">1 10 function 2* create-set cr zet.</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{2,4,6,8,10,12,14,16,18} ok</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
1 10 function * 3 create-set cr zet.</div>
<div>
{3,6,9,12,15,18,21,24,27} ok</div>
<div>
<br /></div>
<div>
The word after condition/function must be a defined condition or function for one or two parameters.</div>
<div>
<br /></div>
<div>
Filter sets:</div>
<div>
<br /></div>
<div>
<div>
{ 1 25 | all } condition odd filter-set cr zet.</div>
<div>
{1,3,5,7,9,11,13,15,17,19,21,23} ok</div>
</div>
<div>
<br /></div>
<div>
<div>
{ 1 25 | all } condition < 10 filter-set cr zet.</div>
<div>
{1,2,3,4,5,6,7,8,9} ok</div>
</div>
<div>
<br /></div>
<div>
<div>
{ 1 2 3 } zdup cartprod zdup cr zet.</div>
<div>
{(3,3),(3,2),(3,1),(2,3),(2,2),(2,1),(1,3),(1,2),(1,1)} ok</div>
<div>
2dim < filter-set cr zet.</div>
<div>
{(1,2),(1,3),(2,3)} ok</div>
</div>
<div>
<br /></div>
<div>
Transform sets:</div>
<div>
<br /></div>
<div>
<div>
{ 1 100 | prime } function 2* transform-set ok</div>
<div>
function 1- transform-set ok</div>
<div>
condition prime filter-set cr zet.</div>
<div>
{3,5,13,37,61,73,157,193} ok</div>
</div>
<div>
<br /></div>
<div>
<div>
1 1000000 condition prime create-set ok</div>
<div>
condition < 50 filter-set ok</div>
<div>
function + 2 transform-set cr zet.</div>
<div>
{4,5,7,9,13,15,19,21,25,31,33,39,43,45,49} ok</div>
</div>
<div>
<br /></div>
<div>
<div>
{ 1 10 | odd } zdup cartprod ok</div>
<div>
2dim + transform-set cr zet.</div>
<div>
{2,4,6,8,10,12,14,16,18} ok</div>
</div>
<div>
<br /></div>
<div>
The word 2dim works like condition and function but acts on a set of pairs and can be used both for 2-dim conditions and 2-dim functions.</div>
<div>
<br /></div>
<div>
So far those instructions don't works in definitions and they just works for numbers and pairs of numbers.</div>
</span></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-24657901428838100392016-06-18T03:07:00.001-07:002016-08-13T22:28:41.339-07:00String operations and bioinformatics<span style="font-family: "courier new" , "courier" , monospace;">Strings makes it possible to generalize the concept of sets. In BigZ a set is a nested set of nested sets and lists like</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 123 ( 234 { 345 456 { 567 678 } } ) } cr zet. </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">{123,(234,{345,456,{567,678}})} ok</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">and the only lack of generality concern the atomic elements, which must be non negative single numbers. But virtually anything can be denoted as a string which can be interpreted as a list of characters:</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">s" {Hello world!,How are you?}" >str stringset>zet cr zet.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{(72,101,108,108,111,32,119,111,114,108,100,33),(72,111,119,32,97,114,101,32,121,111,117,63)} ok</span></div>
<div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">In this way also sets of big integers, Gaussian integers etc can be elements of sets.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">A nice way to handle strings in Forth is using a string stack, which in this implementation consists of two stacks, one for the arrays of ASCII signs and one for addresses to the arrays of signs.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>>str</b> \ ad n -- string Push a string on the stack</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>str></b> \ string -- ad n Pop a string from the stack</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>str@</b> \ string -- string | -- ad n</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>sempty </b>\ string -- string | -- flag</span></div>
<div>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>.str</b> \ -- Prints the stack without changing it
<b>str.</b> \ str -- Print and drop the topmost element
<b>sdup sdrop sover snip sswap srot stuck spick</b> does the normal operations<b>.</b></span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><b style="font-family: "courier new", courier, monospace;">soover </b><span style="font-family: "courier new" , "courier" , monospace;">\ str1 str2 str3 -- str1 str2 str3 str1</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;">A shorter way to enter strings from commando line is</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><b style="font-family: "courier new", courier, monospace;">s</b><span style="font-family: "courier new" , "courier" , monospace;"> Hello world"</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;">However, in definitions one must use </span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;">s" Hello world" >str</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;">Some words for string manipulations</span><b style="font-family: "courier new", courier, monospace;">:</b></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><b style="font-family: "courier new", courier, monospace;">s&</b><span style="font-family: "courier new" , "courier" , monospace;"> \ s1 s2 -- s1&s2 Concatenation</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><b style="font-family: "courier new", courier, monospace;">sleft </b><span style="font-family: "courier new" , "courier" , monospace;">\ s1 -- s2 | n -- Skip all but the n leftmost characters</span></pre>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>sright </b>\ s1 -- s2 | n -- The samr for the n rightmost chars</span></div>
<div>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>ssplit </b>\ s -- s' s" | n -- split string after the nth letter</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><b style="font-family: "courier new", courier, monospace;">sanalyze </b><span style="font-family: "courier new" , "courier" , monospace;">\ s1 s2 -- s1 s3 s1 s4 / s2 | -- flag </span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;">split s2 if s1 is a part of s2 and if true flag then s2=s3&s1&s4.</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><b style="font-family: "courier new", courier, monospace;">substring </b><span style="font-family: "courier new" , "courier" , monospace;">\ s1 s2 -- s1 s2 | -- flag</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>sreplace </b>\ s1 s2 s3 -- s4 Replace s2 with s1 in s3</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>scomp </b>\ s1 s2 -- | -- n -1:s1>s2, +1:s1<s2, 0:s1=s2</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>snull </b>\ -- emptystring</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>schr&</b> \ s -- s' | ch -- Concatenate ch to top string</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>slen=</b> \ s1 s2 -- | -- flag Test if same length
<b>strail </b>\ s -- s' Remove trailing spaces
<b>>capital</b> \ ch -- ch' Change common to capital
<b>>common</b> \ ch -- ch' The oposite
<b>capital </b>\ ch --flag Test if capital letter
<b>common </b>\ ch -- flag Test if common letter
<b>slower </b>\ s -- s' Change to lower in string
<b>supper </b>\ s -- s' Opposite as above
<b>str>ud</b> \ s -- s' | -- ud flag Unsigned double from string
</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>str>d</b> \ s -- s' | -- d flag Double from string
</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>snobl </b>\ s -- s' Remove all blanks</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>sjustabc </b>\ s -- s' Remove all signs but eng. letters</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>alphabet </b>\ s -- s' Gives the alphabet of string</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><b style="font-family: "courier new", courier, monospace;">zet>stringset</b><span style="font-family: "courier new" , "courier" , monospace;"> \ set -- string</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>stringset>zet</b> \ string -- set</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>sunion </b>\ str1 str2 -- str3</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>sintersection </b>\ str1 str2 -- str3</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>sdiff</b> \ str1 str2 -- str3</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;">s {brown,red,orange,yellow,green}" ok</span></pre>
<pre style="word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="white-space: pre-wrap;">s {blue,violet,brown,black}" ok
sunion str. {black,brown,violet,blue,green,yellow,orange,red} ok</span></span></pre>
<pre style="word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><span style="white-space: pre-wrap;"><span style="font-family: "courier new" , "courier" , monospace;"><b>hamming </b>\ s1 s2 --</span><span style="font-family: "courier new" , "courier" , monospace;"> s1 s2 |</span><span style="font-family: "courier new" , "courier" , monospace;"> n The Hamming distance</span>
</span></span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><b>editdistance </b>\ </span><span style="font-family: "courier new" , "courier" , monospace;">s1 s2 --</span><span style="font-family: "courier new" , "courier" , monospace;"> s1 s2 |</span><span style="font-family: "courier new" , "courier" , monospace;"> n The Levenshtein distance</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;">
</span></pre>
<pre style="white-space: pre-wrap; word-wrap: break-word;"><span style="font-family: "courier new" , "courier" , monospace;"><a href="https://raw.githubusercontent.com/Lehs/BigZ/master/bioinformatics.f" target="_blank">T</a>his code is now included in the BigZ code.</span></pre>
</div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-23285512577537894292016-05-27T10:49:00.001-07:002016-06-28T19:43:34.794-07:00BigZ, Zet with big integers included<span style="font-family: "courier new" , "courier" , monospace;">Forth is a very special computer language - a kind of smart macro assembler. Even if the programming is on high level you always program directly upon an addressable part of the memory. The visible stack orientation is the simple way to handle data. Postfix notation makes brackets and operator priorities unnecessary. There is no black box parser limiting what is allowed and possible. The programmer decide virtually everything about the procedures, input, output and memory. And this makes it very easy to extend the system with new data types with postfix algebra.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">In BigZ (see the top bar) a system for big integers is included to Zet. It's simple, efficient and rather complete, in spite of my limited programming ability. As for integers, floating point numbers and sets, there are stacks for numbers of dynamical length. And as for sets, there is no other limit of the size than the allocated memory. When needed the memory is reallocated. </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The stack for big numbers is really two stacks in the same area of memory: one growing towards high memory (the numbers) and one growing towards low memory (the addresses to the numbers). Writing</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">b 702486742867487684278678476028746724601 </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">and pressing enter, reads the number string and convert it to a multi-decimal number A_0*B^0+...+A_r*B^r where B is 2^b and b is the maximal number of bits of a single cell integer. The single cell numbers A_i are stored in the stack with i growing towards hi memory.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The operators have the usual names but with the prefix b.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">b 2000 bfaculty cr b.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">fill the screen with a 5736 figure number within some tenth of a second.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The word </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">b**mod \ -- | a n m -- b</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">counts aⁿ(mod m) and </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">b 26359783991551070871965201979080333254038743646746158379582192038055842791146833506745978666309678710238746262325665407448047112858614221184120023774728850927701745782077979943165434355776993447809155163506304287949484786229043007193369097865681445643720004387345872800008950502312482268122160708155160328564 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">b 39327375191467048647521018841730348998598651522372708158670691892420060531890655533991461398550696324722351925617448324344083141484661951392820800479947685042791549748743564268081958080246132723174581232969062661990556972176861792341905425252382562697686127413259201904144867482279552760624394742040590855602 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">b 16306675630939784626502807161425612212340131109932460322238576590610976549235432503764166590338557086651302692446204937053886057954003032814801648230668894753863150108029570966337696939560565101312815273803547555619029325583815565767168841836143511237512006023630352590540140638620838094344583215840893265550 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">b**mod cr b.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">13589152355661418800480923196880892958242540305591911682228289531245831992616543540153046075650497423341388067834762342417455873016510076223412593080539625696104324076486611754715629613440368922879919737699812253207474005960378943204378352266794545844684513362891786202126506784931492440650088987888029494246 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">executes in about 0.5 seconds, which might be fast enough for some encryption experiments.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Some of the most important words are:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">bdrop, bdup, bover, brot, bnip, btuck, bswap, b+, b-, b*, b/, b=, b<, b>, b0=, bmod, b/mod, bsqrtf, bgcd and b**mod.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">with obvious operations. The word .b prints the b-stack. There are also mixed words:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">bs* \ n -- | b -- n*b</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">bs/mod \ n -- r | b -- q, where b=nq+r</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">which is much faster than the corresponding b* and b/mod.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Ahead I will try so submit adequate prime tests and factoring functions.</span>Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-3649641128611254212016-05-15T07:44:00.000-07:002016-05-15T07:44:08.364-07:00Words for testing conjectures<span style="font-family: "courier new" , "courier" , monospace;">Making code for testing conjectures can be cumbersome even in the case of easy programming. So far in Zet there is the possibility of make and calculate with sets of numbers interactively.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">{ 1 1000 | prime }</span><span style="font-family: "courier new";"> ok<br /><span style="font-family: "courier new";">{ 1 1000 | pairprime } </span>{ 1 1000 | notpairprime } </span><span style="font-family: "courier new";">union ok</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">zet= . -1 ok</span><br />
<b><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></b>
<b><span style="font-family: "courier new" , "courier" , monospace;">Conditions so far are</span></b><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: all dup = ;<br />: odd 1 and ; <br />: 1mod4 4 mod 1 = ; <br />: 3mod4 4 mod 3 = ; <br />: sqr dup sqrtf dup * = ;<br />: sqrfree dup radical = ;<br />: pairprime dup prime over 2 + prime rot 2 - prime or and ; <br />: notpairprime dup prime swap pairprime 0= and ;<br />: semiprime bigomega 2 = ; \ A product of two primes?<br />: uniprime smallomega 1 = ; \ Only divisional by one prime?<br />: biprime smallomega 2 = ; \ Exact two different primes?</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The construction { 1 10000 | pairprime } is fancy but slow and risk overflow in data stack. All the pairprimes in the intervall will first be created on the stack and then be moved to the zst-stack. It's better to check number for number and create the set directly on the zst-stack.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: intcond \ low hi xt -- | -- s "intervall condition"</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loc{ xt } </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> swap 0 -rot</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do i xt execute </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if i >zst 1+ then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop 2* negate >zst ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">utime <b>1 100000 ' pairprime intcond</b> utime cr d- d. cardinality .</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">-35954 2447 ok</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">A set of 2447 primes is created in about 0.04 seconds. This construction is also possible to use in definitions, then using ['] instead of '.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">To filtrate a set on the zst-stack:</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">: setcond \ xt -- | s -- s' "set condition"</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loc{ xt } 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> foreach</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do zst> dup xt execute</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if >xst 1+ else drop then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop dup 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do xst> >zst </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop 2* negate >zst ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 100 | prime } ' 1mod4 setcond cr zet.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{5,13,17,29,37,41,53,61,73,89,97} ok</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">It's also nice to be able to create the image of a function:</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">: intimage \ low hi xt -- | -- s "intervall image"</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loc{ xt } </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> swap 2dup</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do i xt execute >zst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop - 2* negate >zst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> set-sort reduce ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: setimage \ xt -- | s -- s' "set image"</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loc{ xt } 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> foreach </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do zst> xt execute >xst 1+</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop dup 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do xst> >zst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop 2* negate >zst </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> set-sort reduce ;</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
</div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new";"><span style="font-family: "courier new" , "courier" , monospace;">Functions so far are: </span></span><br />
<span style="font-family: "courier new";"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span></div>
<span style="font-family: "courier new";"><span style="font-family: "courier new" , "courier" , monospace;">
</span></span>
<div>
<span style="font-family: "courier new";"><span style="font-family: "courier new" , "courier" , monospace;">log~ ( n -- nr ) where nr=1+²log n</span></span></div>
<span style="font-family: "courier new";">
<div>
<span style="font-family: "courier new" , "courier" , monospace;">random ( u1 -- u2 ) where 0≤u2<u1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">nextprime ( numb -- prime )</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">prevprime ( numb -- prime )</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">sqrtf ( m -- n ) "floor"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">sqrtc ( m -- n ) "ceiling"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">radical ( n -- r )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b></b><i></i><u></u><sub></sub><sup></sup><strike></strike>totients ( n -- t )<b></b><i></i><u></u><sub></sub><sup></sup><strike></strike></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">bigomega ( n -- b )</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">smallomega ( n -- s )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">ufaculty ( u -- u! )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">pnr@ ( n -- p ) prime number n</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">pi ( x -- n ) number of primes ≤ x</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Functions and conditions both must have the stackdiagram ( m -- n ), but the concept will be generalized.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">1 20 ' radical intimage zet. {1,2,3,5,6,7,10,11,13,14,15,17,19} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /><span style="font-family: "courier new" , "courier" , monospace;"></span></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Some test functions:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: square dup * ; \ x → x²</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: sqr>prime square nextprime ; \ x → nextprime(x²)</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: sqr<prime square prevprime ; \ x → prevprime(x²)</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: foo dup totients mod ; \ x → x(mod ϕ(x)) Euler's totient.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 100 | all } ' foo setimage cr zet.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">{0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,21,22,23,25,27,31,33,35,39} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">1 100 ' square intimage ' foo setimage cr zet.</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{0,3,5,7,11,13,17,19,20,23,27,28,29,31,37,41,43,44,47,52,53,59,61,67,68,71,73,76,79,80,83,89,92,97,105,112,116,124,125,148,164,172,176,180,188,189,208,243,252,272,304,320,343,368,385,396,429,448,468,500,585,704,720,825,945,969,1008,1105,1197,1280,1309,1372,1540,1620,1701,1725,1729,1785,2185,2187,2625,2697,3069,3861} ok</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
<br /></div>
</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">Hmm, it seems like all odd primes less than 100 belongs to the image...</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">1 10000 ' square intimage ' foo setimage ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">1 10000 ' prime intcond ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">zswap diff zet. {2} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">So I asked <a href="http://math.stackexchange.com/questions/1783949/conjecture-about-odd-primes" target="_blank">Mathematics stack exchange</a> about it. (: </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<div class="separator" style="clear: both; text-align: center;">
<a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEjV422tiqZmbE70rLQIdulX6Vv7LYMOAjvy3S1slob-pU_mkxk_YXELPCq-iBvXezxHNygpZpGWjmBsiEdEQD0fnRQUoSD0yPuIDiSsRe70B_cp-1XNpXyhlH4BygorNljmIhhIbhCO1zwr/s1600/Sk%25C3%25A4rmklipp+2016-05-15+08.35.48.png" imageanchor="1" style="clear: left; float: left; margin-bottom: 1em; margin-right: 1em;"><span style="font-family: "courier new" , "courier" , monospace;"><img border="0" height="72" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEjV422tiqZmbE70rLQIdulX6Vv7LYMOAjvy3S1slob-pU_mkxk_YXELPCq-iBvXezxHNygpZpGWjmBsiEdEQD0fnRQUoSD0yPuIDiSsRe70B_cp-1XNpXyhlH4BygorNljmIhhIbhCO1zwr/s640/Sk%25C3%25A4rmklipp+2016-05-15+08.35.48.png" width="640" /></span></a></div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Well, it might be sound to expect non dramatic explanations to conjectures, especially conjectures concerning primes.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">To check relations <b>n <i>R</i> m</b> there is a need for testing subsets of Cartesian products, sets of pairs of integers.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: paircond \ xt -- | s -- s'</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loc{ xt } 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> foreach</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do zdup zet> drop xt execute</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if zst xst setmove 1+ else zdrop then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop 6 * negate >xst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> xst zst setmove ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 10 | all } zdup cartprod ' = paircond cr zet.</span><br />
<br />
<span style="font-family: "courier new" , "courier" , monospace;">{(1,1),(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),(8,8),(9,9)} ok</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">: pairimage \ xt -- | s -- s'</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loc{ xt } 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> foreach</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do 1+ zet> drop xt execute >xst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop dup 0 </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do xst> >zst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop 2* negate >zst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> set-sort reduce ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 2 10 | all } zdup cartprod ' * pairimage cr zet.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{4,6,8,9,10,12,14,15,16,18,20,21,24,25,27,28,30,32,35,36,40,42,45,48,49,54,56,63,64,72,81} ok</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Some conditions and functions N²→N are =, <>, <, >, >=, <=, +, *, /, mod, **, ugcd, -, invmod, legendre, jacobi, kronecker, gnorm, choose, where m ≥ n for m n - and m n must be coprime for m n invmod. the gnorm of two integers m n is the norm of the gaussian integer m+in, that is the number m²+n².</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: coprime ugcd 1 = ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: divide swap mod 0= ; </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 10 | all } zdup cartprod ' coprime paircond cr zet.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{(1,1),(1,2),(1,3),(1,4),(1,5),(1,6),(1,7),(1,8),(1,9),(2,1),(2,3),(2,5),(2,7),(2,9),(3,1),(3,2),(3,4),(3,5),(3,7),(3,8),(4,1),(4,3),(4,5),(4,7),(4,9),(5,1),(5,2),(5,3),(5,4),(5,6),(5,7),(5,8),(5,9),(6,1),(6,5),(6,7),(7,1),(7,2),(7,3),(7,4),(7,5),(7,6),(7,8),(7,9),(8,1),(8,3),(8,5),(8,7),(8,9),(9,1),(9,2),(9,4),(9,5),(9,7),(9,8)} ok</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 10 | all } zdup cartprod ' divide paircond cr zet.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{(1,1),(1,2),(1,3),(1,4),(1,5),(1,6),(1,7),(1,8),(1,9),(2,2),(2,4),(2,6),(2,8),(3,3),(3,6),(3,9),(4,4),(4,8),(5,5),(6,6),(7,7),(8,8),(9,9)} ok</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 10 | all } zdup cartprod ' coprime paircond ' gnorm pairimage cr zet.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{2,5,10,13,17,25,26,29,34,37,41,50,53,58,61,65,73,74,82,85,89,97,106,113,130,145} ok</span></div>
</div>
<div>
<br /></div>
<div style="font-family: 'courier new';">
</div>
</div>
</span>Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-68379850136195682322016-05-14T12:57:00.002-07:002016-05-15T07:31:31.661-07:00Simple graphs<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;">The idea of using stacks for sets is not a bad idea - in my opinion. Besides from the simplified garbage collecton there is the benefit that the data can be accessed in arrays (in the stacks), which at least can be used to define some fast primitive routines. The set routines are not slow. When enumerating all the cards in a deck from 0 to 51, Zet can calculate the set of all 1326 possible hold cards in Texas hold´em poker in a few hundredths of a second. On my Android:</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">{ 0 52 | all } utime 2 power# utime 2swap d- cr d. cardinality cr .</span></span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;">29099 </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;">1326</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">Here utime counts in μs.</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">Formally a simple graph is a set of vertices V and a subset of all unordered pairs of vertices E. Visually, a simple graph is a collection of verticies joined by zero or one edges and which consist no loops.</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">A subgraph (V,E) of a simple graph (V',E') is a graph such that V is a subset of V' and E of E'.</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">: subgraph \ -- flag | (V,E) (V',E') -- </span></span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> unfence zrot unfence </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zrot subset</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zswap subset and ;</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">There is a maximal subgraph for each subset V generated by E'.</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">\ E = intersection of E' and power#(2,V)</span></span><br />
<span style="font-family: Courier New, Courier, monospace;">: edges~ \ E' V -- E</span><br />
<span style="font-family: Courier New, Courier, monospace;"> 2 power# intersection ;</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">But this straightforward implementation is inefficient. About 20 times faster is:</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: 'courier new', courier, monospace;"><br /></span>
<span style="font-family: 'courier new', courier, monospace;">: edges \ E' V -- E</span></span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> 0 >xst </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zst yst setmove </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> foreach \ {u,v}∈E'</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> ?do zdup unfence yzcopy1 member </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> if yzcopy1 member</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> if zfence xzmerge</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> else zdrop</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> then</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> else zst> drop zdrop</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> then</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> loop yst setdrop xst zst setmove ;</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">To make a random simple graph with v vertices and with an edge between two vertices in m cases of n:</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: 'courier new', courier, monospace;"><br /></span>
<span style="font-family: 'courier new', courier, monospace;">: randgraph \ m n v -- | -- (V,E)</span></span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> loc{ m n v } </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> 0 >xst</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> { v 0 do i 1+ loop } </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zdup 2 power# foreach \ {u,v}</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> do n random m < </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> if zfence xzmerge</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> else zdrop</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> then</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> loop xst zst setmove pair ;</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">The word <b>extend</b> creates a superset to the graph created by <b>edges</b> where all edges connected to V is submitted plus all edges connected to the submitted points.</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">\ V={x∈V'|y∈V" & {x,y}∈E'}</span></span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;">\ E={{x,y}∈E'|x∈V & y∈V}</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;">: extend \ E' V" -- (V,E)</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zswap zst yst setmove </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zst xst setcopy </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> foreach \ v∈V"</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> do zst> yzcopy1</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> begin zst@ </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> while zsplit zdup dup smember</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> if xzmerge</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> else zdrop</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> then</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> repeat zet> 2drop</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> loop xst zst setmove </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> set-sort reduce</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> yst zst setmove </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zover edges pair ;</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Counts all isolated points in a graph:</span></span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;">: isolated-vertices# \ -- n | (V,E) --</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> unfence 0 dup loc{ flag }</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zst yst setmove</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> foreach</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> do zst> yzcopy1 true to flag</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> begin zst@ flag and</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> while zsplit dup smember 0= to flag</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> repeat zdrop drop flag -</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> loop yst zst setmove zdrop ;</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"><br /></span>
<span style="font-family: Courier New, Courier, monospace;">4 5 9 randgraph zdup cr zet.</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"></span><br />
<span style="font-family: Courier New, Courier, monospace;">({1,2,3,4,5,6,7,8,9},{{8,9},{7,9},{6,9},{5,9},{4,9},{3,9},{2,9},{1,9},{6,8},{4,8},{1,8},{6,7},{5,7},{3,7},{2,7},{1,7},{5,6},{4,6},{3,6},{2,6},{1,6},{4,5},{3,5},{2,5},{3,4},{2,4},{1,4},{1,3}}) ok</span><br />
<span style="font-family: Courier New, Courier, monospace;"><br /></span>
<span style="font-family: Courier New, Courier, monospace;">isolated-vertices# . 0 ok</span><br />
<div>
<div>
<span style="font-family: Courier New, Courier, monospace;"><br /></span></div>
<div>
<span style="font-family: Courier New, Courier, monospace;">Counts all isolated components in a graph:</span></div>
</div>
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;">: components# \ -- n | (V,E) --</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zdup 0 >xst</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> unfence </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> znip zst yst setcopy</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> foreach</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> do begin yzcopy1 zover</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> extend unfence zdrop ztuck zet=</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> until zfence xzmerge</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> loop yst setdrop </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> xst zst setmove reduce cardinality</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> isolated-vertices# + ;</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Due to the formula for vertices, edges and components for a forest, that is, a graph without circuits, v=e+c:</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">: forest? \ -- flag | (V,E) -- </span></span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> zdup unfence </span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> cardinality \ e</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> cardinality \ v</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> components# \ c</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"> rot + = ;</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"><br /></span>
<span style="font-family: Courier New, Courier, monospace;">4 5 9 randgraph zdup cr zet.</span><br />
<span style="font-family: Courier New, Courier, monospace;">({1,2,3,4,5,6,7,8,9},{{7,9},{6,9},{5,9},{4,9},{3,9},{2,9},{6,8},{5,8},{4,8},{3,8},{2,8},{1,8},{5,7},{4,7},{3,7},{1,7},{5,6},{4,6},{3,6},{2,6},{1,6},{4,5},{3,5},{2,5},{1,5},{3,4},{2,4},{1,4},{2,3},{1,2}}) ok</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"></span><br />
<span style="font-family: Courier New, Courier, monospace;">forest? . 0 ok</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">\ Using set-sort to sort a vector</span></span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;">: vector-sort \ s -- s'<br /> set-sort zst> 1- >zst ;</span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">\ check if E is a cycle</span> </span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">: cycle \ -- flag | E -- <br /> zdup multiunion <br /> zdup cardinality true loc{ v flag } <br /> zover zdup cardinality v = 0=<br /> if triplet zdrop false exit <br /> then pair components# 1 > <br /> if zdrop false exit<br /> then 0 >xst foreach<br /> do xzmerge<br /> loop xst zst setmove<br /> zet> cs sort 2 - 0<br /> do over = flag and to flag<br /> over > flag and to flag <br /> +loop = flag and ;</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: "courier new";"><br /></span>
<span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">: clear-table \ s --<br /> pad 0 foreach <br /> do zst> max<br /> loop cells erase ;<br /> <br />: cyc!check \ n -- flag<br /> cells pad + 1 over +! @ 2 > ;</span></span><br />
<span style="font-family: Courier New, Courier, monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">\ Test if (V,E) is 2-regular</span> </span><br />
<span style="font-family: Courier New, Courier, monospace;"><span class="Apple-style-span" style="font-family: "courier new" , "courier" , monospace;">: 2-regular \ -- flag | (V,E) --<br /> unfence zswap clear-table<br /> begin zst@ <br /> while zsplit unfence <br /> zst> cyc!check if zst> drop zdrop false exit then <br /> zst> cyc!check if zdrop false exit then<br /> repeat zdrop true ;<br /></span>
</span><br />
<span style="font-family: Courier New, Courier, monospace;">4 5 9 randgraph zdup cr zet.</span><br />
<span style="font-family: Courier New, Courier, monospace;">({1,2,3,4,5,6,7,8,9},{{8,9},{7,9},{6,9},{4,9},{3,9},{2,9},{7,8},{6,8},{5,8},{4,8},{2,8},{1,8},{6,7},{4,7},{2,7},{1,7},{4,6},{2,6},{1,6},{4,5},{3,5},{1,5},{3,4},{1,4},{1,3},{1,2}}) ok</span><br />
<span class="Apple-style-span" style="font-family: Courier New, Courier, monospace;"></span><br />
<span style="font-family: Courier New, Courier, monospace;">2-regular . 0 ok</span><br />
<div>
<br /></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-22259643619346143512016-05-03T02:01:00.000-07:002016-05-03T03:54:00.266-07:00Fast generation of the symmetric and alternating groups<span style="font-family: "courier new" , "courier" , monospace;">From Wikipedia I got this algorithm, how to generate all permutation in alphabetical order:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">1. Find the largest index k such that a[k]<a[k+1]. If no such index</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> exists, the permutation is the last.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">2. Find the largest index l greater than k such that a[k]<a[l].</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">3. Swap the value of a[k] with that of a[l].</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">4. Reverse the sequence from a[k+1] up to and including the final</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> element a[n].</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">First a word that reverse the order of all n characters starting at address ad.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: reverse-string \ ad n --</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 2dup + 1- loc{ ad1 n ad2 } n 2/ 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ?do ad1 i + c@ ad2 i - c@ </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ad1 i + c! ad2 i - c!</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Then the 1'st part of the algorithm, returning the address corresponding to the index k if it exists or else return 0.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: lex-perm1 \ ad n -- a1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 loc{ a1 } 2 - over + </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do i c@ i 1+ c@ <</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if i to a1 leave then -1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> +loop a1 ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Find the largest address a2 greater than a1 such that [a1]<[a2].</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: lex-perm2 \ ad n a1 -- a2</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 loc{ a1 a2 } 1- over +</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do a1 c@ i c@ <</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if i to a2 leave then -1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> +loop a2 ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Swap the values at addresses a1 and a2.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: lex-perm3 \ a1 a2 --</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> over c@ over c@</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> swap rot c!</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> swap c! ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Reverse the order of the last characters, from address a1 to the end.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: lex-perm4 \ ad n a1 -- </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> reverse from a1+1 to ad+n-1 </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 1+ -rot \ a1+1 ad n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> + over - \ a1+1 ad+n-(a1+1) </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> reverse-string ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Calculate the next permutation:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: nextp \ ad n -- </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 2dup 2dup \ ad n ad n ad n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> lex-perm1 dup 0=</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if 2drop 2drop drop exit </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then dup >r \ ad n ad n a1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> lex-perm2 r> \ ad n a2 a1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> tuck swap \ ad n a1 a1 a2</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> lex-perm3 \ ad n a1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> lex-perm4 ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Create the string 123...n:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: n>str \ n -- ad n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup 0 do i 49 + pad i + c! loop pad swap ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Create a vector on the z-stack from the string.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: str>vect \ ad n -- | -- s</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loc{ ad n } n dup 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do ad i + c@ 15 and >zst loop 2* 1+ negate >zst ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Fast calculation of the symmetry group of n! permutations.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: sym \ n -- | -- s</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> n>str loc{ ad n }</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> n dup ufaculty dup 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do ad n str>vect </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ad n nextp</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop swap 1+ * 2* negate >zst ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">utime 7 sym cardinality . utime d- d. 5040 -3931 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">What would take hours with straight forward generation is now done in 4 milliseconds.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Next word calculates how many components in the vector s that is greater than the number m:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: perm> \ m -- n | s --</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loc{ m } 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> foreach do zst> m > + loop negate ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">This is used to calculate the number of pairs of components in the vector s that is unsorted:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: #perm \ -- n | s -- </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> begin zst@ -3 <</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> while zsplit zst> zdup perm> +</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> repeat zdrop ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Which determine if the vector correspond to an odd permutation:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: oddperm \ -- flag | s --</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> #perm 1 and ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: alt \ n -- | -- s</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> n>str loc{ ad n }</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> n dup ufaculty dup 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do ad n str>vect zdup oddperm</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if zdrop then ad n nextp</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop swap 1+ * negate >zst ;</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">utime 7 alt cardinality . utime d- d. 2520 -35424 ok</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">To filter out the odd permutations takes some time, so the alternating group of n!/2 even permutations runs in 35 ms.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">What is left is to figure out how to generate general groups fast. And to write a manual!</span></div>
<div>
<br /></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-15155076814023997982016-04-11T08:28:00.002-07:002016-04-11T23:49:00.418-07:00Tutorial 2: Euler project 1 - 5<span style="font-family: "courier new" , "courier" , monospace;"><a href="https://projecteuler.net/problem=1">https://projecteuler.net/problem=1</a></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>If we list all the natural numbers below 10 that are multiples of 3 or 5, we get 3, 5, 6 and 9. The sum of these multiples is 23.</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b><br /></b></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>Find the sum of all the multiples of 3 or 5 below 1000.</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: multiple-of-3 3 mod 0= ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: multiple-of-5 5 mod 0= ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: setsum \ -- n | s --</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 foreach do zst> + loop ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 1000 | multiple-of-3 } { 1 1000 | multiple-of-5 } union setsum .</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">or</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: multiple-of-3-or-5 dup multiple-of-3 swap multiple-of-5 or ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 1000 | multiple-of-3-or-5 } setsum . </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><a href="https://projecteuler.net/problem=2">https://projecteuler.net/problem=2</a></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>Each new term in the Fibonacci sequence is generated by adding the previous two terms. By starting with 1 and 2, the first 10 terms will be:</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b><br /></b></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b><br /></b></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>By considering the terms in the Fibonacci sequence whose values do not exceed four million, find the sum of the even-valued terms.</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: next-fib-pair \ m n -- n m+n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> tuck + ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: euler2 \ -- sum</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 0 loc{ sum } 1 2</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> begin dup 1 and 0=</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if dup sum + to sum </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then next-fib-pair dup 4000000 ></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> until 2drop sum ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">euler2 . </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><a href="https://projecteuler.net/problem=3">https://projecteuler.net/problem=3</a></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>The prime factors of 13195 are 5, 7, 13 and 29.</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b><br /></b></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>What is the largest prime factor of the number 600851475143 ?</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">600851475143 pollard# sort over . drops </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><a href="https://projecteuler.net/problem=4">https://projecteuler.net/problem=4</a></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>A palindromic number reads the same both ways. The largest palindrome made from the product of two 2-digit numbers is 9009 = 91 × 99.</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b><br /></b></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>Find the largest palindrome made from the product of two 3-digit numbers.</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: palindrome \ n -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> s>d <# #s #> 2dup + 1- true </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loc{ add1 nr add2 flag } </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> nr 2/ 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do add1 i + c@ </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> add2 i - c@ = 0=</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if false to flag leave then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop flag ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Just for curiosity:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 10000 1000000 | palindrome } cardinality . </span><span style="font-family: courier new, courier, monospace;">1800 ok</span><br />
<span style="font-family: courier new, courier, monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: split-fact \ n -- i j where ij=n and i+j is minim</span><span style="font-family: 'courier new', courier, monospace;">al</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup sqrtf </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> begin 2dup mod</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> while 1-</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> repeat tuck / ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: euler4 \ -- n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 10000 999999 </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do i palindrome</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if i split-fact</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 100 1000 within swap</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 100 1000 within and</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if i leave then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> then -1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> +loop ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">euler4 . </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><a href="https://projecteuler.net/problem=5">https://projecteuler.net/problem=5</a></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>2520 is the smallest number that can be divided by each of the numbers from 1 to 10 without any remainder.</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b><br /></b></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>What is the smallest positive number that is evenly divisible by all of the numbers from 1 to 20?</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: divisible20 \ m -- flag</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> true loc{ m flag } 21 1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do m i mod</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if false to flag leave then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop flag ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: euler5 \ -- n</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> -1 1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> do i divisible20</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if i leave then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">utime euler5 . utime d- d. xxxxxxxxx -36728698 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">That takes more than 36.7 seconds. However, the wanted number is the product of all numbers in the intervall 1...20 that are of the form p^n, where p is a prime and p^n<=20<p^(n+1).</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">20 value numb</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: pn \ m -- flag </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup uniprime 0= if drop false exit then </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> dup pollard# over >r drops r> * numb > ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: setmul \ -- n | s -- </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> 1 foreach do zst> * loop ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">utime { 2 21 | pn } setmul . utime d- d. xxxxxxxxx -190 ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">which takes 190 micro seconds.</span>Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-54205425250980761582016-03-14T02:15:00.000-07:002016-03-18T03:34:35.466-07:00Some groups<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">First, I have improved the word </span><b><span style="font-family: "courier new" , "courier" , monospace;">psubgroups</span></b><span style="font-family: "courier new" , "courier" , monospace;">. Stupidly enough it </span><i><span style="font-family: "courier new" , "courier" , monospace;">calculated</span></i><span style="font-family: "courier new" , "courier" , monospace;"> the whole (known) group. Now it works 5-10 times faster and calculate the set of subgroups of Sym(4) in a second. To calculate the set of subgroups to Sym(5) takes about 30 minutes, though, so enhancements must still be made.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">Now handling groups with order around 100 and subgroups of groups with order around 30 is okay. A little more with a fast system...</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span><span style="font-family: "courier new" , "courier" , monospace;">Some finite groups</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ cyclic group of permutations of 1...n<br />: cyc \ n -- | -- s<br /> pcirc pgen ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">6 cyc zet. {(6,1,2,3,4,5),(5,6,1,2,3,4),(4,5,6,1,2,3),(3,4,5,6,1,2),(2,3,4,5,6,1),(1,2,3,4,5,6)} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ symetric group of permutations of 1...n, n<6<br />: sym \ n -- | -- s <br /> dup 2 ><br /> if dup pcirc zfence proll zfence zmerge generate<br /> else 2 = if ( 2 1 ) pgen else ( 1 ) pgen then<br /> then ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">The n-th symmetry group is the set of all bijections of {1,...,n}.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">4 sym cr zet.<br />{(4,2,3,1),(1,2,3,4),(1,3,4,2),(2,3,4,1),(2,4,3,1),(1,4,3,2),(2,1,3,4),(4,1,3,2),(3,4,1,2),(2,4,1,3),(3,4,2,1),(1,4,2,3),(3,1,4,2),(2,1,4,3),(3,2,4,1),(1,2,4,3),(4,3,1,2),(2,3,1,4),(4,2,1,3),(3,2,1,4),(4,3,2,1),(1,3,2,4),(4,1,2,3),(3,1,2,4)} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ dihedral group of permutations of 1...n<br />: dih \ n -- | -- s<br /> dup >r pcirc zfence<br /> ( 1 r> ?do i -1 +loop ) zfence <br /> zetmerge generate ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">6 dih cr zet.<br />{(6,5,4,3,2,1),(6,1,2,3,4,5),(2,1,6,5,4,3),(2,3,4,5,6,1),(4,5,6,1,2,3),(4,3,2,1,6,5),(3,2,1,6,5,4),(3,4,5,6,1,2),(5,4,3,2,1,6),(5,6,1,2,3,4),(1,2,3,4,5,6),(1,6,5,4,3,2)} ok</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">There is also an other tradition where the dihedral group is denoted after the order of the group, but I think it's more consequent to denote it after the number of permutation elements.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Any permutation can be factorized in simple so called 2-cycles: (n m) where n maps to m and m maps to n. Example: (2,3,1)=(1 2)(1 3). Certain permutations can be factorized in an even number of 2-cycles and some can not. The product of even permutations is of course an even permutation and those permutation forms a subgroup Alt(S) of Sym(S). Both Sym(S) and Alt(S) can be generated by two elements, while their subgroups might not.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ alternating group of permutations of 1...n, n<6<br />: alt \ n -- | -- s n>2<br /> dup 3 = if drop ( 2 3 1 ) pgen exit then<br /> dup 1 and<br /> if >r <br /> { r@ pcirc <br /> ( r@ 2 - 1 do i loop r@ 1- r@ r> 2 - )<br /> } generate<br /> else >r <br /> { ( r@ 2 do i loop 1 r@ )<br /> ( r@ 2 - 1 do i loop r@ 1- r@ r> 2 - )<br /> } generate<br /> then ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">4 alt cr zet.<br />{(3,4,1,2),(3,1,2,4),(3,2,4,1),(4,1,3,2),(2,1,4,3),(1,3,4,2),(2,4,3,1),(1,4,2,3),(2,3,1,4),(4,3,2,1),(1,2,3,4),(4,2,1,3)} ok</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ quaternion group Q8={±1,±i,±j,±k} as group of permutations of 1..8</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">\ q8 \ -- s<br />: { ( 2 4 6 7 3 8 1 5 ) ( 3 5 4 8 7 2 6 1 ) } generate ;</span>
</span><br />
<span style="font-family: "courier new";"></span><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<h3>
<span style="font-family: "courier new" , "courier" , monospace;">
</span><span style="font-family: "courier new" , "courier" , monospace;">The product of two permutation groups given as a permutation group</span></h3>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ extend, to the right, bijection v to permute n elements </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: rext \ n -- | v -- v'<br /> >r ( r> zst@ cs do i 1+ loop )<br /> 1 zst+! zswap 1 zst+! zswap zmerge -1 zst+! ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ extend to the left</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: lext \ n -- | v -- v'<br /> dup >r ( r> zst@ cs - 1+ 1 do i loop ) 1 zst+!<br /> zswap zst@ tuck cs - loc{ x y }<br /> 1 zst+! foreach<br /> do zst> y + loop x 1+ >>zst<br /> zmerge -1 zst+! ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ extend all functions in a set to the right </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: multirext \ n -- | s -- s'<br /> 0 >xst foreach<br /> do dup rext zfence xzmerge<br /> loop drop xst zst setmove ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">3 sym 4 multirext cr zet.<br />{(3,2,1,4),(1,2,3,4),(2,3,1,4),(1,3,2,4),(3,1,2,4),(2,1,3,4)} ok</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ extend all to the left </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: multilext \ n -- | s -- s'<br /> 0 >xst foreach<br /> do dup lext zfence xzmerge<br /> loop drop xst zst setmove ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">5 cyc 6 multilext cr zet.<br />{(1,2,3,4,5,6),(1,3,4,5,6,2),(1,4,5,6,2,3),(1,5,6,2,3,4),(1,6,2,3,4,5)} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br />
\ the product of two groups s and s'<br />: gprod \ s s' -- sxs'<br /> ord zswap ord +<br /> dup multirext zswap<br /> multilext union generate ;</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">2 cyc zdup gprod zet. {(2,1,3,4),(1,2,3,4),(1,2,4,3),(2,1,4,3)} ok</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">3 cyc 4 alt gprod cr zet.<br />{(2,3,1,4,5,6,7,8,9,10,11,15,12,14,13),(2,3,1,4,5,6,7,8,9,10,11,15,14,13,12),(2,3,1,4,5,6,7,8,9,10,11,12,14,15,13),(2,3,1,4,5,6,7,8,9,10,11,13,14,12,15),(2,3,1,4,5,6,7,8,9,10,11,14,15,12,13),(2,3,1,4,5,6,7,8,9,10,11,13,12,15,14),(2,3,1,4,5,6,7,8,9,10,11,14,12,13,15),(2,3,1,4,5,6,7,8,9,10,11,13,15,14,12),(2,3,1,4,5,6,7,8,9,10,11,12,15,13,14),(2,3,1,4,5,6,7,8,9,10,11,14,13,15,12),(2,3,1,4,5,6,7,8,9,10,11,12,13,14,15),(1,2,3,4,5,6,7,8,9,10,11,12,14,15,13),(1,2,3,4,5,6,7,8,9,10,11,12,15,13,14),(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15),(1,2,3,4,5,6,7,8,9,10,11,14,15,12,13),(1,2,3,4,5,6,7,8,9,10,11,13,15,14,12),(1,2,3,4,5,6,7,8,9,10,11,15,12,14,13),(1,2,3,4,5,6,7,8,9,10,11,13,14,12,15),(1,2,3,4,5,6,7,8,9,10,11,15,14,13,12),(1,2,3,4,5,6,7,8,9,10,11,13,12,15,14),(1,2,3,4,5,6,7,8,9,10,11,14,12,13,15),(1,2,3,4,5,6,7,8,9,10,11,14,13,15,12),(3,1,2,4,5,6,7,8,9,10,11,12,14,15,13),(3,1,2,4,5,6,7,8,9,10,11,12,15,13,14),(3,1,2,4,5,6,7,8,9,10,11,12,13,14,15),(3,1,2,4,5,6,7,8,9,10,11,14,15,12,13),(3,1,2,4,5,6,7,8,9,10,11,13,15,14,12),(3,1,2,4,5,6,7,8,9,10,11,15,12,14,13),(3,1,2,4,5,6,7,8,9,10,11,13,14,12,15),(3,1,2,4,5,6,7,8,9,10,11,15,14,13,12),(3,1,2,4,5,6,7,8,9,10,11,13,12,15,14),(3,1,2,4,5,6,7,8,9,10,11,14,12,13,15),(3,1,2,4,5,6,7,8,9,10,11,15,13,12,14),(3,1,2,4,5,6,7,8,9,10,11,14,13,15,12),(2,3,1,4,5,6,7,8,9,10,11,15,13,12,14),(1,2,3,4,5,6,7,8,9,10,11,15,13,12,14)} ok</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></div>
<h3>
<span style="font-family: "courier new" , "courier" , monospace;">Pseudo isomorphism test</span></h3>
<span style="font-family: "courier new" , "courier" , monospace;">\ the set of cyclic subgroups of the group s<br />: pcsubs \ s -- s'<br /> 0 >xst<br /> foreach<br /> do pgen zfence xzmerge<br /> loop xst zst setmove reduce ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br />\ flag true if not equal cardinality<br />: card<> \ -- flag | s s' -- s s'</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zover cardinality zdup cardinality = 0= ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ sort a list of non-negative integers</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: vect-sort \ v -- v'<br /> set-sort zst> 1- > zst ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ compute vector of orders of all cyclic subgroups in s<br />: pscan \ s -- v <br /> 0 foreach do cardinality swap 1+ loop <br /> sort 2* 1+ negate >zet ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: pseudoiso \ -- flag | s s' --<br /> card<><br /> if zdrop zdrop false exit then <br /> pcsubs zswap pcsubs card<><br /> if zdrop zdrop false exit then<br /> pscan zswap pscan vector= ;</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">4 dih pcsubs pscan zet. (1,2,2,2,2,2,4) ok</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">4 dih 8 cyc pseudoiso . 0 ok</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">3 sym 3 dih pseudoiso . -1 ok</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<div>
<span style="font-family: "courier new";"><span style="font-family: "courier new" , "courier" , monospace;">Due to </span><a href="http://math.stackexchange.com/questions/1694000/isomorphic-subgroups-of-finite-groups" target="_blank"><span style="font-family: "courier new" , "courier" , monospace;">Mathematics Stack Exchange</span></a><span style="font-family: "courier new" , "courier" , monospace;"> the psudoiso test holds for all subgroups of Sym(7) but already in Sym(8) there are counterexamples. A counterexample in Sym(16) is also:</span></span></div>
<div>
<span style="font-family: "courier new";"><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">4 cyc zdup gprod 2 cyc q8 gprod pseudoiso . -1 ok</span></div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com1tag:blogger.com,1999:blog-5309775736131296725.post-63711816964402868312016-03-04T14:15:00.001-08:002016-03-04T23:58:39.057-08:00Tutorial: play around 1<span style="font-family: "courier new" , "courier" , monospace;">In addition to the two Forth stacks s and r, there are three stacks x, y and z in Zet. The main stack (set parameter stack) for bundles is z. Most of the algebraic is done in z, for example:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>reduce</b> ( -- ) that eliminates copies of members in <i>sorted</i> sets in z;</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>zdup zdrop zover zswap znip ztuck </b>and<b> zrot</b> manipulates bundles in z;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>cardinality</b> ( -- n | s -- ) that counts the number of elements in sets or components vectors;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>foreach</b> ( -- n 0 | s -- z1...zn ) that "appends" a set and prepare for a do loop for each element;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>zet.</b> ( s -- ) that prints the set/vector on z;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>subset zet= member</b> that examines sets and vectors on z;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>union intersection diff powerset cartprod</b> etc that works on z;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>set-sort</b> ( -- | m1...mk -- n1---nk ) </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>zmerge </b>( s s' -- s" )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The other two stacks, x and y, are help stacks that compensate the lack of variables. Some operations working on x and y are:</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>setdup </b>( ad -- | obj -- obj obj )</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>setdrop </b>( ad -- | obj -- )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>setover</b> ( ad -- | obj1 obj2 -- obj1 obj2 obj1</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>setmove </b>( ad1 ad2 -- )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>setcopy </b>( ad1 ad2 -- )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>_fence</b> ( ad -- | obj -- {obj} )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>_split</b> ( ad -- | s -- s' obj ) ad=yst,zst </span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">And there are also some special words for stack interaction:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><b><br /></b></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>xzmerge</b> ( s -- ) takes set from z and merge so set in x</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>yzcopy1</b> ( -- s ) copy set from top y to z</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><b>yzcopy2</b> ( -- s ) </span><span style="font-family: "courier new" , "courier" , monospace;">copy set from next after top y to z</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">There are two main methods to penetrate a set, to use <b>foreach </b>or to use <b>zsplit</b> (or <b>ysplit</b>). When all elements are to be penetrated <b>foreach </b>is handy, but no objects under the top set on z can be reached under the penetration. When using zsplit, that splits a set in the top element and the rest of the set, the sets under can be reached, and the penetration can be abrupt without stack problems.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The facility with | in</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 100 | prime } cr zet.</span><span style="font-family: "courier new" , "courier" , monospace;">{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</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">does only work in interpretation mode and can't be compiled. </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">1 value num</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: coprime \ n -- flag </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> num ugcd 1 = ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 30 dup to num | coprime } zet. {1,7,11,13,17,19,23,29} ok</span></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">17 num invmod . 23 ok</span></div>
<div style="font-family: 'Courier New', Courier, monospace;">
<div>
17 23 num u*mod . 1 ok</div>
<div>
<br /></div>
<div>
About adding all numbers in two sets:</div>
<div>
<br /></div>
</div>
</div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: setint+ \ n -- | s -- s'</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> 0 >xst \ empty set on x</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> foreach \ for each number in s</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> ?do zst> over + >zst \ element to datastack and back</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> zfence xzmerge \ merge {x+y} to the set on x</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> loop drop xst zst setmove ; \ drop n and move the set to z</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: set+ \ s s' -- s"</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> 0 >xst </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> zst yst setmove</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> foreach</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> ?do zst> \ element to data stack</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> yzcopy1 setint+ \ add element to all elements in s'</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> xzmergered \ merge this set to the set on x</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> loop yst setdrop </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> xst zst setmove ;</span></div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
</div>
<div>
<div style="font-family: 'Courier New', Courier, monospace;">
{ 3 100 | prime } zdup set+ cr zet.</div>
<div style="font-family: 'Courier New', Courier, monospace;">
{6,8,10,12,14,16,18,20,22,24,26,28,30,32,34,36,38,40,42,44,46,48,50,52,54,56,58,60,62,64,66,68,70,72,74,76,78,80,82,84,86,88,90,92,94,96,98,100,102,104,106,108,110,112,114,116,118,120,122,124,126,128,130,132,134,136,138,140,142,144,146,148,150,152,154,156,158,160,162,164,166,168,170,172,176,178,180,186,194} ok</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
<div style="font-family: 'Courier New', Courier, monospace;">
Hmm..! Goldbach seems to be right...</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
<div style="font-family: 'Courier New', Courier, monospace;">
The first failure is 174.</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 3 200 | prime } zdup set+ cr zet.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{6,8,10,12,14,16,18,20,22,24,26,28,30,32,34,36,38,40,42,44,46,48,50,52,54,56,58,60,62,64,66,68,70,72,74,76,78,80,82,84,86,88,90,92,94,96,98,100,102,104,106,108,110,112,114,116,118,120,122,124,126,128,130,132,134,136,138,140,142,144,146,148,150,152,154,156,158,160,162,164,166,168,170,172,174,176,178,180,182,184,186,188,190,192,194,196,198,200,202,204,206,208,210,212,214,216,218,220,222,224,226,228,230,232,234,236,238,240,242,244,246,248,250,252,254,256,258,260,262,264,266,268,270,272,274,276,278,280,282,284,286,288,290,292,294,296,298,300,302,304,306,308,310,312,314,316,318,320,322,324,326,328,330,332,334,336,338,340,342,344,346,348,350,352,354,356,358,360,362,364,366,370,372,374,376,378,380,382,384,386,388,390,392,394,396,398} ok</span></div>
</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
</div>
<div style="font-family: 'Courier New', Courier, monospace;">
First failure at 368.</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
<div>
<div style="font-family: 'Courier New', Courier, monospace;">
{ 3 300 | prime } zdup set+ cr zet.</div>
<div style="font-family: 'Courier New', Courier, monospace;">
{6,8,10,12,14,16,18,20,22,24,26,28,30,32,34,36,38,40,42,44,46,48,50,52,54,56,58,60,62,64,66,68,70,72,74,76,78,80,82,84,86,88,90,92,94,96,98,100,102,104,106,108,110,112,114,116,118,120,122,124,126,128,130,132,134,136,138,140,142,144,146,148,150,152,154,156,158,160,162,164,166,168,170,172,174,176,178,180,182,184,186,188,190,192,194,196,198,200,202,204,206,208,210,212,214,216,218,220,222,224,226,228,230,232,234,236,238,240,242,244,246,248,250,252,254,256,258,260,262,264,266,268,270,272,274,276,278,280,282,284,286,288,290,292,294,296,298,300,302,304,306,308,310,312,314,316,318,320,322,324,326,328,330,332,334,336,338,340,342,344,346,348,350,352,354,356,358,360,362,364,366,368,370,372,374,376,378,380,382,384,386,388,390,392,394,396,398,400,402,404,406,408,410,412,414,416,418,420,422,424,426,428,430,432,434,436,438,440,442,444,446,448,450,452,454,456,458,460,462,464,466,468,470,472,474,476,478,480,482,484,486,488,490,492,494,496,498,500,502,504,506,508,510,512,514,516,518,520,522,524,526,528,532,534,538,540,542,544,546,548,550,552,554,556,558,560,562,564,566,570,574,576,586} ok</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
<div style="font-family: 'Courier New', Courier, monospace;">
Fail(300)=530. The first failure is a kind of measure of the probability of Goldbachs conjecture to be true.</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
<div style="font-family: 'Courier New', Courier, monospace;">
Additional words for permutation groups:</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
<div style="font-family: 'Courier New', Courier, monospace;">
\ Is s a permutation subgroup of s'?</div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: psub? \ -- flag | s s' --</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> zover zswap subset 0= </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> if zdrop false exit </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> then permgroup? ;</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ Is s a normal permutation subgroup of s'?</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: pnsub? \ -- flag | s s' --</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> zover zover psub? 0= </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> if zdrop zdrop false exit then</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> zswap zst yst setmove</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> begin zst@</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> while zsplit yzcopy1 zover prcoset </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> zswap yzcopy1 plcoset zet= 0= \ false</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> if zdrop yst setdrop false exit then</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> repeat zdrop \ dropping the empty set left in z</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> yst setdrop true ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ s' is the set of normal subgroups of s</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: pnsubgroups \ s -- s'</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> zst yst setcopy</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> psubgroups</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> 0 >xst</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> begin zst@</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> while zsplit zdup yzcopy1 pnsub?</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> if zfence xzmerge else zdrop then</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> repeat zdrop yst setdrop xst zst setmove ;</span></div>
</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
</div>
<div>
<div style="font-family: 'Courier New', Courier, monospace;">
{ ( 4 1 2 3 ) ( 2 1 3 4 ) } generate zdup cardinality . 24 ok</div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">pnsubgroups cr zet.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{{(2,1,3,4),(3,4,2,1),(3,1,4,2),(2,3,4,1),(1,4,2,3),(1,3,4,2),(1,2,3,4),(4,2,3,1),(4,1,2,3),(3,2,1,4),(4,1,3,2),(4,2,1,3),(4,3,1,2),(2,1,4,3),(2,3,1,4),(2,4,1,3),(3,1,2,4),(3,4,1,2),(3,2,4,1),(4,3,2,1),(2,4,3,1),(1,2,4,3),(1,3,2,4),(1,4,3,2)},{(4,3,2,1),(1,3,4,2),(1,2,3,4),(4,2,1,3),(3,1,2,4),(2,3,1,4),(2,4,3,1),(3,2,4,1),(1,4,2,3),(4,1,3,2),(2,1,4,3),(3,4,1,2)},{(4,3,2,1),(1,2,3,4),(3,4,1,2),(2,1,4,3)},{(1,2,3,4)}} ok</span></div>
</div>
<div style="font-family: 'Courier New', Courier, monospace;">
<br /></div>
</div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-47636194229140068612016-03-02T09:11:00.000-08:002016-03-03T03:29:37.329-08:00A simple implementation of permutation groups<span style="font-family: "courier new" , "courier" , monospace;">I have big problems with groups. </span><span style="font-family: "courier new" , "courier" , monospace;">If you in GAP write </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>gap> s7 := Group ( (1, 2, 3, 4, 5, 6, 7), (1, 2) );</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">GAP immediately respond </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>Group([ (1,2,3,4,5,6,7), (1,2) ])</b></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">And if you then write</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>gap> Elements ( s7 );</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span><div>
<span style="font-family: "courier new" , "courier" , monospace;">GAP prints the list of all 7! elements of Sym(7) in a second or so.</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
<br /></div>
<div>
In my simple implementation of permutation groups it takes about two seconds to generate Sym(5), and Sym(6) seems to be out of reach. The big discrepancy comes from that GAP has been developed at the universities for twenty years or so and that I so far has almost no knowledge of computational algebra. </div>
<div>
<br /></div>
<div>
In GAP a group is determined by its generators while in ZET it's determined by the set of permutations. To me it's interesting to examine subgroups of Sym(5) in this form, but it would also be interesting to try to make a more general and perhaps more efficient implementation later on.</div>
<div>
<br /></div>
<div>
In GAP i.e. (1,2,3,4) denotes a cycle but here the same vector will denote the identity permutation and the cycle in GAP would correspond to (2,3,4,1) here.<br />
<br />
\ The number of permutations in a set of permutations<br />
: ord \ -- n | s -- s<br />
zst> zst> 2dup >zst >zst<br />
cs 1+ swap cs swap / ;<br />
<br />
\ The number of elements to be permuted in v<br />
: numb \ -- n | v --<br />
zst@ cs zdrop ;<br />
<br />
\ j=v(i)<br />
: pmaps \ i -- j | v --<br />
zdrop cells zst @ + @ ;<br />
<br />
\ composition of permutations as functions<br />
: permcomp \ v1 v2 -- v1v2<br />
( zst@ cs 1+ 1<br />
do zover zover i pmaps pmaps<br />
loop ) znip znip ;<br />
<br />
\ generation of cyclic permutation group<br />
: pgen \ v -- s<br />
zst yst setcopy -1 1<br />
do zdup yzcopy1 permcomp zdup yzcopy1 vector=<br />
if numb 1+ i * 2* negate >zst leave then<br />
loop yst setdrop ;<br />
<br />
\ right coset<br />
: prcoset \ s v -- s'<br />
0 >xst<br />
zst yst setmove<br />
foreach<br />
?do yzcopy1 permcomp zfence xzmerge<br />
loop yst setdrop xst zst setmove ;<br />
<br />
\ left coset<br />
: plcoset \ v s -- s'<br />
0 >xst<br />
zswap zst yst setmove<br />
foreach<br />
?do yzcopy1 zswap permcomp zfence xzmerge<br />
loop yst setdrop xst zst setmove ;<br />
<br />
\ componentwise composition of permutation sets<br />
: permset* \ -- | s1 s2 -- s3<br />
0 >xst<br />
zst yst setmove<br />
foreach<br />
?do yzcopy1 plcoset<br />
xzmergered<br />
loop yst setdrop<br />
xst zst setmove ;<br />
<br />
: permgroup? \ -- flag | s --<br />
zdup zdup permset* zet= ;<br />
<br />
\ Generation of standard permutations<br />
: pidentity \ n -- | -- v<br />
>r ( r> 1+ 1 ?do i loop ) ;<br />
<br />
: pcirc \ n -- | -- v<br />
>r ( r> dup 1 ?do i loop ) ;<br />
<br />
: proll \ n -- | -- v<br />
>r ( r@ 1- dup 1 do i loop r> ) ;<br />
<br />
\ The number of element to be permuted in permutations in s<br />
: perm# \ -- n | s -- s<br />
zst> zst> tuck >zst >zst cs ;<br />
<br />
\ Calculate the inverse permutation<br />
: pinv \ v -- v'<br />
zdup adn2 drop adn1 -rot loc{ a2 a1 } cell/ 1<br />
do i dup 1- cells a2 + @ 1- cells a1 + ! loop znip ;<br />
<br />
\ add the inverses to all permutations in s<br />
: adinv \ s -- s'<br />
0 >xst zdup xzmerge foreach<br />
do pinv zfence xzmerge<br />
loop xst zst setmove reduce ;<br />
<br />
\ generates the group s' from the generators in s<br />
: generate \ s -- s'<br />
zst yst setcopy 0 >xst foreach<br />
?do pgen xzmerge<br />
loop xst zst setmove reduce 1<br />
begin yzcopy1 zswap permset*<br />
yzcopy1 permset* ord tuck =<br />
until yst setdrop drop ;<br />
<br />
\ generate set of groups s' from set of generators s<br />
: multigen \ s -- s'<br />
0 >xst foreach<br />
?do generate zfence xzmerge<br />
loop xst zst setmove reduce ;<br />
<br />
\ Set of all subgroups to s<br />
: psubgroups \ s -- s'<br />
perm# pidentity zfence zfence<br />
zst yst setmove foreach<br />
do yst zst setmove zdup zrot multincl<br />
multigen union zst yst setmove<br />
loop yst zst setmove ;</div>
<div>
<br /></div>
<div>
<div>
{ ( 4 1 2 3 ) ( 2 1 3 4 ) } generate ok</div>
<div>
ord . 24 ok</div>
<div>
psubgroups ok</div>
<div>
zdup ok</div>
<div>
cardinality . 30 ok</div>
<div>
zet. {{(4,3,2,1),(1,2,3,4)},{(1,2,3,4)},{(1,3,4,2),(1,4,2,3),(1,2,3,4)},{(2,1,4,3),(1,2,3,4)},{(4,1,3,2),(2,4,3,1),(1,2,3,4)},{(3,4,1,2),(1,2,3,4)},{(4,3,2,1),(1,2,3,4),(3,4,1,2),(2,1,4,3)},{(3,1,2,4),(2,3,1,4),(1,2,3,4)},{(1,3,2,4),(1,2,3,4)},{(3,2,1,4),(1,2,3,4)},{(1,2,4,3),(1,2,3,4)},{(4,2,3,1),(1,2,3,4)},{(4,3,2,1),(1,2,3,4),(4,2,3,1),(1,3,2,4)},{(3,4,1,2),(1,2,3,4),(1,4,3,2),(3,2,1,4)},{(1,3,4,2),(1,4,2,3),(1,2,3,4),(1,4,3,2),(1,2,4,3),(1,3,2,4)},{(1,4,3,2),(1,2,3,4)},{(4,3,1,2),(2,1,4,3),(3,4,2,1),(1,2,3,4)},{(1,2,4,3),(1,2,3,4),(3,2,1,4),(4,2,1,3),(3,2,4,1),(4,2,3,1)},{(4,3,2,1),(1,3,4,2),(1,2,3,4),(4,2,1,3),(3,1,2,4),(2,3,1,4),(2,4,3,1),(3,2,4,1),(1,4,2,3),(4,1,3,2),(2,1,4,3),(3,4,1,2)},{(3,2,4,1),(4,2,1,3),(1,2,3,4)},{(3,1,4,2),(3,4,1,2),(1,3,2,4),(1,2,3,4),(2,1,4,3),(4,3,2,1),(2,4,1,3),(4,2,3,1)},{(2,4,1,3),(3,1,4,2),(4,3,2,1),(1,2,3,4)},{(3,1,2,4),(2,3,1,4),(1,2,3,4),(2,1,3,4),(1,3,2,4),(3,2,1,4)},{(4,1,3,2),(2,4,3,1),(1,2,3,4),(2,1,3,4),(1,4,3,2),(4,2,3,1)},{(2,1,4,3),(1,2,3,4),(2,1,3,4),(1,2,4,3)},{(2,1,3,4),(1,2,3,4)},{(4,3,2,1),(1,2,3,4),(2,1,3,4),(3,4,2,1),(1,2,4,3),(4,3,1,2),(3,4,1,2),(2,1,4,3)},{(2,1,3,4),(3,4,2,1),(3,1,4,2),(2,3,4,1),(1,4,2,3),(1,3,4,2),(1,2,3,4),(4,2,3,1),(4,1,2,3),(3,2,1,4),(4,1,3,2),(4,2,1,3),(4,3,1,2),(2,1,4,3),(2,3,1,4),(2,4,1,3),(3,1,2,4),(3,4,1,2),(3,2,4,1),(4,3,2,1),(2,4,3,1),(1,2,4,3),(1,3,2,4),(1,4,3,2)},{(4,1,2,3),(3,4,1,2),(2,3,4,1),(1,2,3,4)},{(4,1,2,3),(2,1,4,3),(3,2,1,4),(1,2,3,4),(4,3,2,1),(3,4,1,2),(2,3,4,1),(1,4,3,2)}} ok</div>
</div>
<div>
<br />
My purpose with the nested sets was to investigate the possibility of simple dynamic data structures without the need of garbage collection. The stacks are administrated as usual and rest data on the stacks comes from faulty programming. So in a way the word q, that resets the stacks in case of error (manually now, but should be automatic), and the word drop, replace the garbage collection systems used in traditional programming with dynamic data. Except from with the present primitive implementation of groups it turned out to be surprisingly efficient.</div>
</span></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com2tag:blogger.com,1999:blog-5309775736131296725.post-9996320163326293382016-02-23T10:53:00.000-08:002016-02-23T10:53:47.638-08:00Directed graphs<span style="font-family: "Courier New", Courier, monospace;">A relation (V,V,E) is equivalent with a directed graph (V,E), where E⊆V×V is the set of edges and V is the set of vertices. </span><br />
<span style="font-family: "Courier New", Courier, monospace;"><br /></span>
<span style="font-family: "Courier New", Courier, monospace;">There is a path from the node x to the node y if there exist a sequence (x,x1),(x1,x2),...,(xn,y)∈E:</span><br />
<b></b><i></i><u></u><sub></sub><sup></sup><span style="font-family: "Courier New", Courier, monospace;"><br />: path? \ x y -- flag | E --<br /> swap >zst zfence <br /> begin zover zover ztuck subimage \ E s s s'<br /> union zdup dup smember \ E s s" f<br /> if drop zdrop zdrop zdrop true exit</span><br />
<span style="font-family: "Courier New", Courier, monospace;"> then zswap zover zet= \ E s" s=s"<br /> if drop zdrop zdrop false exit</span><br />
<span style="font-family: "Courier New", Courier, monospace;"> then<br /> again ;</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">To make a pair on zst-stack from two integers of the data stack:</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">: ipair \ m n -- | -- (m,n)<br /> 2>r ( 2r> ) ;</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">Find the set s of all nodes in (V,E) without incoming arrows:</span><br />
<span style="font-family: "Courier New", Courier, monospace;"><span style="font-family: "Courier New", Courier, monospace;"></span><br /></span>
<span style="font-family: "Courier New", Courier, monospace;">: sourceset \ (V,E) -- s<br /> unfence image diff ;</span><br />
<span style="font-family: "Courier New", Courier, monospace;"><span style="font-family: "Courier New", Courier, monospace;"></span><br /></span>
<span style="font-family: "Courier New", Courier, monospace;">Find the set s of all nodes in (V,E) without outgoing arrows:</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">: sinkset \ (V,E) -- s<br /> unfence coimage diff ;</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">The next word merge the set on top of zst into the set on top of the xst leaving the result in xst.</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">: xzmerge \ s --<br /> xst zst setmove</span><br />
<span style="font-family: "Courier New", Courier, monospace;"> zswap zetmerge \ swap to build from right<br /> zst xst setmove ;</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">Given a directed graph (V,E), a topological sort is an ordered list including all the elements in V once, (x1,...xn), sorted so that if there is a path from xi to xj, then i<j. Such paths exist if and only if there are no directed cycles.</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<table align="center" cellpadding="0" cellspacing="0" class="tr-caption-container" style="margin-left: auto; margin-right: auto; text-align: center;"><tbody>
<tr><td style="text-align: center;"><a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEgZWNQ2WAoTZaC9I6FoOv8r6tfx_A-v3XVoIHyB_GYlhT5fwm1H8WquCkcF7WvppAMcfjHtqUPunoJmntjVyRH6i7w8b48hfkNQEix0Yml9NM88SRs2r8syCe34RP2PW-LnU5A56Cga8fb0/s1600/IMG_20160223_004700.jpg" imageanchor="1" style="margin-left: auto; margin-right: auto;"><span style="font-family: "Courier New", Courier, monospace;"><img border="0" height="217" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEgZWNQ2WAoTZaC9I6FoOv8r6tfx_A-v3XVoIHyB_GYlhT5fwm1H8WquCkcF7WvppAMcfjHtqUPunoJmntjVyRH6i7w8b48hfkNQEix0Yml9NM88SRs2r8syCe34RP2PW-LnU5A56Cga8fb0/s400/IMG_20160223_004700.jpg" width="400" /></span></a></td></tr>
<tr><td class="tr-caption" style="text-align: center;"><span class="mw-headline" id="Kahn.27s_algorithm"><i><span style="font-family: "Courier New", Courier, monospace;">Kahn's algorithm, from Wikipedia.</span></i></span></td></tr>
</tbody></table>
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">: toposort \ (V,E) -- s<br /> 0 >xst \ empty set in x<br /> zdup sourceset zst yst setmove \ source nodes in y<br /> unfence znip \ drop V keep E<br /> begin yst@ \ while source nodes left<br /> while ysplit yst> dup \ remove node m<br /> zdup >zst zfence zdup xzmerge \ add m to the set in x<br /> subimage \ set of all n: m→n<br /> begin zst@ \ while that set non empty<br /> while zsplit zst> zswap \ remove node n, E tos<br /> 2dup ipair zfence diff \ E:=E\{(m,n)}<br /> dup zdup >zst zfence \ build set of all nodes..<br /> subcoimage zst@ 0= \ ..pointing at n<br /> if >yst yfence ymerge \ add n to y-set if empty<br /> else drop \ else drop n<br /> then zdrop zswap \ drop set, swap E back<br /> repeat zdrop drop \ drop empty set and node m<br /> repeat yst> drop zst@ zdrop \ drop empty set and E<br /> if xst setdrop 0 >zst \ if |E|>0 flag with empty set<br /> else xst zst setmove \ else move the x-set to zst<br /> zst> 1- >zst \ mark it as an ordered list<br /> then ;</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">A directed graph without directed cycles is called a </span><i><span style="font-family: "Courier New", Courier, monospace;">dag </span></i><span style="font-family: "Courier New", Courier, monospace;">(directed acyclic graph):</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">: dag? \ -- f | (V,E) -- </span><br />
<span style="font-family: "Courier New", Courier, monospace;"> toposort zst@ 0= 0= zdrop ;</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">A loop is an edge from a node to itself and loopset gives the edge set to a graph in which all edges are loops. Can be used to filtrate the loops from digraphs.</span><br />
<div>
<span style="font-family: "Courier New", Courier, monospace;"></span><br /></div>
<div>
<span style="font-family: "Courier New", Courier, monospace;"></span><span style="font-family: "Courier New", Courier, monospace;">: loopset \ V -- E<br /> { foreach ?do ( zst> dup ) loop } ;</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">Generate a random pair of nodes:</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">: randpair \ |V| -- | -- (m,n)<br /> dup random 1+ swap random 1+ ipair ; </span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">Generate a random digraph with certain number of vertices and edges.</span><br />
<span style="font-family: "Courier New", Courier, monospace;"></span><br />
<span style="font-family: "Courier New", Courier, monospace;">: rand-digraph \ |V| |E| -- | -- (V,E)<br /> { over 1+ 1 ?do i loop } <br /> 0 >zst <br /> begin over rand-pair zfence union zdup cardinality over = <br /> until 2drop <br /> pair ; </span></div>
<div>
<span style="font-family: "Courier New", Courier, monospace;"><br /></span></div>
<div>
<span style="font-family: "Courier New", Courier, monospace;">: rand-noloop-digraph \ |V| |E| -- | -- (V,E)<br /> { over 1+ 1 ?do i loop } <br /> 0 >zst <br /> begin over rand-pair zfence union <br /> zover loopset diff <br /> zdup cardinality over = <br /> until 2drop pair ; </span></div>
<div>
<br /></div>
<div>
<span style="font-family: Courier New;">: rand-acyclic-digraph \ m n -- | -- (V,E)<br /> begin 2dup rand-noloop-digraph zdup dag? 0=<br /> while zdrop<br /> repeat 2drop ;</span><span style="font-family: "Courier New", Courier, monospace;"></span></div>
<div>
<br /></div>
<div>
<span style="font-family: "Courier New", Courier, monospace;">10 20 rand-noloop-digraph ok<br />zdup cr zet.<br />({1,2,3,4,5,6,7,8,9,10},{(5,2),(2,5),(10,3),(9,3),(9,10),(3,7),(4,10),(8,4),(3,8),(5,4),(3,6),(2,8),(6,10),(10,6),(7,6),(10,2),(7,4),(6,2),(3,9),(3,1)}) ok<br />toposort zet. 0 ok</span><br />
<br />
<span class="hps"><span style="font-family: "Courier New", Courier, monospace;">Already</span></span><b></b><i></i><u></u><sub></sub><sup></sup><strike></strike><span style="font-family: "Courier New", Courier, monospace;"> the two first edges builds a directed loop.</span><br />
<span style="font-family: Courier New;"><br /></span>
<span style="font-family: Courier New;">10 20 rand-acyclic-digraph zdup cr zet.<br />({1,2,3,4,5,6,7,8,9,10},{(4,7),(1,10),(3,8),(4,8),(5,6),(8,2),(3,7),(2,10),(4,10),(2,6),(1,2),(9,2),(3,4),(7,2),(1,3),(1,7),(4,6),(9,4),(3,5),(5,4)}) ok<br />toposort zet. (9,1,3,5,4,7,8,2,6,10) ok</span><br />
<span style="font-family: Courier New;"><br /></span></div>
<div>
<br /></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-56980912332615159132016-02-21T01:54:00.000-08:002016-02-24T00:19:32.607-08:00Relations<span style="font-family: "courier new" , "courier" , monospace;">A relation is a triplet (A,B,R) where A and B are sets and R⊆A×B. A function from A to B is a relation (A,B,f) where </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">(x1,y),(x2,y)∈f ⇒ x1=x2 and x∈A ⇒ ∃y∈B: (x,y)∈f.</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Some definitions:</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ remove brackets of object at top of stack</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: unfence zst> drop ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: domain \ (A,B,R) -- A<br /> unfence zdrop zdrop ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: codomain \ (A,B,R) -- B<br /> unfence zdrop znip ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: rel \ (A,B,R) -- R<br /> unfence znip znip ;</span></div>
<br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">The set of all elements in the codomain that is related to some element in the domain:</span><br />
<span style="font-family: "courier new";"></span></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ y∈image(R) ⇔ ∃x:(x,y)∈R</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: image \ R -- s<br /> { foreach ?do unfence zst> zst> drop loop } ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new";">The set of all elements in the domain that is related to some element in the codomain:</span></div>
<div>
<br /></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ x∈coimage(R) ⇔ ∃y:(x,y)∈R</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: coimage \ R -- s<br /> { foreach ?do unfence zst> drop zst> loop } ;</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new";">The image of a relation restricted to a subset s of the domain:</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: subimage \ R s -- s'<br /> zst yst setmove<br /> { foreach <br /> ?do unfence zst> zst> yst zst setcopy smember 0=<br /> if drop then<br /> loop } yst setdrop ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">The coimage of a relation restricted to a subset s of the codomain:</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: subcoimage \ R s -- s'<br /> zst yst setmove<br /> { foreach <br /> ?do unfence zst> zst> yst zst setcopy swap smember 0=<br /> if drop then<br /> loop } yst setdrop ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Test if a relation (A,B,R) is a function:</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: func? \ -- flag | (A,B,R) --<br /> unfence znip <br /> zst yst setmove true <br /> begin zst@ <br /> while zsplit zst> yst zst setcopy >zst zfence <br /> subimage cardinality 1 = 0=<br /> if 0= zdrop yst setdrop exit then<br /> repeat zdrop yst setdrop ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Evaluate f(x):</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">: eval \ x -- y | f --<br /> >zst zfence subimage unfence zst> ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Making a ordered pair or triplet of the top bundles:</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">: pair \ s1 s2 -- (s1,s2)<br /> zswap zst@ 2 - zswap zst@ 2 - + 1- >zst ;</span><br />
<br />
<span style="font-family: "courier new" , "courier" , monospace;">: triplet \ s1 s2 s3 -- (s1,s2,s3)<br /> zrot zst@ 2 - zrot zst@ 2 - zrot zst@ 2 - + + 1- >zst ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">The composition of two relations (A,B,R) and (B,C,S) is the relation (A,C,SR) defined by </span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">(a,c)∈SR ⇔ ∃b∈B:(a,b)∈R & (b,c)∈S.</span><br />
<br />
<span style="font-family: "courier new";"><span style="font-family: "courier new" , "courier" , monospace;">: composition \ (A,B,R) (B,C,S) -- (A,C,SR) <br /> 0 >xst \ empty set on xst-stack<br /> unfence zrot zdrop zrot unfence \ C S A B R <br /> zst yst setmove zdrop zswap \ C A S<br /> zst yst setmove \ R S in yst <br /> zswap zover zover cartprod \ A C A×C <br /> begin zst@ \ while elements in top set<br /> while zsplit infence<br /> yzcopy1 zover zsplit znip subcoimage<br /> zst xst setmove<br /> yzcopy2 zover zsplit zdrop unfence subimage <br /> xst zst setmove intersection zst@ zdrop <br /> if unfence unfence zst> unfence >zst -5 >zst zfence<br /> xst zst setmove zetmerge zst xst setmove<br /> else zdrop<br /> then <br /> repeat zdrop yst setdrop yst setdrop<br /> xst zst setmove triplet ;</span></span></div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-66490493577005976552016-02-19T08:48:00.001-08:002016-03-04T08:10:18.911-08:00Set algebra<span style="font-family: "courier new" , "courier" , monospace;">In bundles that represent sets all integers must be sorted, because the word <b>smember</b> stop searching for a single member when reaching an integer less than the integer to be tested. While <b>zetmerge</b> is faster than <b>union</b> it's safer to use <b>union</b>. </span><span style="font-family: "courier new";">Never the less, I have tried to replace <b>union</b> with <b>zetmerge</b> as much as possible, with considerable faster code. It <i>seems</i> to work.</span><br />
<div>
<span style="font-family: "courier new";"><br /></span></div>
<div>
<span style="font-family: "courier new";">: union \ -- | s s' -- sUs'<br /> zetmerge set-sort reduce ;</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: intersection \ -- | s s' -- sΛs'<br /> 0 >xst zst yst setmove<br /> begin zst@<br /> while zsplit zfence zdup zst> drop<br /> yst zst setcopy member<br /> if xst zst setmove zetmerge zst xst setmove<br /> else zdrop<br /> then <br /> repeat zdrop yst setdrop<br /> xst zst setmove reduce ; </span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: diff \ -- | s s' -- s\s'<br /> 0 >xst zst yst setmove <br /> begin zst@<br /> while zsplit zfence zdup zst> drop<br /> yst zst setcopy member<br /> if zdrop <br /> else xst zst setmove zetmerge zst xst setmove<br /> then<br /> repeat zdrop yst setdrop<br /> xst zst setmove reduce ;</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: multincl \ -- |{s1,...,sn} x -- {s1U{x},...,snU{x}}<br /> 0 >xst zfence zst yst setmove <br /> begin zst@ <br /> while zsplit yst zst setcopy union zfence <br /> xst zst setmove zetmerge zst xst setmove <br /> repeat zdrop yst setdrop xst zst setmove ;</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: powerset \ -- | s -- p(s) Set of all subsets<br /> zst@ 0= if -2 >zst exit then<br /> zsplit zfence zst yst setmove recurse<br /> zdup yst zst setmove zst> drop multincl<br /> zetmerge ;</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: cartprod \ -- | s s' -- s×s' Cartesian product<br /> zst yst setmove<br /> zst xst setcopy xst> drop cardinality 0 0 >zst<br /> ?do xfence -1 xst+! <br /> yst setdup<br /> begin yst@<br /> while ysplit yfence -1 yst+!<br /> xst zst setcopy<br /> yst zst setmove vmerge<br /> zfence<br /> zetmerge<br /> repeat yst> drop xst setdrop <br /> loop yst setdrop ;</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: infence \ -- |{x1,...,xn} -- {{x1},...,{xn}}<br /> 0 >xst foreach <br /> ?do zfence zfence<br /> xst zst setmove zetmerge<br /> zst xst setmove <br /> loop xst zst </span><span style="font-family: "courier new" , "courier" , monospace;">setmove ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="background-color: white; color: #222222; line-height: 18.48px;">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:</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<div class="separator" style="clear: both; text-align: center;">
<a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEirFqgUVLdzmXvN0ioMMtB9N5V9Qjc7tjCN8b5jTBW0drQTtH0sDeaJAfU7rQ_a0I4FWDf2_oEHxMIBpAk5BgomGRlHqHMzZJRBk-OioYPb7prXAWpCIa9IjCnGwtLiS8-LdED8KseGAavc/s1600/Sk%25C3%25A4rmklipp+2016-01-20+09.15.11.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" height="91" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEirFqgUVLdzmXvN0ioMMtB9N5V9Qjc7tjCN8b5jTBW0drQTtH0sDeaJAfU7rQ_a0I4FWDf2_oEHxMIBpAk5BgomGRlHqHMzZJRBk-OioYPb7prXAWpCIa9IjCnGwtLiS8-LdED8KseGAavc/s400/Sk%25C3%25A4rmklipp+2016-01-20+09.15.11.png" width="400" /></a></div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="background-color: white; color: #222222; line-height: 18.48px;">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 </span><span style="background-color: white; color: #222222; line-height: 18.48px;">S%x to be the set consisting of all sets X in S where x have been included. </span><span style="background-color: white; color: #222222; line-height: 18.48px;">Then</span><br style="background-color: white; color: #222222; font-family: Arial, Tahoma, Helvetica, FreeSans, sans-serif; line-height: 18.48px;" /><span style="background-color: white; color: #222222; line-height: 18.48px;"><br /></span><span style="background-color: white; color: #222222; font-family: "arial" , "tahoma" , "helvetica" , "freesans" , sans-serif; line-height: 18.48px;"></span><span style="background-color: white; color: #222222; line-height: 18.48px;">p(A,k)=p(A\{f(A)},k)+(p(</span><span style="background-color: white; color: #222222; line-height: 18.48px;">A\{f(A)},k-1)%f(A))</span><br style="background-color: white; color: #222222; font-family: Arial, Tahoma, Helvetica, FreeSans, sans-serif; line-height: 18.48px;" /><span style="background-color: white; color: #222222; line-height: 18.48px;"><br /></span><span style="background-color: white; color: #222222; font-family: "arial" , "tahoma" , "helvetica" , "freesans" , sans-serif; line-height: 18.48px;"></span><span style="background-color: white; color: #222222; line-height: 18.48px;">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.</span><br style="background-color: white; color: #222222; font-family: Arial, Tahoma, Helvetica, FreeSans, sans-serif; line-height: 18.48px;" /><span style="background-color: white; color: #222222; line-height: 18.48px;"><br /></span><span style="background-color: white; color: #222222; font-family: "arial" , "tahoma" , "helvetica" , "freesans" , sans-serif; line-height: 18.48px;"></span><span style="background-color: white; color: #222222; line-height: 18.48px;">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.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="background-color: white; color: #222222; line-height: 18.48px;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ Set of all subsets with k elements</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">\ p(A,k)=p(A\{f</span><span style="font-family: "courier new";">(A)},k)+(p(A\{f(A)},k-1)%f(A))<br />: power# \ k -- | s -- p(s,k)<br /> ?dup 0= if zdrop 0 >zst zfence exit then <br /> dup 1 = if drop infence exit then <br /> dup zdup cardinality = <br /> if drop zfence exit then <br /> dup 1 = if drop infence exit then <br /> zsplit zfence zst xst setmove <br /> dup zdup recurse <br /> zswap 1- recurse xst zst setmove <br /> zst> drop multincl <br /> zetmerge ; </span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Before trying to calculate p(A,k) it's a good idea to count the number of elements: </span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">|p(A,k)|=choose(|A|,k).</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">\ http://rosettacode.org/wiki/Evaluate_binomial_coefficients#Forth<br />: choose \ n k -- nCk <br /> 1 swap 0 ?do over i - i 1+ */ loop nip ;</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: multiunion \ -- |{s1,...,sn} -- s1U...Usn<br /> foreach 0 >zst<br /> ?do zetmerge<br /> loop set-sort reduce ;</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: zetcup \ -- |{s1,...,sn} s -- {s1Us,...,snUs}</span></div>
<div>
<span style="font-family: "courier new";"> zst xst setmove 0 >yst foreach<br /> ?do xst zst setcopy union zfence<br /> yst zst setmove zetmerge zst yst setmove<br /> loop xst setdrop yst zst setmove ;</span></div>
<div>
<span style="font-family: "courier new";"><br />: zetcap \ -- |{s1,...,sn} s' -- {s1Λs',...,snΛs'}</span></div>
<div>
<span style="font-family: "courier new";"> zst xst setmove 0 >yst foreach<br /> ?do xst zst setcopy intersection zfence<br /> yst zst setmove zetmerge zst yst setmove<br /> loop xst setdrop yst zst setmove ;</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: zetunion \ -- |{ s1,...,sn} {t1,...,tm} -- {siUtj}ij<br /> 0 >xst zst yst setmove foreach<br /> ?do yst zst setcopy<br /> zswap zetcup<br /> xst zst setmove union<br /> zst xst setmove<br /> loop yst setdrop xst zst setmove ; </span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">The set of <b>functions</b>:</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">: functions \ -- | s s' -- fun(s,s')</span></div>
<div>
<span style="font-family: "courier new";"> secobjad @ 0= if zdrop -2 >zst exit then<br /> secobjad @ -2 = if cartprod infence exit then<br /> zswap zsplit zfence zst xst setmove<br /> zover recurse zswap xst zst setmove<br /> zswap cartprod infence zetunion ;</span></div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">utime { 1 2 3 } zdup functions 3 power# cardinality cr . utime d- d.<br />2925 -628052 ok</span><br />
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">ZET creates and count this set with 2925 elements in 0.63 seconds.</span></div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">
utime { 1 100000 | prime } utime cr d- d. cardinality . <br />
-6652182 9592 ok<br /><span style="font-family: "courier new" , "courier" , monospace;"></span></span><span style="font-family: "courier new" , "courier" , monospace;">utime { 1 10 | all } powerset utime cardinality cr . d- d.<br />512 -24502 ok<br />utime { 1 11 | all } powerset utime cardinality cr . d- d.<br />1024 -83816 ok<br />utime { 1 12 | all } powerset utime cardinality cr . d- d.<br />2048 -251767 ok<br />utime { 1 13 | all } powerset utime cardinality cr . d- d.<br />4096 -986219 ok<br />utime { 1 14 | all } powerset utime cardinality cr . d- d.<br />8192 -3944057 ok</span><br />
<div>
<br /></div>
<div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 2 3 } zdup functions cr zet.</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{{(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</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-56394560602031489122016-02-12T14:05:00.000-08:002016-03-04T08:09:45.877-08:00Nested sets<span style="font-family: "courier new" , "courier" , monospace;">[Some errors are corrected and some other changes is done]</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">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.</span><br />
<span style="font-family: "courier new";"><br /></span> <span style="font-family: "courier new";">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.</span><br />
<span style="font-family: "courier new";"><br /></span> <span style="font-family: "courier new";">{ 0 1 2 3 ( 4 5 6 6 ) { 7 { 8 8 } } 9 0 } cr showz cr zet.<br />1 2 3 4 5 6 6 -9 7 8 -2 -6 9 0 -28<br />{1,2,3,(4,5,6,6),{7,{8}},9,0} ok</span><br />
<span style="font-family: "courier new";"><br /></span> <span style="font-family: "courier new";">Negative integers indicate a bundle count, <i>even</i> for sets and <i>odd</i> for vectors. If the absolute value of these numbers are divided by 2 the number of integers in the bundle is obtained.</span><br />
<h3>
Stacks</h3>
<span style="font-family: "courier new";">Implementation of the three stacks:</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: cs negate 2/ ;<br />: listflag 1 and ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: objsize \ bc -- n <br /> dup 0< if cs 1+ else drop 1 then ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">cell negate constant -cell</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: >stack ( n ad -- ) cell over +! @ ! ;<br />: stack> ( ad -- n ) dup @ @ -cell rot +! ;<br />: >stack> ( n ad -- m ) dup @ @ -rot @ ! ;<br />: stack@ ( ad -- n ) @ @ ;<br />: stack! ( n ad -- ) @ ! ;<br />: stack+! ( n ad -- ) @ +! ;</span><br />
<span style="font-family: "courier new";"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">cell 1- log~ constant cellshift</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: stack-depth ( ad -- n ) dup @ swap - cellshift rshift ;<br />: stack-cl ( ad -- ) dup ! ;<br />: stack-empty ( ad -- flag ) dup @ = ;</span></span><br />
<span style="font-family: "courier new";"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span></span>
<span style="font-family: "courier new" , "courier" , monospace;">1 16 lshift cells allocate throw dup constant xst dup ! </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: >xst ( n -- ) xst >stack ;<br />: xst> ( -- n ) xst stack> ;<br />: >xst> ( n -- m ) xst >stack> ;<br />: xst@ ( -- n ) xst @ @ ;<br />: xst! ( n -- ) xst @ ! ;<br />: xst+! ( n -- ) xst @ +! ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: >>xst ( xn ... x1 bc -- ) >r r@ cs 0 ?do >xst loop r> >xst ;<br />: xst>> ( -- x1 ... xn bc ) xst@ >r xst> cs 0 ?do xst> loop r> ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">1 20 lshift cells allocate throw dup constant yst dup ! </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: >yst ( n -- ) yst >stack ;<br />: yst> ( -- n ) yst stack> ;<br />: >yst> ( n -- m ) yst >stack> ;<br />: yst@ ( -- n ) yst @ @ ;<br />: yst! ( n -- ) yst @ ! ;<br />: yst+! ( n -- ) yst @ +! ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: >>yst ( xn ... x1 bc -- ) >r r@ cs 0 ?do >yst loop r> >yst ;<br />: yst>> ( -- x1 ... xn bc ) yst@ >r yst> cs 0 ?do yst> loop r> ; </span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">1 21 lshift cells allocate throw dup constant zst dup ! </span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: >zst ( n -- ) zst >stack ;<br />: zst> ( -- n ) zst stack> ;<br />: >zst> ( n -- m ) zst >stack> ;<br />: zst@ ( -- n ) zst @ @ ;<br />: zst! ( n -- ) zst @ ! ;<br />: zst+! ( n -- ) zst @ +! ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: >>zst ( xn ... x1 bc -- ) >r r@ cs 0 ?do >zst loop r> >zst ;<br />: zst>> ( -- x1 ... xn -n ) zst@ >r zst> cs 0 ?do zst> loop r> ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: showx xst stack-depth if xst> >r recurse r> dup . >xst then ;<br />: showy yst stack-depth if yst> >r recurse r> dup . >yst then ;<br />: showz zst stack-depth if zst> >r recurse r> dup . >zst then ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: >zet ( s -- | -- s)</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> >>yst yst> dup >r cs 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ?do yst> >zst loop r> >zst ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new" , "courier" , monospace;"><br />: zet> ( -- s | s -- )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zst> dup >r cs 0</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> ?do zst> >xst loop r> >xst xst>> ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">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.</span><br />
<span style="font-family: "courier new";"><br /></span>
<br />
<div>
<span style="font-family: "courier new";">All words beginning with <b>set</b> is called with one or two stack addresses.</span></div>
<div>
<span style="font-family: "courier new";"><br /></span></div>
<span style="font-family: "courier new";">
</span><span style="font-family: "courier new" , "courier" , monospace;">: setdrop \ ad -- <br /> dup @ @ cs cells cell+ negate swap +! ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: setdup \ ad -- <br /> >r<br /> r@ @ @ cs cells \ n'<br /> r@ @ over - \ n' ad1<br /> r@ @ cell+ \ n' ad1 ad2<br /> rot cell+ dup r> +! cmove ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: setover \ ad --<br /> dup >r @ @ cs cells cell+ \ nr of bytes 1'st set <br /> r@ @ swap - \ ad to 2'nd set<br /> dup @ cs cells cell+ dup >r - \ ad to 3'rd set<br /> cell+ r> r@ @ cell+ \ ad to move to<br /> swap dup r> +! cmove ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: setcopy loc{ ad1 ad2 -- }<br /> ad1 @ @ cs cells \ n'<br /> ad1 @ over - swap cell+ \ ad1-n' n<br /> ad2 @ cell+ over ad2 +! swap cmove ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: setmove \ ad1 ad2 --<br /> swap dup rot setcopy setdrop ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">The three words below gets the addresses and the counts for the first, second and third sets on the zst-stack.</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: adn1 zst@ cs cells zst @ over - swap cell+ ;<br />: adn2 adn1 drop cell- dup @ cs cells tuck - swap cell+ ;<br />: adn3 adn2 drop cell- dup @ cs cells tuck - swap cell+ ;</span><br />
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">All words beginning with <b>z</b> acts on the zst-stack, and the words below manipulates sets.</span></div>
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">
</span><br />
<div>
<span style="font-family: "courier new";">: zdup zst setdup ;</span><br />
<span style="font-family: "courier new";">: zdrop zst setdrop ;</span><br />
<span style="font-family: "courier new";">: zover adn2 tuck zst @ cell+ swap cmove zst +! ;</span><br />
<span style="font-family: "courier new";">: zswap zover adn2 adn3 rot + move zdrop ;</span><br />
<span style="font-family: "courier new";">: znip zswap zdrop ;</span><br />
<span style="font-family: "courier new";">: ztuck zswap zover ;</span><br />
<span style="font-family: "courier new";">: zrot zst>> zswap >>zst zswap ; <b></b><i></i><u></u><sub></sub><sup></sup><strike></strike></span></div>
<span style="font-family: "courier new";">
</span><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<h3>
Output of sets</h3>
<span style="font-family: "courier new" , "courier" , monospace;">The output is built up backwards in a buffer which is printed out.</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">0 value addr1</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: addr1- \ -- <br /> addr1 1- to addr1 ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: fillad$ \ addr n -- <br /> dup 1- negate addr1 + dup to addr1 swap move addr1- ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: n>addr1 \ n -- <br /> 0 <# #s #> fillad$ ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: a>addr1 \ c -- <br /> addr1 c! addr1- ;</span><br />
<span style="font-family: "courier new";"></span><br />
<div>
<span style="font-family: "courier new";"><br /></span></div>
<span style="font-family: "courier new";">
</span>
<br />
<div>
<span style="font-family: "courier new";">Defining the <b>cardinality</b> here for the definition of <b>foreach</b> that removes the fences around the top set on the zst-stack and prepare for a do-loop.</span></div>
<span style="font-family: "courier new";">
</span>
<br />
<div>
<span style="font-family: "courier new";"><br /></span></div>
<span style="font-family: "courier new";">
</span><span style="font-family: "courier new" , "courier" , monospace;">: cardinality \ -- n | s --<br /> zst> cs dup >xst 0<br /> ?do zst@ 0<<br /> if zst@ dup cs negate xst+! >r zdrop r> cs 1+<br /> else zst> drop 1<br /> then<br /> +loop xst> ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: foreach \ -- n 0 | s -- z1...zn<br /> zdup cardinality zst> drop 0 ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: closep \ -- bc asc<br /> zst@ dup listflag if [char] ) else [char] } then ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: openp \ bc -- asc<br /> listflag if [char] ( else [char] { then ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: list$ \ n1...nk -k ad -- ad n <br /> dup to addr1 false loc{ addr2 flag }<br /> closep a>addr1<br /> foreach <br /> do flag if [char] , a>addr1 then zst@ 0<<br /> if addr1 recurse 2drop<br /> else zst> n>addr1<br /> then flag 0= if true to flag then<br /> loop openp a>addr1<br /> addr1 1+ addr2 over - 1+ ; </span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">\ Corrected code:</span>
<br />
<span style="font-family: "courier new" , "courier" , monospace;">1 20 lshift dup allocate throw swap cell - + constant printbuf</span><br />
<span style="font-family: "courier new";"><br /></span>
<br />
<div>
<span style="font-family: "courier new";"></span></div>
<span style="font-family: "courier new";">
</span><span style="font-family: "courier new" , "courier" , monospace;">: zet. \ -- | s -- prints top set on zst stack<br /> zst@ 0=<br /> if zst> .<br /> else printbuf list$ type<br /> then ; </span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: set. \ ad -- prints top set on xst or yst stack<br /> zst setcopy zet. ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<br />
<h3>
Analyzing sets </h3>
<span style="font-family: "courier new";">The next word analyse a bundle cell: 0 integer, 1 vector, 2 set.</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: ?obj \ x -- 0,1,2<br /> dup 0<<br /> if listflag<br /> if 1 else 2 then<br /> else drop 0<br /> then ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">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.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: _split \ ad -- ad=yst,zst <br /> dup >r @ cell- @ 0< 0=<br /> if r@ stack> 2 + r@ stack> swap r@ >stack r> >stack exit then<br /> r@ stack><br /> r@ xst setmove<br /> xst@ cs 1+ 2* + r@ >stack<br /> xst r> setmove ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: ysplit \ -- | s -- s' x in yst stack<br /> yst _split ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: zsplit \ -- | s -- s' x<br /> zst _split ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<br />
<h3>
Set equal, subset and membership</h3>
<span style="font-family: "courier new";">The word <b>zet=</b> is defined by <b>subset</b>, <b>member</b> is defined by <b>zet=</b> and <b>subset</b> is defined by <b>member</b>, by recursion. Next word examines if the integer n is a member of the set s.</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">A change is made in this section. All sets of integers are sorted and smember use that for faster exit when 'not member'.</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">: zetmerge \ -- | s s' -- s" <br /> zst yst setmove<br /> yst@ zst> + <br /> yst zst setmove<br /> zst! ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">: vmerge \ -- | v v'-- v" <br /> zst yst setmove<br /> yst@ zst> + 1+<br /> yst zst setmove<br /> zst! ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">: _fence \ ad -- | x -- {x} <br /> dup >r stack@ ?obj <br /> case 0 of -2 r@ >stack endof <br /> 1 of r@ stack@ 1- r@ >stack endof<br /> 2 of r@ stack@ 2 - r@ >stack endof<br /> endcase rdrop ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">: xfence xst _fence ;<br />: yfence yst _fence ;<br />: zfence zst _fence ;<br /> <br />: set-sort \ -- | s -- n1...nk -2k<br /> 0 loc{ counter } 0 >xst 0 >yst<br /> foreach<br /> ?do zst@ ?obj<br /> case 0 of counter 1+ to counter zst> endof<br /> 1 of zfence xst zst setmove zetmerge zst xst setmove endof<br /> 2 of zfence yst zst setmove zetmerge zst yst setmove endof<br /> endcase<br /> loop counter sort 2* negate >zet </span><br />
<span style="font-family: "courier new";"> xst zst setmove zetmerge<br /> yst zst setmove zetmerge ;</span><br />
<span style="font-family: "courier new";"> <br />: smember \ n -- flag | s -- <br /> zst@ cs false loc{ m flag } <br /> foreach <br /> ?do zst@ 0< <br /> if m zst@ cs 1+ - to m zdrop <br /> else m 1- to m dup zst> 2dup ><br /> if false to flag 2drop <br /> m cells negate zst +! leave <br /> then = <br /> if true to flag <br /> m cells negate zst +! leave <br /> then <br /> then <br /> loop drop flag ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Equality for vectors:</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: vect= \ s -- flag | s' --</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">\ non empty list not including non empty sets<br /> dup zst@ = 0=<br /> if zdrop cs 0 ?do drop loop false exit<br /> then true loc{ flag } zst> drop cs 0<br /> ?do flag<br /> if zst> = 0= if false to flag then<br /> else zst> 2drop <br /> then<br /> loop flag ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: vector= \ -- flag | s s' --<br /> zet> vect= ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Examines if the vector s is a member in the set s':</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: vmember \ -- flag | s s' --<br /> zswap zst yst setmove<br /> zst@ cs false loc{ m flag }<br /> foreach<br /> ?do zst@ ?obj <br /> case 0 of m 1 - to m zst> drop endof<br /> 1 of m zst@ cs 1+ - to m <br /> yst zst setcopy vector=<br /> if true to flag<br /> m cells negate zst +! leave<br /> then endof<br /> 2 of m zst@ cs 1+ - to m <br /> zst@ cs 1+ cells negate zst +! endof<br /> endcase<br /> loop yst setdrop flag ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Get the count/integer of the second object of the zst-stack:</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: secobjad \ -- ad | x y -- x y<br /> zst @ zst@ 0< if zst@ cs 1+ cells - else cell - then ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">Move the second object of zst-stack to datastack:</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: routout \ -- x | x s -- s<br /> secobjad du</span><span style="font-family: "courier new" , "courier" , monospace;">p @ swap dup cell+ swap zst@ cs 1+ cells move</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> zst> drop ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">0 value 'subset <br />: subset \ -- flag | s s' --<br /> 'subset execute ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: zet= \ -- flag | s s' --<br /> zover zover subset<br /> if zswap subset<br /> else zdrop zdrop false<br /> then ; </span><br />
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">Examines if s is a set-member:</span></div>
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">
</span><span style="font-family: "courier new" , "courier" , monospace;">: zet-member \ -- flag | s s' -- <br /> zswap zst yst setmove<br /> begin zst@ \ set not empty?<br /> while zsplit zst@ ?obj 2 = \ element is a set?<br /> if yst zst setcopy zet= <br /> if yst setdrop zdrop true exit then<br /> else zst@ ?obj if zdrop else zst> drop then<br /> then <br /> repeat yst setdrop zdrop false ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: member \ -- flag | x s --<br /> secobjad @ ?obj<br /> case 0 of routout smember endof<br /> 1 of vmember endof<br /> 2 of zet-member endof<br /> endcase ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">:noname \ -- flag | s s' -- \ the subset code<br /> zst @ cell - 2@ or 0=<br /> if zdrop zdrop true exit then \ true if both sets are empty<br /> zswap zst yst setmove<br /> begin yst@ \ set is not empty?<br /> while ysplit yst@ ?obj<br /> if yst zst setmove zover member<br /> else yst> zdup smember <br /> then 0= if yst setdrop zdrop false exit then<br /> repeat yst> drop zdrop true ; to 'subset</span><br />
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">Merge two sets on zst-stack:</span></div>
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">
</span><span style="font-family: "courier new" , "courier" , monospace;">: zetmerge \ -- | s s' -- s"<br /> zst yst setmove<br /> yst@ zst> + <br /> yst zst setmove<br /> zst! ;</span><br />
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">Merge two vectors on zst-stack:</span></div>
<div>
<span style="font-family: "courier new";"><br /></span></div>
<span style="font-family: "courier new";">
</span><span style="font-family: "courier new" , "courier" , monospace;">: vmerge \ -- | v v'-- v" <br /> zst yst setmove<br /> yst@ zst> + 1+<br /> yst zst setmove<br /> zst! ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: _fence \ ad -- | x -- {x} <br /> dup >r stack@ ?obj <br /> case 0 of -2 r@ >stack endof <br /> 1 of r@ stack@ 1- r@ >stack endof<br /> 2 of r@ stack@ 2 - r@ >stack endof<br /> endcase rdrop ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: xfence xst _fence ;<br />: yfence yst _fence ;<br />: zfence zst _fence ;</span><br />
<div>
<br /></div>
<div>
<span style="font-family: "courier new";">The important word that reduce multiple members in a set at top of zst-stack:</span></div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">
</span><span style="font-family: "courier new" , "courier" , monospace;">: reduce \ -- | s -- s' <br /> 0 >yst foreach<br /> ?do zfence zdup zst> drop<br /> yst zst setcopy member<br /> if zdrop<br /> else yst zst setmove<br /> zetmerge zst yst setmove<br /> then<br /> loop yst zst setmove ;</span><br />
<span style="font-family: "courier new";"><br /></span>
<br />
<h3>
Input of sets</h3>
<span style="font-family: "courier new" , "courier" , monospace;">0 create match ,</span><br />
<span style="font-family: "courier new";">true value sort?</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: { \ --<br /> 1 match +! depth >xst true to sort? ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">\ Integer sorting is included</span>
<br />
<span style="font-family: "courier new" , "courier" , monospace;">: } \ x1...xk -- <br /> depth xst> - 2* negate<br /> -1 match +! >zet sort?</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if set-sort then reduce match @</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> if zet> then true to sort? ; </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new";"></span>
<span style="font-family: "courier new";">Next word resets everything and should be automatic on error somehow.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: q xst stack-cl yst stack-cl zst stack-cl 0 match ! abort ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: ( { ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">: ) \ x1...xk --<br /> depth xst> - 2* 1+ negate<br /> -1 match +! >zet match @ if zet> then ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<h3>
Integer conditions</h3>
<br />
<span style="font-family: "courier new" , "courier" , monospace;">\ n -- flag<br />
<span style="font-family: "courier new" , "courier" , monospace;">: pairprime dup prime over 2 + prime rot 2 - prime or and ; </span><br />
: odd 1 and ; \ n -- flag<br />: 1mod4 4 mod 1 = ; \ n -- flag<br />: 3mod4 4 mod 3 = ; \ n -- flag<br />: sqr dup sqrtf dup * = ;<br />: all dup = ;<br />: sqrfree dup radical = ; \ square free test<br />: semiprime bigomega 2 = ; \ number is product of two primes?<br />: uniprime smallomega 1 = ; \ number is power of single prime?<br />: biprime smallomega 2 = ; \ number has two different pfactors?<br />
</span><br />
<span style="font-family: "courier new" , "courier" , monospace;">: 2sqrsum dup 0 \ number sum of two squares?<br /> ?do dup i dup * - dup<br /> 0< if drop false leave then <br /> sqr if true leave then<br /> </span><span style="font-family: "courier new" , "courier" , monospace;">loop nip ;</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br />: | \ m n -- x1...xk <br /> swap ' loc{ xt }<br /> ?do i xt execute if i then</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"> loop false to sort? ;</span><br />
<div>
<b></b><i></i><u></u><sub></sub><sup></sup><strike><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></strike></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 10000 20000 | pairprime } cardinality . 274 ok<br />53 >zst { 1 100 | prime } member . -1 ok</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 100 200 | pairprime } { 100 200 | prime } subset . -1 ok</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1000 2000 | sqrfree } cardinality . 607 ok<br />{ 2000 3000 | sqrfree } cardinality . 609 ok<br />{ 3000 4000 | sqrfree } cardinality . 609 ok<br />{ 8000 9000 | sqrfree } cardinality . 608 ok</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">( 1 1 ) { { 0 } ( 1 1 ) } member . -1 ok</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 100 | prime } cr </span><span style="font-family: "courier new" , "courier" , monospace;">zet.</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{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</span></div>
<div>
<span style="font-family: "times new roman";"><span style="font-family: "courier new" , "courier" , monospace;">{ 1 100 | uniprime } { 1 100 | semiprime } union cr zet.<br />{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</span></span></div>
<div>
<span style="font-family: "times new roman";"><br /></span></div>
<br />Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com1tag:blogger.com,1999:blog-5309775736131296725.post-24462204638810341782016-01-31T00:33:00.000-08:002016-02-13T04:03:53.884-08:00Topology<span style="font-family: "courier new" , "courier" , monospace;">[Attention, this code is not included in the code site!]</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The blog has become a little messy and I will try to clean it up. These simple implementations of sets and groups are limited but interesting. I believe in the idea of bundles on a stack, but the data stack is not perfect for the purpose: for the sake of portability the data stack can only be manipulated with a restricted number of words. With a special stack for bundles, stack manipulations can be made much more efficient. </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">While going on with the current implementation for a while, I will try to find out a faster implementation. With better algorithms: until now I have used sloppy straight forward brutal force algorithms or worse! Also the implementation of permutations and groups must be enhanced.</span></span><span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
</span><br />
<h3>
<span style="font-family: "courier new" , "courier" , monospace;">
Topological spaces</span></h3>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">Topology is very easy to understand in spite of it's often formalistic presentation for the students. </span><span style="font-family: "courier new" , "courier" , monospace;">In set theory the question is: does an element belong to the set or not. </span><span style="font-family: "courier new" , "courier" , monospace;">In topology the question is if the element is close to the set or not. </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">That's what a topological structure λ on a set X submit, the possibility to decide whether a point x in X belongs to the closure of a subset A of X or not. </span><span style="font-family: "courier new" , "courier" , monospace;">The set λ of open subsets of X brings the method: the point x is in the closure of A if and only if every open set O in λ that contain x, also contain a point in A.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Two subsets of X are obligatory in λ and that's ø and X. Beyond that there are two rules for λ to be a topology on X. (1) Given a subset B of λ, then the union of all sets in B should belong to λ. (2) given two sets O,Ô in λ, then the intersection of O and Ô should belong to λ.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
</span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><u>Examples</u>: </span></div>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span><br /></span>
<br />
<ul>
<li><span style="font-family: "courier new" , "courier" , monospace;">The topology of the real numbers (a topology which is a necessary part of the definition of the set of real numbers) consists of all unions of limited open intervalls, that is, open intervalls of the type {x|a<x<b} for real numbers a,b. Any union of such intervalls belongs to this topology. The point 1 belongs to the closure of {x|0<x<1}, without actually being a member of that set, because every open set that contains 1 also contains a point in {x|0<x<1}.</span></li>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span>
</span>
<li><span style="font-family: "courier new" , "courier" , monospace;">The set {ø,X} is a topology on X called the trivial topology and the set of all subsets of X is a topology called the discrete topology.</span></li>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span>
</span>
<li><span style="font-family: "courier new" , "courier" , monospace;">Any infinite set X has an obvious topology consisting of all complements of finite subsets of X plus the empty set.</span></li>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"></span>
</span>
<li><span style="font-family: "courier new" , "courier" , monospace;">Any set of subsets of a set X generates a minimal topology on X which contain those subsets.</span></li>
</ul>
<span style="font-family: "courier new" , "courier" , monospace;">A subset C of X is said to be closed if X\C is open, that is belong to λ. The closure of a subset A of X is the smallest closed set C such that A is a subset of C. The most interesting infinite topological spaces are the Hausdorff spaces, where all singleton sets {x} are closed. But for finite topological spaces all Hausdorff spaces are discrete. Finite spaces are determined by the closure function of all the singleton sets, because with that function it's possible to decide which points that are close to which sets.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">In stack diagram for <b>setcup</b> s is a set of sets and s' is a set of points. And s" is the set of the unions of all elements of s ans s':</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ { 1 2 } { 2 3 4 } } { 3 4 5 } setcup cr set.<br />{{1,2,3,4,5},{2,3,4,5}} ok</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: setcup ( s s' -- s")<br /> >>xst 0 >yst foreach<br /> ?do nxst@ union fence yst>> union >>yst<br /> loop nxstdrop yst>> ;</b></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">Similar for the word:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: setcap ( s s' -- s")<br /> >>xst 0 >yst foreach<br /> ?do nxst@ intersection fence yst>> union >>yst<br /> loop nxstdrop yst>> ;</b></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">The word <b>capgen</b> generates all intersections:</span></div>
<span style="font-family: "courier new" , "courier" , monospace;"><b><br /></b></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";">
<b>: capgen ( s -- s')<br /> ndup >>yst ndup >>xst foreach<br /> ?do nyst@ nswap setcap xst>> union >>xst<br /> loop nystdrop xst>> ;</b></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;">The word <b>cupgen</b> generates the set of all unions os s. When first apply capgen and then cupgen all </span><span style="font-family: "courier new" , "courier" , monospace;">the non trivial open sets in the smallest topology that includes s are generated. And the word topology completes with ø and X, which might or might not be generated by <b>capgen</b> and <b>cupgen</b>. </span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><b></b></span><span style="font-family: "courier new";"><i></i><b></b><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: cupgen ( s -- s' )<br /> ndup >>yst ndup >>xst foreach<br /> ?do nyst@ nswap setcup xst>> union >>xst<br /> loop nystdrop xst>> ;</b></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><b></b><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new";"><b></b></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ { 1 2 } { 2 3 4 } { 3 4 5 } } capgen ndup cr set.<br />{{2},0,{3,4},{1,2},{2,3,4},{3,4,5}} ok<br />cupgen ndup cr set.<br />{{1,2,3,4},{1,2,3,4,5},{2,3,4,5},{2},0,{3,4},{1,2},{2,3,4},{3,4,5}} ok<br />{ 1 2 3 4 5 } { { 1 2 } { 2 3 4 } { 3 4 5 } } topology cr set.<br />{{1,2,3,4},{2,3,4,5},{2},{3,4},{1,2},{2,3,4},{3,4,5},{1,2,3,4,5},0} ok</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><b></b></span><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: topology \ X s -- λ <br /> nover nswap capgen<br /> cupgen nswap incl 0 incl ;</b></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><b><br /></b></span></span>
<br />
<div class="separator" style="clear: both; text-align: center;">
<a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEi2zfL2QpELEsLzs-hjkLh0AKIxjyfxTIh2cNuM7ARO17S1-V8beewstTM9n_2Y0hDTEvVbkA37HzZdCrOsAoicJCIyKhqGX3mlMY5GaOdD7vJD4TYYJbq-AySJ5pjIFaQILULAfod9ol5_/s1600/Venn.jpg" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" height="282" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEi2zfL2QpELEsLzs-hjkLh0AKIxjyfxTIh2cNuM7ARO17S1-V8beewstTM9n_2Y0hDTEvVbkA37HzZdCrOsAoicJCIyKhqGX3mlMY5GaOdD7vJD4TYYJbq-AySJ5pjIFaQILULAfod9ol5_/s400/Venn.jpg" width="400" /></a></div>
<span style="font-family: "courier new" , "courier" , monospace;">In the figure the rectangle correspond to X and the colored shapes to the set of sets generating a topology. The colored surfaces are the primitive intersections, and the topology is the set of all combinations of unions of those intersections.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"></span><span style="font-family: "courier new";"></span>
<span style="font-family: "courier new" , "courier" , monospace;">The next word computes the closure to the singleton {x}.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: singlecl \ λ x -- s <br /> 0 false loc{ x y flag } >>yst 0 >xst <br /> nyst@ nunion foreach<br /> ?do to y true to flag nyst@ foreach<br /> ?do ndup y member<br /> if x member 0=<br /> if false to flag then<br /> else ndrop <br /> then<br /> loop flag if xst>> y incl >>xst then<br /> loop nystdrop xst>> ;</b></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">And the λ-closure for any set:</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: closure ( λ s -- s')<br /> nswap >>xst 0 >yst foreach<br /> ?do >r nxst@ r> singlecl yst>> union >>yst<br /> loop nxstdrop yst>> ;</b></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 2 3 4 5 } { { 1 2 } { 2 3 4 } { 3 4 5 } } topology ok<br />{ 1 3 5 } closure cr set.<br />{1,4,3,5} ok</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">So except for the members 1,3,5 also 4 is close to {1,3,5}.<br />The word <b>opsubs</b> computes all open sets that are subsets of s.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: opsubs ( λ s -- s' )<br /> >>yst 0 >xst foreach<br /> ?do ndup nyst@ subset<br /> if fence xst>> union >>xst<br /> else ndrop<br /> then<br /> loop nystdrop xst>> ;</b></span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The interior of a set s is the set of all points which are members of an open set that is a subset of s. That is, s' is the union of all open subsets of s.</span></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: interior ( λ s --- s')<br /> opsubs nunion ;</b></span></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 1 2 3 4 5 } { { 1 2 } { 2 3 4 } { 3 4 5 } } topology ndup ok<br />{ 1 3 5 } interior cr set.<br />0 ok<br />{ 2 3 } interior cr set.<br />{2} ok</span></div>
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new";">
</span>Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com2tag:blogger.com,1999:blog-5309775736131296725.post-28213708421336601572016-01-26T12:45:00.003-08:002016-03-14T10:42:29.278-07:00A conjecture about groups<span style="font-family: "courier new" , "courier" , monospace;">[Attention, this code is not included in the code site!]</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">First I want to make a reform, since I want the {}-brackets for sets:</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: loc{ [compile] { ; immediate</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">I have changed this all over.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<div style="font-family: 'courier new', courier, monospace;">
<b>: { depth >xst ; </b></div>
<div style="font-family: 'courier new', courier, monospace;">
<b>: } depth xst> - negate >set ;</b></div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<div class="separator" style="clear: both; text-align: center;">
<a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEjLOfZcxMBScvvmOizfZyKo1o2JeCBuYSD3pXWHxNlMI7hG8vww6Ve7yVUxuVI_HNt_BWUaSa6CQJI3ENdnADEMi_f96sc8HxinXk9FaMX0W828YzU0al3xptWpho2BbppCjvKiV_uP48JB/s1600/Sk%25C3%25A4rmklipp+2016-01-26+20.52.50.png" imageanchor="1" style="clear: left; float: left; margin-bottom: 1em; margin-right: 1em;"><span style="font-family: "courier new" , "courier" , monospace;"><img border="0" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEjLOfZcxMBScvvmOizfZyKo1o2JeCBuYSD3pXWHxNlMI7hG8vww6Ve7yVUxuVI_HNt_BWUaSa6CQJI3ENdnADEMi_f96sc8HxinXk9FaMX0W828YzU0al3xptWpho2BbppCjvKiV_uP48JB/s1600/Sk%25C3%25A4rmklipp+2016-01-26+20.52.50.png" /></span></a></div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><a href="http://math.stackexchange.com/questions/1628000/group-conjecture/1629294#1629294" target="_blank">See Mathematics Stack Exchange</a></span><br />
<span style="font-family: Courier New;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">The composition of sets of permutations is performed by the word </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>pset*</b> ( s1 s2 -- s3 )</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b>: go xst clst ndup >>xst ;</b></span><br />
<div>
<b><span style="font-family: "courier new" , "courier" , monospace;"></span></b><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: gen. ( s -- s') ndup set. nxst@ pset* ;</b></span></div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>
</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">The word <b>gen.</b> multiply the top set on the data stack with the set on the xst stack and leave the result on the data stack without changing the xst stack. </span><span style="font-family: "courier new" , "courier" , monospace;">Now the conjecture can be tested.</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 2143 1234 } { 3412 2143 4321 1234 } pnormal . -1 ok</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">So the smaller set is a normal subgroup of the bigger set, and therefore the quotient is a group:</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
</span><div>
<span style="font-family: "courier new" , "courier" , monospace;">{ 3412 2143 4321 1234 } { 2143 1234 } ok</span></div>
<span style="font-family: "courier new" , "courier" , monospace;">
<div>
pquotient set. {{3412,4321},{2143,1234}} ok</div>
<div>
<br /></div>
<div>
This set is a group under <b>pset*</b> and is generated by {3412,4321}:</div>
<div>
<br /></div>
<div>
<div>
{ 4321 3412 } go ok</div>
<div>
gen. {4321,3412} ok</div>
<div>
gen. {2143,1234} ok</div>
<div>
gen. {4321,3412} ok</div>
</div>
<div>
ndrop ok</div>
</span><span style="font-family: "courier new" , "courier" , monospace;"><div>
<br /></div>
<div>
As always with the set elements in quotient groups they have the same number of elements.</div>
<div>
<br /></div>
<div>
Now take a random set of 4-permutations:</div>
<div>
<br /></div>
<div>
<div>
{ 2431 2341 } go ok</div>
<div>
gen. {2431,2341} ok</div>
<div>
gen. {4132,3142,4312,3412} ok</div>
<div>
gen. {1234,1243,3214,4213,1324,1423,3124,4123} ok</div>
<div>
gen. {2413,2314,3421,4321,1423,1324,2341,2431,2143,2134,3241,4231, 1243,1234} ok</div>
<div>
gen. {4123,3124,4321,3421,2143,2134,4132,3142,4213,3214,4231,3241, 3412,4312,1432,1342,2413,2314,2431,2341} ok</div>
<div>
gen. {4231,3241,1234,1243,3214,4213,1432,1342,1324,1423,2134,2143, 2314,2413,4123,3124,4321,3421,4132,3142,4312,3412} ok</div>
<div>
gen. {3412,4312,2314,2413,2341,2431,2143,2134,4321,3421,3241,4231, 1342,1432,3142,4132,1234,1243,3214,4213,1324,1423,3124,4123} ok</div>
<div>
gen. {4123,3124,3142,4132,3412,4312,1432,1342,3214,4213,2413,2314, 3421,4321,1423,1324,2341,2431,2143,2134,3241,4231,1243,1234} ok</div>
<div>
ndrop ok</div>
</div>
<div>
<br /></div>
<div>
In this case the series </div>
<div>
<br /></div>
<div>
A, A*A, A*A*A,... </div>
<div>
<br /></div>
<div>
grows until it stagnates in a loop (which is a group), in this case the trivial group generated by <i>the set of</i> the symmetric group of 4-permutations.</div>
</span></div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0tag:blogger.com,1999:blog-5309775736131296725.post-18619543318929573402016-01-23T12:56:00.000-08:002016-02-13T04:03:17.974-08:00More about subgroups<span style="font-family: "courier new" , "courier" , monospace;">[Attention, this code is not included in the code site!]</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">My first try to compute the set of subgroups of a group was to compute the set of subsets and test which subsets that was groups. But Sym(4), the group of all permutations of 1234, has 16777216 subsets. My next thought was to divide the set of subsets P(S) into subsets of equal cardinality P(S,k). This works for small k but</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">|P(Sym(4),12)|=24!/((24-12)!*12!)=2704156.</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Not very efficient thinking nor code so far! </span><span style="font-family: "courier new" , "courier" , monospace;">But even a blind dog can follow a track and I think that following algorithm is correct and "efficient":</span><br />
<ol>
<li><span style="font-family: "courier new" , "courier" , monospace;">set Subs={{123..}}, the set of the set of the identity</span></li>
<li><span style="font-family: "courier new" , "courier" , monospace;">for each x in S include x in all sets in a copy of Subs and compute the set of subgroups generated by the sets in the copy</span></li>
<li><span style="font-family: "courier new" , "courier" , monospace;">set Subs=Subs+copy (union)</span></li>
</ol>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Repetition of some set words and group words.</span></div>
<div>
<ul>
<li><span style="font-family: "courier new" , "courier" , monospace;"><b>fence </b>( x -- {x} ) and x could be an integer or a set</span></li>
<li><span style="font-family: "courier new" , "courier" , monospace;"><b>nfence </b>( s -- s') any object in s' is a fenced object of s</span></li>
<li><span style="font-family: "courier new" , "courier" , monospace;"><b>incl </b>( s x -- su{x}) the object x is included to s</span></li>
<li><span style="font-family: "courier new" , "courier" , monospace;"><b>nincl </b>( s x -- s') the elements in s' is the sets that are elements of s where x is included</span></li>
<li><span style="font-family: "courier new" , "courier" , monospace;"><b>generate </b>( s -- s') s' is the group generated by the permutations in s</span></li>
</ul>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">A set on the stack is represented by a negative-counted bundle on the stack and the count specifies the number of integers in the bundle. A semiotic word <b>foreach</b> prepares for processing of the elements in a do-loop:</span></div>
</div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: foreach ( s -- x1...xn n 0 )</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b> ndup \ s s duplicates the bundle</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b> card \ s n computes n=|s|</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b> nip 0 ; \ drop the bundle count and prepare for do loop</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"> </span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: ngenerate ( s -- s')</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b> 0 >>yst \ empty set on yst stack</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b> foreach \ for each element in the set s</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b> do generate \ the sets in s generates cyclic groups</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b> fence \ fence the group</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b> yst>> union >>yst</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b> loop yst>> ;</b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Here s' is the set of groups generated by the sets of permutations that are elements of s.</span></div>
<div>
<br /></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">And now finally the set of all subgroups</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: psubs ( s -- s')</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b> over numb identity fence fence >>yst </b>\ {{123...}} pushed to yst</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b> foreach</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b> do >r yst>> ndup r> nincl ngenerate union >>yst</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b> loop yst>> ;</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">4 sym psubs cr set. </span><br />
<span style="font-family: "courier new" , "courier" , monospace;"></span><br />
<span style="font-family: "courier new" , "courier" , monospace;">{{1234},{2134,1234},{3412,1234},{4123,3412,2341,1234},{1423,1342,1234},{4213,3241,1234},{4321,1234},{3142,2413,4321,1234},{4231,1234},{1243,1234},{1324,1234},{4321,4231,1324,1234},{1432,1234},{1423,1342,1243,1324,1432,1234},{3214,1234},{4213,3241,4231,1243,3214,1234},{3412,1432,3214,1234},{2314,3124,1234},{2134,2314,1324,3214,3124,1234},{2431,4132,1234},{2134,2431,4231,1432,4132,1234},{2143,1234},{3421,4312,2143,1234},{3412,4321,2143,1234},{2134,1243,2143,1234},{2134,3412,3421,4312,4321,1243,2143,1234},{3412,3142,2413,4321,4231,1324,2143,1234},{4123,3412,2341,4321,1432,3214,2143,1234},{3412,4213,1423,1342,2314,2431,3241,4321,3124,4132,2143,1234},{4123,2134,3412,4213,1423,2341,3421,3142,4312,2413,1342,2314,2431,3241,4321,4231,1243,1324,1432,3214,3124,4132,2143,1234}}</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new";">The normal subgroups:</span><br />
<span style="font-family: "courier new";"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;"><b>: pnsubs ( s -- s')<br /> ndup >>xst<br /> 0 >>yst<br /> psubs foreach<br /> do ndup nxst@ pnormal<br /> if fence yst>> union >>yst else ndrop then<br /> loop nxstdrop yst>> ;</b></span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><b></b></span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<br />
<div>
<span style="font-family: "courier new" , "courier" , monospace;">4 sym pnsubs cr set.<br />{{1234},{3412,4321,2143,1234},{3412,4213,1423,1342,2314,2431,3241,4321,3124,4132,2143,1234},{4123,2134,3412,4213,1423,2341,3421,3142,4312,2413,1342,2314,2431,3241,4321,4231,1243,1324,1432,3214,3124,4132,2143,1234}} ok</span><br />
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span>
<span style="font-family: "courier new" , "courier" , monospace;">Some reflections and facts:</span></div>
<div>
<span style="font-family: "courier new" , "courier" , monospace;">Any finite group is isomorphic to a subgroup of Sym(n) for some n. For all n>2, Sym(n) can be generated by two permutations. A consequence of the Structure Theorem for Abelian Groups, (a group where ab=ba for all a and b in the group) is that for any positive number m there is an Abelian group that can be generated by m but not by m-1 elements. So for n big enough, Sym(n) can be generated by 2 elements, but has subgroups needing m>2 generators.</span></div>
<br />
<div>
</div>
<br />
<div style="-webkit-text-stroke-width: 0px; color: black; font-family: 'Times New Roman'; font-size: medium; font-style: normal; font-variant: normal; font-weight: normal; letter-spacing: normal; line-height: normal; orphans: auto; text-align: start; text-indent: 0px; text-transform: none; white-space: normal; widows: 1; word-spacing: 0px;">
<div style="margin: 0px;">
<span style="font-family: "courier new" , "courier" , monospace;"><br /></span></div>
</div>
</div>
Lars-Erikhttp://www.blogger.com/profile/04526054592701399055noreply@blogger.com0