DE.09 The Heat Equation
       \(∂\_{x, 2}temp[x, t] = ∂\_t temp[x, t]\)
and the Wave Equation
       \(\(\ 
      ∂\_{x, 2}position[x, t] = 
        ∂\_{t, 2}position[x, t]\)\)
TUTORIALS

Needs["Graphics`Colors`"];
Needs["Graphics`FilledPlot`"];

If[MemberQ[{"Global`","Graphics`Common`GraphicsCommon`","Vector3D`"}, 
    Context[ScaleFactor]],Remove["*`ScaleFactor"]];
<<"Graphics`Legend`";
<<"Graphics`Common`GraphicsCommon`";
Remove["*`ScaleFactor"];
Graphics`Colors`GosiaGreen=RGBColor[0, 0.392187, 0];
Off[General::spell];
Off[General::spell1];
Off[ParametricPlot3D::ppcom];
Off[ParametricPlot::ppcom];
Off[Plot::plnr];
Needs["Calculus`Master`"];
Off[Unique::"usym"];
SetOptions[Limit,Analytic->True];

CMView = {2.7, 1.6, 1.2};
Clear[FastFourierfit,Fourierfitters,F,Fvalues,n,k,
      jump,num,numtab,coeffs,t,L];
jump[n_] := jump[n] = N[1/(2 n)];
Fvalues[F_,L_,n_] := 
  N[Table[F[L t],{t,0,1 - jump[n],jump[n]}]];
  

numtab[n_] := numtab[n] = Table[k,{k,1,n}];

Fourierfitters[L_,n_,t_] := Table[E^(2 Pi I k t/L),
          {k,-n + 1,n - 1}];
coeffs[n_,list_] := Join[Reverse[Part[Fourier[list],numtab[n]]],
	Part[InverseFourier[list],Drop[numtab[n],1]]]/
		N[Sqrt[Length[list]]]

FastFourierfit[F_,L_,n_,t_] := 
     Chop[Fourierfitters[L,n,t].coeffs[n,Fvalues[F,L,n]]];    
L:=Expand[a D[#1,{#2,2}] + b D[#1,#2] + c #1]&

Off[Graphics::gpt]

New Vector Drawers

(* :Title:  NewVectorDraw  *)
(* :Author: Bruce Carpenter *)
(* :Summary:  Construct 2 and 3 dimensional vectors,
     arrows, and arrowheads as graphics 
     objects.
*)
(* :Date:  Copyright 1997, Math Everywhere, Inc. 
*)
(*  :Drawbacks:  Since the vectors are drawn out of 
     context, the shapes of the arrowheads are only 
     correct with AspectRatio set to Automatic.
*)
BeginPackage["Vector3D`","Graphics`Colors`"];

Axes3D::usage = "Axes3D[a, b] creates a Graphics3D object of cartesian axes with x, y, and z running from -a/3 to a, and with axes labels b units beyond the tips of the axes.  Axes3D[a] is Axes3D[a, a/8].";

Perpend::usage = "Perpend[a] returns a unit vector which is perpendicular to the vector a.";

Arrow::usage = "Arrow[a] produces a 2 or 3 dimensional vector from the origin to a. Arrow[a, Tail -> tail] gives a vector from tail to a.";
	
Vector::usage = "Vector[a, b] gives a 2D or 3D vector from a to b.";

ArrowHead::usage = "ArrowHead[a, vec] produces an arrowhead with its tip placed at the point a, pointing in the direction of the vector vec.";

Tail::usage = "Tail -> point puts the tail of the vector at point.";

Norm::usage = "Norm[vec] returns the Euclidean length of vec.";

Normalize::usage = "Normalize[vec] returns a unit vector in the direction of vec, provided vec is nonzero.";

Aperture::usage = "Aperture is the ratio of the radius of the base to the length of the head of a vector.";

TipSize::usage = "TipSize specifies an absolute size for the inner tip length of the head of a vector.";

TipRatio::usage = "TipRatio is the ratio of the inner length of the arrowhead to the length of the shaft of a vector.";

HeadRatio::usage = "HeadRatio is the ratio of the outer length of the arrowhead to the length of the shaft of a vector.";

HeadSize::usage = "HeadSize specifies an absolute size for the head of a vector.";

ScaleFactor::usage = "ScaleFactor specifies the amount to scale a vector in length and may be either a number or a pure function.";

ZeroVectorPointSize::usage = "ZeroVectorPointSize is the size of the point used to represent a zero vector.";

Options[Vector] = Options[Arrow] = Options[ArrowHead] =
{HeadRatio -> 0.18, TipRatio -> 0.14, Aperture -> 0.3, ScaleFactor -> 1, HeadType -> Polygon, ShaftQ -> True, EdgesQ -> True, VectorColor -> RGBColor[0,0,1], ShaftWidth -> 0.005, ZeroVectorPointSize -> 0.01};
		
Begin["`Private`"];

SetOptions[ParametricPlot,AspectRatio -> Automatic];
SetOptions[Plot,AspectRatio -> Automatic];
SetOptions[Graphics,AspectRatio -> Automatic];

Axes3D[u_,v_] := 
      Graphics3D[{
            {Blue,Line[{{-u/3,0,0},{u,0,0}}]},
                    Text["x",{u + v,0,0}],
            {Blue,Line[{{0,-u/3,0},{0,u,0}}]},
                    Text["y",{0, u + v,0}],
            {Blue,Line[{{0,0,-u/3},{0,0,u}}]},
                    Text["z",{0,0,u + v}]}]; 
Axes3D[u_] := Axes3D[u,u/8];
				
Norm[a_?VectorQ] := N[Sqrt[a.a]];

Normalize[a_?VectorQ] := If[a.a == 0, a, a/Norm[a]];

Perpend[a_?VectorQ] := Normalize[{a[[2]],-a[[1]]}]/;Length[a]==2
Perpend[a_?VectorQ] := Normalize[If[a[[1]]==0,{1,0,0},{0,a[[3]],-a[[2]]}]]/;Length[a]==3

Base3D = Table[{Cos[2 k Pi/8.], Sin[2 k Pi/8.]},{k,0,8}]; 

Vector[from_?VectorQ, to_?VectorQ, opts___] := Module[
   {sq, sw, ht, hs, hr, tr, ap, sf, vc, zvps, diff = to - from, tip},
   {sq, sw, ht, hs, hr, ts, tr, ap, sf, vc, zvps} = {ShaftQ, ShaftWidth, HeadType, HeadSize, HeadRatio, TipSize, TipRatio, Aperture, ScaleFactor, VectorColor, ZeroVectorPointSize} /. {opts} /. Options[Vector];
   If[from==to, Return[Graphics[{PointSize[zvps],vc,Point[from]}]]];
   diff = If[NumberQ[N[sf]], sf diff, sf[diff]];
   tip = from + diff;
   If[NumberQ[hs], hr = hs/Norm[diff]; tr = 0.75 hr];
   If[NumberQ[ts], tr = ts/Norm[diff]];
   Graphics[{If[sq,{vc,Thickness[sw],Line[{from,tip - tr diff}]},{}],
      With[{trans = ap hr Norm[diff] Perpend[diff]},
      {vc, Thickness[sw], ht[{tip,
                   (tip - hr diff + trans),
                   (tip - tr diff),
                   (tip - hr diff - trans),tip}]}]}]
] /; Length[from]==Length[to]==2

Vector[from_?VectorQ, to_?VectorQ, opts___] := Module[
   {sq, eq, sw, hs, hr, tr,ap, sf, vc, zvps, diff = to - from, tip},
   {sq, eq, sw, hs, hr, ap, sf, vc, zvps} = {ShaftQ, EdgesQ, ShaftWidth, HeadSize, HeadRatio, Aperture, ScaleFactor, VectorColor, ZeroVectorPointSize} /. {opts} /. Options[Vector];
   If[from==to, Return[Graphics3D[{PointSize[zvps],vc,Point[from]}]]];
   diff = If[NumberQ[N[sf]], sf diff, sf[diff]];
   tip = from + diff;
   If[NumberQ[hs], hr = hs/Norm[diff]];
   tr = hr/2;
   Graphics3D[{If[sq,{vc,Thickness[sw],Line[{from,tip-tr diff}]},{}], If[eq, {}, EdgeForm[]], {SurfaceColor[vc],
      With[{temp = Perpend[diff]},
      Polygon[Append[#,tip]]& /@ Partition[(tip - hr diff + #)&/@((ap hr Norm[diff] Base3D) . {temp,Normalize[Cross[temp,diff]]}),2,1]]}}]
] /; Length[from]==Length[to]==3


Arrow[a_, Tail->b_, opts___] := Vector[b,a+b,opts]

Arrow[a_, opts___] := Vector[Table[0,{Length[a]}],a,opts]

ArrowHead[a_, b_, opts___] := Vector[a-b,a,ShaftQ->False,opts];

End[];

EndPackage[];
Null

VectorField and Phase Lines

(*  :Title: VectorAndPhase.m  *)

(*  :Author:  Bill Davis  *)

(*  :Dates:  about March, 1996 *)

(*  :Drawbacks:  I wish someone serious would come and turn these into
                 Really carefully done packages.  *)

BeginPackage["PhaseStuff`","Vector3D`",
		"Utilities`FilterOptions`"];

PhaseLine::usage = "PhaseLine[fcn,{var,a,b},tint,pos]
	makes a vertical phase line for the function, fcn, of the variable, var,
	for the variable going from a to b, with 
	a color given by tint,  at the x-coordinate pos.";
	
PhaseLine3D::usage = "PhaseLIne3D[fcn,{var,a,b},tint,loc]
	makes a vertical phase line for the function, fcn, of the variable, var,
	for the variable going from a to b, with 
	a color given by tint, and base point at loc = {x,y}";
	
VectorField::usage = "VectorField[{function,{var1,a,b,space1},{var2,c,d,space2}]
	will make a vector field of normalized vectors, colored by
	magnitude, for the function of the variables on the
	range {r1,r2} with spacing between points given by 
	{space1, space2}.  If a single function of a single variable is given,
	the vector field {1,f} will be plotted.";
	
StikPikXZ::usage = "StikPikXZ[picture,a:_0] takes a 2 dimensional
	Mathematica picture and embeds it on the XZ plane at y = a.  
	Some optional characteristics of the graphs are lost in the 
	process.  StikPikYZ and StikPikXZ are similar.";
	
StikPikYZ::usage = "StikPikYZ[picture,a:_0] takes a 2 dimensional
	Mathematica picture and embeds it on the XZ plane at y = a.  
	Some optional characteristics of the graphs are lost in the 
	process.  StikPikYZ and StikPikXZ are similar.";
	
StikPikXY::usage = "StikPikXY[picture,a:_0] takes a 2 dimensional
	Mathematica picture and embeds it on the XZ plane at y = a.  
	Some optional characteristics of the graphs are lost in the 
	process.  StikPikYZ and StikPikXZ are similar.";
	
Begin["`Private`"];	

PhaseLine[fcn_,{var_,a_,b_},tint_,pos_:0] := 
	Module[{len,len1,k,zset,zero,zero1,signs,stick,dots,pointers},
	zset = Solve[fcn==0,var];
	zero = If[Length[zset]==0,{},var/.zset];
	zero = Sort[zero];
	zero = Select[zero,((# >= a)&&(# <= b))&];
	zero1 = Sort[Union[zero,{a,b}]];
	len = Length[zero];
	len1 = Length[zero1];
	signs = Table[Sign[fcn/.var->((zero1[[k+1]] + zero1[[k]])/2)],
		{k,1,len1-1}];
	stick = {Thickness[0.007],Line[{{pos,a},{pos,b}}]};
	dots = Point[{pos,#}]&/@zero;
	dots = Join[{PointSize[0.05],tint},dots];
	heads = Table[MakeHead[zero1[[k]],zero1[[k+1]],pos,
		signs[[k]],b-a,tint],{k,1,len1-1}];
	Return[{Graphics[Join[{tint},stick,dots]],heads}]
		]
		
MakeHead[a_,b_,c_,s_,slen_,tint_] := Module[{u,v,w},
	u = Min[2(b-a),3/4 slen];
	Return[ArrowHead[{c,a(.5-s/5)+b(.5+s/5)},
		{0,s u},VectorColor->tint]]]
		
PhaseLine3D[fcn_,{var_,a_,b_},tint_,pos_:{0,0}] := 
	Module[{len,len1,k,zset,zero,zero1,signs,stick,dots,pointers},
	zset = Solve[fcn==0,var];
	zero = If[Length[zset]==0,{},var/.zset];
	zero = Sort[zero];
	zero = Select[zero,((# >= a)&&(# <= b))&];
	zero1 = Sort[Union[zero,{a,b}]];
	len = Length[zero];
	len1 = Length[zero1];
	signs = Table[Sign[fcn/.var->((zero1[[k+1]] + zero1[[k]])/2)],
		{k,1,len1-1}];
	stick = {Thickness[0.007],Line[{{pos[[1]],pos[[2]],a},
		{pos[[1]],pos[[2]],b}}]};
	dots = Point[{pos[[1]],pos[[2]],#}]&/@zero;
	dots = Join[{PointSize[0.03],tint},dots];
	heads = Table[MakeHead3D[zero1[[k]],zero1[[k+1]],pos,
		signs[[k]],b-a,tint],{k,1,len1-1}];
	Return[{Graphics3D[Join[{tint},stick,dots]],heads}]
		]
		
MakeHead3D[a_,b_,c_,s_,slen_,tint_] := Module[{u,v,w},
	u = Min[2(b-a),1/2 slen];
	Return[ArrowHead[{c[[1]],c[[2]],a(.5-s/5)+b(.5+s/5)},
		{0,0,s u},VectorColor->tint]]]
		
		
VectorField[function_List,{var1_,a_,b_,sp1_:1},{var2_,c_,d_,sp2_:1}] := 
	Module[{i,j,U,V,UU,VV,ulow,uhigh,vlow,vhigh,maxval,minval,
		lengths,directions,locations,mlen},
	mlen = Min[sp1,sp2];
	normf[uu_,vv_] = Sqrt[function[[1]]^2+function[[2]]^2]/.
		{var1->uu,var2->vv};
	lengths = Table[N[normf[U,V]],{U,a,b,sp1},{V,c,d,sp2}];
	maxval = Max[lengths]; minval = Min[lengths];
	If[minval == maxval,maxval += 1];
	locations = Table[{uu,vv},{uu,a,b,sp1},
		{vv,c,d,sp2}];
	directions = Table[If[N[normf[U,V]]==0,{0,0},
		mlen (function/.{var1->U,var2->V})/(1.3 N[normf[U,V]])],
			{U,a,b,sp1},{V,c,d,sp2}];
	{UU,VV} = Dimensions[directions][[{1,2}]];
	Return[Table[Arrow[directions[[i,j]],
			Tail->locations[[i,j]],Aperture->1,
			HeadRatio->.4,ShaftWidth->0.008, VectorColor->
			RGBColor[(lengths[[i,j]] - minval)/(maxval-minval),0,
				(maxval -lengths[[i,j]])/(maxval-minval)]],{i,UU},{j,VV}]]
		]
		
VectorField[function_,{var1_,a_,b_,sp1_:1},{var2_,c_,d_,sp2_:1}] :=
	VectorField[{1,function},{var1,a,b,sp1},{var2,c,d,sp2}]
	
	
Needs["Utilities`FilterOptions`"]

FixOptions[a_] := Module[{picture = a, opt3},
If[Options[picture] != {}, 
	opt3 = FilterOptions[Graphics3D,#]&/@Options[picture];
	(* Fix things that might carry 2D characteristics. *)
	opt3 = opt3//. {(AxesLabel -> _) ->(AxesLabel -> None),
			(PlotRange->_) -> (PlotRange->Automatic),
			(PlotRegion -> _) -> (PlotRegion -> Automatic),
			(Ticks -> _) -> (Ticks -> Automatic)};
	picture = Apply[List,picture];
	picture[[-1]] = opt3;
	picture = Apply[Graphics3D,picture]];
	Return[picture]
	]

StikPikXZ[picture_,a_:0] := Module[{PIK3 = picture},
	PIK3 = PIK3//.{Graphics->Graphics3D,
		{u_?NumberQ,v_?NumberQ}:>{u,a,v}};
	PIK3 = FixOptions[PIK3];
	Return[PIK3]
		]


StikPikYZ[picture_,a_:0] := Module[{PIK3 = picture},
	PIK3 = PIK3//.{Graphics->Graphics3D,
		{u_?NumberQ,v_?NumberQ}:>{a,u,v}};
	PIK3 = FixOptions[PIK3];
	Return[PIK3]
		]


StikPikXY[picture_,a_:0] := Module[{PIK3 = picture},
	PIK3 = PIK3//.{Graphics->Graphics3D,
		{u_?NumberQ,v_?NumberQ}:>{u,v,a}};
	PIK3 = FixOptions[PIK3];
	Return[PIK3]
		]
		
End[];

EndPackage[];
Null

ThreeAxes[u,v]

ThreeAxes[u_,v_] := 
      Graphics3D[{
            {Blue,Line[{{-u,0,0},{u,0,0}}]},
                    Text["x",{u + v,0,0}],
            {Blue,Line[{{0,-u,0},{0,u,0}}]},
                    Text["y",{0, u + v,0}],
            {Blue,Line[{{0,0,0},{0,0,u}}]},
                    Text["z",{0,0,u + v}]}]; 
ThreeAxes[u_] := ThreeAxes[u,u/8];
ThreeAxes::usage = "ThreeAxes[a,b] makes a standard cartesian axis graphics object
	with x, y, and z running from -a to a, and with axis
	labels b units beyond the tips of the axes.  ThreeAxes[a]
	is ThreeAxes[a,a/8].";

Crisscross

Clear[x];
crisscross = Plot[{Cos[x],Sin[x]},{x,Pi/8,3 Pi/8},
    PlotStyle->{{RGBColor[1,0,0],Thickness[0.02]}},
    Axes->None,AspectRatio->1/3,
    DisplayFunction->Identity];

Pendulum Stuff

modticksX[gr_Graphics,m_] :=
   Module[{f,x},
     f[{a_,"",st___}] := {a,""};
     f[{a_,b_,st___}] := {a,b m};
     Show[gr,
        AxesOrigin->Reverse[FullOptions[gr,AxesOrigin]],
        Ticks->{Map[f,FullOptions[gr,Ticks][[1]]],
                Automatic}]
]

modticksY[gr_Graphics,m_] :=
   Module[{f,x},
     f[{a_,"",st___}] := {a,""};
     f[{a_,b_,st___}] := {a,b m};
     Show[gr,
        AxesOrigin->Reverse[FullOptions[gr,AxesOrigin]],
        Ticks->{Automatic,
                Map[f,FullOptions[gr,Ticks][[2]]]
               }]
]

Clear[center,angle,length,a,l,pendulum,calibratedpendulum];

pendulum[length_,angle_]:=
Module[
{center:={length Sin[Pi-angle],length Cos[Pi-angle]}},

Show[

Graphics[{Blue,Thickness[.01],
Line[{{0,0},{0,-(length+3)}}]}],

Graphics[{Blue,
Polygon[{{-5,-(length+3)},{-5,-(length+3.5)},{-5.3,-(length+3.5)},
{-5.3,-(length+4)},{5.3,-(length+4)},{5.3,-(length+3.5)},
{5,-(length+3.5)},{5,-(length+3)},{-5,-(length+3)}}]}],

Graphics[{Black,
Disk[{0,0},length,{(-Pi/2+angle-Pi/84),(-Pi/2+angle+Pi/84)}]}],

Graphics[{Black,
Disk[center,length,{(Pi/2+angle-Pi/500),(Pi/2+angle+Pi/500)}]}],

Graphics[{Red,PointSize[.05],Point[{0,0}]}],

Graphics[{Red,
Disk[center,length/5,{0,360 Degree}]}],

Graphics[{GoldenrodLight,
Disk[center,length/6,{330 Degree,350 Degree}]}],

Graphics[{Red,
Disk[center,length/7,{0,360 Degree}]}],

Graphics[{Black,PointSize[.02],Point[center]}],


AspectRatio->Automatic,
PlotRange->{{length+5,-(length+3)},{(length+4),-(length+4)}},
AxesOrigin->{0,0},
DisplayFunction->Identity]
]

calibratedpendulum[length_,angle_]:=
Module[
{center:={length Sin[Pi-angle],length Cos[Pi-angle]}},

Show[

Graphics[{Blue,Thickness[.01],
Line[{{0,0},{0,-(length+3)}}]}],

Graphics[{Blue,
Polygon[{{-5,-(length+3)},{-5,-(length+3.5)},{-5.3,-(length+3.5)},
{-5.3,-(length+4)},{5.3,-(length+4)},{5.3,-(length+3.5)},
{5,-(length+3.5)},{5,-(length+3)},{-5,-(length+3)}}]}],

Graphics[{Black,
Disk[{0,0},length,{(-Pi/2+angle-Pi/84),(-Pi/2+angle+Pi/84)}]}],

Graphics[{Black,
Disk[center,length,{(Pi/2+angle-Pi/500),(Pi/2+angle+Pi/500)}]}],

Graphics[{Red,PointSize[.05],Point[{0,0}]}],

Graphics[{Red,
Disk[center,length/5,{0,360 Degree}]}],

Graphics[{GoldenrodLight,
Disk[center,length/6,{330 Degree,350 Degree}]}],

Graphics[{Red,
Disk[center,length/7,{0,360 Degree}]}],

Graphics[{Black,PointSize[.02],Point[center]}],

Graphics[Text[StringForm["y[t] =  ``",angle],
{8 length/8 Sin[15 Pi/12], 8 length/8 Cos[5Pi/6]}]],

AspectRatio->Automatic,
PlotRange->{{length+5,-(length+3)},{(length+4),-(length+4)}},
AxesOrigin->{0,0},DisplayFunction->Identity]
]

T.1) Different starter temperatures on the left and right: The general case of the heat equation

T.1.a.i)

Start with a heated wire L units long with the temperature allowed to vary from position to position on the wire. Think of the wire as the interval 0 ≤ x ≤ L.  At the start of the experiment,  you apply apparatus that maintains the temperatures at the end points of then wire. At the start of this particular experiment, the temperature of the wire at position x (for  0 ≤ x ≤ L= 3) is given by the following function startertemp[t]:

L = 3; \(Clear[startertemp, x]; 

    startertemp[x_] = 3\ Abs[0.25\ x - Round[0.25\ x]] + 1; 

    \(starterplot = 
      Plot[startertemp[x], {x, 0, L}, 
        PlotStyle -> {{Thickness[0.01], Blue}}, 
        PlotRange -> {0, 3}, 
        AxesLabel -> {"x", "starting temperature"}]; \)\)

To fully understand this plot, look at this:

\(Clear[pointer]; 

    pointer[x_] := Arrow[{0, startertemp[x]}, Tail -> {x, 0}]; 

    \(Show[starterplot, pointer[1.2]]; \)\)

Think of the interval [0,L] = [0, 3] as the wire.  
The tip of the pointer tells you the starting temperature (at time t = 0) at the tail of the pointer.
Your problem here is to come up with the function temp[x,t] that estimates the  temperature of the wire at position x at time t after the experiment begins.  This means that you are looking for a function temp[x,t] satisfying the heat equation
             \(∂\_{x, 2}temp[x, t] = ∂\_t temp[x, t]\) 
with 
->  temp[x, 0] a good approximation of startertemp[x] and
->  temp[0, t] = startertemp[0] and temp[L ,t] = startertemp[L] for all t's.
Do it.
Make a movie.

The function startertemp[x] is NOT ripe for a rigged Fourier Sine fit on [0,L] because 
              startertemp[0]≠ 0 and startertemp[L] ≠  0 .

{startertemp[0], startertemp[L]}

To see how to get around this little obstacle, look at the plot of startertemp[x]:

Show[starterplot];

Run a line through the endpoints of the plot.

\(Clear[line]; 

    line[x_] = 
      \(\((startertemp[L] - startertemp[0])\)\ x\)\/L + startertemp[0]\)

Take a look:

Plot[{startertemp[x], line[x]}, {x, 0, L}, 
      PlotStyle -> {{Thickness[0.01], Blue}, {Thickness[0.01], Red}}, 
      PlotRange -> {0, 3}, 
      AxesLabel -> {"x", "starting temperature"}];

Put 
      adjustedstartertemp[x] = startertemp[x] - line[x]
and plot:

\(Clear[adjustedstartertemp]; 

    adjustedstartertemp[x_] = startertemp[x] - line[x]; 

    \(Plot[adjustedstartertemp[x], {x, 0, L}, 
      PlotStyle -> {{Thickness[0.01], Blue}}, 
      AxesLabel -> {"x", "starting temperature"}]; \)\)

The function adjustedstartertemp[x] IS ripe for a rigged Fourier Sine fit on [0,L] because 
              adjustedstartertemp[0] = 0 and adjustedstartertemp[L] = 0.

{adjustedstartertemp[0], adjustedstartertemp[L]}

Rig adjustedstartertemp[x] for a pure sine fit on [0,L] and get a good sine fit of adjustedstartertemp[x] on [0,L]:

\(Clear[rigged]; 

    rigged[x_] := adjustedstartertemp[x] /; 0 ≤ x ≤ L; 
    
\(rigged[x_] := 
      \(-adjustedstartertemp[2\ L - x]\) /; L < x ≤ 2\ L; \)\)n = 10; \(Clear[riggedsinefit]; 

    riggedsinefit[x_] = 
      Chop[ComplexExpand[FastFourierfit[rigged, 2\ L, n, x]]]\)

fitplot = 
      Plot[{adjustedstartertemp[x], riggedsinefit[x]}, {x, 0, L}, 
        PlotStyle -> {{Thickness[0.02], Blue}, {Thickness[0.008], Red}}, 
        AxesLabel -> {"x", ""}];

That's a decent fit.
Now look at the rigged sine fit of startertep[x]:

riggedsinefit[x]

Pick off the coefficients of the Sin[(k Pi/L) x] terms:

\(Clear[A, k]; 

    A[k_] := Coefficient[riggedsinefit[x], Sin[\(\((k\ π)\)\ x\)\/L]]; 

    coeffs = Table[A[k], {k, 1, n}]\)

Now you're done because you can write down temp[x,t]:

Clear[temp, x, t];
temp[x_, t_]=line[x]+(∑_(k = 1)^n) A[k] 
              (E^(-(((((k π)/L)))^2) t)) 
              Sin[(((k π) x)/L)]

Notice the line term at the beginning.
Here comes a movie showing the approximate temperature along with the line function.

\(Clear[tempplotter]; 

    tempplotter[t_] := 
      Plot[{temp[x, t], line[x]}, {x, 0, L}, 
        PlotStyle -> {{Thickness[0.01], Blue}, {Thickness[0.01], Red}}, 
        PlotRange -> {0, 3}, 
        AxesLabel -> {"x", " temperature"}, 
        PlotLabel -> N[t]\ "= t"]; 
\(timejump = 1; \)\)Table[tempplotter[t], {t, 0, 6, timejump}]

You are seeing the wire settle into its steady state temparature which at point x with 0 ≤ x  ≤ L is given by:

line[x]

T.1.a.ii)

How does the heat equation explain why the little stunt with the line works?

Engineering studies have shown that after the appropriate unit adjustments are made, the function temp[x,t] satisfies the heat equation
        \(∂\_{x, 2}temp[x, t] = ∂\_t temp[x, t]\)
with 
->  temp[x, 0] = startertemp[x] and
-> temp[0, t] = startertemp[0] and temp[L, t] = startertemp[L] for all t's.

Check out the heat equation D[temp[x,t], {x,2}] = D[temp[x,t], t]:

To do this, look at:

temp[x, t]

Note the Sine terms. In the Basics, it was seen that the Sine terms were specially selected to solve the heat equation. So checking that temp[x,t] satisies the heat equation reduces to checking that the first two terms of temp[x,t] solve the heat equation.  The first two terms are:

line[x]

Check whether line[x] solves the heat equation
           \(∂\_{x, 2}line[x] = ∂\_t line[x]\):

\({∂\_{x, 2}line[x], ∂\_t line[x]}\)

This tells you that 
      \(∂\_{x, 2}line[x] = ∂\_t line[x]\). 
and explains why temp[x,t] solves the heat equation.

Check out temp[0,0] = startertemp[0] and temp[L,0] = startertemp[L]

{startertemp[0], temp[0, 0]}

{startertemp[L], temp[L, 0]}

Perfecto.

Check out temp[x,0]  ≈ startertemp[x]

Plot[{startertemp[x], temp[x, 0]}, {x, 0, L}, 
      PlotStyle -> {{Thickness[0.015], Blue}, {Thickness[0.008], Red}}, 
      AxesLabel -> {"x", ""}];

Good enough. The slight discrepanies indicate that temp[x,t] does not solve the original problem but does solve a problem virtually indistinguishable from the original problem.

T.1.a.iii)

That idea of running a line connecting 
         {0, startertemp[0]} to {L, startertemp[L]} 
looks like a really cheap trick. 
Could you have run another curve through those points and gotten good results?

If you make the adjustment with any other function f[x] with 
f[0] = startertemp[0] and f[L] = startertemp[L], the issue is whether the heat equation is solved. This boils down to checking

Check whether f[x] solves the heat equation
     \(∂\_{x, 2}f[x] = ∂\_t f[x]\):

\(Clear[f]; 
{∂\_{x, 2}f[x], ∂\_t f[x]}\)

This tells you that to solve the heat equation you need
f''[x] = 0.  This forces you to go with a line:

DSolve[f''[x]==0,f[x],x]

Not only was the line a cheap trick, it was the only possible adjustment that could have been made.

T.2) When the starter conditions are given by a data list

Activate this code:

\(Clear[FastFourierfit, Fourierfitters, F, Fvalues, n, k, jump, num, 
      numtab, coeffs, t, L]; 
jump[n_] := \(jump[n] = N[1\/\(2\ n\)]\); 
    Fvalues[F_, L_, n_] := N[Table[F[L\ t], {t, 0, 1 - jump[n], jump[n]}]]; 
    numtab[n_] := \(numtab[n] = Table[k, {k, 1, n}]\); 
    Fourierfitters[L_, n_, t_] := 
      Table[E\^\(\(2\ π\ I\ k\ t\)\/L\), {k, \(-n\) + 1, n - 1}]; 
    coeffs[n_, list_] := 
      Join[Reverse[
            \(Fourier[list]\)[[numtab[n]
                ]]], 
          \(InverseFourier[list]\)[[Drop[numtab[n], 1]
              ]]]/N[\@Length[list]]\)\(FastFourierfit[F_, L_, n_, t_] := 
      Chop[Fourierfitters[L, n, t] . coeffs[n, Fvalues[F, L, n]]]; 
    L := Expand[a\ ∂\_{#2, 2}#1 + b\ ∂\_#2 #1 + c\ #1]&
        \)

T.2.a) Heat equation

Start with a heated wire L units long with the temperature allowed to vary from position to position on the wire. Think of the wire as the interval 0 ≤ x ≤ L.  At the start of the experiment,  you instantly cool the ends at x = 0 and x = L  and maintain these ends at temperature 0, and you take pains to guarantee that the rest of the wire is perfectly insulated.
At the start of this partricular experiment, the temperature of the wire at position x (for 0 ≤ x ≤ L = 4) is given by the following startertemp data:

startertempdata = {{0.0, 0.0}, {0.2, 0.25}, {0.4, 0.35}, {0.6, 
          0.48}, {0.8, 0.69}, {1.0, 0.75}, {1.2, 0.97}, {1.4, 1.08}, {1.6, 
          1.23}, {1.8, 1.44}, {2.0, 1.5}, {2.2, 1.44}, {2.4, 1.21}, {2.6, 
          1.07}, {2.8, 0.99}, {3. , 0.75}, {3.2, 0.70}, {3.4, 0.49}, {3.6, 
          0.32}, {3.8, 0.24}, {4. , 0.0}}; starterdataplot = 
      ListPlot[startertempdata, PlotStyle -> {PointSize[0.03], Red}, 
        AspectRatio -> (1/2), 
        AxesLabel -> {"x", "startertemp[x]"}];

Your problem here is to come up with a function temp[x,t] that estimates the  temperature of the wire at position x at time t after the experiment begins. 
Do it.
Throw in a good movie.

Take another look at the data:

Show[starterdataplot];

Now put an interpolating function through these data:

\(Clear[startertemp]; 

    startertemp[t_] = \(Interpolation[startertempdata]\)[t]\)

Take a look:

L = 4; starterplot = 
      Plot[startertemp[x], {x, 0, L}, 
        PlotStyle -> {{Thickness[0.01], Blue}}, 
        AxesLabel -> {"x", "starting temperature"}];

Check this plot against the data:

both = Show[starterplot, starterdataplot];

To fully understand the curve plot, look at this:

\(Clear[pointer]; 

    pointer[x_] := 
      Arrow[{0, startertemp[x]}, Tail -> {x, 0}, 
        VectorColor -> Black]; 
\(Show[both, pointer[1.7]]; \)\)

Think of the interval [0,L] = [0,4] as the wire.  
The tip of the pointer tells you the starting temperature (at time t = 0) at the tail of the pointer.
The function startertemp[x] is ripe for a rigged Fourier Sine fit on [0,L] because startertemp[x] = 0 for x = 0 and x = L:

{startertemp[0], startertemp[L]}

Rig startertemp[x] for a pure sine fit on [0,L] and get a good sine fit of startertemp[t] on [0,L]:

\(Clear[rigged]; 

    rigged[x_] := startertemp[x] /; 0 ≤ x ≤ L; 

    \(rigged[x_] := \(-startertemp[2\ L - x]\) /; L < x ≤ 2\ L; 
    \)\)n = 4; \(Clear[riggedsinefit]; 

    riggedsinefit[x_] = 
      Chop[ComplexExpand[FastFourierfit[rigged, 2\ L, n, x]]]\)

fitplot = 
      Plot[{startertemp[x], riggedsinefit[x]}, {x, 0, L}, 
        PlotStyle -> {{Thickness[0.02], Blue}, {Thickness[0.008], Red}}, 
        AxesLabel -> {"x", ""}];

That's not a great fit.  Go for a better fit by increasing n:

\(Clear[rigged]; 

    rigged[x_] := startertemp[x] /; 0 ≤ x ≤ L; 

    \(rigged[x_] := \(-startertemp[2\ L - x]\) /; L < x ≤ 2\ L; 
    \)\)n = 20; \(Clear[riggedsinefit]; 

    riggedsinefit[x_] = 
      Chop[ComplexExpand[FastFourierfit[rigged, 2\ L, n, x]]]\)

fitplot = 
      Plot[{startertemp[x], riggedsinefit[x]}, {x, 0, L}, 
        PlotStyle -> {{Thickness[0.02], Blue}, {Thickness[0.008], Red}}, 
        AxesLabel -> {"x", ""}];

That's better.
Now look at the rigged sine fit of startertep[x]:

riggedsinefit[x]

Pick off the coefficients of the Sin[(k Pi/L) x] terms:

\(Clear[A, k]; 

    A[k_] := Coefficient[riggedsinefit[x], Sin[\(\((k\ π)\)\ x\)\/L]]; 

    coeffs = Table[A[k], {k, 1, n}]\)

Now you're done because you can write down temp[x,t]:

\(Clear[temp, x, t]; 

    temp[x_, t_] = 
      ∑\+\(k = 1\)\%n A[k]\ E\^\(\(-\((\(k\ π\)\/L)\)\^2\)\ t\)\ 
          Sin[\(\((k\ π)\)\ x\)\/L]\)

Here comes a movie:

\(Clear[tempplotter]; 

    tempplotter[t_] := 
      Plot[temp[x, t], {x, 0, L}, 
        PlotStyle -> {{Thickness[0.01], Blue}}, 
        PlotRange -> {0, 1.5}, 
        AxesLabel -> {"x", " temperature"}, 
        PlotLabel -> N[t]\ "= t", AspectRatio -> 1\/2]; 

    \(timejump = 1; \)\)Table[tempplotter[t], {t, 0, 6, timejump}]

Those exponentials are cooling this wire fast.

T.2.b) Wave equation

Activate this code:

\(Clear[FastFourierfit, Fourierfitters, F, Fvalues, n, k, jump, num, 
      numtab, coeffs, t, L]; 
jump[n_] := \(jump[n] = N[1\/\(2\ n\)]\); 
    Fvalues[F_, L_, n_] := N[Table[F[L\ t], {t, 0, 1 - jump[n], jump[n]}]]; 
    numtab[n_] := \(numtab[n] = Table[k, {k, 1, n}]\); 
    Fourierfitters[L_, n_, t_] := 
      Table[E\^\(\(2\ π\ I\ k\ t\)\/L\), {k, \(-n\) + 1, n - 1}]; 
    coeffs[n_, list_] := 
      Join[Reverse[
            \(Fourier[list]\)[[numtab[n]
                ]]], 
          \(InverseFourier[list]\)[[Drop[numtab[n], 1]
              ]]]/N[\@Length[list]]\)\(FastFourierfit[F_, L_, n_, t_] := 
      Chop[Fourierfitters[L, n, t] . coeffs[n, Fvalues[F, L, n]]]; 
    L := Expand[a\ ∂\_{#2, 2}#1 + b\ ∂\_#2 #1 + c\ #1]&
        \)

The ends of a guitar string are anchored at 0 and L on the x-axis and the string is pulled to an initial position and then allowed to vibrate on its own starting with initial velocity 0.

At the start of this partricular experiment, the position of the wire at position x (for 0 ≤ x ≤ L = 4) is given by the following starterposition data:

starterpositiondata = {{0.0, 0.0}, {0.2, 0.25}, {0.4, 0.35}, {0.6, 
          0.48}, {0.8, 0.69}, {1.0, 0.75}, {1.2, 0.97}, {1.4, 1.08}, {1.6, 
          1.23}, {1.8, 1.44}, {2.0, 1.5}, {2.2, 1.44}, {2.4, 1.21}, {2.6, 
          1.07}, {2.8, 0.99}, {3. , 0.75}, {3.2, 0.70}, {3.4, 0.49}, {3.6, 
          0.32}, {3.8, 0.24}, {4. , 0.0}}; starterdataplot = 
      ListPlot[starterpositiondata, PlotStyle -> {PointSize[0.03], Red}, 
        AspectRatio -> (1/2), 
        AxesLabel -> {"x", "starterposition[x]"}];

Your problem here is to come up with a function position[x,t] that estimates the position of the guitar string at position x on the x-axis at time t after the experiment begins.
Do it.
Throw in a good movie.

Take another look at the data:

Show[starterdataplot];

Now put an interpolating function through these data:

\(Clear[starterposition]; 

    starterposition[t_] = \(Interpolation[starterpositiondata]\)[t]\)

Take a look:

L = 4; starterplot = 
      Plot[starterposition[x], {x, 0, L}, 
        PlotStyle -> {{Thickness[0.01], Blue}}, 
        AxesLabel -> {"x", "starting position"}];

Check this plot against the data:

both = Show[starterplot, starterdataplot];

To fully understand the curve plot, look at this:

\(Clear[pointer]; 

    pointer[x_] := 
      Arrow[{0, startertemp[x]}, Tail -> {x, 0}, 
        VectorColor -> Black]; 
\(Show[both, pointer[2.85]]; \)\)

The function starterposition[x] is ripe for a rigged Fourier Sine fit on [0,L] because starterposition[x] = 0 for x = 0 and x = L:

{starterposition[0], starterposition[L]}

Rig starterposition[x] for a pure sine fit on [0,L] and get a good sine fit of starterposition[t] on [0,L]:

\(Clear[rigged]; 

    rigged[x_] := starterposition[x] /; 0 ≤ x ≤ L; 

    \(rigged[x_] := 
      \(-starterposition[2\ L - x]\) /; L < x ≤ 2\ L; \)\)\(Clear[riggedsinefit]; 
n = 18; 

    riggedsinefit[x_] = 
      Chop[ComplexExpand[FastFourierfit[rigged, 2\ L, n, x]]]\)

fitplot = 
      Plot[{starterposition[x], riggedsinefit[x]}, {x, 0, L}, 
        PlotStyle -> {{Thickness[0.02], Blue}, {Thickness[0.008], Red}}, 
        AxesLabel -> {"x", ""}];

That's a pretty good fit.
Now look at the rigged sine fit of starterposition[x]:

riggedsinefit[x]

Pick off the coefficients of the Sin[(((k π) x)/L)] terms:

L

\(Clear[A, k]; 

    A[k_] := Coefficient[riggedsinefit[x], Sin[\(\((k\ π)\)\ x\)\/L]]; 

    coeffs = Table[A[k], {k, 1, n}]\)

Now you're done because you can write down position[x,t]:

\(Clear[position, x, t]; 

    position[x_, t_] = 
      ∑\+\(k = 1\)\%\(Length[coeffs]\)A[k]\ 
          Cos[\(\((k\ π)\)\ t\)\/L]\ Sin[\(\((k\ π)\)\ x\)\/L]\)

That's all there is to it.
Here comes the movie:

\(Clear[positionplotter]; 

    positionplotter[t_] := 
      Plot[position[x, t], {x, 0, L}, 
        PlotStyle -> {{Thickness[0.01], Blue}}, 
        PlotRange -> {\(-1.5\), 1.5}, 
        AxesLabel -> {"x", " position"}, 
        PlotLabel -> N[t]\ "= t", AspectRatio -> 1\/2]; 

    \(timejump = L\/3; \)\)Table[positionplotter[t], {t, 0, 2 L, timejump}]

The Cosines in the formula for position[x,t]  are responsible for the periodic motion (waves) of the string:

position[x, t]