Directory[]

<<KnotTheory`

We will first start by starting with the most straightforward starting point and go from there:

To do that, because of the massive amount of branching that might happen, I reckon we use recursion:

The following only works for non-initial and non-final crossings

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]]⋃#,curFronts[[possibilityIndex]]⋂#]]]<=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]

Given the initial line segment stacking order we now try to connect the rest of the line segments

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]

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

And finally we use these functions to find the minimum q-width for each knot:

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]

quickWidth[pd_PD] :=Module[{listCrossings, startCrossingIndex, startingCrossings, quickCrossingPermutations, quickCrossingPermutationWidths}, 
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 ⋃ #2, #1 ⋂ #2] &, {}, #])&/@quickCrossingPermutations)];
quickCrossingPermutationWidths]

quantitiesGivenCrossingNum = <|3 -> 1, 4 -> 1, 5 -> 2, 6 -> 3, 7 -> 7, 8 -> 21, 9 -> 49, 10 -> 165|>

Table[Echo[Knot[i,j] -> quickWidth[PD[Knot[i,j]]]], {i, 3,10}, {j, 1, quantitiesGivenCrossingNum[i]}]