print("Welcome to new_words, a Maple program by Lara Pudwell"):
print("for counting pattern-avoiding words"):
print(""):
print("This version was last updated on 12 October 2005"):
print("Try Help(); to see a list of available functions"):

Help:=proc()
print("words(n,k): gives all possible words of length n with k letters"):
print():
print():
print("gwords(n,k,S): gives all possible words of length n with k letters that avoid all patterns in the set S"):
print("note: gwords works very naively, values of n greater than 6 are not recommended"):
print():
print():
print("pats(k,S): gives all permuations equiv to {S} with k letters"):
print("e.g. pats(3,{[1,2],[2,1]}) returns {[1,2],[1,3],[2,3],[2,1],[3,1],[3,2]}"):
print():
print():
print("genfun(k,S,x): gives the generating function (with variable x) of words on k letters that avoid all patterns in S"):
print("e.g. genfun(3,{[1,1]},x) returns 6x^3+6x^2+3x+1"):
print("note that in this example, the coefficient of x^i is the number of words of length i on 3 letters that have no repeated letters"):
end:

with(combinat):

words:=proc(n, k) local alphaLi, i:
alphaLi:=[]:
for i from 1 to k do
alphaLi:=[op(alphaLi), i$n]:
od:
alphaLi:=permute(alphaLi, n):
#alphaLi is the list of possible words of length n with k letters.
end:

#(red, reduces Li)
red:=proc(Li) local i, temp, word, temp2, k, curr, rests:
temp:=sort(Li): temp2:=[1]: k:=1:
for i from 2 to nops(Li) do
 if temp[i]>temp[i-1] then k:=k+1: fi:
temp2:=[op(temp2), k]:
od:
word:=sort(Li):
rests:={}:
for i from 1 to nops(Li) do
 rests:=rests union {word[i]=temp2[i]}:
od:
word:=subs(rests, Li):
end:

pats:=proc(k,Li2) local word,i,j,newalpha,newpat,newword,letters,m,allpats,Li:
Li:={}:
for i from 1 to nops(Li2) do
 Li:={op(Li), red(Li2[i])}:
od:

allpats:={}:
for m from 1 to nops(Li) do

	word:=Li[m]:
	for i from 1 to k do
	word:=subs(i=x[i], word):
	od:
	#word is now the pattern in terms of x_i's

	newalpha:=choose(k,nops({op(word)})):
	#(this gives us the set of letters to work with in our new pattern set)

	newpat:={}:
	for i from 1 to nops(newalpha) do
	newword:=word:

	letters:=[seq(x[j]=newalpha[i][j], j =1..nops(newalpha[i]))]: 
	newword:=subs(letters,newword):

	newpat:={op(newpat), newword}:
	od:
	
	#newpat is the set of all possible permutations that are equivalent to Li[k]
allpats:=allpats union newpat:
od:

allpats:
end:

genfun:=proc(k,Li,x) local i, m:
option remember:
for i from 1 to nops(Li) do
 if nops(Li[i])=1 then return 1: fi:
od:

if nops(Li)=0 then
return 1/(1-x): 
fi:

m:=nops({op(Li[1])}):
for i from 1 to nops(Li) do
if nops({op(Li[i])})<m then m:=nops({op(Li2[i])}): fi:
od:

if k<m then return 1/(1-k*x):
fi:

func2({seq(i, i=1..k)},pats(k, Li),x):

end:

#func2 inputs "literal" patterns, not reduced and works recursively
func2:=proc(alphabe, Li,x) local i, tot, j, temppat, m, temppat2, finis, singles, newalphabe, newLi, newLi2, otherpat:
option remember:
tot:=0:

otherpat:={}:
for j from 1 to nops(alphabe) do
temppat:={}:
 for m from 1 to nops(Li) do
  if Li[m][1]=alphabe[j] then temppat:=temppat union{Li[m]}: else 
otherpat:=otherpat union {Li[m]}: fi:
 od:

temppat2:={}:
for m from 1 to nops(temppat) do:
 temppat2:=temppat2 union {[op(2..nops(temppat[m]), temppat[m])]}:
od:

if Li={} then return 0: fi:

singles:={}:
for i from 1 to nops(temppat2) do
 if nops(temppat2[i])=1 then singles:=singles union {op(temppat2[i])}: fi:
od:

#singles is the list of singleton patterns

temppat2:=temppat2 minus {[]}:
for i from 1 to nops(singles) do
 temppat2:=temppat2 minus {[singles[i]]}:
od:

newalphabe:=alphabe minus singles:
newLi:=temppat2 union Li:
newLi2:={}:

for i from 1 to nops(newLi) do
 if {op(newLi[i])} subset newalphabe then
  newLi2:={op(newLi2), newLi[i]}:
 fi:
od:

newLi:=newLi2:

#temppat2 is a set of chopped permutations beginning with letter j
# so the set of all words avoiding Li starting with j must avoid temppat2
#tot:=tot+func2(newalphabe, newLi):
#this should sum over all j to give a generating function

if nops(newalphabe)=0 then
	tot:=tot+x:
elif nops(newLi)=0 then
	tot:=tot+ (x/(1-(nops(newalphabe)*x))):
elif newalphabe = alphabe and newLi = Li then
	tot:=x*y+tot:
else
	tot:=tot+x*func2(newalphabe, newLi,x):
fi:
od:

tot:=solve(y=tot+1,y):
tot:
end:

#the set of words of length n with k letters avoiding Li
gwords:=proc(n,k,Li) local temp, poss, badw,i,j,m, tempword, s,tempw,t, 
Li2:
Li2:={}:
for i from 1 to nops(Li) do
 Li2:=Li2 union{red(Li[i])}:
od:

temp:=words(n,k):
badw:={}:

for i from 1 to nops(Li2) do
 for j from 1 to nops(temp) do
  poss:=choose({seq(m, m=1..nops(temp[j]))}, nops(Li2[i])): 
#poss is the set of all positions in temp of length of pattern i

for t from 1 to nops(poss) do
tempw:=temp[j]:
 tempword:=[]:
 for s from 1 to nops(poss[t]) do
  tempword:=[op(tempword), tempw[poss[t][s]]]:
 od:

 if red(tempword)=Li2[i] then badw:=badw union {temp[j]}: fi:
od:
 od:
od:

{op(temp)} minus badw:

end: