Voigt notation in Mathematica

Your question does not have a satisfactory answer unless you remove the requirement against a "manual" way.

First, let us define a function that will allow us to translate from {i,j} coordinates to k coordinates, where the i and j run from 1 to 3 and k runs from 1 to 6.

transf[u_] := 
  Simplify[u.{{0, 3 - α}, {α, -3}}.u + {-10, 11}.u];

There, α is an arbitrary parameter. The call to Simplify is not necessary if you pick a value for α, say 0. In any case,

transf /@ {{1, 1}, {1, 2}, {1, 3}, {2, 2}, {2, 3}, {3, 3}}

yields

{1, 6, 5, 2, 4, 3}

Thus, we confirm transf is the mapping {i,j}↦k. Unfortunately, one cannot solve

k == transf[{i, j}]
(*k == (11 - 3 j) j + i (-10 + 3 j)*)

to get a "unique" inverse k↦{i,j}. For example, if we solve it for the diagonal entries:

Solve[k == transf[{i, i}], i]
(*{{i -> k}}*)

But for off-diagional entries in the third column:

Solve[k == transf[{i, 3}], i]
(*{{i -> 6 - k}}*)

So, the map k↦{i,j} will necessarily be a piece-wise function that will look as if it was coded by hand.

By the way, I will left it as an exercise for you to prove that the pullback k↦{i,j} is necessary to obtain the Voigt components out of the traditional ones.

If you decide to remove the requirement against "manual", then I would advise you to use Dispatch.


Assuming that, in general, the elements are ordered in a spiral:

ClearAll[voigtSpiral]
voigtSpiral = Module[{indices = Accumulate[
  Join @@ ConstantArray @@@ Transpose[
   {PadRight[{{1, 1}, {-1, 0}, {0, -1}}, {Length@#, 2}, "Periodic"], 
    Range[Length@#, 1, -1]}]]}, 
 Extract[#, indices]] &;

Examples:

array[n_Integer] := Array[Subscript[a, ## & @@ Sort[{##}]] &, {n, n}]

voigtSpiral @ array @ 3 // TeXForm

$\small\left\{a_ {1, 1}, a_ {2, 2}, a_ {3, 3}, a_ {2, 3}, a_ {1, 3}, a_ {1, 2} \right\}$

voigtSpiral @ array @ 6 // TeXForm

$\small\left\{a_{1,1},a_{2,2},a_{3,3},a_{4,4},a_{5,5},a_{6,6},a_{5,6},a_{4,6},a_{3,6},a_{2,6},a_{1,6},a_{1,5},a_{1,4},a_{1,3},a_{1,2},a_{2,3},a_{3,4},a_{4,5},a_{3,5},a_{2,5},a_{2,4}\right\}$

Visualization:

pathGraph = PathGraph[voigtSpiral @ array @ #, DirectedEdges -> True, 
    VertexLabels -> Placed["Name", Center], VertexLabelStyle -> 20, 
    ImagePadding -> 20, VertexShapeFunction -> None, 
    VertexSize -> Scaled[.1], ImageSize -> 350, 
    VertexCoordinates -> (RotationTransform[-Pi/2] @ 
     (voigtSpiral[array @ #] /. Subscript[_, x__] :> {x}))] &;

Grid[Partition[pathGraph /@ Range[2, 7], 3]]

enter image description here

Tags:

Tensors