This Notebook contains supplementary material related to the paper
"Relationships Between Six Areas" by Stanley Rabinowitz,
submitted to the Sangaku Journal of Mathematics  (http://www.sangaku-journal.com/) in June 2020.
 
This Notebook is Copyright © June 2020 by Stanley Rabinowitz (stan.rabinowitz@comcast.net) and is published with open access. This Notebook is distributed under the terms of the Creative Commons Attribution License which permits any use, distribution, and reproduction in any medium, provided the original author and the source are credited.

Now use Van Aubel' s Theorem to find e/f, g/h, and k/j in terms of a1, a2, b, b2, c1, c2.

Create a substitution that removes e, g, and k from an expression.

fixegk={e->f(c2/c1+a1/a2),g->h(b1/b2+a2/a1),k->j(c1/c2+b2/b1)};

Set up equations to find K, K2, K3, K4, K5,  K6 in terms of K1.

eq1=K==K1+K2+K3+K4+K5+K6;
eq2=K2/K1==a2/a1;
eq3=(K1+K2)/K3==e/f;
eq4=K4/K3==b2/b1;
eq5=(K3+K4)/K5==g/h;
eq6=K6/K5==c2/c1;

Create a substitution that removes K, K2, K3, K4, K5, and K6 from an expression, leaving only K1.

fixk=Solve[{eq1,eq2,eq3,eq4,eq5,eq6},{K,K2,K3,K4,K5,K6}][[1]]

Use Ceva’s Theorem to create a substitution that removes c2 from an expression.

Ceva=c2->a1 b1 c1/(a2 b2)

Proof of Lemma 3.3

lemma={K2,K3,K4,K5,K6}/.fixk//Simplify

(* Find all terms of a given degree in variables x1, x2, x3, x4 *)
(* with x4 appearing to at most degree 1 *)
findTerms[degree_]:=Module[{},
p=PadRight[{{x1,x2,x3,x4}},degree,{{x1,x2,x3}}];
q=Prepend[p,Times];
ans=Apply[Outer,q]//Flatten//DeleteDuplicates;
Return[ans];
]

findTerms[1]

findTerms[2]

findTerms[3]

findTerms[4]

findRelationAmong4Terms[degree_,term1_,term2_,term3_,term4_]:=Module[{},
xterms=findTerms[degree];
testSet={3.12345432112345678932217777,4.156789357812345678947838888,5.1322287630112345678956676666,6.103356218312345678960095555,7.18765432123412345678971124444};
(* Apply test set *)
{a1val,a2val,b1val,b2val,c1val}=testSet;
terms=xterms/.{x1->term1,x2->term2,x3->term3,x4->term4};
nterms=terms/.{a->a1+a2,b->b1+b2,d->a1 b1+a2 b2};
nterms=nterms/.{a1->a1val,a2->a2val,b1->b1val,b2->b2val,c1->c1val};
qu=Quiet[FindIntegerNullVector[nterms,20]];
If[Head[qu]===FindIntegerNullVector,(* Print["No relationship found."] *),
expr=qu.xterms;Print[" vector = ",qu];Print["   expr = ",expr];
ans=Solve[expr==0,x4][[1]]//Simplify;
Return[ans];];
];

aterms={K,K1,K2,K3,K4,K5,K6}/.fixk//Simplify;
{B,B1,B2,B3,B4,B5,B6}=aterms/K1

Discovery of Naotake’s Formula

findRelation[term1_,term2_,term3_,term4_]:=Module[{},
For[n=1,n≤6,n++,
formula=findRelationAmong4Terms[n,term1,term2,term3,term4];
If[formula=!=Null,Print["formula = ",formula];
Break[];
];
];
If[formula===Null,Print["No relationship found."],];
];

{A,A1,A2,A3,A4,A5,A6}={B,B1,B2,B3,B4,B5,B6}/.fixegk/.Ceva//Simplify;

findRelation[A1,A2,A3,A]

Naotake=expr/.{x1->K1,x2->K2,x3->K3,x4->K}

Discovery of Theorem 2.1

Discovery of the formula for K4

findRelation[A1,A2,A3,A4]

formula4=formula/.{x1->K1,x2->K2,x3->K3,x4->K4}

Discovery of the formula for K5

findRelation[A1,A2,A3,A5]

formula5=formula/.{x1->K1,x2->K2,x3->K3,x4->K5}

Discovery of the formula for K6

A6

findRelation[A1,A2,A3,A6]

formula6=formula/.{x1->K1,x2->K2,x3->K3,x4->K6}

Solve[Naotake==0,K3]//Simplify

Proof of formula for K4

expression4=formula4[[1,2]];
S=K4-expression4

Sprime=S/.{K1->B1,K2->B2,K3->B3,K4->B4}//Factor

Sprime=Sprime/.fixegk/.Ceva//Simplify

findRelation[A1,A3,A5,A]

findRelation[A1,A2,A4,A5]

findRelation[A1,A2,A4,A6]

Proof of formula for K5

expression5=formula5[[1,2]];
S5=K5-expression5

S5/.{K1->B1,K2->B2,K3->B3,K4->B4,K5->B5}/.fixegk/.Ceva//Simplify

Proof of formula for K6

expression6=formula6[[1,2]];
S6=K6-expression6

S6/.{K1->B1,K2->B2,K3->B3,K4->B4,K5->B5,K6->B6}/.fixegk/.Ceva//Simplify

Expressing K in terms of K1, K3, and K5

form135=Eliminate[{Naotake==0,K5==expression5},K2]

ans=First[form135]-Last[form135]//Simplify

ans2=Collect[ans,K,Simplify]

coef4=Coefficient[ans2,K^4]

coef3=Coefficient[ans2,K^3]

coef2=Coefficient[ans2,K^2]

coef1=Coefficient[ans2,K]

coef0=ans2/.K->0

c4symmetric=SymmetricReduction[coef4,{K1,K3,K5},{s1,s2,s3}]

c3symmetric=SymmetricReduction[coef3,{K1,K3,K5},{s1,s2,s3}]

c2symmetric=SymmetricReduction[coef2,{K1,K3,K5},{s1,s2,s3}]

c1symmetric=SymmetricReduction[coef1,{K1,K3,K5},{s1,s2,s3}]

c0symmetric=SymmetricReduction[coef0,{K1,K3,K5},{s1,s2,s3}]

const4=c4symmetric[[1]]

const3=c3symmetric[[1]]

exp1=c2symmetric[[2]]

const2=c2symmetric[[1]]+e1

exp2=c1symmetric[[2]]//Factor

const1=c1symmetric[[1]]+2s3 e2

const0=c0symmetric[[1]]

Expressing K in terms of K1, K2, and K4

form124=Eliminate[{Naotake==0,K4==expression4,K5==expression5,K6==expression6},{K3,K5,K6}]

ans124=Solve[form124,K]

ans124num=ans124[[1,1,2]]//Numerator//Factor

Expressing K in terms of K1, K3, and K6

form136=Eliminate[{Naotake==0,K4==expression4,K5==expression5,K6==expression6},{K2,K4,K5}]

ans136=Solve[form136,K]

ans136solution=ans136[[2,1,2]]

ans136num=ans136solution//Numerator

ans136den=ans136solution//Denominator//Factor

ans136den/(2K6)-K1^2 K3//Factor

ans136numFactor=ans136num/K1//Simplify

term2=Last[ans136numFactor]

radicand=First[Last[term2]]//Simplify

term1=ans136numFactor-term2

expanded=(term1-K1^2 K3^2)/K6//Expand

Collect[expanded,K3,Factor]