##########################################################################
### This ASCII FILE SHOULD BE SAVED AS a FILE CALLED HORTON.             #
### TO USE IT: GET INTO Maple, Type: `read HORTON:' [without the quotes],#
### and then follow the instructions given there                         #
##########################################################################

#HORTON: A Maple package accompanying the paper
#"Proof of Conway's `Lost' Cosmological Theorem" by Shalosh B. Ekhad
#and Doron Zeilberger. (ERA-AMS, v.3)
#It proves the Cosmological Theorem, and in the process
# it also investigates John HORTON
#Conway's brilliant analysis of his brilliant Audioacive decay
#as it is explained in his paper `The weird and wonderful chemistry
#of audioactive decay' that appeared in `Open problems in
#communication and computation', edited by Thomas M. Cover and
#B. Gopinath, Springer, 1987.



#Written by Doron Zeilberger, Temple University ,zeilberg@math.temple.edu.
#Please report bugs to zeilberg@math.temple.edu
 
die:=rand(1..3):
 
with(linalg):
 print(`Version of July 9, 1997`):
 print(`written by Doron Zeilberger(zeilberg@math.temple.edu).`):
 
 
print(` HORTON: A Maple package accompanying the paper`):
print(`"Proof of Conway's "Lost" Cosmological Theorem" by Shalosh B. Ekhad`):
print(` and Doron Zeilberger. (ERA-AMS, v.3) `):
print(``):
print(`It proves the Cosmological Theorem and also investigates John HORTON `):
print(`Conway's brilliant analysis of his brilliant Audioacive decay,`):
print(`as it is explained in his paper "The weird and wonderful chemistry`):
print(`of audioactive decay" that appeared in "Open problems in`):
print(`communication and computation", edited by Thomas M. Cover and`):
print(`B. Gopinath, Springer, 1987.`):
 
 print(`The most current version of the program`):
 print(` is  available from`):
 print(`http://www.math.temple.edu/~zeilberg`):
 print(`For a list of the procedures type ezra(), for help with`):
 print(`a specific procedure, type ezra(procedure_name)`):
 print(``):
 
ezra:=proc()
if args=NULL then
 print(`Contains the following procedures:`):
 print(` JHC, rat, se , split , midsplit, Detach, `):
 print( ` Split, PT, PTmat, PTlam, PerTab `):
 print(` TransUra, Life , Exotic, Hal, HalG, ExoticG, CHJ, Reject `): 
 print(` MidReject, GoodStart, GoodMid , SplitSegment , Cosmo, CosmoMethu `):
 print(`  CosmoNR `):
fi:
 
if nops([args])=1 and op(1,[args])=`CosmoNR` then
print(`CosmoNR(L): Fast, Non-rigorous version of Cosmo`):
fi:
 
 
 
if nops([args])=1 and op(1,[args])=`CosmoMethu` then
print(`CosmoMethu(L): Like Cosmo, but with the additional feature`):
print(`that it looks for  strings of longest longevity it is`):
print(`not guaranteed to find all  of them, only those that`):
print(`are of the form CHJ^a(w) for some a, and w in U_i(L)`):
fi:
 
 
if nops([args])=1 and op(1,[args])=`MidReject` then
print(`MidReject(w,i): Finds whether there is no way that `):
print(`the female chunk w can be a factor`):
print(`of an i-day-old string. It returns 1 in the`):
print(`affirmative, and 0 in the negative`):
fi:
 
 
if nops([args])=1 and op(1,[args])=`Cosmo` then
print(`Cosmo(L): Proves Conway's "Lost" cosmological theorem (by halting)`):
print(` (L=8 turns out to work, so Cosmo(8); does the job ),`):
print(`by finding  all female chunks of length 2i, i=1,2,3, ...`):
print(` that may`):
print(`be a factor of an atom of an L-day-old string; and checking each `):
print(` of them, w, for finite longevity, and the finite longevity`):
print(` of her Male extensions [i,op(w),j] of even-length (1<=i,j<=3) `):
print(`and her Female  extension of odd length [op(w),i] (i=1,2,3)`):
print(`and her Male  extension of odd length [i,op(w)] (i=1,2,3).`):
print(` The program halts if it reaches an i for which`):
print(` the set of successful female chunks of length 2i is empty.`):
lprint(``):
print(`The fact that it halted, together with the fact that all the `):
print(`female chunks of even length accepted,`):
print(` as well as their Male and Female`):
print(`extensions,  tested positively for finite longevity`):
print(` implies  Conway's Cosmological Theorem. `):
lprint(``):
print(`The reason is that the halting of the program implies that the`):
print(` set of atoms that occur in the decomposition of an L-day-old`):
print(` string is finite. `):
print(` Furthermore, any such atom `):
print(` must show up among those tested, since it does not`):
print(` split,  and it survives`):
print(` depth-L genealogical screening. Of course, the program does `):
print(` lots of  unnecessary testing, but  every no atom  escapes testing. `):
lprint(``):
print(`As a bonus, we have an upper bound for the maximum longevity:`):
print(` of ANY string. It is: `):
print(` L+ the max. longevity of tested chunks +1 `):
lprint(``):
print(`In order to keep us entertained during the long run of this `):
print(`program, it `):
print(`prints the number of accepted female-chunks of length 2i`):
print(`i=1,2, ...,  `):
print(` and the maximum longevity, to-date, encountered` ):
fi:
  
if nops([args])=1 and op(1,[args])=`FindMax` then
print(`FindMax(L): Finds the maximal length of a segment that may`):
print(`be a factor of an atom of an L-old string; In the meantime it`):
print(`prints the number of survivors of length i, for even i for`):
print(`i=2,4, ..., L`):
print(`that may be factors of an`):
print(`unsplitable atom of an i-day-old strings`):
fi:
 
if nops([args])=1 and op(1,[args])=`SplitSegment` then
print(`SplitSegment(w) given a segment w, returns 1 if it can`):
print(`be split somewhere via midsplit, otherwise it returns 0`):
fi:
 
 
if nops([args])=1 and op(1,[args])=`GoodMid` then
print(`GoodMid(k,i): Finds all the Female word-segments in {1,2,3}`):
print(` of k letters that may be factors of an`):
print(` atom of an i-day-old strings`):
fi:
 
if nops([args])=1 and op(1,[args])=`GoodStart` then
print(`GoodStart(k,i): Finds all the words in {1,2,3} of k letters`):
print(`that may be the beginning of the first`):
print(`unsplitable atom of an i-day-old strings`):
fi:
 
if nops([args])=1 and op(1,[args])=`GoodStarto` then
print(` GoodStarto(k,i): Finds all the words in {1,2,3} of k letters `):
print( ` that may be the beginning of i-day-old strings `):
fi:
 
 
if nops([args])=1 and op(1,[args])=`Reject` then
print(`Reject(w,i):Finds whether there is no way that w can be the`):
print(`beginning of an i-day-old string. It returns 1 in the`):
print(` affirmative, and 0 in the negative `):
fi:
 
if nops([args])=1 and op(1,[args])=`badword` then
print(`badword(w): Given a word w decides whether it is surely not`):
print(`a  beginning of JHC(v) for some v, i.e. it looks whether there`):
print(` exists an i s.t. w[2*i]=w[2*i+2]. If it is bad, it returns 1 `):
print( ` otherwise, it returns 0 `):
fi:
 
if nops([args])=1 and op(1,[args])=`CHJ` then
print(`CHJ(w):Given a word w, finds the beginning of JHC^(-1)(u),`):
print(` as far as it is determined uniquely, of all words  u`):
print(` that start with w `):
fi:
 
 
if nops([args])=1 and op(1,[args])=`EAdForbidCorpus` then
print(`EAdForbidCorpus(k,K,L,i) finds all forbidden tuples up to`):
print(` in even places `):
print(`length k in splitting of JHC^i(w) , where w ranges over`):
print(`an L-word random corpus of K-letter words`):
fi:
 
if nops([args])=1 and op(1,[args])=`AdForbidCorpus` then
print(`AdForbidCorpus(k,K,L,i) finds all forbidden tuples up to`):
print(`length k in splitting of JHC^i(w) , where w ranges over`):
print(`an L-word random corpus of K-letter words`):
fi:
 
 
if nops([args])=1 and op(1,[args])=`EForbidCorpus` then
print(`EForbidCorpus(k,K,L,i):All the k-tuples `):
print(` (in even places) that don't show up in atoms`):
print(`of splitting of i-Days Old sequences that came from length-K`):
print(`sequences and that are not implied by Forbid(k-1,K,i)`):
fi:
 
if nops([args])=1 and op(1,[args])=`ForbidCorpus` then
print(`ForbidCorpus(k,K,L,i):All the k-tuples that don't show up in atoms`):
print(`of splitting of i-Days Old sequences that came from length-K`):
print(`sequences and that are not implied by Forbid(k-1,K,i)`):
fi:
 
 
if nops([args])=1 and op(1,[args])=`Forbid` then
print(`Forbid(k,K,i):All the k-tuples that don't show up in atoms`):
print(`of splitting of i-Days Old sequences that came from length-K`):
print(`sequences`):
fi:
 
if nops([args])=1 and op(1,[args])=`kTuplesKiDaysOld` then
print( `kTuplesKiDaysOld(k,K,i) finds all k-tuples that show up`):
print(`in the atoms of the splitting`):
print(`of applying JHC^i to all words of length K`):
fi:
 
 
if nops([args])=1 and op(1,[args])=`RandSeq` then
print(`RandSeq(k): finds a random sequence in {1,2,3} of length k`):
fi:
 
if nops([args])=1 and op(1,[args])=`AllAtomsiDaysOld` then
print(`AllAtomsiDaysOld(K,i): finds the set of`):
print(` all atoms in the splitting of JHC^(i)(w)`):
fi:
 
if nops([args])=1 and op(1,[args])=`AtomsiDaysOld` then
print(`AtomsiDaysOld(w,i): given a word w, and a positive integer`):
print(`i, finds all the atoms in the splitting of JHC^(i)(w)`):
fi:
 
if nops([args])=1 and op(1,[args])=`AllLeftiDaysOld` then
print( `AllLeftiDaysOld(K,i): finds the set of`):
print(`leftmost atoms in the splitting of JHC^(i)(w)`):
fi:
 
if nops([args])=1 and op(1,[args])=`LeftiDaysOld` then
print(`LeftiDaysOld(w,i): given a word w, and a positive integer`):
print(`i, finds the leftmost atom in the splitting of JHC^(i)(w)`):
fi:
 
if nops([args])=1 and op(1,[args])=`Hal` then
print(`Hal(K) gives a candidate for the set of all exotic elements`):
print(`starting from the descendants of words of length<=i until i=K`):
print(`when the output from two consecutive i matches it halts with`):
print(`the set, followed by 1, otherwise  it outputs Exotic(K) followed`):
print(`by 0`):
fi:
 
if nops([args])=1 and op(1,[args])=`Exotic` then
print(`ExoticU(L) gives the list of non-stable elements derived from`):
print(`words in {1,2,3} of length <=L`):
fi:
 
if nops([args])=1 and op(1,[args])=`HalG` then
print(`HalG(K,r) gives a candidate for the set of all exotic elements`):
print(`starting from the descendants of words of length<=i until i=K`):
print(`after JHC has been applied r times`):
print(`when the output from two consecutive i matches it halts with`):
print(`the set, followed by 1, otherwise  it outputs ExoticG(K,r) followed`):
print(`by 0`):
fi:
 
if nops([args])=1 and op(1,[args])=`ExoticG` then
print(`ExoticG(L,r) gives the list of non-stable elements derived from`):
print(`words in {1,2,3} of length <=L after applying JHC r times` ):
fi:
 
if nops([args])=1 and op(1,[args])=`Life` then
print(`Life(w) finds the number of moves  taken to reduce a word w`):
print(`into atoms`):
fi:
 
if nops([args])=1 and op(1,[args])=`TransUra` then
print(`TransUra() gives the two transuranic elements with n=4`):
fi:
 
if nops([args])=1 and op(1,[args])=`PerTab` then
print(`PerTab(); gives the set of 92 elements`):
print(`it uses PT()`):
print(`but it is tabulated here so that it can be used faster`):
fi:
 
if nops([args])=1 and op(1,[args])=`PTlam` then
print(`PTlam(x) computes the list of atoms  followed by the splitting `):
print(`table A, defined by A[atom]=splitting of `):
print(`JHC(atom), followed by  the abundance table `):
print(`followed by the minimal polynomial satisfied by Conway's constant`):
print(`lambda,  using x as the variable,`):
print(` followed by the floating point appx. to lambda `):
fi:
 
if nops([args])=1 and op(1,[args])=`PTmat` then
print(`PTmat() computes the list of atoms and the expansion matrix`):
print(`A, defined by A[atom1,atom2]=number of times atom2 appears in`):
print(`JHC(atom1) `):
fi:
 
if nops([args])=1 and op(1,[args])=`PT` then
print(`PT() computes the list of atoms and the splitting function`):
print(`A, defined by A[atom]=Sequence of atoms making up the compound`):
print(`of JHC(atom) (in that order).`):
fi:
 
if nops([args])=1 and op(1,[args])=`Split` then
print(`Split(w) : given w sequence w, decomposes it into`):
print(`indecomposables (atoms).`):
fi:
 
 
if nops([args])=1 and op(1,[args])=`Detach` then
print(`Detach(w) : given w sequence w, finds the leftmost factor`):
print(`w1 s.t. w can be written as w=w1.w2.`):
fi:
 
if nops([args])=1 and op(1,[args])=`split` then
print(`split(L,R) tests whether L and R split as L.R `):
print(`if it is, it returns 1, otherwise 0`):
fi:
 
 
 
if nops([args])=1 and op(1,[args])=`midsplit` then
print(`midsplit(L,R) tests whether two segments L and R split as`):
print(` ...L.R... `):
print(`if it is, it returns 1, otherwise 0`):
fi:
 
if nops([args])=1 and op(1,[args])=`JHC` then
print(`JHC(seq): given a sequence of integers, represented in terms of`):
print(`a list, outputs one iteration of the Conway operation`):
print(`a_1^{b_1} ... a_r^{b_r}-> b_1 a_1 b_2 a_2 ... b_r a_r`):
fi:
 
 
if nops([args])=1 and op(1,[args])=`rat` then
print(`rat(K): computes the ratios of the length if JHC^{i+1}([1])`):
print(`to the length of JHC^{i}([1]), for i=1, ..., K`):
fi:
 
 
if nops([args])=1 and op(1,[args])=`se` then
print(`se(K): computes the  sequence of the lengths of JHC^{i}([1])`):
print(`for i=1, ..., K`):
fi:
 
end:
 
 
ezra1:=proc()
if args=NULL then
 print(`We also have the following procedures:`):
 print(` LeftiDaysOld , AllLeftiDaysOld , AtomsiDaysOld, `):
 print(`  AllAtomsiDaysOld , RandSeq , kTuplesKiDaysOld, Forbid `):
 print(` ForbidCorpus ,  EForbidCorpus , AdForbidCorpus, EAdForbidCorpus `):
 print(` badword `):
 print(`To find out about them, do ezra(procedure_name)`):
fi:
end: 
TransUra:=proc():
{[3,1,2,2,1,1,3,2,2,2,1,2,2,2,1,1,2,1,1,2,3,2,2,2,1,1,4],
[1,3,1,1,2,2,2,1,1,3,3,2,1,1,3,2,2,1,1,2,2,1,1,2,1,3,3,2,2,1,1,4]}
end:
 
 
 
 
PerTab:=proc()
option remember:
PT()[1]:
end:
 
 
JHC:=proc(w)
local j,i,r,lu,gu:
 
if nops(w)=0 then
 RETURN([]):
fi:
 
gu:=[]:
j:=1:
 
while j<=nops(w) do
r:=op(j,w):
lu:=[r]:
for i from j+1  to nops(w) while op(i,w)=r do
lu:=[op(lu),r]:
od:
 
gu:=[op(gu),nops(lu),r]:
j:=nops(lu)+j:
od:
gu:
 
end:
 
 
rat:=proc(K)
local i,mu,mu1:
mu:=[1]:
for i from 1 to K do
mu1:=JHC(mu):
print(evalf(nops(mu1)/nops(mu))):
mu:=mu1:
od:
end:
 
 
se:=proc(K)
local i,mu,ku:
ku:=[]:
mu:=[1]:
for i from 1 to K do
ku:=[op(ku),nops(mu)]:
mu:=JHC(mu):
od:
ku:
end:
 
 
redu:=proc(w)
local i,w1,ot1:
w1:=[]:
for i from 1 to nops(w) do
 ot1:=op(i,w):
if ot1>4 then
 w1:=[op(w1),4]:
else
 w1:=[op(w1),ot1]:
fi:
od:
w1:
end:
 
#Seqk: all sequences of length k
Seqk:=proc(k)
local i,gu,mu,lu:
if k=0 then
 RETURN({[]}):
fi:
 
gu:=Seqk(k-1):
mu:={}:
 
for i from 1 to nops(gu) do
lu:=op(i,gu):
mu:=mu union {[op(lu),1],[op(lu),2],[op(lu),3]}:
od:
 
mu:
end:
 
#Hafokh(w) converts a word into the word obtained by
#changing all integers>=4 to 4
 
Hafokh:=proc(w)
local w1,i:
 
w1:=[]:
for i from 1 to nops(w) do
if op(i,w)>4 then
 w1:=[op(w1),4]:
else
 w1:=[op(w1),op(i,w)]:
fi:
od:
w1:
end:
 
 
Hal:=proc(K)
local i,gu,gu1:
 
if K<2 then
ERROR(`K>=2`):
fi:
 
gu:=Exotic(1):
for i from 2 to K do
print(`i=`,i-1):
lprint(gu):
 
gu1:=Exotic(i):
if gu1=gu then
RETURN(gu,1):
fi:
od:
 
gu1,0:
end:
 
 
split:=proc(L,R)
local n,m:
if nops(L)=0 or nops(R)=0 then
 RETURN(1):
fi:
 
n:=op(nops(L),L):
m:=op(1,R):
 
if n=m then
 RETURN(0):
fi:
 
if n>=4 and m<=3 then
RETURN(1):
fi:
 
if n=2 then
 if m=1 and nops(R)>2 and op(2,R)<>1 and op(3,R)<>op(2,R) then 
   RETURN(1):
 fi:
 if m=1 and nops(R)=2 and op(2,R)<>1 then 
   RETURN(1):
 fi:
 
 if m=1 and nops(R)>=3 and op(2,R)=1 and op(3,R)=1 then 
   RETURN(1):
 fi:
 
 if m=3 and nops(R)>=2 and op(2,R)<>3
and not(nops(R)>=4 and op(2,R)=op(3,R) and op(3,R)=op(4,R))
 then
        RETURN(1):
 fi:
 
 if m=3 and nops(R)=1 
 then
        RETURN(1):
 fi:
 
 if m>=4 then
  RETURN(1):
 fi:
fi:
 
if n<>2 then
  if nops(R)>=5 and op(1,R)=2 and op(2,R)=2 and op(3,R)=1 and op(4,R)<>1
     and op(5,R)<>op(4,R)  then
      RETURN(1):
  fi:
 
  if nops(R)=4 and op(1,R)=2 and op(2,R)=2 and op(3,R)=1 and op(4,R)<>1 then
      RETURN(1):
  fi:
 
 if nops(R)>=5 and op(1,R)=2 and op(2,R)=2 and op(3,R)=1 and op(4,R)=1
              and op(5,R)=1 then
    RETURN(1):
 fi:
 
 if nops(R)>=4 and op(1,R)=2 and op(2,R)=2 and op(3,R)=3 and op(4,R)<>op(3,R)
              and not(nops(R)>=6 and op(4,R)=op(5,R) and op(5,R)=op(6,R))
                 then
    RETURN(1):
 fi:
 
 if nops(R)=2 and op(1,R)=2 and op(2,R)=2 then
  RETURN(1):
 fi:
 
 if nops(R)=3 and op(1,R)=2 and op(2,R)=2 and op(3,R)>=4 then
  RETURN(1):
 fi:
 
 if nops(R)>=3 and op(1,R)=2 and op(2,R)=2 and op(3,R)>=4 and
                     op(4,R)<>op(3,R)    then
                   
  RETURN(1):
 fi:
fi:
0:
end:
 
 
 
 
 
#Detach(w) : given a sequence w, finds the leftmost factor
#w1 s.t. w can be written as w=w1.w2  
 
 
Detach:=proc(w)
local i,w1,w2:
 
for i from 1 to nops(w) do
w1:=[op(1..i,w)]:
w2:=[op(i+1..nops(w),w)]:
if split(w1,w2)=1 then
 RETURN(w1,w2):
fi:
od:
end:
 
 
#Split(w) : given w sequence w, decomposes it into
#indecomposables (atoms)
 
Split:=proc(w)
local w1,w2:
 
w1:=Detach(w):
w2:=w1[2]:
w1:=w1[1]:
 
if w2=[] then
RETURN([w1]):
fi:
 
[w1,op(Split(w2))]:
 
end:
 
 
 
#PT() computes the list of atoms and the splitting function
#A, defined by A[atom]=Sequence of atoms making up the compound
#of JHC(atom) (in that order), 
 
PT:=proc()
local Elements,A,khadas,Mapped,mu:
 
Elements:={[3]}:
Mapped:={}:
 
while nops(Elements minus Mapped)>0 do
mu:=op(1,Elements minus Mapped):
khadas:=Split(JHC(mu)):
A[op(mu)]:=khadas:
Elements:=Elements union convert(khadas,set):
Mapped:=Mapped union {mu}:
od:
 
Elements,A:
end:
 
 
 
 
#PTmat() computes the list of atoms and the expansion matrix
#A, defined by A[atom1,atom2]=number of times atom2 appears in
#JHC(atom1) 
 
PTmat:=proc()
local atom,Elements,A,khadas,Mapped,mu,mat,B,nu,i,j,ima:
 
Elements:={[3]}:
Mapped:={}:
 
while nops(Elements minus Mapped)>0 do
mu:=op(1,Elements minus Mapped):
khadas:=Split(JHC(mu)):
A[op(mu)]:=khadas:
Elements:=Elements union convert(khadas,set):
Mapped:=Mapped union {mu}:
od:
 
nu:=nops(Elements):
 
mat:=matrix(nu,nu):
 
for i from 1 to nu do
for j from 1 to nu do
mat[i,j]:=0:
od:
od:
 
Elements:=convert(Elements,list):
 
for i from 1 to nu do
B[op(i,Elements)]:=i:
od:
 
for i from 1 to nu do
atom:=op(i,Elements):
 
ima:=A[op(atom)]:
 
for j from 1 to  nops(ima) do
mat[i,B[op(j,ima)]]:=mat[i,B[op(j,ima)]]+1:
od:
od:
 
 
Elements, mat:
 
end:
 
 
 
#PTlam(x) computes the list of atoms  followed by the splitting 
#table A, defined by A[atom]=splitting of 
#JHC(atom), followed by  the abundance table 
#followed by the minimal polynomial satisfied by Conway's constant
#lambda,  using x as the variable
#followed by the floating point appx. to lambda
 
PTlam:=proc(x)
local atom,Elements,A,khadas,Mapped,mu,mat,B,nu,i,j,ima,shoresh,pol,eq,var,
eq1,C,D1,gu:
 
Digits:=50:
Elements:={[3]}:
Mapped:={}:
 
while nops(Elements minus Mapped)>0 do
mu:=op(1,Elements minus Mapped):
khadas:=Split(JHC(mu)):
A[op(mu)]:=khadas:
Elements:=Elements union convert(khadas,set):
Mapped:=Mapped union {mu}:
od:
 
nu:=nops(Elements):
 
mat:=matrix(nu,nu):
 
for i from 1 to nu do
for j from 1 to nu do
mat[i,j]:=0:
od:
od:
 
Elements:=convert(Elements,list):
 
for i from 1 to nu do
B[op(i,Elements)]:=i:
od:
 
for i from 1 to nu do
atom:=op(i,Elements):
 
ima:=A[op(atom)]:
 
for j from 1 to  nops(ima) do
mat[i,B[op(j,ima)]]:=mat[i,B[op(j,ima)]]+1:
od:
od:
 
pol:=charpoly(mat,x):
shoresh:=max(fsolve(pol,x)):
 
 
eq:={}:
var:={}: 
for j from 1 to nu do
eq1:=shoresh*x[j]:
var:=var union {x[j]}:
for i from 1 to nu do
eq1:=eq1-mat[i,j]*x[i]:
od:
eq:=eq union {eq1}:
od:
 
 
eq:=eq minus {op(1,eq)}:
var:=solve(eq,var):
 
for i from 1 to nu do
C[i]:=subs(var,x[i]):
od:
 
gu:=0:
for i from 1 to nu do
gu:=gu+C[i]:
od:
 
 
for i from 1 to nu do
D1[op(i,Elements)]:=C[i]/gu:
od:
 
pol:=sort(factor(pol)):
 
print(`The set of elements is`):
print(Elements):
print(`The  Splitting table atom->Splitting(JHC(atom)) is`):
print(op(A)):
print(`The  Abundance table  is`):
print(op(D1)):
print(`The characteristic polynomial is `):
print(pol):
print(`Conway's Constant, lambda is`, shoresh ):
Elements, A,D1, pol, shoresh:
 
end:
 
 
 
 
#Exotic1(L) gives the list of non-stable elements derived from
#words in {1,2,3} of length L
 
Exotic1:=proc(L)
local gu,i,mu,w:
option remember:
mu:={}:
gu:=Seqk(L):
 
for i from 1 to nops(gu) do
w:=op(i,gu):
w:=JHC(JHC(w)):
w:=Hafokh(w):
mu:=mu union Derived(w):
od:
 
mu:
end:
 
 
#Exotic(L) gives the list of non-stable elements derived from
#JHC^2(words) in {1,2,3} of length <=L
 
Exotic:=proc(L)
local mu,i:
 
mu:={}:
for i from 1 to L do
mu:=mu union  Exotic1(i):
od:
 
mu:
end:
 
 
 
#Derived(w) finds all the non-stable elements obtained by
#repeating JHC until it is decomposed into stable elements
 
Derived:=proc(w3)
local gu,Elements,khadas,Mapped,mu,w:
 
w:=JHC(JHC(JHC(w3))):
gu:=PerTab(): 
Elements:=convert(Split(w),set) minus gu:
Mapped:={}:
 
while nops(Elements minus Mapped)>0 do
mu:=op(1,Elements minus Mapped):
khadas:=convert(Split(JHC(mu)),set) minus gu:
Elements:=Elements union khadas:
Mapped:=Mapped union {mu}:
od:
 
Elements:
end:
 
 
 
 
#Life(w) finds the number of moves<=L  taken to reduce a word w
#into atoms
 
Life:=proc(w)
local i,ma,ku,gu,w1:
option remember:
 
if not type(w,list) then
ERROR(`Input must be a list of integers`):
fi:
 
gu:=PerTab() union TransUra():
 
w1:=convert(Split(redu(w)),set):
if w1 intersect gu=w1  then
RETURN(0):
fi:
 
w1:=JHC(w):
w1:=Split(redu(w1)):
 
w1:=convert(w1,set) minus gu:
 
ma:=0:
 
for i from 1 to nops(w1) do
 ku:=Life(op(i,w1)):
if ku>ma then
  ma:=ku:
fi:
od:
 
ma+1:
end:
 
 
 
 
 
 
 
#ExoticG1(L,r) gives the list of non-stable elements derived from
#words in {1,2,3} of length L after JHC is applied r times
 
ExoticG1:=proc(L,r)
local gu,i,mu,w,j:
option remember:
mu:={}:
gu:=Seqk(L):
 
for i from 1 to nops(gu) do
w:=op(i,gu):
for j from 1 to r do
w:=JHC(w):
od:
w:=Hafokh(w):
mu:=mu union Derived(w):
od:
 
mu:
end:
 
 
#ExoticG(L,r) gives the list of non-stable elements derived from
#JHC^r(words) in {1,2,3} of length <=L
 
ExoticG:=proc(L,r)
local mu,i:
 
mu:={}:
for i from 1 to L do
mu:=mu union  ExoticG1(i,r):
od:
 
mu:
end:
 
 
 
HalG:=proc(K,r)
local i,gu,gu1:
 
if K<3 then
ERROR(`K>=3`):
fi:
 
gu:=ExoticG(2,r):
for i from 3 to K do
print(`i=`,i-1):
lprint(gu):
 
gu1:=ExoticG(i,r):
if gu1=gu then
RETURN(gu,1):
fi:
od:
 
gu1,0:
end:
 
#LeftiDaysOld(w,i): given a word w, and a positive integer
#i, finds the leftmost atom in the splitting of JHC^(i)(w)
 
LeftiDaysOld:=proc(w,i)
local j,lu:
 
lu:=w:
 
for j from 1 to i do
lu:=Split(lu)[1]:
lu:=JHC(lu):
od:
lu:
end:
 
 
#AllLeftiDaysOld(K,i): finds the set of
#leftmost atoms in the splitting of JHC^(i)(w)
 
AllLeftiDaysOld:=proc(K,i)
local gu,w,mu,j:
gu:={}:
 
mu:=Seqk(K):
gu:={}:
 
for j from 1 to nops(mu) do
w:=op(j,mu):
w:=LeftiDaysOld(w,i):
gu:=gu union {w}:
od:
 
gu:
 
end:
 
 
#AtomsiDaysOld(w,i): given a word w, and a positive integer
#i, finds all the atoms in the splitting of JHC^(i)(w)
 
AtomsiDaysOld:=proc(w,i)
local j,lu:
 
lu:=w:
 
for j from 1 to i do
lu:=JHC(lu):
od:
 
convert(Split(lu),set):
end:
 
 
 
#AllAtomsiDaysOld(K,i): finds the set of
#leftmost atoms in the splitting of JHC^(i)(w)
 
AllAtomsiDaysOld:=proc(K,i)
local gu,w,mu,j:
gu:={}:
 
mu:=Seqk(K):
gu:={}:
 
for j from 1 to nops(mu) do
w:=op(j,mu):
gu:=gu union AtomsiDaysOld(w,i):
od:
 
gu:
 
end:
 
 
 
 
#RandSeq(k): finds a random sequence in {1,2,3} of length k
RandSeq:=proc(k)
local lu,i:
lu:=[]:
 
for i from 1 to k do
lu:=[op(lu),die()]:
od:
 
lu:
 
end:
 
 
#kTuplesKiDaysOld(k,K,i) finds all k-tuples that show up
#in the atoms of the splitting
#of applying JHC^i to all words of length K
 
kTuplesKiDaysOld:=proc(k,K,i)
local j,Sequs,w,w1,j1,lu,j2,ktup,j3:
 
ktup:={}:
Sequs:=Seqk(K):
 
for j from 1 to nops(Sequs) do
w:=op(j,Sequs):
 
w1:=w:
for j1 from 1 to i do
w1:=JHC(w1):
od:
 
lu:=Split(w1):
 
for j2 from 1 to nops(lu) do
w1:=op(j2,lu):
w1:=Hafokh(w1):
 
for j3 from 1 to nops(w1)-k+1 do
ktup:=ktup union {[op(j3..j3+k-1,w1)]}:
od:
 
od:
od:
ktup:
end:
 
#Forbid(k,K,i):All the k-tuples that don't show up in atoms
#of splitting of i-Days Old sequences that came from length-K
#sequences and that are not implied by Forbid(k-1,K,i)
 
Forbid:=proc(k,K,i)
local gu1,gu,w,i1,mu:
option remember:
 
if k=0 then
RETURN({}):
fi:
 
mu:=Forbid(k-1,K,i):
gu:=Seqk(k) minus kTuplesKiDaysOld(k,K,i):
 
gu1:=gu:
for i1 from 1 to nops(gu) do
 w:=op(i1,gu):
 if member([op(1..k-1,w)],mu) or member([op(2..k,w)],mu) then
  gu1:=gu1 minus {w}:
 fi:
od:
gu1:
end:
 
 
 
 
#kTuplesKCorpusLiDaysOld(k,K,L,i) finds all k-tuples that show up
#in the atoms of the splitting
#of applying JHC^i to a random corpus of L words of length K
 
kTuplesKCorpusLiDaysOld:=proc(k,K,L,i)
local j,w,w1,j1,lu,j2,ktup,j3:
 
ktup:={}:
 
for j from 1 to L do
w:=RandSeq(K):
 
w1:=w:
for j1 from 1 to i do
w1:=JHC(w1):
od:
 
lu:=Split(w1):
 
for j2 from 1 to nops(lu) do
w1:=op(j2,lu):
w1:=Hafokh(w1):
 
for j3 from 1 to nops(w1)-k+1 do
ktup:=ktup union {[op(j3..j3+k-1,w1)]}:
od:
 
od:
od:
ktup:
end:
 
#ForbidCorpus(k,K,L,i):All the k-tuples that don't show up in atoms
#of splitting of i-Days Old sequences that came from length-K
#sequences and that are not implied by Forbid(k-1,K,i)
 
ForbidCorpus:=proc(k,K,L,i)
local gu1,w,i1,mu,gu:
option remember:
 
if k=0 then
RETURN({}):
fi:
 
mu:=ForbidCorpus(k-1,K,L,i):
gu:=Seqk(k) minus kTuplesKCorpusLiDaysOld(k,K,L,i):
 
gu1:=gu:
for i1 from 1 to nops(gu) do
 w:=op(i1,gu):
 if member([op(1..k-1,w)],mu) or member([op(2..k,w)],mu) then
  gu1:=gu1 minus {w}:
 fi:
od:
gu1:
end:
 
 
 
#EkTuplesKiDaysOld(k,K,i) finds all k-tuples (in even places) that show up
#in the atoms of the splitting
#of applying JHC^i to all words of length K
 
EkTuplesKiDaysOld:=proc(k,K,i)
local j,Sequs,w,w1,j1,lu,j2,ktup,j3,ka,j4:
 
ktup:={}:
Sequs:=Seqk(K):
 
for j from 1 to nops(Sequs) do
w:=op(j,Sequs):
 
w1:=w:
for j1 from 1 to i do
w1:=JHC(w1):
od:
 
lu:=Split(w1):
 
for j2 from 1 to nops(lu) do
w1:=op(j2,lu):
w1:=Hafokh(w1):
 
for j3 from 2 to nops(w1)-2*k do
ka:=[]:
for j4 from 1 to k do
ka:=[op(ka),op(j3+2*j4,w1)]:
od:
ktup:=ktup union {ka}:
od:
 
od:
od:
ktup:
end:
 
#EForbid(k,K,i):All the k-tuples (in even places)
#that don't show up in atoms
#of splitting of i-Days Old sequences that came from length-K
#sequences and that are not implied by Forbid(k-1,K,i)
 
EForbid:=proc(k,K,i)
local gu1,gu,w,i1,mu:
option remember:
 
if k=0 then
RETURN({}):
fi:
 
mu:=EForbid(k-1,K,i):
gu:=Seqk(k) minus EkTuplesKiDaysOld(k,K,i):
 
gu1:=gu:
for i1 from 1 to nops(gu) do
 w:=op(i1,gu):
 if member([op(1..k-1,w)],mu) or member([op(2..k,w)],mu) then
  gu1:=gu1 minus {w}:
 fi:
od:
gu1:
end:
 
 
 
 
#EkTuplesKCorpusLiDaysOld(k,K,L,i) finds all k-tuples(in even places)
#that show up
#in the atoms of the splitting
#of applying JHC^i to a random corpus of L words of length K
 
EkTuplesKCorpusLiDaysOld:=proc(k,K,L,i)
local j,w,w1,j1,lu,j2,ktup,j3,j4,ka:
 
ktup:={}:
 
for j from 1 to L do
w:=RandSeq(K):
 
w1:=w:
for j1 from 1 to i do
w1:=JHC(w1):
od:
 
lu:=Split(w1):
 
for j2 from 1 to nops(lu) do
w1:=op(j2,lu):
w1:=Hafokh(w1):
 
for j3 from 2 to nops(w1)-2*k do
 
ka:=[]:
for j4 from 1 to k do
ka:=[op(ka),op(j3+2*j4,w1)]:
od:
ktup:=ktup union {ka}: 
od:
 
od:
od:
ktup:
end:
 
#EForbidCorpus(k,K,L,i):All the k-tuples (in even places)
#that don't show up in atoms
#of splitting of i-Days Old sequences that came from length-K
#sequences and that are not implied by Forbid(k-1,K,i)
 
EForbidCorpus:=proc(k,K,L,i)
local gu1,w,i1,mu,gu:
option remember:
 
if k=0 then
RETURN({}):
fi:
 
mu:=EForbidCorpus(k-1,K,L,i):
gu:=Seqk(k) minus EkTuplesKCorpusLiDaysOld(k,K,L,i):
 
gu1:=gu:
for i1 from 1 to nops(gu) do
 w:=op(i1,gu):
 if member([op(1..k-1,w)],mu) or member([op(2..k,w)],mu) then
  gu1:=gu1 minus {w}:
 fi:
od:
gu1:
end:
 
 
 
#AdForbidCorpus(k,K,L,i) finds all forbidden tuples up to
#length k in splitting of JHC^i(w) , where w ranges over
#an L-word random corpus of K-letter words
 
AdForbidCorpus:=proc(k,K,L,i)
local mu,k1:
mu:={}:
 
for k1 from 1 to k do
mu:=mu union ForbidCorpus(k1,K,L,i):
od:
 
mu:
end:
 
 
 
 
#EAdForbidCorpus(k,K,L,i) finds all forbidden tuples up to
#length k in (even places) of splitting of JHC^i(w) , where w ranges over
#an L-word random corpus of K-letter words
 
EAdForbidCorpus:=proc(k,K,L,i)
local mu,k1:
mu:={}:
 
for k1 from 1 to k do
mu:=mu union EForbidCorpus(k1,K,L,i):
od:
 
mu:
end:
 
 
 
#CHJ(w):Given a word w, finds the beginning of JHC^(-1)(u),
#as far as it is determined uniquely, of all words  u
#that start with w
 
CHJ:=proc(w)
local gu,i,num,ot1,j:
gu:=[]:
 
for i from 1 to trunc(nops(w)/2) do
ot1:=op(2*i,w):
num:=op(2*i-1,w):
gu:=[op(gu),seq(ot1,j=1..num)]:
od:
gu:
end:
 
#badword(w): Given a word w decides whether it is surely not
#a  beginning of JHC(v) for some v, i.e. it looks whether there
#exists an i s.t. w[2*i]=w[2*i+2]. If it is bad, it returns 1
#otherwise, it returns 0
 
badword:=proc(w)
local i:
for i from 1 to trunc(nops(w)/2)-1 do
  if op(2*i,w)=op(2*i+2,w) then
   RETURN(1):
  fi:
od:
0:
end:
 
 
#Finds whether there is no way that w can be the
#beginning of an i-day-old string. It returns 1 in the
#affirmative, and 0 in the negative
 
Reject:=proc(w,i)
local j,w1:
 
w1:=w:
 
for j from 1 to i while nops(w1)>1 do
if badword(w1)=1 then
  RETURN(1):
fi:
w1:=CHJ(w1):
od:
0:
end:
 
 
#GoodStarto(k,i): Finds all the words in {1,2,3} of k letters
#that may be the beginning of i-day-old strings
 
GoodStarto:=proc(k,i)
local se1,i1,se,w,w1,j1,j2:
option remember:
 
if not k mod 2=0 or k<0 then
ERROR(`First argument must be an even positive integer`):
fi:
 
if k=0 then
RETURN({[]}):
fi:
 
se:={}:
se1:=Seqk(k-2):
 
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
 
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
if Reject(w1,i)=0 then
 se:=se union {w1}:
fi:
od:
od:
 
od:
se:
end:
 
 
 
#GoodStarto(k,i): Old Version of
#GoodStart Finds all the words in {1,2,3} of k letters
#that may be the beginning of the first
#atom of an i-day-old strings
 
GoodStarto:=proc(k,i)
local se1,i1,se,w,w1,w2,j1,j2:
option remember:
 
if not k mod 2=0 or k<0 then
ERROR(`First argument must be an even positive integer`):
fi:
 
if k=0 then
RETURN({[]}):
fi:
 
se:={}:
se1:=GoodStarto(k-2,i):
 
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
 
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
if Reject(w1,i)=0 then
  w2:=Split(w1):
 if nops(w2)=1  or (nops(w2)>1 and Life(w2[1])>1000) then
  se:=se union {w1}:
 fi:
 
fi:
od:
od:
 
od:
se:
end:
 
 
#GoodStart(k,i): Finds all the words in {1,2,3} of k letters
#that may be the beginning of the first
#atom of an i-day-old strings
 
GoodStart:=proc(k,i)
local se1,i1,se,w,w1,j1,j2:
option remember:
 
if not k mod 2=0 or k<0 then
ERROR(`First argument must be an even positive integer`):
fi:
 
if k=0 then
RETURN({[]}):
fi:
 
se:={}:
se1:=GoodStart(k-2,i):
 
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
 
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
if Reject(w1,i)=0 then
 if SplitSegment(w1)=0 then
  se:=se union {w1}:
 fi:
 
fi:
od:
od:
 
od:
se:
end:
 
 
 
 
#ParentOfGirl(w):Given a Female word-segment w, (i.e. starting
#with a comma) finds the  corresponding
#segment in JHC^(-1)(...w...), assuming that it is Female
 
 
ParentOfGirl:=proc(w)
local gu,i,num,ot1,j:
gu:=[]:
 
for i from 1 to trunc(nops(w)/2) do
ot1:=op(2*i,w):
num:=op(2*i-1,w):
gu:=[op(gu),seq(ot1,j=1..num)]:
od:
gu:
end:
 
 
#ParentOfBoy(w):Given a Male word-segment w, (i.e. not starting
#with a comma) finds the  corresponding
#segment in JHC^(-1)(...w...), assuming that it is Female
 
 
ParentOfBoy:=proc(w)
local gu,i,num,ot1,j:
gu:=[op(1,w)]:
 
for i from 1 to trunc((nops(w)-1)/2) do
ot1:=op(2*i+1,w):
num:=op(2*i,w):
gu:=[op(gu),seq(ot1,j=1..num)]:
od:
gu:
end:
 
 
 
 
#badFemale(w): Given a Female word-segment w,
# decides whether it is surely not
#a factor  of JHC(v) for some v, i.e. it looks whether there
#exists an i s.t. w[2*i]=w[2*i+2]. If it is bad, it returns 1
#otherwise, it returns 0
 
badFemale:=proc(w)
local i:
for i from 1 to trunc(nops(w)/2)-1 do
  if op(2*i,w)=op(2*i+2,w) then
   RETURN(1):
  fi:
od:
0:
end:
 
 
#badMale(w): Given a Male word-segment w,
# decides whether it is surely not
#a factor  of JHC(v) for some v, i.e. it looks whether there
#exists an i s.t. w[2*i+1]=w[2*i+3]. If it is bad, it returns 1
#otherwise, it returns 0
 
badMale:=proc(w)
local i:
for i from 1 to trunc((nops(w)-1)/2) do
  if op(2*i-1,w)=op(2*i+1,w) then
   RETURN(1):
  fi:
od:
0:
end:
 
 
#ScreenMales(SetOfMales): Given a set of males, SetOfMales,
#kicks out all the bad ones
 
ScreenMales:=proc(SetOfMales)
local kv,i,w:
 
kv:={}:
 
for i from 1 to nops(SetOfMales) do
w:=op(i,SetOfMales):
 
if badMale(w)=0 then
kv:=kv union {w}:
fi:
od:
 
kv:
end:
 
 
 
#ScreenFemales(SetOfFemales): Given a set of males, SetOfMales
#kicks out all the bad ones
 
ScreenFemales:=proc(SetOfFemales)
local kv,i,w:
 
kv:={}:
 
for i from 1 to nops(SetOfFemales) do
w:=op(i,SetOfFemales):
 
if badFemale(w)=0 then
kv:=kv union {w}:
fi:
od:
 
kv:
end:
 
 
GadolNekeva:=proc(kv)
local w,i:
for i from 1 to nops(kv) do
w:=op(i,kv):
 if nops(w)<2 then
  RETURN(0):
 fi:
od:
1:
end:
 
 
GadolZakhar:=proc(kv)
local w,i:
for i from 1 to nops(kv) do
w:=op(i,kv):
 if nops(w)<3 then
  RETURN(0):
 fi:
od:
1:
end:
 
MidReject:=proc(w,i)
local j,Zakhar,Nekeva,Zakhar1,Nekeva1,k:
 
 
if i=0 then
RETURN(0):
fi:
 
Zakhar:={}:
Nekeva:={w}:
 
if badFemale(w)=1 and i>0 then
RETURN(1):
fi:
 
for j from 1 to i while GadolZakhar(Zakhar)=1 and GadolNekeva(Nekeva)=1 do
Zakhar1:={}:
Nekeva1:={}:
for k from 1 to nops(Zakhar) do
Zakhar1:= Zakhar1 union {ParentOfBoy(op(k,Zakhar))}:
Nekeva1:= Nekeva1 union {ParentOfBoy(op(k,Zakhar))}:
od:
 
for k from 1 to nops(Nekeva) do
Zakhar1:= Zakhar1 union {ParentOfGirl(op(k,Nekeva))}:
Nekeva1:= Nekeva1 union {ParentOfGirl(op(k,Nekeva))}:
od:
 
Zakhar:=ScreenMales(Zakhar1):
Nekeva:=ScreenFemales(Nekeva1):
 
if Zakhar={} and Nekeva={} then
RETURN(1):
fi:
od:
0:
end:
 
 
 
 
 
#GoodMid(k,i): Finds all the Female word-segments in {1,2,3} of k letters
#that may be factors of an
#atom in the decomposition of an i-day-old strings
 
GoodMid:=proc(k,i)
local se1,i1,se,w,w1,j1,j2:
option remember:
 
if not k mod 2=0 or k<0 then
ERROR(`First argument must be an even positive integer`):
fi:
 
if k=0 then
RETURN({[]}):
fi:
 
se:={}:
se1:=GoodMid(k-2,i):
 
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
 
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
if MidReject(w1,i)=0 then
 if SplitSegment(w1)=0 then
  se:=se union {w1}:
 fi:
 
fi:
od:
od:
 
 
od:
se:
end:
 
 
 
midsplit:=proc(L,R)
local n,m:
 
if nops(L)=0 or nops(R)=0 then
ERROR(`Both arguments must be non-empty lists`):
fi:
 
n:=op(nops(L),L):
m:=op(1,R):
 
if n=m then
 RETURN(0):
fi:
 
if n>=4 and m<=3 then
RETURN(1):
fi:
 
if n=2 then
 if m=1 and nops(R)>2 and op(2,R)<>1 and op(3,R)<>op(2,R) then 
   RETURN(1):
 fi:
 if m=1 and nops(R)>=3 and op(2,R)=1 and op(3,R)=1 then 
   RETURN(1):
 fi:
 
 if m=3 and 
( (nops(R)>=3 and op(2,R)=1 and op(3,R)=2) or
  (nops(R)>=3 and op(2,R)=1 and op(3,R)=3) or
  (nops(R)>=3 and op(2,R)=2 and op(3,R)=1) or
  (nops(R)>=3 and op(2,R)=2 and op(3,R)=3) or
#  
  (nops(R)>=4 and op(2,R)=1 and op(3,R)=1 and op(4,R)=2) or
  (nops(R)>=4 and op(2,R)=1 and op(3,R)=1 and op(4,R)=3) or
  (nops(R)>=4 and op(2,R)=2 and op(3,R)=2 and op(4,R)=1) or
  (nops(R)>=4 and op(2,R)=2 and op(3,R)=2 and op(4,R)=3) 
)
 then
        RETURN(1):
 fi:
 
 if m>=4 then
  RETURN(1):
 fi:
fi:
 
if n<>2 then
  if nops(R)>=5 and op(1,R)=2 and op(2,R)=2 and op(3,R)=1 and op(4,R)<>1
     and op(5,R)<>op(4,R)  then
      RETURN(1):
  fi:
 
 
 if nops(R)>=5 and op(1,R)=2 and op(2,R)=2 and op(3,R)=1 and op(4,R)=1
              and op(5,R)=1 then
    RETURN(1):
 fi:
 
##<>2][2^23^1X^(<>3)
if nops(R)>=5 and op(1,R)=2 and op(2,R)=2 and op(3,R)=3 and op(4,R)=1 and
           op(5,R)=2 then
 RETURN(1):
fi:
 
if nops(R)>=5 and op(1,R)=2 and op(2,R)=2 and op(3,R)=3 and op(4,R)=1 and
           op(5,R)=3 then
 RETURN(1):
fi:
 
if nops(R)>=5 and op(1,R)=2 and op(2,R)=2 and op(3,R)=3 and op(4,R)=2 and
           op(5,R)=1 then
 RETURN(1):
fi:
 
if nops(R)>=5 and op(1,R)=2 and op(2,R)=2 and op(3,R)=3 and op(4,R)=2 and
           op(5,R)=3 then
 RETURN(1):
fi:
 
if nops(R)>=6 and op(1,R)=2 and op(2,R)=2 and op(3,R)=3 and op(4,R)=1 and
           op(5,R)=1 and op(6,R)=2 then
 RETURN(1):
fi:
 
if nops(R)>=6 and op(1,R)=2 and op(2,R)=2 and op(3,R)=3 and op(4,R)=1 and
           op(5,R)=1 and op(6,R)=3 then
 RETURN(1):
fi:
 
if nops(R)>=6 and op(1,R)=2 and op(2,R)=2 and op(3,R)=3 and op(4,R)=2 and
           op(5,R)=2 and op(6,R)=1 then
 RETURN(1):
fi:
 
if nops(R)>=6 and op(1,R)=2 and op(2,R)=2 and op(3,R)=3 and op(4,R)=2 and
           op(5,R)=2 and op(6,R)=3 then
 RETURN(1):
fi:
# 
 
 
 if nops(R)>=3 and op(1,R)=2 and op(2,R)=2 and op(3,R)>=4 and
                     op(4,R)<>op(3,R)    then
                   
  RETURN(1):
 fi:
fi:
0:
end:
 
 
#SplitSegment(w) given a segment w, returns 1 if it can
#be split somewhere via midsplit, otherwise it returns 0
 
SplitSegment:=proc(w)
local i:
 
for i from 1 to nops(w)-1 do
if midsplit([op(1..i,w)],[op(i+1..nops(w),w)])=1 then
 RETURN(1):
fi:
od:
0:
end:
 
 
#FindMax(L): Finds the maximal length of a segment that may
#be a factor of an atom of an L-old string; In the meantime it
#prints the number of survivors of length i, for even i for
#i=2,4, ..., L
#that may be factors of an
#unsplitable atom of an i-day-old strings
 
FindMax:=proc(L)
local se1,i1,se,w,w1,j1,j2,gu,i2:
option remember:
 
gu:=[]:
 
 
se1:={[]}:
 
for i2 from 0 while se1<>{} do
se:={}:
gu:=[op(gu),nops(se1)]:
lprint(`The number of segments of length`, 2*i2, `that may be factors`):
lprint(` of an atom in the decomposition of an `,L, `-day-old string is:`):
lprint(nops(se1)):
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
 
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
if MidReject(w1,L)=0 then
 if SplitSegment(w1)=0 then
  se:=se union {w1}:
 fi:
 
fi:
od:
od:
 
od:
se1:=se:
od:
 
2*i2,gu:
end:
 
 
 
#Cosmo(L): Proves Conway's "Lost" cosmological theorem (by halting)
#L=8 turns out to work, so Cosmo(8); does the job )
#by finding  all female chunks of length 2i, i=1,2,3, ...
#that may
#be a factor of an atom of an L-day-old string; and checking each
#of them, w, for finite longevity, and the finite longevity
#of her Male extensions [i,op(w),j] of even-length (1<=i,j<=3) 
#and her Female  extension of odd length [op(w),i] (i=1,2,3)    
#and her Male  extension of odd length [i,op(w)] (i=1,2,3)
# The program halts if it reaches an i for which
# the set of successful female chunks of length 2i is empty
 
#The fact that it halted, together with the fact that all the 
#female chunks of even length accepted
#as well as their Male and Female
#extensions,  tested positively for finite longevity
#implies  Conway's Cosmological Theorem
#
#The reason is that the halting of the program implies that the
# set of atoms that occur in the decomposition of an L-day-old
# string is finite. 
# Furthermore, any such atom 
#must show up among those tested, since it does not
# split,  and it survives
# depth-L genealogical screening. Of course, the program does 
#lots of  unnecessary testing, but  every no atom  escapes testing.
#
#As a bonus, we have an upper bound for the maximum longevity
# of ANY string. It is:
# L+ the max. longevity of tested chunks +1 
#
#In order to keep us entertained during the long run of this 
#program, it 
#prints the number of accepted female-chunks of length 2i
#i=1,2, ..., 
# and the maximum longevity, to-date, encountered
 
 
Cosmo:=proc(L)
local se1,i1,se,w,w1,j1,j2,gu,i2,maxlife,ka:
option remember:
 
gu:=[]:
 
 
se1:={[]}:
 maxlife:=0:
 
for i2 from 0 while se1<>{} do
se:={}:
gu:=[op(gu),nops(se1)]:
lprint(`The number of female segments of length`, 2*i2, `that may be factors`):
lprint(` of an atom in the decomposition of an `,L, `-day-old string is:`):
lprint(nops(se1)):
lprint(`The largest longevity, so far, is`, maxlife):
lprint(``):
 
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
if member([op(3..nops(w1),w1)],se1) then
if SplitSegment(w1)=0 and MidReject(w1,L)=0  then
  ka:=max
(Life([1,op(w1)]),Life([2,op(w1)]),Life([3,op(w1)]),
Life([1,op(w1),1]),Life([1,op(w1),2]),Life([1,op(w1),3]),
Life([2,op(w1),1]),Life([2,op(w1),2]),Life([2,op(w1),3]),
Life([3,op(w1),1]),Life([3,op(w1),2]),Life([3,op(w1),3]),
Life([op(w1),1]),Life([op(w1),2]),Life([op(w1),3])
)
:
 if ka>10000 then
  print(`the string`,w1,`has life`,ka):
  RETURN(0):
 fi:
  if ka>maxlife then
   maxlife:=ka:
 fi:
 
 
 
  se:=se union {w1}:
 fi:
fi: 
od:
od:
od:
se1:=se:
od:
 
i2,gu:
end:
 
 
 
MaAncestor:=proc(w)
local w1,i:
 
w1:=w:
 
for i from 1 while nops(w1)>2 and
badFemale(w1)=0 and type(nops(w1)/2,integer) do
w1:=CHJ(w1):
od:
 
w1,i-1:
end:
 
#CosmoMethu(L): Like Cosmo, but with the additional feature
#that it looks for  strings of longest longevity (it is
#not guaranteed to find all  of them, only those that
#are of the form CHJ^a(w) for some a, and w in U_i(L)
 
CosmoMethu:=proc(L)
local se1,i1,se,w,w1,j1,j2,gu,i2,maxlife,ka,lu,maxsaba,ka1,Zkenim:
option remember:
 
Zkenim:={}:
 
gu:=[]:
 
 
se1:={[]}:
 maxlife:=0:
maxsaba:=0:
 
for i2 from 0 while se1<>{} do
se:={}:
gu:=[op(gu),nops(se1)]:
lprint(`The number of female segments of length`, 2*i2, `that may be factors`):
lprint(` of an atom in the decomposition of an `,L, `-day-old string is:`):
lprint(nops(se1)):
lprint(`The largest longevity, so far, is`, maxlife):
lprint(`The largest longevity of an ancestor is, so far, is`, maxsaba):
lprint(`The Methuselakhs are`, Zkenim):
 
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
if SplitSegment(w1)=0 and MidReject(w1,L)=0  then
  ka:=max
(Life([1,op(w1)]),Life([2,op(w1)]),Life([3,op(w1)]),
Life([1,op(w1),1]),Life([1,op(w1),2]),Life([1,op(w1),3]),
Life([2,op(w1),1]),Life([2,op(w1),2]),Life([2,op(w1),3]),
Life([3,op(w1),1]),Life([3,op(w1),2]),Life([3,op(w1),3]),
Life([op(w1),1]),Life([op(w1),2]),Life([op(w1),3])
)
:
 if ka>10000 then
  print(`the string`,w1,`has life`,ka):
  RETURN(0):
 fi:
  if ka>maxlife then
   maxlife:=ka:
 fi:
 
 
lu:=MaAncestor(w1):
 
ka1:=Life(w1)+lu[2]:
 
if ka1=maxsaba then
Zkenim:=Zkenim union {lu[1]}:
fi:
 
if ka1>maxsaba then
Zkenim:={lu[1]}:
maxsaba:=ka1:
fi:
 
  se:=se union {w1}:
 fi:
 
od:
od:
od:
se1:=se:
od:
 
i2,gu,Zkenim, maxsaba:
end:
 
 
 
 
#GoodMid1(k,i): Finds all the Female word-segments in {1,2,3} of k letters
#that may be factors of an
#atom in the decomposition of an i-day-old strings
 
GoodMid1:=proc(k,i)
local se1,i1,se,w,w1,j1,j2,lu,i2:
option remember:
 
if not k mod 2=0 or k<0 then
ERROR(`First argument must be an even positive integer`):
fi:
 
if k=0 then
RETURN({[]}):
fi:
 
se:={}:
se1:=GoodMid1(k-2,i):
 
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
 
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
 
lu:=1:
for i2 from 2 by 2 to k-4 do
 if not member([op(i2+1..k,w1)],GoodMid1(k-i2,i)) then
   lu:=0:
   break:
 fi:
od:
 
if lu=1 and MidReject(w1,i)=0 and SplitSegment(w1)=0 then
  se:=se union {w1}:
fi:
od:
od:
 
 
od:
se:
end:
 
 
###################NEW
 
 
#CosmoMethu1(L): Like CosmoMethu with a speeding up
 
CosmoMethu1:=proc(L)
local se1,i1,se,w,w1,j1,j2,gu,i2,maxlife,ka,lu,maxsaba,ka1,Zkenim:
option remember:
 
Zkenim:={}:
 
gu:=[]:
 
 
se1:={[]}:
 maxlife:=0:
maxsaba:=0:
 
for i2 from 0 while se1<>{} do
se:={}:
gu:=[op(gu),nops(se1)]:
lprint(`The number of female segments of length`, 2*i2, `that may be factors`):
lprint(` of an atom in the decomposition of an `,L, `-day-old string is:`):
lprint(nops(se1)):
lprint(`The largest longevity, so far, is`, maxlife):
lprint(`The largest longevity of an ancestor is, so far, is`, maxsaba):
lprint(`The Methuselakhs are`, Zkenim):
lprint(`The time is`, time()):
lprint(``):
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
if member([op(3..nops(w1),w1)],se1) then
if SplitSegment(w1)=0 and MidReject(w1,L)=0  then
  ka:=max
(Life([1,op(w1)]),Life([2,op(w1)]),Life([3,op(w1)]),
Life([1,op(w1),1]),Life([1,op(w1),2]),Life([1,op(w1),3]),
Life([2,op(w1),1]),Life([2,op(w1),2]),Life([2,op(w1),3]),
Life([3,op(w1),1]),Life([3,op(w1),2]),Life([3,op(w1),3]),
Life([op(w1),1]),Life([op(w1),2]),Life([op(w1),3])
)
:
 if ka>10000 then
  print(`the string`,w1,`has life`,ka):
  RETURN(0):
 fi:
  if ka>maxlife then
   maxlife:=ka:
 fi:
 
 
lu:=MaAncestor(w1):
 
ka1:=Life(w1)+lu[2]:
 
if ka1=maxsaba then
Zkenim:=Zkenim union {lu[1]}:
fi:
 
if ka1>maxsaba then
Zkenim:={lu[1]}:
maxsaba:=ka1:
fi:
 
  se:=se union {w1}:
 fi:
fi: 
od:
od:
od:
se1:=se:
od:
 
i2,gu,Zkenim, maxsaba:
end:
 
 
 
 
#CosmoNR(L): Fast, Non-rigorous version of Cosmo
 
CosmoNR:=proc(L)
local se1,i1,se,w,w1,j1,j2,gu,i2:
option remember:
 
 
gu:=[]:
 
 
se1:={[]}:
 
for i2 from 0 while se1<>{} do
se:={}:
gu:=[op(gu),nops(se1)]:
lprint(`The number of female segments of length`, 2*i2, `that may be factors`):
lprint(` of an atom in the decomposition of an `,L, `-day-old string is:`):
lprint(nops(se1)):
lprint(``):
for i1 from 1 to nops(se1) do
w:=op(i1,se1):
for j1 from 1 to 3 do
for j2 from 1 to 3 do
w1:=[op(w),j1,j2]:
if member([op(3..nops(w1),w1)],se1) then
if SplitSegment(w1)=0 and MidReject(w1,L)=0  then
  se:=se union {w1}:
 fi:
fi: 
od:
od:
od:
se1:=se:
od:
 
i2,gu:
end: