WOLFRAM NOTEBOOK

In[]:=
EquationsFromSequences[seqs_List]:=Module[{u=Expand[Fold[{n,i}|->1+{a+bI,a-bI}[[i]]n,1,#]]&/@seqs,eqns},eqns=Thread[#==0]&/@(ComplexExpand[ReIm[First[#]]]&/@Union[SubtractSides/@DeleteCases[Flatten[Outer[Equal,u,u]],True|False]])]
In[]:=
AssociationPairings[func_,assoc_]:=With[{keys=Keys[assoc]},Association[#->func[assoc[#[[1]]],assoc[#[[2]]]]&/@Tuples[keys,2]]]
In[]:=
EquationsFromSequencesX[seqs_List]:=Module[{u=Association[#->Expand[Fold[{n,i}|->1+{a+bI,a-bI}[[i]]n,1,#]]&/@seqs],eqns},eqns=Thread[#==0]&/@(ComplexExpand[ReIm[First[#]]]&/@Union[SubtractSides/@DeleteCases[AssociationPairings[Equal,u],True|False]])]
In[]:=
EquationsFromSequencesX[Tuples[{1,2},2]]
Out[]=
{{1,1},{1,2}}{-2
2
b
0,2b+2ab0},{{1,1},{2,1}}{-2
2
b
0,2ab0},{{1,1},{2,2}}{True,2b+4ab0},{{1,2},{1,1}}{2
2
b
0,-2b-2ab0},{{1,2},{2,1}}{True,-2b0},{{1,2},{2,2}}{2
2
b
0,2ab0},{{2,1},{1,1}}{2
2
b
0,-2ab0},{{2,1},{1,2}}{True,2b0},{{2,1},{2,2}}{2
2
b
0,2b+2ab0},{{2,2},{1,1}}{True,-2b-4ab0},{{2,2},{1,2}}{-2
2
b
0,-2ab0},{{2,2},{2,1}}{-2
2
b
0,-2b-2ab0}
In[]:=
Association[First/@GatherBy[Normal[Solve[#,{a,b},Reals]&/@EquationsFromSequencesX[Tuples[{1,2},2]]],Last]]
Solve
:Equations may not give solutions for all "solve" variables.
Solve
:Equations may not give solutions for all "solve" variables.
Solve
:Equations may not give solutions for all "solve" variables.
General
:Further output of Solve::svars will be suppressed during this calculation.
Out[]=
{{1,1},{1,2}}{{b0}},{{1,1},{2,2}}a
-
1
2
if b>0||b<0
,{b0}
In[]:=
Fold[{n,u}|->1+{a+bI,a-bI}[[u]]n,{1,1}]
Out[]=
1+a+b
In[]:=
Fold[{n,u}|->1+{a+bI,a-bI}[[u]]n,{2,2}]
Out[]=
1+2(a-b)
In[]:=
Expand[%]
Out[]=
1+2a-2b
In[]:=
Quiet[Association[First/@GatherBy[Normal[Solve[#,{a,b},Reals]&/@EquationsFromSequencesX[Catenate[Table[Tuples[{1,2},m],{m,3}]]]],Last]]]
Out[]=
{{1},{2}}{{b0}},{{1},{1,1}}{{a0,b0}},{{1},{2,2}}{{a-1,b-1},{a-1,b1},{a0,b0}},{{1},{1,1,1}}{{a-1,b0},{a0,b0}},{{1},{1,1,2}}{{a-1,b-1},{a-1,b0},{a-1,b1},{a0,b0}},{{1},{2,2,2}}{a-1,b0},{a0,b0},a
-0.319
…
,b
-1.29
…
,a
-0.319
…
,b
1.29
…
,{{1,1},{2,2}}a
-
1
2
if b>0||b<0
,{b0},{{1,1},{1,1,2}}a-
2
3
,b-
2
3
,a-
2
3
,b
2
3
,{a0,b0},{{1,1},{2,2,2}}{a0,b0},a0,b-
2
,a0,b
2
,{{1,2},{1,1,1}}{a0,b0},a
-0.727
…
,b
-1.46
…
,a
-0.727
…
,b
1.46
…
,{{1,1,1},{1,1,2}}b
0 if a>-
1
2
||a<-
1
2
,a-
1
2
,b0,a-
1
2
,b-
3
2
,a-
1
2
,b
3
2
,{{1,1,1},{2,2,1}}a-
1
2
,b
0 if a>-
1
2
||a<-
1
2
,{{1,1,1},{2,2,2}}{b0},b-
1+2a+3
2
a
,b
1+2a+3
2
a
,{{1,1,2},{2,2,1}}b
0 if a∈
,b
-
1-
2
a
if -1<a<1
,b
1-
2
a
if -1<a<1
In[]:=
{Map[Row,First[#]],a+bI/.res[First[#]][[Last[#]]]}&/@{{{1},{2,2}}->2,{{1},{1,1,2}}->1,{{1},{2,2,2}}->3,{{1,1},{1,1,2}}->2,{{1,1},{2,2,2}}->3,{{1,2},{1,1,1}}->2,{{1,1,1},{1,1,2}}->4,{{1,1,1},{2,2,2}}->3,{{1,1,2},{2,2,1}}->3}
Out[]=
{{1,22},-1+},{{1,112},-1-},{1,222},
-1.29
…
+
-0.319
…
,{11,112},-
2
3
+
2
3
,{11,222},
2
,{12,111},
-1.46
…
+
-0.727
…
,{111,112},-
1
2
+
3
2
,{111,222},a+
1+2a+3
2
a
,{112,221},
a+
1-
2
a
if -1<a<1
{{{1,1,2},{2,2,1}},3}
In[]:=
-1.46
…
//RootReduce
In[]:=
-1.46
…
//MinimalPolynomial
Out[]=
-2+5
2
#1
-36
4
#1
+16
6
#1
&
In[]:=
N[%]
Out[]=
-1.45975
In[]:=
MinimalPolynomial
-1.29
…
Out[]=
-3-16
2
#1
-16
4
#1
+16
6
#1
&
In[]:=
-1.29
…
//InputForm
Out[]//InputForm=
Root[{1 + 4*#1 + 4*#1^2 + 4*#1^3 & , 2 + 2*#1 + 3*#1^2 - #2^2 & }, {1, 1}]
Root
In[]:=
ToRadicals
-1.29
…
Out[]=
-
1
2
3
4+
64
2/3
(1+3
57
)
+
2/3
(1+3
57
)
In[]:=
Simplify[%592]
Out[]=
-
1
2
3
4+
64
2/3
(1+3
57
)
+
2/3
(1+3
57
)
In[]:=
FullSimplify[%]
Out[]=
-1.29
…
In[]:=
Withz=-
1
2
+I,NestGraphTagged[n|->Together[{1+zn,1+Conjugate[z]n}],1,3,"StateLabeling"->True,GraphLayout->{"LayeredDigraphEmbedding","RootVertex"->1}]
Out[]=
In[]:=
Labeled[With[{z=Last[#]},NestGraphTagged[n|->Together[{1+zn,1+Conjugate[z]n}],1,3,"StateLabeling"->True,GraphLayout->{"LayeredDigraphEmbedding","RootVertex"->1}]],#]&/@​​{{1,22},-1+},{{1,112},-1-},{1,222},
-1.29
…
+
-0.319
…
,{11,112},-
2
3
+
2
3
,{11,222},
2
,{12,111},
-1.46
…
+
-0.727
…
,{111,112},-
1
2
+
3
2
,{111,222},a+
1+2a+3
2
a
,{112,221},
a+
1-
2
a
if -1<a<1
Out[]=
{{1,22},-1+}
,
{{1,112},-1-}
,
{1,222},
-1.29
…
+
-0.319
…
,
{11,112},-
2
3
+
2
3
,
{11,222},
2
,
{12,111},
-1.46
…
+
-0.727
…
,
{111,112},-
1
2
+
3
2
,
{111,222},a+
1+2a+3
2
a
,
{112,221},
a+
1-
2
a
if -1<a<1
Wolfram Cloud

You are using a browser not supported by the Wolfram Cloud

Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.


I understand and wish to continue anyway »

You are using a browser not supported by the Wolfram Cloud. Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.