(* This produces something homeomorphic to a three-sphere.  Just the Gamma matrices with one rescaled *)

n=4;

q=2;

r=1;

s=1;

t=1;

sigmax = {{0,1},{1,0}};

sigmay = {{0,-I},{I,0}};

sigmaz = {{1,0},{0,-1}};

I2 = IdentityMatrix[2];

AA= q*KroneckerProduct[-sigmay,sigmax];

MatrixForm[AA]

BB= r*KroneckerProduct[-sigmay,sigmay];

MatrixForm[BB]

CC= s*KroneckerProduct[-sigmay,sigmaz];

MatrixForm[CC]

DD = t*KroneckerProduct[sigmax,I2];

MatrixForm[DD]

loclzrHalf=KroneckerProduct[I*sigmax,AA -  w*IdentityMatrix[4]] +KroneckerProduct[I*sigmay,BB - x*IdentityMatrix[4]] +KroneckerProduct[I*sigmaz,CC -  y*IdentityMatrix[4]]+KroneckerProduct[I2,DD -  z*IdentityMatrix[4]];

charpoly=Factor[Det[loclzrHalf]]

(*Notice this involves only  w  and R = Sqrt[x^2 + w^2 + z^2]  is the result of a
curve rotated into two more dimensions *)

curvePoly = Factor[ReplaceAll[charpoly, {y^2->0, z^2 ->0, x^2 -> R^2}]]

factors = FactorList[curvePoly]

p =factors[[ 2,1]]

p2 = ReplaceAll[p,{R ->Sqrt[R],w ->Sqrt[w]}]

q =factors[[ 3,1]]

Solve[p2==0,R]

-3+2 (Sqrt[3]) (Sqrt[w])-w

(∂_w)(-3+2 (Sqrt[3]) (Sqrt[w])-w)

Plot[-3+2 (Sqrt[3]) (Sqrt[w])-w,{w,2,4}]

(* We have one non-negative solution to  p2==0  so there is just one solution to
 p == 0, namely w = (Sqrt[3])  and  R = 0.  Let's check this is a solutoin.
*)

ReplaceAll[p,{w-> Sqrt[3],R->0}]

ReplaceAll[q,{w-> Sqrt[3],R->0}]

ReplaceAll[curvePoly,{w-> Sqrt[3],R->0}]

(* Since this point is on the other curve, it adds nothing. *)

fullPlot =ContourPlot[q==0,{w,-2,2},{R,-2,2},Axes->Automatic,AxesLabel->{w,R}]

Export["AlmostThreeSphere.eps",fullPlot ,ImageSize->3.2*72];