A Word Reconstruction Problem for Polynomial Regular Languages
by M. Golafshan, A. Huch, M. Rigo
Mathematica companion

Abstract: The reconstruction problem concerns the ability to uniquely determine an unknown word from querying information on the number of occurrences of chosen subwords. In this work, we focus on the reconstruction problem when the unknown word belongs to a known polynomial regular language, i.e., its growth function is bounded by a polynomial. Exploiting the combinatorial and structural properties of these languages, we are able to translate queries into polynomial equations and transfer the problem of unique reconstruction to finding those sets of queries such that their polynomial equations have a unique integer solution. Alongside combinatorial properties of the equations and polynomials we completely characterize which queries are necessary to uniquely reconstruct the word in the case of two loops. Further, we integrate techniques from real algebraic geometry and Tarski–Seidenberg Theorem on quantifier elimination to show that we can decide for a constant number of queries whether they suffice for a unique reconstruction.

Auxiliary functions to be evaluated first

(* Pascal formula to recursively compute binomial coefficients, Note: previous computations are stored in memory *)
BinomialWord[u_List,v_List] := BinomialWord[u, v] = 
	If[Length[v] == 0, 1, If[Length[u] < Length[v], 0, 
	BinomialWord[Drop[u, -1], v] + If[Last[u]===Last[v],1,0] BinomialWord[Drop[u, -1], Drop[v, -1]]]];

(* Split a list into k non-empty sublists, return all the possible ways to do so *)
splitRec[list_List,1]:={{list}};
splitRec[list_List,k_Integer]/;k>1:=Module[{n=Length[list],res={}},
Do[
With[{first=Take[list,i],rest=Drop[list,i]},
res=Join[res,Prepend[#,first]&/@splitRec[rest,k-1]]],{i,1,n-(k-1)}  
];
res]

(* Similar to the previous one but empty lists are allowed in the result *)
splitRecAllowEmpty[list_List,k_Integer]:=Module[{n=Length[list],res={}},(*If the list is empty,there is exactly one way:k empty blocks*)If[n==0,Return[{Table[{},{k}]}]];
(*If only one block left,it just gets whatever remains (possibly non\[Hyphen]empty)*)If[k==1,Return[{{list}}]];
(*Otherwise,choose a first block of length i=0..n,recurse on the remainder with k-1 blocks*)Do[With[{first=Take[list,i],rest=Drop[list,i]},res=Join[res,Prepend[#,first]&/@splitRecAllowEmpty[rest,k-1]]],{i,0,n}];
res]

(* Specific function from the paper, useful to compute the b polynomial below *)
α[v_,u_,i_]:=Apply[Plus,Map[Apply[Times,#]&,Map[BinomialWord[v ,#]&,splitRec[u,i],{2}]]]

(* polynomial introduced in the paper, v and u are words, coded by lists, and x is the variable *)
b[v_,{},x_]=1; (* !!! needed otherwise, it returns 0 !!! *)
b[v_,u_,x_]:=Sum[α[v,u,i]Binomial[x,i],{i,1,Length[u]}]//FunctionExpand//Expand

(* the main function building a multivariate polynomial equation *)
equation[language_List,u_List]:=
If[EvenQ[Length[language]],Print["The language list must have an odd number of components"],
Apply[Plus,Map[
Apply[Times,Table[If[OddQ[i],BinomialWord[language[[i]],#[[i]]],b[language[[i]],#[[i]],Subscript[x,i/2]]],{i,1,Length[language]}]]&,
splitRecAllowEmpty[u,Length[language]]
]]]

(* build an element of language of the form u_1 (v_1)^{l_1} ... u_n (v_n)^{l_n} u_{n+1} *)
elementLanguage[language_List,l_List]:=
Flatten[Table[If[OddQ[i],language[[i]],ConstantArray[language[[i]],l[[i/2]]]],{i,1,Length[language]}]]

(* The final equation associated with a query *)

Eq[language_,g_,q_]:=equation[language,q]-BinomialWord[g,q]

(* This function tests injectivity with a given list of queries -it automatically adapts the number of variables (locally called y and z) to the input language - so it certifies uniqueness of the reconstruction problem for a given language and set of queries *)

injectivity[language_List,queries_List]:=
Module[{var=Join[Table[y[i],{i,1,(Length[language]-1)/2}],Table[z[i],{i,1,(Length[language]-1)/2}]]},
If[OddQ[Length[language]],
Resolve[
Not[Exists[Evaluate[var],
And[
And@@Table[y[i]>=0&&z[i]>=0,{i,1,(Length[language]-1)/2}],
Or@@Table[y[i]!=z[i],{i,1,(Length[language]-1)/2}],
And@@
Map[(equation[language,#]/.Table[(Subscript[x, i])->y[i],{i,1,(Length[language]-1)/2}])==(equation[language,#]/.Table[(Subscript[x, i])->z[i],{i,1,(Length[language]-1)/2}])&,queries]
]]],Reals],
Print["The language list must have an odd number of components"]]]

Usage of the auxiliary functions, examples

BinomialWord : computing binomial coefficients

Compute the binomial coefficient of two words coded as lists:

BinomialWord[{0,1,1,0,1},{0,1}]

splitRec : all the possible ways to split a list into k non-empty parts

We split a list into a given number of non-empty lists, we return all the list of all the possibilities (each is a list of lists)

splitRec[{1,2,3,4},3]

If we split into to many parts, it returns an empty list :

splitRec[{1,2,3,4},5]

splitRec[{1,2,3,4},1]

splitRecAllowEmpty : all the possible ways to split a list into k (possibly empty) parts

Similar to the previous function, but here empty list are also allowed

splitRecAllowEmpty[{1,2,3,4},3]

splitRecAllowEmpty[{1,2,3,4},5]

the α[v,u,i] function

Here is a part of the paper where the function α[v,u,i] is defined:

α[{1,0,0,1},{0,0,1},2]

Table[α[{1,0,0,1},{0,0,1},i],{i,1,5}]

the b[v,u,i] function

The aim is to compute the following quantity

b[{1,0,0,1},{0,0,1},2]

equation : building an equation - one of the main functions of the paper - equation[language,q]

A language is given by a list of odd length : it encodes u_1, v_1, ... , u_n, v_n, u_{n+1} some lists can be empty lists

language={
{0},{0,0,1,0,0,1},{0,0,0,1,0,1,0,1,0,0,0,1,0,0,0,1,1,0}, {0,0,0,1,0,1,0,1,0},{0},{},{}
};

equation[language,{0}]

elementLanguage[language,list] : generating a word in the language from the exponents

g=elementLanguage[language,{3,2,3}]

equation[language,{0}]-BinomialWord[g,{0}]

Eq[language, g, q] = 0 : the complete equation associated with a query

language={
{0},{0,0,1,0,0,1},{0,0,0,1,0,1,0,1,0,0,0,1,0,0,0,1,1,0}, {0,0,0,1,0,1,0,1,0},{0},{},{}
};

Eq[language,elementLanguage[language,{3,2,3}],{0}]

Examples form the paper

Example 1

language={{0},{0,0,1},{1,1,0},{1,0,0,1},{0}};
q={0,1};

equation[language,q]

Eq[language,elementLanguage[language,{2,2}],q]

Now use the complete equation using Eq

ContourPlot[Eq[language,elementLanguage[language,{2,2}],q]==0,{(Subscript[x, 1]) ,-1,5},{(Subscript[x, 2]),-1,5}]

Now use the complete equation using Eq, we change the word to guess : the two exponents are given by an element of candidates. The query q is fixed.

Block[
{candidates={{3,0},{2,2},{3,2},{0,3}}},
Show[Table[
ContourPlot[
Eq[language,elementLanguage[language,candidates[[j]]],q]==0,
{(Subscript[x, 1]) ,-1,5},{(Subscript[x, 2]),-1,5},ContourStyle->Hue[j/Length[candidates]],Axes->True],{j,1,Length[candidates]}]]
]

Example 2

language={{0},{1,0,0,1,0},{0,1,0},{0,1,0},{}};

equation[language,{0}]

equation[language,{1,0}]

equation[language,{0,1,1}]//Expand

wordToGuess=elementLanguage[language,{4,3}]

BinomialWord[wordToGuess,{0}]

BinomialWord[wordToGuess,{1,0}]

BinomialWord[wordToGuess,{0,1,1}]

A system of equations (the word to guess is fixed, we change only the queries)

{Eq[language,wordToGuess,{0}]==0,Eq[language,wordToGuess,{1,0}]==0}

Solve[,{(Subscript[x, 1]), (Subscript[x, 2])}]

Block[
{queries={{0},{1,0},{0,1,1}}},
Show[
Join[
Table[
ContourPlot[
Eq[language,wordToGuess,queries[[j]]]==0,
{(Subscript[x, 1]) ,-10,15},{(Subscript[x, 2]),-20,20},ContourStyle->Hue[j/Length[queries]],PlotPoints->25,Axes->True],{j,1,Length[queries]}],
{Graphics[Point[{4,3}]]}]
]
]

Example 4

language={{0},{1,0,0,1,0},{0,1,0},{0,1,0},{}};

wordToGuess=elementLanguage[language,{4,3}]

Eq[language,wordToGuess,{0}]

Eq[language,wordToGuess,{1}]

Block[
{queries={{0},{1}}},
Show[
Join[
Table[
ContourPlot[
Eq[language,wordToGuess,queries[[j]]]==0,
{(Subscript[x, 1]) ,-10,15},{(Subscript[x, 2]),-20,20},ContourStyle->Hue[j/Length[queries]],PlotPoints->25],{j,1,Length[queries]}],
{Graphics[Point[{4,3}]]}]
]
]

language={{0},{1,1,0,0,0,0},{0,1,0},{0,0,1},{}};

wordToGuess=elementLanguage[language,{2,3}]

Eq[language,wordToGuess,{0}]

Eq[language,wordToGuess,{1}]

Eq[language,wordToGuess,{0,1}]

Block[
{queries={{0},{0,1}}},
Show[
Join[
Table[
ContourPlot[
Eq[language,wordToGuess,queries[[j]]]==0,
{(Subscript[x, 1]) ,-15,10},{(Subscript[x, 2]),-10,25},ContourStyle->Hue[j/Length[queries]],PlotPoints->25],{j,1,Length[queries]}],
{Graphics[Point[{2,3}]]}]
]
]

The use of Resolve - using the “injectivity test”

language={{0},{1,0,0,1,0},{},{0,1,0},{}};

This injectivity function tests whether a given list of queries leads to unique reconstruction for a given language. It is based on the following result:

injectivity[language,{{0},{1}}]

Indeed, the two equations are independent

equation[language,{0}]

equation[language,{1}]

A trivial test with twice the same query, so no injectivity !

injectivity[language,{{0},{0}}]

Randomly testing a large number of languages with three loops

You run a number of tests provided by nbTest ; we build 7 non-empty random words of random length at most maxLength. These words are u_1, v_1, u_2, v_2,u_3, v_3, u_4, the we test injectivity - here for the queries {0},{1}, {0,1} . It returns the numbers of queries where injectivity fails (the languages are stored in notCertified).

Block[{nbTest=100,maxLength=11,queries={{0},{1},{0,1}},randomlanguage,notCertified={}},
For[
i=1,i<nbTest,
randomlanguage=Map[Table[RandomInteger[{0,1}],#]&,Table[RandomInteger[maxLength-1]+1,7]];
If[Not[injectivity[randomlanguage,queries]],AppendTo[notCertified,randomlanguage]];
i++;];
notCertified//Length]

Now we add an extra query, then a fifth query

Block[{nbTest=100,maxLength=11,queries={{0},{1},{0,1},{0,0,1}},randomlanguage,notCertified={}},
For[
i=1,i<nbTest,
randomlanguage=Map[Table[RandomInteger[{0,1}],#]&,Table[RandomInteger[maxLength-1]+1,7]];
If[Not[injectivity[randomlanguage,queries]],AppendTo[notCertified,randomlanguage]];
i++;];
notCertified//Length]

Block[{nbTest=100,maxLength=11,queries={{0},{1},{0,1},{0,0,1},{0,1,1}},randomlanguage,notCertified={}},
For[
i=1,i<nbTest,
randomlanguage=Map[Table[RandomInteger[{0,1}],#]&,Table[RandomInteger[maxLength-1]+1,7]];
If[Not[injectivity[randomlanguage,queries]],AppendTo[notCertified,randomlanguage]];
i++;];
notCertified//Length]

Example 6

language={{0},{1,0,0,1,0},{0,1,0},{0,1,0},{1,0},{0,0,1},{1,1,0},{1,0,0,1},{0,1,0}};
injectivity[language,{{0},{1},{0,1},{0,1,1}}]

language={{0},{1,0,0,1,0},{0,1,0},{0,1,0},{1,0},{0,0,1,1},{1,1,0},{1,0,0,1},{0,1,0}};
injectivity[language,{{0},{1},{0,1},{0,1,1}}]

Timing[
Block[{nbTest=10,maxLength=9,nbLoops=4,queries={{0},{1},{2},{0,1},{0,2},{2,1}},randomlanguage,notCertified={}},
For[
i=1,i<nbTest,
randomlanguage=Map[Table[RandomInteger[{0,2}],#]&,Table[RandomInteger[maxLength-1]+1,2 nbLoops+1]];
If[Not[injectivity[randomlanguage,queries]],AppendTo[notCertified,randomlanguage]];
i++;];
notCertified//Length]]