{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Math.Combinatorics.Multiset
(
Count
, Multiset(..)
, emptyMS, singletonMS
, consMS, (+:)
, toList
, fromList
, fromListEq
, fromDistinctList
, fromCounts
, getCounts
, size
, disjUnion
, disjUnions
, permutations
, permutationsRLE
, Vec
, vPartitions
, partitions
, splits
, kSubsets
, cycles
, bracelets
, genFixedBracelets
, sequenceMS
) where
import Control.Arrow (first, second, (&&&), (***))
import Control.Monad (forM_, when)
import Control.Monad.Trans.Writer
import qualified Data.IntMap.Strict as IM
import Data.List (group, partition, sort)
import Data.Maybe (catMaybes, fromJust)
type Count = Int
newtype Multiset a = MS { forall a. Multiset a -> [(a, Int)]
toCounts :: [(a, Count)] }
deriving (Int -> Multiset a -> ShowS
[Multiset a] -> ShowS
Multiset a -> String
(Int -> Multiset a -> ShowS)
-> (Multiset a -> String)
-> ([Multiset a] -> ShowS)
-> Show (Multiset a)
forall a. Show a => Int -> Multiset a -> ShowS
forall a. Show a => [Multiset a] -> ShowS
forall a. Show a => Multiset a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Multiset a -> ShowS
showsPrec :: Int -> Multiset a -> ShowS
$cshow :: forall a. Show a => Multiset a -> String
show :: Multiset a -> String
$cshowList :: forall a. Show a => [Multiset a] -> ShowS
showList :: [Multiset a] -> ShowS
Show, (forall a b. (a -> b) -> Multiset a -> Multiset b)
-> (forall a b. a -> Multiset b -> Multiset a) -> Functor Multiset
forall a b. a -> Multiset b -> Multiset a
forall a b. (a -> b) -> Multiset a -> Multiset b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Multiset a -> Multiset b
fmap :: forall a b. (a -> b) -> Multiset a -> Multiset b
$c<$ :: forall a b. a -> Multiset b -> Multiset a
<$ :: forall a b. a -> Multiset b -> Multiset a
Functor)
fromCounts :: [(a, Count)] -> Multiset a
fromCounts :: forall a. [(a, Int)] -> Multiset a
fromCounts = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS
getCounts :: Multiset a -> [Count]
getCounts :: forall a. Multiset a -> [Int]
getCounts = ((a, Int) -> Int) -> [(a, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (a, Int) -> Int
forall a b. (a, b) -> b
snd ([(a, Int)] -> [Int])
-> (Multiset a -> [(a, Int)]) -> Multiset a -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Multiset a -> [(a, Int)]
forall a. Multiset a -> [(a, Int)]
toCounts
size :: Multiset a -> Int
size :: forall a. Multiset a -> Int
size = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Multiset a -> [Int]) -> Multiset a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Multiset a -> [Int]
forall a. Multiset a -> [Int]
getCounts
liftMS :: ([(a, Count)] -> [(b, Count)]) -> Multiset a -> Multiset b
liftMS :: forall a b. ([(a, Int)] -> [(b, Int)]) -> Multiset a -> Multiset b
liftMS [(a, Int)] -> [(b, Int)]
f (MS [(a, Int)]
m) = [(b, Int)] -> Multiset b
forall a. [(a, Int)] -> Multiset a
MS ([(a, Int)] -> [(b, Int)]
f [(a, Int)]
m)
emptyMS :: Multiset a
emptyMS :: forall a. Multiset a
emptyMS = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS []
singletonMS :: a -> Multiset a
singletonMS :: forall a. a -> Multiset a
singletonMS a
a = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS [(a
a,Int
1)]
consMS :: (a, Count) -> Multiset a -> Multiset a
consMS :: forall a. (a, Int) -> Multiset a -> Multiset a
consMS e :: (a, Int)
e@(a
_,Int
c) (MS [(a, Int)]
m)
| Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS ((a, Int)
e(a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
:[(a, Int)]
m)
| Bool
otherwise = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS [(a, Int)]
m
(+:) :: (a, Count) -> Multiset a -> Multiset a
+: :: forall a. (a, Int) -> Multiset a -> Multiset a
(+:) = (a, Int) -> Multiset a -> Multiset a
forall a. (a, Int) -> Multiset a -> Multiset a
consMS
toList :: Multiset a -> [a]
toList :: forall a. Multiset a -> [a]
toList = [(a, Int)] -> [a]
forall a. [(a, Int)] -> [a]
expandCounts ([(a, Int)] -> [a])
-> (Multiset a -> [(a, Int)]) -> Multiset a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Multiset a -> [(a, Int)]
forall a. Multiset a -> [(a, Int)]
toCounts
expandCounts :: [(a, Count)] -> [a]
expandCounts :: forall a. [(a, Int)] -> [a]
expandCounts = ((a, Int) -> [a]) -> [(a, Int)] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((a -> Int -> [a]) -> (a, Int) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Int -> a -> [a]) -> a -> Int -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> a -> [a]
forall a. Int -> a -> [a]
replicate))
fromList :: Ord a => [a] -> Multiset a
fromList :: forall a. Ord a => [a] -> Multiset a
fromList = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
fromCounts ([(a, Int)] -> Multiset a)
-> ([a] -> [(a, Int)]) -> [a] -> Multiset a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> (a, Int)) -> [[a]] -> [(a, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ([a] -> a
forall a. HasCallStack => [a] -> a
head ([a] -> a) -> ([a] -> Int) -> [a] -> (a, Int)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([[a]] -> [(a, Int)]) -> ([a] -> [[a]]) -> [a] -> [(a, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
group ([a] -> [[a]]) -> ([a] -> [a]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. Ord a => [a] -> [a]
sort
fromListEq :: Eq a => [a] -> Multiset a
fromListEq :: forall a. Eq a => [a] -> Multiset a
fromListEq = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
fromCounts ([(a, Int)] -> Multiset a)
-> ([a] -> [(a, Int)]) -> [a] -> Multiset a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [(a, Int)]
forall {a}. Eq a => [a] -> [(a, Int)]
fromListEq'
where fromListEq' :: [a] -> [(a, Int)]
fromListEq' [] = []
fromListEq' (a
x:[a]
xs) = (a
x, Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xEqs) (a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
: [a] -> [(a, Int)]
fromListEq' [a]
xNeqs
where
([a]
xEqs, [a]
xNeqs) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
x) [a]
xs
fromDistinctList :: [a] -> Multiset a
fromDistinctList :: forall a. [a] -> Multiset a
fromDistinctList = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
fromCounts ([(a, Int)] -> Multiset a)
-> ([a] -> [(a, Int)]) -> [a] -> Multiset a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (a, Int)) -> [a] -> [(a, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a
x,Int
1))
disjUnion :: Multiset a -> Multiset a -> Multiset a
disjUnion :: forall a. Multiset a -> Multiset a -> Multiset a
disjUnion (MS [(a, Int)]
xs) (MS [(a, Int)]
ys) = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS ([(a, Int)]
xs [(a, Int)] -> [(a, Int)] -> [(a, Int)]
forall a. [a] -> [a] -> [a]
++ [(a, Int)]
ys)
disjUnions :: [Multiset a] -> Multiset a
disjUnions :: forall a. [Multiset a] -> Multiset a
disjUnions = (Multiset a -> Multiset a -> Multiset a)
-> Multiset a -> [Multiset a] -> Multiset a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Multiset a -> Multiset a -> Multiset a
forall a. Multiset a -> Multiset a -> Multiset a
disjUnion ([(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS [])
data RMultiset a = RMS (Maybe (a, Count)) [(a,Count)]
deriving Int -> RMultiset a -> ShowS
[RMultiset a] -> ShowS
RMultiset a -> String
(Int -> RMultiset a -> ShowS)
-> (RMultiset a -> String)
-> ([RMultiset a] -> ShowS)
-> Show (RMultiset a)
forall a. Show a => Int -> RMultiset a -> ShowS
forall a. Show a => [RMultiset a] -> ShowS
forall a. Show a => RMultiset a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> RMultiset a -> ShowS
showsPrec :: Int -> RMultiset a -> ShowS
$cshow :: forall a. Show a => RMultiset a -> String
show :: RMultiset a -> String
$cshowList :: forall a. Show a => [RMultiset a] -> ShowS
showList :: [RMultiset a] -> ShowS
Show
toRMS :: Multiset a -> RMultiset a
toRMS :: forall a. Multiset a -> RMultiset a
toRMS = Maybe (a, Int) -> [(a, Int)] -> RMultiset a
forall a. Maybe (a, Int) -> [(a, Int)] -> RMultiset a
RMS Maybe (a, Int)
forall a. Maybe a
Nothing ([(a, Int)] -> RMultiset a)
-> (Multiset a -> [(a, Int)]) -> Multiset a -> RMultiset a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Multiset a -> [(a, Int)]
forall a. Multiset a -> [(a, Int)]
toCounts
fromRMS :: RMultiset a -> Multiset a
fromRMS :: forall a. RMultiset a -> Multiset a
fromRMS (RMS Maybe (a, Int)
Nothing [(a, Int)]
m) = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS [(a, Int)]
m
fromRMS (RMS (Just (a, Int)
e) [(a, Int)]
m) = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS ((a, Int)
e(a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
:[(a, Int)]
m)
permutations :: Multiset a -> [[a]]
permutations :: forall a. Multiset a -> [[a]]
permutations = ([(a, Int)] -> [a]) -> [[(a, Int)]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [(a, Int)] -> [a]
forall a. [(a, Int)] -> [a]
expandCounts ([[(a, Int)]] -> [[a]])
-> (Multiset a -> [[(a, Int)]]) -> Multiset a -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Multiset a -> [[(a, Int)]]
forall a. Multiset a -> [[(a, Int)]]
permutationsRLE
permutationsRLE :: Multiset a -> [[(a,Count)]]
permutationsRLE :: forall a. Multiset a -> [[(a, Int)]]
permutationsRLE (MS []) = [[]]
permutationsRLE Multiset a
m = RMultiset a -> [[(a, Int)]]
forall a. RMultiset a -> [[(a, Int)]]
permutationsRLE' (Multiset a -> RMultiset a
forall a. Multiset a -> RMultiset a
toRMS Multiset a
m)
permutationsRLE' :: RMultiset a -> [[(a,Count)]]
permutationsRLE' :: forall a. RMultiset a -> [[(a, Int)]]
permutationsRLE' (RMS Maybe (a, Int)
Nothing [(a
x,Int
n)]) = [[(a
x,Int
n)]]
permutationsRLE' RMultiset a
m = [ (a, Int)
e (a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
: [(a, Int)]
p
| ((a, Int)
e, RMultiset a
m') <- RMultiset a -> [((a, Int), RMultiset a)]
forall a. RMultiset a -> [((a, Int), RMultiset a)]
selectRMS RMultiset a
m
, [(a, Int)]
p <- RMultiset a -> [[(a, Int)]]
forall a. RMultiset a -> [[(a, Int)]]
permutationsRLE' RMultiset a
m'
]
selectRMS :: RMultiset a -> [((a, Count), RMultiset a)]
selectRMS :: forall a. RMultiset a -> [((a, Int), RMultiset a)]
selectRMS (RMS Maybe (a, Int)
_ []) = []
selectRMS (RMS Maybe (a, Int)
e ((a
x,Int
n) : [(a, Int)]
ms)) =
((a
x,Int
n), Maybe (a, Int) -> [(a, Int)] -> RMultiset a
forall a. Maybe (a, Int) -> [(a, Int)] -> RMultiset a
RMS Maybe (a, Int)
forall a. Maybe a
Nothing ([(a, Int)]
-> ((a, Int) -> [(a, Int)]) -> Maybe (a, Int) -> [(a, Int)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(a, Int)]
ms ((a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
:[(a, Int)]
ms) Maybe (a, Int)
e)) ((a, Int), RMultiset a)
-> [((a, Int), RMultiset a)] -> [((a, Int), RMultiset a)]
forall a. a -> [a] -> [a]
:
[ ( (a
x,Int
k), Maybe (a, Int) -> [(a, Int)] -> RMultiset a
forall a. Maybe (a, Int) -> [(a, Int)] -> RMultiset a
RMS ((a, Int) -> Maybe (a, Int)
forall a. a -> Maybe a
Just (a
x,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
k))
([(a, Int)]
-> ((a, Int) -> [(a, Int)]) -> Maybe (a, Int) -> [(a, Int)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(a, Int)]
ms ((a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
:[(a, Int)]
ms) Maybe (a, Int)
e) )
| Int
k <- [Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2 .. Int
1]
] [((a, Int), RMultiset a)]
-> [((a, Int), RMultiset a)] -> [((a, Int), RMultiset a)]
forall a. [a] -> [a] -> [a]
++
(((a, Int), RMultiset a) -> ((a, Int), RMultiset a))
-> [((a, Int), RMultiset a)] -> [((a, Int), RMultiset a)]
forall a b. (a -> b) -> [a] -> [b]
map ((RMultiset a -> RMultiset a)
-> ((a, Int), RMultiset a) -> ((a, Int), RMultiset a)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((a, Int) -> RMultiset a -> RMultiset a
forall a. (a, Int) -> RMultiset a -> RMultiset a
consRMS (a
x,Int
n))) (RMultiset a -> [((a, Int), RMultiset a)]
forall a. RMultiset a -> [((a, Int), RMultiset a)]
selectRMS (Maybe (a, Int) -> [(a, Int)] -> RMultiset a
forall a. Maybe (a, Int) -> [(a, Int)] -> RMultiset a
RMS Maybe (a, Int)
e [(a, Int)]
ms))
consRMS :: (a, Count) -> RMultiset a -> RMultiset a
consRMS :: forall a. (a, Int) -> RMultiset a -> RMultiset a
consRMS (a, Int)
x (RMS Maybe (a, Int)
e [(a, Int)]
m) = Maybe (a, Int) -> [(a, Int)] -> RMultiset a
forall a. Maybe (a, Int) -> [(a, Int)] -> RMultiset a
RMS Maybe (a, Int)
e ((a, Int)
x(a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
:[(a, Int)]
m)
type Vec = [Count]
(<|=) :: Vec -> Vec -> Bool
[Int]
xs <|= :: [Int] -> [Int] -> Bool
<|= [Int]
ys = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool) -> [Int] -> [Int] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [Int]
xs [Int]
ys
vZero :: Vec -> Vec
vZero :: [Int] -> [Int]
vZero = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a b. a -> b -> a
const Int
0)
vIsZero :: Vec -> Bool
vIsZero :: [Int] -> Bool
vIsZero = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0)
(.+.), (.-.) :: Vec -> Vec -> Vec
.+. :: [Int] -> [Int] -> [Int]
(.+.) = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
.-. :: [Int] -> [Int] -> [Int]
(.-.) = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-)
(*.) :: Count -> Vec -> Vec
*. :: Int -> [Int] -> [Int]
(*.) Int
n = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*)
vDiv :: Vec -> Vec -> Count
vDiv :: [Int] -> [Int] -> Int
vDiv [Int]
v1 [Int]
v2 = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> ([Maybe Int] -> [Int]) -> [Maybe Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Int] -> Int) -> [Maybe Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Maybe Int) -> [Int] -> [Int] -> [Maybe Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Maybe Int
forall {a}. Integral a => a -> a -> Maybe a
zdiv [Int]
v1 [Int]
v2
where zdiv :: a -> a -> Maybe a
zdiv a
_ a
0 = Maybe a
forall a. Maybe a
Nothing
zdiv a
x a
y = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
y
vInc :: Vec -> Vec -> Vec
vInc :: [Int] -> [Int] -> [Int]
vInc [Int]
lim [Int]
v = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int] -> [Int]
forall {a}. (Num a, Ord a) => [a] -> [a] -> [a]
vInc' ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
lim) ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
v))
where vInc' :: [a] -> [a] -> [a]
vInc' [a]
_ [] = []
vInc' [] (a
x:[a]
xs) = a
xa -> a -> a
forall a. Num a => a -> a -> a
+a
1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
vInc' (a
l:[a]
ls) (a
x:[a]
xs) | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
l = a
xa -> a -> a
forall a. Num a => a -> a -> a
+a
1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
| Bool
otherwise = a
0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
vInc' [a]
ls [a]
xs
vPartitions :: Vec -> [Multiset Vec]
vPartitions :: [Int] -> [Multiset [Int]]
vPartitions [Int]
v = [Int] -> [Int] -> [Multiset [Int]]
vPart [Int]
v ([Int] -> [Int]
vZero [Int]
v) where
vPart :: [Int] -> [Int] -> [Multiset [Int]]
vPart [Int]
v [Int]
_ | [Int] -> Bool
vIsZero [Int]
v = [[([Int], Int)] -> Multiset [Int]
forall a. [(a, Int)] -> Multiset a
MS []]
vPart [Int]
v [Int]
vL
| [Int]
v [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
<= [Int]
vL = []
| Bool
otherwise = [([Int], Int)] -> Multiset [Int]
forall a. [(a, Int)] -> Multiset a
MS [([Int]
v,Int
1)]
Multiset [Int] -> [Multiset [Int]] -> [Multiset [Int]]
forall a. a -> [a] -> [a]
: [ ([Int]
v',Int
k) ([Int], Int) -> Multiset [Int] -> Multiset [Int]
forall a. (a, Int) -> Multiset a -> Multiset a
+: Multiset [Int]
p' | [Int]
v' <- [Int] -> [Int] -> [Int] -> [[Int]]
withinFromTo [Int]
v ([Int] -> [Int]
vHalf [Int]
v) ([Int] -> [Int] -> [Int]
vInc [Int]
v [Int]
vL)
, Int
k <- [Int
1 .. ([Int]
v [Int] -> [Int] -> Int
`vDiv` [Int]
v')]
, Multiset [Int]
p' <- [Int] -> [Int] -> [Multiset [Int]]
vPart ([Int]
v [Int] -> [Int] -> [Int]
.-. (Int
k Int -> [Int] -> [Int]
*. [Int]
v')) [Int]
v' ]
vHalf :: Vec -> Vec
vHalf :: [Int] -> [Int]
vHalf [] = []
vHalf (Int
x:[Int]
xs) | (Int -> Bool
forall a. Integral a => a -> Bool
even Int
x) = (Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int] -> [Int]
vHalf [Int]
xs
| Bool
otherwise = (Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
xs
downFrom :: a -> [a]
downFrom a
n = [a
n,(a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1)..a
0]
within :: Vec -> [Vec]
within :: [Int] -> [[Int]]
within = [[Int]] -> [[Int]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([[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}. (Num a, Enum a) => a -> [a]
downFrom
clip :: Vec -> Vec -> Vec
clip :: [Int] -> [Int] -> [Int]
clip = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Ord a => a -> a -> a
min
withinFromTo :: Vec -> Vec -> Vec -> [Vec]
withinFromTo :: [Int] -> [Int] -> [Int] -> [[Int]]
withinFromTo [Int]
m [Int]
s [Int]
e | Bool -> Bool
not ([Int]
s [Int] -> [Int] -> Bool
<|= [Int]
m) = [Int] -> [Int] -> [Int] -> [[Int]]
withinFromTo [Int]
m ([Int] -> [Int] -> [Int]
clip [Int]
m [Int]
s) [Int]
e
withinFromTo [Int]
m [Int]
s [Int]
e | [Int]
e [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
> [Int]
s = []
withinFromTo [Int]
m [Int]
s [Int]
e = [Int] -> [Int] -> [Int] -> Bool -> Bool -> [[Int]]
forall {a}.
(Enum a, Num a, Eq a) =>
[a] -> [a] -> [a] -> Bool -> Bool -> [[a]]
wFT [Int]
m [Int]
s [Int]
e Bool
True Bool
True
where
wFT :: [a] -> [a] -> [a] -> Bool -> Bool -> [[a]]
wFT [] [a]
_ [a]
_ Bool
_ Bool
_ = [[]]
wFT (a
m:[a]
ms) (a
s:[a]
ss) (a
e:[a]
es) Bool
useS Bool
useE =
let start :: a
start = if Bool
useS then a
s else a
m
end :: a
end = if Bool
useE then a
e else a
0
in
[a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs | a
x <- [a
start,(a
starta -> a -> a
forall a. Num a => a -> a -> a
-a
1)..a
end],
let useS' :: Bool
useS' = Bool
useS Bool -> Bool -> Bool
&& a
xa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
s,
let useE' :: Bool
useE' = Bool
useE Bool -> Bool -> Bool
&& a
xa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
e,
[a]
xs <- [a] -> [a] -> [a] -> Bool -> Bool -> [[a]]
wFT [a]
ms [a]
ss [a]
es Bool
useS' Bool
useE' ]
partitions :: Multiset a -> [Multiset (Multiset a)]
partitions :: forall a. Multiset a -> [Multiset (Multiset a)]
partitions (MS []) = [[(Multiset a, Int)] -> Multiset (Multiset a)
forall a. [(a, Int)] -> Multiset a
MS []]
partitions (MS [(a, Int)]
m) = ((Multiset [Int] -> Multiset (Multiset a))
-> [Multiset [Int]] -> [Multiset (Multiset a)]
forall a b. (a -> b) -> [a] -> [b]
map ((Multiset [Int] -> Multiset (Multiset a))
-> [Multiset [Int]] -> [Multiset (Multiset a)])
-> (([Int] -> Multiset a)
-> Multiset [Int] -> Multiset (Multiset a))
-> ([Int] -> Multiset a)
-> [Multiset [Int]]
-> [Multiset (Multiset a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> Multiset a) -> Multiset [Int] -> Multiset (Multiset a)
forall a b. (a -> b) -> Multiset a -> Multiset b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ([a] -> [Int] -> Multiset a
forall {a}. [a] -> [Int] -> Multiset a
combine [a]
elts) ([Multiset [Int]] -> [Multiset (Multiset a)])
-> [Multiset [Int]] -> [Multiset (Multiset a)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Multiset [Int]]
vPartitions [Int]
counts
where ([a]
elts, [Int]
counts) = [(a, Int)] -> ([a], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a, Int)]
m
combine :: [a] -> [Int] -> Multiset a
combine [a]
es [Int]
cs = [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS ([(a, Int)] -> Multiset a)
-> ([(a, Int)] -> [(a, Int)]) -> [(a, Int)] -> Multiset a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Int) -> Bool) -> [(a, Int)] -> [(a, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
0) (Int -> Bool) -> ((a, Int) -> Int) -> (a, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Int) -> Int
forall a b. (a, b) -> b
snd) ([(a, Int)] -> Multiset a) -> [(a, Int)] -> Multiset a
forall a b. (a -> b) -> a -> b
$ [a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
es [Int]
cs
splits :: Multiset a -> [(Multiset a, Multiset a)]
splits :: forall a. Multiset a -> [(Multiset a, Multiset a)]
splits (MS []) = [([(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS [], [(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS [])]
splits (MS ((a
x,Int
n):[(a, Int)]
m)) =
[Int]
-> (Int -> [(Multiset a, Multiset a)])
-> [(Multiset a, Multiset a)]
forall {a} {b}. [a] -> (a -> [b]) -> [b]
for [Int
0..Int
n] ((Int -> [(Multiset a, Multiset a)]) -> [(Multiset a, Multiset a)])
-> (Int -> [(Multiset a, Multiset a)])
-> [(Multiset a, Multiset a)]
forall a b. (a -> b) -> a -> b
$ \Int
k ->
((Multiset a, Multiset a) -> (Multiset a, Multiset a))
-> [(Multiset a, Multiset a)] -> [(Multiset a, Multiset a)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> Int -> Multiset a -> Multiset a
forall {a}. a -> Int -> Multiset a -> Multiset a
addElt a
x Int
k (Multiset a -> Multiset a)
-> (Multiset a -> Multiset a)
-> (Multiset a, Multiset a)
-> (Multiset a, Multiset a)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a -> Int -> Multiset a -> Multiset a
forall {a}. a -> Int -> Multiset a -> Multiset a
addElt a
x (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
k)) (Multiset a -> [(Multiset a, Multiset a)]
forall a. Multiset a -> [(Multiset a, Multiset a)]
splits ([(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS [(a, Int)]
m))
kSubsets :: Count -> Multiset a -> [Multiset a]
kSubsets :: forall a. Int -> Multiset a -> [Multiset a]
kSubsets Int
0 Multiset a
_ = [[(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS []]
kSubsets Int
_ (MS []) = []
kSubsets Int
k (MS ((a
x,Int
n):[(a, Int)]
m)) =
[Int] -> (Int -> [Multiset a]) -> [Multiset a]
forall {a} {b}. [a] -> (a -> [b]) -> [b]
for [Int
0 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
k Int
n] ((Int -> [Multiset a]) -> [Multiset a])
-> (Int -> [Multiset a]) -> [Multiset a]
forall a b. (a -> b) -> a -> b
$ \Int
j ->
(Multiset a -> Multiset a) -> [Multiset a] -> [Multiset a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> Int -> Multiset a -> Multiset a
forall {a}. a -> Int -> Multiset a -> Multiset a
addElt a
x Int
j) (Int -> Multiset a -> [Multiset a]
forall a. Int -> Multiset a -> [Multiset a]
kSubsets (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
j) ([(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS [(a, Int)]
m))
for :: [a] -> (a -> [b]) -> [b]
for = ((a -> [b]) -> [a] -> [b]) -> [a] -> (a -> [b]) -> [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> [b]) -> [a] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
addElt :: a -> Int -> Multiset a -> Multiset a
addElt a
_ Int
0 = Multiset a -> Multiset a
forall a. a -> a
id
addElt a
x Int
k = ((a
x,Int
k) (a, Int) -> Multiset a -> Multiset a
forall a. (a, Int) -> Multiset a -> Multiset a
+:)
cycles :: Multiset a -> [[a]]
cycles :: forall a. Multiset a -> [[a]]
cycles (MS []) = []
cycles m :: Multiset a
m@(MS ((a
x1,Int
n1):[(a, Int)]
xs))
| Int
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = (Int -> Int -> Int -> [(Int, a)] -> [(Int, (a, Int))] -> [[a]]
forall a.
Int -> Int -> Int -> [(Int, a)] -> [(Int, (a, Int))] -> [[a]]
cycles' Int
n Int
2 Int
1 [(Int
0,a
x1)] ([(Int, (a, Int))] -> [(Int, (a, Int))]
forall a. [a] -> [a]
reverse ([(Int, (a, Int))] -> [(Int, (a, Int))])
-> [(Int, (a, Int))] -> [(Int, (a, Int))]
forall a b. (a -> b) -> a -> b
$ [Int] -> [(a, Int)] -> [(Int, (a, Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [(a, Int)]
xs))
| Bool
otherwise = (Int -> Int -> Int -> [(Int, a)] -> [(Int, (a, Int))] -> [[a]]
forall a.
Int -> Int -> Int -> [(Int, a)] -> [(Int, (a, Int))] -> [[a]]
cycles' Int
n Int
2 Int
1 [(Int
0,a
x1)] ([(Int, (a, Int))] -> [(Int, (a, Int))]
forall a. [a] -> [a]
reverse ([(Int, (a, Int))] -> [(Int, (a, Int))])
-> [(Int, (a, Int))] -> [(Int, (a, Int))]
forall a b. (a -> b) -> a -> b
$ [Int] -> [(a, Int)] -> [(Int, (a, Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ((a
x1,Int
n1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)(a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
:[(a, Int)]
xs)))
where n :: Int
n = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Multiset a -> [Int]) -> Multiset a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Multiset a -> [Int]
forall a. Multiset a -> [Int]
getCounts (Multiset a -> Int) -> Multiset a -> Int
forall a b. (a -> b) -> a -> b
$ Multiset a
m
cycles' :: Int -> Int -> Int -> [(Int, a)] -> [(Int, (a,Count))] -> [[a]]
cycles' :: forall a.
Int -> Int -> Int -> [(Int, a)] -> [(Int, (a, Int))] -> [[a]]
cycles' Int
n Int
_ Int
p [(Int, a)]
pre [] | Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> a
forall a b. (a, b) -> b
snd [(Int, a)]
pre]
| Bool
otherwise = []
cycles' Int
n Int
t Int
p [(Int, a)]
pre [(Int, (a, Int))]
xs =
(((Int, (a, Int)) -> Bool) -> [(Int, (a, Int))] -> [(Int, (a, Int))]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
atp) (Int -> Bool)
-> ((Int, (a, Int)) -> Int) -> (Int, (a, Int)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (a, Int)) -> Int
forall a b. (a, b) -> a
fst) [(Int, (a, Int))]
xs) [(Int, (a, Int))] -> ((Int, (a, Int)) -> [[a]]) -> [[a]]
forall {a} {b}. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Int
j, (a
xj,Int
_)) ->
Int -> Int -> Int -> [(Int, a)] -> [(Int, (a, Int))] -> [[a]]
forall a.
Int -> Int -> Int -> [(Int, a)] -> [(Int, (a, Int))] -> [[a]]
cycles' Int
n (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
atp then Int
p else Int
t)
((Int
j,a
xj)(Int, a) -> [(Int, a)] -> [(Int, a)]
forall a. a -> [a] -> [a]
:[(Int, a)]
pre)
(Int -> [(Int, (a, Int))] -> [(Int, (a, Int))]
forall a. Int -> [(Int, (a, Int))] -> [(Int, (a, Int))]
remove Int
j [(Int, (a, Int))]
xs)
where atp :: Int
atp = (Int, a) -> Int
forall a b. (a, b) -> a
fst ((Int, a) -> Int) -> (Int, a) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, a)]
pre [(Int, a)] -> Int -> (Int, a)
forall a. HasCallStack => [a] -> Int -> a
!! (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
remove :: Int -> [(Int, (a, Int))] -> [(Int, (a, Int))]
remove :: forall a. Int -> [(Int, (a, Int))] -> [(Int, (a, Int))]
remove Int
_ [] = []
remove Int
j (x :: (Int, (a, Int))
x@(Int
j',(a
xj,Int
nj)):[(Int, (a, Int))]
xs)
| Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j' Bool -> Bool -> Bool
&& Int
nj Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = [(Int, (a, Int))]
xs
| Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j' = (Int
j',(a
xj,Int
njInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))(Int, (a, Int)) -> [(Int, (a, Int))] -> [(Int, (a, Int))]
forall a. a -> [a] -> [a]
:[(Int, (a, Int))]
xs
| Bool
otherwise = (Int, (a, Int))
x(Int, (a, Int)) -> [(Int, (a, Int))] -> [(Int, (a, Int))]
forall a. a -> [a] -> [a]
:Int -> [(Int, (a, Int))] -> [(Int, (a, Int))]
forall a. Int -> [(Int, (a, Int))] -> [(Int, (a, Int))]
remove Int
j [(Int, (a, Int))]
xs
class Snocable p a where
(|>) :: p -> a -> p
class Indexable p where
(!) :: p -> Int -> Int
type PreNecklace = [Int]
data Pre = Pre !Int (Maybe Int) PreNecklace
deriving (Int -> Pre -> ShowS
[Pre] -> ShowS
Pre -> String
(Int -> Pre -> ShowS)
-> (Pre -> String) -> ([Pre] -> ShowS) -> Show Pre
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pre -> ShowS
showsPrec :: Int -> Pre -> ShowS
$cshow :: Pre -> String
show :: Pre -> String
$cshowList :: [Pre] -> ShowS
showList :: [Pre] -> ShowS
Show)
emptyPre :: Pre
emptyPre :: Pre
emptyPre = Int -> Maybe Int -> [Int] -> Pre
Pre Int
0 Maybe Int
forall a. Maybe a
Nothing []
getPre :: Pre -> PreNecklace
getPre :: Pre -> [Int]
getPre (Pre Int
_ Maybe Int
_ [Int]
as) = [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
as
instance Snocable Pre Int where
(Pre Int
0 Maybe Int
_ []) |> :: Pre -> Int -> Pre
|> Int
a = Int -> Maybe Int -> [Int] -> Pre
Pre Int
1 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
a) [Int
a]
(Pre Int
t Maybe Int
a1 [Int]
as) |> Int
a = Int -> Maybe Int -> [Int] -> Pre
Pre (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Maybe Int
a1 (Int
aInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
as)
instance Indexable Pre where
Pre
_ ! :: Pre -> Int -> Int
! Int
0 = Int
0
(Pre Int
_ (Just Int
a1) [Int]
_) ! Int
1 = Int
a1
(Pre Int
t Maybe Int
_ [Int]
as) ! Int
i = [Int]
as [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)
data RLE a = RLE !Int !Int [(a,Int)]
deriving (Int -> RLE a -> ShowS
[RLE a] -> ShowS
RLE a -> String
(Int -> RLE a -> ShowS)
-> (RLE a -> String) -> ([RLE a] -> ShowS) -> Show (RLE a)
forall a. Show a => Int -> RLE a -> ShowS
forall a. Show a => [RLE a] -> ShowS
forall a. Show a => RLE a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> RLE a -> ShowS
showsPrec :: Int -> RLE a -> ShowS
$cshow :: forall a. Show a => RLE a -> String
show :: RLE a -> String
$cshowList :: forall a. Show a => [RLE a] -> ShowS
showList :: [RLE a] -> ShowS
Show)
emptyRLE :: RLE a
emptyRLE :: forall a. RLE a
emptyRLE = Int -> Int -> [(a, Int)] -> RLE a
forall a. Int -> Int -> [(a, Int)] -> RLE a
RLE Int
0 Int
0 []
compareRLE :: Ord a => [(a,Int)] -> [(a,Int)] -> Ordering
compareRLE :: forall a. Ord a => [(a, Int)] -> [(a, Int)] -> Ordering
compareRLE [] [] = Ordering
EQ
compareRLE [] [(a, Int)]
_ = Ordering
LT
compareRLE [(a, Int)]
_ [] = Ordering
GT
compareRLE ((a
a1,Int
n1):[(a, Int)]
rle1) ((a
a2,Int
n2):[(a, Int)]
rle2)
| (a
a1,Int
n1) (a, Int) -> (a, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (a
a2,Int
n2) = [(a, Int)] -> [(a, Int)] -> Ordering
forall a. Ord a => [(a, Int)] -> [(a, Int)] -> Ordering
compareRLE [(a, Int)]
rle1 [(a, Int)]
rle2
| a
a1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
a2 = Ordering
LT
| a
a1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
a2 = Ordering
GT
| (Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n2 Bool -> Bool -> Bool
&& ([(a, Int)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, Int)]
rle1 Bool -> Bool -> Bool
|| (a, Int) -> a
forall a b. (a, b) -> a
fst ([(a, Int)] -> (a, Int)
forall a. HasCallStack => [a] -> a
head [(a, Int)]
rle1) a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
a2)) Bool -> Bool -> Bool
|| (Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([(a, Int)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(a, Int)]
rle2) Bool -> Bool -> Bool
&& a
a1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< (a, Int) -> a
forall a b. (a, b) -> a
fst ([(a, Int)] -> (a, Int)
forall a. HasCallStack => [a] -> a
head [(a, Int)]
rle2)) = Ordering
LT
| Bool
otherwise = Ordering
GT
instance Indexable (RLE Int) where
(RLE Int
_ Int
_ []) ! :: RLE Int -> Int -> Int
! Int
_ = String -> Int
forall a. HasCallStack => String -> a
error String
"Bad index in (!) for RLE"
(RLE Int
n Int
b ((Int
a,Int
v):[(Int, Int)]
rest)) ! Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
v = Int
a
| Bool
otherwise = (Int -> Int -> [(Int, Int)] -> RLE Int
forall a. Int -> Int -> [(a, Int)] -> RLE a
RLE (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
v) (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [(Int, Int)]
rest) RLE Int -> Int -> Int
forall p. Indexable p => p -> Int -> Int
! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
v)
instance Eq a => Snocable (RLE a) a where
(RLE Int
_ Int
_ []) |> :: RLE a -> a -> RLE a
|> a
a' = Int -> Int -> [(a, Int)] -> RLE a
forall a. Int -> Int -> [(a, Int)] -> RLE a
RLE Int
1 Int
1 [(a
a',Int
1)]
(RLE Int
n Int
b rle :: [(a, Int)]
rle@((a
a,Int
v):[(a, Int)]
rest)) |> a
a'
| a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a' = Int -> Int -> [(a, Int)] -> RLE a
forall a. Int -> Int -> [(a, Int)] -> RLE a
RLE (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
b ((a
a,Int
vInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)(a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
:[(a, Int)]
rest)
| Bool
otherwise = Int -> Int -> [(a, Int)] -> RLE a
forall a. Int -> Int -> [(a, Int)] -> RLE a
RLE (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ((a
a',Int
1)(a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
:[(a, Int)]
rle)
data Pre' = Pre' Pre (RLE Int)
deriving Int -> Pre' -> ShowS
[Pre'] -> ShowS
Pre' -> String
(Int -> Pre' -> ShowS)
-> (Pre' -> String) -> ([Pre'] -> ShowS) -> Show Pre'
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pre' -> ShowS
showsPrec :: Int -> Pre' -> ShowS
$cshow :: Pre' -> String
show :: Pre' -> String
$cshowList :: [Pre'] -> ShowS
showList :: [Pre'] -> ShowS
Show
emptyPre' :: Pre'
emptyPre' :: Pre'
emptyPre' = Pre -> RLE Int -> Pre'
Pre' Pre
emptyPre RLE Int
forall a. RLE a
emptyRLE
getPre' :: Pre' -> PreNecklace
getPre' :: Pre' -> [Int]
getPre' (Pre' Pre
pre RLE Int
_) = Pre -> [Int]
getPre Pre
pre
instance Indexable Pre' where
Pre'
_ ! :: Pre' -> Int -> Int
! Int
0 = Int
0
(Pre' (Pre Int
len Maybe Int
_ [Int]
_) RLE Int
rle) ! Int
i = RLE Int
rle RLE Int -> Int -> Int
forall p. Indexable p => p -> Int -> Int
! (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
instance Snocable Pre' Int where
(Pre' Pre
p RLE Int
rle) |> :: Pre' -> Int -> Pre'
|> Int
a = Pre -> RLE Int -> Pre'
Pre' (Pre
p Pre -> Int -> Pre
forall p a. Snocable p a => p -> a -> p
|> Int
a) (RLE Int
rle RLE Int -> Int -> RLE Int
forall p a. Snocable p a => p -> a -> p
|> Int
a)
type Bracelet = [Int]
genFixedBracelets :: Int -> [(Int,Int)] -> [Bracelet]
genFixedBracelets :: Int -> [(Int, Int)] -> [[Int]]
genFixedBracelets Int
n [(Int
0,Int
k)] | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = [Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
k Int
0]
| Bool
otherwise = []
genFixedBracelets Int
n [(Int, Int)]
content = Writer [[Int]] () -> [[Int]]
forall w a. Writer w a -> w
execWriter (Int -> Int -> Int -> IntMap Int -> Pre' -> Writer [[Int]] ()
go Int
1 Int
1 Int
0 ([(Int, Int)] -> IntMap Int
forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int, Int)]
content) Pre'
emptyPre')
where
go :: Int -> Int -> Int -> IM.IntMap Int -> Pre' -> Writer [Bracelet] ()
go :: Int -> Int -> Int -> IntMap Int -> Pre' -> Writer [[Int]] ()
go Int
_ Int
_ Int
_ IntMap Int
con Pre'
_ | IntMap Int -> [Int]
forall a. IntMap a -> [Int]
IM.keys IntMap Int
con [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int
0] = () -> Writer [[Int]] ()
forall a. a -> WriterT [[Int]] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go Int
t Int
p Int
r IntMap Int
con pre :: Pre'
pre@(Pre' (Pre Int
_ Maybe Int
_ [Int]
as) RLE Int
_)
| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n =
Bool -> Writer [[Int]] () -> Writer [[Int]] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r) [Int]
as [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> [Int]
forall a. [a] -> [a]
reverse (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r) [Int]
as) Bool -> Bool -> Bool
&& Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Writer [[Int]] () -> Writer [[Int]] ())
-> Writer [[Int]] () -> Writer [[Int]] ()
forall a b. (a -> b) -> a -> b
$
[[Int]] -> Writer [[Int]] ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell [Pre' -> [Int]
getPre' Pre'
pre]
| Bool
otherwise = do
let a' :: Int
a' = Pre'
pre Pre' -> Int -> Int
forall p. Indexable p => p -> Int -> Int
! (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
p)
[Int] -> (Int -> Writer [[Int]] ()) -> Writer [[Int]] ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
a') ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ IntMap Int -> [Int]
forall a. IntMap a -> [Int]
IM.keys IntMap Int
con) ((Int -> Writer [[Int]] ()) -> Writer [[Int]] ())
-> (Int -> Writer [[Int]] ()) -> Writer [[Int]] ()
forall a b. (a -> b) -> a -> b
$ \Int
j -> do
let con' :: IntMap Int
con' = Int -> IntMap Int -> IntMap Int
decrease Int
j IntMap Int
con
pre' :: Pre'
pre' = Pre'
pre Pre' -> Int -> Pre'
forall p a. Snocable p a => p -> a -> p
|> Int
j
c :: Ordering
c = Int -> Pre' -> Ordering
forall {p}. p -> Pre' -> Ordering
checkRev2 Int
t Pre'
pre'
p' :: Int
p' | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
a' = Int
t
| Bool
otherwise = Int
p
Bool -> Writer [[Int]] () -> Writer [[Int]] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ordering
c Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ) (Writer [[Int]] () -> Writer [[Int]] ())
-> Writer [[Int]] () -> Writer [[Int]] ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> IntMap Int -> Pre' -> Writer [[Int]] ()
go (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
p' Int
t IntMap Int
con' Pre'
pre'
Bool -> Writer [[Int]] () -> Writer [[Int]] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ordering
c Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT) (Writer [[Int]] () -> Writer [[Int]] ())
-> Writer [[Int]] () -> Writer [[Int]] ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> IntMap Int -> Pre' -> Writer [[Int]] ()
go (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
p' Int
r IntMap Int
con' Pre'
pre'
decrease :: Int -> IM.IntMap Int -> IM.IntMap Int
decrease :: Int -> IntMap Int -> IntMap Int
decrease Int
j IntMap Int
con
| IntMap Int -> Bool
forall a. IntMap a -> Bool
IM.null IntMap Int
con = IntMap Int
con
| Bool
otherwise = (Maybe Int -> Maybe Int) -> Int -> IntMap Int -> IntMap Int
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe Int -> Maybe Int
forall {a}. (Eq a, Num a) => Maybe a -> Maybe a
q Int
j IntMap Int
con
where
q :: Maybe a -> Maybe a
q (Just a
1) = Maybe a
forall a. Maybe a
Nothing
q (Just a
cnt) = a -> Maybe a
forall a. a -> Maybe a
Just (a
cnta -> a -> a
forall a. Num a => a -> a -> a
-a
1)
q Maybe a
_ = Maybe a
forall a. Maybe a
Nothing
checkRev2 :: p -> Pre' -> Ordering
checkRev2 p
_ (Pre' Pre
_ (RLE Int
_ Int
_ [(Int, Int)]
rle)) = [(Int, Int)] -> [(Int, Int)] -> Ordering
forall a. Ord a => [(a, Int)] -> [(a, Int)] -> Ordering
compareRLE [(Int, Int)]
rle ([(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a]
reverse [(Int, Int)]
rle)
bracelets :: Multiset a -> [[a]]
bracelets :: forall a. Multiset a -> [[a]]
bracelets ms :: Multiset a
ms@(MS [(a, Int)]
cnts) = [[a]]
bs
where
contentMap :: IntMap a
contentMap = [(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IM.fromList ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (((a, Int) -> a) -> [(a, Int)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Int) -> a
forall a b. (a, b) -> a
fst [(a, Int)]
cnts))
content :: [(Int, Int)]
content = (Int -> (a, Int) -> (Int, Int))
-> [Int] -> [(a, Int)] -> [(Int, Int)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i (a
_,Int
n) -> (Int
i,Int
n)) [Int
0..] [(a, Int)]
cnts
rawBs :: [[Int]]
rawBs = Int -> [(Int, Int)] -> [[Int]]
genFixedBracelets (Multiset a -> Int
forall a. Multiset a -> Int
size Multiset a
ms) [(Int, Int)]
content
bs :: [[a]]
bs = ([Int] -> [a]) -> [[Int]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> (Int -> Maybe a) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IntMap a -> Maybe a) -> IntMap a -> Int -> Maybe a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IM.lookup IntMap a
contentMap)) [[Int]]
rawBs
sequenceMS :: Multiset [a] -> [Multiset a]
sequenceMS :: forall a. Multiset [a] -> [Multiset a]
sequenceMS = ([Multiset a] -> Multiset a) -> [[Multiset a]] -> [Multiset a]
forall a b. (a -> b) -> [a] -> [b]
map [Multiset a] -> Multiset a
forall a. [Multiset a] -> Multiset a
disjUnions
([[Multiset a]] -> [Multiset a])
-> (Multiset [a] -> [[Multiset a]]) -> Multiset [a] -> [Multiset a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Multiset a]] -> [[Multiset a]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
([[Multiset a]] -> [[Multiset a]])
-> (Multiset [a] -> [[Multiset a]])
-> Multiset [a]
-> [[Multiset a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([a], Int) -> [Multiset a]) -> [([a], Int)] -> [[Multiset a]]
forall a b. (a -> b) -> [a] -> [b]
map (\([a]
xs, Int
n) -> Int -> Multiset a -> [Multiset a]
forall a. Int -> Multiset a -> [Multiset a]
kSubsets Int
n ([(a, Int)] -> Multiset a
forall a. [(a, Int)] -> Multiset a
MS ([(a, Int)] -> Multiset a) -> [(a, Int)] -> Multiset a
forall a b. (a -> b) -> a -> b
$ ([a], Int) -> [(a, Int)]
forall a. ([a], Int) -> [(a, Int)]
uncollate ([a]
xs, Int
n)))
([([a], Int)] -> [[Multiset a]])
-> (Multiset [a] -> [([a], Int)]) -> Multiset [a] -> [[Multiset a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Multiset [a] -> [([a], Int)]
forall a. Multiset a -> [(a, Int)]
toCounts
uncollate :: ([a], Count) -> [(a, Count)]
uncollate :: forall a. ([a], Int) -> [(a, Int)]
uncollate ([a]
xs, Int
n) = (a -> (a, Int)) -> [a] -> [(a, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a
x,Int
n)) [a]
xs