by jreed » Mon Jul 15, 2019 9:55 am
- Code: Select all
(* Quaternion simulation of two level entangled state from "Quantum Correlations are Weaved by the Spinors of the Euclidean Primitives"
III B 1 *)
<<Quaternions`;
β0=Quaternion[1,0,0,0];
β1=Quaternion[0,1,0,0];
β2=Quaternion[0,0,1,0];
β3=Quaternion[0,0,0,1];
Qcoordinates={β1,β2,β3};
(* randomVector generates a random normed 3D vector in the X-Y plane *)
randomVector:=Module[{x,y,z},
x=RandomVariate[UniformDistribution[{-1,1}]];
y=RandomVariate[UniformDistribution[{-1,1}]];
z=0;
{x,y,z}={x,y,z}/Sqrt[(x^2+y^2+z^2)];
{x,y,z}]
s=0; t=0; u=0;
m=10000;
plotArray=Table[{0,0},m];
For[nn=1,nn<=m,nn+=1,
{
vectorA=randomVector;
vectorB=randomVector;
Da=vectorA.Qcoordinates;
Db=vectorB.Qcoordinates; (* Convert to quaternion coordinates *)
λ=RandomChoice[{-1,1}];
=Re[FromQuaternion[-λ Da**Da]]; (* detector *)ℬ=Re[FromQuaternion[λ Db**Db]]; (* ℬ detector *)
NA=/(-Da);
NB=ℬ/(Db);
q=0;
If[λ==1,q=NA**NB,q=NB**NA];
s=s+q;
t=t+;
u=u+ℬ;
ϕA=ArcTan[vectorA[[2]],vectorA[[1]]];
ϕB=ArcTan[vectorB[[2]],vectorB[[1]]];
angle=Abs[ϕB-ϕA]/Degree;
plotArray[[nn]]={angle,Re[q]};
};]
mean=FromQuaternion[s/m ] (*shows vanishing of the non-real part K *)
(0.00493082 +0. I)-0.00439433 K
av=t/m;
avℬ=u/m;
Print[" <> = ",av," <ℬ> = ",avℬ]
<> = -0.0036 <ℬ> = 0.0036
ListPlot[plotArray]
This is the code from a run of the program. The plot wouldn't copy, so it isn't there. It is a cosine curve, very accurate.
[code](* Quaternion simulation of two level entangled state from "Quantum Correlations are Weaved by the Spinors of the Euclidean Primitives"
III B 1 *)
<<Quaternions`;
β0=Quaternion[1,0,0,0];
β1=Quaternion[0,1,0,0];
β2=Quaternion[0,0,1,0];
β3=Quaternion[0,0,0,1];
Qcoordinates={β1,β2,β3};
(* randomVector generates a random normed 3D vector in the X-Y plane *)
randomVector:=Module[{x,y,z},
x=RandomVariate[UniformDistribution[{-1,1}]];
y=RandomVariate[UniformDistribution[{-1,1}]];
z=0;
{x,y,z}={x,y,z}/Sqrt[(x^2+y^2+z^2)];
{x,y,z}]
s=0; t=0; u=0;
m=10000;
plotArray=Table[{0,0},m];
For[nn=1,nn<=m,nn+=1,
{
vectorA=randomVector;
vectorB=randomVector;
Da=vectorA.Qcoordinates;
Db=vectorB.Qcoordinates; (* Convert to quaternion coordinates *)
λ=RandomChoice[{-1,1}];
=Re[FromQuaternion[-λ Da**Da]]; (* detector *)ℬ=Re[FromQuaternion[λ Db**Db]]; (* ℬ detector *)
NA=/(-Da);
NB=ℬ/(Db);
q=0;
If[λ==1,q=NA**NB,q=NB**NA];
s=s+q;
t=t+;
u=u+ℬ;
ϕA=ArcTan[vectorA[[2]],vectorA[[1]]];
ϕB=ArcTan[vectorB[[2]],vectorB[[1]]];
angle=Abs[ϕB-ϕA]/Degree;
plotArray[[nn]]={angle,Re[q]};
};]
mean=FromQuaternion[s/m ] (*shows vanishing of the non-real part K *)
(0.00493082 +0. I)-0.00439433 K
av=t/m;
avℬ=u/m;
Print[" <> = ",av," <ℬ> = ",avℬ]
<> = -0.0036 <ℬ> = 0.0036
ListPlot[plotArray]
[/code]
This is the code from a run of the program. The plot wouldn't copy, so it isn't there. It is a cosine curve, very accurate.