(* Content-type: application/mathematica *)

(*** Wolfram Notebook File ***)
(* http://www.wolfram.com/nb *)

(* CreatedBy='Mathematica 6.0' *)

(*CacheID: 234*)
(* Internal cache information:
NotebookFileLineBreakTest
NotebookFileLineBreakTest
NotebookDataPosition[       145,          7]
NotebookDataLength[     33685,       1100]
NotebookOptionsPosition[     29953,        981]
NotebookOutlinePosition[     30342,        998]
CellTagsIndexPosition[     30299,        995]
WindowFrame->Normal
ContainsDynamic->False*)

(* Beginning of Notebook Content *)
Notebook[{

Cell[CellGroupData[{
Cell["Solutions (12)", "Title",
 CellChangeTimes->{{3.4494787970693893`*^9, 3.449478798299262*^9}}],

Cell["\<\
Assigned: April 16
Due: April 23\
\>", "Subsubtitle",
 CellChangeTimes->{{3.448901465465457*^9, 3.4489014692941*^9}}],

Cell[CellGroupData[{

Cell["Setup your Notebook (in-Class)", "Section"],

Cell[TextData[{
 "Copy the Crank-Nicolson formula from the class notebook, ",
 StyleBox["7-QuantumIntro",
  FontSlant->"Italic"],
 StyleBox[".nb",
  FontSlant->"Italic"],
 ", that advances the wavefunction in unit time steps. \nAlso, copy the \
initial condition function that creates an initial wave-packet of a given \
size and momentum.\nThese functions are called ",
 StyleBox["cnStep[\[Ellipsis]]",
  FontWeight->"Bold"],
 " and ",
 StyleBox["initial[\[Ellipsis]][x].\n",
  FontWeight->"Bold"],
 "(If you wish, you may also want to copy the function ",
 StyleBox["plot\[Psi][\[Ellipsis]]",
  FontWeight->"Bold"],
 ".)"
}], "Text"],

Cell[CellGroupData[{

Cell["Solution", "Subsubsection"],

Cell[BoxData[
 RowBox[{
  RowBox[{"cnStep", "[", 
   RowBox[{"\[Psi]_List", ",", " ", "v_List"}], "]"}], " ", ":=", " ", 
  RowBox[{"Module", "[", 
   RowBox[{
    RowBox[{"{", 
     RowBox[{"sparseA", ",", "r", ",", "len"}], "}"}], ",", 
    "\[IndentingNewLine]", 
    RowBox[{
     RowBox[{"len", " ", "=", " ", 
      RowBox[{"Length", "[", "\[Psi]", "]"}]}], ";", "\[IndentingNewLine]", 
     RowBox[{"sparseA", " ", "=", " ", 
      RowBox[{"SparseArray", "[", 
       RowBox[{
        RowBox[{"{", 
         RowBox[{
          RowBox[{
           RowBox[{"{", 
            RowBox[{"i_", ",", "i_"}], "}"}], " ", ":>", " ", 
           RowBox[{"1", " ", "+", " ", 
            RowBox[{"I", " ", 
             RowBox[{"(", 
              RowBox[{"1.0", " ", "+", " ", 
               RowBox[{
               "v", "\[LeftDoubleBracket]", "i", "\[RightDoubleBracket]"}]}], 
              ")"}], " ", "0.5"}]}]}], ",", " ", 
          RowBox[{
           RowBox[{
            RowBox[{"{", 
             RowBox[{"i_", ",", "j_"}], "}"}], "/;", " ", 
            RowBox[{
             RowBox[{"Abs", "[", 
              RowBox[{"i", "-", "j"}], "]"}], " ", "\[Equal]", "  ", "1"}]}], 
           " ", "\[Rule]", " ", 
           RowBox[{
            RowBox[{"-", " ", "I"}], " ", "0.25"}]}]}], "}"}], ",", " ", 
        RowBox[{"{", 
         RowBox[{"len", ",", " ", "len"}], "}"}], ",", " ", "0.0"}], "]"}]}], 
     ";", "\[IndentingNewLine]", 
     RowBox[{"r", " ", "=", "  ", 
      RowBox[{
       RowBox[{"ListConvolve", "[", 
        RowBox[{
         RowBox[{"{", 
          RowBox[{
           RowBox[{"I", " ", "0.25"}], ",", 
           RowBox[{"1.0", " ", "-", " ", 
            RowBox[{"I", " ", "0.5"}]}], ",", " ", 
           RowBox[{"I", " ", "0.25"}]}], "}"}], ",", "\[Psi]", ",", " ", "2", 
         ",", " ", "0.0"}], "]"}], " ", "-", " ", 
       RowBox[{"I", " ", "\[Psi]", " ", "v", " ", "0.5"}]}]}], ";", 
     "\[IndentingNewLine]", 
     RowBox[{"(*", " ", 
      StyleBox[
       RowBox[{"fixed", " ", "boundaries"}],
       FontColor->RGBColor[0, 1, 0]], " ", "*)"}], "\[IndentingNewLine]", 
     RowBox[{"sol", " ", "=", " ", 
      RowBox[{"LinearSolve", "[", 
       RowBox[{"sparseA", ",", "r"}], "]"}]}], ";", "\[IndentingNewLine]", 
     "sol"}]}], "]"}]}]], "Input",
 CellChangeTimes->{{3.448901019266375*^9, 3.448901090956354*^9}}],

Cell[BoxData[
 RowBox[{
  RowBox[{
   RowBox[{
    RowBox[{"initial", "[", 
     RowBox[{"k_", ",", "x0_", ",", "s_"}], "]"}], "[", "x_", "]"}], " ", ":=",
    " ", 
   RowBox[{
    RowBox[{"Exp", "[", 
     RowBox[{"I", " ", "k", " ", "x"}], "]"}], " ", 
    RowBox[{
     RowBox[{"Exp", "[", 
      RowBox[{"-", 
       RowBox[{
        RowBox[{"(", 
         RowBox[{
          RowBox[{"(", 
           RowBox[{"x", "-", "x0"}], ")"}], "/", 
          RowBox[{"(", 
           RowBox[{"2", " ", "s"}], ")"}]}], ")"}], "^", "2"}]}], "]"}], "/", 
     
     RowBox[{"Sqrt", "[", " ", 
      RowBox[{"Sqrt", "[", 
       RowBox[{"2", " ", "\[Pi]", " ", 
        RowBox[{"s", "^", "2"}]}], "]"}], "]"}]}]}]}], ";"}]], "Input"],

Cell[BoxData[
 RowBox[{
  RowBox[{
   RowBox[{"plot\[Psi]", "[", 
    RowBox[{"\[Psi]_List", ",", "options___"}], "]"}], ":=", 
   RowBox[{"Module", "[", 
    RowBox[{
     RowBox[{"{", 
      RowBox[{"p1", ",", "p2", ",", "p3", ",", "p4"}], "}"}], ",", 
     RowBox[{
      RowBox[{"p1", "=", 
       RowBox[{"ListPlot", "[", 
        RowBox[{
         RowBox[{"Re", "[", "\[Psi]", "]"}], ",", 
         RowBox[{"PlotStyle", "\[Rule]", 
          RowBox[{"RGBColor", "[", 
           RowBox[{"0", ",", "0", ",", "1"}], "]"}]}], ",", 
         RowBox[{"Joined", "\[Rule]", "True"}], ",", 
         RowBox[{"DisplayFunction", "\[Rule]", "Identity"}]}], "]"}]}], ";", 
      RowBox[{"p2", "=", 
       RowBox[{"ListPlot", "[", 
        RowBox[{
         RowBox[{"Im", "[", "\[Psi]", "]"}], ",", 
         RowBox[{"PlotStyle", "\[Rule]", 
          RowBox[{"RGBColor", "[", 
           RowBox[{"1", ",", "0", ",", "0"}], "]"}]}], ",", 
         RowBox[{"Joined", "\[Rule]", "True"}], ",", 
         RowBox[{"DisplayFunction", "\[Rule]", "Identity"}]}], "]"}]}], ";", 
      RowBox[{"p3", "=", 
       RowBox[{"ListPlot", "[", 
        RowBox[{
         RowBox[{"Abs", "[", "\[Psi]", "]"}], ",", 
         RowBox[{"Joined", "\[Rule]", "True"}], ",", 
         RowBox[{"DisplayFunction", "\[Rule]", "Identity"}]}], "]"}]}], ";", 
      RowBox[{"p4", "=", 
       RowBox[{"ListPlot", "[", 
        RowBox[{
         RowBox[{"-", 
          RowBox[{"Abs", "[", "\[Psi]", "]"}]}], ",", 
         RowBox[{"Joined", "\[Rule]", "True"}], ",", 
         RowBox[{"DisplayFunction", "\[Rule]", "Identity"}]}], "]"}]}], ";", 
      RowBox[{"Show", "[", 
       RowBox[{"p1", ",", "p2", ",", "p3", ",", "p4", ",", 
        RowBox[{"DisplayFunction", "\[Rule]", "$DisplayFunction"}], ",", 
        "options"}], "]"}]}]}], "]"}]}], ";"}]], "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell["A stationary start (in-Class)", "Section"],

Cell[TextData[{
 "Examine quantum wave-function dynamics when the initial condition has no \
initial momentum. This is determined by initializing your solution with ",
 StyleBox["k",
  FontSlant->"Italic"],
 " = 0.0, or",
 " ",
 StyleBox["initial[0.0,x0,s0][x]",
  FontWeight->"Bold"],
 "."
}], "Text"],

Cell[CellGroupData[{

Cell["Solution", "Subsubsection"],

Cell[BoxData[{
 RowBox[{
  RowBox[{"nGrid", " ", "=", " ", "100"}], ";", 
  RowBox[{"\[Psi]0", " ", "=", " ", 
   RowBox[{"(", 
    RowBox[{
     RowBox[{"Table", "[", 
      RowBox[{
       RowBox[{
        RowBox[{"initial", "[", 
         RowBox[{"0.0", ",", 
          RowBox[{"nGrid", "/", "2"}], ",", "8"}], "]"}], "[", "x", "]"}], 
       ",", " ", 
       RowBox[{"{", 
        RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], " ", 
     "//", " ", "N"}], ")"}]}], ";"}], "\[IndentingNewLine]", 
 RowBox[{
  RowBox[{"v0", " ", "=", " ", 
   RowBox[{"Table", "[", 
    RowBox[{"0.0", ",", " ", 
     RowBox[{"{", 
      RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}]}], 
  ";"}], "\[IndentingNewLine]", 
 RowBox[{"plot\[Psi]", "[", "\[Psi]0", "]"}]}], "Input",
 CellChangeTimes->{3.448901517569137*^9}],

Cell[TextData[{
 "Here, I introduced an auxiliary function, called ",
 StyleBox["tenSteps[\[Psi]]",
  FontWeight->"Bold"],
 ", that returns a time-advanced wave-function resulting from 10 time steps. \
This reduces the memory requirements for subsequent graphics."
}], "Text"],

Cell[BoxData[
 RowBox[{
  RowBox[{
   RowBox[{"tenSteps", "[", "\[Psi]_List", "]"}], " ", ":=", " ", 
   RowBox[{"Nest", "[", 
    RowBox[{
     RowBox[{
      RowBox[{"cnStep", "[", 
       RowBox[{"#", ",", "v0"}], "]"}], "&"}], ",", " ", "\[Psi]", ",", " ", 
     "10"}], "]"}]}], ";"}]], "Input"],

Cell[BoxData[
 RowBox[{
  RowBox[{"(*", " ", 
   StyleBox[
    RowBox[{
     RowBox[{"100", " ", "x", " ", "10"}], " ", "=", " ", 
     RowBox[{"1000", " ", 
      RowBox[{"steps", "!"}]}]}],
    FontColor->RGBColor[1, 0, 1]], " ", "*)"}], 
  RowBox[{
   RowBox[{"(", 
    RowBox[{
     RowBox[{"sol", " ", "=", " ", 
      RowBox[{"NestList", "[", 
       RowBox[{"tenSteps", ",", " ", "\[Psi]0", ",", " ", "100"}], "]"}]}], 
     ";"}], ")"}], "//", "Timing"}]}]], "Input"],

Cell[BoxData[
 RowBox[{"ListDensityPlot", "[", 
  RowBox[{
   RowBox[{"Abs", "[", "sol", "]"}], ",", 
   RowBox[{"Mesh", "\[Rule]", "False"}], ",", 
   RowBox[{"ColorFunction", "\[Rule]", "Hue"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", 
    RowBox[{"{", 
     RowBox[{"0", ",", "0.3"}], "}"}]}]}], "]"}]], "Input",
 CellChangeTimes->{3.448901548035557*^9}],

Cell[BoxData[
 RowBox[{"ListPlot3D", "[", 
  RowBox[{
   RowBox[{"Abs", "[", "sol", "]"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", 
    RowBox[{"{", 
     RowBox[{"0", ",", "0.3"}], "}"}]}], ",", 
   RowBox[{"Mesh", "\[Rule]", "False"}]}], "]"}]], "Input",
 CellChangeTimes->{3.448901555422675*^9}],

Cell[BoxData[
 RowBox[{"plot\[Psi]", "[", 
  RowBox[{"sol", "\[LeftDoubleBracket]", "80", "\[RightDoubleBracket]"}], 
  "]"}]], "Input",
 CellChangeTimes->{3.448901561266059*^9}],

Cell["\<\
Although the particle starts in the middle of the box and although it is not \
\"moving\" in the classical sense, over time, the probablity of finding the \
object is no longer at the center. In fact, the probability oscillates in \
time between the center and the sides.\
\>", "Text"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell["Most likely position (in-class)", "Section"],

Cell[TextData[{
 "Compute the \"most likely position\" of the object as a function of time \
for the initial condition above and for the initial condition used in class.\n\
The most likely position is defined as the sum, ",
 Cell[BoxData[
  FormBox[
   RowBox[{
    UnderoverscriptBox["\[Sum]", 
     RowBox[{"x", "=", "1"}], "nGrid"], 
    RowBox[{
     SuperscriptBox["\[Psi]", "*"], " ", "x", " ", "\[Psi]"}]}], 
   TraditionalForm]]],
 ", where ",
 Cell[BoxData[
  FormBox[
   SuperscriptBox["\[Psi]", "*"], TraditionalForm]]],
 "is the complex conjugate of \[Psi]."
}], "Text"],

Cell[BoxData[
 RowBox[{
  RowBox[{
   RowBox[{"avgx", "[", "\[Psi]_List", "]"}], " ", ":=", " ", 
   RowBox[{
    RowBox[{"Plus", " ", "@@", " ", 
     RowBox[{"(", 
      RowBox[{
       RowBox[{"Conjugate", "[", "\[Psi]", "]"}], " ", 
       RowBox[{"Table", "[", 
        RowBox[{"x", ",", " ", 
         RowBox[{"{", 
          RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], 
       " ", "\[Psi]"}], ")"}]}], " ", "//", " ", "Chop"}]}], ";"}]], "Input"],

Cell[CellGroupData[{

Cell["Solution", "Subsubsection"],

Cell[BoxData[
 RowBox[{"avgx", "[", 
  RowBox[{"sol", "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], 
  "]"}]], "Input"],

Cell[BoxData[
 RowBox[{"avgx", "[", 
  RowBox[{"sol", "\[LeftDoubleBracket]", "100", "\[RightDoubleBracket]"}], 
  "]"}]], "Input"],

Cell[BoxData[
 RowBox[{"ListPlot", "[", 
  RowBox[{
   RowBox[{"avgx", "/@", "sol"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", 
    RowBox[{"{", 
     RowBox[{"1", ",", "100"}], "}"}]}]}], "]"}]], "Input"],

Cell[BoxData[{
 RowBox[{
  RowBox[{"nGrid", " ", "=", " ", "100"}], ";", 
  RowBox[{"\[Psi]0", " ", "=", " ", 
   RowBox[{"(", 
    RowBox[{
     RowBox[{"Table", "[", 
      RowBox[{
       RowBox[{
        RowBox[{"initial", "[", 
         RowBox[{"0.6", ",", 
          RowBox[{"nGrid", "/", "2"}], ",", "8"}], "]"}], "[", "x", "]"}], 
       ",", " ", 
       RowBox[{"{", 
        RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], " ", 
     "//", " ", "N"}], ")"}]}], ";"}], "\[IndentingNewLine]", 
 RowBox[{
  RowBox[{"v0", " ", "=", " ", 
   RowBox[{"Table", "[", 
    RowBox[{"0.0", ",", " ", 
     RowBox[{"{", 
      RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}]}], 
  ";"}], "\[IndentingNewLine]", 
 RowBox[{"plot\[Psi]", "[", "\[Psi]0", "]"}]}], "Input",
 CellChangeTimes->{3.4489015723710546`*^9}],

Cell[BoxData[
 RowBox[{
  RowBox[{"sol", " ", "=", " ", 
   RowBox[{"NestList", "[", 
    RowBox[{"tenSteps", ",", " ", "\[Psi]0", ",", " ", "100"}], "]"}]}], 
  ";"}]], "Input"],

Cell[BoxData[
 RowBox[{"ListDensityPlot", "[", 
  RowBox[{
   RowBox[{"Abs", "[", "sol", "]"}], ",", 
   RowBox[{"Mesh", "\[Rule]", "False"}], ",", 
   RowBox[{"ColorFunction", "\[Rule]", "Hue"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", 
    RowBox[{"{", 
     RowBox[{"0", ",", "0.3"}], "}"}]}]}], "]"}]], "Input",
 CellChangeTimes->{3.448901578881143*^9}],

Cell[BoxData[
 RowBox[{"ListPlot", "[", 
  RowBox[{
   RowBox[{"avgx", "/@", "sol"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", 
    RowBox[{"{", 
     RowBox[{"1", ",", "100"}], "}"}]}]}], "]"}]], "Input"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell["Most likely momentum (in-class)", "Section"],

Cell["\<\
For the wave-function computed in class, determine the \"most-likely momentum\
\" as a function of time.\
\>", "Text"],

Cell[TextData[{
 "The most likely momentum can be calculated in several ways. One easy method \
is to compute the sum ",
 Cell[BoxData[
  FormBox[
   RowBox[{
    UnderoverscriptBox["\[Sum]", 
     RowBox[{"x", "=", "1"}], "nGrid"], 
    RowBox[{
     SuperscriptBox["\[Psi]", "*"], "(", 
     RowBox[{
      RowBox[{"-", " ", "I"}], " ", 
      RowBox[{
       SubscriptBox["\[PartialD]", "x"], " ", "\[Psi]"}]}], ")"}]}], 
   TraditionalForm]]],
 ". This can be written as"
}], "Text"],

Cell[BoxData[
 RowBox[{
  RowBox[{
   RowBox[{"avgk", "[", "\[Psi]_List", "]"}], " ", ":=", " ", 
   RowBox[{
    RowBox[{"-", " ", "I"}], " ", 
    RowBox[{"Chop", "[", " ", 
     RowBox[{"Plus", " ", "@@", " ", 
      RowBox[{"(", 
       RowBox[{
        RowBox[{"Conjugate", "[", "\[Psi]", "]"}], " ", 
        RowBox[{"ListConvolve", "[", 
         RowBox[{
          RowBox[{"{", 
           RowBox[{"0.5", ",", " ", "0", ",", " ", 
            RowBox[{"-", "0.5"}]}], "}"}], ",", " ", "\[Psi]", ",", " ", "2", 
          ",", " ", "0.0"}], "]"}]}], ")"}]}], "]"}]}]}], ";"}]], "Input"],

Cell[TextData[{
 "The command ",
 StyleBox["ListConvolve[\[Ellipsis]]",
  FontWeight->"Bold"],
 " is used to find the central-difference approximation to the first \
derivative in x",
 StyleBox[". ",
  FontSlant->"Italic"],
 Cell[BoxData[
  FormBox[
   RowBox[{
    SubscriptBox["\[PartialD]", "x"], " ", "\[Psi]"}], TraditionalForm]]],
 "\[TildeTilde] (\[Psi](x + 1) - \[Psi](x - 1)) / 2."
}], "Text"],

Cell[CellGroupData[{

Cell["Solution", "Subsubsection"],

Cell[BoxData[
 RowBox[{"avgk", "[", 
  RowBox[{"sol", "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}], 
  "]"}]], "Input"],

Cell[BoxData[
 RowBox[{"ListPlot", "[", 
  RowBox[{"avgk", "/@", "sol"}], "]"}]], "Input"]
}, Closed]],

Cell[CellGroupData[{

Cell["Momentum Probability", "Subsubsection"],

Cell[TextData[{
 "Another way to view the momentum is to transform the solution to a \
\"momentum representation\". This is simply the Fourier transform (along the \
",
 StyleBox["x",
  FontSlant->"Italic"],
 " direction) of the solution, \[Psi](x, t) \[Rule] \[Psi](k, t)."
}], "Text"],

Cell[TextData[{
 "As described in ",
 StyleBox["Mathematica's ",
  FontSlant->"Italic"],
 "help manuals, ",
 StyleBox["Fourier[\[Ellipsis]]",
  FontWeight->"Bold"],
 " returns the spectrum in a mixed order. The first ",
 StyleBox["nGrid/2",
  FontWeight->"Bold"],
 " points correspond to ",
 StyleBox["k",
  FontSlant->"Italic"],
 " = 0 to -\[Pi]. The next points correspond to \[Pi] back down towards 0. \
For this reason, we need t o re-arrange the spectrum:"
}], "Text"],

Cell[BoxData[
 RowBox[{
  RowBox[{"rearrangeFourier", "[", "p_List", "]"}], " ", ":=", " ", 
  RowBox[{"Reverse", "[", 
   RowBox[{
    RowBox[{"p", "[", 
     RowBox[{"[", 
      RowBox[{"Range", "[", 
       RowBox[{
        RowBox[{
         RowBox[{"nGrid", "/", "2"}], " ", "+", " ", "1"}], ",", " ", 
        "nGrid"}], "]"}], "]"}], "]"}], " ", 
    StyleBox["~",
     FontColor->RGBColor[1, 0, 1]], 
    StyleBox[" ",
     FontColor->RGBColor[1, 0, 1]], 
    StyleBox["Join",
     FontColor->RGBColor[1, 0, 1]], 
    StyleBox["~",
     FontColor->RGBColor[1, 0, 1]], " ", 
    RowBox[{"p", "[", 
     RowBox[{"[", 
      RowBox[{"Range", "[", 
       RowBox[{"1", ",", 
        RowBox[{"nGrid", "/", "2"}]}], "]"}], "]"}], "]"}]}], 
   "]"}]}]], "Input"],

Cell[BoxData[
 RowBox[{
  RowBox[{"kTest", "=", "0.6"}], ";", 
  RowBox[{"ListPlot", "[", 
   RowBox[{
    RowBox[{"Abs", "[", 
     RowBox[{"Fourier", "[", 
      RowBox[{"Table", "[", 
       RowBox[{
        SuperscriptBox["\[ExponentialE]", 
         RowBox[{"\[ImaginaryI]", " ", "kTest", " ", "x"}]], ",", 
        RowBox[{"{", 
         RowBox[{"x", ",", "1", ",", "nGrid"}], "}"}]}], "]"}], "]"}], "]"}], 
    ",", 
    RowBox[{"PlotRange", "\[Rule]", "All"}]}], "]"}]}]], "Input",
 CellChangeTimes->{3.448901621053219*^9}],

Cell[BoxData[
 RowBox[{"ListPlot", "[", 
  RowBox[{
   RowBox[{"Abs", "[", 
    RowBox[{"rearrangeFourier", "[", 
     RowBox[{"Fourier", "[", 
      RowBox[{"Table", "[", 
       RowBox[{
        SuperscriptBox["\[ExponentialE]", 
         RowBox[{"\[ImaginaryI]", " ", "kTest", " ", "x"}]], ",", 
        RowBox[{"{", 
         RowBox[{"x", ",", "1", ",", "nGrid"}], "}"}]}], "]"}], "]"}], "]"}], 
    "]"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", "All"}]}], "]"}]], "Input"],

Cell[BoxData[
 RowBox[{
  RowBox[{"solk", " ", "=", " ", 
   RowBox[{
    RowBox[{
     RowBox[{"rearrangeFourier", "[", 
      RowBox[{"Fourier", "[", "#", "]"}], "]"}], "&"}], " ", "/@", " ", 
    "sol"}]}], ";"}]], "Input"],

Cell[BoxData[
 RowBox[{"ListDensityPlot", "[", 
  RowBox[{
   RowBox[{"Abs", "[", "solk", "]"}], ",", 
   RowBox[{"Mesh", "\[Rule]", "False"}], ",", 
   RowBox[{"ColorFunction", "\[Rule]", "Hue"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", "All"}]}], "]"}]], "Input"],

Cell[BoxData[
 RowBox[{"ListPlot3D", "[", 
  RowBox[{
   RowBox[{"Abs", "[", "solk", "]"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", "All"}], ",", 
   RowBox[{"Mesh", "\[Rule]", "False"}]}], "]"}]], "Input"],

Cell[TextData[{
 "Notice that ",
 StyleBox["zero",
  FontSlant->"Italic"],
 " momentum is at position ",
 StyleBox["nGrid/2",
  FontWeight->"Bold"],
 ". The particle bounces back and forth. After a few bounces, however, it \
becomes difficult to know whether the particle is moving to the right or to \
the left!"
}], "Text"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell["Heisenberg's Uncertainty", "Section"],

Cell["\<\
In this problem, you are to examine Heisenberg's Uncertainty Principle. If \
you specify the location of a particle with high accuracy, you can not know \
its momentum very well. On the other hand, if you allow uncertainty in a \
particle's location, then you may specify its momentum more accurately. \
\>", "Text"],

Cell[CellGroupData[{

Cell["Part 1", "Subsection"],

Cell["\<\
In order to illustrate this, we'll look at particles initialized with \
\"zero\" momentum. We'll first examine the time-dependence of the \
wave-function for a \"narrow\" (well-localized) initial condition and next \
for a broad (not very-well localized) initial condtion. \
\>", "Text"],

Cell[TextData[{
 "Let these two initial conditions be called, ",
 StyleBox["\[Psi]",
  FontWeight->"Bold"],
 StyleBox["Narrow",
  FontWeight->"Bold"],
 " and ",
 StyleBox["\[Psi]Broad",
  FontWeight->"Bold"],
 ":"
}], "Text"],

Cell[BoxData[{
 RowBox[{
  RowBox[{"nGrid", " ", "=", " ", "100"}], ";"}], "\[IndentingNewLine]", 
 RowBox[{
  RowBox[{"v0", " ", "=", " ", 
   RowBox[{"Table", "[", 
    RowBox[{"0.0", ",", " ", 
     RowBox[{"{", 
      RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}]}], ";", 
  
  RowBox[{"\[Psi]Narrow", " ", "=", " ", 
   RowBox[{"N", "[", 
    RowBox[{"Table", "[", 
     RowBox[{
      RowBox[{
       RowBox[{"initial", "[", 
        RowBox[{"0.0", ",", 
         RowBox[{"nGrid", "/", "2"}], ",", "2"}], "]"}], "[", "x", "]"}], ",",
       " ", 
      RowBox[{"{", 
       RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], 
    "]"}]}], ";"}], "\[IndentingNewLine]", 
 RowBox[{
  RowBox[{"\[Psi]Broad", " ", "=", " ", 
   RowBox[{"N", "[", 
    RowBox[{"Table", "[", 
     RowBox[{
      RowBox[{
       RowBox[{"initial", "[", 
        RowBox[{"0.0", ",", 
         RowBox[{"nGrid", "/", "2"}], ",", "16"}], "]"}], "[", "x", "]"}], 
      ",", " ", 
      RowBox[{"{", 
       RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], 
    "]"}]}], ";"}]}], "Input"],

Cell[TextData[{
 "Advance the wave-function from both of these initial conditions using ",
 StyleBox["cnStep[\[Ellipsis]]",
  FontWeight->"Bold"],
 ". Describe in words the differences between the two solutions. What do \
these differences say about the uncertainty relation?"
}], "Text"],

Cell[CellGroupData[{

Cell["Solution", "Subsubsection"],

Cell[BoxData[{
 RowBox[{
  RowBox[{"solNarrow", "=", 
   RowBox[{"NestList", "[", 
    RowBox[{
     RowBox[{
      RowBox[{"cnStep", "[", 
       RowBox[{"#1", ",", "v0"}], "]"}], "&"}], ",", "\[Psi]Narrow", ",", 
     "100"}], "]"}]}], ";"}], "\n", 
 RowBox[{"ListPlot3D", "[", 
  RowBox[{
   RowBox[{"Abs", "[", "solNarrow", "]"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", "All"}], ",", 
   RowBox[{"Mesh", "\[Rule]", "False"}]}], "]"}]}], "Input"],

Cell[BoxData[{
 RowBox[{
  RowBox[{"solBroad", "=", 
   RowBox[{"NestList", "[", 
    RowBox[{
     RowBox[{
      RowBox[{"cnStep", "[", 
       RowBox[{"#1", ",", "v0"}], "]"}], "&"}], ",", "\[Psi]Broad", ",", 
     "100"}], "]"}]}], ";"}], "\n", 
 RowBox[{"ListPlot3D", "[", 
  RowBox[{
   RowBox[{"Abs", "[", "solBroad", "]"}], ",", 
   RowBox[{"PlotRange", "\[Rule]", "All"}], ",", 
   RowBox[{"Mesh", "\[Rule]", "False"}]}], "]"}]}], "Input"],

Cell["\<\
Both plots show the particle's position spreads out in time. However, the \
narrow initial condition spreads more quickly indicating that it has faster \
momentum than the broad initial condition. Relatively to the narror initial \
condition, the broad initial condition hardly spreads at all. It's momentum \
is nearly zero.\
\>", "Text"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell["Part 2", "Subsection"],

Cell[TextData[{
 "Another way to illustrate the uncertainty relation is to look at both the \
\"width\" of the particle's probability in both coordinate space, or ",
 StyleBox["x",
  FontSlant->"Italic"],
 "-space, and in \"momentum space\", or ",
 StyleBox["k",
  FontSlant->"Italic"],
 "-space. Call the width in coordinate space \[CapitalDelta]x. Call the width \
in momentum space \[CapitalDelta]k. The uncertainty principle states that \
\[CapitalDelta]x \[CapitalDelta]k is a constant. "
}], "Text"],

Cell["\<\
Below, two functions are defined that compute the width in coordinate space \
and the width in momentum space:\
\>", "Text"],

Cell[BoxData[{
 RowBox[{
  RowBox[{
   RowBox[{"deltaX", "[", "\[Psi]_List", "]"}], " ", ":=", " ", 
   RowBox[{"Module", "[", 
    RowBox[{
     RowBox[{"{", "avg", "}"}], ",", "\[IndentingNewLine]", 
     RowBox[{
      RowBox[{"avg", " ", "=", " ", 
       RowBox[{"Plus", " ", "@@", " ", 
        RowBox[{"Chop", "[", 
         RowBox[{
          RowBox[{"Conjugate", "[", "\[Psi]", "]"}], " ", 
          RowBox[{"Table", "[", 
           RowBox[{"x", ",", " ", 
            RowBox[{"{", 
             RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], 
          " ", "\[Psi]"}], "]"}]}]}], ";", "\[IndentingNewLine]", 
      RowBox[{"Sqrt", "[", 
       RowBox[{"Plus", " ", "@@", " ", 
        RowBox[{"Chop", "[", 
         RowBox[{
          RowBox[{"Conjugate", "[", "\[Psi]", "]"}], " ", 
          RowBox[{"Table", "[", 
           RowBox[{
            RowBox[{
             RowBox[{"(", 
              RowBox[{"x", " ", "-", " ", "avg"}], ")"}], "^", "2"}], ",", 
            " ", 
            RowBox[{"{", 
             RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], 
          " ", "\[Psi]"}], "]"}]}], "]"}]}]}], "]"}]}], 
  ";"}], "\[IndentingNewLine]", 
 RowBox[{
  RowBox[{
   RowBox[{"deltaP", "[", "\[Psi]_List", "]"}], " ", ":=", " ", 
   RowBox[{"Module", "[", 
    RowBox[{
     RowBox[{"{", 
      RowBox[{"p", ",", "avg"}], "}"}], ",", "\[IndentingNewLine]", 
     RowBox[{
      RowBox[{"p", " ", "=", " ", 
       RowBox[{"rearrangeFourier", "[", 
        RowBox[{"Fourier", "[", "\[Psi]", "]"}], "]"}]}], ";", 
      RowBox[{"avg", " ", "=", " ", 
       RowBox[{"Plus", " ", "@@", " ", 
        RowBox[{"Chop", "[", 
         RowBox[{
          RowBox[{"Conjugate", "[", "p", "]"}], " ", 
          RowBox[{"Table", "[", 
           RowBox[{"k", ",", " ", 
            RowBox[{"{", 
             RowBox[{"k", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], 
          " ", "p"}], "]"}]}]}], ";", "\[IndentingNewLine]", 
      RowBox[{"Sqrt", "[", 
       RowBox[{"Plus", " ", "@@", " ", 
        RowBox[{"Chop", "[", 
         RowBox[{
          RowBox[{"Conjugate", "[", "p", "]"}], " ", 
          RowBox[{"Table", "[", 
           RowBox[{
            RowBox[{
             RowBox[{"(", 
              RowBox[{"k", " ", "-", " ", "avg"}], ")"}], "^", "2"}], ",", 
            " ", 
            RowBox[{"{", 
             RowBox[{"k", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], 
          " ", "p"}], "]"}]}], "]"}]}]}], "]"}]}], ";"}]}], "Input"],

Cell[TextData[{
 "These two functions work in the same way, except ",
 StyleBox["deltaP[\[Ellipsis]]",
  FontWeight->"Bold"],
 " uses the Fourier transform of \[Psi] while ",
 StyleBox["deltaX[\[Ellipsis]]",
  FontWeight->"Bold"],
 " uses \[Psi](",
 StyleBox["x",
  FontSlant->"Italic"],
 ")."
}], "Text"],

Cell[BoxData[
 RowBox[{"{", 
  RowBox[{
   RowBox[{"deltaX", "[", "\[Psi]Narrow", "]"}], ",", " ", 
   RowBox[{"deltaP", "[", "\[Psi]Narrow", "]"}], ",", " ", 
   RowBox[{
    RowBox[{"deltaX", "[", "\[Psi]Narrow", "]"}], " ", "*", " ", 
    RowBox[{"deltaP", "[", "\[Psi]Narrow", "]"}]}]}], "}"}]], "Input"],

Cell[BoxData[
 RowBox[{"{", 
  RowBox[{
   RowBox[{"deltaX", "[", "\[Psi]Broad", "]"}], ",", " ", 
   RowBox[{"deltaP", "[", "\[Psi]Broad", "]"}], ",", " ", 
   RowBox[{
    RowBox[{"deltaX", "[", "\[Psi]Broad", "]"}], " ", "*", " ", 
    RowBox[{"deltaP", "[", "\[Psi]Broad", "]"}]}]}], "}"}]], "Input"],

Cell[TextData[{
 StyleBox["Your assignment: ",
  FontWeight->"Bold",
  FontSlant->"Italic"],
 "Use the functions defined above and plot \[CapitalDelta]x versus \
\[CapitalDelta]k for various initial conditions. Use the ",
 StyleBox["initial[\[Ellipsis]]",
  FontWeight->"Bold"],
 " function to change the width of \[Psi] keeping the mean momentum at zero. \
ListPlot your results."
}], "Text"],

Cell[CellGroupData[{

Cell["Solution", "Subsubsection"],

Cell[BoxData[
 RowBox[{"deltaList", " ", "=", " ", 
  RowBox[{"Table", "[", 
   RowBox[{
    RowBox[{"{", 
     RowBox[{
      RowBox[{"deltaX", "[", 
       RowBox[{"N", "[", 
        RowBox[{"Table", "[", 
         RowBox[{
          RowBox[{
           RowBox[{"initial", "[", 
            RowBox[{"0.0", ",", 
             RowBox[{"nGrid", "/", "2"}], ",", "w"}], "]"}], "[", "x", "]"}], 
          ",", " ", 
          RowBox[{"{", 
           RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], 
        "]"}], "]"}], ",", " ", 
      RowBox[{"deltaP", "[", 
       RowBox[{"N", "[", 
        RowBox[{"Table", "[", 
         RowBox[{
          RowBox[{
           RowBox[{"initial", "[", 
            RowBox[{"0.0", ",", 
             RowBox[{"nGrid", "/", "2"}], ",", "w"}], "]"}], "[", "x", "]"}], 
          ",", " ", 
          RowBox[{"{", 
           RowBox[{"x", ",", " ", "1", ",", " ", "nGrid"}], "}"}]}], "]"}], 
        "]"}], "]"}]}], "}"}], ",", " ", 
    RowBox[{"{", 
     RowBox[{"w", ",", " ", "1", ",", " ", "16"}], "}"}]}], "]"}]}]], "Input"],

Cell[BoxData[
 RowBox[{"plt1", "=", 
  RowBox[{"ListPlot", "[", 
   RowBox[{"deltaList", ",", 
    RowBox[{"PlotRange", "\[Rule]", 
     RowBox[{"{", 
      RowBox[{"0", ",", "9"}], "}"}]}], ",", 
    RowBox[{"PlotStyle", "\[Rule]", 
     RowBox[{"PointSize", "[", "0.02`", "]"}]}], ",", 
    RowBox[{"AxesLabel", "\[Rule]", 
     RowBox[{"{", 
      RowBox[{"\"\<\[CapitalDelta]x\>\"", ",", "\"\<\[CapitalDelta]p\>\""}], 
      "}"}]}]}], "]"}]}]], "Input"],

Cell[BoxData[
 RowBox[{"Times", " ", "@@@", " ", "deltaList"}]], "Input"],

Cell[BoxData[{
 RowBox[{
  RowBox[{"plt2", "=", 
   RowBox[{"Plot", "[", 
    RowBox[{
     RowBox[{"Evaluate", "[", 
      RowBox[{"Fit", "[", 
       RowBox[{"deltaList", ",", 
        FractionBox["1", "x"], ",", "x"}], "]"}], "]"}], ",", 
     RowBox[{"{", 
      RowBox[{"x", ",", "1", ",", "16"}], "}"}], ",", 
     RowBox[{"DisplayFunction", "\[Rule]", "Identity"}]}], "]"}]}], 
  ";"}], "\n", 
 RowBox[{"Show", "[", 
  RowBox[{"plt1", ",", "plt2", ",", 
   RowBox[{"DisplayFunction", "\[Rule]", "$DisplayFunction"}]}], 
  "]"}]}], "Input"],

Cell[BoxData[
 RowBox[{"Fit", "[", 
  RowBox[{"deltaList", ",", " ", 
   RowBox[{"1", "/", "x"}], ",", " ", "x"}], "]"}]], "Input"],

Cell[BoxData[
 RowBox[{
  RowBox[{"2", " ", "\[Pi]"}], " ", "//", " ", "N"}]], "Input"],

Cell[TextData[{
 "Therefore, \[Delta]",
 StyleBox["p",
  FontSlant->"Italic"],
 " \[Delta]",
 StyleBox["x",
  FontSlant->"Italic"],
 " ~ 7.96 > 2\[Pi]."
}], "Text"]
}, Closed]]
}, Closed]]
}, Closed]]
}, Open  ]]
},
WindowSize->{674, 848},
WindowMargins->{{159, Automatic}, {Automatic, 0}},
PrintingCopies->1,
PrintingPageRange->{1, Automatic},
FrontEndVersion->"6.0 for Mac OS X x86 (32-bit) (May 21, 2008)",
StyleDefinitions->"Default.nb"
]
(* End of Notebook Content *)

(* Internal cache information *)
(*CellTagsOutline
CellTagsIndex->{}
*)
(*CellTagsIndex
CellTagsIndex->{}
*)
(*NotebookFileOutline
Notebook[{
Cell[CellGroupData[{
Cell[590, 23, 99, 1, 73, "Title"],
Cell[692, 26, 127, 4, 45, "Subsubtitle"],
Cell[CellGroupData[{
Cell[844, 34, 49, 0, 69, "Section"],
Cell[896, 36, 635, 18, 91, "Text"],
Cell[CellGroupData[{
Cell[1556, 58, 33, 0, 24, "Subsubsection"],
Cell[1592, 60, 2368, 61, 165, "Input"],
Cell[3963, 123, 725, 24, 46, "Input"],
Cell[4691, 149, 1830, 44, 165, "Input"]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell[6570, 199, 48, 0, 39, "Section"],
Cell[6621, 201, 302, 10, 43, "Text"],
Cell[CellGroupData[{
Cell[6948, 215, 33, 0, 24, "Subsubsection"],
Cell[6984, 217, 842, 24, 63, "Input"],
Cell[7829, 243, 276, 6, 43, "Text"],
Cell[8108, 251, 300, 9, 28, "Input"],
Cell[8411, 262, 475, 15, 46, "Input"],
Cell[8889, 279, 358, 9, 46, "Input"],
Cell[9250, 290, 299, 8, 28, "Input"],
Cell[9552, 300, 178, 4, 28, "Input"],
Cell[9733, 306, 295, 5, 59, "Text"]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell[10077, 317, 50, 0, 39, "Section"],
Cell[10130, 319, 582, 17, 67, "Text"],
Cell[10715, 338, 475, 13, 28, "Input"],
Cell[CellGroupData[{
Cell[11215, 355, 33, 0, 24, "Subsubsection"],
Cell[11251, 357, 129, 3, 28, "Input"],
Cell[11383, 362, 131, 3, 28, "Input"],
Cell[11517, 367, 205, 6, 28, "Input"],
Cell[11725, 375, 844, 24, 63, "Input"],
Cell[12572, 401, 178, 5, 28, "Input"],
Cell[12753, 408, 358, 9, 46, "Input"],
Cell[13114, 419, 205, 6, 28, "Input"]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell[13368, 431, 50, 0, 39, "Section"],
Cell[13421, 433, 128, 3, 27, "Text"],
Cell[13552, 438, 487, 16, 51, "Text"],
Cell[14042, 456, 592, 16, 46, "Input"],
Cell[14637, 474, 402, 13, 43, "Text"],
Cell[CellGroupData[{
Cell[15064, 491, 33, 0, 24, "Subsubsection"],
Cell[15100, 493, 129, 3, 28, "Input"],
Cell[15232, 498, 90, 2, 28, "Input"]
}, Closed]],
Cell[CellGroupData[{
Cell[15359, 505, 45, 0, 24, "Subsubsection"],
Cell[15407, 507, 286, 7, 43, "Text"],
Cell[15696, 516, 473, 15, 59, "Text"],
Cell[16172, 533, 762, 25, 46, "Input"],
Cell[16937, 560, 531, 15, 53, "Input"],
Cell[17471, 577, 479, 13, 53, "Input"],
Cell[17953, 592, 226, 7, 28, "Input"],
Cell[18182, 601, 266, 6, 46, "Input"],
Cell[18451, 609, 207, 5, 28, "Input"],
Cell[18661, 616, 325, 10, 43, "Text"]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell[19035, 632, 43, 0, 39, "Section"],
Cell[19081, 634, 326, 5, 59, "Text"],
Cell[CellGroupData[{
Cell[19432, 643, 28, 0, 33, "Subsection"],
Cell[19463, 645, 297, 5, 59, "Text"],
Cell[19763, 652, 225, 10, 27, "Text"],
Cell[19991, 664, 1114, 34, 80, "Input"],
Cell[21108, 700, 288, 6, 43, "Text"],
Cell[CellGroupData[{
Cell[21421, 710, 33, 0, 24, "Subsubsection"],
Cell[21457, 712, 451, 13, 46, "Input"],
Cell[21911, 727, 448, 13, 46, "Input"],
Cell[22362, 742, 349, 6, 59, "Text"]
}, Closed]]
}, Closed]],
Cell[CellGroupData[{
Cell[22760, 754, 28, 0, 33, "Subsection"],
Cell[22791, 756, 505, 11, 59, "Text"],
Cell[23299, 769, 134, 3, 27, "Text"],
Cell[23436, 774, 2525, 67, 131, "Input"],
Cell[25964, 843, 305, 11, 43, "Text"],
Cell[26272, 856, 308, 7, 28, "Input"],
Cell[26583, 865, 304, 7, 28, "Input"],
Cell[26890, 874, 393, 10, 43, "Text"],
Cell[CellGroupData[{
Cell[27308, 888, 33, 0, 24, "Subsubsection"],
Cell[27344, 890, 1080, 31, 80, "Input"],
Cell[28427, 923, 458, 12, 46, "Input"],
Cell[28888, 937, 73, 1, 28, "Input"],
Cell[28964, 940, 546, 16, 88, "Input"],
Cell[29513, 958, 131, 3, 28, "Input"],
Cell[29647, 963, 87, 2, 28, "Input"],
Cell[29737, 967, 164, 8, 27, "Text"]
}, Closed]]
}, Closed]]
}, Closed]]
}, Open  ]]
}
]
*)

(* End of internal cache information *)