Kernel

Implementation

code and documentation by jph - download from www.hakenberg.de

Prolog

Packages

The packages related to graphics do not influence the functionality of the kernel.

<< LinearAlgebra`Orthogonalization`
<< LinearAlgebra`MatrixManipulation`
<< DiscreteMath`Combinatorica`
<< Graphics`Graphics`
<< Graphics`ImplicitPlot`
<< Graphics`ContourPlot3D`
<< Graphics`PlotField`
<< Graphics`PlotField3D`
<< Graphics`InequalityGraphics`
<< Miscellaneous`PhysicalConstants`

For a graph, M gives number of edges, V gives number of vertices.

Unprotect[{M, V}]

Messages

no warning when using similar variable names:

Off[General::spell]; 
Off[General::spell1];

Abbreviations

assume = {};

elementary list operations

𝒹 := Dimensions;
𝒻[x__] := Flatten[{x}];
ℓ := Length;
𝓃[x__] := 
        Union[0 == #1 & /@ 
            Simplify[𝒻[x], assume]];
𝓇 := TensorRank;
𝓉 := Transpose;
𝓈 := 
        FullSimplify[#1, assume] &;
𝓋[x__] := Variables[𝒻[x]];

transpose tensors

Unprotect[{Transpose}];
Transpose[{}] = {};
Transpose[{}, x_List] = {};
Protect[{Transpose}];

matrix related

EXP := MatrixExp;
Inv := Inverse;

Id[
          n_] := IdentityMatrix[n];

    Id[p_, q_] := 
        DiagonalMatrix[𝒻[Array[1 &, p], 
            Array[-1 &, q]]];

    BS[X_] := Join[X, NS[X]];

    ES[X_] := 
        Module[{d, V}, {d, V} = Eigensystem[X]; 
          V = #1/(Sqrt[#1 . #1]) & /@ V; {d, V}];

    NS[X_] := Reverse[NullSpace[X]];

    Span[{}] = {};

    Span[X_] := 
        Select[RowReduce[X], ! And @@ 𝓃[#1] &];

miscellaneous

ℒ := LaplaceTransform;
ℒInv := InverseLaplaceTransform;

ZeroQ[x__] := ℓ[𝓃[x, 0]] == 1;

forms

MF[{}] = MatrixForm[{}];
MF[X_] := 
        If[ZeroQ[X], 
"zero…" <> 
            StringDrop[
              StringJoin[ToString[#1] <> "\[Cross]" & /@ 𝒹[
                    X]], -1], 
          MatrixForm[X]];
tex := TeXForm;
TF := TableForm;

old

Operators

inQ[s1_String, s2_String] := Not[StringFreeQ[s1, s2]];

Relations

\(\(x_Symbol → y_List := 
        Array[x\_#1 -> y[[#1]] &, 
          Length[y]];\)\)
x_List → y_List := 
        Array[x[[#1]] -> 
              y[[#1]] &, 
          Min[Length[x], Length[y]]];
x_List → 0 := 
        Array[x[[#1]] -> 0 &, 
          Length[x]];

Plotting

𝒿ParametricPlot[Fin_, ab_, rgb_: {1,  .3,  .2}, thi_:  .01] := 
        Module[
{F = 
              If[𝓇[Fin] == 1, {Fin}, 
                Fin], 
c = 
              If[𝓇[rgb] == 1, {rgb}, 
                rgb]}, 
Graphics[{
RGBColor @@ 
                    c[[#1]], 
Thickness[thi], 
Line[
                    Table[Evaluate[
                        F[[#1]]], 
                      ab]]
} & /@ 
              Range[ℓ[F]]]
];

PlotShow[grp__] := 
        Show[𝒻[grp], Frame -> True, Axes -> True, 
          DisplayFunction -> $DisplayFunction];
PlotLine[f_, ab_, rgb_: {1,  .3,  .2}, thi_:  .01] := 
        Graphics[{RGBColor @@ rgb, Thickness[thi], 
            Line[Table[Evaluate[f], ab]]}];
PlotPoint[f_, rgb_: {1,  .3,  .2}, thi_:  .04] := 
        Graphics[{RGBColor @@ rgb, PointSize[thi], Thickness[thi], 
            Point /@ f}];
PlotFrame[α_, f_, 
          ab_] := 
ListPlotVectorField[
          Table[{α, 
              f[[All, k]]}, {𝓉, 
              ab[[1]], 
              ab[[2]], 
              ab[[3]]}, {k, Dims[
                  f][[2]]}], 
          DisplayFunction -> 
            Identity, 
ColorOutput -> {RGBColor[1, 1, 
                0]}];

PlotLine3D[f_, ab_, rgb_: {1,  .3,  .2}, thi_:  .01] := 
        Graphics3D[{RGBColor @@ rgb, Thickness[thi], 
            Line[Table[Evaluate[f], ab]]}];
PlotPoint3D[f_, rgb_: {1,  .3,  .2}, thi_:  .01] := 
        Graphics3D[{RGBColor @@ rgb, Thickness[thi], PointSize[thi], 
            Point[f]}];

Global variables

enable debug to protocol advanced functions

debug = False;

some values

ε = (10^(-3));
ι = "ι";
ℝ = "ℝ";
ℂ = "ℂ";
MYDIR = "";

Content

Tensors

<!> covariant application from right: A(x, y, z) = A . x . y . z 
TODOs:

\(\(Τ★[v_, n_] := 
        Array[v\_##1 &, n];\)\)

X_⊕Y_ := 
        With[{n = ℓ[X] + ℓ[Y], 
            p = RotateLeft[
                Range[𝓇[X]]]}, 
Nest[𝓉[
                  Map[PadRight[#1, n] &, #1, {𝓇[X] - 1}], p] &, 
              X, 𝓇[X]] + 
            Nest[𝓉[Map[PadLeft[#1, n] &, #1, {𝓇[X] - 1}], 
                  p] &, Y, 𝓇[X]]];
X_⊕{} := X;
X_List⊗Y_List := 
        Outer[Times, X, Y];
r_⊗X_ := r X;

Τ𝒮[X_] := 
        1/𝓇[X]! Plus @@ (𝓉[X, #1] & /@ 
                Permutations[𝓇[X]]);
Τ𝒜[X_] := 
        1/𝓇[
                X]! Plus @@ (Signature[#1] 𝓉[X, #1] & /@ 
                Permutations[𝓇[X]]);
X_List⋀Y_List := (((𝓇[X] + 𝓇[Y])!)/(𝓇[X]! 𝓇[Y]!)) Τ𝒜[
            X⊗Y];
r_⋀X_ := r X;

contraction

ΤC::dimensions = "conflict";
ΤC[X_, i_Integer, 
          j_Integer] := ΤC[𝓉[
            X, 𝒻[Range[3, i + 1], 1, Range[i + 2, j], 
              2]]];
ΤC[X_] := 
        If[ℓ[
              X] == 𝒹[
                X][[2]], 
          Plus @@ Array[
              X[[#1, #1]] &, ℓ[
                X]], Message[ΤC::dimensions]];

basis transformation

Τα[X_, r_Integer, α_] := 
        Fold[
𝓉[#1, 
                  RotateRight[Range[𝓇[X]], 1]] . #2 &, 
            X, 
Join @@ {Table[𝓉[
                    Inv[α]], {r}], 
                Table[α, {𝓇[X] - 
                      r}]}] // 𝓈;
Τdα[X_, r_Integer, α_] := 
        Module[{δ = 
              1 + UnitStep[
                  r - Range[𝓇[X]]]}, 
Plus @@ 
            Array[(-1)^δ[[#1]] 𝓉[ΤC[
                      X⊗α, #1, 𝓇[
                          X] + δ[[#1]]], 
Append[
                      Drop[Range[𝓇[X]], {#1}], #1]] &, 𝓇[
                X]]];

concatenate tensors along some slot:

ΤJ::dimensions = "conflict";
ΤJ[X_, Y_, n_] := 
        Which[
0 == Times @@ 𝒹[X], 
          Y, 
0 == Times @@ 𝒹[Y], 
          X, 
Drop[𝒹[X], {n}] == 
            Drop[𝒹[Y], {n}], 
𝓉[
            Join[𝓉[X, RotateLeft[Range[n], 1]], 𝓉[Y, 
                RotateLeft[Range[n], 1]]], 
RotateRight[
              Range[n], 1]], 
True, 
          Message[ΤJ::dimensions]];

build block matrix with possibly symbolic entries:

MB[X_, n_] := 
        Module[{}, 
MBin[x_List, s_] := 
            x; 
MBin[x_Symbol, s_] := 
            Which[s == {1, 
                  1}, {{x}}, 
s[[1]] == 
                1, {Τ★[x, 
                  s[[2]]]}, 
              s[[2]] == 1, 
              T[{Τ★[x, 
                    s[[1]]]}], 
True, Τ★[x, 
                s]]; 
MBin[x_, s_] := 
            Array[x &, s]; 
BlockMatrix[
            Array[MBin[
                  X[[##1]], {n[[1, #1]], 
                    n[[2, #2]]}] &, ℓ /@ n]]];

LSolve::nosol = "no solution";
LSolve::multsol = "multiple solutions";
LSolve[nul_, v_] := 
        Module[{tmp, sol}, 
          Off[Solve::svars]; 
tmp = 
            FullSimplify[{Re[nul], Im[nul]}, #1 > 0 & /@ 
                Vars[nul]]; 
sol = Solve[E0[tmp], Vars[v]]; 
          On[Solve::svars]; 
Which[sol == {}, 
            Message[LSolve::nosol], 
ℓ[sol] > 1, 
            Message[LSolve::multsol], 
True, 
            v /. sol[[1]]]];

ModSign[lst_] := 
        Module[{x = {}}, 
If[MemberQ[x, -#1], 
                Null, x = Append[x, #1];] & /@ Union[𝒻[lst]]; 
          x];
HSolve[nul_, v_] := 
        Module[{tmp, A}, 
If[debug, 
            Print[𝒹[nul]]]; 
tmp = 
            Simplify[{Re[nul], 
                Im[nul]}, #1 > 0 & /@ 𝓋[
                  nul]]; 
tmp = 
            ModSign[tmp]; 
If[debug, 
            Print[nul]]; 
If[debug, 
            Print[tmp]]; 
A = CoefficientList[
                      tmp + #(1^2), #1][[All, 
                    2]] & /@ 𝓋[
                  v] // 𝓉; 
If[debug, 
            Print[A // 
                MF]]; 
v /. 𝓋[
                    v] → #1 & /@ NS[A]];

whenever coordinates are required
ΤΛ[n_,k_]:=Fold[#1⋀#2&,Id[n][[#1[[1]]]],Id[n][[#1[[Range[2,k]]]]]]&/@KSubsets[Range[n],k];
ΤdΛ[X]:=someKonst Τ𝒜[ΤJ[X]];
ΤdΛ[X_,n_,k_]:=Plus@@(ΤJ[X[[#1]],n]⋀ΤΛ[n,k][[#1]]&/@Range[ℓ[ΤΛ[n,k]]]);
ΤAlmostComplex[J_]:=J.J+Id[ℓ[J]];
ΤFit[Ξ_,X_]:=LinearSolve[T[Ft[#1]&/@Ξ],Ft[X]];

Τ𝒜[X_, r_] := 
        Array[Τ𝒜[
              X[[##1]]] &, Dims[
              X][[Range[
              r]]]];

Manifolds

<!> coordinates are (Subscript[x, i]), parameter for curves is t 
TODOs:
• use g instead of ℊ
• (Subscript[L, X]) A

\(\(Μ★[v_, k_Integer, n_: {}] := 
        If[n == {}, 
v @@ 
            Table[x\_i, {i, k}], 
Array[
            v\_##1 @@ Table[x\_i, {i, k}] &, n]];\)\)

(*
\(Χ★[n_Integer] := 
          Array[x\_##1[t] &, n]\);
Χ★[n_Integer, d_Integer]:=Array[(Subscript[x, ##1]^((d)))[t]&,n];
*)

Χ★[v_Symbol, n_Integer]:=Array[(Subscript[v, ##1])[t]&,n];
Χ0[v_Symbol, d_Integer, X0_, τ_:  t]:=MapIndexed[(Subscript[v, #2[[1]]]^((d)))[τ]-#1&,X0];

X_∘ϕ_ := 
        X /. Τ★[
              x, ℓ[ϕ]] → ϕ;

PROBLEM NOT RESOLVED:::

\(\(Μd[X_List, r_Integer, n_Integer] := 𝓉[
          Array[D[X, x\_#1] &, {n}], 𝒻[r + 1, 
            Range[r]]];\)\)
Μd[X_List, r_Integer] := Μd[X, 
          r, ℓ[X]];
\(\(Μd[X_List, n_Integer] := 
        Array[D[X, x\_#1] &, n];\)\)

commutator

ΜCom[X_, 
          Y_] := Μd[Y, 1] . X - Μd[X, 1] . 
            Y;

integral curve, flow
Χdα seems to work. Thanks to TN

ΧIntegral[
          X_] := (∂_t) Χ★[X] - 
            X∘Χ★[X] // S;  
Χα[X_, 
          x0_, Ι_: {0, 1}] := Χ★[
            X] /. 
NDSolve[𝓃[ΧIntegral[X], Χ0[0, x0]], Χ★[
                X], {𝓉, Ι[[1]], Ι[[2]]}][[1]];
Χdα[X_, x0_, Ι_: {0, 1}] := 
        With[{α = Χα[X, 
                x0, Ι]}, 
Χ★[
                    X] /. NDSolve[𝓃[(∂_𝓉) Χ★[
                              X] - Μd[X, 
                                1]∘α . Χ★[X], Χ0[
                          0, #1]], Χ★[
                        X], {𝓉, Ι[[1]], Ι[[2]]}][[1]] & /@ 
              Id[ℓ[X]] // T];
Χψ[X_, x0_, 
          t_:  1] := Χα[X, 
            x0, {0, t}] /. 𝓉 -> t;

linear connection

ΜD[Ξ_, X_𝕃, 
          r_ℤ:  1] := Μd[X, 
            r] + Τdα[X, r, Ξ];

semi-Riemannian manifolds

Μℊ[ℊ_, X_, Y_, r_Integer:  1] := 
        Total[Τα[X, r, Inv[ℊ]] Y, 𝓇[
            X]];
ΜNorm[ℊ_, X_, 
          r_Integer:  
            1] := (Sqrt[Abs])[Μℊ[ℊ, X, X, r]];
ΜNormalize[ℊ_, X_] := 
        X/ΜNorm[ℊ, X];
ΜAngle[ℊ_, X_, Y_] := 
        ArcCos[ℊ . X . 
              Y/(ΜNorm[ℊ, 
                  X] ΜNorm[ℊ, Y])];

orthonormal basis, gram-schmitt, eigendecomposition

ΜOrthNormalize[ℊ_, X_] := 
        Module[{Y = {}}, 
AppendTo[
                Y, 𝓈[ΜNormalize[ℊ, #1 - 
                      If[ℓ[Y] > 0, Y . ℊ . #1 . Y, 
                        0]]]] & /@ X; Y];
ΜOrthNormalize[ℊ_] := 
        Module[{d, V}, 
{d, V} = ES[ℊ]; 
          S[T[Inv[Diag[(Sqrt[Abs])[d]] . V]]]];

because the christoffel tensor field is used frequently, we have implemented ΜΓ as a memo function. formerly, the covariant derivative of a _vector field_ was implemented as Μ▽[ℊ_,X_List]:=Μd[X,1]+ΜΓ[ℊ].X; but the result should match the more general function Μ▽ below.

ΜΓ03[ℊ_] := 
        With[{Q = Μd[ℊ, 0]}, -Q + 𝓉[
                Q, {2, 3, 1}] + 𝓉[Q, {3, 1, 2}]]/
          2;
ΜΓ[ℊ_] := ΜΓ[ℊ] = 
          Inv[ℊ] . ΜΓ03[ℊ] // 𝓈;
Μ▽[ℊ_, X_List, 
          r_Integer:  1] := Μd[X, r] + Τdα[X, 
            r, ΜΓ[ℊ]];

covariant derivative along a curve, parallel transport, geodesics, exponential map

Χ▽[ℊ_, α_, 
          X_] := (∂_𝓉)(X∘α) + ΜΓ[ℊ]∘α . (∂_𝓉) α . (X∘α);
ΧParallel[ℊ_, α_] := (∂_𝓉) Χ★[ℊ] + ΜΓ[ℊ]∘α . (∂_𝓉) α . Χ★[ℊ];
Χ𝒫[ℊ_, α_, Ι_: {0, 
              1}] := Χ★[ℊ] /. NDSolve[𝓃[
ΧParallel[ℊ, α], Χ0[
                        0, #1]], Χ★[ℊ], {𝓉, Ι[[1]], Ι[[2]]}][[1]] & /@ Id[ℓ[ℊ]] // 
          T;
ΧGeodesic[ℊ_] := 
        With[{n = ℓ[ℊ]}, 
(∂_t)(∂_t) Χ★[x, 
                  n] + ΜΓ[ℊ]∘Χ★[x, 
                  n] . (∂_t) Χ★[x, 
                  n] . (∂_t) Χ★[x, 
                  n]];
Χℽ[ℊ_, p_, 
          v_, Ι_: {0, 
              1}] := Χ★[ℊ] /. NDSolve[𝓃[
ΧGeodesic[ℊ], Χ0[0, p], Χ0[1, 
                  v]], Χ★[ℊ], {t, Ι[[1]], Ι[[2]]}][[1]];
ΧE[ℊ_, p_, 
          v_] := Χℽ[ℊ, p, v] /. 
          t -> 1;

Jacobi vector fields

ΧJacobi[ℊ_] := 
        With[{ℛ = Μℛ[ℊ]}, (∂_𝓉)(∂_𝓉) Χ★[
                  y, ℊ] + (ℛ∘Χ★[ℊ]) . Χ★[
                y, ℊ] . (∂_𝓉) Χ★[ℊ] . (∂_𝓉) Χ★[ℊ]];
ΧJacobi[ℊ_, ℽ_] := 
        With[{ℛ = Μℛ[ℊ]}, (∂_𝓉)(∂_𝓉) Χ★[
                  y, ℊ] + (ℛ∘ℽ) . Χ★[
                y, ℊ] . (∂_𝓉) ℽ . (∂_𝓉) ℽ];
Χ𝒥[ℊ_, p_, 
          v_, Ι_: {0, 1}] := 
        With[{ℽ = Χℽ[ℊ, p, 
                v, Ι]}, 
{ℽ, 
            T[{Χ★[
                        y, ℊ], (∂_𝓉) Χ★[
                          y, ℊ]} /. NDSolve[𝓃[
ΧJacobi[ℊ, ℽ], {Χ0[0, 0 #1], Χ0[1, #1]} /. 
                            x -> y
], 
                        Ft[Χ★[
                            y, ℊ], (∂_𝓉) Χ★[
                              y, ℊ]], {𝓉, Ι[[1]], Ι[[2]]}][[1]] & /@ 
                Id[ℓ[ℊ]], {3, 1, 2}]}];

notions of curvature

Μℛ[ℊ_] := 
        With[{r = Μd[ΜΓ[ℊ], 
                  1] + ΜΓ[ℊ] . ΜΓ[ℊ]}, 𝓉[r, {1, 4, 3, 2}] - 𝓉[
                r, {1, 3, 4, 2}] // 𝓈];
ΜK[ℊ_, X_, 
          Y_] := {ℊ . Μℛ[ℊ] . 
              X . Y . Y . 
              X, (ℊ . X . X) (ℊ . Y . 
                    Y) - (((ℊ . X . Y))^2)} // 𝓈;
ΜK[ℊ_] := ΜK[ℊ, Τ★[
            v, ℓ[ℊ]], Τ★[
            w, ℓ[ℊ]]];
ΜRic[r_] := 
        If[𝓇[r] == 4, ΤC[r, 1, 
              4], ΤC[Μℛ[r], 1, 
              4]] // 𝓈;
ΜS[ℊ_] := ΤC[
            Inv[ℊ] . ΜRic[Μℛ[ℊ]]] // 𝓈;
ΜS[ℊ_, ℛ_] := ΤC[
            Inv[ℊ] . ΜRic[ℛ]] // 𝓈;

curvature identities

ΜℛSkew[ℛ_] := ℛ + 
          T[ℛ, {1, 2, 4, 3}];
ΜℛSkew[ℛ_, ℊ_] := ℊ . ℛ + 
          T[ℊ . ℛ, {2, 1, 3, 
              4}];
ΜℛBianchi[ℛ_] := 
        Plus @@ (𝓉[ℛ, #1] & /@ {{1, 2, 3, 
                  4}, {1, 3, 4, 2}, {1, 4, 2, 
                  3}});
ΜℛRotate[ℛ_, ℊ_] := ℊ . ℛ - 
          T[ℊ . ℛ, {3, 4, 1, 2}];

is the laplacian the (metrical) contraction of ΜHessian?

Μgrad[ℊ_, f_] := 
        Inv[ℊ] . Μd[
            f, ℓ[ℊ]];
Μ△[ℊ_, f_] := 
        With[{df = Μd[f, ℓ[ℊ]]}, ΤC[
            Inv[ℊ] . (Μd[df, 1] - 
                  df . ΜΓ[ℊ])]];

Μcurl[
          X_] := {(∂_((Subscript[x, 2])))X[[3]] - (∂_((Subscript[x, 3])))X[[2]], (∂_((Subscript[x, 3])))X[[1]] - (∂_((Subscript[x, 1])))X[[3]], (∂_((Subscript[x, 1])))X[[2]] - (∂_((Subscript[x, 2])))X[[1]]};

debug! can we use Μ▽ for ΜHessian?

ΜHessian[ℊ_, f_] := 
        With[{df = Μd[f, ℓ[ℊ]]}, Μd[
              df, 1] - 
            df . ΜΓ[ℊ]];
Μdiv[ℊ_, X_, r_Int, 
          i_Int] := ΤC[Μ▽[ℊ, X, r], 
          If[i < r, i, i + 1], r + 1];

TODO:
• Jacobi field equation along geodesic

Submanifolds

• replace name: ΜInduce
• wrong order in Pullback, use Τα with ∘ instead!?

ΜBs[ℊ_, X_] := 
        Join[X, NS[X . ℊ]];
ΜInduce[ϕ_, n_Int, 𝒽_] := 
        Module[{A}, 
If[debug, 
            Print[ΜBs[𝒽∘ϕ, Μd[ϕ, 0, n]] // 
                MF]]; 
A = ΜOrthNormalize[𝒽∘ϕ, ΜBs[𝒽∘ϕ, Μd[ϕ, 0, 
                    n]]][[Range[
                n + 1, ℓ[𝒽]]]]; 
If[debug, Print[A // MF]]; 
If[debug, 
            Print[Array[(Subscript[x, n + #1]) &, ℓ[𝒽] - n] . 
                A]]; 
S[ϕ + 
              Array[(Subscript[x, n + #1]) &, ℓ[𝒽] - 
                    n] . ΜOrthNormalize[𝒽∘ϕ, ΜBs[𝒽∘ϕ, Μd[ϕ, 
                        0, n]]][[
                  Range[n + 
                      1, ℓ[𝒽]]]]]];

ΜSub[X_, s_, n_Int] := ΜSub[X, s]∘
          Pr[Τ★[x, n], ℓ[
              X]];
ΜSub[X_, s_] := 
        X Fold[#1⊗χ[#2, ℓ[X]] &, 1, 
            s];
ΜII[ℊ_, 
          n_Int] := ΜSub[ΜΓ[ℊ], {Range[n + 1, ℓ[ℊ]], Range[n], Range[n]}, 
          n];
ΜShape[ℊ_] := (Inv[ℊ] . (ℊ[[ℓ[ℊ]]] . ΜII[ℊ, ℓ[ℊ] - 1]))∘
          Pr[Τ★[
              x, ℓ[ℊ] - 
                1], ℓ[ℊ]];
ΜHyper[ℊ_] := 
        Eigensystem[ΜShape[ℊ][[
            Range[ℓ[ℊ] - 1], 
            Range[ℓ[ℊ] - 
                1]]]];

debug:

ΜℛPlaneWaves[ℊ_, ℛ_] := ΤC[
          Inv[ℊ] . ΤC[
              Inv[ℊ] . 
                T[(ℊ . ℛ)⊗(ℊ . ℛ), {2, 1}], 1, 8], 2, 6];

garbage collector

ΜPullback[ϕ_,n_Int,Y_]:=Nest[T[#1.Μd[ϕ,1,n],Ft[{Range[2,𝓇[Y]],1}]]&,Y∘ϕ,𝓇[Y]]//S;

𝔛∠𝔛Time[X_, Y_] := 
        ArcCosh[-ℊ . X . 
                  (Y/(𝔛Norm[X] 𝔛Norm[
                    Y]))];
𝔛Causal[X_] := Sign[ℊ . X . X];

Lie algebras

TODOs:
• complexification Ar.p30
• cartan subalgebra Ar.p41
• factor Algebra g=m+k

Table2ad[t_] := 
        Table2ad[Τ★[e, ℓ[t]], 
          t];
Table2ad[v_, t_] := 𝓉[
          If[ℓ[𝓃[Τ𝒮[
                      t]]] == 1, t, 
              2  Τ𝒜[t]]
 /. 
            Join[v → 
                Id[ℓ[v]], {0 -> 
                  Table[0, {ℓ[v]}]}], {3, 2, 1}];

adSkew[ad_] := 
        ad + 𝓉[ad, {1, 3, 2}];
adJacobi[ad_] := ΜℛBianchi[
          ad . ad];
adKilling[ad_] := ΤC[ad . ad, 1, 4];

adCom[ad_, V_, W_] := 
        If[V ≠ {} && W ≠ {}, 
          Fold[T[#1 . T[#2], {1, 3, 2}] &, 
            ad, {V, W}], {}];
adCenter[ad_] := NS[Join @@ ad];
adDescend[ad_] := 
        adDescend[ad, Id[ℓ[ad]]];
adDescend[ad_, V_] := 
        FixedPointList[Rr[Join @@ T[adCom[ad, V, #1], {3, 1, 2}]] &, 
          V];
adDerived[ad_] := 
        FixedPointList[Rr[Join @@ T[adCom[ad, #1, #1], {3, 1, 2}]] &, 
          Id[ℓ[ad]]];
adSub[ad_, V_, f_:  FixedPoint] := 
        f[Rr[Join[#1, Join @@ T[adCom[ad, #1, #1], {3, 1, 2}]]] &, 
          V];

representation

adζTr[ζ_] := ΤC[
          T[ζ, {1, 3, 2}] . ζ, 1, 
          3];
adζCasimir[ζ_] := ΤC[
          T[ζ, {1, 3, 2}] . ζ . Inv[adζTr[ζ]], 2, 
          4];

spectrum

adEigenspace[ad_, X_List, λ_] := 
        NS[MatrixPower[
            ad . X - λ Id[ℓ[ad]], ℓ[
              ad]]];
adCharacter[ad_, x_Symbol, λ_] := 
        adCharacter[
          ad, Τ★[
            x, ℓ[ad]], λ];
adCharacter[ad_, X_List, λ_] := 
        Det[ad . 
              X - λ Id[ℓ[
                  ad]]];
adRank[ad_] := adRank[ad] = 
          With[
{fp = 
                Ft[Position[
                    S[CoefficientList[
                        adCharacter[ad, x, λ], λ]], 
                    0]]}, 
ℓ[
              Position[fp - Range[ℓ[fp]], 0]]];

dont know if adRoots the following code is universal(!) adRootspace more elegant please?

adCartanSubalgebra[ad_, X_: {}] := 1;
adRoots[ad_, rin_:  0] := 
        Module[{r, α, H}, 
          r = If[rin == 0, adRank[ad], 
              rin]; 
α = 
            Pr[Τ★[a, r], ℓ[ad]]; 
          H = Pr[Τ★[x, r], ℓ[
                ad]]; 
Τ★[a, 
              r] /. Union[
              Solve[E0[
adCharacter[ad, 
                    H, α . 
                      H], 
adCharacter[
                        ad, #1, α . #1] & /@ Id[ℓ[
                          ad]][[
                      Range[r]]]], Τ★[a, r]]]];
adRootspace[ad_, α_List] := 
NS[
          ad . Pr[Τ★[
                  x, ℓ[α]], ℓ[
                  ad]] - α . Τ★[
                  x, ℓ[α]] Id[ℓ[
                  ad]]];

look up in book if correct !

adStars[ad_, α_] := 
        With[{rn = 
              Range[Dims[α][[2]]]}, 
α . 
            Inv[adKilling[ad][[rn, 
                rn]]]];
adStarsNormed[ad_, α_] := 
        With[
{rn = 
              Range[Dims[α][[2]]], 
            s = adStars[ad, α]}, 
If[
                And @@ E0[#1], #1, 
                2  #1/(adKilling[ad][[rn, 
                          rn]] . #1 . #1)] & /@ 
            s
];

Lie algebras.matrix

TODOs: 
• 𝔤𝔩Close with Outer (einigermassen moeglich)
• 𝔤𝔩2ad not ideal yet :-(

𝔤𝔩Com[x_, y_] := 𝓈[
          x . y - y . x];
𝔤𝔩2ad[𝔤_] := 
        Module[{X = Τ★[
                x, ℓ[𝔤]]}, 
T[
            Array[With[{α = 
                      X . 𝔤 - 𝔤𝔩Com[𝔤[[#1]], 𝔤[[#2]]]}, 
LSolve[α, 
                    X]] &, {ℓ[𝔤], ℓ[𝔤]}], {3, 2, 1}]];

ad∡𝔤𝔩[ad_, 𝔤_] := 
        With[{n = ℓ[ad], 
            m = ℓ[𝔤] + ℓ[
                  ad], 𝔤ad = 𝔤𝔩2ad[𝔤]}, 
Array[
            Which[
#1 ≤ n ∧ #2 ≤ 
                    n ∧ #3 ≤ n, 
                ad[[#1, #2, #3]], 
#1 ≤ n ∧ #2 ≤ n ∧ #3 > 
                    n, +𝔤[[#3 - 
                        n]][[#1, #2]], 
#1 ≤ n ∧ #2 > 
                    n ∧ #3 ≤ 
                    n, -𝔤[[#2 - 
                        n]][[#1, #3]], 
#1 > n ∧ #2 > n ∧ #3 > 
                    n, 𝔤ad[[#1 - n, #2 - n, #3 - 
                    n]], 
True, 
                0] &, {m, m, m}]];

FtCom[x_, y_] := 
        With[{n = (Sqrt[ℓ])[x]}, 
          Ft[Pt[x, n] . Pt[y, n] - 
              Pt[y, n] . Pt[x, n]]];
𝔤𝔩Hash[n_Int] := 
        Module[{cnt = 
              Array[(((#1 - 1))^2) &, {n}]}, 
++cnt[[#1]] & /@ 
            Ft[Array[Max[#1, #2] &, {n, n}]]];
𝔤𝔩Close[{}] = {};
𝔤𝔩Close[𝔤_] := 
        Module[{n = ℓ[𝔤[[1]]], 
            cnt, ℐn, ℐν}, 
ℐn = 𝔤𝔩Hash[
              n]; ℐν = 
            InversePermutation[ℐn]; 
Pt[#1[[ℐn]], n] & /@ 
            FixedPoint[
Rr[
                  Join[#1, 
                    Join @@ Table[FtCom[#1[[
                                c1]][[ℐn]], #1[[
                                c2]][[ℐn]]][[ℐν]], {c1, ℓ[#1]}, {c2, ℓ[#1]}]]] &, 
Ft[#1][[ℐν]] & /@ Union[𝔤], 
              (n^2)]];

𝔤𝔩Algebra::unknownfld = "unknown field. supported \
are ℝ, and ℂ";
𝔤𝔩Algebra[n_, inv_, 
          fld_:  ℝ] := 
        Module[{A, ar, as}, 
          Which[
fld == ℝ, 
            A = Τ★[
                ar, {n, 
                  n}], 
fld == ℂ, 
            A = Τ★[
                  ar, {n, 
                    n}] + I Τ★[
                    as, {n, n}], 
True, 
            Message[𝔤𝔩Algebra::unknownfld]]; 
HSolve[#1[A] & /@ 𝒻[inv], 
              A] // 𝓈];

Lie groups

TODOs: 
• diffeo hfb th 1.5 p.12 
• volume form hfb th 1.13 p.24

𝔊Inv::Problem = "with inverting group \
elements";
\(\(𝔊Inv[ϕin_, e_, hin_:  I] := 
        Module[{n = ℓ[ϕin], ϕ, h, eqs, 
            gi}, 
h = 
            If[hin == I, n, 
              hin]; 
ϕ = ϕin /. 
              Table[y\_k -> 
                  e[[k]], {k, h + 1, 
                  n}]; 
eqs = 
            Reduce[E0[\((ϕ - e)\)[[
                  Range[h]]]], Τ★[y, 
                h]]; 
gi = Τ★[
                  y, h] /. Solve[eqs, Τ★[y, h]] // 
              S; 
If[debug || inQ[showMe, "eqs"], 
            Print["eqs: ", eqs, "  ", 
              gi]]; 
If[ℓ[gi] ≠ 
              1, 
Print["suggest ", Τ★[y, 𝔊[]] /. 
                Solve[E0[ϕ - 𝔊[
                        0]], Τ★[
                    y, 𝔊[]]]]; 
Message[𝔊Inv::Problem], 
gi[[1]]⊕e[[
                  Range[h + 1, n]]] /. 
              y -> x
]];\)\)

\(\(𝔊Setup::Dimensions = "violation in group action";\)\)
\(\(𝔊Setup[ϕ_, e_: {}, inv_: {}] := 
        Module[{𝔊, 
            gi, τ}, 
𝔊[] = ℓ[ϕ]; 
𝔊[0] = 
            If[ℓ[e] > 0, e, 
              Array[0 &, ℓ[ϕ]]]; 
𝔊[xin_List, yin_List] := 
            If[ℓ[xin] == ℓ[
                  yin] == 𝔊[], 
S[ϕ /. Ft[Τ★[
                        x, 𝔊[]] → 
                      xin, Τ★[
                        y, 𝔊[]] → 
                      yin]], 
Message[𝔊Setup::Dimensions]]; 
𝔊[x_List, 
              y_Symbol] := 𝔊[
              x, Τ★[
                y, 𝔊[]]]; 
𝔊[x_Symbol, 
              y_List] := 𝔊[Τ★[
                x, 𝔊[]], 
              y]; 
𝔊[x_Symbol, 
              y_Symbol] := 𝔊[Τ★[
                x, 𝔊[]], Τ★[
                y, 𝔊[]]]; 
If[ℓ[
                inv] == 
              0, 
𝔊[–] = 𝔊Inv[ϕ, 𝔊[
                  0]], 
If[ℓ[τ = 
                    E0[0, 𝔊[inv, x] - 𝔊[
                          0], 𝔊[x, inv] - 𝔊[
                          0]]] ≠ 1, 
              Print["consist??? = ", τ]]; 
𝔊[–] = S[inv]]; 
𝔊[
              x_List] := 𝔊[–]∘
              x; 
𝔊[
              x_Symbol] := 𝔊[Τ★[
                x, 𝔊[]]]; 
𝔊];\)\)

𝔊α[𝔊_, α_] := 
        With[{αi = 
              Inv[α]}, 
Print[αi . 𝔊[α . Τ★[
                    x, 𝔊[]], α . Τ★[
                    y, 𝔊[]]]]; 
𝔊Setup[
αi . 𝔊[α . Τ★[
                    x, 𝔊[]], α . Τ★[y, 𝔊[]]], αi . 𝔊[
                0], αi . 𝔊[α . Τ★[x, 𝔊[]]]]];

Adjoint representations

𝔊Ad[𝔊_] := Μd[𝔊[𝔊[g, x], 𝔊[g]], 
                1]∘𝔊[0] /. g -> x // 
          S;
𝔊ad[𝔊_] := 
        T[Μd[𝔊Ad[𝔊], 
                1]∘𝔊[0], {1, 3, 2}] // 
          S;

Left- and right-invariant tensors

𝔊dL[𝔊_] := 𝔊dL[𝔊] = Μd[𝔊[𝔊[y], 
                  x], 1] /. y -> x // S;
𝔊dR[𝔊_] := 𝔊dR[𝔊] = Μd[𝔊[
                  x, 𝔊[y]], 1] /. y -> x // 
            S;
𝔊ΤL[𝔊_, X_, 
          r_Int] := Τα[X, 
            r, 𝔊dL[𝔊]] // 
          S;
𝔊ΤR[𝔊_, X_, 
          r_Int] := Τα[X, 
            r, 𝔊dR[𝔊]] // S;

𝔊ExpL[𝔊_, 
          v_] := ΧIntegral[𝔊ΤL[𝔊, v, 1]];
𝔊EL[𝔊_, 
          v_, ℐ_: {-1, 
              1}] := Χα[𝔊ΤL[𝔊, v, 1], 𝔊[
            0], ℐ];
𝔊ER[𝔊_, 
          v_, ℐ_: {-1, 
              1}] := Χα[𝔊ΤR[𝔊, v, 1], 𝔊[
            0], ℐ];

\(\(adδ[ad_] := 
        Module[{n = ℓ[ad], 
            m, α, αi, 
at = ad, 𝔫 = 
              Range[ℓ[ad] - 1], 
cbh, e, 
            inv, 
s, j}, 
α = 
            EXP[m = ad[[𝔫, 𝔫, 
                    n]]\ x\_n]; αi = 
            Inv[α]; 
If[
            debug, 
{s, j} = 
              JordanDecomposition[\(-m\)]; 
Print["jnf  ", j // MF]; 
Print["exp  ", \(α // S\) // 
                MF, "    |·|= ", 
              S[Det[α]]]; 
Print[\*""\!\(\(exp\^-\)\) "", \(αi // S\) // 
                MF]]; 
at[[𝔫, 𝔫, n]] = 0; 
          at[[𝔫, 
              n, 𝔫]] = 
            0; 
{cbh, e, inv} = 
            adCBH[at]; 
If[debug, 
            Print[{cbh, e, 
                inv}]]; 
inv[[𝔫]] = αi . 
              inv[[𝔫]]; 
 (*\(Print["ded", 
                cbh /. Τ★[y, 
                      n - 1] → α . Τ★[y, n - 
                          1]];\)*) 
S[{cbh /. Τ★[y, 
                    n - 1] → α . Τ★[y, n - 1], e, inv}]];\)\)

adCBH[ad_, p_Int] := 
        adCBH[ad, 
          p, Τ★[
            x, ℓ[ad]], Τ★[
            y, ℓ[ad]]];
adCBH[ad_, p_Int, X_, Y_] := 
        Module[
{glb = 
              Prepend[Array[0 &, {p, ℓ[ad]}], X], AX = ad . X, 
            AY = ad . Y, 
            cnt = 0}, 
adCBHin[v_, d_, qp_, s_] := 
            Module[{n = ℓ[qp], 
                k = ℓ[qp]/
                    2}, cnt++; 
glb[[
                  d]] += 
                v (((-1))^k)/(k + 1)/(1 + 
                          Plus @@ qp[[
                              Range[1, ℓ[qp], 
                                2]]])/
                    Times @@ (qp!); 
If[
                d ≤ p && ℓ[E0[0, v]] > 
                    1, 
If[
                  n > 0, 
If[s, 
                    adCBHin[AY . v, d + 1, 
                      qp + Id[n][[
                          n - 1]], 
                      True]]; 
adCBHin[AX . v, d + 1, 
                    qp + Id[n][[n]], 
                    False];]; 
adCBHin[AY . v, d + 1, 
                  Join[qp, {1, 0}], True]; 
adCBHin[AX . v, 
                  d + 1, Join[qp, {0, 1}], 
                  False];
];]; 
Table[
            adCBHin[MatrixPower[AX, m] . Y/m!, m + 1, {}, True], {m, 0, 
              p}]; 
If[debug, 
            Print[cnt, " recursive calls"]]; 
S[
            glb]];

adCBH::Nilpotency = "in question";
\(\(adCBH[ad_] := 
        Module[{nil = adDescend[ad], 
            n = ℓ[ad]}, 
If[debug, 
            Print["descent: ", \(ℓ[#1] &\) /@ 
                nil]]; 
If[ℓ[
                nil[[\(-1\)]]] ≠ 0, Message[adCBH::Nilpotency]; 
            Return[]]; 
{Plus @@ 
              adCBH[ad, ℓ[ad] + 1], 
            Array[0 &, 
              n], \(-Τ★[x, n]\)}];\)\)

Homogeneous triples

TODOs:
• what does "Naturally" do

Η𝔥𝔪[ad_, 
          X_] := {Range[ℓ[ad] - ℓ[X]], 
          Range[ℓ[ad] - ℓ[X] + 1, ℓ[
              ad]]};
ΗadInv[ad_, X_, r_Int] := 
        Module[{𝔥, 𝔪}, {𝔥, 𝔪} = Η𝔥𝔪[ad, 
              X]; 
Τdα[X, r, 
            ad[[𝔪, 𝔪, 𝔥]]]];

Ην𝔪[ad_, ℊ_] := 
        With[{𝔪 = Η𝔥𝔪[
                  ad, ℊ][[2]]}, Inv[ℊ] . (𝓉[ℊ . 
                      ad[[𝔪, 𝔪, 𝔪]], {3, 2, 1}] + 𝓉[ℊ . 
                      ad[[𝔪, 𝔪, 𝔪]], {2, 3, 1}])/
            2];
Ην[ad_, ℊ_] := 
        Module[{𝔥, 𝔪}, {𝔥, 𝔪} = Η𝔥𝔪[
                ad, ℊ]; 
ΤJ[-ad[[𝔪, 𝔥, All]]/
                2, ΤJ[
                ad[[𝔪, 𝔪, 𝔥]]/2, Ην𝔪[ad, ℊ], 3], 
              2]] // 𝓈;
ΗΛ[ad_, ℊ_] := 
        With[{𝔪 = Η𝔥𝔪[
                    ad, ℊ][[2]]}, 
            ad[[𝔪, 𝔪]]/
                2 + Ην[ad, ℊ][[
                All, 𝔪]]] // 𝓈;
Ηℛ[
          ad_, ℊ_] := ΗΛℛ[
          ad, ΗΛ[
            ad, ℊ]];
ΗΛℛ[
          ad_, Λ_] := 
        With[{𝔪 = 
              Range[ℓ[ad] - ℓ[Λ] + 
                  1, ℓ[
                  ad]]}, 𝓈[
(𝓉[𝓉[Λ, {1, 3, 2}] . Λ, {1, 4, 2, 
                        3}] - 𝓉[𝓉[Λ, {1, 3, 
                            2}] . Λ, {1, 3, 2, 
                        4}])[[All, 
                All, 𝔪, 𝔪]] - Λ . 
                ad[[
                  All, 𝔪, 𝔪]]]];
ΗΡHolonomy[Λ_, ℛ_] := 
        With[{L = 𝓉[Λ, {2, 3, 
                    1}][[Range[Dims[Λ][[3]] - ℓ[Λ] + 
                    1, Dims[Λ][[3]]]]]}, 
FixedPoint[𝔤𝔩Close[
                Join[#1, 
                  Join @@ Outer[𝔤𝔩Com, L, #1, 
                      1]]] &, 𝔤𝔩Close[
              Join @@ 𝓉[ℛ, {3, 4, 1, 
                    2}]]]];

Ηreductive[ad_, n_] := 
        Module[{𝔥 = Range[ℓ[ad] - n], 𝔪 = 
              Range[ℓ[ad] - n + 1, ℓ[
                  ad]]}, 
ad[[𝔥, 𝔪, 𝔥]]];
Ηsymmetric[ad_, n_] := 
        With[{𝔪 = Range[ℓ[ad] - n + 1, ℓ[ad]]}, 
          ad[[𝔪, 𝔪, 𝔪]]];
ΗΡNaturally[ad_, ℊ_] := 
        With[{𝔪 = Η𝔥𝔪[
                  ad, ℊ][[2]]}, ℊ . 
              ad[[𝔪, 𝔪, 𝔪]] + 
            T[ℊ . 
                ad[[𝔪, 𝔪, 𝔪]], {3, 2, 1}]];

Homogeneous spaces

Η𝔊[𝔊_, n_Int] := 
        Module[{gh}, 
𝔊[Η] = 
            Range[𝔊[] - 
                n]; 
𝔊[Μ] = 
            Range[𝔊[] - n + 
                1, 𝔊[]]; 
𝔊[
              x_List, ι] := 𝔊[0][[
                Range[𝔊[] - ℓ[
                      x]]]]⊕x;  (*embeds x ∈ 
              G or x ∈ Μ in G*) 
𝔊[
              x_Symbol, ι] := 𝔊[Τ★[
                x, ℓ[𝔊[Μ]]], ι]; 
𝔊[
              x_Symbol, Η] := Τ★[
                x, ℓ[𝔊[Η]]]⊕𝔊[
                  0][[𝔊[Μ]]]; 
gh = 𝔊[Τ★[
                x, 𝔊[]], 𝔊[
                h, Η]]; 
𝔊[π] := 𝔊[π] = (gh /. Solve[E0[(gh - 𝔊[
                                  0])[[𝔊[Η]]]], 
                        Vars[𝔊[
                            h, Η]]][[1]])[[𝔊[Μ]]]; 
𝔊[
              x_List, Μ] := 𝔊[π]∘𝔊[x, ι]; 
𝔊[
              g_, Μ] := 𝔊[π] /. 
              x -> 
                g;  (*g denotes coords in G*) 
𝔊[x_List, 
              y_List, Μ] := 𝔊[𝔊[𝔊[x, ι], 𝔊[
                  
                  y, ι]], Μ]; 
𝔊[x_, 
              y_List, Μ] := 𝔊[Τ★[x, 𝔊[]], 
              y, Μ]; 
𝔊[
              x_List, υm_, Μ] := 𝔊[
              x, Τ★[υm, 
                n], Μ]; 
𝔊[
              x_, υm_, Μ] := 𝔊[
              x, Τ★[υm, 
                n], Μ];
];

Η𝔛[𝔊_, 
          v_] := ((∂_𝓉) 𝔊[𝔊EL[𝔊, v], 
                x, Μ]) /. 𝓉 -> 0;

Ηdτ[𝔊_] := 
      With[{mh = 𝔊[𝔊[
                m, ι], 𝔊[
                h, Η]]}, Μd[𝔊[mh, 
                x, Μ], 1] /. m -> x // S]

Yet to sort

RungeKutta[X_] := 
        Module[
{t = 
              X[[1]], 
            x = X[[2]], k1, k2, k3, 
            k4}, 
k1 = Φ[t, 
              x]; 
k2 = Φ[t +  .5 h, 
              x +  .5 h k1]; 
k3 = Φ[
              t +  .5 h, 
              x +  .5 h k2]; 
k4 = Φ[t + h, 
              x + h k3]; 
{t + h, 
            x + h {(1/6), (1/3), (1/3), (1/6)} . {k1, k2, k3, 
                    k4}}];

Utilities

Default constructors

Pure constructors, <!> ad★ only realises skew, but not jacobi ,TODO: Τ𝒮 etc for any tensor rank

Τ𝒮★[v_, n_] := 
        Module[{A = Array[0 &, {n, n}], 
            cnt = 0}, 
Array[(A[[#1, #2]] = 
                  If[#1 ≤ #2, (Subscript[v, ++cnt]), 
                    A[[#2, #1]]]) &, {n, n}]];
Τ𝒜★[v_, n_] := 
        Module[{A = Array[0 &, {n, n}], 
            cnt = 0}, 
Array[(A[[#1, #2]] = 
                  Which[#1 == #2, 
                    0, #1 < #2, -(Subscript[v, ++cnt]), #1 > #2, -A[[#2, #1]]]) &, {n, 
              n}]];
Τℛ★[v_, n_Int] := 
        With[{ℛ = Τ★[
                v, {n, n, n, n}]}, 
          LSolve[{ΜℛSkew[ℛ], ΜℛBianchi[ℛ]}, ℛ]];
Τℛ★[
          v_, ℊ_List] := 
        Module[{n = ℓ[ℊ], ℛ}, ℛ = Τ★[
              v, {n, n, n, 
                n}]; 
LSolve[{ΜℛSkew[ℛ], ΜℛBianchi[ℛ], ΜℛSkew[ℛ, ℊ]}, ℛ]];
ad★[v_, n_] := 
        Array[Which[#2 > #3, 
              (Subscript[a, #1, #2, #3]), #2 < #3, -(Subscript[a, #1, #3, #2]), True, 
              0] &, {n, n, n}];

does anybody need this:

ΜΓ★[ℊ_] := ΜΓ[ℊ] = 
          Array[(Subscript[Γ, #1, Min[#2, #3], Max[#2, #3]]) @@ 
                Table[(Subscript[x, k]), {k, ℓ[ℊ]}] &, {ℓ[ℊ], ℓ[ℊ], ℓ[ℊ]}];

parametrizations

\(\(ΜϕSphere[n_, f_:  Nest] := 
        Module[{cnt = 0}, 
          assum = Array[\(-ε\) < 
                  x\_#1 < ε &, {n + 1}]; 
\(f[
              With[{k = \(++cnt\)}, Ft[#1\ Cos[x\_k], Sin[x\_k]]] &, {1}, 
              n]\)[[Ft[Range[2, n + 1], 
              1]]]];\)\)
ΜϕSphereH[n_] := 
        With[{X = Τ★[x, n]}, 
          X⊕{(Sqrt[(r^2) - X . X])}];

differential of parametrization of torus is not pretty in 0 for high dimensions. is there a better way?

\(\(ΜϕTorus[n_, f_:  Nest] := 
        Module[{cnt = 1}, 
          assum = Array[\(-ε\) < x\_#1 < ε &, 
              n]; 
f[
            With[{k = \(++cnt\)}, 
                Ft[{#1 + #1\ \(r\_k\) Sin[x\_k]}, \(r\_k\) 
                    Cos[x\_k]]] &, 
{r\_1\ Sin[
                  x\_1], \(r\_1\) Cos[x\_1]}, n - 1]];\)\)

ΤℊSigned[n_, p_] := 
        Join @@ {Pl[#1, n + p] & /@ Id[n], Pl[Pr[#1, p], n + p] & /@ 
              Id[p - n], Pr[#1, n + p] & /@ 
              Id[n]};
ΜℊHyperbolicDisc[
          n_] := (((2/(1 - Τ★[x, 
                          n] . Τ★[x, 
                          n])))^2) Id[n];
ΜℊHyperbolicPlane[n_] := 
        (r^2)/(Subscript[x, n]^2) Id[n];

inv𝔤𝔩 = {};
inv𝔱 = {Table[
              Pr[#1[[k]], 
                k - 1], {k, ℓ[#1]}] &};
inv𝔲𝔱 = {Table[
              Pr[#1[[k]], 
                k], {k, ℓ[#1]}] &};
inv𝔰𝔱 = {Table[
              Pr[#1[[k]], 
                k - 1], {k, ℓ[#1]}] &, 
          Tr[#1] &};
inv𝔰𝔩 = {Tr[#1] &};
inv𝔲[p_, 
          q_:  0] := {#(1^\[HermitianConjugate])  . Id[p, q] + 
              Id[p, q] . #1 &};
inv𝔰𝔲[p_, 
          q_:  0] := {#(1^\[HermitianConjugate])  . Id[p, q] + 
              Id[p, q] . #1 &, Tr[#1] &};
inv𝔰𝔭[p_] := 
        With[{B = 
              Join[Pl[-#1, 2 p] & /@ Id[p], Pr[#1, 2 p] & /@ 
                  Id[p]]}, {#(1^\[HermitianConjugate])  . B + 
                B . #1 &}];

adℋℯ[n_] := 
        ad∡𝔤𝔩[
          0 ad★[a, n + 1], 
          Array[-δ[#2, n + 1] δ[#3, #1] &, {n, n + 1, 
              n + 1}]];

(*Τℊ★[n_,r_,s_]:=With[{m=2n+r+s},Join@@{
            PadLeft[PadRight[#1,n+s],m]&/@Id[n],
            PadLeft[PadRight[#1,n+s+r],m]&/@Id[r],
            PadRight[#1,m]&/@Id[n],
            PadLeft[#1,m]&/@Id[s]}];*)

Display

TODO:
• merge ShowM
• IMPORTANT: return [ all computed values ]

showMe = "";

ShowMat[X_, 
          n_Integer:  1] := MF[#1] & /@ 𝓉[
            X, 𝒻[Range[2, n], 1]];

ShowΓFunc = Identity;
ShowΓLevel = 1;
\(\(ShowΓ[G_] := 
        TF[ShowΓFunc[{Array["Γ"\_\(i, j\)\%\(ToString[#1]\) &, ℓ[G]], 
              ShowMat[G, ShowΓLevel]}], 
          TableSpacing -> {1, 1}];\)\)

Showν[ν_, αin_: {}] := 
        Module[{n = Dims[ν][[3]], α = αin}, 
If[α == {}, α = 
              Join @@ {Τ★[e, 
                    n - ℓ[ν]], Τ★[
                    u, ℓ[ν]]}]; 
TF[α[[Range[n - ℓ[ν] + 1, 
                  n]]] . ν, 
            TableHeadings -> {α, α}, 
            TableSpacing -> {1, 1}]];

ShowΛFunc = Identity;
\(\(ShowΛ[Λ_] := 
        TF[ShowΛFunc[{Array["Λ"\_\(j, ToString[#1]\)\%i &, \(Dims[Λ]\)[[3]]], ShowMat[Λ, 3]}], 
          TableSpacing -> {1, 1}];\)\)

ShowℛFunc = Identity;
\(\(ShowℛCheck[ℛ_, ℊ_] := 
        If[ℓ[
              E0[0, ΜℛSkew[ℛ], ΜℛBianchi[ℛ], ΜℛSkew[ℛ, ℊ], ΜℛRotate[ℛ, ℊ]]] ≠ 
            1, 
Print["Riemann curvature ids!!!"], 
Print["fine:"]
];\)\)
\(\(Showℛ[ℛ_, ℊ_: {}] := 
        Module[
{m, 
            lst = {}}, 
If[ℓ[ℊ] > 0, 
            ShowℛCheck[ℛ, ℊ]]; 
If[ℓ[𝓃[ℛ, 0]] == 
              1, 
"ℛ-Flat", 
\(If[ℓ[𝓃[
                        m = 𝓈[ℛ[[
                              All, All, #1[[2]], #1[[1]]]]], 0]] > 
                    1, 
AppendTo[
lst, {\ 
                      RIE\_\(ToString[#1[[1]]], ToString[#1[[2]]], j\)\%i, MF[m]}]] &\) /@ 
              KSubsets[Range[ℓ[ℛ]], 
                2]; 
TF[
              ShowℛFunc[𝓉[lst]], 
              TableSpacing -> {1, 1}]]];\)\)

semi-Riemannian manifold

ShowΜ::metric = "not symmetric";
\(\(ShowΜ[ℊ_, p_List: {}] := 
        Module[{ℊp = ℊ∘
                p, Γp = ΜΓ[ℊ]∘
                p, ℛ = Μℛ[ℊ], ℛp, 
            Ric}, 
If[ℓ[𝓃[Τ𝒜[ℊp], 0]] ≠ 1, 
            Message[ShowΜ::metric]]; 
ℛp = ℛ∘p; 
If[
            inQ[showMe, "ℊ"], 
            Print["metric ", ℊp // MF, " |·|=", 
              Det[ℊp]]]; 
If[
            inQ[showMe, "Γ"], 
            Print[ShowΓ[Γp]]]; 
If[inQ[showMe, "ℛ"], 
            Print[Showℛ[ℛp, ℊp]]]; 
Ric = ΜRic[ℛp]; 
If[inQ[showMe, "Ric"], 
            Print["ricci  ", MF[Ric]]]; 
If[
            inQ[showMe, "S"], 
            Print["scalar ", ΜS[ℊ]∘
                p]]; 
{ℊp, Γp, ℛp, Ric}
];\)\)
\(\(ShowΜ[ℊ_, n_Int] := 
        Module[{ℛ = Μℛ[ℊ], κ = "κ", 
            v = "v"}, 
Print["metric ", ℊ // 
              MF]; 
Print["christ↓ "]; 
Print[
            ShowΓ[ΜΓ[ℊ]]]; 
Print[\*""II=(Subscript[Γ, sub]) "", 
            ShowΓ[ΜII[ℊ, 
                n]]]; 
Print["shape= ", ΜShape[ℊ] // 
              MF]; 
If[ℓ[ℊ] == 
              n + 1, With[{sys = ΜHyper[ℊ]}, 
Table[
                Print["   ", κ\_k, "= ", 
                  sys[[1, k]], "  ", 
                  v\_k, "= ", 
                  sys[[2, k]]], {k, 
                  n}]; 
Print[" K=Πκ    ", Times @@ 
                  sys[[1]]]; 
Print[" H=Σκ/n  ", 
                Plus @@ sys[[1]]/
                  n];
]];
];\)\)

ShowAd[ad_, n_Integer:  0] := 
        ShowAd[ad, 
          Join[Τ★[
              e, ℓ[ad] - n], Τ★[u, 
              n]]];
\(\(ShowAd[ad_, α_List] := 
        Module[{}, 
If[ℓ[𝓃[0, 
                  adSkew[ad]]] > 1, 
            Print["not skew."]]; 
If[ℓ[𝓃[0, adJacobi[ad]]] > 1, 
            Print["not jacobian."]]; 
α . \(-ad\) // MF];\)\)

\(\(ShowCBH[ad_, cbh_, ℐin_: {}] := 
        Module[{X = Τ★[x, ℓ[ad]], 
            Y = Τ★[
                y, ℓ[
                  ad]]}, 
If[ℐin == {}, ℐ = 
              Range[ℓ[
                  ad]], ℐ = ℐin]; 
Print["terms 1-3 ", 
            E0[0, 
cbh[[2]] - ad . X . Y/2, 
              cbh[[3]] + \((ad . ad . 
                        X . Y . X + ad . ad . Y . X . Y)\)/
                  12, 
cbh[[4]] - 
                ad . ad . ad . Y . X . X . Y/
                  24]
]; 
Table[\(Print[
                k, cbh[[
                  k, ℐ]]];\), {k, ℓ[cbh]}];
];\)\)

Lie Group

\(\(Show𝔊[𝔊_] := 
        Module[{dL, dR, Ad, ad, bas}, 
If[
            debug || inQ[
                showMe, "∘"], 
Print["act ", 𝔊[x, 
                y]]; 
Print["one ", 𝔊[
                0]]; 
Print["inv ", 𝔊[–]]]; 
If[
            debug || inQ[showMe, "dL"], 
Print[
              TF[{{\*"" dL=(Subscript[d, x])(g∘x)_(x -> e, g -> x)"", \*"" Ad=(Subscript[d, x])(g∘x∘\!\(\(g\^-\)\))_(x -> e, g -> x)""}, 
ShowMat[{dL = 
                          Inv[𝔊dL[𝔊]] // S, 
                        Ad = 𝔊Ad[𝔊]}], 
S[\(Det[#1] &\) /@ {dL, Ad}]} // T, 
                TableSpacing -> {1, 1}]]]; 
If[
            debug || inQ[
                showMe, "ad"], 
Print[\*"" ad=(Subscript[d, x])(Ad)_(x -> e)   "", 
              ShowAd[ad = 𝔊ad[𝔊]], "  κ=", \(adKilling[ad] // S\) // 
                MF]];
];\)\)

\(\(ShowΗ[𝔊_] := 
        Module[{}, 
Print["π:x∈𝔊->Μ  ", 𝔊[π]]; 
 (*\(Print[
\*""test:  π∘(Subscript[L, a])=(Subscript[τ, a])∘π "", 
                E0[𝔊[𝔊[a, 
                        x], Μ] - 𝔊[
                      a, 𝔊[π], Μ]], 
\*""        (Subscript[τ, ab])=(Subscript[τ, a])∘(Subscript[τ, b]) "", 
                E0[𝔊[𝔊[a, b], 
                      m, Μ] - 𝔊[
                      a, 𝔊[b, 
                        m, Μ], Μ]]];\)*) 
Print["     ad= ", 
            ShowAd[𝔊ad[𝔊], ℓ[𝔊[Μ]]]]; 
Print[" x∘m->Μ   ", 𝔊[x, 
                m, Μ] // 
              S]; 
Print[\*""(Subscript[d, x])(x∘m)_(x -> e, m -> x)  "", ΗdLΜ[𝔊] /. x -> m // 
              MF]; 
Print[\*""(Subscript[d, x])(g∘x)_(x -> e, g -> x)  "", Ηdτ[𝔊] // 
              MF]; 
Print[\*""   Ad\!\(\( | \_H\)\)="", 𝔊Ad[G]∘𝔊[
                  h, Η] // 
              MF, \*""    (Subscript[Ad, 𝔪]^𝔪)(x∈H)"", ΗAdΜ[𝔊] /. x -> h // 
              MF];
];\)\)

\(\(ShowΗ[adin_, ℊin_] := 
        Module[
{n = ℓ[ℊin], 
            ad, ℊ, ν, Λ, ℛ, Ric, 
            sol, eqs}, 
If[ℓ[
                E0[Ηreductive[adin, n], 0]] ≠ 1, 
            Print["not reductive!"]; 
            Return[]]; 
ℊ = 
            LSolve[ΗadInv[adin, ℊin, 
                0], ℊin]; 
ad = 
            LSolve[ΗadInv[adin, ℊ, 0], 
              adin]; 
If[inQ[showMe, "ad"], 
            Print["   ad  ", ShowAd[ad, n]]]; 
If[
            inQ[showMe, "kill"], 
            Print["killng ", adKilling[ad] // MF]]; 
If[
            debug, 
Print["adInv of B: ", 
              E0[ΗadInv[ad, ℊ, 0]], "   jacobi:  ", 
              E0[adJacobi[ad]]]]; 
If[
            inQ[showMe, "ℊ"], 
            Print["metric ", ℊ // MF, "   |·|=", 
              Det[ℊ] // 
                S]]; 
ν = Ην[
                ad, ℊ] // S; 
          If[inQ[showMe, "ν"], 
            Print["nu    ", 
              Showν[ν]]]; 
Λ = ΗΛ[ad, ℊ] // S; 
          If[inQ[showMe, "Λ"], 
            Print["LeviC ", 
              ShowΛ[Λ]]]; 
ℛ = ΗΛℛ[
                ad, Λ] // S; 
          If[inQ[showMe, "ℛ"], 
            Print[Showℛ[ℛ, ℊ]]]; 
Ric = ΜRic[ℛ] // S; 
          If[inQ[showMe, "Ric"], 
            Print["ricci ", 
              Ric // MF, "  scalar:", ΜS[ℊ, ℛ]]]; 
{ad, ℊ, Λ, ℛ, Ric, ν}];\)\)

Tex export

TODO:
Merge ShowM

ShowΓ𝓉[G_] := 
      TF[{Ft[Array[{(Subscript["Γ", i, j]^(ToString[#1])), 
                  G[[#1]] // 
                    MF} &, ℓ[G]]]}]

ShowΓFunc = Identity;
\(\(ShowΓ[G_] := 
        TF[ShowΓFunc[{Array["Γ"\_\(i, j\)\%\(ToString[#1]\) &, ℓ[G]], ShowMat[G]}], 
          TableSpacing -> {1, 1}];\)\)

ShowΛind𝓉[{m_, t_, g_}, k_] := 
        If[k ≤ 
            g - m, (Subscript["e", k]), (Subscript["u", k - g + m])];
\(\(ShowΛ𝓉[L_] := 
        TF[{Ft[Array[{Λ "."\_\(ShowΛind𝓉[Dims[L], #1]\), 
                    L[[All, All, #1]] // 
                      MF} &, \(Dims[
                    L]\)[[3]]]]}];\)\)

\(\(ShowΜ𝓉[ℊ_, p_List: {}] := 
        Module[{ℛ = Μℛ[ℊ], ℛp}, 
ℛp = ℛ∘
              p; 
Print[\(ℊ∘p // 
                MF\) // tex]; 
Print[
            ShowΓ[ΜΓ[ℊ]∘p] // 
              tex]; 
 (*\(Print[
                Showℛ[ℛp] // 
                  tex];\)*) 
 (*If[ℓ[
                  E0[0, ΜℛSkew[ℛ], ΜℛSkew[ℛ, ℊ], ΜℛBianchi[ℛ], ΜℛRotate[ℛ, ℊ]]] ≠ 
                1, 
Print["!!! curvature identities "]]; 
Print["ricci ", ΜRic[ℛp] // 
                MF, "   scalar ", ΜS[ℊ]∘
                p];*) 
];\)\)

ShowAd𝓉[ad_, n_Int] := 
        ShowAd𝓉[ad, 
          Join[Τ★[
              e, ℓ[ad] - n], Τ★[u, 
              n]]];
ShowAd𝓉[ad_, α_List] := 
        TableForm[α . -ad, 
          TableHeadings -> {α, α}];

Show𝔊𝓉[𝔊_] := 
        Module[{dL, dR, Ad, 
            ad}, 
Print[𝔊[x, y] // 
              tex]; 
Print[𝔊[0] // 
              tex]; 
Print[𝔊[–] // 
              tex]; 
Print[𝔊dL[𝔊] // 
              tex]; 
Print[𝔊Ad[𝔊] // 
              tex]; 
Print[adKilling[𝔊ad[𝔊]] // MF // 
              tex]; 
ShowAd𝓉[𝔊ad[𝔊], 0]
];

ShowΗ𝓉[𝔊_] := 
        Module[{}, 
Print[𝔊[π] // 
              tex]; 
Print[𝔊[x, 
                  m, Μ] // S // 
              tex]; 
Print[ΗdLΜ[𝔊] /. x -> m // MF // 
              tex]; 
Print[Ηdτ[𝔊] // MF // 
              tex]; 
Print[𝔊Ad[
                    G]∘𝔊[h, Η] // 
                MF // 
              tex]; 
Print[ΗAdΜ[𝔊] /. x -> h // MF // 
              tex]; 
ShowAd𝓉[𝔊ad[𝔊], ℓ[𝔊[Μ]]]
];