{- | Compact representation of integer partitions.

Partitions are conceptually nonincreasing sequences of /positive/ integers.

This implementation uses the @compact-word-vectors@ library internally to provide
a much more memory-efficient Partition type that the naive lists of integer.
This is very helpful when building large tables indexed by partitions, for example; 
and hopefully quite a bit faster, too.

Note: This is an internal module, you are not supposed to import it directly.
It is also not fully ready to be used yet...

-}

{-# LANGUAGE BangPatterns, PatternSynonyms, ViewPatterns #-}
module Math.Combinat.Partitions.Integer.Compact where

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

import Data.Bits
import Data.Word
import Data.Ord
import Data.List ( intercalate , group , sort , sortBy , foldl' , scanl' ) 

import Data.Vector.Compact.WordVec ( WordVec , Shape(..) )
import qualified Data.Vector.Compact.WordVec as V

import Math.Combinat.Compositions ( compositions' )

--------------------------------------------------------------------------------
-- * The compact partition data type

newtype Partition 
  = Partition WordVec 
  deriving Partition -> Partition -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Partition -> Partition -> Bool
$c/= :: Partition -> Partition -> Bool
== :: Partition -> Partition -> Bool
$c== :: Partition -> Partition -> Bool
Eq

instance Show Partition where
  showsPrec :: Int -> Partition -> ShowS
showsPrec = Int -> Partition -> ShowS
showsPrecPartition

showsPrecPartition :: Int -> Partition -> ShowS
showsPrecPartition :: Int -> Partition -> ShowS
showsPrecPartition Int
prec (Partition WordVec
vec)
  = Bool -> ShowS -> ShowS
showParen (Int
prec forall a. Ord a => a -> a -> Bool
> Int
10) 
  forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Partition"
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' 
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows (WordVec -> [Word]
V.toList WordVec
vec)

instance Ord Partition where
  compare :: Partition -> Partition -> Ordering
compare = Partition -> Partition -> Ordering
cmpLexico
               
--------------------------------------------------------------------------------
-- * Pattern synonyms 

-- | Pattern sysnonyms allows us to use existing code with minimal modifications
pattern Nil :: Partition
pattern $bNil :: Partition
$mNil :: forall {r}. Partition -> ((# #) -> r) -> ((# #) -> r) -> r
Nil <- (isEmpty -> True) where
        Nil =  Partition
empty

pattern Cons :: Int -> Partition -> Partition
pattern $bCons :: Int -> Partition -> Partition
$mCons :: forall {r}.
Partition -> (Int -> Partition -> r) -> ((# #) -> r) -> r
Cons x xs <- (uncons -> Just (x,xs)) where
        Cons Int
x Partition
xs = Int -> Partition -> Partition
cons Int
x Partition
xs

-- | Simulated newtype constructor 
pattern Partition_ :: [Int] -> Partition
pattern $bPartition_ :: [Int] -> Partition
$mPartition_ :: forall {r}. Partition -> ([Int] -> r) -> ((# #) -> r) -> r
Partition_ xs <- (toList -> xs) where
        Partition_ [Int]
xs = [Int] -> Partition
fromDescList [Int]
xs

pattern Head :: Int -> Partition 
pattern $mHead :: forall {r}. Partition -> (Int -> r) -> ((# #) -> r) -> r
Head h <- (height -> h)

pattern Tail :: Partition -> Partition
pattern $mTail :: forall {r}. Partition -> (Partition -> r) -> ((# #) -> r) -> r
Tail xs <- (partitionTail -> xs)

pattern Length :: Int -> Partition 
pattern $mLength :: forall {r}. Partition -> (Int -> r) -> ((# #) -> r) -> r
Length n <- (width -> n)        

--------------------------------------------------------------------------------
-- * Lexicographic comparison

-- | The lexicographic ordering
cmpLexico :: Partition -> Partition -> Ordering
cmpLexico :: Partition -> Partition -> Ordering
cmpLexico (Partition WordVec
vec1) (Partition WordVec
vec2) = forall a. Ord a => a -> a -> Ordering
compare (WordVec -> [Word]
V.toList WordVec
vec1) (WordVec -> [Word]
V.toList WordVec
vec2)

--------------------------------------------------------------------------------
-- * Basic (de)constructrion

empty :: Partition
empty :: Partition
empty = WordVec -> Partition
Partition (WordVec
V.empty)

isEmpty :: Partition -> Bool
isEmpty :: Partition -> Bool
isEmpty (Partition WordVec
vec) = WordVec -> Bool
V.null WordVec
vec

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

singleton :: Int -> Partition
singleton :: Int -> Partition
singleton Int
x 
  | Int
x forall a. Ord a => a -> a -> Bool
>  Int
0     = WordVec -> Partition
Partition (Word -> WordVec
V.singleton forall a b. (a -> b) -> a -> b
$ Int -> Word
i2w Int
x)
  | Int
x forall a. Eq a => a -> a -> Bool
== Int
0     = Partition
empty
  | Bool
otherwise  = forall a. HasCallStack => String -> a
error String
"Parittion/singleton: negative input"

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

uncons :: Partition -> Maybe (Int,Partition)
uncons :: Partition -> Maybe (Int, Partition)
uncons (Partition WordVec
vec) = case WordVec -> Maybe (Word, WordVec)
V.uncons WordVec
vec of
  Maybe (Word, WordVec)
Nothing     -> forall a. Maybe a
Nothing
  Just (Word
h,WordVec
tl) -> forall a. a -> Maybe a
Just (Word -> Int
w2i Word
h, WordVec -> Partition
Partition WordVec
tl)

-- | @partitionTail p == snd (uncons p)@
partitionTail :: Partition -> Partition
partitionTail :: Partition -> Partition
partitionTail (Partition WordVec
vec) = WordVec -> Partition
Partition (WordVec -> WordVec
V.tail WordVec
vec)

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

-- | We assume that @x >= partitionHeight p@!
cons :: Int -> Partition -> Partition
cons :: Int -> Partition -> Partition
cons !Int
x (Partition !WordVec
vec) 
  | WordVec -> Bool
V.null WordVec
vec = WordVec -> Partition
Partition (if Int
x forall a. Ord a => a -> a -> Bool
> Int
0 then Word -> WordVec
V.singleton Word
y else WordVec
V.empty) 
  | Word
y forall a. Ord a => a -> a -> Bool
>= Word
h     = WordVec -> Partition
Partition (Word -> WordVec -> WordVec
V.cons Word
y WordVec
vec)
  | Bool
otherwise  = forall a. HasCallStack => String -> a
error String
"Partition/cons: invalid element to cons"
  where  
    y :: Word
y = Int -> Word
i2w Int
x
    h :: Word
h = WordVec -> Word
V.head WordVec
vec

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

-- | We assume that the element is not bigger than the last element!
snoc :: Partition -> Int -> Partition
snoc :: Partition -> Int -> Partition
snoc (Partition !WordVec
vec) !Int
x
  | Int
x forall a. Eq a => a -> a -> Bool
== Int
0           = WordVec -> Partition
Partition WordVec
vec
  | WordVec -> Bool
V.null WordVec
vec       = WordVec -> Partition
Partition (Word -> WordVec
V.singleton Word
y)
  | Word
y forall a. Ord a => a -> a -> Bool
<= WordVec -> Word
V.last WordVec
vec  = WordVec -> Partition
Partition (WordVec -> Word -> WordVec
V.snoc WordVec
vec Word
y)
  | Bool
otherwise        = forall a. HasCallStack => String -> a
error String
"Partition/snoc: invalid element to snoc"
  where
    y :: Word
y = Int -> Word
i2w Int
x

--------------------------------------------------------------------------------
-- * exponential form

toExponentialForm :: Partition -> [(Int,Int)]
toExponentialForm :: Partition -> [(Int, Int)]
toExponentialForm = forall a b. (a -> b) -> [a] -> [b]
map (\[Int]
xs -> (forall a. [a] -> a
head [Int]
xs,forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [[a]]
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. Partition -> [Int]
toAscList

fromExponentialForm :: [(Int,Int)] -> Partition
fromExponentialForm :: [(Int, Int)] -> Partition
fromExponentialForm = [Int] -> Partition
fromDescList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. (a, Int) -> [a]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {b} {b}. Ord a => (a, b) -> (a, b) -> Ordering
g where
  f :: (a, Int) -> [a]
f (!a
i,!Int
e) = forall a. Int -> a -> [a]
replicate Int
e a
i
  g :: (a, b) -> (a, b) -> Ordering
g (!a
i, b
_) (!a
j,b
_) = forall a. Ord a => a -> a -> Ordering
compare a
j a
i

--------------------------------------------------------------------------------
-- * Width and height of the bounding rectangle

-- | Width, or the number of parts
width :: Partition -> Int
width :: Partition -> Int
width (Partition WordVec
vec) = WordVec -> Int
V.vecLen WordVec
vec

-- | Height, or the first (that is, the largest) element
height :: Partition -> Int
height :: Partition -> Int
height (Partition WordVec
vec) = Word -> Int
w2i (WordVec -> Word
V.head WordVec
vec)

-- | Width and height 
widthHeight :: Partition -> (Int,Int)
widthHeight :: Partition -> (Int, Int)
widthHeight (Partition WordVec
vec) = (WordVec -> Int
V.vecLen WordVec
vec , Word -> Int
w2i (WordVec -> Word
V.head WordVec
vec))

--------------------------------------------------------------------------------
-- * Differential sequence

-- | From a non-increasing sequence @[a1,a2,..,an]@ this computes the sequence of differences
-- @[a1-a2,a2-a3,...,an-0]@
diffSequence :: Partition -> [Int]
diffSequence :: Partition -> [Int]
diffSequence = forall {a}. Num a => [a] -> [a]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Partition -> [Int]
toDescList where
  go :: [a] -> [a]
go (a
x:ys :: [a]
ys@(a
y:[a]
_)) = (a
xforall a. Num a => a -> a -> a
-a
y) forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
ys 
  go [a
x] = [a
x]
  go []  = []

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

-- | From a non-increasing sequence @[a1,a2,..,an]@ this computes the reversed sequence of differences
-- @[ a[n]-0 , a[n-1]-a[n] , ... , a[2]-a[3] , a[1]-a[2] ] @
reverseDiffSequence :: Partition -> [Int]
reverseDiffSequence :: Partition -> [Int]
reverseDiffSequence Partition
p = forall {a}. Num a => [a] -> [a]
go (Int
0 forall a. a -> [a] -> [a]
: Partition -> [Int]
toAscList Partition
p) where
  go :: [a] -> [a]
go (a
x:ys :: [a]
ys@(a
y:[a]
_)) = (a
yforall a. Num a => a -> a -> a
-a
x) forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
ys 
  go [a
x] = []
  go []  = []

--------------------------------------------------------------------------------
-- *  Dual partition

dualPartition :: Partition -> Partition
dualPartition :: Partition -> Partition
dualPartition compact :: Partition
compact@(Partition WordVec
vec) 
  | WordVec -> Bool
V.null WordVec
vec  = WordVec -> Partition
Partition WordVec
V.empty
  | Bool
otherwise   = WordVec -> Partition
Partition (Shape -> [Word] -> WordVec
V.fromList' Shape
shape forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> Word
i2w [Int]
dual)
  where
    height :: Word
height = WordVec -> Word
V.head   WordVec
vec
    len :: Int
len    = WordVec -> Int
V.vecLen WordVec
vec
    shape :: Shape
shape  = Int -> Int -> Shape
Shape (Word -> Int
w2i Word
height) (Word -> Int
V.bitsNeededFor forall a b. (a -> b) -> a -> b
$ Int -> Word
i2w Int
len)
    dual :: [Int]
dual   = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ forall a. Int -> a -> [a]
replicate Int
d Int
j
      | (Int
j,Int
d) <- forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
descendToOne Int
len) (Partition -> [Int]
reverseDiffSequence Partition
compact)
      ]

--------------------------------------------------------------------------------
-- * Conversion to list

toList :: Partition -> [Int]
toList :: Partition -> [Int]
toList = Partition -> [Int]
toDescList

-- | returns a descending (non-increasing) list
toDescList :: Partition -> [Int]
toDescList :: Partition -> [Int]
toDescList (Partition WordVec
vec) = forall a b. (a -> b) -> [a] -> [b]
map Word -> Int
w2i (WordVec -> [Word]
V.toList WordVec
vec)

-- | Returns a reversed (ascending; non-decreasing) list
toAscList :: Partition -> [Int]
toAscList :: Partition -> [Int]
toAscList (Partition WordVec
vec) = forall a b. (a -> b) -> [a] -> [b]
map Word -> Int
w2i (WordVec -> [Word]
V.toRevList WordVec
vec)

--------------------------------------------------------------------------------
-- * Conversion from list

fromDescList :: [Int] -> Partition
fromDescList :: [Int] -> Partition
fromDescList [Int]
list = Int -> [Int] -> Partition
fromDescList' (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
list) [Int]
list

-- | We assume that the input is a non-increasing list of /positive/ integers!
fromDescList' 
  :: Int          -- ^ length
  -> [Int]        -- ^ the list
  -> Partition
fromDescList' :: Int -> [Int] -> Partition
fromDescList' !Int
len ![Int]
list = WordVec -> Partition
Partition (Shape -> [Word] -> WordVec
V.fromList' (Int -> Int -> Shape
Shape Int
len Int
bits) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> Word
i2w [Int]
list) where
  bits :: Int
bits = case [Int]
list of
    []     -> Int
4
    (Int
x:[Int]
xs) -> Word -> Int
V.bitsNeededFor (Int -> Word
i2w Int
x)

--------------------------------------------------------------------------------
-- * Partial orderings

-- @ |p `isSubPartitionOf` q@
isSubPartitionOf :: Partition -> Partition -> Bool
isSubPartitionOf :: Partition -> Partition -> Bool
isSubPartitionOf Partition
p Partition
q = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> Bool
(<=) (Partition -> [Int]
toList Partition
p) (Partition -> [Int]
toList Partition
q forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Int
0)

-- | @q `dominates` p@
dominates :: Partition -> Partition -> Bool
dominates :: Partition -> Partition -> Bool
dominates (Partition WordVec
vec_q) (Partition WordVec
vec_p) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> Bool
(>=) ([Word] -> [Word]
sums ([Word]
qs forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Word
0)) ([Word] -> [Word]
sums [Word]
ps) where 
  sums :: [Word] -> [Word]
sums = forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl' forall a. Num a => a -> a -> a
(+) Word
0
  ps :: [Word]
ps = WordVec -> [Word]
V.toList WordVec
vec_p
  qs :: [Word]
qs = WordVec -> [Word]
V.toList WordVec
vec_q

--------------------------------------------------------------------------------
-- * Pieri rule

-- | Expands to product @s[lambda]*h[k]@ as a sum of @s[mu]@-s. See <https://en.wikipedia.org/wiki/Pieri's_formula>
pieriRule :: Partition -> Int -> [Partition]
pieriRule :: Partition -> Int -> [Partition]
pieriRule = forall a. HasCallStack => String -> a
error String
"Partitions/Integer/Compact: pieriRule not implemented yet"

{-
-- | Expands to product @s[lambda]*h[1] = s[lambda]*e[1]@ as a sum of @s[mu]@-s. See <https://en.wikipedia.org/wiki/Pieri's_formula>
pieriRuleSingleBox :: Partition -> [Partition]
pieriRuleSingleBox !compact = case compact of

  Nibble 0 -> [ singleton 1 ]

  Nibble w | h < 15 -> 
    [ Nibble  (w + shiftL 1 (60-4*i)) | (i,d)<-zip [0..n-1] diffs1 , d>0 ] ++ [ snoc compact 1 ]

  Medium1 w | h < 255 -> 
    [ Medium1 (w + shiftL 1 (56-8*i)) | (i,d)<-zip [0..n-1] diffs1 , d>0 ] ++ [ snoc compact 1 ]

  Medium2 w1 w2 | h < 255 -> 
    let (diffs1a,diffs1b) = splitAt 8 diffs1 
    in  [ Medium2    (w1 + shiftL 1 (56-8*i)) w2 | (i,d)<-zip [0..7  ] diffs1a , d>0 ] ++
        [ Medium2 w1 (w2 + shiftL 1 (56-8*i))    | (i,d)<-zip [0..n-9] diffs1b , d>0 ] ++
        [ snoc compact 1 ]

  Medium3 w1 w2 w3 | h < 255 -> 
    let (diffs1a,tmp    ) = splitAt 8 diffs1 
        (diffs1b,diffs1c) = splitAt 8 tmp
    in  [ Medium3       (w1 + shiftL 1 (56-8*i)) w2 w3 | (i,d)<-zip [0..7   ] diffs1a , d>0 ] ++
        [ Medium3    w1 (w2 + shiftL 1 (56-8*i)) w3    | (i,d)<-zip [0..7   ] diffs1b , d>0 ] ++
        [ Medium3 w1 w2 (w3 + shiftL 1 (56-8*i))       | (i,d)<-zip [0..n-17] diffs1c , d>0 ] ++
        [ snoc compact 1 ]
    
  _ -> genericSingleBox

  where
    (n,h)  =     widthHeight  compact
    list   =     toDescList   compact
    diffs1 = 1 : diffSequence compact

    genericSingleBox :: [Partition]
    genericSingleBox = map (fromDescList' n) (go list diffs1) ++ [ fromDescList' (n+1) (list ++ [1]) ] where
      go :: [Int] -> [Int] -> [[Int]]
      go (a:as) (d:ds) = if d > 0 then ((a+1):as) : map (a:) (go as ds) 
                                  else              map (a:) (go as ds)
      go []     _      = []

-- | Expands to product @s[lambda]*h[k]@ as a sum of @s[mu]@-s. See <https://en.wikipedia.org/wiki/Pieri's_formula>
pieriRule :: Partition -> Int -> [Partition]
pieriRule !compact !k 
  | k <  0                  = []
  | k == 0                  = [ compact ]
  | k == 1                  = pieriRuleSingleBox compact
  | h == 0                  = [ singleton k ]
  | h + k <= 15  && n < 15  = case compact of { Nibble w -> 
                              [ Nibble (w + encode c)  | c <- comps ] }
  | otherwise               = [ fromDescList' (n+b) xs | c <- comps , let (b,xs) = add c ] 

  where
    (n,h)  = widthHeight compact
    list   = toDescList compact
    bounds = k : {- map (min k) -} (diffSequence compact) 
    comps = compositions' bounds k

    add clist = go list clist where
      go (!p:ps) (!c:cs) = let (b,rest) = go ps cs in (b, (p+c):rest)
      go []      [c]     = if c>0 then (1,[c]) else (0,[])
      go _       _       = error "Compact/pieriRule/add: shouldn't happen"

    encode :: [Int] -> Word64
    encode = go 60 where
      go !k [c]    = if c==0 then 0 else shiftL (i2w c) k + 1
      go !k (c:cs) = shiftL (i2w c) k + go (k-4) cs
      go !k []     = error "Compact/pieriRule/encode: shouldn't happen"
-}

--------------------------------------------------------------------------------
-- * local (internally used) utility functions

{-# INLINE i2w #-}
i2w :: Int -> Word
i2w :: Int -> Word
i2w = forall a b. (Integral a, Num b) => a -> b
fromIntegral

{-# INLINE w2i #-}
w2i :: Word -> Int
w2i :: Word -> Int
w2i = forall a b. (Integral a, Num b) => a -> b
fromIntegral

{-# INLINE sum' #-}
sum' :: [Word] -> Word
sum' :: [Word] -> Word
sum' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Word
0

{-# INLINE safeTail #-}
safeTail :: [Int] -> [Int]
safeTail :: [Int] -> [Int]
safeTail [Int]
xs = case [Int]
xs of { [] -> [] ; [Int]
_ -> forall a. [a] -> [a]
tail [Int]
xs }

{-# INLINE descendToZero #-}
descendToZero :: Int -> [Int]
descendToZero :: Int -> [Int]
descendToZero !Int
n
  | Int
n forall a. Ord a => a -> a -> Bool
>  Int
0  = Int
n forall a. a -> [a] -> [a]
: Int -> [Int]
descendToZero (Int
nforall a. Num a => a -> a -> a
-Int
1) 
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
0  = [Int
0]
  | Int
n forall a. Ord a => a -> a -> Bool
<  Int
0  = []

{-# INLINE descendToOne #-}
descendToOne :: Int -> [Int]
descendToOne :: Int -> [Int]
descendToOne !Int
n
  | Int
n forall a. Ord a => a -> a -> Bool
>  Int
1  = Int
n forall a. a -> [a] -> [a]
: Int -> [Int]
descendToOne (Int
nforall a. Num a => a -> a -> a
-Int
1) 
  | Int
n forall a. Eq a => a -> a -> Bool
== Int
1  = [Int
1]
  | Int
n forall a. Ord a => a -> a -> Bool
<  Int
1  = []

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