Pensieve header: Seam carving for the GST-48 knot, following http://community.wolfram.com/groups/-/m/t/960843.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2016-09"]

img=Import["../2016-09/GST48-Marked.png"]

EnergyFunction[img_Image]:=GradientFilter[img,1,Method->"ShenCastan"]

EnergyFunction[img]

MinFilter1[x_List]:=Min/@Partition[x,3,1,{2,2},1.0 10^6] (*same as MinFilter[x,1] but 10x faster*)
MinPosition[x_List]:=First[Ordering[x,1]] (*position of min element*)
Neighbours[n_Integer?Positive,len_Integer?Positive]:=Which[n==1,If[len>1,{1,2},{1}],n==len,If[len>1,{len,len-1},{1}],True,{n-1,n,n+1}]
FindSeam[mat_List?MatrixQ]:=Module[{dimx,dimy,seam,neighbours,values,newpos,ii},{dimy,dimx}=Dimensions[mat];
seam=ConstantArray[-1,dimy];
seam[[-1]]=MinPosition[mat[[-1]]];
Do[neighbours=Neighbours[seam[[ii+1]],dimx];
values=mat[[ii,neighbours]];
newpos=neighbours[[MinPosition[values]]];
seam[[ii]]=newpos,{ii,dimy-1,1,-1}];
seam]
ComputeEnergyField[img_Image]:=FoldList[#2+MinFilter1[#1]&,ImageData[EnergyFunction[img]]]
ComputeEnergyField[mat_List]:=ComputeEnergyField[Image[mat]]

seam=FindSeam[ComputeEnergyField[img]];
HighlightImage[img,Transpose[{seam,Range[Length[seam]]}]]

ClearAll[MinFilter1,MinPosition,Neighbours,FindSeam,EnergyFunction,ComputeEnergyField,Carve,FillNthPosition,CreateSeamcarveImageData,SeamCarve]
MinFilter1[x_List]:=Min/@Partition[x,3,1,{2,2},1.0 10^6] (*same as MinFilter[x,1] but 10x faster*)
MinPosition[x_List]:=First[Ordering[x,1]] (*position of min element*)
Neighbours[n_Integer?Positive,len_Integer?Positive]:=Which[n==1,If[len>1,{1,2},{1}],n==len,If[len>1,{len,len-1},{1}],True,{n-1,n,n+1}]
FindSeam[mat_List?MatrixQ]:=Module[{dimx,dimy,seam,neighbours,values,newpos,ii},{dimy,dimx}=Dimensions[mat];
seam=ConstantArray[-1,dimy];
seam[[-1]]=MinPosition[mat[[-1]]];
Do[neighbours=Neighbours[seam[[ii+1]],dimx];
values=mat[[ii,neighbours]];
newpos=neighbours[[MinPosition[values]]];
seam[[ii]]=newpos,{ii,dimy-1,1,-1}];
seam]
EnergyFunction[img_Image]:=GradientFilter[img,1,Method->"ShenCastan"]
ComputeEnergyField[img_Image]:=FoldList[#2+MinFilter1[#1]&,ImageData[EnergyFunction[img]]]
ComputeEnergyField[mat_List]:=ComputeEnergyField[Image[mat]]
Carve[mat_List?ArrayQ,seam_List]:=MapThread[Delete,{mat,seam},1]
FillNthPosition[x_List,n_Integer?Positive,fill_,empty_: 0]:=Block[{pos,out},out=x;
pos=Position[out,empty,{1},n,Heads->False];
out[[pos[[n]]]]=fill;
out]
CreateSeamcarveImageData[img_Image]:=Block[{imagedata,dims,dimx,dimy,carveinfo,seam,energyinfo},imagedata=ImageData[img];
dims={dimy,dimx}=Dimensions[imagedata,2];
carveinfo=ConstantArray[0,dims];
PrintTemporary[Dynamic[Row[{"Calculating: ",i,"/",dimx}]]];
Do[energyinfo=ComputeEnergyField[imagedata];
seam=FindSeam[energyinfo];
carveinfo=MapThread[FillNthPosition[#1,#2,i,0]&,{carveinfo,seam}];
imagedata=Carve[imagedata,seam];,{i,dimx}];
{img,carveinfo}]
SeamCarve[{img_Image,carveinfo_List},n_Integer?NonNegative]:=Block[{imgdata,pick,sel,m},imgdata=ImageData[img];
If[Dimensions[imgdata,2]==Dimensions[carveinfo],m=Clip[n,{0,Length[carveinfo[[1]]]-1}];
sel=UnitStep[m-carveinfo];
Image[Pick[ImageData[img],sel,0]],Abort[];]]

out=CreateSeamcarveImageData[img];

Manipulate[SeamCarve[out,n],{n,0,1000,5}]

SeamCarve[out,500]