(* ::Package:: *)

BeginPackage["KnotTheory`MinimumQuickWidth`", {"KnotTheory`"}]


MinimumQuickWidth::about = "
	MinimumQuickWidth was written by Yun-chi Tang at the University of Toronto in summer 2021 under the guidance of Dr. Dror Bar-Natan.
"


Begin["`Private`"]


nextStepSelection[curFronts_, curCrossingOrders_, pd_PD] := Module[{pdList, pdListLeft, listPossibleCrossings, listAllowedCrossings, listAfterFront, listAfterCrossings, possibilityIndex, numPossibilities, newFronts, newCrossingOrders}, 
pdList = List @@ List @@@ pd;
numPossibilities = Length[curFronts];
possibilityIndex = 1;
newFronts = {};
newCrossingOrders = {};
While[possibilityIndex <= numPossibilities, 
pdListLeft = Complement[pdList,curCrossingOrders[[possibilityIndex]]];
listPossibleCrossings = Select[pdListLeft, Abs[Length[curFronts[[possibilityIndex]]] - Length[Complement[curFronts[[possibilityIndex]]\[Union]#,curFronts[[possibilityIndex]]\[Intersection]#]]]<=2&];
listAllowedCrossings = Select[listPossibleCrossings, combineFrontAndCrossing[curFronts[[possibilityIndex]],#] != {-1}&];
listAfterFront = combineFrontAndCrossing[curFronts[[possibilityIndex]],#]&/@listAllowedCrossings;
listAfterCrossings = Join[curCrossingOrders[[possibilityIndex]], {#}] &/@listAllowedCrossings;
newFronts = Join[newFronts, {listAfterFront}];
newCrossingOrders = Join[newCrossingOrders, {listAfterCrossings}];
possibilityIndex = possibilityIndex + 1;
];
If[newFronts == {}, -1, {Flatten[newFronts,1], Flatten[newCrossingOrders,1]}]] 


combineFrontAndCrossing[curFront_, curCrossing_] := Module[{intersection, intersectionFrontIndex, intersectionCrossingIndex, intersectionFrontIndexDiff, intersectionCrossingIndexDiff, newFront},
intersection = SortBy[Select[curCrossing,MemberQ[curFront,#]&], First[First[Position[curFront,#]]]&];
intersectionFrontIndex = First[First[Position[curFront,#]]]&/@intersection;
intersectionCrossingIndex = First[First[Position[curCrossing,#]]]&/@intersection;
intersectionFrontIndexDiff = Table[intersectionFrontIndex[[i + 1]]-intersectionFrontIndex[[i]], {i, Length[intersectionFrontIndex] - 1}];
intersectionCrossingIndexDiff =Table[intersectionCrossingIndex[[i + 1]]-intersectionCrossingIndex[[i]], {i, Length[intersectionCrossingIndex] - 1}] /. -3 -> 1;
newFront = If[(DeleteDuplicates[intersectionFrontIndexDiff]== {1} || DeleteDuplicates[intersectionFrontIndexDiff]== {})&&  (DeleteDuplicates[intersectionCrossingIndexDiff]==  {1} || DeleteDuplicates[intersectionCrossingIndexDiff]==  {}), Join[curFront[[1;;intersectionFrontIndex[[1]] - 1]], orderUnconnected[curCrossing,intersectionCrossingIndex],curFront[[intersectionFrontIndex[[-1]] + 1;;Length[curFront]]]],{-1}];
newFront]


orderUnconnected[crossing_, connected_] := 
Module[{containOne, order}, 
containOne = MemberQ[connected, 1];
 order = If[containOne, 
Reverse[crossing[[connected[[-1]] + 1;; If[connected[[1]] == 1, 4,connected[[1]]-1]]]],
Join[Reverse[crossing[[1;;connected[[1]] - 1]]],Reverse[crossing[[connected[[-1]]+1;;4]]]]];
order]


selectAppropriateCrossing[pd_PD, givenCrossingOrder_] := Select[List @@ List @@@ pd, ContainsAll[#, givenCrossingOrder]&]


quickCrossingOrderGivenStart[pd_PD, startCrossing_] := 
Module[{currentFronts, currentCrossingOrders, index, newCrossingFrontOrders, newFronts, newCrossingOrders, newFrontsFinal, newCrossingOrdersFinal},
index = 2;
currentFronts = {{startCrossing[[3]], startCrossing[[2]], startCrossing[[1]], startCrossing[[4]]}};
currentCrossingOrders = {selectAppropriateCrossing[pd, startCrossing]};
While[index < Length[List @@ pd] && IntegerQ[currentFronts] == False,
newCrossingFrontOrders = nextStepSelection[currentFronts, currentCrossingOrders, pd];
currentFronts = If[IntegerQ[newCrossingFrontOrders], -1, newCrossingFrontOrders[[1]]];
currentCrossingOrders = If[IntegerQ[newCrossingFrontOrders], -1, newCrossingFrontOrders[[2]]];
index = index + 1;
];
newFrontsFinal = If[IntegerQ[currentFronts], -1, Flatten[Table[combineFrontAndCrossing[currentFronts[[i]], First[Complement[List @@ List @@@ pd, currentCrossingOrders[[i]]]]], {i, Length[currentFronts]}]]];
newCrossingOrdersFinal = If[IntegerQ[newFrontsFinal], -1, Join[#, Complement[List @@ List @@@ pd, #]]&/@ currentCrossingOrders];
newCrossingOrdersFinal]


generateStartingPoints[pd_PD] := Module[{index, indexedCrossing, indexedCrossingOrder, possibleStartingPoints},
index = 1;
possibleStartingPoints = {};
While[index <= Length[List @@ pd],
indexedCrossingOrder = (List @@ List @@@ pd)[[index]];
possibleStartingPoints = Join[possibleStartingPoints, NestList[Join[{#[[-1]]},Delete[#, -1]]& , indexedCrossingOrder, 3]];
index = index + 1;
];
possibleStartingPoints]


QuickMinWidthPerm[pd_PD] :=Module[{listCrossings, startCrossingIndex, startingCrossings, quickCrossingPermutations, quickCrossingPermutationWidths, quickCrossingMinPermutations}, 
listCrossings = List @@ List @@@ pd;
startCrossingIndex = 1;
startingCrossings = generateStartingPoints [pd];
quickCrossingPermutations =Select[DeleteDuplicates[Flatten[Table[quickCrossingOrderGivenStart[pd, startingCrossings[[i]]], {i, Length[startingCrossings]}]
,1]], IntegerQ[#] == False&];
quickCrossingPermutationWidths = Min [Max/@ ((Length /@ FoldList[Complement[#1 \[Union] #2, #1 \[Intersection] #2] &, {}, #])&/@quickCrossingPermutations)];
quickCrossingMinPermutations = First[Select[quickCrossingPermutations, Max [Length /@ FoldList[Complement[#1 \[Union] #2, #1 \[Intersection] #2] &, {}, #]]== quickCrossingPermutationWidths&]];
quickCrossingMinPermutations]


quickMinWidthFronts[pd_PD] := Module[{quickMinWidthCrossings, openingPossibilities, indexStart, indexCrossing, curFront, frontArrangement, foundArrangement},
quickMinWidthCrossings = QuickMinWidthPerm[pd];
openingPossibilities =  NestList[Join[{#[[-1]]},Delete[#, -1]]& , {quickMinWidthCrossings[[1]][[3]], quickMinWidthCrossings[[1]][[2]], quickMinWidthCrossings[[1]][[1]], quickMinWidthCrossings[[1]][[4]]}, 3];
indexStart = 1;
foundArrangement = False;
While[indexStart <= 4 && foundArrangement == False, 
curFront = openingPossibilities[[indexStart]];
indexCrossing = 2; 
frontArrangement = {curFront}; 
While[indexCrossing <= Length[List @@ pd], 
curFront =  combineFrontAndCrossing[curFront, quickMinWidthCrossings[[indexCrossing]]];
indexCrossing = If[curFront == {-1}, Length[List @@ pd] + 1, indexCrossing + 1];
frontArrangement = If[curFront == {-1}, {-1}, Join[frontArrangement, {curFront}]];
];
foundArrangement = If[frontArrangement == {-1}, False, True];
frontArrangement = If[foundArrangement, frontArrangement, {}];
indexStart = indexStart + 1;
];
frontArrangement]


crossing4L1[leftPoints_, n_] := 
{{{-0.5 + n - 1, leftPoints[[1]]}, {0 + n - 1,leftPoints[[1]]}, {0.35 + n - 1, leftPoints[[2]]}, {0.15 + n - 1, (leftPoints[[2]] + leftPoints[[3]]) / 2 + 0.2}},
{{-0.5 + n - 1, leftPoints[[2]]}, {-0.4 + n  - 1, leftPoints[[2]]}, {0 + n - 1,(leftPoints[[2]] + leftPoints[[3]]) / 2}},
{{-0.5 + n - 1, leftPoints[[3]]},{ -0.4 + n -1, leftPoints[[3]]},{-0.15+ n - 1,(leftPoints[[2]] + leftPoints[[3]]) / 2 - 0.2}},
{{-0.5 + n - 1, leftPoints[[4]]}, {0 + n -1,leftPoints[[4]]},{0.35 + n - 1,leftPoints[[3]]},{0 + n -1,(leftPoints[[2]] + leftPoints[[3]]) / 2}}
}


crossing4L2[leftPoints_, n_] := 
{{{-0.5+ n - 1,leftPoints[[4]]}, {0+ n - 1,leftPoints[[4]]},{0.35 + n - 1, leftPoints[[3]]},{0.15 + n - 1, (leftPoints[[2]] + leftPoints[[3]]) / 2 - 0.2}},
{{-0.5+ n - 1,leftPoints[[1]]},{0+ n - 1,leftPoints[[1]]},{0.35 + n - 1,leftPoints[[2]]},{0 + n - 1,0}},
{{-0.5+ n - 1, leftPoints[[2]]},{-0.4 + n - 1, leftPoints[[2]]},{-0.15 + n - 1, (leftPoints[[2]] + leftPoints[[3]]) / 2 + 0.2}},
{{-0.5+ n - 1, leftPoints[[3]]}, {-0.4+ n - 1, leftPoints[[3]]}, {0 + n - 1,0}}
}


crossing4L3[leftPoints_, n_] :=
{{{-0.5 + n - 1, leftPoints[[3]]}, {-0.4 + n - 1, leftPoints[[3]]},{-0.15 + n - 1, (leftPoints[[2]] + leftPoints[[3]]) / 2 - 0.2}},
{{-0.5 + n - 1, leftPoints[[4]]}, {0 + n - 1,leftPoints[[4]]},{0.35 + n - 1,leftPoints[[3]]},{0 + n - 1,0}},
{{-0.5 + n - 1, leftPoints[[1]]}, {0 + n - 1,leftPoints[[1]]},{0.35 + n - 1, leftPoints[[2]]},{0.15 + n - 1, (leftPoints[[2]] + leftPoints[[3]]) / 2 + 0.2}},
{{-0.5 + n - 1,  leftPoints[[2]]}, {-0.4 + n - 1,  leftPoints[[2]]}, {0 + n - 1,0}}
}


crossing4L4[leftPoints_, n_] := 
{{{-0.5 + n - 1,  leftPoints[[2]]},{-0.4 + n - 1,  leftPoints[[2]]}, {-0.15 + n - 1, (leftPoints[[2]] + leftPoints[[3]]) / 2 + 0.2}},
{{-0.5 + n - 1, leftPoints[[3]]},{-0.4 + n - 1, leftPoints[[3]]},{0 + n - 1,0}},
{{-0.5 + n - 1, leftPoints[[4]]},{0 + n - 1,leftPoints[[4]]},{0.35 + n - 1, leftPoints[[3]]},{0.15 + n - 1, (leftPoints[[2]] + leftPoints[[3]]) / 2 - 0.2}},
{{-0.5+ n - 1, leftPoints[[1]]},{0 + n - 1,leftPoints[[1]]},{0.35 + n - 1,  leftPoints[[2]]},{0 + n - 1,0}}
}


crossing4R1[rightPoints_, n_] := 
{{{-0.15 + n - 1,(rightPoints[[2]] + rightPoints[[3]]) / 2 - 0.2},{-0.35 + n - 1, rightPoints[[3]]}, {0 + n - 1,rightPoints[[4]]},{0.5 + n - 1, rightPoints[[4]]}},
{{0 + n - 1,0},{0.4 + n - 1, rightPoints[[3]]},{0.5 + n - 1, rightPoints[[3]]}},
{{0.15 + n - 1, (rightPoints[[2]] + rightPoints[[3]]) / 2 + 0.2},{0.4 + n - 1, rightPoints[[2]]},{0.5 + n - 1, rightPoints[[2]]}},
{{0 + n - 1,0},{-0.35 + n - 1, rightPoints[[2]]},{0 + n - 1,rightPoints[[1]]},{0.5+ n - 1,rightPoints[[1]]}}
}


crossing4R2[rightPoints_, n_] := 
{{{0.15 + n - 1, (rightPoints[[2]] + rightPoints[[3]]) / 2 - 0.2},{0.4  + n - 1,rightPoints[[3]]},{0.5+ n - 1, rightPoints[[3]]}},
{{0 + n - 1, 0},{0.4 + n - 1, rightPoints[[2]]},{0.5+ n - 1, rightPoints[[2]]}},
{{-0.15 + n - 1,(rightPoints[[2]] + rightPoints[[3]]) / 2 + 0.2},{-0.35 + n - 1, rightPoints[[2]]}, {0+ n - 1,rightPoints[[1]]},{0.5+ n - 1,rightPoints[[1]]}},
{{0 + n - 1, 0},{-0.35 + n - 1, rightPoints[[3]]}, {0+n - 1 ,rightPoints[[4]]},{0.5+ n - 1,rightPoints[[4]]}}
}


crossing4R3[rightPoints_, n_] := 
{{{0.15+ n - 1, (rightPoints[[2]] + rightPoints[[3]]) / 2 + 0.2},{0.4+ n - 1, rightPoints[[2]]},{0.5 + n - 1, rightPoints[[2]]}},
{{0 + n - 1, 0},{-0.35 + n - 1, rightPoints[[2]]}, {0 + n - 1, rightPoints[[1]]},{0.5 + n - 1, rightPoints[[1]]}},
{{-0.15 + n - 1, (rightPoints[[2]] + rightPoints[[3]]) / 2 - 0.2},{-0.35 + n - 1, rightPoints[[3]]}, {0 + n - 1, rightPoints[[4]]},{0.5+ n - 1, rightPoints[[4]]}},
{{0+ n - 1, 0},{0.4+ n - 1, rightPoints[[3]]},{0.5+ n - 1, rightPoints[[3]]}}
}


crossing4R4[rightPoints_, n_] := 
{{{-0.15+ n - 1, (rightPoints[[2]] + rightPoints[[3]]) / 2 + 0.2},{-0.35+ n - 1,rightPoints[[2]]}, {0+ n - 1, rightPoints[[1]]},{0.5+ n - 1, rightPoints[[1]]}},
{{0+ n - 1, 0},{-0.35+ n - 1, rightPoints[[3]]}, {0+ n - 1, rightPoints[[4]]},{0.5+ n - 1, rightPoints[[4]]}},
{{0.15+ n - 1, (rightPoints[[2]] + rightPoints[[3]]) / 2 - 0.2},{0.4+ n - 1, rightPoints[[3]]},{0.5+ n - 1, rightPoints[[3]]} },
{{0+ n - 1, 0},{0.4+ n - 1,rightPoints[[2]]},{0.5+ n - 1, rightPoints[[2]]}}
}


crossing3R1[leftPoints_, rightPoints_, n_] := 
{{{0.2 + n - 1, leftPoints[[2]]},{0.5 + n - 1, rightPoints[[1]]}},
{{-0.5+ n - 1,leftPoints[[1]]},{0+ n - 1, leftPoints[[1]]},{0+ n - 1, leftPoints[[2]]}},
{{-0.5 + n - 1, leftPoints[[2]]},{-0.2 + n - 1, leftPoints[[2]]}},
{{-0.5 + n - 1, leftPoints[[3]]},{0 + n - 1, leftPoints[[3]]},{0 + n - 1, leftPoints[[2]]}}
}


crossing3R2[leftPoints_, rightPoints_, n_] := 
{{{-0.5+ n - 1, leftPoints[[3]]},{0 + n - 1,leftPoints[[3]]} ,{0 + n - 1, leftPoints[[2]]-0.2}},
{{0+ n - 1, leftPoints[[2]]},{0.5 + n - 1,rightPoints[[1]]}},
{{-0.5 + n - 1, leftPoints[[1]]},{0 + n - 1,leftPoints[[1]]} ,{0 + n - 1, leftPoints[[2]]+0.2}},
{{-0.5 + n - 1, leftPoints[[2]]},{0 + n - 1, leftPoints[[2]]}}
}


crossing3R3[leftPoints_, rightPoints_, n_] := 
{{{-0.5+ n - 1, leftPoints[[2]]},{-0.2+ n - 1, leftPoints[[2]]}},
{{-0.5+ n - 1, leftPoints[[3]]},{0+ n - 1, leftPoints[[3]]},{0+ n - 1, leftPoints[[2]]}},
{{0.2+ n - 1, leftPoints[[2]]},{0.5+ n - 1, rightPoints[[1]]}},
{{-0.5+ n - 1, leftPoints[[1]]},{0+ n - 1, leftPoints[[1]]},{0+ n - 1, leftPoints[[2]]}}
}


crossing3R4[leftPoints_, rightPoints_, n_] := 
{{{-0.5+ n - 1, leftPoints[[1]]},{0+ n - 1, leftPoints[[1]]}, {0+ n - 1, leftPoints[[2]]+0.2}},
{{-0.5+ n - 1, leftPoints[[2]]},{0+ n - 1, leftPoints[[2]]}},
{{-0.5+ n - 1, leftPoints[[3]]},{0+ n - 1, leftPoints[[3]]}, {0+ n - 1, leftPoints[[2]]-0.2}},
{{0+ n - 1, leftPoints[[2]]},{0.5+ n - 1, rightPoints[[1]]}}
}


crossing3L1[leftPoints_,rightPoints_, n_]:=
{{{-0.5+ n - 1, leftPoints[[1]]},{-0.2+ n - 1,rightPoints[[2]]} },
{{0+ n - 1, rightPoints[[2]]},{0+ n - 1,rightPoints[[3]]}, {0.5+ n - 1, rightPoints[[3]]}},
{{0.2+ n - 1, rightPoints[[2]]},{0.5+ n - 1, rightPoints[[2]]}},
{{0+ n - 1, rightPoints[[2]]},{0+ n - 1, rightPoints[[1]]},{0.5+ n - 1, rightPoints[[1]]} }
}


crossing3L2[leftPoints_,rightPoints_, n_]:=
{{{0+ n - 1, rightPoints[[2]]+ 0.2},{0+ n - 1,rightPoints[[1]]},{0.5+ n - 1, rightPoints[[1]]}},
{{-0.5+ n - 1, leftPoints[[1]]},{0+ n - 1, rightPoints[[2]]}},
{{0+ n - 1, rightPoints[[2]]-0.2},{0+ n - 1, rightPoints[[3]]},{0.5+ n - 1, rightPoints[[3]]}},
{{0+ n - 1, rightPoints[[2]]},{0.5+ n - 1, rightPoints[[2]]}}
}


crossing3L3[leftPoints_,rightPoints_, n_]:=
{{{0.2+ n - 1, rightPoints[[2]]},{0.5+ n - 1, rightPoints[[2]]}},
{{0+ n - 1, rightPoints[[2]]},{0+ n - 1,rightPoints[[1]]}, {0.5+ n - 1, rightPoints[[1]]}},
{{-0.5+ n - 1, leftPoints[[1]]},{-0.2+ n - 1, rightPoints[[2]]}},
{{0+ n - 1, rightPoints[[2]]},{0+ n - 1, rightPoints[[3]]}, {0.5+ n - 1, rightPoints[[3]]}}
}


crossing3L4[leftPoints_, rightPoints_, n_] := 
{{{0+ n - 1,  rightPoints[[2]]-0.2},{0+ n - 1, rightPoints[[3]]},{0.5+ n - 1, rightPoints[[3]]}},
{{0+ n - 1,  rightPoints[[2]]},{0.5+ n - 1,  rightPoints[[2]]}},
{{0+ n - 1,  rightPoints[[2]] + 0.2},{0+ n - 1,  rightPoints[[1]]},{0.5+ n - 1, rightPoints[[1]]}},
{{-0.5+ n - 1, leftPoints[[1]]},{0+ n - 1,  rightPoints[[2]]}}
}


crossing34[leftPoints_, rightPoints_, n_] := 
{{{0.1+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 - 0.15 * (rightPoints[[1]] - rightPoints[[2]])},{0.3+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 - 0.45 * (rightPoints[[1]] - rightPoints[[2]])},{0.5+ n - 1,rightPoints[[2]]}},
{{0+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2},{0.3+ n - 1,(rightPoints[[1]] + rightPoints[[2]])/2 + 0.45 * (rightPoints[[1]] - rightPoints[[2]])}, {0.5+ n - 1, rightPoints[[1]]}},
{{-0.5+ n - 1, leftPoints[[1]]},{-0.3+ n - 1,(rightPoints[[1]] + rightPoints[[2]])/2 + 0.45 * (rightPoints[[1]] - rightPoints[[2]])},{-0.1+ n - 1,(rightPoints[[1]] + rightPoints[[2]])/2 + 0.15 * (rightPoints[[1]] - rightPoints[[2]])}},
{{-0.5+ n - 1, leftPoints[[2]]},{-0.3+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 - 0.45 * (rightPoints[[1]] - rightPoints[[2]])},{0+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2}}
}


crossing23[leftPoints_, rightPoints_, n_] := 
{{{0.1+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 +0.15 * (rightPoints[[1]] - rightPoints[[2]])},{0.3+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 +0.45 * (rightPoints[[1]] - rightPoints[[2]])}, {0.5+ n - 1, rightPoints[[1]]}},
{{-0.5+ n - 1, leftPoints[[1]]},{-0.3+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 +0.45 * (rightPoints[[1]] - rightPoints[[2]])},{0+ n - 1,(rightPoints[[1]] + rightPoints[[2]])/2 }},
{{-0.5+ n - 1,leftPoints[[2]]},{-0.3+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 -0.45 * (rightPoints[[1]] - rightPoints[[2]])}, {-0.1+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 -0.15 * (rightPoints[[1]] - rightPoints[[2]])}},
{{0+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 },{0.3+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 -0.45 * (rightPoints[[1]] - rightPoints[[2]])},{0.5+ n - 1,rightPoints[[2]]}}
}


crossing14[leftPoints_, rightPoints_, n_] :=
{{{-0.5+ n - 1, leftPoints[[2]]}, {-0.3+ n -1, (rightPoints[[1]] + rightPoints[[2]])/2-0.45* (rightPoints[[1]] - rightPoints[[2]])},{-0.1 + n -1, (rightPoints[[1]] + rightPoints[[2]])/2-0.15* (rightPoints[[1]] - rightPoints[[2]])}},
{{0 + n - 1, (rightPoints[[1]] + rightPoints[[2]])/2},{0.3+ n -1, (rightPoints[[1]] + rightPoints[[2]])/2-0.45* (rightPoints[[1]] - rightPoints[[2]])},{0.5 + n - 1, rightPoints[[2]]}},
{{0.1 + n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 +0.15* (rightPoints[[1]] - rightPoints[[2]])},{0.3 + n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 +0.45* (rightPoints[[1]] - rightPoints[[2]])}, {0.5 + n -1, rightPoints[[1]]}},
{{-0.5+ n - 1, leftPoints[[1]]},{-0.3 + n - 1, (rightPoints[[1]] + rightPoints[[2]])/2 +0.45* (rightPoints[[1]] - rightPoints[[2]])},{0 + n - 1, (rightPoints[[1]] + rightPoints[[2]])/2}}
}


crossing12[leftPoints_, rightPoints_, n_] :=
{{{-0.5+ n - 1, leftPoints[[1]]},{-0.3+ n - 1,(rightPoints[[1]] + rightPoints[[2]])/2+ 0.45* (rightPoints[[1]] - rightPoints[[2]])},{-0.1+ n - 1,(rightPoints[[1]] + rightPoints[[2]])/2+ 0.15* (rightPoints[[1]] - rightPoints[[2]])}},
{{-0.5+ n - 1, leftPoints[[2]]},{-0.3+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2-0.45* (rightPoints[[1]] - rightPoints[[2]])},{0+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2}},
{{0.1+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2-0.15* (rightPoints[[1]] - rightPoints[[2]])},{0.3+ n - 1, (rightPoints[[1]] + rightPoints[[2]])/2-0.45* (rightPoints[[1]] - rightPoints[[2]])},{0.5+ n - 1, rightPoints[[2]]}},
{{0+ n - 1,(rightPoints[[1]] + rightPoints[[2]])/2},{0.3+ n - 1,(rightPoints[[1]] + rightPoints[[2]])/2+ 0.45* (rightPoints[[1]] - rightPoints[[2]])},{0.5+ n - 1, rightPoints[[1]]}}
}


crossingSegmentsToLeft[n_, pdList_]  := Flatten[Position[(List @@@ pdList)[[n]], #]&/@ Select[(List @@@ pdList)[[n]], MemberQ[Flatten[(List @@@ pdList)[[1;;n-1]]], #]&]]


listToIndex[list_] := StringJoin[ToString /@ Join[list, {"_"}]]


segmentsToLeft[pdList_] := listToIndex /@ (crossingSegmentsToLeft[#, pdList] &/@Range[Length[pdList]])


listOfCrossings[leftPoints_, rightPoints_, n_] := <| "1_" -> crossing3L1[leftPoints,rightPoints, n], "2_" -> crossing3L2[leftPoints,rightPoints, n], "3_" -> crossing3L3[leftPoints,rightPoints, n], 
"4_" -> crossing3L4[leftPoints,rightPoints, n], "12_" -> crossing12[leftPoints,rightPoints, n], "14_" -> crossing14[leftPoints,rightPoints, n], "23_" -> crossing23[leftPoints,rightPoints, n], 
"34_" -> crossing34[leftPoints,rightPoints, n], "123_" -> crossing3R4[leftPoints,rightPoints, n], "124_" -> crossing3R3[leftPoints,rightPoints, n], "134_" -> crossing3R2[leftPoints,rightPoints, n], "234_" -> crossing3R1[leftPoints,rightPoints, n]|>


addCrossing[listPoints_, crossing_, crossingPoints_] := 
Module[{indexCros, newPointsList},
newPointsList = listPoints;
indexCros = 1;
While[indexCros <= 4, 
newPointsList[[crossing[[indexCros]]]] = Join[newPointsList[[crossing[[indexCros]]]], crossingPoints[[indexCros]]];
indexCros = indexCros + 1;
];
newPointsList]


addFront[index_,listPoints_, preFront_, front_, crossing_, segLeft_]:=
Module[{connected, preFrontLocation,frontLocation, preUnconnect,postUnconnect,newListPoints,connectionIndex},
newListPoints= listPoints;
connected = Select[preFront,MemberQ[front, #]&];
preFrontLocation = AssociationThread[preFront -> Join[Reverse[Table[(2* i- 1)/2, {i, (Length[preFront] / 2)}]],Table[(-2 * i + 1 )/2,{i,(Length[preFront] / 2)}]]];
frontLocation = AssociationThread[front -> Join[Reverse[Table[(2* i- 1)/2, {i, (Length[front] / 2)}]],Table[(-2* i+ 1)/2,{i,(Length[front] / 2)}]]];
preUnconnect = Reverse[Sort[preFrontLocation[#] &/@ Complement[preFront,connected]]];
postUnconnect =Reverse[Sort[frontLocation[#] &/@ Complement[front,connected]]];
newListPoints = addCrossing[newListPoints, crossing, listOfCrossings[Join[preUnconnect, {0,0,0,0}], Join[postUnconnect,{0,0,0,0}], index][segLeft]];
connectionIndex = 1;
While[connectionIndex<= Length[connected],
newListPoints[[connected[[connectionIndex]]]] = Join[newListPoints[[connected[[connectionIndex]]]], {{0.5 + index - 1, frontLocation[connected[[connectionIndex]]]}}];
connectionIndex= connectionIndex + 1;
];
newListPoints]


minWidthDiagram[pd_PD] := 
Module[{crossingOrder,frontOrder, segLeft, listPoints, begFrontOrder, begBackOrder, index, crossingLineSegments}, 
crossingOrder = QuickMinWidthPerm[pd];
frontOrder = quickMinWidthFronts[pd];
segLeft = segmentsToLeft[crossingOrder];
listPoints = ConstantArray[{}, 2 * Length[List @@ pd]];
begFrontOrder = First[First[Position[crossingOrder[[1]],frontOrder[[1]][[1]]]]];
begBackOrder = First[First[Position[crossingOrder[[-1]],frontOrder[[-2]][[1]]]]];
listPoints = addCrossing[listPoints, crossingOrder[[1]],{crossing4R4[{1.5, 0.5, -0.5, -1.5}, 1], crossing4R3[{1.5, 0.5, -0.5, -1.5}, 1], crossing4R2[{1.5, 0.5, -0.5, -1.5}, 1], crossing4R1[{1.5, 0.5, -0.5, -1.5}, 1]}[[begFrontOrder]]];
index = 2;
While[index <= Length[List @@ pd] - 1,
listPoints = addFront[index, listPoints, frontOrder[[index - 1]], frontOrder[[index]], crossingOrder[[index]],segLeft[[index]]];
index = index + 1;
];
listPoints = addCrossing[listPoints, crossingOrder[[Length[crossingOrder]]],  {crossing4L1[{1.5, 0.5, -0.5, -1.5},Length[crossingOrder]], crossing4L2[{1.5, 0.5, -0.5, -1.5}, Length[crossingOrder]], crossing4L3[{1.5, 0.5, -0.5, -1.5}, Length[crossingOrder]], crossing4L4[{1.5, 0.5, -0.5, -1.5},Length[crossingOrder]]}[[begBackOrder]]];
crossingLineSegments = BSplineCurve[#]&/@ listPoints;
Graphics[crossingLineSegments]]


End[]


EndPackage[]
