Skip to main content
Mathematica

Return to Answer

deleted 390 characters in body
Source Link
Henrik Schumacher
Henrik Schumacher
  • 109.5k
  • 7
  • 186
  • 323
   ClearAll["Global`*"];

n = 4;
coord = {t, x, y, z};

(*For raising/lowering latin indices like a, b, ...*)
\[Eta]η = {{-1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}};
\[Eta]η // MatrixForm;
inveta = Inverse[\[Eta]];Inverse[η];
inveta // MatrixForm;

(*"e-Metric";*)
e = {{\[ScriptCapitalN][t], 0, 0, 0}, {0, \[ScriptA][t], 0, 0}, {0, 
    0, \[ScriptA][t], 0}, {0, 0, 0, \[ScriptA][t]}};
\[ScriptCapitalN][t] = -1;
e // MatrixForm;
dete = Det[e];
(*Inverse e-Metric*)
inve = Inverse[e];
inve // MatrixForm;
detinve = Det[inve];

g := g = Simplify[Table[
    ParallelSum[ \[Eta][[aη[[a, b]]*e[[a, \[Mu]]]*e[[bμ]]*e[[b, \[Nu]]]ν]]
     , {a, 1, n}, {b, 1, n}]
    , {\[Mu]μ, 1, n}, {\[Nu]ν, 1, n}]]
g // MatrixForm;
(*g is used to LOWER indices for Greek indices \[Mu]μ, \[Nu]*ν*)
invg = Inverse[g];
invg // MatrixForm;
(*invg is used to RAISE indices for Greek indices \[Mu]μ, \[Nu]*ν*)

(* In the form \[CapitalGamma]^Γ^{x}_{xx}*)
affine := affine = Simplify[Table[(1/2)*Sum[(invg[[i, s]])*
        (D[g[[s, j]], coord[[k]] ] +
          D[g[[s, k]], coord[[j]] ] - D[g[[j, k]], coord[[s]] ]), {s, 
        1, n}],
     {i, 1, n}, {j, 1, n}, {k, 1, n}] ];
listaffine := 
  Table[If[UnsameQ[affine[[i, j, k]], 
     0], {ToString[\[CapitalGamma][iToString[Γ[i, j, k]], 
     affine[[i, j, k]]}] , {i, 1, n}, {j, 1, n}, {k, 1, j}];
TableForm[Partition[DeleteCases[Flatten[listaffine], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R^{x}_{xxx} *)
riemann := riemann = Simplify[Table[
     D[affine[[i, j, l]], coord[[k]] ] - 
      D[affine[[i, j, k]], coord[[l]] ] +
      Sum[
       affine[[s, j, l]] affine[[i, k, s]] - 
        affine[[s, j, k]] affine[[i, l, s]],
       {s, 1, n}],
     {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1, n}] ];
listriemann := 
 Table[If[UnsameQ[riemann[[i, j, k, l]], 0], {ToString[R[i, j, k, l]],
     riemann[[i, j, k, l]]}] , {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1,
    k - 1}]
TableForm[Partition[DeleteCases[Flatten[listriemann], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R_{xxxx} *)
riemann1 := riemann1 = Simplify[Table[
    Sum[
     g[[\[Mu]g[[μ, \[Mu]1]]*riemann[[\[Mu]1μ1]]*riemann[[μ1, \[Nu]ν, \[Rho]ρ, \[Sigma]]]σ]]
     , {\[Mu]1μ1, 1, n}]
    , {\[Mu]μ, 1, n}, {\[Nu]ν, 1, n}, {\[Rho]ρ, 1, n}, {\[Sigma]σ, 1, n}]]
listriemann1 := 
  Table[If[UnsameQ[riemann1[[\[Mu]Table[If[UnsameQ[riemann1[[μ, \[Nu]ν, \[Rho]ρ, \[Sigma]]]σ]], 
     0], {ToString[R1[\[Mu]ToString[R1[μ, \[Nu]ν, \[Rho]ρ, \[Sigma]]]σ]], 
     riemann1[[\[Mu]riemann1[[μ, \[Nu]ν, \[Rho]ρ, \[Sigma]]]σ]]}] , {\[Mu]μ, 1, 
    n}, {\[Nu]ν, 1, n}, {\[Rho]ρ, 1, n}, {\[Sigma]σ, 1, \[Rho]ρ - 1}];
TableForm[Partition[DeleteCases[Flatten[listriemann1], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R^{xxxx} *)
riemann2 := riemann2 = Simplify[Table[
    Sum[
     Sum[
      Sum[
       invg[[\[Nu]1invg[[ν1, \[Nu]]]*invg[[\[Rho]1ν]]*invg[[ρ1, \[Rho]]]*ρ]]*
        invg[[\[Sigma]1invg[[σ1, \[Sigma]]]*σ]]*
        riemann[[\[Mu]riemann[[μ, \[Nu]1ν1, \[Rho]1ρ1, \[Sigma]1]]σ1]]
       , {\[Nu]1ν1, 1, n}]
      , {\[Rho]1ρ1, 1, n}]
     , {\[Sigma]1σ1, 1, n}]
    , {\[Mu]μ, 1, n}, {\[Nu]ν, 1, n}, {\[Rho]ρ, 1, n}, {\[Sigma]σ, 1, n}]]
listriemann2 := 
  Table[If[UnsameQ[riemann2[[\[Mu]Table[If[UnsameQ[riemann2[[μ, \[Nu]ν, \[Rho]ρ, \[Sigma]]]σ]], 
     0], {ToString[R2[\[Mu]ToString[R2[μ, \[Nu]ν, \[Rho]ρ, \[Sigma]]]σ]], 
     riemann2[[\[Mu]riemann2[[μ, \[Nu]ν, \[Rho]ρ, \[Sigma]]]σ]]}] , {\[Mu]μ, 1, 
    n}, {\[Nu]ν, 1, n}, {\[Rho]ρ, 1, n}, {\[Sigma]σ, 1, \[Rho]ρ - 1}];
TableForm[Partition[DeleteCases[Flatten[listriemann2], Null], 2], 
  TableSpacing -> {2, 2}];

KretschmannScalar = Simplify[
  Sum[riemann1[[a, b, c, d]]*riemann2[[a, b, c, d]], {a, 1, n}, {b, 1,
     n}, {c, 1, n}, {d, 1, n}]]

   ClearAll["Global`*"];

n = 4;
coord = {t, x, y, z};

(*For raising/lowering latin indices like a, b, ...*)
\[Eta] = {{-1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}};
\[Eta] // MatrixForm;
inveta = Inverse[\[Eta]];
inveta // MatrixForm;

(*"e-Metric";*)
e = {{\[ScriptCapitalN][t], 0, 0, 0}, {0, \[ScriptA][t], 0, 0}, {0, 
    0, \[ScriptA][t], 0}, {0, 0, 0, \[ScriptA][t]}};
\[ScriptCapitalN][t] = -1;
e // MatrixForm;
dete = Det[e];
(*Inverse e-Metric*)
inve = Inverse[e];
inve // MatrixForm;
detinve = Det[inve];

g := g = Simplify[Table[
    ParallelSum[ \[Eta][[a, b]]*e[[a, \[Mu]]]*e[[b, \[Nu]]]
     , {a, 1, n}, {b, 1, n}]
    , {\[Mu], 1, n}, {\[Nu], 1, n}]]
g // MatrixForm;
(*g is used to LOWER indices for Greek indices \[Mu], \[Nu]*)
invg = Inverse[g];
invg // MatrixForm;
(*invg is used to RAISE indices for Greek indices \[Mu], \[Nu]*)

(* In the form \[CapitalGamma]^{x}_{xx}*)
affine := affine = Simplify[Table[(1/2)*Sum[(invg[[i, s]])*
        (D[g[[s, j]], coord[[k]] ] +
          D[g[[s, k]], coord[[j]] ] - D[g[[j, k]], coord[[s]] ]), {s, 
        1, n}],
     {i, 1, n}, {j, 1, n}, {k, 1, n}] ];
listaffine := 
  Table[If[UnsameQ[affine[[i, j, k]], 
     0], {ToString[\[CapitalGamma][i, j, k]], 
     affine[[i, j, k]]}] , {i, 1, n}, {j, 1, n}, {k, 1, j}];
TableForm[Partition[DeleteCases[Flatten[listaffine], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R^{x}_{xxx} *)
riemann := riemann = Simplify[Table[
     D[affine[[i, j, l]], coord[[k]] ] - 
      D[affine[[i, j, k]], coord[[l]] ] +
      Sum[
       affine[[s, j, l]] affine[[i, k, s]] - 
        affine[[s, j, k]] affine[[i, l, s]],
       {s, 1, n}],
     {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1, n}] ];
listriemann := 
 Table[If[UnsameQ[riemann[[i, j, k, l]], 0], {ToString[R[i, j, k, l]],
     riemann[[i, j, k, l]]}] , {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1,
    k - 1}]
TableForm[Partition[DeleteCases[Flatten[listriemann], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R_{xxxx} *)
riemann1 := riemann1 = Simplify[Table[
    Sum[
     g[[\[Mu], \[Mu]1]]*riemann[[\[Mu]1, \[Nu], \[Rho], \[Sigma]]]
     , {\[Mu]1, 1, n}]
    , {\[Mu], 1, n}, {\[Nu], 1, n}, {\[Rho], 1, n}, {\[Sigma], 1, n}]]
listriemann1 := 
  Table[If[UnsameQ[riemann1[[\[Mu], \[Nu], \[Rho], \[Sigma]]], 
     0], {ToString[R1[\[Mu], \[Nu], \[Rho], \[Sigma]]], 
     riemann1[[\[Mu], \[Nu], \[Rho], \[Sigma]]]}] , {\[Mu], 1, 
    n}, {\[Nu], 1, n}, {\[Rho], 1, n}, {\[Sigma], 1, \[Rho] - 1}];
TableForm[Partition[DeleteCases[Flatten[listriemann1], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R^{xxxx} *)
riemann2 := riemann2 = Simplify[Table[
    Sum[
     Sum[
      Sum[
       invg[[\[Nu]1, \[Nu]]]*invg[[\[Rho]1, \[Rho]]]*
        invg[[\[Sigma]1, \[Sigma]]]*
        riemann[[\[Mu], \[Nu]1, \[Rho]1, \[Sigma]1]]
       , {\[Nu]1, 1, n}]
      , {\[Rho]1, 1, n}]
     , {\[Sigma]1, 1, n}]
    , {\[Mu], 1, n}, {\[Nu], 1, n}, {\[Rho], 1, n}, {\[Sigma], 1, n}]]
listriemann2 := 
  Table[If[UnsameQ[riemann2[[\[Mu], \[Nu], \[Rho], \[Sigma]]], 
     0], {ToString[R2[\[Mu], \[Nu], \[Rho], \[Sigma]]], 
     riemann2[[\[Mu], \[Nu], \[Rho], \[Sigma]]]}] , {\[Mu], 1, 
    n}, {\[Nu], 1, n}, {\[Rho], 1, n}, {\[Sigma], 1, \[Rho] - 1}];
TableForm[Partition[DeleteCases[Flatten[listriemann2], Null], 2], 
  TableSpacing -> {2, 2}];

KretschmannScalar = Simplify[
  Sum[riemann1[[a, b, c, d]]*riemann2[[a, b, c, d]], {a, 1, n}, {b, 1,
     n}, {c, 1, n}, {d, 1, n}]]

   ClearAll["Global`*"];

n = 4;
coord = {t, x, y, z};

(*For raising/lowering latin indices like a, b, ...*)
η = {{-1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}};
η // MatrixForm;
inveta = Inverse[η];
inveta // MatrixForm;

(*"e-Metric";*)
e = {{\[ScriptCapitalN][t], 0, 0, 0}, {0, \[ScriptA][t], 0, 0}, {0, 
    0, \[ScriptA][t], 0}, {0, 0, 0, \[ScriptA][t]}};
\[ScriptCapitalN][t] = -1;
e // MatrixForm;
dete = Det[e];
(*Inverse e-Metric*)
inve = Inverse[e];
inve // MatrixForm;
detinve = Det[inve];

g := g = Simplify[Table[
    ParallelSum[ η[[a, b]]*e[[a, μ]]*e[[b, ν]]
     , {a, 1, n}, {b, 1, n}]
    , {μ, 1, n}, {ν, 1, n}]]
g // MatrixForm;
(*g is used to LOWER indices for Greek indices μ, ν*)
invg = Inverse[g];
invg // MatrixForm;
(*invg is used to RAISE indices for Greek indices μ, ν*)

(* In the form Γ^{x}_{xx}*)
affine := affine = Simplify[Table[(1/2)*Sum[(invg[[i, s]])*
        (D[g[[s, j]], coord[[k]] ] +
          D[g[[s, k]], coord[[j]] ] - D[g[[j, k]], coord[[s]] ]), {s, 
        1, n}],
     {i, 1, n}, {j, 1, n}, {k, 1, n}] ];
listaffine := 
  Table[If[UnsameQ[affine[[i, j, k]], 
     0], {ToString[Γ[i, j, k]], 
     affine[[i, j, k]]}] , {i, 1, n}, {j, 1, n}, {k, 1, j}];
TableForm[Partition[DeleteCases[Flatten[listaffine], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R^{x}_{xxx} *)
riemann := riemann = Simplify[Table[
     D[affine[[i, j, l]], coord[[k]] ] - 
      D[affine[[i, j, k]], coord[[l]] ] +
      Sum[
       affine[[s, j, l]] affine[[i, k, s]] - 
        affine[[s, j, k]] affine[[i, l, s]],
       {s, 1, n}],
     {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1, n}] ];
listriemann := 
 Table[If[UnsameQ[riemann[[i, j, k, l]], 0], {ToString[R[i, j, k, l]],
     riemann[[i, j, k, l]]}] , {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1,
    k - 1}]
TableForm[Partition[DeleteCases[Flatten[listriemann], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R_{xxxx} *)
riemann1 := riemann1 = Simplify[Table[
    Sum[
     g[[μ, μ1]]*riemann[[μ1, ν, ρ, σ]]
     , {μ1, 1, n}]
    , {μ, 1, n}, {ν, 1, n}, {ρ, 1, n}, {σ, 1, n}]]
listriemann1 := 
  Table[If[UnsameQ[riemann1[[μ, ν, ρ, σ]], 
     0], {ToString[R1[μ, ν, ρ, σ]], 
     riemann1[[μ, ν, ρ, σ]]}] , {μ, 1, 
    n}, {ν, 1, n}, {ρ, 1, n}, {σ, 1, ρ - 1}];
TableForm[Partition[DeleteCases[Flatten[listriemann1], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R^{xxxx} *)
riemann2 := riemann2 = Simplify[Table[
    Sum[
     Sum[
      Sum[
       invg[[ν1, ν]]*invg[[ρ1, ρ]]*
        invg[[σ1, σ]]*
        riemann[[μ, ν1, ρ1, σ1]]
       , {ν1, 1, n}]
      , {ρ1, 1, n}]
     , {σ1, 1, n}]
    , {μ, 1, n}, {ν, 1, n}, {ρ, 1, n}, {σ, 1, n}]]
listriemann2 := 
  Table[If[UnsameQ[riemann2[[μ, ν, ρ, σ]], 
     0], {ToString[R2[μ, ν, ρ, σ]], 
     riemann2[[μ, ν, ρ, σ]]}] , {μ, 1, 
    n}, {ν, 1, n}, {ρ, 1, n}, {σ, 1, ρ - 1}];
TableForm[Partition[DeleteCases[Flatten[listriemann2], Null], 2], 
  TableSpacing -> {2, 2}];

KretschmannScalar = Simplify[
  Sum[riemann1[[a, b, c, d]]*riemann2[[a, b, c, d]], {a, 1, n}, {b, 1,
     n}, {c, 1, n}, {d, 1, n}]]
Source Link
Mark Pace
Mark Pace
  • 316
  • 1
  • 12

There might be some extra bits feel free to remove

   ClearAll["Global`*"];

n = 4;
coord = {t, x, y, z};

(*For raising/lowering latin indices like a, b, ...*)
\[Eta] = {{-1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}};
\[Eta] // MatrixForm;
inveta = Inverse[\[Eta]];
inveta // MatrixForm;

(*"e-Metric";*)
e = {{\[ScriptCapitalN][t], 0, 0, 0}, {0, \[ScriptA][t], 0, 0}, {0, 
    0, \[ScriptA][t], 0}, {0, 0, 0, \[ScriptA][t]}};
\[ScriptCapitalN][t] = -1;
e // MatrixForm;
dete = Det[e];
(*Inverse e-Metric*)
inve = Inverse[e];
inve // MatrixForm;
detinve = Det[inve];

g := g = Simplify[Table[
    ParallelSum[ \[Eta][[a, b]]*e[[a, \[Mu]]]*e[[b, \[Nu]]]
     , {a, 1, n}, {b, 1, n}]
    , {\[Mu], 1, n}, {\[Nu], 1, n}]]
g // MatrixForm;
(*g is used to LOWER indices for Greek indices \[Mu], \[Nu]*)
invg = Inverse[g];
invg // MatrixForm;
(*invg is used to RAISE indices for Greek indices \[Mu], \[Nu]*)

(* In the form \[CapitalGamma]^{x}_{xx}*)
affine := affine = Simplify[Table[(1/2)*Sum[(invg[[i, s]])*
        (D[g[[s, j]], coord[[k]] ] +
          D[g[[s, k]], coord[[j]] ] - D[g[[j, k]], coord[[s]] ]), {s, 
        1, n}],
     {i, 1, n}, {j, 1, n}, {k, 1, n}] ];
listaffine := 
  Table[If[UnsameQ[affine[[i, j, k]], 
     0], {ToString[\[CapitalGamma][i, j, k]], 
     affine[[i, j, k]]}] , {i, 1, n}, {j, 1, n}, {k, 1, j}];
TableForm[Partition[DeleteCases[Flatten[listaffine], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R^{x}_{xxx} *)
riemann := riemann = Simplify[Table[
     D[affine[[i, j, l]], coord[[k]] ] - 
      D[affine[[i, j, k]], coord[[l]] ] +
      Sum[
       affine[[s, j, l]] affine[[i, k, s]] - 
        affine[[s, j, k]] affine[[i, l, s]],
       {s, 1, n}],
     {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1, n}] ];
listriemann := 
 Table[If[UnsameQ[riemann[[i, j, k, l]], 0], {ToString[R[i, j, k, l]],
     riemann[[i, j, k, l]]}] , {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1,
    k - 1}]
TableForm[Partition[DeleteCases[Flatten[listriemann], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R_{xxxx} *)
riemann1 := riemann1 = Simplify[Table[
    Sum[
     g[[\[Mu], \[Mu]1]]*riemann[[\[Mu]1, \[Nu], \[Rho], \[Sigma]]]
     , {\[Mu]1, 1, n}]
    , {\[Mu], 1, n}, {\[Nu], 1, n}, {\[Rho], 1, n}, {\[Sigma], 1, n}]]
listriemann1 := 
  Table[If[UnsameQ[riemann1[[\[Mu], \[Nu], \[Rho], \[Sigma]]], 
     0], {ToString[R1[\[Mu], \[Nu], \[Rho], \[Sigma]]], 
     riemann1[[\[Mu], \[Nu], \[Rho], \[Sigma]]]}] , {\[Mu], 1, 
    n}, {\[Nu], 1, n}, {\[Rho], 1, n}, {\[Sigma], 1, \[Rho] - 1}];
TableForm[Partition[DeleteCases[Flatten[listriemann1], Null], 2], 
  TableSpacing -> {2, 2}];

(* In the form R^{xxxx} *)
riemann2 := riemann2 = Simplify[Table[
    Sum[
     Sum[
      Sum[
       invg[[\[Nu]1, \[Nu]]]*invg[[\[Rho]1, \[Rho]]]*
        invg[[\[Sigma]1, \[Sigma]]]*
        riemann[[\[Mu], \[Nu]1, \[Rho]1, \[Sigma]1]]
       , {\[Nu]1, 1, n}]
      , {\[Rho]1, 1, n}]
     , {\[Sigma]1, 1, n}]
    , {\[Mu], 1, n}, {\[Nu], 1, n}, {\[Rho], 1, n}, {\[Sigma], 1, n}]]
listriemann2 := 
  Table[If[UnsameQ[riemann2[[\[Mu], \[Nu], \[Rho], \[Sigma]]], 
     0], {ToString[R2[\[Mu], \[Nu], \[Rho], \[Sigma]]], 
     riemann2[[\[Mu], \[Nu], \[Rho], \[Sigma]]]}] , {\[Mu], 1, 
    n}, {\[Nu], 1, n}, {\[Rho], 1, n}, {\[Sigma], 1, \[Rho] - 1}];
TableForm[Partition[DeleteCases[Flatten[listriemann2], Null], 2], 
  TableSpacing -> {2, 2}];

KretschmannScalar = Simplify[
  Sum[riemann1[[a, b, c, d]]*riemann2[[a, b, c, d]], {a, 1, n}, {b, 1,
     n}, {c, 1, n}, {d, 1, n}]]

With that input metric I got this answer:

$\frac{12 \left(\mathit{a}(t)^2 \mathit{a}''(t)^2+\mathit{a}'(t)^4\right)}{\mathit{a}(t)^4}$