Sequences Extrapolation and the Moser Problem

Polynomial extrapolation of a (((n+1))^th) length sequence

f[n_,m_]:=(Subscript[c, 0])  + (∑_(i=1)^n)(Subscript[c, i]) (m^i)  (*The general "n parameters" polynomial model*)

f[4,m]      (*The particular "5 parameters" polynomial model :*)

Exemple  : polynomial extrapolation of  the sequence 1, 2, 4, 8, 16

Solve[Table[f[4,m]==(2^(m-1)),{m,5}],Table[(Subscript[c, k]),{k,0,4}]]

f[4,m]/.{(Subscript[c, 0])->1,(Subscript[c, 1])->-(3/4),(Subscript[c, 2])->(23/24),(Subscript[c, 3])->-(1/4),(Subscript[c, 4])->(1/24)}          (*The 4th degree interpolation polynomial :*)

Table[1-((3 m)/4)+((23 (m^2))/24)-((m^3)/4)+((m^4)/24),{m,5}]     (*Check : it takes the imposed values 1, 2, 4, 8, 16 (when m=1,2,...,5)*)

Table[1-((3 m)/4)+((23 (m^2))/24)-((m^3)/4)+((m^4)/24),{m,8}]     (*Extrapolating further leads to "unexpected" results :*)

Mathematica is able to generalize the polynomial extrapolation to all degrees :

Clear[m];pol[m_]:=Table[Expand[InterpolatingPolynomial[Table[(2^k),{k,0,n}],m]],{n,6}]

Column[Table[pol[m]],{m,6}]        (*Extrapolating polynomials of degrees 1 to 6 :*)

Column[Table[Table[pol[m][[k]],{m,8}],{k,6}]]     (*The powers of two retreived by the model as the degree increases :*)

({{{1,2,3,4,5,6,7,8}}, {{1,2,4,7,11,16,22,29}}, {{1,2,4,8,15,26,42,64}}, {{1,2,4,8,16,31,57,99}}, {{1,2,4,8,16,32,63,120}}, {{1,2,4,8,16,32,64,127}}})

The Moser problem

One point is marked at the top of a circle. Six other points are marked at random. Chords are drawed. Points are successively removed one at a time : the figures are modified appropriately.

extpoints={{0,1},{-0.881215,0.472715},{-0.822516,-0.568742},{-0.123483,-0.992347},{0.553081,-0.833127},{0.936129,-0.351658},{0.978845,0.204605}}

f7=Graphics[{Circle[{0,0},1],PointSize[Large],Point[extpoints],Line[#]&/@Tuples[extpoints,2]}]

f6=Graphics[{Circle[{0,0},1],PointSize[Large],Point[Delete[extpoints,6]],Line[#]&/@Tuples[Delete[extpoints,6],2]}]

f5=Graphics[{Circle[{0,0},1],PointSize[Large],Point[Delete[extpoints,{{6},{5}}]],Line[#]&/@Tuples[Delete[extpoints,{{6},{5}}],2]}]

f4=Graphics[{Circle[{0,0},1],PointSize[Large],Point[Delete[extpoints,{{6},{5},{4}}]],Line[#]&/@Tuples[Delete[extpoints,{{6},{5},{4}}],2]}]

f3=Graphics[{Circle[{0,0},1],PointSize[Large],Point[Delete[extpoints,{{6},{5},{4},{3}}]],Line[#]&/@Tuples[Delete[extpoints,{{6},{5},{4},{3}}],2]}]

f2=Graphics[{Circle[{0,0},1],PointSize[Large],Point[Delete[extpoints,{{6},{5},{4},{3},{1}}]],Line[#]&/@Tuples[Delete[extpoints,{{6},{5},{4},{3},{1}}],2]}]

f1=Graphics[{Circle[{0,0},1],PointSize[Large],Point[Delete[extpoints,{{6},{5},{4},{3},{1},{2}}]],Line[#]&/@Tuples[Delete[extpoints,{{6},{5},{4},{3},{1},{2}}],2]}]

GraphicsGrid[{{f1,f2,f3,f4},{f5,f6,f7}}]

Expand[Binomial[m,4]+Binomial[m,2]+1]    (*The number of elementary surfaces in function of the number of points, m :*)

The Pascal triangle

pt=NestList[{0,##}+{##,0}&@@#&,{1},#]&;        (*Recursive programmation of Pascal's triangle*)

ptform[pt:{_List..}]:=With[{n=Length@Last@pt,long=Max@Map[StringLength@ToString@#&,pt,{2}]},Graphics[MapIndexed[Text[#,{#2-#/2,-#}&@@#2]&,pt,{2}],PlotRange->All,AspectRatio->0.7,BaseStyle->FontSize->Scaled[1.5/(n long)]]]     (*Design ot the triangle*)

MapAt[Style[#,Red,Bold]&,pt@10,Union[Table[{k,1},{k,1+10}],Table[{k,3},{k,3,1+10}],Table[{k,5},{k,5,1+10}]]]//ptform