# Symbolic Output after numerical computation

I have a small question about the symbolic output. I started to write a program that generates the coordinates of n-dimensional polytopes by Wythoff construction. For crystallographic groups, all is well, but for non-crystallographic groups, H2, H3 and H4 (5-fold symmetry) I have to use the golden ratio. The calculation operates. However, I would like the output of the golden ratio and its multiples is done by a symbol, for exemple $\tau$. There he has a way to do this without losing too much computational efficiency?

(*General setting*)
$RecursionLimit = Infinity; SetOptions[EvaluationNotebook[], CellEvaluationFunction -> (ToExpression[#, StandardForm, Function[ Null, Module[{aborted =$Aborted},
InternalWithLocalSettings[
Null,
aborted = (ReleaseHold[Most[Hold[##]]]; Last[Hold[##]]),
AbortProtect[
If[aborted === \$Aborted,
Print["General Abort"]; Abort[]
]]]],
HoldAll]] &)]

(*Constants*)
τ = (1 + Sqrt[5])/2;

(*Cartan Matrices*)
An[n_] :=
Which[n == 1, {2}, n > 1,
Normal[SparseArray[{Band[{1, 1}] -> 2, Band[{2, 1}] -> -1,
Band[{1, 2}] -> -1}, n]]];
Bn[n_] :=
Which[n == 1, {2}, n == 2, Normal[{{2, -1}, {-1, 2}}], n >= 3,
Normal[SparseArray[{Band[{1, 1}] -> 2, Band[{2, 1}] -> -1,
Band[{1, 2}, {n - 2, n - 1}] -> -1, {n - 1, n} -> -2}, n]]];
Cn[n_] :=
Which[n == 1, {2}, n == 2, Normal[{{2, -1}, {-1, 2}}], n >= 3,
Normal[
SparseArray[{Band[{1, 1}] -> 2, Band[{1, 2}] -> -1,
Band[{2, 1}, {n - 1, n - 1}] -> -1, {n, n - 1} -> -2}, n]]];
Dn[n_] :=
Which[n == 1, {2}, 1 < n < 4,
Normal[SparseArray[{Band[{1, 1}] -> 2, Band[{2, 1}] -> -1,
Band[{1, 2}] -> -1}, n]], n >= 4,
Normal[SparseArray[{Band[{1, 1}] -> 2,
Band[{1, 2}, {n - 3, n - 2}] -> -1,
Band[{2, 1}, {n - 1, n}] -> -1,
Band[{n - 2, n - 2}] -> {{2, -1, -1}, {-1, 2, 0}, {-1, 0, 2}}},
n]]];
En[n_] :=
If[6 <= n <= 8,
Normal[SparseArray[{Band[{1, 1}] -> {{2, 0, -1, 0}, {0, 2,
0, -1}, {-1, 0, 2, -1}, {0, -1, -1, 2}}, Band[{4, 3}] -> -1,
Band[{3, 4}] -> -1, Band[{5, 5}] -> 2}, n]],
Print["This group doesn' t exist."] && Abort[]];
Fn[n_] :=
If[n == 4,
Normal[{{2, -1, 0, 0}, {-1, 2, -2, 0}, {0, -1, 2, -1}, {0, 0, -1,
2}}], Print["This group doesn't exist. n = 4"] && Abort[]];
Gn[n_] :=
If[n == 2, Normal[{{2, -3}, {-1, 2}}],
Print["This group doesn't exist. n = 2"] && Abort[]];
Hn[n_] :=
Which[n == 2, Normal[{{2, -τ}, {-τ, 2}}], n == 3,
Normal[{{2, -1, 0}, {-1, 2, -τ}, {0, -τ, 2}}], n == 4,
Normal[{{2, -1, 0, 0}, {-1, 2, -1, 0}, {0, -1, 2, -τ}, {0,
0, -τ, 2}}], n == 1 || n > 4,
Print["This group doesn't exist."] && Abort[]]

(*Group selection function*)
selectGr[group_, dim_] :=
Which[group == "An", An[dim], group == "Bn", Bn[dim], group == "Cn",
Cn[dim], group == "Dn", Dn[dim], group == "En", En[dim],
group == "Fn", Fn[dim], group == "Gn", Gn[dim], group == "Hn",
Hn[dim]];

(*Reflection*)
reflect[vect_, group_] := Module[{dim, Gr, vectTemp},
dim = Length[vect];
Gr = selectGr[group, dim];
For[i = 1, i <= dim, i++,
vectTemp[i] =
If[vect[[i]] > 0,
FullSimplify[vect - vect[[i]]*Gr[[i]]], ## &[]];
];
Return[Table[vectTemp[k], {k, 1, dim}]];
];
reflectAll[vect_, group_] :=
DeleteDuplicates[
Flatten[{vect, Flatten[reflect[#, group] & /@ vect, 1]},
1], #1 == #2 &];

(*Positive elements*)
elemPos[vect_] := Positive@Max@vect;
(*elemAllPos[vect_]:=elemPos/@vect;
testPos[list1_,list2_]:=If[MemberQ[elemAllPos[Complement[list1,list2]]\
,True]\[Equal]True,True,False];*)

(*ω-basis coordinates*)

omegaCoor[vect_, group_] := (i = 2; j = 1; vtmp[1] = vect;
While[True,
vtmp[i] = reflectAll[vtmp[i - 1], group];
If[elemPos[Last[vtmp[i]]] == False, Break[]]; i++; j++
];
Return[{vtmp[i], group}]);

(*===============================================================================*)
(*Crash Test Dummies Zone*)
seed = {{0, 0, 1}};
coordinates = omegaCoor[seed, "Hn"];
Print[Length[coordinates[[1]]] "vertices"]
Print[coordinates[[1]]]
(*===============================================================================*)


The output will be :

(* 20 vertices *)
{{0,0,1},{0,1/2 (1+Sqrt[5]),-1},{1/2 (1+Sqrt[5]),1/2 (-1-Sqrt[5]),1/2 (1+Sqrt[5])},{1/2 (-1-Sqrt[5]),0,1/2 (1+Sqrt[5])},{1/2 (1+Sqrt[5]),1,1/2 (-1-Sqrt[5])},{1/2 (-1-Sqrt[5]),1/2 (3+Sqrt[5]),1/2 (-1-Sqrt[5])},{1/2 (3+Sqrt[5]),-1,0},{1,1/2 (-3-Sqrt[5]),1/2 (3+Sqrt[5])},{1/2 (-3-Sqrt[5]),1/2 (1+Sqrt[5]),0},{-1,1/2 (-1-Sqrt[5]),1/2 (3+Sqrt[5])},{1,1/2 (1+Sqrt[5]),1/2 (-3-Sqrt[5])},{-1,1/2 (3+Sqrt[5]),1/2 (-3-Sqrt[5])},{1/2 (3+Sqrt[5]),1/2 (-1-Sqrt[5]),0},{1/2 (1+Sqrt[5]),1/2 (-3-Sqrt[5]),1/2 (1+Sqrt[5])},{1/2 (-3-Sqrt[5]),1,0},{1/2 (-1-Sqrt[5]),-1,1/2 (1+Sqrt[5])},{1/2 (1+Sqrt[5]),0,1/2 (-1-Sqrt[5])},{1/2 (-1-Sqrt[5]),1/2 (1+Sqrt[5]),1/2 (-1-Sqrt[5])},{0,1/2 (-1-Sqrt[5]),1},{0,0,-1}}

• You might want to look at this answer. Jun 26, 2014 at 8:35

EDIT

Here's a slightly modified version of a suggestion made by Kuba in my separate question on this topic

(coordinates[[1]] /. (Sqrt[5]) -> (2 tau - 1) // Simplify) /. tau -> HoldForm@\[Tau]


ORIGINAL

This is not the most elegant solution to grace this forum, but:

Map[
If[
AtomQ@#,
#,
(Simplify[#/τ]*HoldForm@τ) /. {
τ -> HoldForm@τ,
-τ -> HoldForm@-τ}] &,
coordinates[[1]], {2}]
`

• @physicien See also Kuba's comment in the question linked by m_goldberg above (I opened a more general version of this question separately). It is an elegant (though not completely general) solution to your specific problem. Jun 26, 2014 at 16:14
• Yeah, I just read it and it's perfect. Thanks! Jun 26, 2014 at 16:21