Problem of the week 1296

intro

Consider a 2 x12 rectangle with dotted lines marking the 24 squares.How many sets R are there such that R is connected, R is obtained by cutting on the dotted lines, and R contains at least one square at the left end and at least one square at the right end?
More generally for an m x n rectangle?

We read the strip as a list, read left to right, of letters, which fundamentally are lists of integers read top to bottom.

 A “component” of a word records, allegedly, the numbering of the components of the marked squares, if we chop off everything to the right. As a data structure, in a letter,
a component is just a list of the form { Value, { range, range,...}} where each range is a pair {min, max}  So for example, a letter might be {0,-1,-1,0,0,2,2,2,0,2,2,0,3} and in component form be {{-1,{{2,3}}},{2,{{6,8},{10,11}}},{3,{{13,13}}}}
A given component may have more than one range, but the implication is that these ranges are connected, somehow, to the left. 

The values of the digits give information about how they are connected. 0 means not filled; 
+- n means square is in the nth component from top of those components meeting that letter. If this component is connected to the left end of the strip, +n, if not, -n.

In the picture above, the letters are:

As a list of values  /   As a list of “components”
000010   /   { {1,{5,5}} }
meaning: only one component of the marked squares so far

(-1)00020   { {-1,{1,1}}, {2,{5,5}} }
(-1)00222  { {-1,{1,1}}, {2, {4,6}} }
(-1)00202   { {-1,{1,1}}, {2, {4,6}} }
meaning: taking this and everything to the left, there are two components
of marked squares, but the first is not connected to the end and is
labeled “minus”

111101  { {1, {{1,4},{6,6}}}
meaning: taking this and everything to the left, there is only one
component of marked squares, + since it meets the left end-- even though
it meets this strip in two different ranges. Etc.

A letter is well-formed iff the value of each non-zero component is well-defined (so distinct non-zero values are not adjacent).

There exists at least one positive component (otherwise, why bother?)

To determine whether two letters may meet:

We consider the letters in component form, a list of {value, list of ranges}. 
A left component and a right component meet if some pair of ranges overlap; 

All of the following conditions must be satisfied:

(a) all components on the right that have a positive value must meet some component on the left that has a positive value. (Positive components have to link back)
(b) positive components on the left cannot meet negative components on the right. (Once linked, always linked)
(c) each component on the left meets exactly one component on the right--- at least one so that components don’t disappear and at most one so that the numbering remains consistent.
(d) each component on the right has to be fully linked up through ranges on the left, to ensure consistency. 

A strip may only begin with letters having all positive components.
A strip may only end with letters having one positive component.

As a practical matter, we keep a list of  letters in component form, and words are lists of indices in this list.

set up

Clear[x];Protect[x]; (*needed for our generating functions*)

redefineLettersMatchQ:=(
(* Given a letter as a list of digits, produce a list in the form
{{value,{{start,end},...}},...}; if the letter is not well formed because distinct non-zero values are adjacent, then return {} *) 
Clear[components];
components[letter_]:=components[letter]=
(i=0;last =0;wellFormedQ=True;comps={};

If[#[[1]]≠0,wellFormedQ = wellFormedQ && (last==0);
AppendTo[comps,{last = #[[1]],i+1,i=i+Length[#]}],last=0;i=i+Length[#]]&/@
Split[letter];
If[wellFormedQ,
{v=#,#[[{2,3}]]&/@
Select[comps,#[[1]]==v&]}&/@
Union[#[[1]]&/@comps],{}]);
Clear[labels];
labels[n_]:=labels[n]=(i=0;
Drop[Nest[
(i++;
Join@@({Append[#,i],Append[#,-i]}&/@#)
)&,
{{}},n],-1]);
(*To make the letters, we generate all binary strings of length n, then write as a series of ranges, and take all partitions of these. For each (sorted) partition, we give the values ±1,±2, etc in order, in all possible choices of sign except all negative.
Finally, we reassamble these lists of components back into letters.
*)

 
(*letters is a presumed globally defined list of letters in component form*)

Clear[LettersMatchQ];
LettersMatchQ[L_,R_ (*as indices*)]:=(*LettersMatchQ[L,R]=*)
Module[{comp,l,r},
l=letters[[L]];r=letters[[R]];
((*all components on the right that have a positive value must meet some component on the left that has a positive value.(Positive components have to link back)

(There is at least one r component that is positive by assumption -- otherwise we have And@@{} which is True;)
*)
(And@@((comp=#;Select[l,(meetQ[#,comp]&&#[[1]]>0)&]≠{})&/@
Select[r,#[[1]]>0&])))
&&
((* positive components on the left cannot meet negative components on the right.(Once linked,always linked)
Equivalently, negative components on the right only meet negative components on the left. *)
(And@@((comp=#;Select[l,(meetQ[#,comp]&&#[[1]]>0)&]=={})&/@
Select[r,#[[1]]<0&])))
&&
((*each component on the left meets exactly one component on the right---at least one so that components don't disappear and at most one so that the numbering remains consistent.*)
And@@((comp=#; Length[Select[r,meetQ[#,comp]&]]==1)&/@l)
)

&&
(*Every component on the right is fully connected through components on the left: 
(So that the component numbering is consistent;the numbering might change,but will be the same for everything that had been connected before)
*)
(*(And@@((comp=#;(Select[l,fullymeetQ[comp,#]&]≠{})||
(comp[[1]]<0&& Length[comp[[2]]]==1 && Select[l,meetQ[comp,#]&]=={}))&/@r))*)

(And@@((comp=#;
(Length[comp[[2]]]==1 )(*only one range*)||(
(*or we must have that all of the ranges are connected up through components of l*)
(remaining=Drop[#[[2]],1];
next = {#[[2,1]]};
safety=0;
While[remaining≠{} && next≠{} && safety++<10,
new = {};
((*for each of the next ranges, get all of the l ranges meeting it, then 
all of the remaining ranges meeting those; add these to new and delete from remaining*)
range=#;
lmeet= Select[l,meetQ[{x,{range}},#]&];

new=Join[new,Intersection[remaining, (Join @@ ((comp = #;Select[remaining,meetQ[{x,{#}},comp]&])&/@lmeet))]];
)&/@next;
next = new; remaining=Complement[remaining,new]];
(*now, if there are any remaining, but next is done, then we do not match*)
remaining =={}
)
)
)&/@r))



]);

redefineLettersMatchQ;

letterFromComponents[components_,n_]:=ReplacePart[Table[0,n],
Join@@Join@@((v=#[[1]];((#->v)&/@(Range@@#))&/@#[[2]])&/@components)]

Needs["Combinatorica`"];

(*this returns the letters in component form*)
makeLetters[n_]:=
Join@@Join@@((
(redefineLettersMatchQ;
Table[{label[[i]],#[[i]]},{label,labels[Length[#]]},{i,Length[#]}])&/@SetPartitions[#])&/@
(components[#][[1,2]]&/@
Drop[Nest[Join@@({Append[#,0],Append[#,1]}&/@#)&,{{}},n],1]))

(*check if a letter is a legitimate start word;
each component must have all positive values, 
each value only on one component *)

startLetterQ[letter_(*in component form*)]:=
And@@((Length[#[[2]]]==1&&#[[1]]>0)&/@letter)

(*check if a letter is a legitimate end word;
there can only be one value-- by the letter 
construction, this will necessarily be positive.*)
endLetterQ[letter_(*in component form*)]:=Length[letter]==1;

(* Given two components of the form {value,{{start,end},...}}, determine if they touch at all*)

meetQ[comp1_,comp2_]:=Module[{a,b,c,d},
(*some segment in the first meets some segment in the second*)
Or@@(Join@@
 Outer[({{a,b},{c,d}}={#1,#2};
a≤c≤b||a≤d≤b||c≤a≤d||c≤b≤d)&,comp1[[2]],comp2[[2]],1])]

(*given two components, check if every interval of the first meets some interval of the second*)

fullymeetQ[comp1_,comp2_]:=

Module[{a,b,c,d},
And@@((Or@@#)&/@
Outer[({{a,b},{c,d}}={#1,#2};
a≤c≤b||a≤d≤b||c≤a≤d||c≤b≤d)&,comp1[[2]],comp2[[2]],1])]

(* this will make all words of a given length, out of given letters*)
MakeAllWords[letters_,1]:=Table[{i},{i,Length[letters]}];
MakeAllWords[letters_,n_?(#>1&)]:=
Module[{m=MakeAllWords[letters,n-1]},
Join @@ Table[
Append[#,j]&/@
Select[m,LettersMatchQ[#[[-1]],j]&],{j,Length[letters]}]
]

(*useful for making pictures*)
DrawWord[letters_,word_,letterLength_,All1Q_:True]:=ArrayPlot[If[All1Q,#/._?(#≠0&)->1,#]&@
(Transpose@
(letterFromComponents[#,letterLength]&/@letters[[word]])),ColorRules->{0->White,-1->GrayLevel[.2],1->GrayLevel[0],2->GrayLevel[.5],-2->GrayLevel[.6],3->GrayLevel[.73],-3->GrayLevel[.8]}]

LegitWordQ[start_,end_,word_]:=(start[[word[[1]]]]==1)&&(end[[word[[-1]]]]==1)

Options[produceStuff]={"useLaTeXQ"->False, "getGenFunctionQ"->False,"keepValuesQ"->True};
produceStuff[width_?(IntegerQ[#]&&#>1&),OptionsPattern[]]:=
Module[{p,q,pp,matrix,
useLaTeXQ=OptionValue["useLaTeXQ"],
getGenFunctionQ=OptionValue["getGenFunctionQ"],
keepValuesQ=OptionValue["keepValuesQ"]},
Clear[a];
If[!keepValuesQ||!(Head[lettersOfWidth[width]]===List),
letters=makeLetters[width];
start = Table[If[startLetterQ[letters[[i]]],1,0],{i,Length[letters]}];
end=Table[If[endLetterQ[letters[[i]]],1,0],{i,Length[letters]}];
If[!keepValuesQ,
lettersOfWidth[width]=Null;startOfWidth[width]=Null;endOfWidth[width]=Null;,
lettersOfWidth[width]=letters;startOfWidth[width]=start;endOfWidth[width]=end;],
letters=lettersOfWidth[width];start= startOfWidth[width];end = endOfWidth[width];];

Print["There are "<>ToString[Length[letters]]<>" letters of width "<>ToString[width]];

If[!keepValuesQ||!(Head[transitionsOfWidth[width]]===List),
(transitions=Parallelize@Table[If[LettersMatchQ[k,m],1,0],{k,Length[letters]},{m,Length[letters]}]);
If[!keepValuesQ, transitionsOfWidth[width]=Null,
transitionsOfWidth[width]=transitions];,
transitions=transitionsOfWidth[width];];

Print["The transition matrix is ",ArrayPlot[transitions]];

If[getGenFunctionQ,
Print["(If this takes too long, run with \"getGenFunctionQ\"->False)\nThe generating function for the sequence of lengths is "];
 vars=Table[ToExpression["x"<>ToString[i]],{i,Length[transitions]}];
genFunction=(start.(vars/.Solve[SparseArray[ IdentityMatrix[Length[transitions]]-x transitions].vars==end,vars][[1]]//Simplify)//Simplify);

Print[genFunction];

poly=Denominator[genFunction/.{x->1/x}//Simplify];,
(*otherwise, if !getGenFunctionQ *)
Print["Guessing the recurrence--- test the result. For the exact answer, run with the slower \"getGenFunctionQ\"->True\n"];
poly = Sort[If[NumberQ[(List@@#)[[-1]]],(List@@#)[[1]],#]&/@
(List@@#),Exponent[#1,x]>Exponent[#2,x]&][[1]]&@
(#&@@Abs[(CharacteristicPolynomial[transitions,x]//Factor)])];

Print["The asymptotic growth rate of the sequence is about "<>ToString[Sort[x/.N[Solve[poly==0,x],20]][[-1]]]<>"..."];

degree=Exponent[poly,x];

Print[({pre,post,header,lft,rght,tail}=If[useLaTeXQ,{"","","\n$a_n=","\\ a_{(n-",")}","$"},
{"(*","*)","\nClear[a];\na[n_]:=a[n]=","a[n-","]",";\n\n"}];
pre<>"A recurrence relation for the sequence is "<>post<>header<>(If[StringTake[#,1]=="+",StringDrop[#,1],#]&@((StringJoin@@(
If[!#=={},Which[StringTake[#,2]=="1a","+"<>StringDrop[#,1],
StringTake[#,3]=="-1a","-"<>StringDrop[#,2],
StringTake[#,1]=="-","-"<>StringDrop[#,1],
True,"+"<>#]&/@#,{}])&@
Join[If[#≠{},Reverse@#,{}]&@
If[#≠{},((ToString[-#/.x->1]<>lft<>ToString[degree-(#/(#/.x->1))[[2]]]<>rght))&/@#,{}]&@Select[List@@poly,degree>Exponent[#,x]>1&],
If[#≠{},((ToString[-#/.{x->1}])<>lft<>ToString[degree-1]<>rght)&/@#,{}]&@
Select[List@@poly,1==Exponent[#,x]&]]))<>If[(poly/.{x->0})>0,"-","+"]<>
If[Abs[(poly/.{x->0})]>1,ToString[Abs[(poly/.{x->0})]],""]<>lft<>ToString[degree]<>rght<>tail))

<>If[useLaTeXQ,"\\end{array}$\n",""]
<>
If[useLaTeXQ,"\\n","(*"]<>
"with initial terms "<>If[useLaTeXQ,"\n\n$\\begin{array}{rcl}\\\\","*)"]<>"\n",

matrix = DiagonalMatrix[Table[1,Length[transitions]]];
values={};
Table[AppendTo[values,
If[useLaTeXQ,"a_{"<>ToString[n]<>"} &=& ","a["<>ToString[n]<>"]="]<>ToString[start.matrix.end]<>
If[useLaTeXQ,"\\\\",";"]<>"\n"]; matrix=matrix.transitions,{n,degree}];
(StringJoin @@values)<>If[useLaTeXQ,"\\end{array}$\n",""]
]];
produceStuff[_]:="Not sure how to handle that width!";

produceStuff

how to use

The command produceStuff 
will produce:
* all the letters of a given width
* the transition matrix specifying which words may follow which, and the start and end vectors specifying which letters may begin and end a word
* the generating function for the sequence of the number of words of each given length.
* the asymptotic growth rate of the sequence
* a recurrence relation on the number of words of each given length
* and sufficiently many initial values of the sequence.

produceStuff[n] has  options: 

“useLaTeXQ”->True/False puts the recurrence relation in LATEX form/ mathematica input form. Defaults to False. (Note capitalization)

“getGenFunctionQ”->True/False gets the exact recurrence relation and its generating function (actually, with indices shifted by 1), by calculating start.(I- x transitions)^-1.end --- for n=7 this is intractable. Otherwise, a guess is made, by taking the largest factor of the characteristic polynomial of the transition matrix. Defaults to False.

“keepValuesQ”->True/False, whether or not to save the values for the transition matrix etc.

To check that the recurrence relation works, use:

With[{howFarDoYouWant=(*go past the initial conditions*) Exponent@poly+10},
matrix=DiagonalMatrix[Table[1,Length[transitions]]];
Table[a[k+1]-start.(matrix=transitions.matrix).end,{k,howFarDoYouWant}]].

n=2,3,4,5

produceStuff[2,"getGenFunctionQ"->True]

produceStuff[3,"keepValuesQ"->True,"useLaTeXQ"->False,"getGenFunctionQ"->True]

produceStuff[4,"getGenFunctionQ"->True]

produceStuff[5,"getGenFunctionQ"->True]

n=6

produceStuff[6]

n=7

produceStuff[7,"keepValuesQ"->True]

n=8

produceStuff[8]