To use this, please ensure Dynamic Content is enabled, then click on the “Click here to begin button,” then scroll up. Browse for your images (256x256 recommended), and where you would like to save the output movie. The images MUST be the same dimensions!!! If you would like to keep the default cars/car vectors, you must still browse for a save directory (but not for image A and B). Now specify the framerate, length, and buffer time. Buffer time is the amount of time that unmorphed versions of Image A and Image B appear on screen before and after the morph Then you MUST click “Apply Changes”, due to limitations in the Show[] functions. This will reevaluate the cells.

If you’re using the default, you can just click the Run button now. If not, click on image A to add your first point P, then click again to add Q. Then on image B, do the same to add P’ and Q’ on the corresponding features. Click and drag on any of the existing points to realign them. Continue until you have outlined all corresponding features that you would like to specify as anchors for the morph, like this:



I advise you to use picture-in-picture magnification (Press Windows and the Plus key, click views, and select lens. On Mac, navigate to System Preferences>Accessibility>Zoom, and click “use keyboard shortcuts to zoom.”
 Also change zoom style to Picture-in-picture.
 
Make sure that the numbers between images correspond, and ensure you are drawing the vectors in the same direction on both images. You can use Alt+Click (or command + click) to delete a point, but you MUST delete them in exactly the reverse order that you made them or else it will mess everything up. I recommend clicking Save Points every few minutes. If you ever screwed up, click import Points. Keep in mind that more vectors = more computing time

Now click Run to launch it, and you should see a box appear with “Launching Kernels”. When the progress bar fills, the computation is complete. Typically a 256x256 image with ~30ish vectors will take 2.5-4 hours to render. A 512x512 image, while we never finished the render, was projected to take 36 hours. If you get any errors, you can manually type: “run[]” and evaluate the cell.

To abort the calculation, you MUST click “Emergency Stop”, quitting Mathematica will not work, as explained below.

Unfortunately, Mathematica can’t properly parallelize in virtual cores. I have 2 physical and 4 virtual cores, and Mathematica will open 2 kernels rather than 4 and use 50% of CPU. Therefore, I forced Mathematica to use as many local kernels you set manually under Evaluation > Parallel Kernel Configuration (should be equal to however many cores you have). This implementation also means that in order to abort the computation, the user must quit the kernels (quitting Mathematica doesn’t work), which also loses all variables, resetting everything. I have coded the button to dump the A and B vectors into a file, but the user must still reload the images.

Button["Click here to begin",ClearAll[ptsa,ptsb]; 
FrontEndExecute@FrontEndToken["EvaluateInitialization"];, Method->"Queued"]

(*load the initial and final images. If the user hasn't uploaded one, use default*)
one = If[ValueQ@onepath==True,Import@onepath,Image[,ImageSize->{256,256}]];
two = If[ValueQ@twopath==True,Import@twopath,Image[,ImageSize->{256,256}]];

(*Load the initial and final vectors. If the user hasn't specified them yet, use default*)
ptsa=If[ValueQ[ptsa]==True,ptsa,{{0.,11.6},{69.2,35.6},{72.2,42.},{84.2,63.6},{83.7,70.},{65.2,122.},{65.7,129.},{69.2,182.},{71.2,191.},{85.2,216.6},{87.7,217.6},{102.7,224.6},{107.7,226.},{129.7,230.},{135.2,229.6},{157.7,223.6},{163.7,219.6},{176.2,213.},{178.2,210.},{186.2,191.6},{187.7,187.},{189.2,131.6},{189.2,124.},{172.2,71.},{171.7,63.6},{180.7,35.6},{185.7,32.6},{256.,2.6},{126.2,129.6},{127.2,95.6},{94.2,135.},{109.7,129.},{140.7,128.6},{159.2,138.},{107.7,126.},{86.2,126.},{144.2,125.6},{164.2,126.},{0.,0.},{256.,0.},{0.,9.6},{0.,0.},{256.,3.},{256.,0.},{88.2,60.},{104.2,37.},{110.7,34.6},{138.7,32.6},{144.2,36.6},{167.7,61.6},{87.2,142.6},{113.2,136.},{168.7,150.},{140.7,137.},{96.2,65.},{94.7,90.},{156.7,69.},{158.2,87.},{86.2,177.},{86.2,148.6},{169.2,176.},{169.7,155.6}}];
ptsb=If[ValueQ[ptsb]==True,ptsb,{{0.,45.6},{46.7,66.},{51.7,68.6},{69.2,78.6},{71.2,87.},{68.7,128.},{68.2,134.},{68.7,185.},{69.7,192.},{77.7,240.6},{81.7,239.6},{91.2,220.6},{95.7,221.},{126.7,227.},{132.7,226.},{163.7,223.},{166.7,224.},{175.2,241.6},{177.7,240.6},{185.7,194.},{186.2,185.},{187.7,137.6},{187.2,127.},{184.7,85.},{186.7,77.},{204.2,68.6},{209.7,65.6},{256.,46.},{129.2,133.},{129.7,92.},{98.7,133.},{115.2,130.},{140.2,132.},{156.2,134.6},{113.2,126.},{93.7,126.},{143.2,127.},{168.2,126.},{0.,0.},{256.,0.},{0.,42.},{0.,0.},{256.,46.},{256.,0.},{74.7,74.6},{108.7,47.},{116.2,45.},{142.2,44.},{148.7,46.6},{181.2,74.},{81.2,152.6},{115.2,144.},{173.7,153.6},{135.2,142.6},{96.2,70.},{86.2,96.6},{163.2,75.6},{170.2,99.},{80.7,185.6},{81.2,157.6},{171.7,186.6},{172.7,160.6}}];

(*Define a function to display the interactive vector drawing UI. User input turns onto one list of points for image A and one list for image B. Vectors are drawn between subsequent points, ie {P,Q,P,Q,P,Q}*)
SetAttributes[ui,HoldFirst](*ensure "pts" in ui[pts,img] is not evaluated before insertion*)
ui[pts_,img_]:=
Column[{Button["Reset points",pts={}],
LocatorPane[Dynamic[pts],
Dynamic[
Show[img,
Graphics[{Orange,
Table[(*draw arrows between locators*)
Arrow[{
pts[[i]],pts[[i+1]]
}],
{i,1,Floor[Length[pts],2],2}
],
Table[
Text[(i+1)/2,((pts[[i+1]]+pts[[i]])/2)+((Cross[pts[[i+1]]-pts[[i]]])/(EuclideanDistance[pts[[i+1]],pts[[i]]]))*10],(*display line # 5 pixels orthogonal to line midpoint*)
{i,1,Floor[Length[pts],2],2}
]
}]
]
],
LocatorAutoCreate->All,Appearance->Style["·",Medium,Red]]}]
(*define functions that parse {P,Q,P,Q,P,Q} from above into {P,P,P} and {Q,Q,Q}*)
showp[pts_]:=Drop[pts,{2,Length[pts],2}]
showq[pts_]:=Drop[pts,{1,Length[pts],2}]

(*Show the UI*)
Column[{
Column[{
Text["Browse for image A:"],
FileNameSetter[
Dynamic[onepath],
"Open",
{"Images"->{"*.jpg","*.jpeg"},"All files"->{"*"}}
],
Dynamic@Text[onepath],

Text["Browse for image B:"],
FileNameSetter[
Dynamic[twopath],
"Open",
{"Images"->{"*.jpg","*.jpeg"},"All files"->{"*"}}
],
Dynamic@Text[twopath],

Text["Where do you want to save this file? Must specify!"],
FileNameSetter[
Dynamic[savepath],
"Save",
{"AVI"->{"*.avi"}}
],
Dynamic@Text[savepath],

Text["Framerate of Movie:"],
(*if user hasn't defined fps, use default*)
fps=If[ValueQ[fps]==False,15,fps];
InputField[Dynamic[fps]],

Text["Length of Movie (seconds):"],
(*if user hasn't defined length, use default*)
lng=If[ValueQ[lng]==False,3,lng];
InputField[Dynamic[lng]],

Text["Buffer (seconds):"],
(*if user hasn't defined buffer, use default*)
buf=If[ValueQ[buf]==False,.5,buf];
InputField[Dynamic[buf]],

Button["APPLY CHANGES",
(*Evaluate this first cell again*)
FrontEndExecute[FrontEndToken["EvaluateInitialization"]]
]
}],

Column[{
(*show a vector input for image a and image b*)
Row[{ui[ptsa,one],ui[ptsb,two]}],
Button[
"Save Points to Documents Folder",
Export["ptsa.mx",ptsa,"MX"];
Export["ptsb.mx",ptsb,"MX"];
],
Button[
"Import Points from Documents Folder",
ptsa=Import["ptsa.mx"];
ptsb=Import["ptsb.mx"];
],
Button["Run",run[],Method->"Queued"],
Button["Emergency Stop, will quit kernel and save points",
Quit[];
Export["ptsa.mx",ptsa,"MX"];
Export["ptsb.mx",ptsb,"MX"];]
}],
(*Show an indicator of calculation progress*)
ProgressIndicator[Dynamic[proga+progb+progfin],{0,2.2}],
Dynamic@Text@StringJoin["P = ",ToString@showp[ptsa]],
Dynamic@Text@StringJoin["Q = ",ToString@showq[ptsa]],
Dynamic@Text@StringJoin["P' = ",ToString@showp[ptsb]],
Dynamic@Text@StringJoin["Q' = ",ToString@showq[ptsb]]
}]

(*Parameterize midpoint, length, and angle of each vector and rebuild points P and Q at time t. Output is {P,Q}*)
Parameterize[s_,Ps_,Qs_,Pd_,Qd_]:=(
SetAttributes[Tableify,HoldFirst];
Tableify[expression_]:=Table[expression,{i,1,Length[Ps]}];
mids=(Ps+Qs)/2;
midd=(Pd+Qd)/2;
parmid[t_]:=mids+t*(midd-mids);
ds=Tableify@EuclideanDistance[Ps[[i]],Qs[[i]]];
dd=Tableify@EuclideanDistance[Pd[[i]],Qd[[i]]];
pardist[t_]:=ds+t*(dd-ds);
(*the if statement determines if the angle is positive or negative*)
angles=Tableify@N@If[
Qs[[i,2]]>Ps[[i,2]],
VectorAngle[Qs[[i]]-Ps[[i]],{1,0}] ,
-VectorAngle[Qs[[i]]-Ps[[i]],{1,0}]
];
angled=Tableify@N@If[
Qd[[i,2]]>Pd[[i,2]],
VectorAngle[Qd[[i]]-Pd[[i]],{1,0}] ,
-VectorAngle[Qd[[i]]-Pd[[i]],{1,0}]
];
(*these if statements ensure the parameterization always take the shortest path around the circle. Otherwise, going from 3Pi/4 to -3Pi/4 will go counterclockwise. Not ideal. Shortest path is clockwise*)
parangle[t_]:=(Tableify@
If[Abs@angles[[i]]≤Pi/2&&Abs@angled[[i]]≤Pi/2,
angles[[i]]+t*(angled[[i]]-angles[[i]]),
If[Sign@angles[[i]]==Sign@angled[[i]],
angles[[i]]+t*(angled[[i]]-angles[[i]]),
If[angles[[i]]>angled[[i]],
angles[[i]]+t*((angled[[i]]+2*Pi)-angles[[i]]),
angles[[i]]+2*Pi+t*(angled[[i]]-(angles[[i]]+2*Pi))
]
]
]);
(*reconstruct P and Q, gives {P,Q}*)
{Tableify[parmid[s][[i]]-{pardist[s][[i]]/2*Cos@parangle[s][[i]],pardist[s][[i]]/2*Sin@parangle[s][[i]]}],
Tableify[parmid[s][[i]]+{pardist[s][[i]]/2*Cos@parangle[s][[i]],pardist[s][[i]]/2*Sin@parangle[s][[i]]}]})

(*implementation of Beier-Neely pseudo-code*)
g[pt_,t_,a_,b_,p_,Ps_,Qs_,P_,Q_]:=Module[{DSUM={0,0},weightsum=0,qp,xp,dqp,qps,u,v,new,disp,weight},
For[i=1,i≤Length[Ps],i++,
qp=Q[[i]]-P[[i]];
xp=pt-P[[i]];
dqp=Norm[qp];
qps=Qs[[i]]-Ps[[i]];
u=((Dot[xp,qp])/(dqp^2));
v=((Dot[xp,Cross[qp]])/dqp);
new=Ps[[i]]+u*(qps)+((v*Cross[qps])/(Norm[qps]));
disp=new-pt;
weight=If[0≤u≤1,(((((dqp^p)/(a+Abs@v))))^b),If[u<0,(((((dqp^p)/(a+Norm[xp]))))^b),(((((dqp^p)/(a+EuclideanDistance[Q[[i]],pt]))))^b)]];
DSUM+=(disp*weight);
weightsum+=weight;];
pt+DSUM/weightsum]

(*Define functions to calculate forward and reverse morphed images for image A and B respectively, for some time t*)
ImgA[t_]:=(Module[{P,Q},
P=Parameterize[t,Pptsa,Qptsa,Pptsb,Qptsb][[1]];
Q=Parameterize[t,Pptsa,Qptsa,Pptsb,Qptsb][[2]];
ImageTransformation[one,g[#,t,.001,2.,0,Pptsa,Qptsa,P,Q]&,DataRange->Full,Padding->"Fixed",Masking->Full]])
ImgB[t_]:=(Module[{P,Q},
P=Parameterize[(1-t),Pptsb,Qptsb,Pptsa,Qptsa][[1]];
Q=Parameterize[(1-t),Pptsb,Qptsb,Pptsa,Qptsa][[2]];
ImageTransformation[two,g[#,(1-t),.001,2.,0,Pptsb,Qptsb,P,Q]&,DataRange->Full,Padding->"Fixed",Masking->Full]])

(*define a way to save individual output images. Creates new folder first*)
SetAttributes[ExportImages,HoldFirst];
ExportImages[name_,ImgsA_]:=(
Clear[name];
Imgsdir=CreateDirectory@FileNameJoin[{
FileNameDrop[savepath,-1],
StringJoin[
FileBaseName@savepath,
"_",
ToString@name
]
}];
Table[
Export[
FileNameJoin[{
Imgsdir,
StringJoin[
ToString@name,
"[",
ToString[i],
"].jpg"
]
}],
ImgsA[[i]],"JPEG"
],{i,Length[ImgsA]}];
);

(*Define a function to execute running the calculate*)
run[]:=
(
(*in case user didn't hit apply*)
one = If[ValueQ@onepath==True,Import@onepath,one];
two = If[ValueQ@twopath==True,Import@twopath,two];

(*launch as many kernels as specified in settings*)
Quiet@LaunchKernels[];
(*reset progress bar, make sure all kernels/cores can edit the progress bar*)
proga=0;SetSharedVariable[proga];
progb=0;SetSharedVariable[progb];
progfin=0;

(*create {P,P,P} and {Q,Q,Q} from function way above*)
Pptsa=showp[ptsa];
Qptsa=showq[ptsa];
Pptsb=showp[ptsb];
Qptsb=showq[ptsb];

oneify=1/(fps*lng);

(*calculate all morphed images for fps/length specified*)
ImgsA=
ParallelTable[(
proga +=oneify;
ImgA[t]),
{t,0,1,oneify},
Method->"CoarsestGrained"];

ImgsB=
ParallelTable[(
progb+=oneify;
ImgB[t]),
{t,0,1,oneify},
Method->"CoarsestGrained"];

(*crossfade*)
total=
ParallelTable[
Module[{d1,d2},
d1=ImageData@ImgsA[[i]];
d2=ImageData@ImgsB[[i]];
Image[d1+((i-1)*oneify)*(d2-d1)]
],{i,1,Length[ImgsA]}
];

(*add in buffer regions*)
final=
Join[
Table[total[[1]],{i,1,fps*buf}],
total,
Table[total[[fps*lng]],{i,1,fps*buf}]
];

(*save the final movie, movie of ImgsA, and movies of ImgsB*)
Export[savepath,Flatten@Append[final,Reverse@final],"FrameRate"->fps];
(*save movie of ImgsA*)
toreverseA=Join[
Table[ImgsA[[1]],{i,1,fps*buf}],
ImgsA,
Table[ImgsA[[fps*lng]],{i,1,fps*buf}]
];
Export[
FileNameJoin[{
FileNameDrop[savepath,-1],
StringJoin[
FileBaseName@savepath,
"_",
"ImgsA.avi"
]
}],Flatten@Append[toreverseA,Reverse@toreverseA],"FrameRate"->fps];
(*save movie of ImgsB*)
toreverseB=Join[
Table[ImgsB[[1]],{i,1,fps*buf}],
ImgsB,
Table[ImgsB[[fps*lng]],{i,1,fps*buf}]
];
Export[
FileNameJoin[{
FileNameDrop[savepath,-1],
StringJoin[
FileBaseName@savepath,
"_",
"ImgsB.avi"
]
}],Flatten@Append[toreverseB,Reverse@toreverseB],"FrameRate"->fps];
(*Save the final output as a bunch of files*)
ExportImages[full,total];

(*show progress bar as complete*)
progfin=.2; 
)

(*Ignore this stuff please*)
FrontEndExecute@FrontEndToken["SelectGeneratedCells"];
FrontEndExecute@FrontEndToken["SelectionCloseUnselectedCells"];
FrontEndExecute@FrontEndToken["MovePrevious"];