-- | Non-crossing partitions.
--
-- See eg. <http://en.wikipedia.org/wiki/Noncrossing_partition>
--
-- Non-crossing partitions of the set @[1..n]@ are encoded as lists of lists
-- in standard form: Entries decreasing in each block  and blocks listed in increasing order of their first entries.
-- For example the partition in the diagram
--
-- <<svg/noncrossing.svg>>
--
-- is represented as
--
-- > NonCrossing [[3],[5,4,2],[7,6,1],[9,8]]
--

{-# LANGUAGE BangPatterns #-}
module Math.Combinat.Partitions.NonCrossing where

--------------------------------------------------------------------------------

import Control.Applicative

import Data.List
import Data.Ord

import System.Random

import Math.Combinat.Numbers
import Math.Combinat.LatticePaths
import Math.Combinat.Helper
import Math.Combinat.Partitions.Set
import Math.Combinat.Classes

--------------------------------------------------------------------------------
-- * The type of non-crossing partitions

-- | A non-crossing partition of the set @[1..n]@ in standard form: 
-- entries decreasing in each block  and blocks listed in increasing order of their first entries.
newtype NonCrossing = NonCrossing [[Int]] deriving (NonCrossing -> NonCrossing -> Bool
(NonCrossing -> NonCrossing -> Bool)
-> (NonCrossing -> NonCrossing -> Bool) -> Eq NonCrossing
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NonCrossing -> NonCrossing -> Bool
$c/= :: NonCrossing -> NonCrossing -> Bool
== :: NonCrossing -> NonCrossing -> Bool
$c== :: NonCrossing -> NonCrossing -> Bool
Eq,Eq NonCrossing
Eq NonCrossing
-> (NonCrossing -> NonCrossing -> Ordering)
-> (NonCrossing -> NonCrossing -> Bool)
-> (NonCrossing -> NonCrossing -> Bool)
-> (NonCrossing -> NonCrossing -> Bool)
-> (NonCrossing -> NonCrossing -> Bool)
-> (NonCrossing -> NonCrossing -> NonCrossing)
-> (NonCrossing -> NonCrossing -> NonCrossing)
-> Ord NonCrossing
NonCrossing -> NonCrossing -> Bool
NonCrossing -> NonCrossing -> Ordering
NonCrossing -> NonCrossing -> NonCrossing
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NonCrossing -> NonCrossing -> NonCrossing
$cmin :: NonCrossing -> NonCrossing -> NonCrossing
max :: NonCrossing -> NonCrossing -> NonCrossing
$cmax :: NonCrossing -> NonCrossing -> NonCrossing
>= :: NonCrossing -> NonCrossing -> Bool
$c>= :: NonCrossing -> NonCrossing -> Bool
> :: NonCrossing -> NonCrossing -> Bool
$c> :: NonCrossing -> NonCrossing -> Bool
<= :: NonCrossing -> NonCrossing -> Bool
$c<= :: NonCrossing -> NonCrossing -> Bool
< :: NonCrossing -> NonCrossing -> Bool
$c< :: NonCrossing -> NonCrossing -> Bool
compare :: NonCrossing -> NonCrossing -> Ordering
$ccompare :: NonCrossing -> NonCrossing -> Ordering
$cp1Ord :: Eq NonCrossing
Ord,Int -> NonCrossing -> ShowS
[NonCrossing] -> ShowS
NonCrossing -> String
(Int -> NonCrossing -> ShowS)
-> (NonCrossing -> String)
-> ([NonCrossing] -> ShowS)
-> Show NonCrossing
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NonCrossing] -> ShowS
$cshowList :: [NonCrossing] -> ShowS
show :: NonCrossing -> String
$cshow :: NonCrossing -> String
showsPrec :: Int -> NonCrossing -> ShowS
$cshowsPrec :: Int -> NonCrossing -> ShowS
Show,ReadPrec [NonCrossing]
ReadPrec NonCrossing
Int -> ReadS NonCrossing
ReadS [NonCrossing]
(Int -> ReadS NonCrossing)
-> ReadS [NonCrossing]
-> ReadPrec NonCrossing
-> ReadPrec [NonCrossing]
-> Read NonCrossing
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NonCrossing]
$creadListPrec :: ReadPrec [NonCrossing]
readPrec :: ReadPrec NonCrossing
$creadPrec :: ReadPrec NonCrossing
readList :: ReadS [NonCrossing]
$creadList :: ReadS [NonCrossing]
readsPrec :: Int -> ReadS NonCrossing
$creadsPrec :: Int -> ReadS NonCrossing
Read)

-- | Checks whether a set partition is noncrossing.
--
-- Implementation method: we convert to a Dyck path and then back again, and finally compare. 
-- Probably not very efficient, but should be better than a naive check for crosses...)
--
_isNonCrossing :: [[Int]] -> Bool
_isNonCrossing :: [[Int]] -> Bool
_isNonCrossing [[Int]]
zzs0 = [[Int]] -> Bool
_isNonCrossingUnsafe ([[Int]] -> [[Int]]
_standardizeNonCrossing [[Int]]
zzs0)

-- | Warning: This function assumes the standard ordering!
_isNonCrossingUnsafe :: [[Int]] -> Bool
_isNonCrossingUnsafe :: [[Int]] -> Bool
_isNonCrossingUnsafe [[Int]]
zzs = 
  case [[Int]] -> Maybe LatticePath
_nonCrossingPartitionToDyckPathMaybe [[Int]]
zzs of
    Maybe LatticePath
Nothing   -> Bool
False
    Just LatticePath
dyck -> case LatticePath -> Maybe NonCrossing
dyckPathToNonCrossingPartitionMaybe LatticePath
dyck of
      Maybe NonCrossing
Nothing                -> Bool
False
      Just (NonCrossing [[Int]]
yys) -> [[Int]]
yys [[Int]] -> [[Int]] -> Bool
forall a. Eq a => a -> a -> Bool
== [[Int]]
zzs

-- | Convert to standard form: entries decreasing in each block 
-- and blocks listed in increasing order of their first entries.
_standardizeNonCrossing :: [[Int]] -> [[Int]]
_standardizeNonCrossing :: [[Int]] -> [[Int]]
_standardizeNonCrossing = ([Int] -> [Int] -> Ordering) -> [[Int]] -> [[Int]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (([Int] -> Int) -> [Int] -> [Int] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing [Int] -> Int
forall p. [p] -> p
myhead) ([[Int]] -> [[Int]]) -> ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> [Int]
forall a. Ord a => [a] -> [a]
reverseSort where
  myhead :: [p] -> p
myhead [p]
xs = case [p]
xs of
    (p
x:[p]
xs) -> p
x
    []     -> String -> p
forall a. HasCallStack => String -> a
error String
"_standardizeNonCrossing: empty subset"

fromNonCrossing :: NonCrossing -> [[Int]]
fromNonCrossing :: NonCrossing -> [[Int]]
fromNonCrossing (NonCrossing [[Int]]
xs) = [[Int]]
xs

toNonCrossingUnsafe :: [[Int]] -> NonCrossing
toNonCrossingUnsafe :: [[Int]] -> NonCrossing
toNonCrossingUnsafe = [[Int]] -> NonCrossing
NonCrossing

-- | Throws an error if the input is not a non-crossing partition
toNonCrossing :: [[Int]] -> NonCrossing
toNonCrossing :: [[Int]] -> NonCrossing
toNonCrossing [[Int]]
xxs = case [[Int]] -> Maybe NonCrossing
toNonCrossingMaybe [[Int]]
xxs of
  Just NonCrossing
nc -> NonCrossing
nc
  Maybe NonCrossing
Nothing -> String -> NonCrossing
forall a. HasCallStack => String -> a
error String
"toNonCrossing: not a non-crossing partition"

toNonCrossingMaybe :: [[Int]] -> Maybe NonCrossing
toNonCrossingMaybe :: [[Int]] -> Maybe NonCrossing
toNonCrossingMaybe [[Int]]
xxs0 = 
  if [[Int]] -> Bool
_isNonCrossingUnsafe [[Int]]
xxs
    then NonCrossing -> Maybe NonCrossing
forall a. a -> Maybe a
Just (NonCrossing -> Maybe NonCrossing)
-> NonCrossing -> Maybe NonCrossing
forall a b. (a -> b) -> a -> b
$ [[Int]] -> NonCrossing
NonCrossing [[Int]]
xxs
    else Maybe NonCrossing
forall a. Maybe a
Nothing
  where 
    xxs :: [[Int]]
xxs = [[Int]] -> [[Int]]
_standardizeNonCrossing [[Int]]
xxs0

-- | If a set partition is actually non-crossing, then we can convert it
setPartitionToNonCrossing :: SetPartition -> Maybe NonCrossing
setPartitionToNonCrossing :: SetPartition -> Maybe NonCrossing
setPartitionToNonCrossing (SetPartition [[Int]]
zzs0) =
  if [[Int]] -> Bool
_isNonCrossingUnsafe [[Int]]
zzs
    then NonCrossing -> Maybe NonCrossing
forall a. a -> Maybe a
Just (NonCrossing -> Maybe NonCrossing)
-> NonCrossing -> Maybe NonCrossing
forall a b. (a -> b) -> a -> b
$ [[Int]] -> NonCrossing
NonCrossing [[Int]]
zzs
    else Maybe NonCrossing
forall a. Maybe a
Nothing
  where
    zzs :: [[Int]]
zzs = [[Int]] -> [[Int]]
_standardizeNonCrossing [[Int]]
zzs0

instance HasNumberOfParts NonCrossing where
  numberOfParts :: NonCrossing -> Int
numberOfParts (NonCrossing [[Int]]
p) = [[Int]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
p

--------------------------------------------------------------------------------
-- * Bijection to Dyck paths

-- | Bijection between Dyck paths and noncrossing partitions
--
-- Based on: David Callan: /Sets, Lists and Noncrossing Partitions/
--
-- Fails if the input is not a Dyck path.
dyckPathToNonCrossingPartition :: LatticePath -> NonCrossing
dyckPathToNonCrossingPartition :: LatticePath -> NonCrossing
dyckPathToNonCrossingPartition = [[Int]] -> NonCrossing
NonCrossing ([[Int]] -> NonCrossing)
-> (LatticePath -> [[Int]]) -> LatticePath -> NonCrossing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> [[Int]]
go Int
0 [] [] [] where
  go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> [[Int]] 
  go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> [[Int]]
go !Int
cnt [Int]
stack [Int]
small [[Int]]
big LatticePath
path =
    case LatticePath
path of
      (Step
x:LatticePath
xs) -> case Step
x of 
        Step
UpStep   -> let cnt' :: Int
cnt' = Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in case LatticePath
xs of
          (Step
y:LatticePath
ys)   -> case Step
y of
            Step
UpStep   -> Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> [[Int]]
go Int
cnt' (Int
cnt'Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
stack) [Int]
small                  [[Int]]
big  LatticePath
xs  
            Step
DownStep -> Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> [[Int]]
go Int
cnt' (Int
cnt'Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
stack) []    ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
small [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
big) LatticePath
xs
          []       -> String -> [[Int]]
forall a. HasCallStack => String -> a
error String
"dyckPathToNonCrossingPartition: last step is an UpStep (thus input was not a Dyck path)"
        Step
DownStep -> case [Int]
stack of
          (Int
k:[Int]
ks)   -> Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> [[Int]]
go Int
cnt [Int]
ks (Int
kInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
small) [[Int]]
big LatticePath
xs
          []       -> String -> [[Int]]
forall a. HasCallStack => String -> a
error String
"dyckPathToNonCrossingPartition: empty stack, shouldn't happen (thus input was not a Dyck path)"
      [] -> [[Int]] -> [[Int]]
forall a. [a] -> [a]
tail ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [[Int]]
forall a. [a] -> [a]
reverse ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
small [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
big)

-- | Safe version of 'dyckPathToNonCrossingPartition'
dyckPathToNonCrossingPartitionMaybe :: LatticePath -> Maybe NonCrossing
dyckPathToNonCrossingPartitionMaybe :: LatticePath -> Maybe NonCrossing
dyckPathToNonCrossingPartitionMaybe = ([[Int]] -> NonCrossing) -> Maybe [[Int]] -> Maybe NonCrossing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Int]] -> NonCrossing
NonCrossing (Maybe [[Int]] -> Maybe NonCrossing)
-> (LatticePath -> Maybe [[Int]])
-> LatticePath
-> Maybe NonCrossing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> Maybe [[Int]]
go Int
0 [] [] [] where
  go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> Maybe [[Int]] 
  go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> Maybe [[Int]]
go !Int
cnt [Int]
stack [Int]
small [[Int]]
big LatticePath
path =
    case LatticePath
path of
      (Step
x:LatticePath
xs) -> case Step
x of 
        Step
UpStep   -> let cnt' :: Int
cnt' = Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in case LatticePath
xs of
          (Step
y:LatticePath
ys)   -> case Step
y of
            Step
UpStep   -> Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> Maybe [[Int]]
go Int
cnt' (Int
cnt'Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
stack) [Int]
small                  [[Int]]
big  LatticePath
xs  
            Step
DownStep -> Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> Maybe [[Int]]
go Int
cnt' (Int
cnt'Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
stack) []    ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
small [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
big) LatticePath
xs
          []       -> Maybe [[Int]]
forall a. Maybe a
Nothing
        Step
DownStep -> case [Int]
stack of
          (Int
k:[Int]
ks)   -> Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> Maybe [[Int]]
go Int
cnt [Int]
ks (Int
kInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
small) [[Int]]
big LatticePath
xs
          []       -> Maybe [[Int]]
forall a. Maybe a
Nothing
      [] -> [[Int]] -> Maybe [[Int]]
forall a. a -> Maybe a
Just ([[Int]] -> Maybe [[Int]]) -> [[Int]] -> Maybe [[Int]]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [[Int]]
forall a. [a] -> [a]
tail ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [[Int]]
forall a. [a] -> [a]
reverse ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
small [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
big)

-- | The inverse bijection (should never fail proper 'NonCrossing'-s)
nonCrossingPartitionToDyckPath :: NonCrossing -> LatticePath
nonCrossingPartitionToDyckPath :: NonCrossing -> LatticePath
nonCrossingPartitionToDyckPath (NonCrossing [[Int]]
zzs) = Int -> [[Int]] -> LatticePath
go Int
0 [[Int]]
zzs where
  go :: Int -> [[Int]] -> LatticePath
go !Int
k (ys :: [Int]
ys@(Int
y:[Int]
_):[[Int]]
yys) = Int -> Step -> LatticePath
forall a. Int -> a -> [a]
replicate (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
k) Step
UpStep LatticePath -> LatticePath -> LatticePath
forall a. [a] -> [a] -> [a]
++ Int -> Step -> LatticePath
forall a. Int -> a -> [a]
replicate ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ys) Step
DownStep LatticePath -> LatticePath -> LatticePath
forall a. [a] -> [a] -> [a]
++ Int -> [[Int]] -> LatticePath
go Int
y [[Int]]
yys
  go !Int
k []             = []
  go Int
_  [[Int]]
_              = String -> LatticePath
forall a. HasCallStack => String -> a
error String
"nonCrossingPartitionToDyckPath: shouldnt't happen"

-- | Safe version 'nonCrossingPartitionToDyckPath'
_nonCrossingPartitionToDyckPathMaybe :: [[Int]] -> Maybe LatticePath
_nonCrossingPartitionToDyckPathMaybe :: [[Int]] -> Maybe LatticePath
_nonCrossingPartitionToDyckPathMaybe = Int -> [[Int]] -> Maybe LatticePath
go Int
0 where
  go :: Int -> [[Int]] -> Maybe LatticePath
go !Int
k (ys :: [Int]
ys@(Int
y:[Int]
_):[[Int]]
yys) = (LatticePath -> LatticePath)
-> Maybe LatticePath -> Maybe LatticePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\LatticePath
zs -> Int -> Step -> LatticePath
forall a. Int -> a -> [a]
replicate (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
k) Step
UpStep LatticePath -> LatticePath -> LatticePath
forall a. [a] -> [a] -> [a]
++ Int -> Step -> LatticePath
forall a. Int -> a -> [a]
replicate ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ys) Step
DownStep LatticePath -> LatticePath -> LatticePath
forall a. [a] -> [a] -> [a]
++ LatticePath
zs) (Int -> [[Int]] -> Maybe LatticePath
go Int
y [[Int]]
yys)
  go !Int
k []             = LatticePath -> Maybe LatticePath
forall a. a -> Maybe a
Just []
  go Int
_  [[Int]]
_              = Maybe LatticePath
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------

{- 
-- this should be mapped to NonCrossing [[3],[5,4,2],[7,6,1],[9,8]]
testpath = [u,u,u,d,u,u,d,d,d,u,u,d,d,d,u,u,d,d] where
  u = UpStep
  d = DownStep

testnc = NonCrossing [[3],[5,4,2],[7,6,1],[9,8]]
-}

--------------------------------------------------------------------------------
-- * Generating non-crossing partitions

-- | Lists all non-crossing partitions of @[1..n]@
--
-- Equivalent to (but orders of magnitude faster than) filtering out the non-crossing ones:
--
-- > (sort $ catMaybes $ map setPartitionToNonCrossing $ setPartitions n) == sort (nonCrossingPartitions n)
--
nonCrossingPartitions :: Int -> [NonCrossing]
nonCrossingPartitions :: Int -> [NonCrossing]
nonCrossingPartitions = (LatticePath -> NonCrossing) -> [LatticePath] -> [NonCrossing]
forall a b. (a -> b) -> [a] -> [b]
map LatticePath -> NonCrossing
dyckPathToNonCrossingPartition ([LatticePath] -> [NonCrossing])
-> (Int -> [LatticePath]) -> Int -> [NonCrossing]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [LatticePath]
dyckPaths

-- | Lists all non-crossing partitions of @[1..n]@ into @k@ parts.
--
-- > sort (nonCrossingPartitionsWithKParts k n) == sort [ p | p <- nonCrossingPartitions n , numberOfParts p == k ]
--
nonCrossingPartitionsWithKParts 
  :: Int   -- ^ @k@ = number of parts 
  -> Int   -- ^ @n@ = size of the set
  -> [NonCrossing]
nonCrossingPartitionsWithKParts :: Int -> Int -> [NonCrossing]
nonCrossingPartitionsWithKParts Int
k Int
n = (LatticePath -> NonCrossing) -> [LatticePath] -> [NonCrossing]
forall a b. (a -> b) -> [a] -> [b]
map LatticePath -> NonCrossing
dyckPathToNonCrossingPartition ([LatticePath] -> [NonCrossing]) -> [LatticePath] -> [NonCrossing]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [LatticePath]
peakingDyckPaths Int
k Int
n

-- | Non-crossing partitions are counted by the Catalan numbers
countNonCrossingPartitions :: Int -> Integer
countNonCrossingPartitions :: Int -> Integer
countNonCrossingPartitions = Int -> Integer
countDyckPaths

-- | Non-crossing partitions with @k@ parts are counted by the Naranaya numbers
countNonCrossingPartitionsWithKParts 
  :: Int   -- ^ @k@ = number of parts 
  -> Int   -- ^ @n@ = size of the set
  -> Integer
countNonCrossingPartitionsWithKParts :: Int -> Int -> Integer
countNonCrossingPartitionsWithKParts = Int -> Int -> Integer
countPeakingDyckPaths

--------------------------------------------------------------------------------

-- | Uniformly random non-crossing partition
randomNonCrossingPartition :: RandomGen g => Int -> g -> (NonCrossing,g)
randomNonCrossingPartition :: Int -> g -> (NonCrossing, g)
randomNonCrossingPartition Int
n g
g0 = (LatticePath -> NonCrossing
dyckPathToNonCrossingPartition LatticePath
dyck, g
g1) where
  (LatticePath
dyck,g
g1) = Int -> g -> (LatticePath, g)
forall g. RandomGen g => Int -> g -> (LatticePath, g)
randomDyckPath Int
n g
g0

--------------------------------------------------------------------------------