Materials for An Infinite Family of Perfect Parallelepipeds

Benjamin D. Sokolowsky, Amy G. VanHooft, Rachel M. Volkert, Clifford A. Reiter

Clear[p,m]

Section 2

Section 2.1

Initial Parameterization

(Subscript[e, 1])=2(Subscript[p, 1])(Subscript[p, 2]);
(Subscript[e, 2])=(Subscript[p, 2])^2-(Subscript[p, 1])^2;
(Subscript[e, 3])=(((Subscript[p, 1])(Subscript[p, 2])/s)^2-1)*s;
(Subscript[d, 12])=(Subscript[p, 2])^2+(Subscript[p, 1])^2;
(Subscript[d, 13])=(((Subscript[p, 1])(Subscript[p, 2])/s)^2+1)*s;
(Subscript[x, 1])=((Subscript[e, 2])+(Subscript[e, 3]))(2m)/(1+m^2)+((Subscript[e, 2])-(Subscript[e, 3]))(1-m^2)/(1+m^2);
(Subscript[x, 2])=((Subscript[e, 2])+(Subscript[e, 3]))(1-m^2)/(1+m^2)-((Subscript[e, 2])-(Subscript[e, 3]))(2m)/(1+m^2);
(Subscript[d, 23])=(Subscript[x, 1]);
(Subscript[d', 23])=(Subscript[x, 2]);

Pythagorian Equation and Parallelogram Law

Simplify[(Subscript[e, 1])^2+(Subscript[e, 2])^2==(Subscript[d, 12])^2]

Simplify[(Subscript[e, 1])^2+(Subscript[e, 3])^2==(Subscript[d, 13])^2]

Simplify[2(Subscript[e, 2])^2+2(Subscript[e, 3])^2==(Subscript[x, 1])^2+(Subscript[x, 2])^2]

Body Diagonals

Remove[e,d]

(Subscript[d, 12])=Sqrt[(Subscript[e, 1])^2+(Subscript[e, 2])^2];
(Subscript[d, 13])=Sqrt[(Subscript[e, 1])^2+(Subscript[e, 3])^2];
Simplify[D1=Sqrt[-(Subscript[e, 1])^2+(Subscript[e, 2])^2+(Subscript[e, 3])^2+(Subscript[d, 12])^2+(Subscript[d, 13])^2-(Subscript[d, 23])^2]]

Simplify[D4=Sqrt[3(Subscript[e, 1])^2+3(Subscript[e, 2])^2+3(Subscript[e, 3])^2-(Subscript[d, 12])^2-(Subscript[d, 13])^2-(Subscript[d, 23])^2]]

Simplify[D2=Sqrt[(Subscript[e, 1])^2-(Subscript[e, 2])^2+(Subscript[e, 3])^2+(Subscript[d, 12])^2-(Subscript[d, 13])^2+(Subscript[d, 23])^2]]

Simplify[D3=Sqrt[(Subscript[e, 1])^2+(Subscript[e, 2])^2-(Subscript[e, 3])^2-(Subscript[d, 12])^2+(Subscript[d, 13])^2+(Subscript[d, 23])^2]]

Section 2.2

Theorem 2.1

(Subscript[e, 1])=2(Subscript[p, 1])(Subscript[p, 2]);
(Subscript[e, 2])=(Subscript[p, 2])^2-(Subscript[p, 1])^2;
(Subscript[e, 3])=(((Subscript[p, 1])(Subscript[p, 2])/s)^2-1)*s;
(Subscript[d, 12])=(Subscript[p, 2])^2+(Subscript[p, 1])^2;
(Subscript[d, 13])=(((Subscript[p, 1])(Subscript[p, 2])/s)^2+1)*s;
(Subscript[x, 1])=((Subscript[e, 2])+(Subscript[e, 3]))(2m)/(1+m^2)+((Subscript[e, 2])-(Subscript[e, 3]))(1-m^2)/(1+m^2);
(Subscript[x, 2])=((Subscript[e, 2])+(Subscript[e, 3]))(1-m^2)/(1+m^2)-((Subscript[e, 2])-(Subscript[e, 3]))(2m)/(1+m^2);
(Subscript[d, 23])=(Subscript[x, 1]);
(Subscript[d', 23])=(Subscript[x, 2]);

(Subscript[p, 1])=p-1;
(Subscript[p, 2])=p+1;
s=((1-m^2)^2-4m^2)/(m(1-m^2))*p;
Simplify[D1]

Simplify[D4]

Simplify[D2]

Simplify[D3]

Body diagonals using (Subscript[d', 23])

Simplify[D1'=Sqrt[-(Subscript[e, 1])^2+(Subscript[e, 2])^2+(Subscript[e, 3])^2+(Subscript[d, 12])^2+(Subscript[d, 13])^2-(Subscript[d', 23])^2]]

Simplify[D4'=Sqrt[3(Subscript[e, 1])^2+3(Subscript[e, 2])^2+3(Subscript[e, 3])^2-(Subscript[d, 12])^2-(Subscript[d, 13])^2-(Subscript[d', 23])^2]]

Simplify[D2'=Sqrt[(Subscript[e, 1])^2-(Subscript[e, 2])^2+(Subscript[e, 3])^2+(Subscript[d, 12])^2-(Subscript[d, 13])^2+(Subscript[d', 23])^2]]

Simplify[D3=Sqrt[(Subscript[e, 1])^2+(Subscript[e, 2])^2-(Subscript[e, 3])^2-(Subscript[d, 12])^2+(Subscript[d, 13])^2+(Subscript[d, 23])^2]]

Final Parameterization

Simplify[(Subscript[e, 1])]

Simplify[(Subscript[e, 2])]

Simplify[Expand[(Subscript[e, 3])]]

Simplify[(Subscript[d, 12])]

Simplify[Expand[(Subscript[d, 13])]]

Simplify[(Subscript[d, 23])]

Embedding in 3-Space

len2[X_]:=Factor[X.X]
len[X_]:=Sqrt[len2[X]]
lena[u_,v_,w_]:={{"u",len[u]},{"v",len[v]},{"w",len[w]},
				{"u+v",len[u+v]},{"u-v",len[u-v]},{"u+w",len[u+w]},{"u-w",len[u-w]},{"v+w",len[v+w]},{"v-w",len[v-w]},
{"u+v+w",len[u+v+w]},{"u+v-w",len[u+v-w]},{"u-v+w",len[u-v+w]},{"u-v-w",len[u-v-w]}}
Assemble[x1_,x2_,x3_,d23_,d13_,d12_]:=Block[{rho,c23,c13,c12,u,v,w},
c12=(x1^2+x2^2-d12^2)/(2 x1 x2);
c13=(x1^2+x3^2-d13^2)/(2 x1 x3);
c23=(x2^2+x3^2-d23^2)/(2 x2 x3);
rho=(c23-c12 c13)/(Sqrt[1-c12^2]Sqrt[1-c13^2]);
u=x1{1,0,0};
v=x2{c12,Sqrt[1-c12^2],0};
w=x3{c13,rho Sqrt[1-c13^2],Sqrt[1-rho^2]Sqrt[1-c13^2]};
{u,v,w}]
Clear[u,v,w]

Clear[p,m]

{u,v,w}=Simplify[Assemble[(Subscript[e, 1]),(Subscript[e, 2]),(Subscript[e, 3]),(Subscript[d, 23]),(Subscript[d, 13]),(Subscript[d, 12])]];

u

v

w

MatrixForm[Simplify[lena[u,v,w]]]

h[p_,m_]=((3 (p^8)+3 (m^32) (p^8)-24 (m^6) (p^4) (3+45 (p^2)+334 (p^4)+45 (p^6)+3 (p^8))-24 (m^26) (p^4) (3+45 (p^2)+334 (p^4)+45 (p^6)+3 (p^8))+2 (m^4) (p^4) (3+76 (p^2)+630 (p^4)+76 (p^6)+3 (p^8))+2 (m^28) (p^4) (3+76 (p^2)+630 (p^4)+76 (p^6)+3 (p^8))-8 (m^2) ((p^6)+12 (p^8)+(p^10))-8 (m^30) ((p^6)+12 (p^8)+(p^10))+(m^16) (-70+560 (p^2)-640 (p^4)+32496 (p^6)+291614 (p^8)+32496 (p^10)-640 (p^12)+560 (p^14)-70 (p^16))+(m^8) (-1+8 (p^2)+176 (p^4)+3048 (p^6)+21398 (p^8)+3048 (p^10)+176 (p^12)+8 (p^14)-(p^16))+(m^24) (-1+8 (p^2)+176 (p^4)+3048 (p^6)+21398 (p^8)+3048 (p^10)+176 (p^12)+8 (p^14)-(p^16))+8 (m^10) (1-8 (p^2)+55 (p^4)+99 (p^6)+844 (p^8)+99 (p^10)+55 (p^12)-8 (p^14)+(p^16))+8 (m^22) (1-8 (p^2)+55 (p^4)+99 (p^6)+844 (p^8)+99 (p^10)+55 (p^12)-8 (p^14)+(p^16))+8 (m^14) (7-56 (p^2)+178 (p^4)-411 (p^6)+6874 (p^8)-411 (p^10)+178 (p^12)-56 (p^14)+7 (p^16))+8 (m^18) (7-56 (p^2)+178 (p^4)-411 (p^6)+6874 (p^8)-411 (p^10)+178 (p^12)-56 (p^14)+7 (p^16))-2 (m^12) (14-112 (p^2)+827 (p^4)+7932 (p^6)+61898 (p^8)+7932 (p^10)+827 (p^12)-112 (p^14)+14 (p^16))-2 (m^20) (14-112 (p^2)+827 (p^4)+7932 (p^6)+61898 (p^8)+7932 (p^10)+827 (p^12)-112 (p^14)+14 (p^16)))/((((1+(m^2)))^4) (((1-6 (m^2)+(m^4)))^2) (p^4) ((((p^2)+(m^8) (p^2)-(m^2) (1+10 (p^2)+(p^4))-(m^6) (1+10 (p^2)+(p^4))+2 (m^4) (1+17 (p^2)+(p^4))))^2)));

j[p_,m_]=(1/(2 m (-1+(m^2)) (((1-5 (m^2)-5 (m^4)+(m^6)))^2) (p^3)))((p^4)-8 (m^2) (p^4)-8 (m^14) (p^4)+(m^16) (p^4)+(m^8) (-6+24 (p^2)+98 (p^4)+24 (p^6)-6 (p^8))-(m^4) (1-4 (p^2)+10 (p^4)-4 (p^6)+(p^8))-(m^12) (1-4 (p^2)+10 (p^4)-4 (p^6)+(p^8))+4 (m^6) (1-4 (p^2)+24 (p^4)-4 (p^6)+(p^8))+4 (m^10) (1-4 (p^2)+24 (p^4)-4 (p^6)+(p^8)));

A[p_,m_]=(p^2)+(m^8) (p^2)-(m^2) (1+10 (p^2)+(p^4))-(m^6) (1+10 (p^2)+(p^4))+2 (m^4) (1+17 (p^2)+(p^4));

Lemma 2.2

Solve[2 m (-1+(m^2)) (((1-5 (m^2)-5 (m^4)+(m^6)))^2) ==0,m]

Solve[A[p,m]==0,p]

Plot1=ContourPlot[ A[p,m]==0,{m,-2,5},{p,-2,5},PlotPoints->500,FrameLabel->Automatic, ColorFunction->Function[Black]];

Lemma 2.3

Plot2=ContourPlot[h[p,m] ,{m,-2,5},{p,-2,5},Contours->{0},PlotPoints->200,FrameLabel->Automatic,ContourShading->{White,Black}];

Show[Plot1,Plot2]

Section 2.3

Theorem 2.6

p=6;
m=1/5;

m=1/5

Simplify[h[p,m]]

u

v

w

lena[u,v,w]

Theorem 2.7

Clear[p]

Simplify[h[p,m]]

Simplify[A[p,m]]

(Subscript[c, 23])[p_]=Simplify[v.w/(len[v]*len[w])]

(Subscript[c, 23])[6]

(Subscript[dc, 23])[p_]=Simplify[D[(Subscript[c, 23])[p],p]]

(Subscript[dc, 23])[6]

Section 3

Clear[p,m];
e1[p_,m_]=(Subscript[e, 1]);
e2[p_,m_]=(Subscript[e, 2]);
e3[p_,m_]=(Subscript[e, 3]);
d12[p_,m_]=(Subscript[d, 12]);
d13[p_,m_]=(Subscript[d, 13]);
d23[p_,m_]=(Subscript[d, 23]);

Lemma 3.1

p'=-p

Simplify[{e1[p,m]/e1[p',m],e2[p,m]/e2[p',m],e3[p,m]/e3[p',m],d12[p,m]/d12[p',m],d13[p,m]/d13[p',m],d23[p,m]/d23[p',m]}]

Lemma 3.2

p'=1/p

Simplify[{e1[p,m]/e1[p',m],e2[p,m]/e2[p',m],e3[p,m]/e3[p',m],d12[p,m]/d12[p',m],d13[p,m]/d13[p',m],d23[p,m]/d23[p',m]}]

Lemma 3.3

m'=-1/m

Simplify[{e1[p,m]/e1[p,m'],e2[p,m]/e2[p,m'],e3[p,m]/e3[p,m'],d12[p,m]/d12[p,m'],d13[p,m]/d13[p,m'],d23[p,m]/d23[p,m']}]

Lemma 3.4

m'=(1-m)/(1+m)

Simplify[{e1[p,m]/e1[p,m'],e2[p,m]/e2[p,m'],e3[p,m]/e3[p,m'],d12[p,m]/d12[p,m'],d13[p,m]/d13[p,m'],d23[p,m]/d23[p,m']}]

Lemma 3.5

m'=(1+m)/(m-1)

Simplify[{e1[p,m]/e1[p,m'],e2[p,m]/e2[p,m'],e3[p,m]/e3[p,m'],d12[p,m]/d12[p,m'],d13[p,m]/d13[p,m'],d23[p,m]/d23[p,m']}]

emb[p_,m_]:=Assemble[e1[p,m],e2[p,m],e3[p,m],d23[p,m],d13[p,m],d12[p,m]]

{u,v,w}=emb[6,1/5]

lena[u,v,w]

{u,v,w}=emb[1/6,1/5]

lena[u,v,w]

perf[p_,m_]:=Block[{},
{lab,lens}=Transpose[Apply[lena,emb[p,m]]];
Transpose[{lab,lens/Apply[GCD,lens]}]]

perf[6,1/5]

perf[1/6,1/5]

Section 5

Theorem 5.1

Simplify[Solve[j[p,m]==0,p]]

$Assumptions=Element[m,Rationals];

m'=-m;

p=(1/(Sqrt[2]))(√(-1/((m^2) (((-1+(m^2)))^2))(1-6 (m^4)-6 (m^6)+(m^8)+(Sqrt[1-14 (m^2)+47 (m^4)-4 (m^6)+47 (m^8)-14 (m^10)+(m^12)])+(m^2) (-6+(Sqrt[1-14 (m^2)+47 (m^4)-4 (m^6)+47 (m^8)-14 (m^10)+(m^12)])))));
FullSimplify[h[p,m]]

Solve[A[p,m]==0,m]

Simplify[{e1[p,m]/e1[p,m'],e2[p,m]/e2[p,m'],e3[p,m]/e3[p,m'],d12[p,m]/d12[p,m'],d13[p,m]/d13[p,m'],d23[p,m]/d23[p,m']}]

p=(1/(Sqrt[2]))(√(1/((m^2) (((-1+(m^2)))^2))(-1+6 (m^4)+6 (m^6)-(m^8)+(Sqrt[1-14 (m^2)+47 (m^4)-4 (m^6)+47 (m^8)-14 (m^10)+(m^12)])+(m^2) (6+(Sqrt[1-14 (m^2)+47 (m^4)-4 (m^6)+47 (m^8)-14 (m^10)+(m^12)])))));
FullSimplify[h[p,m]]

Solve[A[p,m]==0,m]

Simplify[{e1[p,m]/e1[p,m'],e2[p,m]/e2[p,m'],e3[p,m]/e3[p,m'],d12[p,m]/d12[p,m'],d13[p,m]/d13[p,m'],d23[p,m]/d23[p,m']}]

p=(1/(Sqrt[2]))(√(-1/((m^2) (((-1+(m^2)))^2))(-1+14 (m^4)+2 (m^6)-(m^8)+(Sqrt[1-6 (m^2)-17 (m^4)+108 (m^6)-17 (m^8)-6 (m^10)+(m^12)])+(m^2) (2+(Sqrt[1-6 (m^2)-17 (m^4)+108 (m^6)-17 (m^8)-6 (m^10)+(m^12)])))));
FullSimplify[h[p,m]]

Solve[A[p,m]==0,m]

Simplify[{e1[p,m]/e1[p,m'],e2[p,m]/e2[p,m'],e3[p,m]/e3[p,m'],d12[p,m]/d12[p,m'],d13[p,m]/d13[p,m'],d23[p,m]/d23[p,m']}]

p=(1/(Sqrt[2]))(√(1/((m^2) (((-1+(m^2)))^2))(1-14 (m^4)-2 (m^6)+(m^8)+(Sqrt[1-6 (m^2)-17 (m^4)+108 (m^6)-17 (m^8)-6 (m^10)+(m^12)])+(m^2) (-2+(Sqrt[1-6 (m^2)-17 (m^4)+108 (m^6)-17 (m^8)-6 (m^10)+(m^12)])))));

FullSimplify[h[p,m]]

Solve[A[p,m]==0,m]

Simplify[{e1[p,m]/e1[p,m'],e2[p,m]/e2[p,m'],e3[p,m]/e3[p,m'],d12[p,m]/d12[p,m'],d13[p,m]/d13[p,m'],d23[p,m]/d23[p,m']}]

Clear[p]

Plot4=ContourPlot[(1/(Sqrt[2]))(√(-1/((m^2) (((-1+(m^2)))^2))(-1+14 (m^4)+2 (m^6)-(m^8)+(Sqrt[1-6 (m^2)-17 (m^4)+108 (m^6)-17 (m^8)-6 (m^10)+(m^12)])+(m^2) (2+(Sqrt[1-6 (m^2)-17 (m^4)+108 (m^6)-17 (m^8)-6 (m^10)+(m^12)])))))==p,{m,0,2^(1/2)-1},{p,0,1},PlotPoints->200,FrameLabel->Automatic, ColorFunction->Function[White]];

Plot5=ContourPlot[h[p,m] ,{m,0,2^(1/2)-1},{p,0,1},Contours->{0},PlotPoints->150,FrameLabel->Automatic,ContourShading->{White,Black}];

Show[Plot5,Plot4]

m=1/5

p=(1/(Sqrt[2]))(√(-1/((m^2) (((-1+(m^2)))^2))(-1+14 (m^4)+2 (m^6)-(m^8)+(Sqrt[1-6 (m^2)-17 (m^4)+108 (m^6)-17 (m^8)-6 (m^10)+(m^12)])+(m^2) (2+(Sqrt[1-6 (m^2)-17 (m^4)+108 (m^6)-17 (m^8)-6 (m^10)+(m^12)])))))

Example after Theorem 5.3

rapprox[x_,n_]:=FromContinuedFraction[ContinuedFraction[x,n]]

rapprox[p,5]

c23[{p_,m_}]:=(e2[p,m]^2+e3[p,m]^2-d23[p,m]^2)/(2e2[p,m]e3[p,m])

180/Pi*ArcCos[c23[{1/6,1/5}]]//N

180/Pi*ArcCos[c23[{43/212,1/5}]]//N

N[180/Pi*ArcCos[c23[{rapprox[p,100],1/5}]],100]