with(combinat): Help:=proc() if args = NULL then print(`HasScheme(pats,max_depth,max_gap_size), SeqS(scheme, n)`): elif args = 'HasScheme' then print(`HasScheme(pats,max_depth, max_gap_size) attempts to find a scheme to count the permutations avoiding all the patterns of pats with depth <= max_depth and gap restrictions of size <=max_gap_size. If it succeeds, it returns the scheme, and if it fails it returns FAIL along with the set of prefixes it was unable to reduce`): print(`For example, try`): print(`HasScheme({[1, 3, 4, 2], [3, 1, 2, 4]}, 4, 2);`): elif args = 'SeqS' then print(`SeqS(scheme, n) gives the first n terms of the enumeration sequence defined by scheme`): print(`For example, try`): print(`SeqS({[[1, 2], [[[0, 0, 1], 1, []]], [2, [1]]], [[2, 1], [[[0, 0, 0], 2, [1]]], [1, [1]]]},15);`) fi: end: ##Inspired by Dr. Z's procedure Wilf Wilf:=proc(n, pats) local old, o, i, cand, output: if n = 0 then return({[]}): fi: old := Wilf(n-1, pats): output := []: for o in old do for i from 1 to n do cand := [op(1.. i-1, o), n, op(i..(n-1), o)]: if newCheckAvoid(cand, pats) then output := [op(output), cand]: fi: od: od: return(output): end: WilfPlusByPrefix := proc(pats, pref, gaps) local j, old_pref, new_elt, old_gaps, old, prev, new_out, output: option remember: if pref = [] then return(Wilf(gaps[1], pats)): fi: old_pref := redu([op(2..-1, pref)]): new_elt := add(gaps[i], i =1..pref[1]) + pref[1]: old_gaps := [0$nops(gaps)-1]: for j from 1 to nops(gaps) do if j <= pref[1] then old_gaps[j] := old_gaps[j] + gaps[j]: else old_gaps[j-1] := old_gaps[j-1] + gaps[j]: fi: od: old := WilfPlusByPrefix(pats, old_pref, old_gaps): output := []: for prev in old do new_out := prev: for j from 1 to nops(new_out) do if new_out[j] >= new_elt then new_out[j] := new_out[j] + 1: fi: od: new_out := [new_elt,op(new_out)]: if InitCheckAvoid(new_out, pats) then output := [op(output), new_out]: fi: od: return(output): end: ##tests to see if perm contains some pattern in pats using the largest element of perm newCheckAvoid:=proc(perm, pats) local n, i, n_ind, inds_avail, pat, pre_inds, pre_ind, subword, k, inds: n := max(perm): for i from 1 to n do if perm[i] = n then n_ind := i: break: fi: od: inds_avail:=[op({seq(i, i=1..n)} minus {n_ind})]: for pat in pats do k := nops(pat): pre_inds := choose(inds_avail, k-1): for pre_ind in pre_inds do inds := sort([op(pre_ind), n_ind]): subword := [seq(perm[i], i in inds)]: if pat = redu(subword) then return(false): fi: od: od: return(true): end: ##tests to see if perm contains some pattern in pats using the first element of perm InitCheckAvoid := proc(perm, pats) local inds, ind, pat, subword: for pat in pats do inds := choose(nops(perm)-1, nops(pat) - 1): for ind in inds do subword := [perm[1], seq(perm[i+1], i in ind)]: if redu(subword) = pat then return(false): fi: od: od: return(true): end: redu:=proc(perm) sort(sort(perm, output = permutation),output=permutation): end: GapVectorsBySum := proc(len, tot) local output, i, old, o: if tot = 0 then return([[0$len]]): fi: if len = 1 then return([tot]): fi: output := []: for i from 0 to tot do old := GapVectorsBySum(len-1, tot-i): for o in old do output := [op(output), [i, op(o)]]: od: od: return(output): end: AllGapVectors := proc(len, max_tot) local output, i: output := []: for i from 0 to max_tot do output := [op(output), op(GapVectorsBySum(len, i))]: od: return(output): end: RestrictedGapVectors := proc(len, max_tot, restrict) local restrict_sum, i, pre_vectors, pv, output: option remember: restrict_sum := add(restrict[i], i=1..nops(restrict)): if restrict_sum > max_tot then return([]) fi: pre_vectors := AllGapVectors(len, max_tot - restrict_sum): output := []: for pv in pre_vectors do output := [op(output), pv+restrict]: od: return(output): end: ReverseRestrictedGapVectors := proc(len, max_tot, restricts) local cands, cand, output, forbid, restrict: option remember: cands := AllGapVectors(len, max_tot): forbid := {seq(op(RestrictedGapVectors(len, max_tot, restrict)), restrict in restricts)}: output := []: for cand in cands do if not member(cand, forbid) then output := [op(output), cand]: fi: od: return(output): end: Refine := proc(perm) local output, new_perm, i,j: output := []: for i from 1 to nops(perm)+1 do new_perm := perm: for j from 1 to nops(new_perm) do if new_perm[j] >= i then new_perm[j] := new_perm[j] +1: fi: od: output := [op(output), [op(new_perm),i]]: od: return(output): end: #naive_scheme.txt #same as naive_scheme.jl, but written in Maple #read `utils.txt`: CheckEquivalenceDown := proc(pats, pref1, pref2, collapsed_ind, restrict) local vecs2check, pat, v, filler1, v2, filler2, i: vecs2check := RestrictedGapVectors(nops(pref1)+1, max([seq(nops(pat), pat in pats)])+add(restrict[i],i=1..nops(restrict)) -1, restrict): for v in vecs2check do filler1 := [seq(redu([op(nops(pref1)+1..-1, w)]), w in WilfPlusByPrefix(pats, pref1,v))]: v2 := [0$ nops(v)-1]: for i from 1 to collapsed_ind do v2[i] := v2[i] + v[i]: od: for i from collapsed_ind + 1 to nops(v) do v2[i-1] := v2[i-1] + v[i]: od: filler2 := [seq(redu([op(nops(pref2)+1..-1, w)]), w in WilfPlusByPrefix(pats, pref2,v2))]: #print(filler1, filler2): if filler1 <> filler2 then return(false): fi: od: return(true): end: CheckEquivalenceUp := proc(pats, pref1, pref2, collapsed_ind, restricts) local vecs2check, pat, v, filler1, v2, filler2, i: vecs2check := ReverseRestrictedGapVectors(nops(pref1)+1, max([seq(nops(pat), pat in pats)])-1, restricts): for v in vecs2check do filler1 := [seq(redu([op(nops(pref1)+1..-1, w)]), w in WilfPlusByPrefix(pats, pref1,v))]: v2 := [0$ nops(v)-1]: for i from 1 to collapsed_ind do v2[i] := v2[i] + v[i]: od: for i from collapsed_ind + 1 to nops(v) do v2[i-1] := v2[i-1] + v[i]: od: filler2 := [seq(redu([op(nops(pref2)+1..-1, w)]), w in WilfPlusByPrefix(pats, pref2,v2))]: #print(filler1, filler2): if filler1 <> filler2 then return(false): fi: od: return(true): end: IsImpossibleDown := proc(pats, pref, r) if nops(WilfPlusByPrefix(pats, pref, r)) <> 0 then return(false): fi: return(true): end: IsImpossibleUp := proc(pats, pref, r) if {op(r)} = {0} then return(true): fi: if nops(WilfPlusByPrefix(pats,pref,[0$(nops(pref)+1)])) <> 0 then return(false): fi: return(true): end: IsLeaf := proc(pats, pref, max_gap_size) local pref_cands, restrict_cands, r, p, i, output, restricts_found, unreduced, redundant, r1: if pref = [] then return(false): fi: pref_cands := permute(nops(pref)-1): output:=[pref, [], []]: restrict_cands := RestrictedGapVectors(nops(pref)+1, max_gap_size, [0$(nops(pref)+1)]): restricts_found := []: for r in restrict_cands do redundant:=false: for r1 in restricts_found do if ArrayLess(r1,r) then redundant := true: break: fi: od: if redundant then next: fi: if IsImpossibleDown(pats,pref,r) then output[2]:=[op(output[2]), [r,1,[]]]: restricts_found := [op(restricts_found), r]: else unreduced:=true: for p in pref_cands while unreduced do for i from 1 to nops(pref) do if CheckEquivalenceDown(pats, pref, p, i, r) then output[2] := [op(output[2]), [r,i,p]]: restricts_found := [op(restricts_found), r]: unreduced:=false: break: fi: od: od: fi: od: if IsImpossibleUp(pats, pref, restricts_found) then output[3]:=[1,[]]: return(output): fi: for p in pref_cands do for i from 1 to nops(pref) do if CheckEquivalenceUp(pats, pref, p, i, restricts_found) then output[3] := [i, p]: return(output): fi: od: od: return(false): end: HasScheme1 := proc(pats, max_depth, max_gap_size, current_rules, current_need_reduction, current_found_reduction) local rules, need_reduction, found_reduction, pref, putative, opt, nr, unreduced: #print(current_rules, current_need_reduction, current_found_reduction): if current_need_reduction = {} then return(current_rules): fi: rules := current_rules: need_reduction := current_need_reduction: found_reduction := current_found_reduction: for pref in need_reduction do if nops(pref) > max_depth then unreduced:=need_reduction minus found_reduction: return([FAIL,current_rules,{seq(redu([op(1..max_depth, nr)]), nr in unreduced)}]): fi: putative := IsLeaf(pats, pref, max_gap_size): if putative <> false then rules := rules union {putative}: need_reduction := need_reduction minus {pref}: found_reduction := found_reduction union {pref}: for opt in putative[2] do need_reduction := need_reduction union {seq(opt[3], opt in putative[2])}: od: need_reduction := need_reduction union {putative[3][2]}: else need_reduction := need_reduction union {op(Refine(pref))}: found_reduction := found_reduction union {pref}: fi: od: need_reduction := need_reduction minus found_reduction: return(HasScheme1(pats,max_depth,max_gap_size, rules, need_reduction, found_reduction)): end: HasScheme := proc(pats, max_depth, max_gap_size) HasScheme1(pats, max_depth, max_gap_size, {}, {[]}, {}): end: SeqS := proc(scheme, n) local n1: seq(FindTerm1(scheme,[],[n1]), n1=1..n): end: FindTerm1:=proc(scheme, pref, gap) local i,j,rule,gap_restricts, down_collapsed_ind, down_pref, down_gap, up_collapsed_ind, up_pref, up_gap, output, refi, r, new_elt, new_gap,g: option remember: #print(pref,gap): for rule in scheme do if pref = rule[1] then gap_restricts := rule[2]: for g in gap_restricts do if ArrayLess(g[1], gap) then down_collapsed_ind := g[2]: down_pref := g[3]: if down_pref = [] then return(0): fi: down_gap := [0$nops(gap)-1]: for i from 1 to nops(gap) do if i <= down_collapsed_ind then down_gap[i] := down_gap[i] + gap[i]: else down_gap[i-1] := down_gap[i-1] + gap[i]: fi: od: return(FindTerm1(scheme, down_pref, down_gap)): fi: od: g := rule[3]: up_collapsed_ind := g[1]: up_pref := g[2]: if up_pref = [] then return(0): fi: up_gap := [0$nops(gap)-1]: for i from 1 to nops(gap) do if i <= up_collapsed_ind then up_gap[i] := up_gap[i] + gap[i]: else up_gap[i-1] := up_gap[i-1] + gap[i]: fi: od: return(FindTerm1(scheme, up_pref, up_gap)): fi: od: if add(gap[i], i=1..nops(gap)) = 0 then return(1): fi: output:=0: refi := Refine(pref): for r in refi do new_elt := r[-1]: new_gap := [0$(nops(gap)+1)]: for j from 1 to gap[new_elt] do for i from 1 to nops(gap)+1 do if i < new_elt then new_gap[i] := gap[i]: elif i = new_elt then new_gap[i] := j-1: elif i = new_elt +1 then new_gap[i] := gap[new_elt] - j: else new_gap[i] := gap[i-1]: fi: od: output := output + FindTerm1(scheme, r, new_gap): od: od: return(output): end: ArrayLess:=proc(arr1, arr2) local i: if nops(arr1) != nops(arr2) then print(`Two arrays must have the same size`): return(FAIL): fi: for i from 1 to nops(arr1) do if arr1[i] > arr2[i] then return(false): fi: od: return(true): end: Refine:=proc(perm) local i,j,output,new_perm: output := []: for i from 1 to nops(perm)+1 do new_perm := perm: for j from 1 to nops(new_perm) do if new_perm[j] >= i then new_perm[j] := new_perm[j] + 1 fi: od: output:=[op(output), [op(new_perm), i]]: od: return(output): end: ##Example Scheme for 123: {[[1, 2], [[[0, 0, 1], 1, []]], [2, [1]]], [[2, 1], [[[0, 0, 0], 2, [1]]], [1, [1]]]}