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]]