## Homework 20. 8-April-2012. Pat Devlin ## # I don't care about keeping my work private or not # Help:=proc(): print(`UA(k), AUA(k), IsImpliedPatter(pat1, pat2, B)`): print(`MinimalFP(B, FP)`): print(`SAW(n), isSelfAvoidingNextStep(Past, nextStep), isClosedPath(Path)`): print(`SAP(n)`): print(`GFsawd(d,T)`) end proc: HelpAll:=proc(): print(`powerSetOfAllPatternsOfLength(k), allPatternsOfLengthExactly(k)`): print(` AdjustBFP(a,B,FP,BFP) , GFun(A,B,FP,x) `): print(`GFunT(A,B,FP,T)`): end: with(combinat): ############# # Problem 1 # ############# UA:=proc(k) local Patterns, FP, goodPatterns: Patterns:=powerset(allPatternsOfLengthExactly(k)): goodPatterns:={}: for FP in Patterns do if(type(GFunT({0,1}, B, FP, T), polynom)) then goodPatterns:=goodPatterns union {FP}: fi: od: return goodPatterns: end proc: powerSetOfAllPatternsOfLength:=proc(k) local allPatterns, j: allPatterns:={}: for j from 0 to k do allPatterns:= allPatterns union allPatternsOfLengthExactly(j): od: return powerset(allPatterns): end proc: allPatternsOfLengthExactly:=proc(k) local smallerPatterns, allPatterns, S: option remember: if(k<=0) then return {}: fi: if(k=1) then return {[0], [1]}: fi: smallerPatterns:=allPatternsOfLengthExactly(k-1): allPatterns:={}: for S in smallerPatterns do allPatterns:=allPatterns union {[0, op(S)], [1, op(S)]}: od: return allPatterns: end proc: # Some outpus are... # # UA(1); # {{[0], [1]}} # # UA(2); # {{[0, 0], [0, 1], [1, 1]}, {[0, 0], [1, 0], [1, 1]}, {[0, 0], [0, 1], [1, 0], [1, 1]}} # # UA(3); # { # {[0, 0, 0], [0, 0, 1], [1, 0, 1], [1, 1, 1]}, {[0, 0, 0], [0, 1, 0], [0, 1, 1], [1, 1, 1]}, {[0, 0, 0], [0, 1, 0], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [1, 0, 0], [1, 0, 1], [1, 1, 1]}, {[0, 0, 0], [0, 0, 1], [0, 1, 0], [0, 1, 1], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 0], [1, 0, 1], [1, 1, 1]}, {[0, 0, 0], [0, 0, 1], [0, 1, 0], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 1], [1, 0, 1], [1, 1, 1]}, {[0, 0, 0], [0, 0, 1], [1, 0, 0], [1, 0, 1], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, {[0, 0, 0], [0, 1, 0], [0, 1, 1], [1, 0, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 1, 0], [0, 1, 1], [1, 0, 1], [1, 1, 1]}, {[0, 0, 0], [0, 1, 0], [0, 1, 1], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 1, 0], [1, 0, 0], [1, 0, 1], [1, 1, 1]}, {[0, 0, 0], [0, 1, 0], [1, 0, 0], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 1, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, {[0, 0, 0], [0, 1, 1], [1, 0, 0], [1, 0, 1], [1, 1, 1]}, # {[0, 0, 0], [1, 0, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, {[0, 0, 0], [0, 0, 1], [0, 1, 0], [0, 1, 1], [1, 0, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 0], [0, 1, 1], [1, 0, 1], [1, 1, 1]}, {[0, 0, 0], [0, 0, 1], [0, 1, 0], [0, 1, 1], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 0], [1, 0, 0], [1, 0, 1], [1, 1, 1]}, {[0, 0, 0], [0, 0, 1], [0, 1, 0], [1, 0, 0], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, {[0, 0, 0], [0, 0, 1], [0, 1, 1], [1, 0, 0], [1, 0, 1], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 1], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, {[0, 0, 0], [0, 0, 1], [1, 0, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 1, 0], [0, 1, 1], [1, 0, 0], [1, 0, 1], [1, 1, 1]}, {[0, 0, 0], [0, 1, 0], [0, 1, 1], [1, 0, 0], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 1, 0], [0, 1, 1], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, {[0, 0, 0], [0, 1, 0], [1, 0, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 1, 1], [1, 0, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, {[0, 0, 0], [0, 0, 1], [0, 1, 0], [0, 1, 1], [1, 0, 0], [1, 0, 1], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 0], [0, 1, 1], [1, 0, 0], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 0], [0, 1, 1], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 0], [1, 0, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 1], [1, 0, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 1, 0], [0, 1, 1], [1, 0, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]}, # {[0, 0, 0], [0, 0, 1], [0, 1, 0], [0, 1, 1], [1, 0, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1]} # } # # UA(4) took too long ############# # Problem 2 # ############# AUA:=proc(k) local Patterns, FP, goodPatterns, f, addThisOne: Patterns:=powerset(allPatternsOfLengthExactly(k)): goodPatterns:={}: for FP in Patterns do addThisOne:=false: f:=GFunT({0,1}, B, FP, T): if(type(f,polynom)) then addThisOne:=true: else addThisOne:=areAllRootsBig(denom(f), T): fi: if(addThisOne) then goodPatterns:=goodPatterns union {FP}: fi: od: return goodPatterns: end proc: areAllRootsBig:=proc(f, x) local L, k: L:=[fsolve(f=0, x)]: for k from 1 to nops(L) do if(evalf(abs(L[k]))<1) then return false: fi: od: return true: end proc: # # Some outputs are... # # AUA(1); # {{[0]}, {[1]},{[0], [1]}} # # AUA(2); # {{[0, 1]}, {[1, 0]}, {[0, 0], [0, 1]}, {[0, 0], [1, 0]}, {[0, 0], [1, 1]}, # {[0, 1], [1, 0]}, {[0, 1], [1, 1]}, {[1, 0], [1, 1]}, # {[0, 0], [0, 1], [1, 0]}, {[0, 0], [0, 1], [1, 1]}, {[0, 0], [1, 0], [1, 1]}, {[0, 1], [1, 0], [1, 1]}, {[0, 0], [0, 1], [1, 0], [1, 1]}} # # The output for AUA(3) is too big. # The outpus for AUA(4) took too long. ############# # Problem 3 # ############# IsImplied:=proc(pat1, pat2, B) local startIndex, i, p1, p2, thisSubstringWorks: p1:=trim(pat1, B): p2:=trim(pat2, B): if(p2=[]) then return true: fi: if(nops(p1) < nops(p2)) then return false: fi: for startIndex from 1 to (nops(p2) - nops(p1)+1) do thisSubstringWorks:=true: for i from 1 to nops(p1) do if((not (p2[startIndex+i] = B)) and (not (p1[i] = p2[i]))) then thisSubstringWorks:=false: fi: od: if(thisSubstringWorks) then return true: fi: od: return false: end proc: trim:=proc(pat, B): if(nops(pat) = 0) then return pat: fi: if(nops(pat) = 1) then if(pat[1]=B) then return []: else return pat: fi: fi: if(pat[1] = B) then return trim(pat[2..nops(pat)]): fi: if(pat[nops(pat)] = B) then return trim(pat[1..(nops(pat)-1)]): fi: end proc: ############# # Problem 4 # ############# MinimalFP:=proc(B, FP) local P1, P2, minimalSet, isNotImplied: minimalSet:={}: for P1 in FP do isNotImplied:=true: for P2 in FP do if(isImplied(P2, P1, B) and (not (P1 = P2))) then isNotImplied:=false: fi: od: if(isNotImplied) then minimalSet:= minimalSet union {P1}: fi: od: end proc: ############# # Problem 5 # ############# SAW:=proc(n) local nextSteps, nextStep, smallerWalks, walk, longerWalks: option remember: if(n<=0) then return {[]}: fi: nextSteps:={1, -1, 2, -2}: smallerWalks:=SAW(n-1): longerWalks:={}: for walk in smallerWalks do for nextStep in nextSteps do if(isSelfAvoidingNextStep(walk, nextStep)) then longerWalks:= longerWalks union {[op(walk), nextStep]}: fi: od: od: end proc: isSelfAvoidingNextStep:=proc(Past, nextStep) local i: for i from 1 to nops(Past) do if(isClosedPath([op(Past[i..nops(Past)]), nextStep])) then return false: fi: od: return true: end proc: isClosedPath:=proc(Path) local p, x, i: p:=add(x^(Path[i]), i=1..nops(Path)): if(expand(p) = expand(eval(p,x=1/x))) then return true: fi: return false: end proc: ############# # Problem 6 # ############# # The first 8 terms of SAW(n) are... # [SAW(1), SAW(2), ...] = [4, 12, 36, 100, 284, 780, 2172, 5916] # # This is sequence A001411 in Sloane ############# # Problem 7 # ############# # (We have on self-avoiding polygons with an odd perimeter because we need # #(1's) = #(-1's) and #(2's) = #(-2's) # Thus, the total number of steps is # 2*#(1's) + 2*#(2's) , which is even. SAP:=proc(n) local shorterWalks, walk, nextSteps, nextStep, goodPolygons, possiblePoly: nextSteps:={-1, 1, -2, 2}: if(n<=0) then return {[]}: fi: shorterWalks:=SAW(2*n-1): goodPolygons:={}: for walk in shorterWalks do for nextStep in nextSteps do possiblePoly:=[op(walk), nextStep]: if(isClosedPath(possiblePoly)) then goodPolygons:= goodPolygons union {possiblePoly}: fi: od: od: return goodPolygons: end proc: ############# # Problem 8 # ############# GFsawd:=proc(d,t) local A, B, FP, i: A:={1, -1, 2, -2}: FP:={}: for i from 1 to d do FP:=FP union SAP(i): od: return GFunT(A,B,FP,t): end proc: ############# # Problem 9 # ############# # GFsawd(d,T) for d=1, d=2, and d=3 are given by... # GFsawd(1,T) = # # GFsawd(1,t); # -(t + 1) / (3 t - 1) # # # GFsawd(2,t); # 2 3 # -( 2 t + 3 t + 2 t + 1) # ----------------------- # 3 2 # t + 2 t + 2 t - 1 # # # GFsawd(3,t); # 8 7 6 5 4 3 2 # -(8 t + 3 t - t + 8 t + 3 t + 4 t + 2 t + 2 t + 1) # ------------------------------------------------------ # 6 3 2 # (t + 1) (t + t - t + 3 t - 1) # # # GFsawd(4,t) took too much time ## ## From class 20 below ## #AdjustBFP(a,B,FP,BFP): inputs a letter a, a symbol B for #blank, a set of forbidden patterns FP, and another set #of forbidden patterns at the beginning #outputs the new BFP for the chopped word assuming #it starts with a AdjustBFP:=proc(a,B,FP,BFP) local NBFP,fp: NBFP:={}: if member([],BFP) then RETURN(FAIL): fi: for fp in FP union BFP do if fp[1]=a or fp[1]=B then NBFP:=NBFP union {fp[2..nops(fp)]}: fi: od: NBFP: end: #GFun(A,B,FP,x): inputs an alphabet A ( a set of symbols or numbers) #and a letter B (NOT in A) and a set of forbidden patterns #FP, and another symbol x (not in A union {B}) and outputs #a rational function in x[A[1]], ..., x[A[nops(A)]] such #the if you mtaylor it the coeff. of #x[A1]^a1*x[A2]^a2*... is the EXACT number of words in #the alphabet A, avoiding the patterns in FP with #a1 occurrences of A1, #a2 occurrences of A2, .... #For example #GFun({1},B,{},x); should output: #1/(1-x[1]); #GFun({1},B,{[1,1]},x); should output: #1+X[1] #weight([1,2,1,1])=x[1]*x[2]*x[1]*x[1] GFun:=proc(A,B,FP,x) local eq,var, F,S, ToDo,BFP,eq1,ABFP,a: #F[BFP]=generating function of all words in the alphabet A #that avoid FP and in addition avoid BFP #S, the set of BFPs that show up #f=1+x[1]*f+x[2]*f+...+x[n]*f #(1-x[1]-...-x[n])*f=1 #f=1/(1-x[1]-...-x[n]) #f=1/(1-n*t) (if x[1]=...=x[n]=t) eq:={}: S:={{}}: var:={}: ToDo:={{}}: while ToDo<>{} do BFP:=ToDo[1]: S:=S union {BFP}: eq1:=F[BFP]-1: var:=var union {F[BFP]}: for a in A do ABFP:=AdjustBFP(a,B,FP,BFP): if not member([],ABFP) then eq1:=eq1-x[a]*F[ABFP]: ToDo:=ToDo union {ABFP}: fi: od: ToDo:=ToDo minus S: eq:=eq union {eq1}: od: var:=solve(eq,var): subs(var,F[{}]): end: #GFunT(A,B,FP,T): inputs an alphabet A ( a set of symbols or numbers) #and a letter B (NOT in A) and a set of forbidden patterns #FP, and another symbol x (not in A union {B}) and outputs #a rational function in x[A[1]], ..., x[A[nops(A)]] such #the if you mtaylor it the coeff. of #T^(length) #For example #GFunT({1},B,{},T); should output: #1/(1-T); #GFun({1},B,{[1,1]},T); should output: #1+T GFunT:=proc(A,B,FP,T) local eq,var, F,S, ToDo,BFP,eq1,ABFP,a: #F[BFP]=generating function of all words in the alphabet A #that avoid FP and in addition avoid BFP #S, the set of BFPs that show up #f=1+x[1]*f+x[2]*f+...+x[n]*f #(1-x[1]-...-x[n])*f=1 #f=1/(1-x[1]-...-x[n]) #f=1/(1-n*t) (if x[1]=...=x[n]=t) eq:={}: S:={{}}: var:={}: ToDo:={{}}: while ToDo<>{} do BFP:=ToDo[1]: S:=S union {BFP}: eq1:=F[BFP]-1: var:=var union {F[BFP]}: for a in A do ABFP:=AdjustBFP(a,B,FP,BFP): if not member([],ABFP) then eq1:=eq1-T*F[ABFP]: ToDo:=ToDo union {ABFP}: fi: od: ToDo:=ToDo minus S: eq:=eq union {eq1}: od: var:=solve(eq,var): subs(var,F[{}]): end: