(* written by Oliver Knill, September 13, 2008                *)
(* Mathematica Code which produces the animation on this page *) 
(* Demonstration in the intro meeting of September 16, 2008   *)

(* reading in the data from a seperate file                      *)
<<data.txt

(* tools to massage the data, like strip the year from each row  *)

T[A_]:=Flatten[Table[A[[i,j]],{i,Length[A]},{j,2,Length[A[[i]]]}]];
Diff[A_]:=Prepend[Table[A[[k+1]]-A[[k]],{k,Length[A]-1}],0]
Smooth[A_]:=Table[If[k==1,A[[1]],If[k==Length[A],Last[A],(A[[k+1]]+A[[k-1]]+2 A[[k]])/4]],{k,Length[A]}]

(* produce the graph similar to     *)
(* http://www.nytimes.com/2008/09/13/business/economy/13charts.html  *)

A1=Inflation; A2=Unemployment; B1=T[A1]; B2=T[A2]; 
C1=B1; C2=Delete[B2,Length[B2]]; C3=C1+C2;
D1=Smooth[C1]; D2=Smooth[C2]; D3=Smooth[C3];
year[x_]:=Floor[1949+(x-1)/12]; inverseyear[y_]:=Floor[(y-1948)*12]; 
xticks=Table[{48k,year[48k]},{k,0,Floor[Length[C1]/48]}]; yticks={5,10,15,20,25};
S=ListPlot[{D1,D2,D3}, AspectRatio->1, PlotStyle->{{Thickness[0.003],RGBColor[1,0,0]},
    {Thickness[0.003],RGBColor[0,1,0]}, {Thickness[0.005],RGBColor[1,1,0]}}, Background->RGBColor[0,0,0],
    TextStyle->RGBColor[1,1,1],Joined->True,Frame->True,Axes->False,FrameTicks->{xticks,yticks}]
Export["nyt.png",S,"PNG",ImageSize->1000]

(* now we go into the plane *)

C1=Smooth[Smooth[D1]]; C2=Smooth[Smooth[D2]];
a=Min[C1]; b=Max[C1]; c=Min[C2]; d=Max[D2]; 
SS[t1_,t2_,red_,green_,blue_,thick_,pointsize_]:=Show[Graphics[
    {{RGBColor[red,green,blue], Thickness[thick],Line[Table[{C1[[k]],C2[[k]]},
       {k,1+Floor[t1 Length[C1]],Floor[t2 Length[C1]]}]]},
    {RGBColor[1,0,0],PointSize[0.03*pointsize],Point[{C1[[Floor[t2 Length[C1]]]],C2[[Floor[t2 Length[C1]]]]}]}}
    ],
    PlotRange->{{a-0.1,b+0.1},{c-0.1,d+0.1}},DisplayFunction->Identity, 
    TextStyle->RGBColor[1,1,1],Background->RGBColor[0,0,0], AspectRatio->1]
S=SS[0,1,1,1,0,0.005,0.01]; Export["2dnyt.png",S,"PNG",ImageSize->1000]

(* now we start the animation. Most of this is eye candy like that the tail of the path disappears in time  *)

SetOptions[Graphics,BaseStyle->{FontFamily->"Times",FontSize->36}]; 
presidents={ {"George W. Bush",2001,2008}, {"Bill Clinton",1993,2001}, {"George H. Bush",1989,1993},
  {"Jimmy Carter",1977,1981}, {"Gerald Ford",1974,1977}, {"Richard Nixon",1969,1974}, {"Lyndon Johnson",1963,1969},
  {"John F. Kennedy",1961,1963}, {"Dwight Eisenhower",1953,1961}, {"Harry Truman",1945,1953}, {"Franklin D. Roosevelt",1933,1945}}; 
findpresident[year_]:=Module[{},j=1;While[presidents[[j,2]]>year,j++];presidents[[j,1]]]


M=500; G[n_]:=Block[{u,v,w}, u=IntegerDigits[n]+48; v=ToCharacterCode["F"];
  w=ToCharacterCode[".png"]; FromCharacterCode[Join[v,u,w]]];
UU[ll_,kk_]:=Show[SS[ll/M,(ll+2)/M,ll^2/kk^2,ll^2/kk^2,0.2,(0.001+0.013*ll/kk),If[ll==k-1,1,0]],DisplayFunction->Identity]; 
VV[kk_]:=Show[Graphics[Text[findpresident[year[kk+1]],{(a+b)/2,(c+d)/2}]], PlotRange->{{a-0.1,b+0.1},{c-0.1,d+0.1}},
   Background->RGBColor[0,0,0],TextStyle->{RGBColor[1,1,1]},DisplayFunction->Identity];

Do[Export[G[1000+k],Show[Prepend[Table[UU[l,k],{l,1,k-1}],VV[k*Length[C1]/M]], AspectRatio->1,
  PlotRange->{{a-0.1,b+0.1},{c-0.1,d+0.1}},
  DisplayFunction->Identity,TextStyle->RGBColor[1,1,1]],"PNG",ImageSize->500],{k,1,M-1}];