Local Quantum Mechanical Prediction of the Singlet State
Author
Fred Diether
Title
Local Quantum Mechanical Prediction of the Singlet State
Description
Theoretical proof that quantum mechanics is local for the EPR-Bohm scenario
Category
Academic Articles & Supplements
Keywords
locality, quantum mechanics, Bell's Theorem
URL
http://www.notebookarchive.org/2022-04-1eu4roy/
DOI
https://notebookarchive.org/2022-04-1eu4roy
Date Added
2022-04-03
Date Last Modified
2022-04-03
File Size
0.76 megabytes
Supplements
Rights
CC BY 4.0
Download
Open in Wolfram Cloud
Supplemental Material for Fred Diether, “Local Quantum Mechanical Prediction of the Singlet State”
https://dx.doi.org/10.13140/RG.2.2.22142.25927.
Validation of the Local QM Product Calculation Prediction Using Pauli Matrices
and Quaternions with 3D Vectors, Based on Joy Christian’s 3-Sphere Model.
https://dx.doi.org/10.13140/RG.2.2.22142.25927.
Validation of the Local QM Product Calculation Prediction Using Pauli Matrices
and Quaternions with 3D Vectors, Based on Joy Christian’s 3-Sphere Model.
Local Quantum Mechanical Prediction of the Singlet State
Local Quantum Mechanical Prediction of the Singlet State
Created by Fred Diether Mar. 2022
Load Clifford Package, Set Run Time Parameters, Initialize Arrays and Tables
<<"clifford.m"Qcoordinates={1,i,j,k};m=30000;s1=ConstantArray[0,m];s2=ConstantArray[0,m];σs1=ConstantArray[0,m];σs2=ConstantArray[0,m];a1=ConstantArray[0,m];b1=ConstantArray[0,m];ra1=ConstantArray[0,m];rb1=ConstantArray[0,m];qA=ConstantArray[0,m];qB=ConstantArray[0,m];A=ConstantArray[0,m];B=ConstantArray[0,m];pc=ConstantArray[0,m];plotpc=Table[{0,0},m];I3=Pseudoscalar[3];
Generating Particle Data with Three Independent Do-Loops
In[]:=
Do[s=RandomPoint[Sphere[]];(*UniformUnit3DVectors*)s1[[h]]=s;(*SpinvectortoA*)s2[[h]]=-s;(*SpinvectortoB*)σs1[[h]]=PauliMatrix[1]*s[[1]]+PauliMatrix[2]*s[[2]]+PauliMatrix[3]*s[[3]];(*ParticlespintoA*)σs2[[h]]=-(PauliMatrix[1]*s[[1]]+PauliMatrix[2]*s[[2]]+PauliMatrix[3]*s[[3]]),{h,m}](*ParticlespintoB*)
In[]:=
Doa=RandomPoint[Sphere[]];(*UniformUnit3DVectors*)a1[[h]]=a;σa=PauliMatrix[1]*a[[1]]+PauliMatrix[2]*a[[2]]+PauliMatrix[3]*a[[3]];cosas1=ReFullSimplifyExtractFlatten(
).σa.σs1[[h]].
+(
).σa.σs1[[h]].
,1+i;(*Particle-Detectorinteraction*)ra=Cross[a,s1[[h]]];(*Vectorcrossproducts*)ra1[[h]]=ra;qA[[h]]={cosas1,ra[[1]],ra[[2]],ra[[3]]}.Qcoordinates;(*Converttoquaternion*)A[[h]]=Sign[a.s1[[h]]],{h,m}
1
2
1 | 0 |
1 |
0 |
0 | 1 |
0 |
1 |
In[]:=
Dob=RandomPoint[Sphere[]];(*UniformUnit3DVectors*)b1[[h]]=b;σb=PauliMatrix[1]*b[[1]]+PauliMatrix[2]*b[[2]]+PauliMatrix[3]*b[[3]];cosbs2=ReFullSimplifyExtractFlatten(
).σs2[[h]].σb.
+(
).σs2[[h]].σb.
,1+i;(*Particle-Detectorinteraction*)rb=Cross[s2[[h]],b];(*Vectorcrossproducts*)rb1[[h]]=rb;qB[[h]]={cosbs2,rb[[1]],rb[[2]],rb[[3]]}.Qcoordinates;(*Converttoquaternion*)B[[h]]=Sign[b.s2[[h]]],{h,m}
1
2
1 | 0 |
1 |
0 |
0 | 1 |
0 |
1 |
Verification of the Local QM Product Calculation Prediction
In[]:=
Do[r0=Expand[({e[1],e[2],e[3]}).(Re[qA[[h]]]*Limit[Cross[s4,b1[[h]]],s4Sign[Re[qB[[h]]]]b1[[h]]]+Re[qB[[h]]]*Limit[Cross[a1[[h]],s3],s3Sign[Re[qA[[h]]]]a1[[h]]]-Cross[Limit[Cross[a1[[h]],s3],s3Sign[Re[qA[[h]]]]a1[[h]]],Limit[Cross[s4,b1[[h]]],s4Sign[Re[qB[[h]]]]b1[[h]]]])/(Sin[ArcCos[a1[[h]].b1[[h]]]])];Lr0=InnerProduct[I3,r0];qpc=(Re[qA[[h]]]*Re[qB[[h]]]-Im[qA[[h]]].Im[qB[[h]]])+Lr0;(*ProductCalculation*)pc[[h]]=qpc;ϕa=ArcTan[a1[[h]][[1]],a1[[h]][[2]]];ϕb=ArcTan[b1[[h]][[2]],b1[[h]][[1]]];If[ϕa*ϕb>0,angle=ArcCos[a1[[h]].b1[[h]]]/Degree,angle=(2π-ArcCos[a1[[h]].b1[[h]]])/Degree];plotpc[[h]]={angle,Re[qpc]},{h,m}]
In[]:=
simulation=ListPlot[plotpc,PlotMarkers{Automatic,Small},AspectRatio9/16,Ticks{{{90,90°},{180,180°},{0,0°},{270,270°},{360,360°}},Automatic},GridLinesAutomatic,AxesOrigin{0,-1.0}];negcos=Plot[-Cos[xDegree],{x,0,360},PlotStyle{Magenta}];p1=Plot[-1+2x1Degree/π,{x1,0,180},PlotStyle{Gray,Dashed}];p2=Plot[3-2x2Degree/π,{x2,180,360},PlotStyle{Gray,Dashed}];Show[simulation,p1,p2,negcos]
Out[]=
Blue is the correlation data, magenta is the negative cosine curve for an exact match.
Computing Averages
In[]:=
AveA=N[Total[A]/m];AveB=N[Total[B]/m];Print[" <A> = ",AveA," <B> = ",AveB];meanpc=Expand[Mean[pc]];Print["Cross products vanish, meanpc = ",meanpc];
<A> = -0.00646667 <B> = -0.0123333
Cross products vanish, meanpc = 0.00108786
Cite this as: Fred Diether, "Local Quantum Mechanical Prediction of the Singlet State" from the Notebook Archive (2022), https://notebookarchive.org/2022-04-1eu4roy
Download
