MathGroup Archive 1996

[Date Index] [Thread Index] [Author Index]

Search the Archive

doubly stochastic graph to permutations

  • To: mathgroup at smc.vnet.net
  • Subject: [mg3466] doubly stochastic graph to permutations
  • From: Daniel Lichtblau <danl>
  • Date: Sat, 9 Mar 1996 01:00:08 -0500
  • Sender: owner-wri-mathgroup at wolfram.com

  At the risk of injecting relevance to this question, I coded an  
algorithm in Mathematica to do part (b). If my code were cleaner, a  
careful reading would perhaps allow one to construct an argument. As  
it is, I suspect it would be far easier to do the problem from  
scratch (which in fact should give some insight into construction of  
such an algorithm).

In[2]:= permMatrix[vec:{a__Integer}] := Module[{len=Length[vec]},
    Table[If [k==vec[[j]], 1, 0], {j, len}, {k, len}]]
        

In[3]:= augment[mat_] := Module[{len=Length[mat]},
    Table[{mat[[i,j]], {i, j}}, {i, len}, {j, len}]]
        

In[4]:= subMatrix[mat_, i_Integer, j_Integer] :=
    Transpose[Drop[Transpose[Drop[mat, {i}]], {j}]]
        

In[5]:= getMinAndPos[mat_] := Module[{newmat, minlist},
    newmat = mat /. 0->Infinity;
    minlist = Map[First[Sort[#]]&, newmat];
    First[Sort[minlist]]]
                        

In[6]:= getPositionOfMax[mat_] := Module[{newmat, maxlist, ll},
    newmat = augment[mat /. Infinity->0];
    maxlist = Map[Last[Sort[#]]&, newmat];
    ll = Last[Sort[maxlist]];
    {ll[[1,2]], ll[[2]]}]
                                

In[7]:= getPositions[mat_, head_] := Module[{len=Length[mat], j, k,  
j2, k2},
    If [len==1, Return[head[mat[[1,1,2]]]]];
    {{j, k}, {j2, k2}} = getPositionOfMax[mat];
    head[{j, k}, getPositions[subMatrix[mat, j2, k2], head]]]
                        

In[8]:= stochMatrixToPerms[m_?MatrixQ] := Module[
    {len=Length[m], min, j, k, j2, mat=augment[m], posns, row, col,
      perm, list, result},
    result = list[];
    mat = mat /. 0->Infinity;
    {min, {j, k}} = getMinAndPos[mat];
    While [min!=Infinity,
        posns = Flatten[list[{j, k},
          getPositions[subMatrix[mat, j, k], list]], Infinity, list];
        perm = Map[Last, Sort[posns]];
        result = list[result, {min, perm}];
        For[j=1, j<=len, j++, mat[[j, perm[[j]], 1]] -= min];
        mat = mat /. 0->Infinity;
        {min, {j, k}} = getMinAndPos[mat];
        ];
    Map[{#[[1]], permMatrix[#[[2]]]}&,
      Flatten[result, Infinity, list] /. list->List]]
                                                                                                                                

General::spell1: 

   Possible spelling error: new symbol name "min"
     is similar to existing symbol "Min".

General::spell1: 

   Possible spelling error: new symbol name "row"
     is similar to existing symbol "Row".

General::spell1: 

   Possible spelling error: new symbol name "list"
     is similar to existing symbol "List".

General::stop: Further output of General::spell1
     will be suppressed during this calculation.

In[9]:= mat = {{1/3,1/3,1/3}, {1/2,1/2,0},{1/6,1/6,2/3}}; (*example*)

In[10]:= stochMatrixToPerms[mat]

           1
Out[10]= {{-, {{0, 0, 1}, {0, 1, 0}, {1, 0, 0}}}, 

           6
 

      1
>    {-, {{0, 0, 1}, {1, 0, 0}, {0, 1, 0}}}, 

      6
 

      1
>    {-, {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}}, 

      3
 

      1
>    {-, {{0, 1, 0}, {1, 0, 0}, {0, 0, 1}}}}
      3


Daniel Lichtblau
Wolfram Research, Inc.
danl at wolfram.com





==== [MESSAGE SEPARATOR] ====


  • Prev by Date: MonteCarlo Integration
  • Next by Date: Re: Re: FindRoot output format
  • Previous by thread: MonteCarlo Integration
  • Next by thread: How limited is ReIm?