{- | Compact representation of integer partitions.

Partitions are conceptually nonincreasing sequences of /positive/ integers.

When the partition fits into a 15x15 rectangle, we encode the parts as nibbles in a single 64-bit word.
The most significant nibble is the first element, and the least significant nibble is used to encode
the length. This way equality and comparison of 64-bit words is the same as the corresponding operations
for partitions (lexicographic ordering).

This will make working with small partitions much more memory efficient (very helpful when
building tables indexed by partitions, for example!) and hopefully quite a bit faster, too.

When they do not fit into a 15x15 rectangle, but fit into 255x7, 255x15, 255x23 or 255x31, respectively,
then we extend the above to use the bytes of 1, 2, 3 or 4 64-bit words.

In the general case, we encode the partition as a list of 64-bit words, each encoding 4 16-bit parts.

Partitions with elements bigger than 65535 are not supported.

Note: This is an internal module, you are not supposed to import it directly.
-}

{-# LANGUAGE BangPatterns, PatternSynonyms, ViewPatterns, ForeignFunctionInterface #-}
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 Math.Combinat.Compositions ( compositions' )


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

data Partition
  = Nibble   {-# UNPACK #-} !Word64
  | Medium1  {-# UNPACK #-} !Word64
  | Medium2  {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
  | Medium3  {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
  | Medium4  {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
  | WordList {-# UNPACK #-} !Int ![Word64]
  deriving (Eq,Show)

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

-- | for debugging
partitionPrefixChar :: Partition -> Char
partitionPrefixChar p = case p of
  Nibble   {} -> 'N'
  Medium1  {} -> '1'
  Medium2  {} -> '2'
  Medium3  {} -> '3'
  Medium4  {} -> '4'
  WordList {} -> 'L'

{- 
instance Show Partition where
  show compact = partitionPrefixChar compact 
               : '<' : intercalate "," (map show $ toList compact) ++ ">"
-}

instance Ord Partition where
  compare = cmp

--------------------------------------------------------------------------------
-- * Pattern synonyms 

-- | Pattern sysnonyms allows us to use existing code with minimal modifications
pattern Nil :: Partition
pattern Nil <- (isEmpty -> True) where
        Nil =  empty

pattern Cons :: Int -> Partition -> Partition
pattern Cons x xs <- (uncons -> Just (x,xs)) where
        Cons x xs = cons x xs

-- | Simulated newtype constructor 
pattern Partition_ :: [Int] -> Partition
pattern Partition_ xs <- (toList -> xs) where
        Partition_ xs = fromDescList xs

pattern Head :: Int -> Partition
pattern Head h <- (height -> h)

pattern Tail :: Partition -> Partition
pattern Tail xs <- (partitionTail -> xs)

pattern Length :: Int -> Partition
pattern Length n <- (width -> n)

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

-- | The lexicographic ordering
cmp :: Partition -> Partition -> Ordering
cmp (Nibble  a)           (Nibble  b)           = compare  a             b
cmp (Medium1 a1)          (Medium1 b1)          = compare  a1            b1
cmp (Medium2 a1 a2)       (Medium2 b1 b2)       = compare (a1,a2)       (b1,b2)
cmp (Medium3 a1 a2 a3)    (Medium3 b1 b2 b3)    = compare (a1,a2,a3)    (b1,b2,b3)
cmp (Medium4 a1 a2 a3 a4) (Medium4 b1 b2 b3 b4) = compare (a1,a2,a3,a4) (b1,b2,b3,b4)
cmp (WordList _ as)       (WordList _ bs)       = compare  as            bs
cmp p                     q                     = compare (toList p)    (toList q)

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

empty :: Partition
empty = Nibble 0

isEmpty :: Partition -> Bool
isEmpty compact = case compact of
  Nibble x -> (x == 0)
  _        -> False

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

singleton :: Int -> Partition
singleton x
  | x == 0      = Nibble 0
  | x <= 15     = Nibble     $ shiftL (i2w x) 60 + 1
  | x <= 255    = Medium1    $ shiftL (i2w x) 56 + 1
  | x <= 65535  = WordList 1 [ shiftL (i2w x) 48 ]
  | otherwise   = error "singleton: partitions with elements bigger than 65535 are not supported"

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

uncons :: Partition -> Maybe (Int,Partition)
uncons compact = case compact of
  Nibble  0           -> Nothing
  Nibble  w           -> Just ( w2i (shiftR w  60) , Nibble $ shiftL (w .&. 0x0ffffffffffffff0) 4 + ((w .&. 15) - 1) )
  Medium1 w1          -> Just ( w2i (shiftR w1 56) , partitionTail compact )
  Medium2 w1 w2       -> Just ( w2i (shiftR w1 56) , partitionTail compact )
  Medium3 w1 w2 w3    -> Just ( w2i (shiftR w1 56) , partitionTail compact )
  Medium4 w1 w2 w3 w4 -> Just ( w2i (shiftR w1 56) , partitionTail compact )
  WordList n (w:rest) -> Just ( w2i (shiftR w  48) , partitionTail compact )

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

-- | @partitionTail p == snd (uncons p)@
partitionTail :: Partition -> Partition
partitionTail compact = case compact of

  Nibble  0 -> Nibble 0
  Nibble  w -> Nibble $ shiftL (w .&. 0x0ffffffffffffff0) 4 + ((w .&. 15) - 1)

  Medium1 w1 ->
    let !y = (shiftR w1 48) .&. 255     -- next element
        !n = w1 .&. 15
    in  if y <= 15
          then makeNibble (w2i $ n-1) $ safeTail $ toList compact
          else Medium1    $ shiftL (w1 .&. 0x00ffffffffffff00) 8 + (n-1)

  Medium2 w1 w2 ->
    let !y = (shiftR w1 48) .&. 255
        !n = w2 .&. 255
    in  if y <= 15
          then makeNibble (w2i $ n-1) $ safeTail $ toList compact
          else if n <= 8
            then Medium1 $ shiftL (w1 .&. 0x00ffffffffffffff) 8 + shiftL (shiftR w2 56) 8 + (n-1)

            else Medium2 ( shiftL  w1 8 + shiftR w2 56 )
                         ( shiftL (w2 .&. 0x00ffffffffffff00) 8 + (n-1) )

  Medium3 w1 w2 w3 ->
    let !y = (shiftR w1 48) .&. 255
        !n = w3 .&. 255
    in  if y <= 15 && n <= 16
          then makeNibble (w2i $ n-1) $ safeTail $ toList compact
          else if n <= 16
            then Medium2 ( shiftL  w1 8 + shiftR w2 56 )
                         ( shiftL  w2 8 + shiftR w3 56 + shiftL (shiftR w3 56) 8 + (n-1) )

            else Medium3 ( shiftL  w1 8 + shiftR w2 56 )
                         ( shiftL  w2 8 + shiftR w3 56 )
                         ( shiftL (w3 .&. 0x00ffffffffffff00) 8 + (n-1) )

  _ ->
    let n = width compact
    in  fromDescList' (n-1) $ safeTail $ toList compact

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

-- | We assume that @x >= partitionHeight p@!
cons :: Int -> Partition -> Partition
cons !x !compact = case compact of

  Nibble 0                -> singleton x

  Nibble word
    | x <= 15  && n < 15  -> Nibble $ shiftR word 4 + shiftL xw 60 + (n+1)
    | x <= 255            -> makeMedium   (w2i $ n+1) (x : toList compact)
    | otherwise           -> makeWordList (w2i $ n+1) (x : toList compact)
    where
      n  = word .&. 15
      xw = i2w x

  Medium1 w1
    | x <= 255 && n < 7   -> Medium1 (shiftR w1 8 + shiftL xw 56 + (n+1))
    | x <= 255            -> Medium2 (shiftR w1 8 + shiftL xw 56        ) 8
    | otherwise           -> makeWordList (w2i $ n+1) (x : toList compact)
    where
      n  = w1 .&. 255
      xw = i2w x

  Medium2 w1 w2
    | x <= 255 && n < 15  -> Medium2 (shiftR w1 8 + shiftL xw 56) (shiftR w2 8 + shiftL (w1 .&. 255) 56 + (n+1))
    | x <= 255            -> Medium3 (shiftR w1 8 + shiftL xw 56) (shiftR w2 8 + shiftL (w1 .&. 255) 56        ) 16
    | otherwise           -> makeWordList (w2i $ n+1) (x : toList compact)
    where
      n  = w2 .&. 255
      xw = i2w x

  Medium3 w1 w2 w3
    | x <= 255 && n < 23  -> Medium3 (shiftR w1 8 + shiftL xw 56) (shiftR w2 8 + shiftL (w1 .&. 255) 56) (shiftR w3 8 + shiftL (w2 .&. 255) 56 + (n+1))
    | x <= 255            -> Medium4 (shiftR w1 8 + shiftL xw 56) (shiftR w2 8 + shiftL (w1 .&. 255) 56) (shiftR w3 8 + shiftL (w2 .&. 255) 56        ) 24
    | otherwise           -> makeWordList (w2i $ n+1) (x : toList compact)
    where
      n  = w3 .&. 255
      xw = i2w x

  Medium4 w1 w2 w3 w4
    | x <= 255 && n < 31  -> Medium4 (shiftR w1 8 + shiftL  xw          56)
                                     (shiftR w2 8 + shiftL (w1 .&. 255) 56)
                                     (shiftR w3 8 + shiftL (w2 .&. 255) 56)
                                     (shiftR w4 8 + shiftL (w3 .&. 255) 56 + (n+1))
    | otherwise           -> makeWordList (w2i $ n+1) (x : toList compact)
    where
      n = w4 .&. 255
      xw = i2w x

  _ ->
    let n = width compact
    in  fromDescList' (n+1) (x : toList compact)

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

-- | We assume that the element is not bigger than the last element!
snoc :: Partition -> Int -> Partition
snoc !compact  0 = compact
snoc !compact !x = case compact of

  Nibble 0 -> singleton x

  Nibble word
    | n < 15    -> Nibble $ (word + 1) .|. shiftL (i2w x) ((15-n)*4)
    | otherwise -> makeMedium (n+1) (toList compact ++ [x])
    where
      n = w2i (word .&. 15)

  Medium1 w1
    | n < 7     -> Medium1 $ (w1 + 1) .|. shiftL (i2w x) ((7-n)*8)
    | otherwise -> Medium2 ((w1 .&. 0xffffffffffffff00) + i2w x) 8
    where
      n = w2i (w1 .&. 255)

  Medium2 w1 w2
    | n < 15    -> Medium2 w1 $ (w2 + 1) .|. shiftL (i2w x) ((15-n)*8)
    | otherwise -> Medium3 w1 ((w2 .&. 0xffffffffffffff00) + i2w x) 16
    where
      n = w2i (w2 .&. 255)

  Medium3 w1 w2 w3
    | n < 23    -> Medium3 w1 w2 $ (w3 + 1) .|. shiftL (i2w x) ((23-n)*8)
    | otherwise -> Medium4 w1 w2 ((w3 .&. 0xffffffffffffff00) + i2w x) 24
    where
      n = w2i (w3 .&. 255)

  Medium4 w1 w2 w3 w4
    | n < 31    -> Medium4 w1 w2 w3 $ (w4 + 1) .|. shiftL (i2w x) ((31-n)*8)
    | otherwise -> makeWordList (n + 1) (toList compact ++ [x])
    where
      n = w2i (w4 .&. 255)

  WordList n list -> WordList (n+1) (go list) where
    go :: [Word64] -> [Word64]
    go (w:[]) = case mod n 4 of
                  0 -> w : shiftL (i2w x) 48 : []
                  1 -> w + shiftL (i2w x) 32 : []
                  2 -> w + shiftL (i2w x) 16 : []
                  3 -> w +        (i2w x)    : []
    go (w:ws) = w : go ws
    go []     = shiftL (i2w x) 48 : []

{-   
  _ -> 
    let n = width compact
    in  makeWordList (n+1) (toList compact ++ [x])
-}

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

toExponentialForm :: Partition -> [(Int,Int)]
toExponentialForm = map (\xs -> (head xs,length xs)) . group . toAscList

fromExponentialForm :: [(Int,Int)] -> Partition
fromExponentialForm = fromDescList . concatMap f . sortBy g where
  f (!i,!e) = replicate e i
  g (!i, _) (!j,_) = compare j i

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

-- | Width, or the number of parts
width :: Partition -> Int
width compact = case compact of
  Nibble        word -> w2i (word .&.  15)
  Medium1       word -> w2i (word .&. 255)
  Medium2 _     word -> w2i (word .&. 255)
  Medium3 _ _   word -> w2i (word .&. 255)
  Medium4 _ _ _ word -> w2i (word .&. 255)
  WordList n    _    -> n

-- | Height, or the first (that is, the largest) element
height :: Partition -> Int
height compact = case compact of
  Nibble  word        -> w2i (shiftR word 60)
  Medium1 word        -> w2i (shiftR word 56)
  Medium2 word _      -> w2i (shiftR word 56)
  Medium3 word _ _    -> w2i (shiftR word 56)
  Medium4 word _ _ _  -> w2i (shiftR word 56)
  WordList _ (word:_) -> w2i (shiftR word 48)

-- | Width and height 
widthHeight :: Partition -> (Int,Int)
widthHeight compact = case compact of
  Nibble  word            -> ( w2i (word  .&.  15) , w2i (shiftR word  60) )
  Medium1 word            -> ( w2i (word  .&. 255) , w2i (shiftR word  56) )
  Medium2 word1     word2 -> ( w2i (word2 .&. 255) , w2i (shiftR word1 56) )
  Medium3 word1 _   word3 -> ( w2i (word3 .&. 255) , w2i (shiftR word1 56) )
  Medium4 word1 _ _ word4 -> ( w2i (word4 .&. 255) , w2i (shiftR word1 56) )
  WordList n (word:_)     -> ( n                   , w2i (shiftR word  48) )

--------------------------------------------------------------------------------
-- * 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 compact = case compact of

  Nibble 0 -> []

  Nibble w ->
    let !nw = (w .&. 15)
        !w' = w - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w (60 - i*4) - shiftR w' (56 - i*4)) .&. 15 | i<-[0..n-1] ]

  Medium1 w ->
    let !nw = (w .&. 255)
        !w' = w - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w (56 - i*8) - shiftR w' (48 - i*8)) .&. 255 | i<-[0..n-1] ]

  Medium2 w1 w2 ->
    let !nw = (w2 .&. 255)
        !w2' = w2 - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w1 (56 - i*8) - shiftR w1  (48 - i*8)) .&. 255 | i<-[0..6]   ] ++
        ( w2i $ (       w1            - shiftR w2   56       ) .&. 255               ) :
        [ w2i $ (shiftR w2 (56 - i*8) - shiftR w2' (48 - i*8)) .&. 255 | i<-[0..n-9] ]

  Medium3 w1 w2 w3 ->
    let !nw = (w3 .&. 255)
        !w3' = w3 - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w1 (56 - i*8) - shiftR w1  (48 - i*8)) .&. 255 | i<-[0..6]    ] ++
        ( w2i $ (       w1            - shiftR w2   56       ) .&. 255                ) :
        [ w2i $ (shiftR w2 (56 - i*8) - shiftR w2  (48 - i*8)) .&. 255 | i<-[0..6]    ] ++
        ( w2i $ (       w2            - shiftR w3   56       ) .&. 255                ) :
        [ w2i $ (shiftR w3 (56 - i*8) - shiftR w3' (48 - i*8)) .&. 255 | i<-[0..n-17] ]

  Medium4 w1 w2 w3 w4 ->
    let !nw = (w4 .&. 255)
        !w4' = w4 - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w1 (56 - i*8) - shiftR w1  (48 - i*8)) .&. 255 | i<-[0..6]    ] ++
        ( w2i $ (       w1            - shiftR w2   56       ) .&. 255                ) :
        [ w2i $ (shiftR w2 (56 - i*8) - shiftR w2  (48 - i*8)) .&. 255 | i<-[0..6]    ] ++
        ( w2i $ (       w2            - shiftR w3   56       ) .&. 255                ) :
        [ w2i $ (shiftR w3 (56 - i*8) - shiftR w3  (48 - i*8)) .&. 255 | i<-[0..6]    ] ++
        ( w2i $ (       w3            - shiftR w4   56       ) .&. 255                ) :
        [ w2i $ (shiftR w4 (56 - i*8) - shiftR w4' (48 - i*8)) .&. 255 | i<-[0..n-25] ]

  WordList {} -> go (toList compact) where
    go (x:ys@(y:_)) = (x-y) : go ys
    go [x] = [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 compact = case compact of

  Nibble 0 -> []

  Nibble w ->
    let !nw = (w .&. 15)
        !w' = w - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w (60 - i*4) - shiftR w' (56 - i*4)) .&. 15 | i<-toZero (n-1) ]

  Medium1 w ->
    let !nw = (w .&. 255)
        !w' = w - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w (56 - i*8) - shiftR w' (48 - i*8)) .&. 255 | i<-toZero (n-1) ]

  Medium2 w1 w2 ->
    let !nw = (w2 .&. 255)
        !w2' = w2 - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w2 (56 - i*8) - shiftR w2' (48 - i*8)) .&. 255 | i<-toZero (n-9) ] ++
        ( w2i $ (       w1            - shiftR w2   56       ) .&. 255                   ) :
        [ w2i $ (shiftR w1 (56 - i*8) - shiftR w1  (48 - i*8)) .&. 255 | i<-toZero 6     ]

  Medium3 w1 w2 w3 ->
    let !nw = (w3 .&. 255)
        !w3' = w3 - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w3 (56 - i*8) - shiftR w3' (48 - i*8)) .&. 255 | i<-toZero (n-17) ] ++
        ( w2i $ (       w2            - shiftR w3   56       ) .&. 255                    ) :
        [ w2i $ (shiftR w2 (56 - i*8) - shiftR w2  (48 - i*8)) .&. 255 | i<-toZero 6      ] ++
        ( w2i $ (       w1            - shiftR w2   56       ) .&. 255                    ) :
        [ w2i $ (shiftR w1 (56 - i*8) - shiftR w1  (48 - i*8)) .&. 255 | i<-toZero 6      ]

  Medium4 w1 w2 w3 w4 ->
    let !nw = (w4 .&. 255)
        !w4' = w4 - nw
        !n  = w2i nw
    in  [ w2i $ (shiftR w4 (56 - i*8) - shiftR w4' (48 - i*8)) .&. 255 | i<-toZero (n-25) ] ++
        ( w2i $ (       w3            - shiftR w4   56       ) .&. 255                    ) :
        [ w2i $ (shiftR w3 (56 - i*8) - shiftR w3  (48 - i*8)) .&. 255 | i<-toZero 6      ] ++
        ( w2i $ (       w2            - shiftR w3   56       ) .&. 255                    ) :
        [ w2i $ (shiftR w2 (56 - i*8) - shiftR w2  (48 - i*8)) .&. 255 | i<-toZero 6      ] ++
        ( w2i $ (       w1            - shiftR w2   56       ) .&. 255                    ) :
        [ w2i $ (shiftR w1 (56 - i*8) - shiftR w1  (48 - i*8)) .&. 255 | i<-toZero 6      ]

  WordList {} -> (h : go asclist) where
    asclist@(h:_) = toAscList compact
    go (x:ys@(y:_)) = (y-x) : go ys
    go [_] = []
    go []  = []

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

foreign import ccall unsafe "c_dual_nibble" c_dual_nibble :: Word64 -> Word64

dualPartition :: Partition -> Partition
dualPartition compact = case compact of

  Nibble 0 -> Nibble 0
  Nibble w -> Nibble (c_dual_nibble w)
  _        -> if (w <= 255 && h <= 31)
                then makeMedium   h dualList
                else makeWordList h dualList
  where
    (w,h) = widthHeight compact
    dualList = concat
      [ replicate d j
      | (j,d) <- zip (toOne w) (reverseDiffSequence compact)
      ]

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

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

-- | returns a descending (non-increasing) list
toDescList :: Partition -> [Int]
toDescList compact = case compact of

  Nibble 0 -> []

  Nibble word ->
    let !n = w2i (word .&. 15)
    in  [ w2i (shiftR word  (60 - i*4) .&. 15 ) | i<-[0..n-1] ]

  Medium1 word1 ->
    let !n = w2i (word1 .&. 255)
    in  [ w2i (shiftR word1 (56 - i*8) .&. 255) | i<-[0..n-1] ]

  Medium2 word1 word2 ->
    let !n = w2i (word2 .&. 255)
    in  [ w2i (shiftR word1 (56 - i*8) .&. 255) | i<-[0..7]   ] ++
        [ w2i (shiftR word2 (56 - i*8) .&. 255) | i<-[0..n-9] ]

  Medium3 word1 word2 word3 ->
    let !n = w2i (word3 .&. 255)
    in  [ w2i (shiftR word1 (56 - i*8) .&. 255) | i<-[0..7]    ] ++
        [ w2i (shiftR word2 (56 - i*8) .&. 255) | i<-[0..7]    ] ++
        [ w2i (shiftR word3 (56 - i*8) .&. 255) | i<-[0..n-17] ]

  Medium4 word1 word2 word3 word4 ->
    let !n = w2i (word4 .&. 255)
    in  [ w2i (shiftR word1 (56 - i*8) .&. 255) | i<-[0..7]    ] ++
        [ w2i (shiftR word2 (56 - i*8) .&. 255) | i<-[0..7]    ] ++
        [ w2i (shiftR word3 (56 - i*8) .&. 255) | i<-[0..7]    ] ++
        [ w2i (shiftR word4 (56 - i*8) .&. 255) | i<-[0..n-25] ]

  WordList _ list -> go list where
    go :: [Word64] -> [Int]
    go !wlist = case wlist of
      (!w):(!ws) -> case ws of
        (_:_)      -> w2i (shiftR w 48          ) :
                      w2i (shiftR w 32 .&. 65535) :
                      w2i (shiftR w 16 .&. 65535) :
                      w2i (       w    .&. 65535) : go ws
        []         -> takeWhile (/=0) (fromWord w)
      []         -> []

    fromWord :: Word64 -> [Int]
    fromWord !word =
      [ w2i (shiftR word 48          )
      , w2i (shiftR word 32 .&. 65535)
      , w2i (shiftR word 16 .&. 65535)
      , w2i (       word    .&. 65535)
      ]

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

-- | Returns a reversed (ascending; non-decreasing) list
toAscList :: Partition -> [Int]
toAscList compact = case compact of

  Nibble 0 -> []

  Nibble word ->
    let !n = w2i (word .&. 15)
    in  [ w2i (shiftR word  (60 - i*4) .&. 15 ) | i<-toZero (n-1) ]

  Medium1 word1 ->
    let !n = w2i (word1 .&. 255)
    in  [ w2i (shiftR word1 (56 - i*8) .&. 255) | i<-toZero (n-1) ]

  Medium2 word1 word2 ->
    let !n = w2i (word2 .&. 255)
    in  [ w2i (shiftR word2 (56 - i*8) .&. 255) | i<-toZero (n-9) ] ++
        [ w2i (shiftR word1 (56 - i*8) .&. 255) | i<-toZero 7     ]

  Medium3 word1 word2 word3 ->
    let !n = w2i (word3 .&. 255)
    in  [ w2i (shiftR word3 (56 - i*8) .&. 255) | i<-toZero (n-17) ] ++
        [ w2i (shiftR word2 (56 - i*8) .&. 255) | i<-toZero 7      ] ++
        [ w2i (shiftR word1 (56 - i*8) .&. 255) | i<-toZero 7      ]

  Medium4 word1 word2 word3 word4 ->
    let !n = w2i (word4 .&. 255)
    in  [ w2i (shiftR word4 (56 - i*8) .&. 255) | i<-toZero (n-25) ] ++
        [ w2i (shiftR word3 (56 - i*8) .&. 255) | i<-toZero 7      ] ++
        [ w2i (shiftR word2 (56 - i*8) .&. 255) | i<-toZero 7      ] ++
        [ w2i (shiftR word1 (56 - i*8) .&. 255) | i<-toZero 7      ]

  WordList _ list -> dropWhile (==0) $ go (reverse list) where
    go :: [Word64] -> [Int]
    go !wlist = case wlist of
      (!w):ws -> w2i (       w    .&. 65535) :
                 w2i (shiftR w 16 .&. 65535) :
                 w2i (shiftR w 32 .&. 65535) :
                 w2i (shiftR w 48          ) : go ws
      [] -> []

{-
    go :: [Word64] -> [Int]
    go (w:[]) = fromWord w
    go (w:ws) = fromWord w ++ go ws
    go []     = []
    fromWord :: Word64 -> [Int]
    fromWord word = [ w2i (shiftR word (48 - i*16) .&. 65535) | i<-toZero 3 ] 
-}

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

fromDescList :: [Int] -> Partition
fromDescList list = fromDescList' (length list) list

-- | We assume that the input is a non-increasing list of /positive/ integers!
fromDescList'
  :: Int          -- ^ length
  -> [Int]        -- ^ the list
  -> Partition
fromDescList' !n !list =
  case list of
    []                           -> empty
    (h:_) | h <= 0               -> empty
          | h <= 15 && n <= 15   -> makeNibble   n list
          | h >  65535           -> error "partitions with elements bigger than 65535 are not supported"
          | h >  255 || n > 31   -> makeWordList n list
          | otherwise            -> makeMedium   n list

makeNibble :: Int -> [Int] -> Partition
makeNibble !n list = Nibble $ go (i2w n) 60 list where
  go !acc !k (x:xs) = go (acc + shiftL (i2w x) k) (k-4) xs
  go !acc _  []     = acc
{-   
makeNibble :: Int -> [Int] -> Partition
makeNibble !n list = Nibble 
  $ sum' [ shiftL (i2w x) (60 - 4*i) | (i,x) <- zip [0..] list ] 
  + i2w n
-}

makeMedium :: Int -> [Int] -> Partition
makeMedium !n list
  | n <= 7   = makeMedium1 n list
  | n <= 15  = makeMedium2 n list
  | n <= 23  = makeMedium3 n list
  | n <= 31  = makeMedium4 n list
  | otherwise = error "makeMedium: input list too big (should be smaller than 32)"

makeMedium1 :: Int -> [Int] -> Partition
makeMedium1 !n list = Medium1
  $ sum' [ shiftL (fromIntegral x) (56 - 8*i) | (i,x) <- zip [0..] list ]
  + fromIntegral n

makeMedium2 :: Int -> [Int] -> Partition
makeMedium2 !n list = Medium2 word1 word2 where
  (list1,list2) = splitAt 8 list
  word1 = sum' [ shiftL (i2w x) (56 - 8*i) | (i,x) <- zip [0..] list1 ]
  word2 = sum' [ shiftL (i2w x) (56 - 8*i) | (i,x) <- zip [0..] list2 ]
        + fromIntegral n

makeMedium3 :: Int -> [Int] -> Partition
makeMedium3 !n list = Medium3 word1 word2 word3 where
  (list1,tmp  ) = splitAt 8 list
  (list2,list3) = splitAt 8 tmp
  word1 = sum' [ shiftL (i2w x) (56 - 8*i) | (i,x) <- zip [0..] list1 ]
  word2 = sum' [ shiftL (i2w x) (56 - 8*i) | (i,x) <- zip [0..] list2 ]
  word3 = sum' [ shiftL (i2w x) (56 - 8*i) | (i,x) <- zip [0..] list3 ]
        + i2w n

makeMedium4 :: Int -> [Int] -> Partition
makeMedium4 !n list = Medium4 word1 word2 word3 word4 where
  (list1,tmp1 ) = splitAt 8 list
  (list2,tmp2 ) = splitAt 8 tmp1
  (list3,list4) = splitAt 8 tmp2
  word1 = sum' [ shiftL (i2w x) (56 - 8*i) | (i,x) <- zip [0..] list1 ]
  word2 = sum' [ shiftL (i2w x) (56 - 8*i) | (i,x) <- zip [0..] list2 ]
  word3 = sum' [ shiftL (i2w x) (56 - 8*i) | (i,x) <- zip [0..] list3 ]
  word4 = sum' [ shiftL (i2w x) (56 - 8*i) | (i,x) <- zip [0..] list4 ]
        + i2w n

makeWordList :: Int -> [Int] -> Partition
makeWordList !n list = WordList n (go list) where
  go :: [Int] -> [Word64]
  go !xs = case xs of
    (x:y:z:w:rest) -> makeWord x y z w : go rest
    (x:y:z:  []  ) -> makeWord x y z 0 : []
    (x:y:    []  ) -> makeWord x y 0 0 : []
    (x:      []  ) -> makeWord x 0 0 0 : []
    []             -> []
  makeWord !x !y !z !w = shiftL (i2w x) 48
                       + shiftL (i2w y) 32
                       + shiftL (i2w z) 16
                       +        (i2w w)
{-
  go [] = []
  go xs = case splitAt 4 xs of
    (this,rest) -> case rest of
      [] -> makeWord (take 4 $ this ++ repeat 0) : []
      _  -> makeWord this : go rest
  makeWord [x,y,z,w] = shiftL (i2w x) 48  
                     + shiftL (i2w y) 32  
                     + shiftL (i2w z) 16 
                     +        (i2w w)
-}

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

isSubPartitionOf :: Partition -> Partition -> Bool
isSubPartitionOf p q = case (p,q) of

  (Nibble 0 , _       ) -> True

  (Nibble u , Nibble v) -> let !n = w2i (u .&. 15)
                           in  and [    (shiftR u (60 - i*4) .&. 15)
                                     <= (shiftR v (60 - i*4) .&. 15)
                                   | i<-[0..n-1]
                                   ]

  _                     -> and $ zipWith (<=) (toList p) (toList q ++ repeat 0)

dominates :: Partition -> Partition -> Bool
dominates q p = case (q,p) of

  (_        , Nibble 0 ) -> True

  (Nibble v , Nibble u ) -> go 60 0 0 where
                              n = u .&. 15
                              klimit = w2i (4*(15-n))
                              go !k !b !a = if k <= klimit
                                then True
                                else let !b' = b + (shiftR v k .&. 15)
                                         !a' = a + (shiftR u k .&. 15)
                                     in  if b' < a'
                                           then False
                                           else go (k-4) b' a'

  _                      -> and $ zipWith (>=) (sums $ toList q ++ repeat 0) (sums $ toList p) where
                              sums = tail . scanl' (+) 0

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

-- | 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 -> Word64
i2w = fromIntegral

{-# INLINE w2i #-}
w2i :: Word64 -> Int
w2i = fromIntegral

{-# INLINE sum' #-}
sum' :: [Word64] -> Word64
sum' = foldl' (+) 0

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

{-# INLINE toZero #-}
toZero :: Int -> [Int]
toZero !n
  | n >  0  = n : toZero (n-1)
  | n == 0  = [0]
  | n <  0  = []

{-# INLINE toOne #-}
toOne :: Int -> [Int]
toOne !n
  | n >  1  = n : toOne (n-1)
  | n == 1  = [1]
  | n <  1  = []

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