Heisenberg group calculations

heisen[{x_, y_, t_}, {z_, w_, s_}] = {x + z, 
        y + w, (t + s)  + (x  w - y z)/2}

a = {x0, y0, t0};
b = {x1, y1, t1};
c = {x2, y2, t2};

This operation is associative:

heisen[heisen[a, b], c] - heisen[a, heisen[b, c]] // 
      Simplify

heisen[a, heisen[b, c]]

e = {0, 0, 0}

e is the unit for multiplication:

heisen[a, e]

-a is the inverse of a:

heisen[-a, a]

Left multiplication by a:    (Subscript[l, a])(x, y, t) =  
        a· (x, y, t)

lefta[{x_, y_, t_}] =  heisen[a, {x, y, t}]

Its differential is

difflefta = {D[lefta[{x, y, t}], x], D[lefta[{x, y, t}], y], 
          D[lefta[{x, y, t}], t]} // MatrixForm

Note that this differential is a constant function of x, y  and t.

Since it  has determinant 1, the Lebesgue measure
is invariant by left-translations:
                            \(TraditionalForm\`∫\_\(R\^3\)\(f(
              y)\) dy = \(∫\_\(R\^3\)\%\ \)\(f(\(l\_a\)(x))\) dx\)

Here is an arbitrary vector field:
                           v=A(x,y,t)(∂/∂)x+B(x, y, t) (∂/∂)y+C(x,y,t)(∂/∂)t

vectorfield[{x_, y_, t_}] = {A[{x, y, t}], B[{x, y, t}], 
        C[{x, y, t}]}

Vector fields act on functions:
                        v(f)=A(x,y,t)∂(f/∂)x+B(x, y, t) ∂(f/∂)y+C(x,y,t)∂(f/∂)t

vectorfield[{x, y, t}] . {D[f[x, y, t], x], D[f[x, y, t], y], 
        D[f[x, y, t], t]}

Here is the left-translation of the function f  by a:
                                           f ◦ (Subscript[l, a ])

leftfbya[x_, y_, t_] = 
      f[ lefta[{x, y, t}][[1]], lefta[{x, y, 
              t}][[2]], lefta[{x, y, t}][[3]]]

vectorfield acting on the left-translation of f by a:
                               v(f ◦ (Subscript[l, a ]))

\(\(\(\ \)\(\(uno = 
      vectorfield[{x, y, t}] . {D[leftfbya[x, y, t], x], 
          D[leftfbya[x, y, t], y], D[leftfbya[x, y, t], t]}\)\(
\)
    \)\)\)

left translation by  of the action of vector field on a function:
                        v(f) ◦ (Subscript[l, a])

dos = 
      vectorfield[{x, y, t}] . {D[f[x, y, t], x], D[f[x, y, t], y], 
            D[f[x, y, t], t]} /. {x -> lefta[{x, y, t}][[1]],  
          y -> lefta[{x, y, t}][[2]],  
          t -> lefta[{x, y, t}][[3]]}

A vector field is left invariant if for all functions f and all a we have:
                             v(f ◦ (Subscript[l, a ])) =  v(f) ◦ (Subscript[l, a])

Coefficient[uno,  Derivative[1, 0, 0][f][x + x0, y + y0, 
              t + t0 + (1/2) (x0 y - x y0) ]]==Coefficient[dos,  Derivative[1, 0, 0][f][x + x0, y + y0, 
              t + t0 + (1/2) (x0 y - x y0) ]]/.{x -> 0, y -> 0, t -> 0}

Coefficient[uno,  Derivative[0, 1, 0][f][x + x0, y + y0, 
              t + t0 + (1/2) (x0 y - x y0) ]]==Coefficient[dos,  Derivative[0, 1, 0][f][x + x0, y + y0, 
              t + t0 + (1/2) (x0 y - x y0) ]]/.{x -> 0, y -> 0, t -> 0}

Coefficient[uno,  Derivative[0, 0, 1][f][x + x0, y + y0, 
              t + t0 + (1/2) (x0 y - x y0) ]]==Coefficient[dos,  Derivative[0, 0, 1][f][x + x0, y + y0, 
              t + t0 + (1/2) (x0 y - x y0) ]]/.{x -> 0, y -> 0, t -> 0}

A left invariant vector field is then of the form:

A (0) (∂/∂)x + 
      B (0) (∂/∂)y + ( -(1/2) 
              y  A (0) + (1/2) x  B (0) + 
            C (0)) (∂/(∂t ))

The usual basis is obtained taking A(0)=1, B(0)=0, C(0)=0,etc

XX =   (∂/∂)x  - (1/2) 
          y (∂/∂)t

YY =   (∂/∂)y  + (1/2) 
          x (∂/∂)t

TT = (∂/∂)t

Here is the computer code for operators:

XX = (D[#,  x] - (1/2) y D[#,  t]) &

XX[f[x, y, t]]

YY = (D[#,  y] + (1/2) x D[#,  t]) &

TT = ( D[#,  t]) &

XX[YY[f[x, y, t]]] - YY[XX[f[x, y, t]]] // Simplify

That is, we have checked that [XX,YY]=  T

\(postar = {\(α\^*\), \(β\^*\), \(γ\^*\)}\)

pnot = {(Subscript[α, o]), (Subscript[β, o]), (Subscript[γ, o])}

qq = {x, y, t}

heisen[qq, heisen[-postar, pnot]]

polyq[x_, y_, t_] = poly[ heisen[qq, heisen[-postar, pnot]]]

\(\({{XX[XX[polyq[x, y, t]]], 
        \((XX[YY[polyq[x, y, t]]] + YY[XX[polyq[x, y, t]]])\)/2}, 
      
{\((XX[YY[polyq[x, y, t]]] + YY[XX[polyq[x, y, t]]])\)/2, 
        YY[YY[polyq[x, y, t]]]}}
\)\)

{XX[polyq[x, y, t]], YY[polyq[x, y, t]], TT[polyq[x, y, t]]}

Convexity Calculations

u[x_, y_, t_] = x^2 + y^2 - ϵ t^2

XX[u[x, y, t]]

YY[u[x, y, t]]

XX[XX[u[x, y, t]]]

YY[XX[u[x, y, t]]]

XX[YY[u[x, y, t]]]

YY[YY[u[x, y, t]]]

\(sechor = {{XX[XX[u[x, y, t]]], \ 
          \((1/2)\) \((YY[XX[u[x, y, t]]] + XX[YY[u[x, y, t]]])\)}, 

        		{\ \((1/2)\) \((YY[XX[u[x, y, t]]] + XX[YY[u[x, y, t]]])\), \ 
          YY[YY[u[x, y, t]]]}}\)

sechor[[1, 1]] + sechor[[2, 2]]

Det[sechor]

Convexity and Euclidean Translations

Clear[x, y, t, x0, y0, t0]

v[x_, y_, t_] = uu[x + x0, y + y0, t + t0]

XX[v[x, y, t]]

YY[v[x, y, t]]

m11 = XX[XX[v[x, y, t]]]

m12 = (XX[YY[v[x, y, t]]] + YY[XX[v[x, y, t]]])/2 // Simplify

m22 = YY[YY[v[x, y, t]]]

A =  {{m11, m12}, {m12, m22}}

n11 = XX[XX[uu[x, y, t]]]

n12 = (XX[YY[uu[x, y, t]]] + YY[XX[uu[x, y, t]]])/2 // Simplify

n22 = YY[YY[uu[x, y, t]]]

B = {{n11, n12}, {n12, n22}} /. {x -> x + x0,  y -> y + y0, 
          t -> t + t0}

CC = A - B // FullSimplify

\(CC[\([1, 1]\)] + CC
		[\([2, 2]\)] // FullSimplify\)

When is a curve horizontal?

gamma[t_] = {g1[t], g2[t], g3[t]}

tanga[t_] = gamma'[t]

vector1 = {1, 0, -(1/2) y} /. {y -> gamma[t][[2]]}

vector2 = {0, 1, (1/2) x} /. {x -> gamma[t][[1]]}

eq = Det[{tanga[t], vector1, vector2}] == 0

sols = Solve[eq,  g3'[t]]

Observe that whenever {g1[t],g2[t]}={0,0}, we  must have g3'[t]=0

<<Calculus`VariationalMethods`

<<Calculus`VectorAnalysis`

SetCoordinates[Cartesian[x, y, z]];

otro[t_] = ( tanga[t] . tanga[t]) /. sols[[1]]

Looking for geodesics:

eqs = EulerEquations[otro[t], {g1[t], g2[t]}, t] // FullSimplify

initialconditions = {g1[0] == 0, g2[0] == 0, 
        g1'[0] == -2*Random[] + 1, g2'[0] == -2*Random[] + 1}

compeqs = Join[ initialconditions,  eqs] // Simplify

sol = NDSolve[compeqs, {g1 , g2 }, {t, 1000}]

Plot[Evaluate[g2[t] /. sol], {t, 0, 1000}]

Plot[Evaluate[(1/2) (-g2[t] g1'[t]+g1[t] g2'[t])/.sol],{t, 0, 1000}]

.

ParametricPlot3D[Evaluate[{g1[t] , g2[t], g3[t]}  /.  sol], 
       {t,  0, 100},  AspectRatio -> Automatic]

guno[t_] = g1[t] /.  sol[[1]]

gdos[t_] = g2[t] /.  sol[[1]]

\(\(	gtres[t_] = g3[t] /. \ sol[\([1]\)]\)\)

Plot[ gtres[s]  , {s, 0, 10}]

{guno[10], gdos[10], gtres[10]}

More Polynomials

\(heisen[{x_, y_, t_}, {z_, w_, s_}] = {x + z, y + w, 
        t + s
		 + \((x\ \ w - y\ z)\)/2}\)

XX = (D[#,  x] - (1/2) y D[#,  t])&

YY = (D[#,  y] + (1/2) x D[#,  t])&

TT = ( D[#,  t])&

p = {x, y, t}

η = {AA,  BB, CC}

h = {x, y}

mM = {{m11, m}, {m, m22}}

poly[{x_, y_, t_}] =  
      const + η . p + (1/2) (mM . h) . h

{XX[poly[{x, y, t}]], YY[poly[{x, y, t}]], TT[poly[{x, y, t}]]}

\(\({{XX[XX[poly[{x, y, t}]]], 
        \((XX[YY[poly[{x, y, t}]]] + YY[XX[poly[{x, y, t}]]])\)/2}, 
      
{\((XX[YY[poly[{x, y, t}]]] + YY[XX[poly[{x, y, t}]]])\)/2, 
        YY[YY[poly[{x, y, t}]]]}}
\)\)

\(postar = {\(α\^*\), \(β\^*\), \(γ\^*\)}\)

pnot = {(Subscript[α, o]), (Subscript[β, o]), (Subscript[γ, o])}

heisen[-postar, p]

poly[{x_, y_, t_}] = Sqrt[(x^4) + (y^4) + (t^2)]

polyq[x_, y_, t_] = poly[ heisen[-postar, p]]

\(\(uno = {{XX[XX[polyq[x, y, t]]], 
            \((XX[YY[polyq[x, y, t]]] + YY[XX[polyq[x, y, t]]])\)/2}, 
          
{\((XX[YY[polyq[x, y, t]]] + YY[XX[polyq[x, y, t]]])\)/2, 
            YY[YY[polyq[x, y, t]]]}} // FullSimplify
\)\)

dos = 
      uno /. {x -> (Subscript[α, o]),  y -> (Subscript[β, o]),  t -> (Subscript[γ, o])} // 
        FullSimplify

\(\(dos[\([1, 1]\)] + dos[\([2, 2]\)]
\)\)

\(tres = 
      dos /. {α\_o - \(α\^*\) -> AA, \ 
          β\_o - \(β\^*\) -> BB}\)

tres[[1, 1]] + tres[[2, 2]]

Det[tres] // FullSimplify

(tres .  Transpose[tres])[[1, 1]] + 
      (tres .  Transpose[tres])[[2, 2]]

Eigenvalues[tres]

{XX[polyq[x, y, t]], YY[polyq[x, y, t]], TT[polyq[x, y, t]]}

More Powers of the smooth gauge

uu[{x_, y_, t_}] =   ((x^4) + (y^4)) +    (t^2)

mm = XX[XX[uu[{x, y, t}]]]

nn = YY[YY[uu[{x, y, t}]]]

mn = (1/2) (XX[YY[uu[{x, y, t}]]] + YY[XX[uu[{x, y, t}]]])

matrix = {{mm, mn}, {mn, nn}}

Det[matrix] // Factor

mmnn[x_, y_] = mm + nn /. t -> 10000  Random[] // FullSimplify

mmnn[x, y]

Plot3D[mmnn[x, y], {x, -1, 1}, {y, -1, 1}]

pnot = {(Subscript[α, o]), (Subscript[β, o]), (Subscript[γ, o])}

p = {x, y, 0}

uno = 
      uu[heisen[pnot, p]] + uu[heisen[pnot, -p]] - 2  uu[pnot] // 
        FullSimplify

Collect[uno, t]

uno = 
      heisen[-qq , heisen[pnot, heisen[-postar, qq]]] // Simplify

superu[x_, y_, z_] = 
      uno[[1]]^4 + uno[[2]]^4 + uno[[3]]^2

mm = XX[XX[superu[x, y, t]]]

nn = YY[YY[superu[x, y, t]]]

mn = 
      (1/2) (XX[YY[superu[x, y, t]]] + YY[XX[superu[x, y, t]]])

matrix = {{mm, mn}, {mn, nn}}

\(matrix /. {x -> \(α\^*\), \ y -> \(β\^*\), \ 
          z -> \(γ\^*\)} // FullSimplify\)

Det[matrix] // Factor

mm + nn