{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

-- |
-- Copyright   : Anders Claesson 2013-2016
-- Maintainer  : Anders Claesson <anders.claesson@gmail.com>
--
-- Data types for Semistandard Young Tableaux (SSYT) and functions for
-- converting between (generalized) permutataions and SSYT. In other
-- words, this module implements the Robinson-Schensted-Knuth (RSK)
-- correspondence.

module Sym.Perm.SSYT
    (
      GeneralizedPerm
    , Entry
    , SSYT
    , SSYTPair (..)
    , Shape (..)
    , empty
    , null
    , display
    , fromPerm
    , fromGeneralizedPerm
    , toPerm
    , toGeneralizedPerm
    ) where

import Prelude    hiding (null)
import Data.List  hiding (null)
import Sym.Perm

type Row = Int

-- | An entry is a non-negative integer
type Entry = Int

-- | A /Generalized Permutation/ is a lexicographically sorted list of
-- pairs of non-negative integers.
type GeneralizedPerm = [(Int, Int)]

-- | A /Semistandard Young Tableau (SSYT)/: the entries weakly increase
-- along each row and strictly increase down each column.
type SSYT = [[Entry]]

-- | A pair of Semistandard Young Tableaux.
data SSYTPair = SSYTPair { SSYTPair -> SSYT
insertionTableau :: SSYT
                         , SSYTPair -> SSYT
recordingTableau :: SSYT
                         } deriving SSYTPair -> SSYTPair -> Bool
(SSYTPair -> SSYTPair -> Bool)
-> (SSYTPair -> SSYTPair -> Bool) -> Eq SSYTPair
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SSYTPair -> SSYTPair -> Bool
== :: SSYTPair -> SSYTPair -> Bool
$c/= :: SSYTPair -> SSYTPair -> Bool
/= :: SSYTPair -> SSYTPair -> Bool
Eq

class Shape a where
    shape :: a -> [Int]

instance Shape SSYT where
    shape :: SSYT -> [Entry]
shape = ([Entry] -> Entry) -> SSYT -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map [Entry] -> Entry
forall a. [a] -> Entry
forall (t :: * -> *) a. Foldable t => t a -> Entry
length

instance Shape SSYTPair where
    shape :: SSYTPair -> [Entry]
shape = SSYT -> [Entry]
forall a. Shape a => a -> [Entry]
shape (SSYT -> [Entry]) -> (SSYTPair -> SSYT) -> SSYTPair -> [Entry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SSYTPair -> SSYT
recordingTableau

-- | A pair of empty Young tableaux.
empty :: SSYTPair
empty :: SSYTPair
empty = SSYT -> SSYT -> SSYTPair
SSYTPair [] []

-- | Check if a given pair of Young tableaux are empty.
null :: SSYTPair -> Bool
null :: SSYTPair -> Bool
null SSYTPair
pq = SSYTPair
pq SSYTPair -> SSYTPair -> Bool
forall a. Eq a => a -> a -> Bool
== SSYTPair
empty

instance Show SSYTPair where
    show :: SSYTPair -> String
show (SSYTPair SSYT
p SSYT
q) = [String] -> String
unwords [String
"SSYTPair", SSYT -> String
forall a. Show a => a -> String
show SSYT
p, SSYT -> String
forall a. Show a => a -> String
show SSYT
q]

-- | Produce a string for pretty printing SSYT pairs.
display :: SSYTPair -> String
display :: SSYTPair -> String
display pq :: SSYTPair
pq@(SSYTPair SSYT
p SSYT
q)
    | SSYTPair -> Bool
null SSYTPair
pq   = String
"[] []"
    | Bool
otherwise = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> ShowS) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> ShowS
forall a. [a] -> [a] -> [a]
(++) ([String] -> [String]
pad [String]
p') [String]
q'
       where
         p' :: [String]
p'@(String
r:[String]
_) = ([Entry] -> String) -> SSYT -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [Entry] -> String
forall a. Show a => a -> String
show SSYT
p
         q' :: [String]
q'       = ([Entry] -> String) -> SSYT -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [Entry] -> String
forall a. Show a => a -> String
show SSYT
q
         pad :: [String] -> [String]
pad      = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS -> [String] -> [String]) -> ShowS -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ \String
s -> Entry -> ShowS
forall a. Entry -> [a] -> [a]
take (Entry
1Entry -> Entry -> Entry
forall a. Num a => a -> a -> a
+String -> Entry
forall a. [a] -> Entry
forall (t :: * -> *) a. Foldable t => t a -> Entry
length String
r) (String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat Char
' ')

-- Inserts Entry into a given Tableau returning the resulting Tableau
-- and the row where the Tableau was extended with a new box.
insertP :: SSYT -> Entry -> (SSYT, Row)
insertP :: SSYT -> Entry -> (SSYT, Entry)
insertP []     Entry
k = ([[Entry
k]], Entry
1)
insertP ([Entry]
r:SSYT
rs) Entry
k =
    let ([Entry]
smaller, [Entry]
larger) = (Entry -> Bool) -> [Entry] -> ([Entry], [Entry])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Entry -> Entry -> Bool
forall a. Ord a => a -> a -> Bool
<=Entry
k) [Entry]
r
    in case [Entry]
larger of
         []   -> (([Entry]
r[Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++[Entry
k])[Entry] -> SSYT -> SSYT
forall a. a -> [a] -> [a]
:SSYT
rs, Entry
1)
         Entry
c:[Entry]
cs -> let (SSYT
rs', Entry
i) = SSYT -> Entry -> (SSYT, Entry)
insertP SSYT
rs Entry
c
                 in (([Entry]
smaller [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ Entry
kEntry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:[Entry]
cs) [Entry] -> SSYT -> SSYT
forall a. a -> [a] -> [a]
: SSYT
rs', Entry
iEntry -> Entry -> Entry
forall a. Num a => a -> a -> a
+Entry
1)

-- Given (i,j), inserts j at the end of row i in the given Tableau.
insertQ :: SSYT -> Row -> Entry -> SSYT
insertQ :: SSYT -> Entry -> Entry -> SSYT
insertQ []     Entry
_ Entry
j = [[Entry
j]]
insertQ ([Entry]
r:SSYT
rs) Entry
1 Entry
j = ([Entry]
r [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry
j]) [Entry] -> SSYT -> SSYT
forall a. a -> [a] -> [a]
: SSYT
rs
insertQ ([Entry]
r:SSYT
rs) Entry
i Entry
j = [Entry]
r [Entry] -> SSYT -> SSYT
forall a. a -> [a] -> [a]
: SSYT -> Entry -> Entry -> SSYT
insertQ SSYT
rs (Entry
iEntry -> Entry -> Entry
forall a. Num a => a -> a -> a
-Entry
1) Entry
j

-- Given (i,j) and pair of tableaux (p,q) of the same shape, inserts i
-- into p and j into q so that the resulting pair of tableaux (p',q')
-- still have the same shape.
insertPQ :: SSYTPair -> (Entry, Entry) -> SSYTPair
insertPQ :: SSYTPair -> (Entry, Entry) -> SSYTPair
insertPQ (SSYTPair SSYT
p SSYT
q) (Entry
i,Entry
j) =
    let (SSYT
p',Entry
k) = SSYT -> Entry -> (SSYT, Entry)
insertP SSYT
p Entry
j in SSYT -> SSYT -> SSYTPair
SSYTPair SSYT
p' (SSYT -> Entry -> Entry -> SSYT
insertQ SSYT
q Entry
k Entry
i)

trim :: SSYT -> SSYT
trim :: SSYT -> SSYT
trim = ([Entry] -> Bool) -> SSYT -> SSYT
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ([Entry] -> [Entry] -> Bool
forall a. Eq a => a -> a -> Bool
/=[])

-- The inverse of insertP
removeP :: SSYT -> Row -> (SSYT, Entry)
removeP :: SSYT -> Entry -> (SSYT, Entry)
removeP SSYT
p Entry
k = (SSYT -> SSYT
trim (SSYT -> SSYT) -> SSYT -> SSYT
forall a b. (a -> b) -> a -> b
$ SSYT -> SSYT
forall a. [a] -> [a]
reverse SSYT
vs SSYT -> SSYT -> SSYT
forall a. [a] -> [a] -> [a]
++ [[Entry] -> [Entry]
forall a. HasCallStack => [a] -> [a]
init [Entry]
t] SSYT -> SSYT -> SSYT
forall a. [a] -> [a] -> [a]
++ SSYT
p2, Entry
e)
    where
      (SSYT
p1, SSYT
p2) = Entry -> SSYT -> (SSYT, SSYT)
forall a. Entry -> [a] -> ([a], [a])
splitAt (Entry
kEntry -> Entry -> Entry
forall a. Num a => a -> a -> a
+Entry
1) SSYT
p
      ([Entry]
t : SSYT
ts) = SSYT -> SSYT
forall a. [a] -> [a]
reverse SSYT
p1 -- t is the k-th row (counting from 0)
      (SSYT
vs,  Entry
e) = Entry -> SSYT -> (SSYT, Entry)
forall {a}. Ord a => a -> [[a]] -> ([[a]], a)
unbump ([Entry] -> Entry
forall a. HasCallStack => [a] -> a
last [Entry]
t) SSYT
ts
      unbump :: a -> [[a]] -> ([[a]], a)
unbump a
x [] = ([], a
x)
      unbump a
x ([a]
r:[[a]]
rs) =
          let ([a]
r1, [a]
r2) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
x) [a]
r
              ([[a]]
us,  a
y) = a -> [[a]] -> ([[a]], a)
unbump ([a] -> a
forall a. HasCallStack => [a] -> a
last [a]
r1) [[a]]
rs
          in (([a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
r1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
r2) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
us, a
y)

-- The inverse of insertQ
removeQ :: SSYT -> (SSYT, Row, Entry)
removeQ :: SSYT -> (SSYT, Entry, Entry)
removeQ SSYT
q = (SSYT -> SSYT
trim SSYT
q', Entry
k, Entry
e)
    where
      -- The last element and the length of a given row:
      f :: [Entry] -> (Entry, Entry)
f = ((Entry, Entry) -> Entry -> (Entry, Entry))
-> (Entry, Entry) -> [Entry] -> (Entry, Entry)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\(Entry
_,Entry
n) Entry
x -> (Entry
x,Entry
nEntry -> Entry -> Entry
forall a. Num a => a -> a -> a
+Entry
1)) (Entry
0,Entry
0) :: [Int] -> (Int, Int)
      -- Equal elements of Q are inserted left-to-right, allowing us to
      -- know which element, e, was the last to be inserted:
      ((Entry
e, Entry
_), Entry
k) = [((Entry, Entry), Entry)] -> ((Entry, Entry), Entry)
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([((Entry, Entry), Entry)] -> ((Entry, Entry), Entry))
-> [((Entry, Entry), Entry)] -> ((Entry, Entry), Entry)
forall a b. (a -> b) -> a -> b
$ [(Entry, Entry)] -> [Entry] -> [((Entry, Entry), Entry)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([Entry] -> (Entry, Entry)) -> SSYT -> [(Entry, Entry)]
forall a b. (a -> b) -> [a] -> [b]
map [Entry] -> (Entry, Entry)
f SSYT
q) [Entry
0..]
      -- Remove e from Q:
      q' :: SSYT
q' = [ if Entry
i Entry -> Entry -> Bool
forall a. Eq a => a -> a -> Bool
== Entry
k then [Entry] -> [Entry]
forall a. HasCallStack => [a] -> [a]
init [Entry]
r else [Entry]
r | ([Entry]
r,Entry
i) <- SSYT -> [Entry] -> [([Entry], Entry)]
forall a b. [a] -> [b] -> [(a, b)]
zip SSYT
q [Entry
0..] ]

-- The inverse of insertPQ
removePQ :: SSYTPair -> (SSYTPair, (Entry, Entry))
removePQ :: SSYTPair -> (SSYTPair, (Entry, Entry))
removePQ (SSYTPair SSYT
p SSYT
q) = (SSYT -> SSYT -> SSYTPair
SSYTPair SSYT
p' SSYT
q', (Entry
e1, Entry
e2))
    where
      (SSYT
q', Entry
k, Entry
e1) = SSYT -> (SSYT, Entry, Entry)
removeQ SSYT
q
      (SSYT
p', Entry
e2)    = SSYT -> Entry -> (SSYT, Entry)
removeP SSYT
p Entry
k

-- | The Robinson-Schensted-Knuth (RSK) algorithm.
fromGeneralizedPerm :: GeneralizedPerm -> SSYTPair
fromGeneralizedPerm :: [(Entry, Entry)] -> SSYTPair
fromGeneralizedPerm = (SSYTPair -> (Entry, Entry) -> SSYTPair)
-> SSYTPair -> [(Entry, Entry)] -> SSYTPair
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SSYTPair -> (Entry, Entry) -> SSYTPair
insertPQ SSYTPair
empty

-- | The Robinson-Schensted algorithm.
fromPerm :: Perm -> SSYTPair
fromPerm :: Perm -> SSYTPair
fromPerm = [(Entry, Entry)] -> SSYTPair
fromGeneralizedPerm ([(Entry, Entry)] -> SSYTPair)
-> (Perm -> [(Entry, Entry)]) -> Perm -> SSYTPair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entry] -> [Entry] -> [(Entry, Entry)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Entry
0..] ([Entry] -> [(Entry, Entry)])
-> (Perm -> [Entry]) -> Perm -> [(Entry, Entry)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry -> Entry) -> [Entry] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> Entry
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Entry] -> [Entry]) -> (Perm -> [Entry]) -> Perm -> [Entry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Perm -> [Entry]
toList

-- | The inverse of the Robinson-Schensted-Knuth algorithm.
toGeneralizedPerm :: SSYTPair -> GeneralizedPerm
toGeneralizedPerm :: SSYTPair -> [(Entry, Entry)]
toGeneralizedPerm = [(Entry, Entry)] -> SSYTPair -> [(Entry, Entry)]
go []
    where
      go :: [(Entry, Entry)] -> SSYTPair -> [(Entry, Entry)]
go [(Entry, Entry)]
ijs SSYTPair
pq | SSYTPair -> Bool
null SSYTPair
pq   = [(Entry, Entry)]
ijs
                | Bool
otherwise = let (SSYTPair
rs,(Entry, Entry)
ij) = SSYTPair -> (SSYTPair, (Entry, Entry))
removePQ SSYTPair
pq in [(Entry, Entry)] -> SSYTPair -> [(Entry, Entry)]
go ((Entry, Entry)
ij(Entry, Entry) -> [(Entry, Entry)] -> [(Entry, Entry)]
forall a. a -> [a] -> [a]
:[(Entry, Entry)]
ijs) SSYTPair
rs

-- | The inverse of the Robinson-Schensted algorithm.
toPerm :: SSYTPair -> Perm
toPerm :: SSYTPair -> Perm
toPerm = [Entry] -> Perm
fromList ([Entry] -> Perm) -> (SSYTPair -> [Entry]) -> SSYTPair -> Perm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Entry, Entry) -> Entry) -> [(Entry, Entry)] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map (Entry -> Entry
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Entry -> Entry)
-> ((Entry, Entry) -> Entry) -> (Entry, Entry) -> Entry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry, Entry) -> Entry
forall a b. (a, b) -> b
snd) ([(Entry, Entry)] -> [Entry])
-> (SSYTPair -> [(Entry, Entry)]) -> SSYTPair -> [Entry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SSYTPair -> [(Entry, Entry)]
toGeneralizedPerm