-- | Vector partitions. See:
--
--  * Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 3B.
--

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

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

import Data.Array.Unboxed
import Data.List

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

-- | Integer vectors. The indexing starts from 1.
type IntVector = UArray Int Int

-- | Vector partitions. Basically a synonym for 'fasc3B_algorithm_M'.
vectorPartitions :: IntVector -> [[IntVector]]
vectorPartitions :: IntVector -> [[IntVector]]
vectorPartitions = [Int] -> [[IntVector]]
fasc3B_algorithm_M forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems

_vectorPartitions :: [Int] -> [[[Int]]]
_vectorPartitions :: [Int] -> [[[Int]]]
_vectorPartitions = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [[IntVector]]
fasc3B_algorithm_M

-- | Generates all vector partitions 
--   (\"algorithm M\" in Knuth). 
--   The order is decreasing lexicographic.  
fasc3B_algorithm_M :: [Int] -> [[IntVector]] 
{- note to self: Knuth's descriptions of algorithms are still totally unreadable -}
fasc3B_algorithm_M :: [Int] -> [[IntVector]]
fasc3B_algorithm_M [Int]
xs = forall {a} {a :: * -> * -> *}.
(Ord a, IArray a a, Num a) =>
[[(Int, a, a)]] -> [[a Int a]]
worker [[(Int, Int, Int)]
start] where

  -- n = sum xs
  m :: Int
m = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs

  start :: [(Int, Int, Int)]
start = [ (Int
j,Int
x,Int
x) | (Int
j,Int
x) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Int]
xs ]  
  
  worker :: [[(Int, a, a)]] -> [[a Int a]]
worker stack :: [[(Int, a, a)]]
stack@([(Int, a, a)]
last:[[(Int, a, a)]]
_) = 
    case forall {a} {a}.
(Eq a, Num a) =>
[[(a, a, a)]] -> Maybe [[(a, a, a)]]
decrease [[(Int, a, a)]]
stack' of
      Maybe [[(Int, a, a)]]
Nothing -> [[a Int a]
visited]
      Just [[(Int, a, a)]]
stack'' -> [a Int a]
visited forall a. a -> [a] -> [a]
: [[(Int, a, a)]] -> [[a Int a]]
worker [[(Int, a, a)]]
stack''
    where
      stack' :: [[(Int, a, a)]]
stack'  = forall {c} {a}. (Ord c, Num c) => [[(a, c, c)]] -> [[(a, c, c)]]
subtract_rec [[(Int, a, a)]]
stack
      visited :: [a Int a]
visited = forall a b. (a -> b) -> [a] -> [b]
map forall {a :: * -> * -> *} {e} {b}.
(IArray a e, Num e) =>
[(Int, b, e)] -> a Int e
to_vector [[(Int, a, a)]]
stack'
      
  decrease :: [[(a, a, a)]] -> Maybe [[(a, a, a)]]
decrease ([(a, a, a)]
last:[[(a, a, a)]]
rest) = 
    case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\(a
_,a
_,a
v) -> a
vforall a. Eq a => a -> a -> Bool
==a
0) (forall a. [a] -> [a]
reverse [(a, a, a)]
last) of
      ( [(a, a, a)]
_ , [(a
_,a
_,a
1)] ) -> case [[(a, a, a)]]
rest of
        [] -> forall a. Maybe a
Nothing
        [[(a, a, a)]]
_  -> [[(a, a, a)]] -> Maybe [[(a, a, a)]]
decrease [[(a, a, a)]]
rest
      ( [(a, a, a)]
second , (a
c,a
u,a
v):[(a, a, a)]
first ) -> forall a. a -> Maybe a
Just ([(a, a, a)]
modifiedforall a. a -> [a] -> [a]
:[[(a, a, a)]]
rest) where 
        modified :: [(a, a, a)]
modified =   
          forall a. [a] -> [a]
reverse [(a, a, a)]
first forall a. [a] -> [a] -> [a]
++ 
          (a
c,a
u,a
vforall a. Num a => a -> a -> a
-a
1) forall a. a -> [a] -> [a]
:  
          [ (a
c,a
u,a
u) | (a
c,a
u,a
_) <- forall a. [a] -> [a]
reverse [(a, a, a)]
second ] 
      ([(a, a, a)], [(a, a, a)])
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"fasc3B_algorithm_M: should not happen"
        
  to_vector :: [(Int, b, e)] -> a Int e
to_vector [(Int, b, e)]
cuvs = 
    forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
accumArray (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const) e
0 (Int
1,Int
m)
      [ (Int
c,e
v) | (Int
c,b
_,e
v) <- [(Int, b, e)]
cuvs ] 

  subtract_rec :: [[(a, c, c)]] -> [[(a, c, c)]]
subtract_rec all :: [[(a, c, c)]]
all@([(a, c, c)]
last:[[(a, c, c)]]
_) = 
    case forall {c} {a}. (Ord c, Num c) => [(a, c, c)] -> [(a, c, c)]
subtract [(a, c, c)]
last of 
      []  -> [[(a, c, c)]]
all
      [(a, c, c)]
new -> [[(a, c, c)]] -> [[(a, c, c)]]
subtract_rec ([(a, c, c)]
newforall a. a -> [a] -> [a]
:[[(a, c, c)]]
all) 

  subtract :: [(a, c, c)] -> [(a, c, c)]
subtract [] = []
  subtract full :: [(a, c, c)]
full@((a
c,c
u,c
v):[(a, c, c)]
rest) = 
    if c
w forall a. Ord a => a -> a -> Bool
>= c
v 
      then (a
c,c
w,c
v) forall a. a -> [a] -> [a]
: [(a, c, c)] -> [(a, c, c)]
subtract   [(a, c, c)]
rest
      else           forall {c} {a}. (Eq c, Num c) => [(a, c, c)] -> [(a, c, c)]
subtract_b [(a, c, c)]
full
    where w :: c
w = c
u forall a. Num a => a -> a -> a
- c
v
    
  subtract_b :: [(a, c, c)] -> [(a, c, c)]
subtract_b [] = []
  subtract_b ((a
c,c
u,c
v):[(a, c, c)]
rest) = 
    if c
w forall a. Eq a => a -> a -> Bool
/= c
0 
      then (a
c,c
w,c
w) forall a. a -> [a] -> [a]
: [(a, c, c)] -> [(a, c, c)]
subtract_b [(a, c, c)]
rest
      else           [(a, c, c)] -> [(a, c, c)]
subtract_b [(a, c, c)]
rest
    where w :: c
w = c
u forall a. Num a => a -> a -> a
- c
v

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