0
$\begingroup$

I want to find the minimum number of swaps required to reset an array. This problem has many applications in linear algebra.

The key point of this question is to find the number of closed loops in this array:

The key to the problem is to find the closed loop. Assuming that each closed loop has k numbers, the number of swaps in the closed loop is k-1. The minimum number of swaps is the sum of all swaps in the closed loop.

The meaning of the closed loop is that starting from a certain number A1, if A1 is at the wrong index, find A2 in the position after A1 sorting, find A3 in the position after A2 sorting...Finally find that A1 is after Ak sorting's position. Then A1, A2... Ak form a closed loop.

For example: (2,3,1,5,6,4,8,9,7) has 3 closed loops, namely (2,3,1), (5,6,4), (8,9,7), so the minimum number of swaps is 2+2+2= 6.

This is a simple code I wrote to implement this requirement :

arr = {2, 3, 1, 5, 6, 4, 8, 9, 7};
Table[(t = NestWhileList[arr[[#]] &, arr[[i]], # == arr[[i]] &])~Join~
  {arr[[Last[t]]]}, {i, 1, Length[arr]}]
DeleteDuplicates[%, Cycles[{#1}] == Cycles[{#2}] &]

I wonder if there is any other simpler way to do this. In addition, better robustness is needed.

$\endgroup$
2
  • 4
    $\begingroup$ I’m voting to close this question because there is no well-posed question in this post; the OP is simply asking for somebody to act as a free coding service. $\endgroup$ – m_goldberg Aug 6 '20 at 6:05
  • $\begingroup$ @m_goldberg I'm sorry, I shouldn't post before I try. I've updated the question. $\endgroup$ – A little mouse on the pampas Aug 6 '20 at 6:30
2
$\begingroup$

Can you find out the specific swaps and output it?

(Community Wiki)

The swaps needed to obtain startOne in ascending order (see Hausdorff, and the comment above by ciao):

swapsOne=(Partition[#,2,1]&/@First@FindPermutation[startOne]//Catenate)

{{1, 3}, {3, 2}, {4, 6}, {6, 5}, {7, 9}, {9, 8}}

and the steps may be visualized as follows:

FoldList[Permute[#,Cycles[{#2}]] &, startOne, swapsOne]//TeXForm

$$ \left( \begin{array}{ccccccccc} 2 & 3 & 1 & 5 & 6 & 4 & 8 & 9 & 7 \\ 1 & 3 & 2 & 5 & 6 & 4 & 8 & 9 & 7 \\ 1 & 2 & 3 & 5 & 6 & 4 & 8 & 9 & 7 \\ 1 & 2 & 3 & 4 & 6 & 5 & 8 & 9 & 7 \\ 1 & 2 & 3 & 4 & 5 & 6 & 8 & 9 & 7 \\ 1 & 2 & 3 & 4 & 5 & 6 & 7 & 9 & 8 \\ 1 & 2 & 3 & 4 & 5 & 6 & 7 & 8 & 9 \\ \end{array} \right) $$

where

startOne={2,3,1,5,6,4,8,9,7}

In addition:

prob2={7,1,3,2,4,5,6};
swapsProb2=(Partition[#,2,1]&/@First@FindPermutation[prob2]//Catenate)

{{1, 2}, {2, 4}, {4, 5}, {5, 6}, {6, 7}}

FoldList[Permute[#,Cycles[{#2}]] &, prob2, swapsProb2]//TeXForm

$$ \left( \begin{array}{ccccccc} 7 & 1 & 3 & 2 & 4 & 5 & 6 \\ 1 & 7 & 3 & 2 & 4 & 5 & 6 \\ 1 & 2 & 3 & 7 & 4 & 5 & 6 \\ 1 & 2 & 3 & 4 & 7 & 5 & 6 \\ 1 & 2 & 3 & 4 & 5 & 7 & 6 \\ 1 & 2 & 3 & 4 & 5 & 6 & 7 \\ \end{array} \right) $$

$\endgroup$
6
$\begingroup$

I believe this is what you're after:

f=Tr[Length /@ First@FindPermutation@# - 1]&;

Use:

f@{2, 3, 1, 5, 6, 4, 8, 9, 7}
f@{7, 1, 3, 2, 4, 5, 6}

6

5

$\endgroup$
2
  • $\begingroup$ Thank you very much. After verification, your result is correct. Can you find out the specific swaps and output it? $\endgroup$ – A little mouse on the pampas Aug 6 '20 at 7:30
  • $\begingroup$ @Ordinaryusers68 just swap using cycle contents by successive pairs. I think you can figure that out, if you have trouble post attempt and I'll comment. $\endgroup$ – ciao Aug 6 '20 at 8:39
0
$\begingroup$
arr = {2, 3, 4, 1, 5};
Table[If[arr[[i]] == i, 
   i = i + 1; {i - 1}, (t = 
     NestWhileList[(arr[[#]]) &, 
      arr[[i]], (arr[[#]] != arr[[i]]) &])], {i, 1, Length[arr]}];
DeleteDuplicates[%, Cycles[{#1}] == Cycles[{#2}] &]
Total[(Length[#] - 1) & /@ %]

f = Tr[Length /@ First@FindPermutation@# - 1] &;
f@arr
$\endgroup$

Not the answer you're looking for? Browse other questions tagged or ask your own question.