I'm looking for a tetrahedral (triangle pyramid) inscribed sphere sympy. I tried it on the vba solver.

四 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 sympy

2022-09-30 11:10

3 Answers

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

2022-09-30 11:10

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

2022-09-30 11:10

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

2022-09-30 11:10

If you have any answers or tips

Popular Tags

python x 4647

android x 1593

java x 1494

javascript x 1427

c x 927

c++ x 878

ruby-on-rails x 696

php x 692

python3 x 685

html x 656