problem with Quaternion polynomial root solver
- To: mathgroup at smc.vnet.net
- Subject: [mg68252] problem with Quaternion polynomial root solver
- From: Roger Bagula <rlbagula at sbcglobal.net>
- Date: Sun, 30 Jul 2006 04:48:44 -0400 (EDT)
- Sender: owner-wri-mathgroup at wolfram.com
Using my 2by2 matrix representaion of quaternions I solved the
triabonacci polynomial as a Quaternion polynomial.
My problem is that the 6 roots of a cubic come out as :
root=q1+I*q2
Example:
{0.709822\[InvisibleSpace] + 0.303145 \[ImaginaryI],
0.46714\[InvisibleSpace] + 1.31925 \[ImaginaryI], 0.350727\
\[InvisibleSpace] - 0.847789 \[ImaginaryI],
0.966809\[InvisibleSpace] + 0.0242682 \[ImaginaryI]}
I solved the first part of the problem using
I* (t+x*I+y*J+z*K)= Quaternion[ -x,t,-z,y]
Papers I found on this subject:
Computing the Zeros of Quaternion Polynomials Computers and Mathematics
with Applications, 42(2001)1229-1237, (with Edgar Pereira, Rogério Serôdio)
http://www.ingentaconnect.com/content/els/08939659/2001/00000014/00000002/art00142;jsessionid=8uvmr473nhgn.alice
Zeros of Quaternion Polynomials. Authors: Serodio R.; Siu L.-S. Source:
Applied Mathematics Letters, Volume 14, Number 2, February 2001, pp. 237-239
Another problem is that the result is no longer a Pisot in Quarernionic
terms.
My question is:
how do I find polynomials that give real Pisot quaternions ( in analogy
to complex / real Pisot numbers:
roots all modulus less than one except for one real root in the "t"
part of the quaternion)
Mathematica:
i = {{0, 1}, {-1, 0}};
j = {{0, I}, {I, 0}};
k = {{I, 0}, {0, -I}};
e = IdentityMatrix[2];
q[t_, x_, y_, z_] := e*t + x*i + j*y + k*z;
q2 = ExpandAll[q1.q1]
q3 = ExpandAll[q1.q2]
Table[q3[[i, j]] - q2[[i, j]] - q1[[i, j]] - e[[i, j]], {i, 1, 2}, {j,
1, 2}]
Solve[Flatten[Table[q3[[i, j]] - q2[[i, j]] - q1[[i, j]] - e[[i, j]] == 0,
{i, 1, 2}, {j, 1, 2}]], {t, x, y, z}]
a = Table[{t, x, y, z} /. NSolve[Flatten[Table[q3[[i, j]] - q2[[i, j]] -
q1[[
i, j]] - e[[i, j]] ==
0, {i, 1, 2}, {j, 1, 2}]], {t, x, y, z}][[n]], {n, 1, 6}]
Abs[a]
a1 = Table[{Re[t] -
Im[x], Re[x] + Im[t], Re[y] - Im[z], Re[z] + Im[y]} /. NSolve[
Flatten[Table[q3[[i, j]] - q2[[i, j]] - q1[[i, j]] - e[[i, j]] ==
0, {i, 1, 2}, {j, 1, 2}]], {t, x, y, z}][[n]], {n, 1, 6}]
{{-0.609424, 0.770285, 0.326459, 0.11902}, {-0.609424, 0.770285,
0.326459, 0.11902}, {
0.243592, -0.244727, -0.212592, 1.61158}, {-1.08288, -0.244727,
-0.258133, \
0.429828}, {-0.283484, -0.0453468, 0.482102, -0.252834}, {-0.283484, \
-0.0453468, 0.482102, -0.252834}}
b 1= Table[Sqrt[(Re[
t] - Im[x])2 + (Re[x] + Im[t])2 + (Re[y] - Im[
z])2 + (Re[z] + Im[y])2] /. NSolve[Flatten[Table[q3[[i,
j]] - q2[[i, j]] - q1[[i, j]] - e[[i, j]] == 0, {i, 1,
2}, {j,
1, 2}]], {t, x, y, z}][[n]], {n, 1, 6}]
{1.04186, 1.04186, 1.66181, 1.21815, 0.61544, 0.61544}