Quit[];

Load packages (blocking long output)

Block[{Print}, Needs["xAct`xPert`"]]
Block[{Print}, Needs["xAct`xTensor`"]]
Block[{Print},Needs["xAct`xTras`"]]

Define geometry and metric (Following the 3+1 section in xTensorDoc.nb):

DefManifold[M4,4,{a,b,c,d,e,f,i,j,k,l,m,p,r,s,t}];

DefMetric[-1,metricg[-a,-b],CD,{";","∇"},PrintAs-> "g"];

Define normal vector to M4:

DefTensor[n[a],M4]

AutomaticRules[n,MakeRule[{n[a]n[-a],-1}]]
AutomaticRules[n,MakeRule[{metricg[-a,-b]n[a]n[b],-1}]]

$ExtrinsicKSign=-1;
$AccelerationSign=-1;

Define the induced metric on the hypersurface:

DefMetric[1,metrich[-a,-b],cd,SymbolOfCovD-> {"|","D"}, InducedFrom-> {metricg,n}, PrintAs-> "h"];

Define ADM variables:

DefTensor[lapse[], M4, PrintAs-> "N"]

LapseRule=Acceleration[n][a_]-> ((cd[a][lapse[]])/(lapse[]))

Some tests to check everything works as expected

DefTensor[V[-α],M4]

DefTensor[W[-α],M4,OrthogonalTo-> {n[α]},ProjectedWith-> {metrich[α,-β]}]

InducedDecomposition[W[-α],{metrich,n}]

InducedDecomposition[V[-α],{metrich,n}]

InducedDecomposition[RicciCD[-α,β],{metrich,n}]

%//ToCanonical

n[α]%//Expand

%/.Projectormetrich-> ProjectWith[metrich]//ProjectorToMetric//Expand

InducedDecomposition[%%,{metrich,n}]//ToCanonical

Gauss - Codazzi & Riemann decomp (follows xTensorDoc.nb)

DefTensor[v[a],M4,OrthogonalTo->{n[-a]},ProjectedWith->{metrich[-a,b]}]

expr1=Projectormetrich[CD[-d][CD[-c][v[-b]]]-CD[-c][CD[-d][v[-b]]]]

expr1A=expr1//SortCovDs

expr1/.Projectormetrich->ProjectWith[metrich]//ProjectorToMetric//Expand

expr1B=%//GradNormalToExtrinsicK//Simplification

expr2=cd[-d][cd[-c][v[-b]]]-cd[-c][cd[-d][v[-b]]]

expr2A=expr2//SortCovDs

expr2//ProjectDerivative//ProjectDerivative

%/.Projectormetrich->ProjectWith[metrich]//ProjectorToMetric//Expand

%//GradNormalToExtrinsicK//ContractMetric

expr2B=%//Simplification

(expr1A-expr1B)-(expr2A-expr2B)//Simplification

IndexSet[GCRiemann1[-a_,-b_,-c_,-d_],Simplification[(%/.v[_]->1//ScreenDollarIndices)]]

inducedRiemann[-a_,-b_,-c_,-d_]=InducedDecomposition[RiemannCD[-a,-b,-c,-d],{metrich,n}]//ToCanonical

inducedRiemann[-a_,-b_,-c_,-d_]=inducedRiemann[-a,-b,-c,-d]-GCRiemann1[-a,-b,-c,-d]//ToCanonical

expr1=Projectormetrich[CD[-d][CD[-c][n[-b]]]-CD[-c][CD[-d][n[-b]]]]

expr1A=expr1//SortCovDs

expr1/.Projectormetrich->ProjectWith[metrich]//ProjectorToMetric//Expand

expr1B=%//GradNormalToExtrinsicK//ContractMetric//GradNormalToExtrinsicK//Simplification

expr2A=cd[-c][ExtrinsicKmetrich[-b,-d]]-cd[-d][ExtrinsicKmetrich[-b,-c]]

expr2A//ProjectDerivative

%/.Projectormetrich->ProjectWith[metrich]//ProjectorToMetric//Expand

expr2B=%//GradNormalToExtrinsicK//ContractMetric//Simplification

IndexSet[GCRiemann2[-b_,-c_,-d_],(expr1A-expr1B)-(expr2A-expr2B)//Simplification]

inducedRiemann[-a_,-b_,-c_,-d_]=inducedRiemann[-a,-b,-c,-d]-n[-d]GCRiemann2[-c,-a,-b]+n[-c]GCRiemann2[-d,-a,-b]-n[-b]GCRiemann2[-a,-c,-d]+n[-a]GCRiemann2[-b,-c,-d]//ToCanonical

expr1=Projectormetrich[n[d](CD[-d][CD[-c][n[-b]]]-CD[-c][CD[-d][n[-b]]])]

expr1A=expr1//SortCovDs

expr1/.Projectormetrich->ProjectWith[metrich]//ProjectorToMetric//Expand

expr1B=%//GradNormalToExtrinsicK//ContractMetric//GradNormalToExtrinsicK//Simplification

expr2A=-cd[-c][Accelerationn[-b]]-Projectormetrich[n[d]CD[-d][ExtrinsicKmetrich[-b,-c]]]

expr2A//ProjectDerivative

%/.Projectormetrich->ProjectWith[metrich]//ProjectorToMetric//Expand

expr2B=%//GradNormalToExtrinsicK//ContractMetric//Simplification

IndexSet[GCRiemann3[-b_,-c_],(expr1A-expr1B)-(expr2A-expr2B)//Simplification]

ProjectWith[metrich][LieD[n[a],CD][ExtrinsicKmetrich[-b,-c]]-n[a]CD[-a][ExtrinsicKmetrich[-b,-c]]//GradNormalToExtrinsicK]//Simplification//ContractMetric

inducedRiemann[-a_,-b_,-c_,-d_]=inducedRiemann[-a,-b,-c,-d]+n[-b]n[-d]GCRiemann3[-a,-c]-n[-b]n[-c]GCRiemann3[-a,-d]-n[-a]n[-d]GCRiemann3[-b,-c]+n[-a]n[-c]GCRiemann3[-b,-d]//ToCanonical

GaussCodazziRiemannRule=IndexRule[RiemannCD[-a,-b,-c,-d],inducedRiemann[-a,-b,-c,-d]]

GaussCodazzi[RiemannCD[-a,-b,-c,-d],metrich]

%-Last[GaussCodazziRiemannRule]//ToCanonical

So xTensor derives the correct expression for Gauss - Codazzi!

Induced tensors (follows xTensorDoc.nb, inducedRicciScalar[] gives the wrong result?)

inducedRicci[-a_,-b_]=InducedDecomposition[RicciCD[-a,-b],{metrich,n}]//NoScalar

zero=RicciCD[-a,-b]-inducedRiemann[-a,-c,-b,-d] metricg[c,d]//ContractMetric//NoScalar

zeroA=ProjectWith[metrich][%]//ContractMetric//ToCanonical

zeroB=Projectormetrich[RicciCD[-a,-b]]-ProjectWith[metrich][RicciCD[-a,-b]]

IndexSet[GCRicci1[-a_,-b_],zeroA+zeroB//ToCanonical]

inducedRicci[-a_,-b_]=inducedRicci[-a,-b]-GCRicci1[-a,-b]//ToCanonical

zero=(RicciCD[-a,-c]-inducedRiemann[-a,-b,-c,-d] metricg[b,d])n[c]//ContractMetric//NoScalar

zeroA=ProjectWith[metrich][%]//MetricToProjector//ToCanonical

zeroB=Projectormetrich[RicciCD[-a,-b]n[b]]-ProjectWith[metrich][RicciCD[-a,-b]n[b]]

IndexSet[GCRicci2[-a_],zeroA+zeroB//ToCanonical]

inducedRicci[-a_,-b_]=inducedRicci[-a,-b]+GCRicci2[-a]n[-b]+GCRicci2[-b]n[-a]//ToCanonical

zero=(RicciCD[-a,-c]-inducedRiemann[-a,-b,-c,-d] metricg[b,d])n[a]n[c]//Expand//ReplaceDummies

inducedRicci[-a_,-b_]=inducedRicci[-a,-b]-n[-a]n[-b]zero//Expand//SameDummies

inducedRiemann[-a,-b,-c,-d]metricg[b,d]metricg[a,c]//ContractMetric//NoScalar

%/.Projectormetrich->ProjectWith[metrich]//ContractMetric//ToCanonical

%//ProjectorToMetric//ContractMetric

%//GradNormalToExtrinsicK

inducedRicciScalar[]=%/.LapseRule//Expand

The above result is wrong? THIS IS FINE NOW.

GR ADM Lagrangian

L = Sqrt[metrich]*lapse[](RicciScalarCD[]-ExtrinsicKmetrich[-a,-b] ExtrinsicKmetrich[a,b]+(((ExtrinsicKmetrich[a,-a]))^2))//ToCanonical//ExtrinsicKToGradNormal

This is the Lagrangian, but how to rewrite it so that I can get the equations of motion? One suggestion is below.

Quit[];

Block[{Print},Needs["xAct`xTras`"]]

Block[{Print},DefManifold[MSpace,3,{i,j,k,l,m,p,q,r}]];
Block[{Print},DefMetric[1,γ[-i,-j],CDSpace,{"|","D"}]]

PrintAs[RiemannCDSpace]^="R";
PrintAs[RicciCDSpace]^="R";
PrintAs[RicciScalarCDSpace]^="R";
PrintAs[ChristoffelCDSpace]^="Γ";
PrintAs[EinsteinCDSpace]^="G";
PrintAs[Detγ]^="γ";

DefTensor[α[],MSpace];
DefTensor[β[i],MSpace];
DefConstantSymbol[κ];
DefParameter[t];

DefTensor[gt[-i,-j],{t,MSpace},PrintAs-> "G"]

IndexSet[K[i_,j_],(1/(2 α[]))(-ParamD[t][gt[i,j]]+CDSpace[i][β[j]]+CDSpace[j][β[i]])];

K[i,-j]

Lagrangian = Sqrt[Detγ[]]α[]*(RicciScalarCDSpace[]+(1/(2 α[]))(-ParamD[t][gt[i,j]]+CDSpace[i][β[j]]+CDSpace[j][β[i]])(1/(2 α[]))(-ParamD[t][gt[-i,-j]]+CDSpace[-i][β[-j]]+CDSpace[-j][β[-i]])-K[-i,i]*K[-j,j]);

CollectTensors[VarD[α[],CDSpace][Lagrangian]]