四 I'm looking for the sympy of the tetrahedral (triangle pyramid) inscribed sphere.In other languages.
②I tried running it on the vba solver. Please tell me how to shorten the vba code.Only one example has been performed.
➂Failed to write "Range("A7").Formula" multiple lines of code below.
Thank you for your cooperation.
Original Post
(0,0,0), (1,0,0), (0,1,0), (0,0,2)
2021 Kyushu University/Science Mathematics Question 1(1)
https://www.densu.jp/kyusyu/21kyusyuspass.pdf
Reference
"CASIO>Flat expression containing three points, volume of tetrahedron formed at four points"
https://keisan.casio.jp/exec/system/1202458197
https://keisan.casio.jp/exec/system/1202458218
"Wolfram | Alpha"
https://ja.wolframalpha.com/input/?i=%280%2C0%2C0%2C%281%2C0%2C0%2C0%2C0%2C%2C1%2C0%2C0%2C0%2C0%2C2%29
https://ja.wolframalpha.com/input/?i=%E4%B8%89%E8%A7%92%E9%8C%90%EF%BC%880%2C0%2C0%2C0%2C0%2C0%2C0%2C0%2C0%2C%2C1%2C0%2C0%2C%2C0%2C0%2C2%29
Const Ax=0
Const Ay = 0
Const Az = 0
Const Bx = 1
Const By = 0
Const Bz = 0
Const Cx = 0
Const Cy = 1
Const Cz = 0
Const Dx = 0
Const Dy = 0
Const Dz = 2
Function myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
a=(By-Ay)*(Cz-Az)-(Cy-Ay)*(Bz-Az)
b=(Bz-Az)*(Cx-Ax)-(Cz-Az)*(Bx-Ax)
c=(Bx-Ax)*(Cy-Ay)-(Cx-Ax)*(By-Ay)
d=-(a*Ax+b*Ay+c*Az)
myHeimen=Array(a,b,c,d)
End Function
Function mySimentaiTaiseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiTaiseki=_
((x4-x1)*Abs(y2-y1)*(z3-z1)-(z3-z1)*(y3-y1)_
+ (y4-y1)*Abs(z2-z1)*(x3-x1)-(x2-x1)*(z3-z1)_
+ (z4-z1)*Abs(x2-x1)*(y3-y1)-(y2-y1)*(x3-x1)/6#
End Function
Function myDis(x1,y1,z1,x2,y2,z2)
myDis=Sqr(x1-x2)^2+(y1-y2)^2+(z1-z2)^2)
End Function
Function myHeron (x1, y1, z1, x2, y2, z2, x3, y3, z3)
s=(myDis(x1,y1,z1,x2,y2,z2) + myDis(x2,y2,z2,x3,y3,z3) + myDis(x3,y3,z3,x1,y1,z1)/2#
myHeron=Sqr(s*(s-myDis(x1,y1,z1,x2,y2,z2))*(s-myDis(x2,y2,z2,x3,y3,z3))*(s-myDis(x3,y3,z3,x1,y1,z1))))
End Function
Function mySimentaiMenseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiMenseki=_
myHeron(x1,y1,z1,x2,z2,x3,y3,z3)_
+ myHeron(x2,y2,z2,x3,z3,x4,y4,z4)_
+ myHeron(x3,y3,z3,x4,z4,x1,y1,z1)_
+ myHeron (x4, y4, z4, x1, y1, z1, x2, y2, z2)
End Function
Subaaa_Sankakusui()
Dim vD As Variant
Dim vA As Variant
Dim vB As Variant
Dim vC As Variant
ActiveSheet.Cells.Clear
'
MsgBox "Calculate the inscribed sphere of a tetrahedron (triangle pyramid) with a solver."
'
Range ("A1") = Ax
Range ("B1") = Ay
Range ("C1") = Az
Range ("A2") = Bx
Range ("B2") = By
Range ("C2") = Bz
Range ("A3") = Cx
Range ("B3") = Cy
Range ("C3") = Cz
Range ("A4") = Dx
Range ("B4") = Dy
Range ("C4") = Dz
Range("A5") = mySimentaiTaiseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
Range("B5") = mySimentaiMenseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
Range("C5").Formula="=A5*3.0/B5"
'
vD = myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
vA = myHeimen (Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
vB = myHeimen (Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
vC = myHeimen (Dx, Dy, Dz, Ax, Ay, Az, Bx, By, Bz)
' "
Range("E1") = vD(0)
Range("F1") = vD(1)
Range("G1") = vD(2)
Range("H1") = vD(3)
Range("E2") = vA(0)
Range("F2") = vA(1)
Range("G2") = vA(2)
Range("H2") = vA(3)
Range("E3") = vB(0)
Range("F3") = vB(1)
Range("G3") = vB(2)
Range("H3") = vB(3)
Range("E4") = vC(0)
Range("F4") = vC(1)
Range ("G4") = vC(2)
Range("H4") = vC(3)
Range("A7").Formula = "= (Abs(E1 * A6 + F1 * B6 + G1 * C6 + H1) / Sqrt(E1 ^ 2 + F1 ^ 2 + G1 ^ 2) - C5) ^ 2 + (Abs(E2 * A6 + F2 * B6 + G2 * C6 + H2) / Sqrt(E2 ^ 2 + F2 ^ 2 + G2 ^ 2) - C5) ^ 2 + (Abs(E3 * A6 + F3 * B6 + G3 * C6 + H3) / Sqrt(E3 ^ 2 + F3 ^ 2 + G3 ^ 2) - C5) ^ 2 + (Abs(E4 * A6 + F4 * B6 + G4 * C6 + H4) / Sqrt(E4 ^ 2 + F4 ^ 2 + G4 ^ 2) - C5) ^ 2"
Dimws As Worksheet:Sets=ActiveSheet
SolverReset
SolverOksetCell: =ws.Range("A7"),_
MaxMinVal: =3,_
ByChange: =ws.Range("A6:C6"), _
EngineDesc: = "GRG Nonlinear"
SolverSolve UserFinish: = True
End Sub
'Results
'Radius 0.249999801614916
'Central coordinates 0.2499997050.2499998220.249999802 of the sphere inscribed in the tetrahedron
vba solver (of 2)
The radius of the sphere has also been added to the cell (variable cell) to be changed.As a result, surface area and volume calculations are no longer required.
Const Ax=0
Const Ay = 0
Const Az = 0
Const Bx = 1
Const By = 0
Const Bz = 0
Const Cx = 0
Const Cy = 1
Const Cz = 0
Const Dx = 0
Const Dy = 0
Const Dz = 2
Function myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
a=(By-Ay)*(Cz-Az)-(Cy-Ay)*(Bz-Az)
b=(Bz-Az)*(Cx-Ax)-(Cz-Az)*(Bx-Ax)
c=(Bx-Ax)*(Cy-Ay)-(Cx-Ax)*(By-Ay)
d=-(a*Ax+b*Ay+c*Az)
myHeimen=Array(a,b,c,d)
End Function
Subaaa_Sankakusui()
Dim vD As Variant
Dim vA As Variant
Dim vB As Variant
Dim vC As Variant
ActiveSheet.Cells.Clear
'
MsgBox"'Calculate the inscribed sphere of the tetrahedron (triangle pyramid) with a solver."
'
Range ("A1") = Ax
Range ("B1") = Ay
Range ("C1") = Az
Range ("A2") = Bx
Range ("B2") = By
Range ("C2") = Bz
Range ("A3") = Cx
Range ("B3") = Cy
Range ("C3") = Cz
Range ("A4") = Dx
Range ("B4") = Dy
Range ("C4") = Dz
'
vD = myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
vA = myHeimen (Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
vB = myHeimen (Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
vC = myHeimen (Dx, Dy, Dz, Ax, Ay, Az, Bx, By, Bz)
' "
Range("E1") = vD(0)
Range("F1") = vD(1)
Range("G1") = vD(2)
Range("H1") = vD(3)
Range("E2") = vA(0)
Range("F2") = vA(1)
Range("G2") = vA(2)
Range("H2") = vA(3)
Range("E3") = vB(0)
Range("F3") = vB(1)
Range("G3") = vB(2)
Range("H3") = vB(3)
Range("E4") = vC(0)
Range("F4") = vC(1)
Range ("G4") = vC(2)
Range("H4") = vC(3)
Range("A7").Formula = "= (Abs(E1 * A6 + F1 * B6 + G1 * C6 + H1) / Sqrt(E1 ^ 2 + F1 ^ 2 + G1 ^ 2) - D6) ^ 2 + (Abs(E2 * A6 + F2 * B6 + G2 * C6 + H2) / Sqrt(E2 ^ 2 + F2 ^ 2 + G2 ^ 2) - D6) ^ 2 + (Abs(E3 * A6 + F3 * B6 + G3 * C6 + H3) / Sqrt(E3 ^ 2 + F3 ^ 2 + G3 ^ 2) - D6) ^ 2 + (Abs(E4 * A6 + F4 * B6 + G4 * C6 + H4) / Sqrt(E4 ^ 2 + F4 ^ 2 + G4 ^ 2) - D6) ^ 2"
Dimws As Worksheet:Sets=ActiveSheet
SolverReset
SolverOksetCell: =ws.Range("A7"),_
MaxMinVal: =3,_
ByChange: =ws.Range("A6:D6"), _
EngineDesc: = "GRG Nonlinear"
SolverSolve UserFinish: = True
End Sub
'Results
'Radius 0.24999512642834
The central coordinates of the sphere inscribed in the tetrahedron 0.2500002010.24999420.249998773
vba solver (of 3)
For (1) the fourth vertical line calculation was not required because the radius of the sphere was calculated.
Const Ax=0
Const Ay = 0
Const Az = 0
Const Bx = 1
Const By = 0
Const Bz = 0
Const Cx = 0
Const Cy = 1
Const Cz = 0
Const Dx = 0
Const Dy = 0
Const Dz = 2
Function myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
a=(By-Ay)*(Cz-Az)-(Cy-Ay)*(Bz-Az)
b=(Bz-Az)*(Cx-Ax)-(Cz-Az)*(Bx-Ax)
c=(Bx-Ax)*(Cy-Ay)-(Cx-Ax)*(By-Ay)
d=-(a*Ax+b*Ay+c*Az)
myHeimen=Array(a,b,c,d)
End Function
Function mySimentaiTaiseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiTaiseki=_
((x4-x1)*Abs(y2-y1)*(z3-z1)-(z3-z1)*(y3-y1)_
+ (y4-y1)*Abs(z2-z1)*(x3-x1)-(x2-x1)*(z3-z1)_
+ (z4-z1)*Abs(x2-x1)*(y3-y1)-(y2-y1)*(x3-x1)/6#
End Function
Function myDis(x1,y1,z1,x2,y2,z2)
myDis=Sqr(x1-x2)^2+(y1-y2)^2+(z1-z2)^2)
End Function
Function myHeron (x1, y1, z1, x2, y2, z2, x3, y3, z3)
s=(myDis(x1,y1,z1,x2,y2,z2) + myDis(x2,y2,z2,x3,y3,z3) + myDis(x3,y3,z3,x1,y1,z1)/2#
myHeron=Sqr(s*(s-myDis(x1,y1,z1,x2,y2,z2))*(s-myDis(x2,y2,z2,x3,y3,z3))*(s-myDis(x3,y3,z3,x1,y1,z1))))
End Function
Function mySimentaiMenseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiMenseki=_
myHeron(x1,y1,z1,x2,z2,x3,y3,z3)_
+ myHeron(x2,y2,z2,x3,z3,x4,y4,z4)_
+ myHeron(x3,y3,z3,x4,z4,x1,y1,z1)_
+ myHeron (x4, y4, z4, x1, y1, z1, x2, y2, z2)
End Function
Subaaa_Sankakusui()
Dim vD As Variant
Dim vA As Variant
Dim vB As Variant
Dim vC As Variant
ActiveSheet.Cells.Clear
'
MsgBox "Calculate the inscribed sphere of a tetrahedron (triangle pyramid) with a solver."
'
Range ("A1") = Ax
Range ("B1") = Ay
Range ("C1") = Az
Range ("A2") = Bx
Range ("B2") = By
Range ("C2") = Bz
Range ("A3") = Cx
Range ("B3") = Cy
Range ("C3") = Cz
Range ("A4") = Dx
Range ("B4") = Dy
Range ("C4") = Dz
Range("A5") = mySimentaiTaiseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
Range("B5") = mySimentaiMenseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
Range("C5").Formula="=A5*3.0/B5"
'
vD = myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
vA = myHeimen (Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
vB = myHeimen (Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
' "
Range("E1") = vD(0)
Range("F1") = vD(1)
Range("G1") = vD(2)
Range("H1") = vD(3)
Range("E2") = vA(0)
Range("F2") = vA(1)
Range("G2") = vA(2)
Range("H2") = vA(3)
Range("E3") = vB(0)
Range("F3") = vB(1)
Range("G3") = vB(2)
Range("H3") = vB(3)
Range("A7").Formula = "= (Abs(E1 * A6 + F1 * B6 + G1 * C6 + H1) / Sqrt(E1 ^ 2 + F1 ^ 2 + G1 ^ 2) - C5) ^ 2 + (Abs(E2 * A6 + F2 * B6 + G2 * C6 + H2) / Sqrt(E2 ^ 2 + F2 ^ 2 + G2 ^ 2) - C5) ^ 2 + (Abs(E3 * A6 + F3 * B6 + G3 * C6 + H3) / Sqrt(E3 ^ 2 + F3 ^ 2 + G3 ^ 2) - C5) ^ 2"
Dim ws As Worksheet: Set ws = ActiveSheet
SolverReset
SolverOk setCell:=ws.Range("A7"), _
MaxMinVal: =3,_
ByChange: =ws.Range("A6:C6"), _
EngineDesc: = "GRG Nonlinear"
SolverSolve UserFinish: = True
End Sub
'Results
'Radius 0.25
'Central coordinates 0.2499998190.24999810.250015 of the sphere inscribed in the tetrahedron
vba solver (of 4)
I made it a function.[A1 format] has been changed to [R1C1 format].
Const Ax=0
Const Ay = 0
Const Az = 0
Const Bx = 1
Const By = 0
Const Bz = 0
Const Cx = 0
Const Cy = 1
Const Cz = 0
Const Dx = 0
Const Dy = 0
Const Dz = 2
Function myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
a=(By-Ay)*(Cz-Az)-(Cy-Ay)*(Bz-Az)
b=(Bz-Az)*(Cx-Ax)-(Cz-Az)*(Bx-Ax)
c=(Bx-Ax)*(Cy-Ay)-(Cx-Ax)*(By-Ay)
d=-(a*Ax+b*Ay+c*Az)
myHeimen=Array(a,b,c,d)
End Function
Function mySimentaiTaiseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiTaiseki=_
((x4-x1)*Abs(y2-y1)*(z3-z1)-(z3-z1)*(y3-y1)_
+ (y4-y1)*Abs(z2-z1)*(x3-x1)-(x2-x1)*(z3-z1)_
+ (z4-z1)*Abs(x2-x1)*(y3-y1)-(y2-y1)*(x3-x1)/6#
End Function
Function myDis(x1,y1,z1,x2,y2,z2)
myDis=Sqr(x1-x2)^2+(y1-y2)^2+(z1-z2)^2)
End Function
Function myHeron (x1, y1, z1, x2, y2, z2, x3, y3, z3)
s=(myDis(x1,y1,z1,x2,y2,z2) + myDis(x2,y2,z2,x3,y3,z3) + myDis(x3,y3,z3,x1,y1,z1)/2#
myHeron=Sqr(s*(s-myDis(x1,y1,z1,x2,y2,z2))*(s-myDis(x2,y2,z2,x3,y3,z3))*(s-myDis(x3,y3,z3,x1,y1,z1))))
End Function
Function mySimentaiMenseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiMenseki=_
myHeron(x1,y1,z1,x2,z2,x3,y3,z3)_
+ myHeron(x2,y2,z2,x3,z3,x4,y4,z4)_
+ myHeron(x3,y3,z3,x4,z4,x1,y1,z1)_
+ myHeron (x4, y4, z4, x1, y1, z1, x2, y2, z2)
End Function
Function myR1C1 toA1(i,j)
myR1C1toA1 = Application.ConvertFormula ("R" & i& "C" & j, xlR1C1, xlA1)
End Function
Function myNainaisetukyu (igyo,iretu,x1,y1,z1,x2,y2,z2,x3,z3,x4,y4,z4)
Dim vD As Variant
Dim vA As Variant
Dim vB As Variant
Dim vC As Variant
'
myTaiseki = mySimentaiTaiseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
myMenseki = mySimentaiMenseki(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
myR = myTaiseki * 3# / myMenseki
vD = myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
vA = myHeimen(Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
vB = myHeimen(Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
'
myD = "(Abs(" & vD(0) & " * " & myR1C1toA1(igyo, iretu) & "+ " & vD(1) & " * " & myR1C1toA1(igyo, iretu + 1) & "+ " & vD(2) & " * " & myR1C1toA1(igyo, iretu + 2) & "+ " & vD(3) & ") / Sqrt(" & vD(0) & " ^ 2 + " & vD(1) & " ^ 2 +" & vD(2) & " ^ 2) - " & myR & ")"
myA = "(Abs(" & vA(0) & " * " & myR1C1toA1(igyo, iretu) & "+ " & vA(1) & " * " & myR1C1toA1(igyo, iretu + 1) & "+ " & vA(2) & " * " & myR1C1toA1(igyo, iretu + 2) & "+ " & vA(3) & ") / Sqrt(" & vA(0) & " ^ 2 + " & vA(1) & " ^ 2 +" & vA(2) & " ^ 2) - " & myR & ")"
myB = "(Abs(" & vB(0) & " * " & myR1C1toA1(igyo, iretu) & "+ " & vB(1) & " * " & myR1C1toA1(igyo, iretu + 1) & "+ " & vB(2) & " * " & myR1C1toA1(igyo, iretu + 2) & "+ " & vB(3) & ") / Sqrt(" & vB(0) & " ^ 2 + " & vB(1) & " ^ 2 +" & vB(2) & " ^ 2) - " & myR & ")"
Range(myR1C1toA1(igyo, iretu + 4)).Formula = "=" & myD & "^ 2 +" & myA & "^ 2 +" & myB & "^ 2"
'
Dim ws As Worksheet: Set ws = ActiveSheet
SolverReset
SolverOk setCell:=ws.Range(myR1C1toA1(igyo, iretu + 4)), _
MaxMinVal:=3, _
ByChange:=ws.Range(myR1C1toA1(igyo, iretu) & ":" & myR1C1toA1(igyo, iretu + 2)), _
EngineDesc:="GRG Nonlinear"
SolverSolve UserFinish:=True
myNainaisetukyu = Array(Range(myR1C1toA1(igyo, iretu)).Value, Range(myR1C1toA1(igyo, iretu + 1)).Value, Range(myR1C1toA1(igyo, iretu)).Value, myR)
End Function
Subaaa_Sankakusui()
Dim myXYZR As Variant
ActiveSheet.Cells.Clear
igyo=1
iretu=4
myXYZR=myNainaisetukyu(igyo,iretu,Ax,Ay,Az,Bx,By,Bz,Cx,Cy,Cz,Cx,Cy,Cz)
Cells(1,1) = Ax
Cells (1, 2) = Ay
Cells(1,3) = Az
Cells(2,1) = Bx
Cells(2,2) = By
Cells(2,3) = Bz
Cells(3,1) = Cx
Cells(3,2) = Cy
Cells(3,3) = Cz
Cells(4,1) = Dx
Cells(4,2) = Dy
Cells(4,3) = Dz
Cells(igyo,iretu+3) = myXYZR(3)
Cells(igyo,iretu+4)=""
End Sub
'Results
'Central coordinates and radius 0.2499998190.24999810.250000150.25 of the sphere inscribed in the tetrahedron
© 2024 OneMinuteCode. All rights reserved.