1
$\begingroup$

I have been running code to solve the following equations for hours and hours, but there are still no solutions! I am new to Mathematica, so I am not really sure whether or not it is a good idea to use Reduce to solve trigonometric equations.

Also, I want a symbolic solution, NOT a numeric one.

The code is:

eq1 := (Sin[
   Subscript[θ, 1] - Subscript[θ, 
    3]] (-Sin[
       Subscript[θ, 2] - Subscript[θ, 7]] Subscript[
     a, 1] + Cos[
      Subscript[θ, 2] - Subscript[θ, 7]] Subscript[
     a, 2]) + 
 Sin[Subscript[θ, 1] - Subscript[θ, 
    2]] (Sin[
      Subscript[θ, 3] - Subscript[θ, 7]] Subscript[
     b, 1] + Cos[Subscript[θ, 
      7]] (-Cos[Subscript[θ, 3]] + 
       Sin[Subscript[θ, 3]]) Subscript[b, 2])) Subscript[l,
1] Subscript[l, 2] Subscript[l, 3];

eq2 := Sin[
Subscript[θ, 1] - Subscript[θ, 
 4]] (-Cos[
    Subscript[θ, 2] - Subscript[θ, 7]] Subscript[a, 
  2] + Sin[
   Subscript[θ, 2] - Subscript[θ, 7]] (Subscript[a, 
    1] - Subscript[b, 1]) + 
 Cos[Subscript[θ, 
   7]] (Cos[Subscript[θ, 2]] - 
    Sin[Subscript[θ, 2]]) Subscript[b, 2]) Subscript[l, 1]
Subscript[l, 2] Subscript[l, 4];

eq3 := 1/2 Cos[Subscript[θ, 1]] Sin[
Subscript[θ, 2] - Subscript[θ, 
 5]] (-2 Sin[
   Subscript[θ, 3] - Subscript[θ, 7]] Subscript[b, 
  1] + 2 Cos[Subscript[θ, 
   7]] (Cos[Subscript[θ, 3]] - 
    Sin[Subscript[θ, 3]]) Subscript[b, 2]) Subscript[l, 1]
Subscript[l, 2] Subscript[l, 3] Subscript[l, 5];

eq4 := -Sin[
 Subscript[θ, 1] - Subscript[θ, 
  4]] (-Cos[Subscript[θ, 6]] Sin[
   Subscript[θ, 2] - Subscript[θ, 7]] Subscript[a, 
  1] + Cos[Subscript[θ, 6]] Cos[
   Subscript[θ, 2] - Subscript[θ, 7]] Subscript[a, 
  2] + Cos[Subscript[θ, 
   2]] (Sin[
      Subscript[θ, 6] - Subscript[θ, 7]] Subscript[
     b, 1] + Cos[Subscript[θ, 
      7]] (-Cos[Subscript[θ, 6]] + 
       Sin[Subscript[θ, 6]]) Subscript[b, 2])) Subscript[l,
1] Subscript[l, 2] Subscript[l, 4] Subscript[l, 6];

eq5 := -Sin[Subscript[θ, 2] - Subscript[θ, 3]] Sin[
Subscript[θ, 1] - Subscript[θ, 4]] Subscript[l, 1]
Subscript[l, 2] Subscript[l, 3] Subscript[l, 4];

eq6 := Sin[Subscript[θ, 1] - Subscript[θ, 3]] Sin[
Subscript[θ, 2] - Subscript[θ, 5]] Subscript[l, 1]
Subscript[l, 2] Subscript[l, 3] Subscript[l, 5];

eq7 := -Sin[Subscript[θ, 1] - Subscript[θ, 2]] Sin[
Subscript[θ, 3] - Subscript[θ, 6]] Subscript[l, 1]
Subscript[l, 2] Subscript[l, 3] Subscript[l, 6];

sols := Reduce[{eq1 == 0, eq2 == 0, eq3 == 0, eq4 == 0, eq5 == 0, 
eq6 == 0, eq7 == 0}, {Subscript[θ, 1], Subscript[θ, 
2], Subscript[θ, 3], Subscript[θ, 4], 
Subscript[θ, 5], Subscript[θ, 6], 
Subscript[θ, 7]}];

Any help will be appreciated.

$\endgroup$
8
  • 3
    $\begingroup$ Do you have reason to believe that a symbolic solution actually exists? By the way, I suggest avoiding use of subscripted variables. $\endgroup$
    – bbgodfrey
    Nov 29, 2016 at 3:16
  • $\begingroup$ You can find θ6 quickly: Reduce[TrigExpand[{eq4==0, eq7==0}], Subscript[[Theta], 6]] and that might give you some idea how big the full solution might be. $\endgroup$
    – Bill
    Nov 29, 2016 at 4:29
  • 3
    $\begingroup$ Read carefuly this answer Solve symbolically a transcendental trigonometric equation and plot its solutions. Then try to solve it recalling those hints, and at least you'll be able to reformulate your problem in a way to be easily solvable. $\endgroup$
    – Artes
    Nov 29, 2016 at 7:56
  • 6
    $\begingroup$ I'm voting to close this question as off-topic because there is no well-posed question in this post; the OP is simply begging for somebody to act as a free debugging service. $\endgroup$
    – m_goldberg
    Nov 29, 2016 at 9:35
  • $\begingroup$ @bbgodfrey I've got 84 eqs like these 7. I manually worked on some them so they had symbolic solutions (at least what I had expected!). Also, NSlove cannot solve these 7 eqs either! Anyway, I do enhance my next codes :-) $\endgroup$
    – Ham64
    Nov 29, 2016 at 20:20

1 Answer 1

2
$\begingroup$

Probably well beyond what can be handled due to the complexity. I'd try changing to a polynomial formulation (replace the trigs with new variables after first using TrigExpand), add defining relations between "sine" and "cosine" variables, and see if a Groebner basis can be extracted. The code below shows how one might go about this. Amongst other things, it also removes factors that do not involve the variables of interest, as they (generically) do not vanish.

trigs = TrigExpand[{eq1 == 0, eq2 == 0, eq3 == 0, eq4 == 0, eq5 == 0, 
      eq6 == 0, eq7 == 0}[[All, 1]] /. Subscript[th_, n_] -> th[n]];
vars = Cases[Variables[trigs], Sin[_] | Cos[_]];
reprule = {Sin[a_] :> s[a], Cos[a_] :> c[a]};
newtrigs = trigs /. reprule;
newvars = vars /. reprule;
cosvars = Cases[newvars, c[_]];
extratrigs = Map[#^2 + s[#[[1]]]^2 - 1 &, cosvars];

flists = Map[FactorList, newtrigs];
keepflists = 
  Map[Select[#, ! FreeQ[#, Alternatives @@ newvars] &] &, 
    flists, {2}] /. {} -> Nothing;
trigpolys = Apply[Times, keepflists, {1}];
    allpolys = Join[trigpolys, extratrigs]

(* {{a[2] c[θ[2]] c[θ[3]] c[θ[7]] s[θ[1]] - 
   b[2] c[θ[2]] c[θ[3]] c[θ[7]] s[θ[1]] + 
   b[2] c[θ[1]] c[θ[3]] c[θ[7]] s[θ[2]] - 
   a[1] c[θ[3]] c[θ[7]] s[θ[1]] s[θ[2]] - 
   a[2] c[θ[1]] c[θ[2]] c[θ[7]] s[θ[3]] + 
   b[1] c[θ[2]] c[θ[7]] s[θ[1]] s[θ[3]] + 
   b[2] c[θ[2]] c[θ[7]] s[θ[1]] s[θ[3]] + 
   a[1] c[θ[1]] c[θ[7]] s[θ[2]] s[θ[3]] - 
   b[1] c[θ[1]] c[θ[7]] s[θ[2]] s[θ[3]] - 
   b[2] c[θ[1]] c[θ[7]] s[θ[2]] s[θ[3]] + 
   a[1] c[θ[2]] c[θ[3]] s[θ[1]] s[θ[7]] - 
   b[1] c[θ[2]] c[θ[3]] s[θ[1]] s[θ[7]] + 
   b[1] c[θ[1]] c[θ[3]] s[θ[2]] s[θ[7]] + 
   a[2] c[θ[3]] s[θ[1]] s[θ[2]] s[θ[7]] - 
   a[1] c[θ[1]] c[θ[2]] s[θ[3]] s[θ[7]] - 
   a[2] c[θ[1]] s[θ[2]] s[θ[3]] s[θ[
      7]]}, {(c[θ[4]] s[θ[1]] - 
     c[θ[1]] s[θ[4]]) (a[
       2] c[θ[2]] c[θ[7]] - 
     b[2] c[θ[2]] c[θ[7]] - 
     a[1] c[θ[7]] s[θ[2]] + 
     b[1] c[θ[7]] s[θ[2]] + 
     b[2] c[θ[7]] s[θ[2]] + 
     a[1] c[θ[2]] s[θ[7]] - 
     b[1] c[θ[2]] s[θ[7]] + 
     a[2] s[θ[2]] s[θ[7]])}, {c[θ[
     1]] (c[θ[5]] s[θ[2]] - 
     c[θ[2]] s[θ[5]]) (b[
       2] c[θ[3]] c[θ[7]] - 
     b[1] c[θ[7]] s[θ[3]] - 
     b[2] c[θ[7]] s[θ[3]] + 
     b[1] c[θ[3]] s[θ[7]])}, {(c[θ[
        4]] s[θ[1]] - 
     c[θ[1]] s[θ[4]]) (a[
       2] c[θ[2]] c[θ[6]] c[θ[7]] - 
     b[2] c[θ[2]] c[θ[6]] c[θ[7]] - 
     a[1] c[θ[6]] c[θ[7]] s[θ[2]] + 
     b[1] c[θ[2]] c[θ[7]] s[θ[6]] + 
     b[2] c[θ[2]] c[θ[7]] s[θ[6]] + 
     a[1] c[θ[2]] c[θ[6]] s[θ[7]] - 
     b[1] c[θ[2]] c[θ[6]] s[θ[7]] + 
     a[2] c[θ[6]] s[θ[2]] s[θ[
        7]])}, {(c[θ[3]] s[θ[2]] - 
     c[θ[2]] s[θ[3]]) (c[θ[4]] s[θ[1]] - 
     c[θ[1]] s[θ[4]])}, {(c[θ[3]] s[θ[
        1]] - c[θ[1]] s[θ[3]]) (c[θ[
        5]] s[θ[2]] - 
     c[θ[2]] s[θ[5]])}, {(c[θ[2]] s[θ[
        1]] - c[θ[1]] s[θ[2]]) (c[θ[
        6]] s[θ[3]] - c[θ[3]] s[θ[6]])}, -1 + 
  c[θ[1]]^2 + s[θ[1]]^2, -1 + c[θ[2]]^2 + 
  s[θ[2]]^2, -1 + c[θ[3]]^2 + s[θ[3]]^2, -1 + 
  c[θ[4]]^2 + s[θ[4]]^2, -1 + c[θ[5]]^2 + 
  s[θ[5]]^2, -1 + c[θ[6]]^2 + s[θ[6]]^2, -1 + 
  c[θ[7]]^2 + s[θ[7]]^2} *)

I have no idea whether this will run to completion, let alone how useful it will be if it does (the size could be way to big to use in further manipulations).

AbsoluteTiming[
 gb = GroebnerBasis[allpolys, newvars, 
    MonomialOrder -> DegreeReverseLexicographic, 
    CoefficientDomain -> RationalFunctions];]
$\endgroup$

Not the answer you're looking for? Browse other questions tagged or ask your own question.