Implementation of the Robinson-Schensted correspondence

Question

Has the Robinson-Schensted correspondence, as explained by Wikipedia or Richard Stanley, been implemented in any of the standard programming languages. I'm using Python, but I'm open to Java, C++, Mathematica, Matlab. On paper, the bumping is not so bad - I think 1364752 gives you a v-shaped tableau - but coding the algorithm may require linked lists.

The regular representation of a finite group can be decomposed into a direct sum of all the irreducible representations of G. The basis of the right-regular representation is the elements $g \in G$ and the group action is $\rho_g(h) = hg$. Then every irreducible representation appears in the sum with multiplicity equal to its dimension $$ |G| = \sum_{\pi \in \text{Irr(G)}} (\dim \pi )^2$$ When G = S(n), the permutation group on n elements, the irreducible representations are indexed by Young-diagrams with n boxes and |G| = n!

The Robinson-Schensted correspondence takes this literally and bijectively takes in a permutation and spits out two pairs of (standard?) Young tableaux filled with numbers 1 thru n of the same shape.

Answer 1

It doesn't require linked lists, just arrays that can grow.

There's a Java applet online that implements it.

I'm sure there are other implementations online, but since I couldn't find any, as a start, here's a simple Python implementation. [Though it feels odd giving a programming answer here, and I'm sure several people here can write it much better!]

from bisect import bisect
def RSK(p):
    '''Given a permutation p, spit out a pair of Young tableaux'''
    P = []; Q = []
    def insert(m, n=0):
        '''Insert m into P, then place n in Q at the same place'''
        for r in range(len(P)):
            if m > P[r][-1]:
                P[r].append(m); Q[r].append(n)
                return
            c = bisect(P[r], m)
            P[r][c],m = m,P[r][c]
        P.append([m])
        Q.append([n])

    for i in range(len(p)):
        insert(int(p[i]), i+1)
    return (P,Q)

print RSK('1364752')

Edit: Used binary search to improve from O(n³) to O(n²log n), which should matter only for very large permutations.

Answer 2

This is certainly implemented in Sage,

http://www.sagemath.org/doc/reference/sage/combinat/permutation.html

and you can run Sage at http://sagenb.org/

I am sure there are other possibilities.

Answer 3

The Combinatorica package of Mathematica does it with the function PermutationToTableaux

p={1,3,6,4,7,5,2};
t=PermutationToTableaux[p];
t[[1]]//TableForm (* the P table *)

1 2 4 5
3 7
6

t[[2]]//TableForm (* the Q table *)
1 2 3 5 
4 6
7

Answer 4

With R:

bump <- function(P, Q, e, i){
  if(length(P)==0) return(list(P=list(e), Q=list(i)))
  if(e > P[[1]][length(P[[1]])]){
    P[[1]] <- c(P[[1]], e)
    Q[[1]] <- c(Q[[1]], i)
    return(list(P=P, Q=Q))
  }else{
    j <- which.min(P[[1]]<e)
    w <- P[[1]][j]
    P[[1]][j] <- e
    b <- bump(P[-1], Q[-1], w, i)
    return(list(P=c(P[1], b$P), Q=c(Q[1], b$Q)))
  }
}
RKS <- function(sigma){
  out <- bump(list(), list(), sigma[1], 1)
  for(i in 2:length(sigma)){
    out <- bump(out$P, out$Q, sigma[i], i)
  }
  return(out)
}

It seems to work well:

> sigma <- c(1, 3, 6, 4, 7, 5, 2)
> RKS(sigma)
$P
$P[[1]]
[1] 1 2 4 5

$P[[2]]
[1] 3 7

$P[[3]]
[1] 6


$Q
$Q[[1]]
[1] 1 2 3 5

$Q[[2]]
[1] 4 6

$Q[[3]]
[1] 7

With Haskell:

import Control.Lens 
import Data.List
let replace ::[Int] -> Int -> ([Int], Int);
    replace xs e = ((element i .~ e) xs, xs !! i)
          where i = (\(Just x) -> x) (findIndex (>= e) xs)

let bump :: [[Int]] -> [[Int]] -> Int -> Int -> ([[Int]],[[Int]]);
    bump p q e i = if p==[] 
    then ([[e]], [[i]]) 
    else if e > (last (p !! 0))
        then (((p1 !! 0) ++ [e]) : pend, ((q1 !! 0) ++ [i]) : qend)
        else (newp1 : p2, (q !! 0) : q2)
          where (p1, pend) = splitAt 1 p
                (q1, qend) = splitAt 1 q
                (newp1, w) = replace (p !! 0) e
                (p2, q2) = bump (drop 1 p) (drop 1 q) w i

let rs :: [Int] -> ([[Int]],[[Int]]);
    rs sigma | (length sigma == 1) = bump [] [] (sigma !! 0) 1
             | otherwise = bump p q (last sigma) (length sigma)
                    where (p,q) = rs (fst (splitAt (length sigma -1) sigma))

It seems to work fine:

rs [1, 3, 6, 4, 7, 5, 2]
## ([[1,2,4,5],[3,7],[6]],[[1,2,3,5],[4,6],[7]])

Answer 5

This is Mathematica code for performing RSK on words, or biwords. The code is from my GitHub repository, and there are several other algorithms related to tableaux in there (Jeu-de-taquin, crystals, etc).

BiwordRSK::usage = "BiwordRSK[{w1,w2}] inserts the two words and produces a pair of Young Tableaux."

BiwordRSK[{a_Integer, b_Integer}, {YoungTableau[pTab_], YoungTableau[qTab_]}] := Module[
    {insertInRow, pTabOut = pTab, qTabOut = qTab, swapIndex, newi},
    
    (* Tries to insert element i in row r. If fail, continue with next row. *)
    
    insertInRow[r_, i_] := Which[
        (* There is no row r, create row *)
        Length[pTabOut] < r,
            pTabOut = Append[pTabOut, {i}];
            qTabOut = Append[qTabOut, {a}];
    ,
        
        (* Insert at the end of current row. For dual, use less *)
        pTabOut[[r, -1]] <= i,
            pTabOut = Insert[pTabOut, i, {r, -1}];
            qTabOut = Insert[qTabOut, a, {r, -1}];
    ,
        
        (* Recurse with swapped element. *)
        True,
            
            swapIndex = First @@ Position[pTabOut[[r]], _?( # > i &), 1, 1];
            newi = pTabOut[[r, swapIndex]];
            pTabOut = ReplacePart[pTabOut, {r, swapIndex} -> i];
            insertInRow[r + 1, newi];
    ];
    
    insertInRow[1, b];
    YoungTableau/@{pTabOut, qTabOut}
];

(* Performs the RSK insertion algorithm on the biword, and returns two SSYT of the same shape. *)
BiwordRSK[w1_List, w2_List] := Fold[BiwordRSK[#2, #1] &, YoungTableau/@{{}, {}}, Transpose@{w1,w2}];

(* Add increasing recording word. *)
BiwordRSK[w1_List]:=BiwordRSK[Range[Length@w1],w1];