Symbolic Quaternion Multiplication

Question

It is possible to do the symbolic multiplication $qq^*$ of a quaternion $q=a+bi+cj+dk$ by its conjugate $q^*=a-bi-cj-dk$ using Mathematica? It seems that Quaternion package only works with numeric entries.

Answer 1

Needs["Quaternions`"]
q = Quaternion[a, b, c, d];
q ** Conjugate[q]

Quaternion[a^2 + b^2 + c^2 + d^2, 0, 0, 0]

Answer 2

Alternatively to the other answer, you can use this code to define quaternion algebra:

Clear["Global`*"]
Unprotect[Dot];
Dot[x_?NumberQ, y_] := x y;
Protect[Dot];
Matrix /: Matrix[x_?MatrixQ] := 
  First[First[x]] /; x == First[First[x]] IdentityMatrix[Length[x]];
Matrix /: NonCommutativeMultiply[Matrix[x_?MatrixQ], y_] := 
  Dot[Matrix[x], y];
Matrix /: NonCommutativeMultiply[y_, Matrix[x_?MatrixQ]] := 
  Dot[y, Matrix[x]];
Matrix /: Dot[Matrix[x_], Matrix[y_]] := Matrix[x . y];
Matrix /: Matrix[x_] + Matrix[y_] := Matrix[x + y];
Matrix /: x_?NumericQ + Matrix[y_] := 
  Matrix[x IdentityMatrix[Length[y]] + y];
Matrix /: x_?NumericQ Matrix[y_] := Matrix[x y];
Matrix /: Matrix[x_]*Matrix[y_] := Matrix[x . y] /; x . y == y . x;
Matrix /: Power[Matrix[x_?MatrixQ], y_?NumericQ] := 
  Matrix[MatrixPower[x, y]];
Matrix /: Power[Matrix[x_?MatrixQ], Matrix[y_?MatrixQ]] := 
  Exp[Matrix[y] . Log[Matrix[x]]];
Matrix /: Im[Matrix[x_?MatrixQ]] := Matrix[Im[x]]
Matrix /: Re[Matrix[x_?MatrixQ]] := Matrix[Re[x]]
Matrix /: Arg[Matrix[x_?MatrixQ]] := Matrix[Arg[x]]

$Post2 = FullSimplify[FullSimplify[# /. i -> Matrix[( {
               {I, 0},
               {0, -I}
              } )] /. j -> Matrix[( {
              {0, 1},
              {-1, 0}
             } )] /. k -> Matrix[( {
             {0, I},
             {I, 0}
            } ) ] /. 
        f_[args1___?NumericQ, Matrix[mat_], args2___?NumericQ] :> 
         Matrix[MatrixFunction[f[args1, #, args2] &, mat]]] /. 
      Matrix[{{a_, c_}, {d_, b_}}] :> 
       Re[a] + Im[a] i + Re[c] j + Im[c] k ] /. 
    Matrix[{{a_, c_}, {d_, b_}}] :> 
     Re[a] + Im[a] i + Re[c] j + Im[c] k &;
$Post = Nest[$Post2, #, 3] &;

Then input the following:

NumericQ[a] = NumericQ[b] = NumericQ[c] = NumericQ[d] = True;
(a + b i + c j + d k) ** (a - b i - c j - d k)

You will get

Out:=a^2 + b^2 + c^2 + d^2