packages feed

combinat 0.2.4.1 → 0.2.10.1

raw patch · 89 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2008-2011, Balazs Komuves+Copyright (c) 2008-2023, Balazs Komuves All rights reserved.  Redistribution and use in source and binary forms, with or without
− Math/Combinat.hs 
@@ -1,48 +0,0 @@---- | A collection of functions to generate combinatorial--- objects like partitions, combinations, permutations,--- Young tableaux, various trees, etc.------ The long-term goals are ------  (1) to be efficient; ------  (2) to be able to enumerate the structures ---      with constant memory usage. ------ The short-term goal is to generate --- many interesting structures.------ Naming conventions (subject to change): ------  * prime suffix: additional constrains, typically more general;------  * underscore prefix: use plain lists instead of other types with ---    enforced invariants;------  * \"random\" prefix: generates random objects ---    (typically with uniform distribution); ------  * \"count\" prefix: counting functions.--module Math.Combinat -  ( module Math.Combinat.Numbers-  , module Math.Combinat.Sets-  , module Math.Combinat.Tuples-  , module Math.Combinat.Compositions-  , module Math.Combinat.Partitions-  , module Math.Combinat.Permutations-  , module Math.Combinat.Tableaux-  , module Math.Combinat.Trees-  , module Math.Combinat.Graphviz-  ) where--import Math.Combinat.Numbers-import Math.Combinat.Sets-import Math.Combinat.Tuples-import Math.Combinat.Compositions-import Math.Combinat.Partitions-import Math.Combinat.Permutations-import Math.Combinat.Tableaux-import Math.Combinat.Trees-import Math.Combinat.Graphviz
− Math/Combinat/Combinations.hs 
@@ -1,62 +0,0 @@---- | Combinations.--- This module is depracated; it is equivalent to the module "Compositions", --- but it turns out that \"compositions\" is the accepted name. I will--- remove this module in the future.--module Math.Combinat.Combinations where--import Math.Combinat.Numbers (factorial,binomial)------------------------------------------------------------- | Combinations fitting into a given shape and having a given degree.---   The order is lexicographic, that is, ------ > sort cs == cs where cs = combinations' shape k----combinations'  -  :: [Int]         -- ^ shape-  -> Int           -- ^ sum-  -> [[Int]]-combinations' [] 0 = [[]]-combinations' [] _ = []-combinations' shape@(s:ss) n = -  [ x:xs | x <- [0..min s n] , xs <- combinations' ss (n-x) ] --countCombinations' :: [Int] -> Int -> Integer-countCombinations' [] 0 = 1-countCombinations' [] _ = 0-countCombinations' shape@(s:ss) n = sum -  [ countCombinations' ss (n-x) | x <- [0..min s n] ] ---- | All combinations fitting into a given shape.-allCombinations' :: [Int] -> [[[Int]]]-allCombinations' shape = map (combinations' shape) [0..d] where d = sum shape---- | Combinations of a given length.-combinations -  :: Int       -- ^ length-  -> Int       -- ^ sum-  -> [[Int]]-combinations len d = combinations' (replicate len d) d---- | # = \\binom { len+d-1 } { len-1 }-countCombinations :: Int -> Int -> Integer-countCombinations len d = binomial (len+d-1) (len-1)---- | Positive combinations of a given length.-combinations1  -  :: Int       -- ^ length-  -> Int       -- ^ sum-  -> [[Int]]-combinations1 len d -  | len > d = []-  | otherwise = map plus1 $ combinations len (d-len)-  where-    plus1 = map (+1)--countCombinations1 :: Int -> Int -> Integer-countCombinations1 len d = countCombinations len (d-len)---------------------------------------------------------
− Math/Combinat/Compositions.hs 
@@ -1,68 +0,0 @@---- | Compositions. --- This module is equivalent to the module "Combinations", --- but it turns out that \"compositions\" is the accepted name. I will--- remove the "Combinations" module in the future.--module Math.Combinat.Compositions where--import Math.Combinat.Numbers (factorial,binomial)------------------------------------------------------------- | Compositions fitting into a given shape and having a given degree.---   The order is lexicographic, that is, ------ > sort cs == cs where cs = compositions' shape k----compositions'  -  :: [Int]         -- ^ shape-  -> Int           -- ^ sum-  -> [[Int]]-compositions' [] 0 = [[]]-compositions' [] _ = []-compositions' shape@(s:ss) n = -  [ x:xs | x <- [0..min s n] , xs <- compositions' ss (n-x) ] --countCompositions' :: [Int] -> Int -> Integer-countCompositions' [] 0 = 1-countCompositions' [] _ = 0-countCompositions' shape@(s:ss) n = sum -  [ countCompositions' ss (n-x) | x <- [0..min s n] ] ---- | All compositions fitting into a given shape.-allCompositions' :: [Int] -> [[[Int]]]-allCompositions' shape = map (compositions' shape) [0..d] where d = sum shape---- | Compositions of a given length.-compositions -  :: Integral a -  => a       -- ^ length-  -> a       -- ^ sum-  -> [[Int]]-compositions len' d' = compositions' (replicate len d) d where-  len = fromIntegral len'-  d   = fromIntegral d'---- | # = \\binom { len+d-1 } { len-1 }-countCompositions :: Integral a => a -> a -> Integer-countCompositions len d = binomial (len+d-1) (len-1)---- | Positive compositions of a given length.-compositions1  -  :: Integral a -  => a       -- ^ length-  -> a       -- ^ sum-  -> [[Int]]-compositions1 len' d' -  | len > d = []-  | otherwise = map plus1 $ compositions len (d-len)-  where-    plus1 = map (+1)-    len = fromIntegral len'-    d   = fromIntegral d'--countCompositions1 :: Integral a => a -> a -> Integer-countCompositions1 len d = countCompositions len (d-len)---------------------------------------------------------
− Math/Combinat/Graphviz.hs 
@@ -1,115 +0,0 @@---- | Creates graphviz @.dot@ files from various structures, for example trees.--module Math.Combinat.Graphviz -  ( Dot-  , binTreeDot-  , binTree'Dot-  , treeDot-  , forestDot-  )-  where------------------------------------------------------------------------------------import Data.Tree--import Control.Applicative--import Math.Combinat.Trees.Binary (BinTree(..), BinTree'(..))-import Math.Combinat.Trees.Nary (addUniqueLabelsTree, addUniqueLabelsForest)------------------------------------------------------------------------------------type Dot = String--digraphBracket :: String -> [String] -> String   -digraphBracket name lines = -  "digraph " ++ name ++ " {\n" ++ -  concatMap (\xs -> "  "++xs++"\n") lines    -  ++ "}\n"-  -----------------------------------------------------------------------------------binTreeDot :: Show a => String -> BinTree a -> Dot-binTreeDot graphname tree = -  digraphBracket graphname $ binTreeDot' tree--binTree'Dot :: (Show a, Show b) => String -> BinTree' a b -> Dot-binTree'Dot graphname tree = -  digraphBracket graphname $ binTree'Dot' tree-  -binTreeDot' :: Show a => BinTree a -> [String]-binTreeDot' tree = lines where-  lines = worker (0::Int) "r" tree -  name path = "node_"++path-  worker depth path (Leaf x) = -    [ name path ++ "[shape=box,label=\"" ++ show x ++ "\"" ++ "];" ]-  worker depth path (Branch left right) -    = [vertex,leftedge,rightedge] ++ -      worker (depth+1) ('l':path) left ++ -      worker (depth+1) ('r':path) right-    where -      vertex = name path ++ "[shape=circle,style=filled,height=0.25,label=\"\"];"-      leftedge  = name path ++ " -> " ++ name ('l':path) ++ "[tailport=sw];"-      rightedge = name path ++ " -> " ++ name ('r':path) ++ "[tailport=se];"--binTree'Dot' :: (Show a, Show b) => BinTree' a b -> [String]-binTree'Dot' tree = lines where-  lines = worker (0::Int) "r" tree -  name path = "node_"++path-  worker depth path (Leaf' x) = -    [ name path ++ "[shape=box,label=\"" ++ show x ++ "\"" ++ "];" ]-  worker depth path (Branch' left y right) -    = [vertex,leftedge,rightedge] ++ -      worker (depth+1) ('l':path) left ++ -      worker (depth+1) ('r':path) right-    where -      vertex = name path ++ "[shape=ellipse,label=\"" ++ show y ++ "\"];"-      leftedge  = name path ++ " -> " ++ name ('l':path) ++ "[tailport=sw];"-      rightedge = name path ++ " -> " ++ name ('r':path) ++ "[tailport=se];"-----------------------------------------------------------------------------------    --- | Generates graphviz @.dot@ file from a forest. The first argument tells whether--- to make the individual trees clustered subgraphs; the second is the name of the--- graph.-forestDot -  :: Show a -  => Bool        -- ^ make the individual trees clustered subgraphs-  -> Bool        -- ^ reverse the direction of the arrows-  -> String      -- ^ name of the graph-  -> Forest a -  -> Dot-forestDot clustered revarrows graphname forest = digraphBracket graphname lines where-  lines = concat $ zipWith cluster [(1::Int)..] (addUniqueLabelsForest forest) -  name unique = "node_"++show unique-  cluster j tree = let treelines = worker (0::Int) tree in case clustered of-    False -> treelines-    True  -> ("subgraph cluster_"++show j++" {") : map ("  "++) treelines ++ ["}"] -  worker depth (Node (label,unique) subtrees) = vertex : edges ++ concatMap (worker (depth+1)) subtrees where-    vertex = name unique ++ "[label=\"" ++ show label ++ "\"" ++ "];"-    edges = map edge subtrees-    edge (Node (_,unique') _) = if not revarrows -      then name unique  ++ " -> " ++ name unique'   -      else name unique' ++ " -> " ++ name unique-      --- | Generates graphviz @.dot@ file from a tree. The first argument is--- the name of the graph.-treeDot -  :: Show a -  => Bool     -- ^ reverse the direction of the arrow-  -> String   -- ^ name of the graph-  -> Tree a -  -> Dot-treeDot revarrows graphname tree = digraphBracket graphname lines where-  lines = worker (0::Int) (addUniqueLabelsTree tree) -  name unique = "node_"++show unique-  worker depth (Node (label,unique) subtrees) = vertex : edges ++ concatMap (worker (depth+1)) subtrees where-    vertex = name unique ++ "[label=\"" ++ show label ++ "\"" ++ "];"-    edges = map edge subtrees-    edge (Node (_,unique') _) = if not revarrows -      then name unique  ++ " -> " ++ name unique'   -      else name unique' ++ " -> " ++ name unique----------------------------------------------------------------------------------
− Math/Combinat/Helper.hs 
@@ -1,108 +0,0 @@--module Math.Combinat.Helper where--import Control.Monad--import Data.List-import Data.Ord-import qualified Data.Set as Set--import Debug.Trace------------------------------------------------------------------------------------debug :: Show a => a -> b -> b-debug x y = trace ("-- " ++ show x ++ "\n") y--{-# SPECIALIZE swap :: (a,a) -> (a,a) #-}-{-# SPECIALIZE swap :: (Int,Int) -> (Int,Int) #-}-swap :: (a,b) -> (b,a)-swap (x,y) = (y,x)------------------------------------------------------------------------------------equating :: Eq b => (a -> b) -> a -> a -> Bool-equating f x y = (f x == f y)--reverseOrdering :: Ordering -> Ordering-reverseOrdering LT = GT-reverseOrdering GT = LT-reverseOrdering EQ = EQ--reverseCompare :: Ord a => a -> a -> Ordering-reverseCompare x y = reverseOrdering $ compare x y--groupSortBy :: (Eq b, Ord b) => (a -> b) -> [a] -> [[a]]-groupSortBy f = groupBy (equating f) . sortBy (comparing f) --nubOrd :: Ord a => [a] -> [a]-nubOrd = worker Set.empty where-  worker _ [] = []-  worker s (x:xs) -    | Set.member x s = worker s xs-    | otherwise      = x : worker (Set.insert x s) xs-    ------------------------------------------------------------------------------------- helps testing the random rutines -count :: Eq a => a -> [a] -> Int-count x xs = length $ filter (==x) xs------------------------------------------------------------------------------------fromJust :: Maybe a -> a-fromJust (Just x) = x-fromJust Nothing = error "fromJust: Nothing"------------------------------------------------------------------------------------intToBool :: Int -> Bool-intToBool 0 = False-intToBool 1 = True-intToBool _ = error "intToBool"--boolToInt :: Bool -> Int -boolToInt False = 0-boolToInt True  = 1-----------------------------------------------------------------------------------    --- iterated function application-nest :: Int -> (a -> a) -> a -> a-nest 0 _ x = x-nest n f x = nest (n-1) f (f x)--unfold1 :: (a -> Maybe a) -> a -> [a]-unfold1 f x = case f x of -  Nothing -> [x] -  Just y  -> x : unfold1 f y -  -unfold :: (b -> (a,Maybe b)) -> b -> [a]-unfold f y = let (x,m) = f y in case m of -  Nothing -> [x]-  Just y' -> x : unfold f y'--unfoldEither :: (b -> Either c (b,a)) -> b -> (c,[a])-unfoldEither f y = case f y of-  Left z -> (z,[])-  Right (y,x) -> let (z,xs) = unfoldEither f y in (z,x:xs)-  -unfoldM :: Monad m => (b -> m (a,Maybe b)) -> b -> m [a]-unfoldM f y = do-  (x,m) <- f y-  case m of-    Nothing -> return [x]-    Just y' -> do-      xs <- unfoldM f y'-      return (x:xs)--mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])-mapAccumM _ s [] = return (s, [])-mapAccumM f s (x:xs) = do-  (s1,y) <- f s x-  (s2,ys) <- mapAccumM f s1 xs-  return (s2, y:ys)-----------------------------------------------------------------------------------    -
− Math/Combinat/Numbers.hs 
@@ -1,142 +0,0 @@---- | A few important number sequences. ---  --- See the \"On-Line Encyclopedia of Integer Sequences\",--- <http://www.research.att.com/~njas/sequences/> .--module Math.Combinat.Numbers where------------------------------------------------------------------------------------import Data.Array-------------------------------------------------------------------------------------- | @(-1)^k@-paritySign :: Integral a => a -> Integer-paritySign k = if odd k then (-1) else 1-------------------------------------------------------------------------------------- | A000142.-factorial :: Integral a => a -> Integer-factorial n-  | n <  0    = error "factorial: input should be nonnegative"-  | n == 0    = 1-  | otherwise = product [1..fromIntegral n]---- | A006882.-doubleFactorial :: Integral a => a -> Integer-doubleFactorial n-  | n <  0    = error "doubleFactorial: input should be nonnegative"-  | n == 0    = 1-  | odd n     = product [1,3..fromIntegral n]-  | otherwise = product [2,4..fromIntegral n]---- | A007318.-binomial :: Integral a => a -> a -> Integer-binomial n k -  | k > n = 0-  | k < 0 = 0-  | k > (n `div` 2) = binomial n (n-k)-  | otherwise = (product [n'-k'+1 .. n']) `div` (product [1..k'])-  where -    k' = fromIntegral k-    n' = fromIntegral n---- | A given row of the Pascal triangle; equivalent to a sequence of binomial --- numbers, but much more efficient. You can also left-fold over it.------ > pascalRow n == [ binomial n k | k<-[0..n] ]-pascalRow :: Integral a => a -> [Integer]-pascalRow n' = worker 0 1 where-  n = fromIntegral n'-  worker j x-    | j>n   = [] -    | True  = let j'=j+1 in x : worker j' (div (x*(n-j)) j') --multinomial :: Integral a => [a] -> Integer-multinomial xs = div-  (factorial (sum xs))-  (product [ factorial x | x<-xs ])  -  ------------------------------------------------------------------------------------ * Catalan numbers---- | Catalan numbers. OEIS:A000108.-catalan :: Integral a => a -> Integer-catalan n -  | n < 0     = 0-  | otherwise = binomial (n+n) n `div` fromIntegral (n+1)---- | Catalan's triangle. OEIS:A009766.--- Note:------ > catalanTriangle n n == catalan n--- > catalanTriangle n k == countStandardYoungTableaux (toPartition [n,k])----catalanTriangle :: Integral a => a -> a -> Integer-catalanTriangle n k-  | k > n     = 0-  | k < 0     = 0-  | otherwise = binomial (n+k) n * fromIntegral (n-k+1) `div` fromIntegral (n+1)------------------------------------------------------------------------------------- * Stirling numbers---- | Rows of (signed) Stirling numbers of the first kind. OEIS:A008275.--- Coefficients of the polinomial @(x-1)*(x-2)*...*(x-n+1)@.--- This function uses the recursion formula.-signedStirling1stArray :: Integral a => a -> Array Int Integer-signedStirling1stArray n-  | n <  1    = error "stirling1stArray: n should be at least 1"-  | n == 1    = listArray (1,1 ) [1]-  | otherwise = listArray (1,n') [ lkp (k-1) - fromIntegral (n-1) * lkp k | k<-[1..n'] ] -  where-    prev = signedStirling1stArray (n-1)-    n' = fromIntegral n :: Int-    lkp j | j <  1    = 0-          | j >= n'   = 0-          | otherwise = prev ! j -        --- | (Signed) Stirling numbers of the first kind. OEIS:A008275.--- This function uses 'signedStirling1stArray', so it shouldn't be used--- to compute /many/ Stirling numbers.-signedStirling1st :: Integral a => a -> a -> Integer-signedStirling1st n k -  | k < 1     = 0-  | k > n     = 0-  | otherwise = signedStirling1stArray n ! (fromIntegral k)---- | (Unsigned) Stirling numbers of the first kind. See 'signedStirling1st'.-unsignedStirling1st :: Integral a => a -> a -> Integer-unsignedStirling1st n k = abs (signedStirling1st n k)---- | Stirling numbers of the second kind. OEIS:A008277.--- This function uses an explicit formula.-stirling2nd :: Integral a => a -> a -> Integer-stirling2nd n k -  | k < 1     = 0-  | k > n     = 0-  | otherwise = sum xs `div` factorial k where-      xs = [ paritySign (k-i) * binomial k i * (fromIntegral i)^n | i<-[0..k] ]------------------------------------------------------------------------------------- * Bernoulli numbers---- | Bernoulli numbers. @bernoulli 1 == -1%2@ and @bernoulli k == 0@ for--- k>2 and /odd/. This function uses the formula involving Stirling numbers--- of the second kind. Numerators: A027641, denominators: A027642.-bernoulli :: Integral a => a -> Rational-bernoulli n -  | n <  0    = error "bernoulli: n should be nonnegative"-  | n == 0    = 1-  | n == 1    = -1/2-  | otherwise = sum [ f k | k<-[1..n] ] -  where-    f k = toRational (paritySign (n+k) * factorial k * stirling2nd n k) -        / toRational (k+1)------------------------------------------------------------------------------------
− Math/Combinat/Numbers/Primes.hs 
@@ -1,290 +0,0 @@---- | Prime numbers and related number theoretical stuff.--module Math.Combinat.Numbers.Primes -  ( -- * List of prime numbers-    primes-  , primesSimple-  , primesTMWE-    -- * Prime factorization-  , groupIntegerFactors-  , integerFactorsTrialDivision-    -- * Integer logarithm-  , integerLog2-  , ceilingLog2-    -- * Integer square root-  , isSquare-  , integerSquareRoot-  , ceilingSquareRoot-  , integerSquareRoot' -  , integerSquareRootNewton'-    -- * Modulo @m@ arithmetic-  , powerMod-    -- * Prime testing-  , millerRabinPrimalityTest-  )-  where-------------------------------------------------------------------------------------- import Math.Combinat.Numbers--import Data.List ( group , sort )-import Data.Bits------------------------------------------------------------------------------------- List of prime numbers ---- | Infinite list of primes, using the TMWE algorithm.-primes :: [Integer]-primes = primesTMWE---- | A relatively simple but still quite fast implementation of list of primes.--- By Will Ness <http://www.haskell.org/pipermail/haskell-cafe/2009-November/068441.html>-primesSimple :: [Integer]-primesSimple = 2 : 3 : sieve 0 primes' 5 where-  primes' = tail primesSimple-  sieve k (p:ps) x = noDivs k h ++ sieve (k+1) ps (t+2) where-    t = p*p -    h = [x,x+2..t-2]-  noDivs k = filter (\x -> all (\y -> rem x y /= 0) (take k primes'))-  --- | List of primes, using tree merge with wheel. Code by Will Ness.-primesTMWE :: [Integer]-primesTMWE = 2:3:5:7: gaps 11 wheel (fold3t $ roll 11 wheel primes') where                                                             --  primes' = 11: gaps 13 (tail wheel) (fold3t $ roll 11 wheel primes')-  fold3t ((x:xs): ~(ys:zs:t)) -    = x : union xs (union ys zs) `union` fold3t (pairs t)            -  pairs ((x:xs):ys:t) = (x : union xs ys) : pairs t -  wheel = 2:4:2:4:6:2:6:4:2:4:6:6:2:6:4:2:6:4:6:8:4:2:4:2:  -          4:8:6:4:6:2:4:6:2:6:6:4:2:4:6:2:6:4:2:4:2:10:2:10:wheel -  gaps k ws@(w:t) cs@ ~(c:u) -    | k==c  = gaps (k+w) t u              -    | True  = k : gaps (k+w) t cs  -  roll k ws@(w:t) ps@ ~(p:u) -    | k==p  = scanl (\c d->c+p*d) (p*p) ws : roll (k+w) t u              -    | True  = roll (k+w) t ps   --  minus xxs@(x:xs) yys@(y:ys) = case compare x y of -    LT -> x : minus xs  yys-    EQ ->     minus xs  ys -    GT ->     minus xxs ys-  minus xs [] = xs-  minus [] _  = []-  -  union xxs@(x:xs) yys@(y:ys) = case compare x y of -    LT -> x : union xs  yys-    EQ -> x : union xs  ys -    GT -> y : union xxs ys-  union xs [] = xs-  union [] ys =ys------------------------------------------------------------------------------------- Prime factorization---- | Groups integer factors. Example: from [2,2,2,3,3,5] we produce [(2,3),(3,2),(5,1)]  -groupIntegerFactors :: [Integer] -> [(Integer,Int)]-groupIntegerFactors = map f . group . sort where-  f xs = (head xs, length xs)---- | The naive trial division algorithm.-integerFactorsTrialDivision :: Integer -> [Integer]-integerFactorsTrialDivision n -  | n<1 = error "integerFactorsTrialDivision: n should be at least 1"-  | otherwise = go primes n -  where-    go _  1 = []-    go rs k = sub ps k where-      sub [] k = [k]-      sub qqs@(q:qs) k = case mod k q of-        0 -> q : go qqs (div k q)-        _ -> sub qs k-      ps = takeWhile (\p -> p*p <= k) rs  -{--    go 1 = []-    go k = sub ps k where-      sub [] k = [k]-      sub (q:qs) k = case mod k q of-        0 -> q : go (div k q)-        _ -> sub qs k-      ps = takeWhile (\p -> p*p <= k) primes--}--{-    --- brute force testing of factors-ifactorsTest :: (Integer -> [Integer]) -> Integer -> Bool-ifactorsTest alg n = and [ product (alg k) == k | k<-[1..n] ]   --}------------------------------------------------------------------------------------- Integer logarithm---- | Largest integer @k@ such that @2^k@ is smaller or equal to @n@-integerLog2 :: Integer -> Integer-integerLog2 n = go n where-  go 0 = -1-  go k = 1 + go (shiftR k 1)---- | Smallest integer @k@ such that @2^k@ is larger or equal to @n@-ceilingLog2 :: Integer -> Integer-ceilingLog2 0 = 0-ceilingLog2 n = 1 + go (n-1) where-  go 0 = -1-  go k = 1 + go (shiftR k 1)-  ------------------------------------------------------------------------------------ Integer square root--isSquare :: Integer -> Bool-isSquare n = -  if (fromIntegral $ mod n 32) `elem` rs -    then snd (integerSquareRoot' n) == 0-    else False-  where-    rs = [0,1,4,9,16,17,25] :: [Int]-    --- | Integer square root (largest integer whose square is smaller or equal to the input)--- using Newton's method, with a faster (for large numbers) inital guess based on bit shifts.-integerSquareRoot :: Integer -> Integer-integerSquareRoot = fst . integerSquareRoot'---- | Smallest integer whose square is larger or equal to the input-ceilingSquareRoot :: Integer -> Integer-ceilingSquareRoot n = (if r>0 then u+1 else u) where (u,r) = integerSquareRoot' n ---- | We also return the excess residue; that is------ > (a,r) = integerSquareRoot' n--- --- means that------ > a*a + r = n--- > a*a <= n < (a+1)*(a+1)-integerSquareRoot' :: Integer -> (Integer,Integer)-integerSquareRoot' n-  | n<0 = error "integerSquareRoot: negative input"-  | n<2 = (n,0)-  | otherwise = go firstGuess -  where-    k = integerLog2 n-    firstGuess = 2^(div (k+2) 2) -- !! note that (div (k+1) 2) is NOT enough !!-    go a = -      if m < a-        then go a' -        else (a, r + a*(m-a))-      where-        (m,r) = divMod n a-        a' = div (m + a) 2---- | Newton's method without an initial guess. For very small numbers (<10^10) it--- is somewhat faster than the above version.-integerSquareRootNewton' :: Integer -> (Integer,Integer)-integerSquareRootNewton' n-  | n<0 = error "integerSquareRootNewton: negative input"-  | n<2 = (n,0)-  | otherwise = go (div n 2) -  where-    go a = -      if m < a-        then go a' -        else (a, r + a*(m-a))-      where-        (m,r) = divMod n a-        a' = div (m + a) 2--{---- brute force test of integer square root-isqrt_test n1 n2 = -  [ k -  | k<-[n1..n2] -  , let (a,r) = integerSquareRoot' k-  , (a*a+r/=k) || (a*a>k) || (a+1)*(a+1)<=k -  ]--}------------------------------------------------------------------------------------- Modulo @m@ arithmetic---- | Efficient powers modulo m.--- --- > powerMod a k m == (a^k) `mod` m-powerMod :: Integer -> Integer -> Integer -> Integer-powerMod a' k m = {- debug bs $ -} go a bs where--  bs = bin k--  bin 0 = []-  bin x = (x .&. 1 /= 0) : bin (shiftR x 1)--  a = mod a' m--  go _ [] = 1-  go x (b:bs) = -- debug (x,b) $ -    if b -      then mod (x*rest) m-      else rest-    where -      rest = go (mod (x*x) m) bs -      ------------------------------------------------------------------------------------ Prime testing- --- | Miller-Rabin Primality Test (taken from Haskell wiki). --- We test the primality of the first argument @n@ by using the second argument @a@ as a candidate witness.--- If it returs @False@, then @n@ is composite. If it returns @True@, then @n@ is either prime or composite.------ A random choice between @2@ and @(n-2)@ is a good choice for @a@.-millerRabinPrimalityTest :: Integer -> Integer -> Bool-millerRabinPrimalityTest n a-  | a <= 1 || a >= n-1 = -      error $ "millerRabinPrimalityTest: a out of range (" ++ show a ++ " for "++ show n ++ ")" -  | n < 2 = False-  | even n = False-  | b0 == 1 || b0 == n' = True-  | otherwise = iter (tail b)-  where-    n' = n-1-    (k,m) = find2km n'-    b0 = powMod n a m-    b = take (fromIntegral k) $ iterate (squareMod n) b0-    iter [] = False-    iter (x:xs)-      | x == 1 = False-      | x == n' = True-      | otherwise = iter xs---{-# SPECIALIZE find2km :: Integer -> (Integer,Integer) #-}-find2km :: Integral a => a -> (a,a)-find2km n = f 0 n where -  f k m-    | r == 1 = (k,m)-    | otherwise = f (k+1) q-    where (q,r) = quotRem m 2        - -{-# SPECIALIZE pow' :: (Integer -> Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer -> Integer #-}-pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a-pow' _ _ _ 0 = 1-pow' mul sq x' n' = f x' n' 1 where -  f x n y-    | n == 1 = x `mul` y-    | r == 0 = f x2 q y-    | otherwise = f x2 q (x `mul` y)-    where-      (q,r) = quotRem n 2-      x2 = sq x- -{-# SPECIALIZE mulMod :: Integer -> Integer -> Integer -> Integer #-}-mulMod :: Integral a => a -> a -> a -> a-mulMod a b c = (b * c) `mod` a--{-# SPECIALIZE squareMod :: Integer -> Integer -> Integer #-}-squareMod :: Integral a => a -> a -> a-squareMod a b = (b * b) `rem` a--{-# SPECIALIZE powMod :: Integer -> Integer -> Integer -> Integer #-}-powMod :: Integral a => a -> a -> a -> a-powMod m = pow' (mulMod m) (squareMod m)----------------------------------------------------------------------------------
− Math/Combinat/Numbers/Series.hs 
@@ -1,452 +0,0 @@---- | Some basic power series expansions.--- This module is not re-exported by "Math.Combinat".------ Note: the \"@convolveWithXXX@\" functions are much faster than the equivalent--- @(XXX \`convolve\`)@!--- --- TODO: better names for these functions.-----{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}-module Math.Combinat.Numbers.Series where------------------------------------------------------------------------------------import Data.List--#ifdef QUICKCHECK-import System.Random-import Test.QuickCheck-#endif-------------------------------------------------------------------------------------- | The series [1,0,0,0,0,...], which is the neutral element for the convolution.-{-# SPECIALIZE unitSeries :: [Integer] #-}-unitSeries :: Num a => [a]-unitSeries = 1 : repeat 0---- | Convolution of series. The result is always an infinite list. Warning: This is slow!-convolve :: Num a => [a] -> [a] -> [a]-convolve xs1 ys1 = res where-  res = [ foldl' (+) 0 (zipWith (*) xs (reverse (take n ys)))-        | n<-[1..] -        ]-  xs = xs1 ++ repeat 0-  ys = ys1 ++ repeat 0---- | Convolution of many series. Still slow!-convolveMany :: Num a => [[a]] -> [a]-convolveMany []  = 1 : repeat 0-convolveMany xss = foldl1 convolve xss------------------------------------------------------------------------------------- * \"Coin\" series---- | Power series expansion of --- --- > 1 / ( (1-x^k_1) * (1-x^k_2) * ... * (1-x^k_n) )------ Example:------ @(coinSeries [2,3,5])!!k@ is the number of ways --- to pay @k@ dollars with coins of two, three and five dollars.------ TODO: better name?-coinSeries :: [Int] -> [Integer]-coinSeries [] = 1 : repeat 0-coinSeries (k:ks) = xs where-  xs = zipWith (+) (coinSeries ks) (replicate k 0 ++ xs) ---- | Generalization of the above to include coefficients: expansion of ---  --- > 1 / ( (1-a_1*x^k_1) * (1-a_2*x^k_2) * ... * (1-a_n*x^k_n) ) --- -coinSeries' :: Num a => [(a,Int)] -> [a]-coinSeries' [] = 1 : repeat 0-coinSeries' ((a,k):aks) = xs where-  xs = zipWith (+) (coinSeries' aks) (replicate k 0 ++ map (*a) xs) --convolveWithCoinSeries :: [Int] -> [Integer] -> [Integer]-convolveWithCoinSeries ks series1 = worker ks where-  series = series1 ++ repeat 0-  worker [] = series-  worker (k:ks) = xs where-    xs = zipWith (+) (worker ks) (replicate k 0 ++ xs)--convolveWithCoinSeries' :: Num a => [(a,Int)] -> [a] -> [a]-convolveWithCoinSeries' ks series1 = worker ks where-  series = series1 ++ repeat 0-  worker [] = series-  worker ((a,k):aks) = xs where-    xs = zipWith (+) (worker aks) (replicate k 0 ++ map (*a) xs)------------------------------------------------------------------------------------- * Reciprocals of products of polynomials---- | Convolution of many 'pseries', that is, the expansion of the reciprocal--- of a product of polynomials-productPSeries :: [[Int]] -> [Integer]-productPSeries = foldl (flip convolveWithPSeries) unitSeries---- | The same, with coefficients.-productPSeries' :: Num a => [[(a,Int)]] -> [a]-productPSeries' = foldl (flip convolveWithPSeries') unitSeries--convolveWithProductPSeries :: [[Int]] -> [Integer] -> [Integer]-convolveWithProductPSeries kss ser = foldl (flip convolveWithPSeries) ser kss---- | This is the most general function in this module; all the others--- are special cases of this one.  -convolveWithProductPSeries' :: Num a => [[(a,Int)]] -> [a] -> [a] -convolveWithProductPSeries' akss ser = foldl (flip convolveWithPSeries') ser akss-  ------------------------------------------------------------------------------------ * Reciprocals of polynomials---- Reciprocals of polynomials, without coefficients--#ifdef QUICKCHECK--- | Expansion of @1 / (1-x^k)@. Included for completeness only; --- it equals to @coinSeries [k]@, and for example--- for @k=4@ it is simply--- --- > [1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0...]----pseries1 :: Int -> [Integer]-pseries1 k1 = convolveWithPSeries1 k1 unitSeries ---- | The expansion of @1 / (1-x^k_1-x^k_2)@-pseries2 :: Int -> Int -> [Integer]-pseries2 k1 k2 = convolveWithPSeries2 k1 k2 unitSeries ---- | The expansion of @1 / (1-x^k_1-x^k_2-x^k_3)@-pseries3 :: Int -> Int -> Int -> [Integer]-pseries3 k1 k2 k3 = convolveWithPSeries3 k1 k2 k3 unitSeries-#endif---- | The power series expansion of ------ > 1 / (1 - x^k_1 - x^k_2 - x^k_3 - ... - x^k_n)----pseries :: [Int] -> [Integer]-pseries ks = convolveWithPSeries ks unitSeries--#ifdef QUICKCHECK--- | Convolve with (the expansion of) @1 / (1-x^k1)@-convolveWithPSeries1 :: Int -> [Integer] -> [Integer]-convolveWithPSeries1 k1 series1 = xs where-  series = series1 ++ repeat 0 -  xs = zipWith (+) series ( replicate k1 0 ++ xs )---- | Convolve with (the expansion of) @1 / (1-x^k1-x^k2)@-convolveWithPSeries2 :: Int -> Int -> [Integer] -> [Integer]-convolveWithPSeries2 k1 k2 series1 = xs where-  series = series1 ++ repeat 0 -  xs = zipWith3 (\x y z -> x + y + z)-    series-    ( replicate k1 0 ++ xs )-    ( replicate k2 0 ++ xs )-    --- | Convolve with (the expansion of) @1 / (1-x^k_1-x^k_2-x^k_3)@-convolveWithPSeries3 :: Int -> Int -> Int -> [Integer] -> [Integer]-convolveWithPSeries3 k1 k2 k3 series1 = xs where-  series = series1 ++ repeat 0 -  xs = zipWith4 (\x y z w -> x + y + z + w)-    series-    ( replicate k1 0 ++ xs )-    ( replicate k2 0 ++ xs )-    ( replicate k3 0 ++ xs )-#endif---- | Convolve with (the expansion of) ------ > 1 / (1 - x^k_1 - x^k_2 - x^k_3 - ... - x^k_n)----convolveWithPSeries :: [Int] -> [Integer] -> [Integer]-convolveWithPSeries ks series1 = ys where -  series = series1 ++ repeat 0 -  ys = worker ks ys -  worker [] _ = series -  worker (k:ks) ys = xs where-    xs = zipWith (+) (replicate k 0 ++ ys) (worker ks ys)-------------------------------------------------------------------------------------  Reciprocals of polynomials, with coefficients--#ifdef QUICKCHECK--- | @1 / (1 - a*x^k)@. --- For example, for @a=3@ and @k=2@ it is just--- --- > [1,0,3,0,9,0,27,0,81,0,243,0,729,0,2187,0,6561,0,19683,0...]----pseries1' :: Num a => (a,Int) -> [a]-pseries1' ak1 = convolveWithPSeries1' ak1 unitSeries---- | @1 / (1 - a_1*x^k_1 - a_2*x^k_2)@-pseries2' :: Num a => (a,Int) -> (a,Int) -> [a]-pseries2' ak1 ak2 = convolveWithPSeries2' ak1 ak2 unitSeries---- | @1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3)@-pseries3' :: Num a => (a,Int) -> (a,Int) -> (a,Int) -> [a]-pseries3' ak1 ak2 ak3 = convolveWithPSeries3' ak1 ak2 ak3 unitSeries-#endif---- | The expansion of ------ > 1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3 - ... - a_n*x^k_n)----pseries' :: Num a => [(a,Int)] -> [a]-pseries' aks = convolveWithPSeries' aks unitSeries--#ifdef QUICKCHECK--- | Convolve with @1 / (1 - a*x^k)@. -convolveWithPSeries1' :: Num a => (a,Int) -> [a] -> [a]-convolveWithPSeries1' (a1,k1) series1 = xs where-  series = series1 ++ repeat 0 -  xs = zipWith (+)-    series-    ( replicate k1 0 ++ map (*a1) xs )---- | Convolve with @1 / (1 - a_1*x^k_1 - a_2*x^k_2)@-convolveWithPSeries2' :: Num a => (a,Int) -> (a,Int) -> [a] -> [a]-convolveWithPSeries2' (a1,k1) (a2,k2) series1 = xs where-  series = series1 ++ repeat 0 -  xs = zipWith3 (\x y z -> x + y + z)-    series-    ( replicate k1 0 ++ map (*a1) xs )-    ( replicate k2 0 ++ map (*a2) xs )-    --- | Convolve with @1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3)@-convolveWithPSeries3' :: Num a => (a,Int) -> (a,Int) -> (a,Int) -> [a] -> [a]-convolveWithPSeries3' (a1,k1) (a2,k2) (a3,k3) series1 = xs where-  series = series1 ++ repeat 0 -  xs = zipWith4 (\x y z w -> x + y + z + w)-    series-    ( replicate k1 0 ++ map (*a1) xs )-    ( replicate k2 0 ++ map (*a2) xs )-    ( replicate k3 0 ++ map (*a3) xs )-#endif---- | Convolve with (the expansion of) ------ > 1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3 - ... - a_n*x^k_n)----convolveWithPSeries' :: Num a => [(a,Int)] -> [a] -> [a]-convolveWithPSeries' aks series1 = ys where -  series = series1 ++ repeat 0 -  ys = worker aks ys -  worker [] _ = series-  worker ((a,k):aks) ys = xs where-    xs = zipWith (+) (replicate k 0 ++ map (*a) ys) (worker aks ys)--data Sign = Plus | Minus deriving (Eq,Show)--signValue :: Num a => Sign -> a-signValue Plus  =  1-signValue Minus = -1--signedPSeries :: [(Sign,Int)] -> [Integer] -signedPSeries aks = convolveWithSignedPSeries aks unitSeries---- | Convolve with (the expansion of) ------ > 1 / (1 +- x^k_1 +- x^k_2 +- x^k_3 +- ... +- x^k_n)------ Should be faster than using `convolveWithPSeries'`.--- Note: 'Plus' corresponds to the coefficient @-1@ in `pseries'` (since--- there is a minus sign in the definition there)!-convolveWithSignedPSeries :: [(Sign,Int)] -> [Integer] -> [Integer]-convolveWithSignedPSeries aks series1 = ys where -  series = series1 ++ repeat 0 -  ys = worker aks ys -  worker [] _ = series-  worker ((a,k):aks) ys = xs where-    xs = case a of-      Minus -> zipWith (+) one two -      Plus  -> zipWith (-) one two-    one = worker aks ys-    two = replicate k 0 ++ ys-     -----------------------------------------------------------------------------------#ifdef QUICKCHECK--swap :: (a,b) -> (b,a)-swap (x,y) = (y,x)---- compare the first 1000 elements of the infinite lists-(=!=) :: (Eq a, Num a) => [a] -> [a] -> Bool-(=!=) xs1 ys1 = (take m xs == take m ys) where -  m = 1000-  xs = xs1 ++ repeat 0-  ys = ys1 ++ repeat 0-infix 4 =!=--newtype Nat = Nat { fromNat :: Int } deriving (Eq,Ord,Show,Num,Random)-newtype Ser = Ser { fromSer :: [Integer] } deriving (Eq,Ord,Show)-newtype Exp  = Exp  { fromExp  ::  Int  } deriving (Eq,Ord,Show,Num,Random)-newtype Exps = Exps { fromExps :: [Int] } deriving (Eq,Ord,Show)-newtype CoeffExp  = CoeffExp  { fromCoeffExp  ::  (Integer,Int)  } deriving (Eq,Ord,Show)-newtype CoeffExps = CoeffExps { fromCoeffExps :: [(Integer,Int)] } deriving (Eq,Ord,Show)--minSerSize = 0    :: Int-maxSerSize = 1000 :: Int--minSerValue = -10000 :: Integer-maxSerValue =  10000 :: Integer--rndList :: (RandomGen g, Random a) => Int -> (a, a) -> g -> ([a], g)-rndList n minmax g = swap $ mapAccumL f g [1..n] where-  f g _ = swap $ randomR minmax g --instance Arbitrary Nat where-  arbitrary = choose (Nat 0 , Nat 750)--instance Arbitrary Exp where-  arbitrary = choose (Exp 1 , Exp 32)--instance Arbitrary CoeffExp where-  arbitrary = do-    coeff <- choose (minSerValue, maxSerValue) :: Gen Integer-    exp <- arbitrary :: Gen Exp-    return $ CoeffExp (coeff,fromExp exp)-   -instance Random Ser where-  random g = (Ser list, g2) where-    (size,g1) = randomR (minSerSize,maxSerSize) g-    (list,g2) = rndList size (minSerValue,maxSerValue) g1-  randomR _ = random--instance Random Exps where-  random g = (Exps list, g2) where-    (size,g1) = randomR (0,10) g-    (list,g2) = rndList size (1,32) g1-  randomR _ = random--instance Random CoeffExps where-  random g = (CoeffExps (zip list2 list1), g3) where-    (size,g1) = randomR (0,10) g-    (list1,g2) = rndList size (1,32) g1-    (list2,g3) = rndList size (minSerValue,maxSerValue) g2-  randomR _ = random-  -instance Arbitrary Ser where-  arbitrary = choose undefined--instance Arbitrary Exps where-  arbitrary = choose undefined--instance Arbitrary CoeffExps where-  arbitrary = choose undefined-  --- TODO: quickcheck test properties--checkAll :: IO ()-checkAll = do-  let f :: Testable a => a -> IO ()-      f = quickCheck-{- -  -- these are very slow, because random is slow-  putStrLn "leftIdentity"  ; f prop_leftIdentity-  putStrLn "rightIdentity" ; f prop_rightIdentity-  putStrLn "commutativity" ; f prop_commutativity-  putStrLn "associativity" ; f prop_associativity--}-  putStrLn "convPSeries1 vs generic" ; f prop_conv1_vs_gen-  putStrLn "convPSeries2 vs generic" ; f prop_conv2_vs_gen-  putStrLn "convPSeries3 vs generic" ; f prop_conv3_vs_gen-  putStrLn "convPSeries1' vs generic" ; f prop_conv1_vs_gen'-  putStrLn "convPSeries2' vs generic" ; f prop_conv2_vs_gen'-  putStrLn "convPSeries3' vs generic" ; f prop_conv3_vs_gen'-  putStrLn "convolve_pseries"  ; f prop_convolve_pseries -  putStrLn "convolve_pseries'" ; f prop_convolve_pseries' -  putStrLn "coinSeries vs pseries"  ; f prop_coin_vs_pseries-  putStrLn "coinSeries vs pseries'" ; f prop_coin_vs_pseries'-     -prop_leftIdentity ser = ( xs =!= unitSeries `convolve` xs ) where -  xs = fromSer ser --prop_rightIdentity ser = ( unitSeries `convolve` xs =!= xs ) where -  xs = fromSer ser --prop_commutativity ser1 ser2 = ( xs `convolve` ys =!= ys `convolve` xs ) where -  xs = fromSer ser1-  ys = fromSer ser2--prop_associativity ser1 ser2 ser3 = ( one =!= two ) where-  one = (xs `convolve` ys) `convolve` zs-  two = xs `convolve` (ys `convolve` zs)-  xs = fromSer ser1-  ys = fromSer ser2-  zs = fromSer ser3-  -prop_conv1_vs_gen exp1 ser = ( one =!= two ) where-  one = convolveWithPSeries1 k1 xs -  two = convolveWithPSeries [k1] xs-  k1 = fromExp exp1-  xs = fromSer ser  --prop_conv2_vs_gen exp1 exp2 ser = (one =!= two) where-  one = convolveWithPSeries2 k1 k2 xs -  two = convolveWithPSeries [k2,k1] xs-  k1 = fromExp exp1-  k2 = fromExp exp2-  xs = fromSer ser  --prop_conv3_vs_gen exp1 exp2 exp3 ser = (one =!= two) where-  one = convolveWithPSeries3 k1 k2 k3 xs -  two = convolveWithPSeries [k2,k3,k1] xs-  k1 = fromExp exp1-  k2 = fromExp exp2-  k3 = fromExp exp3-  xs = fromSer ser  --prop_conv1_vs_gen' exp1 ser = ( one =!= two ) where-  one = convolveWithPSeries1' ak1 xs -  two = convolveWithPSeries' [ak1] xs-  ak1 = fromCoeffExp exp1-  xs = fromSer ser  --prop_conv2_vs_gen' exp1 exp2 ser = (one =!= two) where-  one = convolveWithPSeries2' ak1 ak2 xs -  two = convolveWithPSeries' [ak2,ak1] xs-  ak1 = fromCoeffExp exp1-  ak2 = fromCoeffExp exp2-  xs = fromSer ser  --prop_conv3_vs_gen' exp1 exp2 exp3 ser = (one =!= two) where-  one = convolveWithPSeries3' ak1 ak2 ak3 xs -  two = convolveWithPSeries' [ak2,ak3,ak1] xs-  ak1 = fromCoeffExp exp1-  ak2 = fromCoeffExp exp2-  ak3 = fromCoeffExp exp3-  xs = fromSer ser  --prop_convolve_pseries exps1 ser = (one =!= two) where-  one = convolveWithPSeries ks1 xs -  two = xs `convolve` pseries ks1 -  ks1 = fromExps exps1-  xs = fromSer ser  --prop_convolve_pseries' cexps1 ser = (one =!= two) where-  one = convolveWithPSeries' aks1 xs -  two = xs `convolve` pseries' aks1 -  aks1 = fromCoeffExps cexps1-  xs = fromSer ser  --prop_coin_vs_pseries exps1 = (one =!= two) where-  one = coinSeries ks1 -  two = convolveMany (map pseries1 ks1)-  ks1 = fromExps exps1--prop_coin_vs_pseries' cexps1 = (one =!= two) where-  one = coinSeries' aks1 -  two = convolveMany (map pseries1' aks1)-  aks1 = fromCoeffExps cexps1-    -#endif -----------------------------------------------------------------------------------
− Math/Combinat/Partitions.hs 
@@ -1,263 +0,0 @@---- | Partitions. Partitions are nonincreasing sequences of positive integers.------ See also ---   Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 3B.--module Math.Combinat.Partitions-  ( -- * Type and basic stuff-    Partition-  , toPartition-  , toPartitionUnsafe-  , mkPartition-  , isPartition-  , fromPartition-  , height-  , width-  , heightWidth-  , weight-  , dualPartition-  , _dualPartition-  , elements-  , _elements-  , countAutomorphisms-  , _countAutomorphisms-    -- * Generation-  , partitions'  -  , _partitions' -  , countPartitions'-  , partitions-  , _partitions-  , countPartitions-  , allPartitions'  -  , allPartitions -  , countAllPartitions'-  , countAllPartitions-    -- * Paritions of multisets, vector partitions-  , partitionMultiset-  , IntVector-  , vectorPartitions-  , _vectorPartitions-  , fasc3B_algorithm_M-  ) -  where--import Data.List-import Data.Array.Unboxed--import Math.Combinat.Helper-import Math.Combinat.Numbers (factorial,binomial,multinomial)-------------------------------------------------------------------------------------- | The additional invariant enforced here is that partitions ---   are monotone decreasing sequences of positive integers.-newtype Partition = Partition [Int] deriving (Eq,Ord,Show,Read)---- | Sorts the input, and cuts the nonpositive elements.-mkPartition :: [Int] -> Partition-mkPartition xs = Partition $ sortBy (reverseCompare) $ filter (>0) xs---- | Assumes that the input is decreasing.-toPartitionUnsafe :: [Int] -> Partition-toPartitionUnsafe = Partition---- | Checks whether the input is a partition. See the note at 'isPartition'!-toPartition :: [Int] -> Partition-toPartition xs = if isPartition xs-  then toPartitionUnsafe xs-  else error "toPartition: not a partition"-  --- | Note: we only check that the sequence is ordered, but we /do not/ check for--- negative elements. This can be useful when working with symmetric functions.--- It may also change in the future...-isPartition :: [Int] -> Bool-isPartition []  = True-isPartition [_] = True-isPartition (x:xs@(y:_)) = (x >= y) && isPartition xs--fromPartition :: Partition -> [Int]-fromPartition (Partition part) = part---- | The first element of the sequence.-height :: Partition -> Int-height (Partition part) = case part of-  (p:_) -> p-  [] -> 0-  --- | The length of the sequence.-width :: Partition -> Int-width (Partition part) = length part--heightWidth :: Partition -> (Int,Int)-heightWidth part = (height part, width part)---- | The weight of the partition ---   (that is, the sum of the corresponding sequence).-weight :: Partition -> Int-weight (Partition part) = sum part---- | The dual (or conjugate) partition.-dualPartition :: Partition -> Partition-dualPartition (Partition part) = Partition (_dualPartition part)---- (we could be more efficient, but it hardly matters)-_dualPartition :: [Int] -> [Int]-_dualPartition [] = []-_dualPartition xs@(k:_) = [ length $ filter (>=i) xs | i <- [1..k] ]---- | Example:------ > elements (toPartition [5,2,1]) ==--- > [ (1,1), (1,2), (1,3), (1,4), (1,5)--- > , (2,1), (2,2), (2,3), (2,4)--- > , (3,1)--- > ]-elements :: Partition -> [(Int,Int)]-elements (Partition part) = _elements part--_elements :: [Int] -> [(Int,Int)]-_elements shape = [ (i,j) | (i,l) <- zip [1..] shape, j<-[1..l] ] ---- | Computes the number of \"automorphisms\" of a given partition.-countAutomorphisms :: Partition -> Integer  -countAutomorphisms = _countAutomorphisms . fromPartition--_countAutomorphisms :: [Int] -> Integer-_countAutomorphisms = multinomial . map length . group- -------------------------------------------------------------------------------------- | Partitions of d, fitting into a given rectangle, as lists.-_partitions' -  :: (Int,Int)     -- ^ (height,width)-  -> Int           -- ^ d-  -> [[Int]]        -_partitions' _ 0 = [[]] -_partitions' (0,_) d = if d==0 then [[]] else []-_partitions' (_,0) d = if d==0 then [[]] else []-_partitions' (h,w) d = -  [ i:xs | i <- [1..min d h] , xs <- _partitions' (i,w-1) (d-i) ]---- | Partitions of d, fitting into a given rectangle. The order is again lexicographic.-partitions'  -  :: (Int,Int)     -- ^ (height,width)-  -> Int           -- ^ d-  -> [Partition]-partitions' hw d = map toPartitionUnsafe $ _partitions' hw d        --countPartitions' :: (Int,Int) -> Int -> Integer-countPartitions' _ 0 = 1-countPartitions' (0,_) d = if d==0 then 1 else 0-countPartitions' (_,0) d = if d==0 then 1 else 0-countPartitions' (h,w) d = sum-  [ countPartitions' (i,w-1) (d-i) | i <- [1..min d h] ] ---- | Partitions of d, as lists-_partitions :: Int -> [[Int]]-_partitions d = _partitions' (d,d) d---- | Partitions of d.-partitions :: Int -> [Partition]-partitions d = partitions' (d,d) d--countPartitions :: Int -> Integer-countPartitions d = countPartitions' (d,d) d---- | All partitions fitting into a given rectangle.-allPartitions'  -  :: (Int,Int)        -- ^ (height,width)-  -> [[Partition]]-allPartitions' (h,w) = [ partitions' (h,w) i | i <- [0..d] ] where d = h*w---- | All partitions up to a given degree.-allPartitions :: Int -> [[Partition]]-allPartitions d = [ partitions i | i <- [0..d] ]---- | # = \\binom { h+w } { h }-countAllPartitions' :: (Int,Int) -> Integer-countAllPartitions' (h,w) = -  binomial (h+w) (min h w)-  --sum [ countPartitions' (h,w) i | i <- [0..d] ] where d = h*w--countAllPartitions :: Int -> Integer-countAllPartitions d = sum [ countPartitions i | i <- [0..d] ]-------------------------------------------------------------------------------------- | Partitions of a multiset.-partitionMultiset :: (Eq a, Ord a) => [a] -> [[[a]]]-partitionMultiset xs = parts where-  parts = (map . map) (f . elems) temp-  f ns = concat (zipWith replicate ns zs)-  temp = fasc3B_algorithm_M counts-  counts = map length ys-  ys = group (sort xs) -  zs = map head ys---- | 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 = fasc3B_algorithm_M . elems--_vectorPartitions :: [Int] -> [[[Int]]]-_vectorPartitions = map (map elems) . 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 xs = worker [start] where--  -- n = sum xs-  m = length xs--  start = [ (j,x,x) | (j,x) <- zip [1..] xs ]  -  -  worker stack@(last:_) = -    case decrease stack' of-      Nothing -> [visited]-      Just stack'' -> visited : worker stack''-    where-      stack'  = subtract_rec stack-      visited = map to_vector stack'-      -  decrease (last:rest) = -    case span (\(_,_,v) -> v==0) (reverse last) of-      ( _ , [(_,_,1)] ) -> case rest of-        [] -> Nothing-        _  -> decrease rest-      ( second , (c,u,v):first ) -> Just (modified:rest) where -        modified =   -          reverse first ++ -          (c,u,v-1) :  -          [ (c,u,u) | (c,u,_) <- reverse second ] -      _ -> error "should not happen"-        -  to_vector cuvs = -    accumArray (flip const) 0 (1,m)-      [ (c,v) | (c,_,v) <- cuvs ] --  subtract_rec all@(last:_) = -    case subtract last of -      []  -> all-      new -> subtract_rec (new:all) --  subtract [] = []-  subtract full@((c,u,v):rest) = -    if w >= v -      then (c,w,v) : subtract   rest-      else           subtract_b full-    where w = u - v-    -  subtract_b [] = []-  subtract_b ((c,u,v):rest) = -    if w /= 0 -      then (c,w,w) : subtract_b rest-      else           subtract_b rest-    where w = u - v----------------------------------------------------------------------------------
− Math/Combinat/Permutations.hs 
@@ -1,514 +0,0 @@---- | Permutations. See:---   Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 2B.----{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE CPP, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}-module Math.Combinat.Permutations -  ( -- * Types-    Permutation-  , DisjointCycles-  , fromPermutation-  , permutationArray-  , toPermutationUnsafe-  , arrayToPermutationUnsafe-  , isPermutation-  , toPermutation-  , permutationSize-    -- * Disjoint cycles-  , fromDisjointCycles-  , disjointCyclesUnsafe-  , permutationToDisjointCycles-  , disjointCyclesToPermutation-  , isEvenPermutation-  , isOddPermutation-  , signOfPermutation-  , isCyclicPermutation-    -- * Permutation groups-  , permute-  , permuteList-  , multiply-  , inverse-  , identity-    -- * Simple permutations-  , permutations-  , _permutations-  , permutationsNaive-  , _permutationsNaive-  , countPermutations-    -- * Random permutations-  , randomPermutation-  , _randomPermutation-  , randomCyclicPermutation-  , _randomCyclicPermutation-  , randomPermutationDurstenfeld-  , randomCyclicPermutationSattolo-    -- * Multisets-  , permuteMultiset-  , countPermuteMultiset-  , fasc2B_algorithm_L--#ifdef QUICKCHECK-    -- * QuickCheck -  , checkAll-#endif QUICKCHECK-  ) -  where--import Control.Monad-import Control.Monad.ST--#if BASE_VERSION < 4-import Data.List -#else-import Data.List hiding (permutations)-#endif--import Data.Array-import Data.Array.ST--import Math.Combinat.Helper-import Math.Combinat.Numbers (factorial,binomial)--import System.Random--#ifdef QUICKCHECK-import Test.QuickCheck-#endif------------------------------------------------------------------------------------- * Types---- | Standard notation for permutations. Internally it is an array of the integers @[1..n]@. -newtype Permutation = Permutation (Array Int Int) deriving (Eq,Ord,Show,Read)---- | Disjoint cycle notation for permutations. Internally it is @[[Int]]@.-newtype DisjointCycles = DisjointCycles [[Int]] deriving (Eq,Ord,Show,Read)--fromPermutation :: Permutation -> [Int]-fromPermutation (Permutation ar) = elems ar--permutationArray :: Permutation -> Array Int Int-permutationArray (Permutation ar) = ar---- | Assumes that the input is a permutation of the numbers @[1..n]@.-toPermutationUnsafe :: [Int] -> Permutation-toPermutationUnsafe xs = Permutation perm where-  n = length xs-  perm = listArray (1,n) xs---- Indexing starts from 1.-arrayToPermutationUnsafe :: Array Int Int -> Permutation-arrayToPermutationUnsafe = Permutation---- | Checks whether the input is a permutation of the numbers @[1..n]@.-isPermutation :: [Int] -> Bool-isPermutation xs = (ar!0 == 0) && and [ ar!j == 1 | j<-[1..n] ] where-  n = length xs-  -- the zero index is an unidiomatic hack-  ar = accumArray (+) 0 (0,n) $ map f xs -  f :: Int -> (Int,Int)-  f j = if j<1 || j>n then (0,1) else (j,1)---- | Checks the input.-toPermutation :: [Int] -> Permutation-toPermutation xs = if isPermutation xs -  then toPermutationUnsafe xs-  else error "toPermutation: not a permutation"---- | Returns @n@, where the input is a permutation of the numbers @[1..n]@-permutationSize :: Permutation -> Int-permutationSize (Permutation ar) = snd $ bounds ar------------------------------------------------------------------------------------- * Disjoint cycles--fromDisjointCycles :: DisjointCycles -> [[Int]]-fromDisjointCycles (DisjointCycles cycles) = cycles--disjointCyclesUnsafe :: [[Int]] -> DisjointCycles -disjointCyclesUnsafe = DisjointCycles-  -disjointCyclesToPermutation :: Int -> DisjointCycles -> Permutation-disjointCyclesToPermutation n (DisjointCycles cycles) = Permutation perm where-  pairs :: [Int] -> [(Int,Int)]-  pairs xs@(x:_) = worker (xs++[x]) where-    worker (x:xs@(y:_)) = (x,y):worker xs-    worker _ = [] -  perm = runST $ do-    ar <- newArray_ (1,n) :: ST s (STUArray s Int Int)-    forM_ [1..n] $ \i -> writeArray ar i i -    forM_ cycles $ \cyc -> forM_ (pairs cyc) $ \(i,j) -> writeArray ar i j-    freeze ar-  --- | This is compatible with Maple's @convert(perm,\'disjcyc\')@.  -permutationToDisjointCycles :: Permutation -> DisjointCycles-permutationToDisjointCycles (Permutation perm) = res where--  (1,n) = bounds perm--  -- we don't want trivial cycles-  f :: [Int] -> Bool-  f [_] = False-  f _ = True-  -  res = runST $ do-    tag <- newArray (1,n) False -    cycles <- unfoldM (step tag) 1 -    return (DisjointCycles $ filter f cycles)-    -  step :: STUArray s Int Bool -> Int -> ST s ([Int],Maybe Int)-  step tag k = do-    cyc <- worker tag k k [k] -    m <- next tag (k+1)-    return (reverse cyc,m)-    -  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)-  next tag k = if k > n-    then return Nothing-    else readArray tag k >>= \b -> if b -      then next tag (k+1)  -      else return (Just k)-       -  worker :: STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int]-  worker tag k l cyc = do-    writeArray tag l True-    let m = perm ! l-    if m == k -      then return cyc-      else worker tag k m (m:cyc)      --isEvenPermutation :: Permutation -> Bool-isEvenPermutation (Permutation perm) = res where--  (1,n) = bounds perm-  res = runST $ do-    tag <- newArray (1,n) False -    cycles <- unfoldM (step tag) 1 -    return $ even (sum cycles)-    -  step :: STUArray s Int Bool -> Int -> ST s (Int,Maybe Int)-  step tag k = do-    cyclen <- worker tag k k 0-    m <- next tag (k+1)-    return (cyclen,m)-    -  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)-  next tag k = if k > n-    then return Nothing-    else readArray tag k >>= \b -> if b -      then next tag (k+1)  -      else return (Just k)-      -  worker :: STUArray s Int Bool -> Int -> Int -> Int -> ST s Int-  worker tag k l cyclen = do-    writeArray tag l True-    let m = perm ! l-    if m == k -      then return cyclen-      else worker tag k m (1+cyclen)      --isOddPermutation :: Permutation -> Bool-isOddPermutation = not . isEvenPermutation---- | Plus 1 or minus 1.-signOfPermutation :: Num a => Permutation -> a-signOfPermutation perm = case isEvenPermutation perm of-  True  ->   1-  False -> (-1)-  -isCyclicPermutation :: Permutation -> Bool-isCyclicPermutation perm = -  case cycles of-    []    -> True-    [cyc] -> (length cyc == n)-    _     -> False-  where -    n = permutationSize perm-    DisjointCycles cycles = permutationToDisjointCycles perm-   ------------------------------------------------------------------------------------ * Permutation groups-    --- | Action of a permutation on a set. If our permutation is --- encoded with the sequence @[p1,p2,...,pn]@, then in the--- two-line notation we have------ > ( 1  2  3  ... n  )--- > ( p1 p2 p3 ... pn )------ We adopt the convention that permutations act /on the left/ --- (as opposed to Knuth, where they act on the right).--- Thus, --- --- > permute pi1 (permute pi2 set) == permute (pi1 `multiply` pi2) set---   --- The second argument should be an array with bounds @(1,n)@.--- The function checks the array bounds.-permute :: Permutation -> Array Int a -> Array Int a    -permute pi@(Permutation perm) ar = -  if (a==1) && (b==n) -    then listArray (1,n) [ ar!(perm!i) | i <- [1..n] ] -    else error "permute: array bounds do not match"-  where-    (_,n) = bounds perm  -    (a,b) = bounds ar   ---- | The list should be of length @n@.-permuteList :: Permutation -> [a] -> [a]    -permuteList perm xs = elems $ permute perm $ listArray (1,n) xs where-  n = permutationSize perm---- | Multiplies two permutations together. See 'permute' for our--- conventions.  -multiply :: Permutation -> Permutation -> Permutation-multiply pi1@(Permutation perm1) (Permutation perm2) = -  if (n==m) -    then Permutation result-    else error "multiply: permutations of different sets"  -  where-	  (_,n) = bounds perm1-	  (_,m) = bounds perm2    -	  result = permute pi1 perm2    -  -infixr 7 `multiply`  -    --- | The inverse permutation.-inverse :: Permutation -> Permutation    -inverse (Permutation perm1) = Permutation result-  where-    result = array (1,n) $ map swap $ assocs perm1-    (_,n) = bounds perm1-    --- | The trivial permutation.-identity :: Int -> Permutation -identity n = Permutation $ listArray (1,n) [1..n]------------------------------------------------------------------------------------- * Permutations of distinct elements---- | A synonym for 'permutationsNaive'-permutations :: Int -> [Permutation]-permutations = permutationsNaive--_permutations :: Int -> [[Int]]-_permutations = _permutationsNaive---- | Permutations of @[1..n]@ in lexicographic order, naive algorithm.-permutationsNaive :: Int -> [Permutation]-permutationsNaive n = map toPermutationUnsafe $ _permutations n --_permutationsNaive :: Int -> [[Int]]  -_permutationsNaive 0 = [[]]-_permutationsNaive 1 = [[1]]-_permutationsNaive n = helper [1..n] where-  helper [] = [[]]-  helper xs = [ i : ys | i <- xs , ys <- helper (xs `minus` i) ]-  minus [] _ = []-  minus (x:xs) i = if x < i then x : minus xs i else xs-          --- | # = n!-countPermutations :: Int -> Integer-countPermutations = factorial------------------------------------------------------------------------------------- * Random permutations---- | A synonym for 'randomPermutationDurstenfeld'.-randomPermutation :: RandomGen g => Int -> g -> (Permutation,g)-randomPermutation = randomPermutationDurstenfeld--_randomPermutation :: RandomGen g => Int -> g -> ([Int],g)-_randomPermutation n rndgen = (fromPermutation perm, rndgen') where-  (perm, rndgen') = randomPermutationDurstenfeld n rndgen ---- | A synonym for 'randomCyclicPermutationSattolo'.-randomCyclicPermutation :: RandomGen g => Int -> g -> (Permutation,g)-randomCyclicPermutation = randomCyclicPermutationSattolo--_randomCyclicPermutation :: RandomGen g => Int -> g -> ([Int],g)-_randomCyclicPermutation n rndgen = (fromPermutation perm, rndgen') where-  (perm, rndgen') = randomCyclicPermutationSattolo n rndgen ---- | Generates a uniformly random permutation of @[1..n]@.--- Durstenfeld's algorithm (see <http://en.wikipedia.org/wiki/Knuth_shuffle>).-randomPermutationDurstenfeld :: RandomGen g => Int -> g -> (Permutation,g)-randomPermutationDurstenfeld = randomPermutationDurstenfeldSattolo False---- | Generates a uniformly random /cyclic/ permutation of @[1..n]@.--- Sattolo's algorithm (see <http://en.wikipedia.org/wiki/Knuth_shuffle>).-randomCyclicPermutationSattolo :: RandomGen g => Int -> g -> (Permutation,g)-randomCyclicPermutationSattolo = randomPermutationDurstenfeldSattolo True--randomPermutationDurstenfeldSattolo :: RandomGen g => Bool -> Int -> g -> (Permutation,g)-randomPermutationDurstenfeldSattolo isSattolo n rnd = res where-  res = runST $ do-    ar <- newArray_ (1,n) -    forM_ [1..n] $ \i -> writeArray ar i i-    rnd' <- worker n (if isSattolo then n-1 else n) rnd ar -    perm <- unsafeFreeze ar-    return (Permutation perm, rnd')-  worker :: RandomGen g => Int -> Int -> g -> STUArray s Int Int -> ST s g -  worker n m rnd ar = -    if n==1 -      then return rnd -      else do-        let (k,rnd') = randomR (1,m) rnd-        when (k /= n) $ do-          y <- readArray ar k -          z <- readArray ar n-          writeArray ar n y-          writeArray ar k z-        worker (n-1) (m-1) rnd' ar ------------------------------------------------------------------------------------- * Permutations of a multiset---- | Generates all permutations of a multiset.  ---   The order is lexicographic. A synonym for 'fasc2B_algorithm_L'-permuteMultiset :: (Eq a, Ord a) => [a] -> [[a]] -permuteMultiset = fasc2B_algorithm_L---- | # = \\frac { (\sum_i n_i) ! } { \\prod_i (n_i !) }    -countPermuteMultiset :: (Eq a, Ord a) => [a] -> Integer-countPermuteMultiset xs = factorial n `div` product [ factorial (length z) | z <- group ys ] -  where-    ys = sort xs-    n = length xs-  --- | Generates all permutations of a multiset ---   (based on \"algorithm L\" in Knuth; somewhat less efficient). ---   The order is lexicographic.  -fasc2B_algorithm_L :: (Eq a, Ord a) => [a] -> [[a]] -fasc2B_algorithm_L xs = unfold1 next (sort xs) where-  -- next :: [a] -> Maybe [a]-  next xs = case findj (reverse xs,[]) of -    Nothing -> Nothing-    Just ( (l:ls) , rs) -> Just $ inc l ls (reverse rs,[]) -    Just ( [] , _ ) -> error "permute: should not happen"--  -- we use simple list zippers: (left,right)-  -- findj :: ([a],[a]) -> Maybe ([a],[a])   -  findj ( xxs@(x:xs) , yys@(y:_) ) = if x >= y -    then findj ( xs , x : yys )-    else Just ( xxs , yys )-  findj ( x:xs , [] ) = findj ( xs , [x] )  -  findj ( [] , _ ) = Nothing-  -  -- inc :: a -> [a] -> ([a],[a]) -> [a]-  inc u us ( (x:xs) , yys ) = if u >= x-    then inc u us ( xs , x : yys ) -    else reverse (x:us)  ++ reverse (u:yys) ++ xs-  inc _ _ ( [] , _ ) = error "permute: should not happen"-      -----------------------------------------------------------------------------------#ifdef QUICKCHECK--minPermSize = 1-maxPermSize = 123--newtype Elem = Elem Int deriving Eq-newtype Nat  = Nat { fromNat :: Int } deriving (Eq,Ord,Show,Num,Random)--naturalSet :: Permutation -> Array Int Elem-naturalSet perm = listArray (1,n) [ Elem i | i<-[1..n] ] where-  n = permutationSize perm--sameSize :: Permutation ->  Permutation -> Bool-sameSize perm1 perm2 = ( permutationSize perm1 == permutationSize perm2)--newtype CyclicPermutation = Cyclic { fromCyclic :: Permutation } deriving Show--data SameSize = SameSize Permutation Permutation deriving Show--instance Random Permutation where-  random g = randomPermutation size g1 where-    (size,g1) = randomR (minPermSize,maxPermSize) g-  randomR _ = random--instance Random CyclicPermutation where-  random g = (Cyclic cycl,g2) where-    (size,g1) = randomR (minPermSize,maxPermSize) g-    (cycl,g2) = randomCyclicPermutation size g1-  randomR _ = random--instance Random DisjointCycles where-  random g = (disjcyc,g2) where-    (size,g1) = randomR (minPermSize,maxPermSize) g-    (perm,g2) = randomPermutation size g1-    disjcyc   = permutationToDisjointCycles perm-  randomR _ = random--instance Random SameSize where-  random g = (SameSize prm1 prm2, g3) where-    (size,g1) = randomR (minPermSize,maxPermSize) g-    (prm1,g2) = randomPermutation size g1 -    (prm2,g3) = randomPermutation size g2-  randomR _ = random--instance Arbitrary Nat where-  arbitrary = choose (Nat 0 , Nat 50)-     -instance Arbitrary Permutation       where arbitrary = choose undefined-instance Arbitrary CyclicPermutation where arbitrary = choose undefined-instance Arbitrary DisjointCycles    where arbitrary = choose undefined-instance Arbitrary SameSize          where arbitrary = choose undefined---- | Runs all quickCheck tests-checkAll :: IO ()-checkAll = do-  let f :: Testable a => a -> IO ()-      f = quickCheck-  f prop_disjcyc1-  f prop_disjcyc2 -  f prop_randCyclic-  f prop_inverse-  f prop_mulPerm-  f prop_mulSign      -  f prop_invMul-  f prop_cyclSign-  f prop_permIsPerm-  f prop_isEven-          -prop_disjcyc1 perm = ( perm == disjointCyclesToPermutation n (permutationToDisjointCycles perm) )-  where n = permutationSize perm-prop_disjcyc2 k dcyc = ( dcyc == permutationToDisjointCycles (disjointCyclesToPermutation n dcyc) )-  where -    n = fromNat k + m -    m = case fromDisjointCycles dcyc of-      [] -> 1-      xxs -> maximum (concat xxs)--prop_randCyclic cycl = ( isCyclicPermutation (fromCyclic cycl) )--prop_inverse perm = ( perm == inverse (inverse perm) ) --prop_mulPerm (SameSize perm1 perm2) = -    ( permute perm1 (permute perm2 set) == permute (perm1 `multiply` perm2) set ) -  where -    set = naturalSet perm1--prop_mulSign (SameSize perm1 perm2) = -    ( sgn perm1 * sgn perm2 == sgn (perm1 `multiply` perm2) ) -  where -    sgn = signOfPermutation :: Permutation -> Int--prop_invMul (SameSize perm1 perm2) =   -  ( inverse perm2 `multiply` inverse perm1 == inverse (perm1 `multiply` perm2) ) --prop_cyclSign cycl = ( isEvenPermutation perm == odd n ) where-  perm = fromCyclic cycl-  n = permutationSize perm-  -prop_permIsPerm perm = ( isPermutation (fromPermutation perm) ) --prop_isEven perm = ( isEvenPermutation perm == isEvenAlternative perm ) where-  isEvenAlternative p = -    even $ sum $ map (\x->x-1) $ map length $ fromDisjointCycles $ permutationToDisjointCycles p---#endif-----------------------------------------------------------------------------------
− Math/Combinat/Sets.hs 
@@ -1,81 +0,0 @@---- | Subsets. --module Math.Combinat.Sets -  ( -    choose-  , combine , compose-  , tuplesFromList-  , listTensor-    -- -  , kSublists-  , sublists-  , countKSublists-  , countSublists-  ) -  where--import Math.Combinat.Numbers (binomial)-------------------------------------------------------------------------------------- | All possible ways to choose @k@ elements from a list, without--- repetitions. \"Antisymmetric power\" for lists. Synonym for "kSublists".-choose :: Int -> [a] -> [[a]]-choose 0 _  = [[]]-choose k [] = []-choose k (x:xs) = map (x:) (choose (k-1) xs) ++ choose k xs  ---- | All possible ways to choose @k@ elements from a list, /with repetitions/. --- \"Symmetric power\" for lists. See also "Math.Combinat.Combinations".--- TODO: better name?-combine :: Int -> [a] -> [[a]]-combine 0 _  = [[]]-combine k [] = []-combine k xxs@(x:xs) = map (x:) (combine (k-1) xxs) ++ combine k xs  ---- | A synonym for 'combine'.-compose :: Int -> [a] -> [[a]]-compose = combine---- | \"Tensor power\" for lists. Special case of 'listTensor':------ > tuplesFromList k xs == listTensor (replicate k xs)--- --- See also "Math.Combinat.Tuples".--- TODO: better name?-tuplesFromList :: Int -> [a] -> [[a]]-tuplesFromList 0 _  = [[]]-tuplesFromList k xs = [ (y:ys) | ys <- tuplesFromList (k-1) xs , y <- xs ]---the order seems to be very important, the wrong order causes a memory leak!---tuplesFromList k xs = [ (y:ys) | y <- xs, ys <- tuplesFromList (k-1) xs ]- --- | \"Tensor product\" for lists.-listTensor :: [[a]] -> [[a]]-listTensor [] = [[]]-listTensor (xs:xss) = [ y:ys | ys <- listTensor xss , y <- xs ]---the order seems to be very important, the wrong order causes a memory leak!---listTensor (xs:xss) = [ y:ys | y <- xs, ys <- listTensor xss ]-------------------------------------------------------------------------------------- | Sublists of a list having given number of elements.-kSublists :: Int -> [a] -> [[a]]-kSublists = choose---- | @# = \binom { n } { k }@.-countKSublists :: Int -> Int -> Integer-countKSublists k n = binomial n k ---- | All sublists of a list.-sublists :: [a] -> [[a]]-sublists [] = [[]]-sublists (x:xs) = sublists xs ++ map (x:) (sublists xs)  ---the order seems to be very important, the wrong order causes a memory leak!---sublists (x:xs) = map (x:) (sublists xs) ++ sublists xs ---- | @# = 2^n@.-countSublists :: Int -> Integer-countSublists n = 2 ^ n----------------------------------------------------------------------------------
− Math/Combinat/Tableaux.hs 
@@ -1,159 +0,0 @@---- | Young tableaux and similar gadgets. ---   See e.g. William Fulton: Young Tableaux, with Applications to ---   Representation theory and Geometry (CUP 1997).--- ---   The convention is that we use ---   the English notation, and we store the tableaux as lists of the rows.--- ---   That is, the following standard tableau of shape [5,4,1]--- --- >  1  3  4  6  7--- >  2  5  8 10--- >  9------   is encoded conveniently as--- --- > [ [ 1 , 3 , 4 , 6 , 7 ]--- > , [ 2 , 5 , 8 ,10 ]--- > , [ 9 ]--- > ]-----module Math.Combinat.Tableaux where--import Data.List--import Math.Combinat.Helper-import Math.Combinat.Numbers (factorial,binomial)-import Math.Combinat.Partitions------------------------------------------------------------------------------------- * Basic stuff--type Tableau a = [[a]]--_shape :: Tableau a -> [Int]-_shape t = map length t --shape :: Tableau a -> Partition-shape t = toPartition (_shape t)--dualTableau :: Tableau a -> Tableau a-dualTableau = transpose--content :: Tableau a -> [a]-content = concat---- | An element @(i,j)@ of the resulting tableau (which has shape of the--- given partition) means that the vertical part of the hook has length @i@,--- and the horizontal part @j@. The /hook length/ is thus @i+j-1@. ------ Example:------ > > mapM_ print $ hooks $ toPartition [5,4,1]--- > [(3,5),(2,4),(2,3),(2,2),(1,1)]--- > [(2,4),(1,3),(1,2),(1,1)]--- > [(1,1)]----hooks :: Partition -> Tableau (Int,Int)-hooks part = zipWith f p [1..] where -  p = fromPartition part-  q = _dualPartition p-  f l i = zipWith (\x y -> (x-i+1,y)) q [l,l-1..1] --hookLengths :: Partition -> Tableau Int-hookLengths part = (map . map) (\(i,j) -> i+j-1) (hooks part) ------------------------------------------------------------------------------------- * Row and column words--rowWord :: Tableau a -> [a]-rowWord = concat . reverse--rowWordToTableau :: Ord a => [a] -> Tableau a-rowWordToTableau xs = reverse rows where-  rows = break xs-  break [] = [[]]-  break [x] = [[x]]-  break (x:xs@(y:_)) = if x>y-    then [x] : break xs-    else let (h:t) = break xs in (x:h):t--columnWord :: Tableau a -> [a]-columnWord = rowWord . transpose--columnWordToTableau :: Ord a => [a] -> Tableau a-columnWordToTableau = transpose . rowWordToTableau-    ------------------------------------------------------------------------------------ * Standard Young tableaux---- | Standard Young tableaux of a given shape.---   Adapted from John Stembridge, ---   <http://www.math.lsa.umich.edu/~jrs/software/SFexamples/tableaux>.-standardYoungTableaux :: Partition -> [Tableau Int]-standardYoungTableaux shape' = map rev $ tableaux shape where-  shape = fromPartition shape'-  rev = reverse . map reverse-  tableaux :: [Int] -> [Tableau Int]-  tableaux p = -    case p of-      []  -> [[]]-      [n] -> [[[n,n-1..1]]]-      _   -> worker (n,k) 0 [] p-    where-      n = sum p-      k = length p-  worker :: (Int,Int) -> Int -> [Int] -> [Int] -> [Tableau Int]-  worker _ _ _ [] = []-  worker nk i ls (x:rs) = case rs of-    (y:_) -> if x==y -      then worker nk (i+1) (x:ls) rs-      else worker2 nk i ls x rs-    [] ->  worker2 nk i ls x rs-  worker2 :: (Int,Int) -> Int -> [Int] -> Int -> [Int] -> [Tableau Int]-  worker2 nk@(n,k) i ls x rs = new ++ worker nk (i+1) (x:ls) rs where-    old = if x>1 -      then             tableaux $ reverse ls ++ (x-1) : rs-      else map ([]:) $ tableaux $ reverse ls ++ rs   -    a = k-1-i-    new = {- debug ( i , a , head old , f a (head old) ) $ -}-      map (f a) old-    f :: Int -> Tableau Int -> Tableau Int-    f _ [] = []-    f 0 (t:ts) = (n:t) : f (-1) ts-    f j (t:ts) = t : f (j-1) ts-  --- | hook-length formula-countStandardYoungTableaux :: Partition -> Integer-countStandardYoungTableaux part = {- debug (hookLengths part) $ -}-  factorial n `div` h where-    h = product $ map fromIntegral $ concat $ hookLengths part -    n = weight part-        ------------------------------------------------------------------------------------ * Semistandard Young tableaux-   --- | Semistandard Young tableaux of given shape, \"naive\" algorithm    -semiStandardYoungTableaux :: Int -> Partition -> [Tableau Int]-semiStandardYoungTableaux n part = worker (repeat 0) shape where-  shape = fromPartition part-  worker _ [] = [[]] -  worker prevRow (s:ss) -    = [ (r:rs) | r <- row n s 1 prevRow, rs <- worker (map (+1) r) ss ]--  -- weekly increasing lists of length @len@, pointwise at least @xs@, -  -- maximum value @n@, minimum value @prev@.-  row :: Int -> Int -> Int -> [Int] -> [[Int]]-  row _ 0   _    _      = [[]]-  row n len prev (x:xs) = [ (a:as) | a <- [max x prev..n] , as <- row n (len-1) a xs ]---- | Stanley's hook formula (cf. Fulton page 55)-countSemiStandardYoungTableaux :: Int -> Partition -> Integer-countSemiStandardYoungTableaux n shape = k `div` h where-  h = product $ map fromIntegral $ concat $ hookLengths shape -  k = product [ fromIntegral (n+j-i) | (i,j) <- elements shape ]-  ----------------------------------------------------------------------------------
− Math/Combinat/Tableaux/Kostka.hs 
@@ -1,222 +0,0 @@---- TODO: better name?---- | This module contains a function to generate (equivalence classes of) --- triangular tableaux of size /k/, strictly increasing to the right and --- to the bottom. For example--- --- >  1  --- >  2  4  --- >  3  5  8  --- >  6  7  9  10 ------ is such a tableau of size 4.--- The numbers filling a tableau always consist of an interval @[1..c]@;--- @c@ is called the /content/ of the tableaux. There is a unique tableau--- of minimal content @2k-1@:------ >  1  --- >  2  3  --- >  3  4  5 --- >  4  5  6  7 --- --- Let us call the tableaux with maximal content (that is, @m = binomial (k+1) 2@)--- /standard/. The number of standard tableaux are------ > 1, 1, 2, 12, 286, 33592, 23178480, ...------ OEIS:A003121, \"Strict sense ballot numbers\", --- <http://www.research.att.com/~njas/sequences/A003121>.------ See --- R. M. Thrall, A combinatorial problem, Michigan Math. J. 1, (1952), 81-88.--- --- The number of tableaux with content @c=m-d@ are--- --- >  d=  |     0      1      2      3    ...--- > -----+------------------------------------------------- >  k=2 |     1--- >  k=3 |     2      1--- >  k=4 |    12     18      8      1--- >  k=5 |   286    858   1001    572    165     22     1--- >  k=6 | 33592 167960 361114 436696 326196 155584 47320 8892 962 52 1 ------ We call these \"Kostka tableaux\" (in the lack of a better name), since--- they are in bijection with the simplicial cones in a canonical simplicial --- decompositions of the Gelfand-Tsetlin cones (the content corresponds--- to the dimension), which encode the combinatorics of Kostka numbers.-----module Math.Combinat.Tableaux.Kostka -  ( -    Tableau-  , Tri(..)-  , TriangularArray-  , fromTriangularArray-  , triangularArrayUnsafe-  , kostkaTableaux-  , _kostkaTableaux-  , countKostkaTableaux-  , kostkaContent-  , _kostkaContent-  ) -  where------------------------------------------------------------------------------------import Data.Ix-import Data.Ord-import Data.List--import Control.Monad-import Control.Monad.ST-import Data.Array.IArray-import Data.Array.Unboxed-import Data.Array.ST--import Math.Combinat.Tableaux (Tableau)-import Math.Combinat.Helper-------------------------------------------------------------------------------------- | Triangular arrays-type TriangularArray a = Array Tri a---- | Set of @(i,j)@ pairs with @i>=j>=1@.-newtype Tri = Tri { unTri :: (Int,Int) } deriving (Eq,Ord,Show)--binom2 :: Int -> Int-binom2 n = (n*(n-1)) `div` 2--index' :: Tri -> Int-index' (Tri (i,j)) = binom2 i + j - 1---- it should be (1+8*m), --- the 2 is a hack to be safe with the floating point stuff-deIndex' :: Int -> Tri -deIndex' m = Tri ( i+1 , m - binom2 (i+1) + 1 ) where-  i = ( (floor.sqrt.(fromIntegral::Int->Double)) (2+8*m) - 1 ) `div` 2  --instance Ix Tri where-  index   (a,b) x = index' x - index' a -  inRange (a,b) x = (u<=j && j<=v) where-    u = index' a -    v = index' b-    j = index' x-  range     (a,b) = map deIndex' [ index' a .. index' b ] -  rangeSize (a,b) = index' b - index' a + 1 --{-# SPECIALIZE triangularArrayUnsafe :: Tableau Int -> TriangularArray Int #-}-triangularArrayUnsafe :: Tableau a -> TriangularArray a-triangularArrayUnsafe tableau = listArray (Tri (1,1),Tri (k,k)) (concat tableau) -  where k = length tableau--{-# SPECIALIZE fromTriangularArray :: TriangularArray Int -> Tableau Int #-}-fromTriangularArray :: TriangularArray a -> Tableau a-fromTriangularArray arr = (map.map) snd $ groupBy (equating f) $ assocs arr-  where f = fst . unTri . fst-  ------------------------------------------------------------------------------------- "fractional fillings"-data Hole = Hole Int Int deriving (Eq,Ord,Show)--type ReverseTableau      = [[Int ]] -type ReverseHoleTableau  = [[Hole]]      --toHole :: Int -> Hole-toHole k = Hole k 0--nextHole :: Hole -> Hole-nextHole (Hole k l) = Hole k (l+1)--{-# SPECIALIZE reverseTableau :: [[Int]] -> [[Int]] #-}-reverseTableau :: [[a]] -> [[a]]-reverseTableau = reverse . map reverse------------------------------------------------------------------------------------kostkaContent :: TriangularArray Int -> Int-kostkaContent arr = arr ! (snd (bounds arr))--_kostkaContent :: Tableau Int -> Int-_kostkaContent = last . last- -normalize :: ReverseHoleTableau -> TriangularArray Int -normalize = snd . normalize'---- returns ( content , tableau )-normalize' :: ReverseHoleTableau -> ( Int , TriangularArray Int )   -normalize' holes = ( c , array (Tri (1,1), Tri (k,k)) xys ) where-  k = length holes-  c = length sorted-  xys = concat $ zipWith hs [1..] sorted-  hs a xs     = map (h a) xs-  h  a (ij,_) = (Tri ij , a)  -  sorted = groupSortBy snd (concat withPos)-  withPos = zipWith f [1..] (reverseTableau holes) -  f i xs = zipWith (g i) [1..] xs -  g i j hole = ((i,j),hole) ------------------------------------------------------------------------------------startHole :: [Hole] -> [Int] -> Hole -startHole (t:ts) (p:ps) = max t (toHole p)-startHole (t:ts) []     = t-startHole []     (p:ps) = toHole p-startHole []     []     = error "startHole"---- c is the "content" of the small tableau-enumHoles :: Int -> Hole -> [Hole]-enumHoles c start@(Hole k l) -  = nextHole start -  : [ Hole i 0 | i <- [k+1..c] ] ++ [ Hole i 1 | i <- [k+1..c] ]--helper :: Int -> [Int] -> [Hole] -> [[Hole]]-helper c [] this = [[]] -helper c prev@(p:ps) this = -  [ t:rest | t <- enumHoles c (startHole this prev), rest <- helper c ps (t:this) ]--newLines' :: Int -> [Int] -> [[Hole]]-newLines' c lastReversed = helper c last []  -  where-    top  = head lastReversed-    last = reverse (top : lastReversed)--newLines :: [Int] -> [[Hole]]-newLines lastReversed = newLines' (head lastReversed) lastReversed---- | Generates all tableaux of size @k@. Effective for @k<=6@.-kostkaTableaux :: Int -> [TriangularArray Int]-kostkaTableaux 0 = [ triangularArrayUnsafe [] ]-kostkaTableaux 1 = [ triangularArrayUnsafe [[1]] ]-kostkaTableaux k = map normalize $ concatMap f smalls where-  smalls :: [ [[Int]] ]-  smalls = map (reverseTableau . fromTriangularArray) $ kostkaTableaux (k-1)-  f :: [[Int]] -> [ [[Hole]] ]-  f small = map (:smallhole) $ map reverse $ newLines (head small) where-    smallhole = map (map toHole) small--_kostkaTableaux :: Int -> [Tableau Int]-_kostkaTableaux k = map fromTriangularArray $ kostkaTableaux k------------------------------------------------------------------------------------countKostkaTableaux :: Int -> [Int]-countKostkaTableaux = elems . sizes'--sizes' :: Int -> UArray Int Int-sizes' k = -  runSTUArray $ do-    let (a,b) = ( 2*k-1 , binom2 (k+1) )-    ar <- newArray (a,b) 0 :: ST s (STUArray s Int Int)   -    mapM_ (worker ar) $ kostkaTableaux k -    return ar-  where-    worker :: STUArray s Int Int -> TriangularArray Int -> ST s ()-    worker ar t = do-      let c = kostkaContent t -      n <- readArray ar c  -      writeArray ar c (n+1)-     ---------------------------------------------------------------------------------
− Math/Combinat/Trees.hs 
@@ -1,9 +0,0 @@--module Math.Combinat.Trees-  ( module Math.Combinat.Trees.Binary-  , module Math.Combinat.Trees.Nary-  ) where--import Math.Combinat.Trees.Binary-import Math.Combinat.Trees.Nary-
− Math/Combinat/Trees/Binary.hs 
@@ -1,333 +0,0 @@---- | Binary trees, forests, etc. See:---   Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 4A.--module Math.Combinat.Trees.Binary -  ( -- * Types-    BinTree(..)-  , leaf-  , BinTree'(..)-  , forgetNodeDecorations-  , module Data.Tree -  , Paren(..)-  , parenthesesToString-  , stringToParentheses-    -- * Bijections-  , forestToNestedParentheses-  , forestToBinaryTree-  , nestedParenthesesToForest-  , nestedParenthesesToForestUnsafe-  , nestedParenthesesToBinaryTree-  , nestedParenthesesToBinaryTreeUnsafe-  , binaryTreeToForest-  , binaryTreeToNestedParentheses-    -- * Nested parentheses-  , nestedParentheses -  , randomNestedParentheses-  , nthNestedParentheses-  , countNestedParentheses-  , fasc4A_algorithm_P-  , fasc4A_algorithm_W-  , fasc4A_algorithm_U-    -- * Binary trees-  , binaryTrees-  , countBinaryTrees-  , binaryTreesNaive-  , randomBinaryTree-  , fasc4A_algorithm_R-  ) -  where------------------------------------------------------------------------------------import Control.Applicative-import Control.Monad-import Control.Monad.ST--import Data.Array-import Data.Array.ST--import Data.List-import Data.Tree (Tree(..),Forest(..))--import Data.Monoid-import Data.Foldable (Foldable(foldMap))-import Data.Traversable (Traversable(traverse))--import System.Random--import Math.Combinat.Helper-import Math.Combinat.Numbers (factorial,binomial)------------------------------------------------------------------------------------- * Types---- | A binary tree with leaves decorated with type @a@.-data BinTree a-  = Branch (BinTree a) (BinTree a)-  | Leaf a-  deriving (Eq,Ord,Show,Read)--leaf :: BinTree ()-leaf = Leaf ()---- | A binary tree with leaves and internal nodes decorated --- with types @a@ and @b@, respectively.-data BinTree' a b-  = Branch' (BinTree' a b) b (BinTree' a b)-  | Leaf' a-  deriving (Eq,Ord,Show,Read)--forgetNodeDecorations :: BinTree' a b -> BinTree a-forgetNodeDecorations (Branch' left _ right) = -  Branch (forgetNodeDecorations left) (forgetNodeDecorations right)-forgetNodeDecorations (Leaf' decor) = Leaf decor -----------------------------------------------------------------------------------  -instance Functor BinTree where-  fmap f (Branch left right) = Branch (fmap f left) (fmap f right)-  fmap f (Leaf x) = Leaf (f x)-  -instance Foldable BinTree where-  foldMap f (Leaf x) = f x-  foldMap f (Branch left right) = (foldMap f left) `mappend` (foldMap f right)  --instance Traversable BinTree where-  traverse f (Leaf x) = Leaf <$> f x-  traverse f (Branch left right) = Branch <$> traverse f left <*> traverse f right------------------------------------------------------------------------------------data Paren = LeftParen | RightParen deriving (Eq,Ord,Show,Read)--parenToChar :: Paren -> Char-parenToChar LeftParen = '('-parenToChar RightParen = ')'--parenthesesToString :: [Paren] -> String-parenthesesToString = map parenToChar--stringToParentheses :: String -> [Paren]-stringToParentheses [] = []-stringToParentheses (x:xs) = p : stringToParentheses xs where-  p = case x of-    '(' -> LeftParen-    ')' -> RightParen-    _ -> error "stringToParentheses: invalid character"------------------------------------------------------------------------------------- * Bijections--forestToNestedParentheses :: Forest a -> [Paren]-forestToNestedParentheses = forest where-  -- forest :: Forest a -> [Paren]-  forest = concatMap tree -  -- tree :: Tree a -> [Paren]-  tree (Node _ sf) = LeftParen : forest sf ++ [RightParen]--forestToBinaryTree :: Forest a -> BinTree ()-forestToBinaryTree = forest where-  -- forest :: Forest a -> BinTree ()-  forest = foldr Branch leaf . map tree -  -- tree :: Tree a -> BinTree ()-  tree (Node _ sf) = case sf of-    [] -> leaf-    _  -> forest sf -   -nestedParenthesesToForest :: [Paren] -> Maybe (Forest ())-nestedParenthesesToForest ps = -  case parseForest ps of -    (rest,forest) -> case rest of-      [] -> Just forest-      _  -> Nothing-  where  -    parseForest :: [Paren] -> ( [Paren] , Forest () )-    parseForest ps = unfoldEither parseTree ps-    parseTree :: [Paren] -> Either [Paren] ( [Paren] , Tree () )  -    parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of-      (RightParen:qs) -> Right (qs, Node () ts)-      _ -> Left orig-    parseTree qs = Left qs--nestedParenthesesToForestUnsafe :: [Paren] -> Forest ()-nestedParenthesesToForestUnsafe = fromJust . nestedParenthesesToForest--nestedParenthesesToBinaryTree :: [Paren] -> Maybe (BinTree ())-nestedParenthesesToBinaryTree ps = -  case parseForest ps of -    (rest,forest) -> case rest of-      [] -> Just forest-      _  -> Nothing-  where  -    parseForest :: [Paren] -> ( [Paren] , BinTree () )-    parseForest ps = let (rest,ts) = unfoldEither parseTree ps in (rest , foldr Branch leaf ts)-    parseTree :: [Paren] -> Either [Paren] ( [Paren] , BinTree () )  -    parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of-      (RightParen:qs) -> Right (qs, ts)-      _ -> Left orig-    parseTree qs = Left qs-    -nestedParenthesesToBinaryTreeUnsafe :: [Paren] -> BinTree ()-nestedParenthesesToBinaryTreeUnsafe = fromJust . nestedParenthesesToBinaryTree--binaryTreeToNestedParentheses :: BinTree a -> [Paren]-binaryTreeToNestedParentheses = worker where-  worker (Branch l r) = LeftParen : worker l ++ RightParen : worker r-  worker (Leaf _) = []--binaryTreeToForest :: BinTree a -> Forest ()-binaryTreeToForest = worker where-  worker (Branch l r) = Node () (worker l) : worker r-  worker (Leaf _) = []------------------------------------------------------------------------------------- * Nested parentheses---- | Synonym for 'fasc4A_algorithm_P'.-nestedParentheses :: Int -> [[Paren]]-nestedParentheses = fasc4A_algorithm_P---- | Synonym for 'fasc4A_algorithm_W'.-randomNestedParentheses :: RandomGen g => Int -> g -> ([Paren],g)-randomNestedParentheses = fasc4A_algorithm_W---- | Synonym for 'fasc4A_algorithm_U'.-nthNestedParentheses :: Int -> Integer -> [Paren]-nthNestedParentheses = fasc4A_algorithm_U--countNestedParentheses :: Int -> Integer-countNestedParentheses = countBinaryTrees---- | Generates all sequences of nested parentheses of length 2n.--- Order is lexigraphic (when right parentheses are considered --- smaller then left ones).--- Based on \"Algorithm P\" in Knuth, but less efficient because of--- the \"idiomatic\" code.-fasc4A_algorithm_P :: Int -> [[Paren]]-fasc4A_algorithm_P 0 = []-fasc4A_algorithm_P 1 = [[LeftParen,RightParen]]-fasc4A_algorithm_P n = unfold next ( start , [] ) where -  start = concat $ replicate n [RightParen,LeftParen]  -- already reversed!-   -  next :: ([Paren],[Paren]) -> ( [Paren] , Maybe ([Paren],[Paren]) )-  next ( (a:b:ls) , [] ) = next ( ls , b:a:[] )-  next ( lls@(l:ls) , rrs@(r:rs) ) = ( visit , new ) where-    visit = reverse lls ++ rrs-    new = -      {- debug (reverse ls,l,r,rs) $ -} -      case l of -	      RightParen -> Just ( ls , LeftParen:RightParen:rs )-	      LeftParen  -> -	        {- debug ("---",reverse ls,l,r,rs) $ -}-	        findj ( lls , [] ) ( reverse (RightParen:rs) , [] ) --  findj :: ([Paren],[Paren]) -> ([Paren],[Paren]) -> Maybe ([Paren],[Paren])-  findj ( [] , _ ) _ = Nothing-  findj ( lls@(l:ls) , rs) ( xs , ys ) = -    {- debug ((reverse ls,l,rs),(reverse xs,ys)) $ -}-    case l of-	    LeftParen  -> case xs of-	      (a:_:as) -> findj ( ls, RightParen:rs ) ( as , LeftParen:a:ys )-	      _ -> findj ( lls, [] ) ( reverse rs ++ xs , ys) -	    RightParen -> Just ( reverse ys ++ xs ++ reverse (LeftParen:rs) ++ ls , [] )-    --- | Generates a uniformly random sequence of nested parentheses of length 2n.    --- Based on \"Algorithm W\" in Knuth.-fasc4A_algorithm_W :: RandomGen g => Int -> g -> ([Paren],g)-fasc4A_algorithm_W n' rnd = worker (rnd,n,n,[]) where-  n = fromIntegral n' :: Integer  -  -- the numbers we use are of order n^2, so for n >> 2^16 -  -- on a 32 bit machine, we need big integers.-  worker :: RandomGen g => (g,Integer,Integer,[Paren]) -> ([Paren],g)-  worker (rnd,_,0,parens) = (parens,rnd)-  worker (rnd,p,q,parens) = -    if x<(q+1)*(q-p) -      then worker (rnd' , p   , q-1 , LeftParen :parens)-      else worker (rnd' , p-1 , q   , RightParen:parens)-    where -      (x,rnd') = randomR ( 0 , (q+p)*(q-p+1)-1 ) rnd---- | Nth sequence of nested parentheses of length 2n. --- The order is the same as in 'fasc4A_algorithm_P'.--- Based on \"Algorithm U\" in Knuth.-fasc4A_algorithm_U -  :: Int               -- ^ n-  -> Integer           -- ^ N; should satisfy 1 <= N <= C(n) -  -> [Paren]-fasc4A_algorithm_U n' bign0 = reverse $ worker (bign0,c0,n,n,[]) where-  n = fromIntegral n' :: Integer-  c0 = foldl f 1 [2..n]  -  f c p = ((4*p-2)*c) `div` (p+1) -  worker :: (Integer,Integer,Integer,Integer,[Paren]) -> [Paren]-  worker (_   ,_,_,0,parens) = parens-  worker (bign,c,p,q,parens) = -    if bign <= c' -      then worker (bign    , c'   , p   , q-1 , RightParen:parens)-      else worker (bign-c' , c-c' , p-1 , q   , LeftParen :parens)-    where-      c' = ((q+1)*(q-p)*c) `div` ((q+p)*(q-p+1))-  ------------------------------------------------------------------------------------ * Binary trees---- | Generates all binary trees with n nodes. ---   At the moment just a synonym for 'binaryTreesNaive'.-binaryTrees :: Int -> [BinTree ()]-binaryTrees = binaryTreesNaive---- | # = Catalan(n) = \\frac { 1 } { n+1 } \\binom { 2n } { n }.------ This is also the counting function for forests and nested parentheses.-countBinaryTrees :: Int -> Integer-countBinaryTrees n = binomial (2*n) n `div` (1 + fromIntegral n)-    --- | Generates all binary trees with n nodes. The naive algorithm.-binaryTreesNaive :: Int -> [BinTree ()]-binaryTreesNaive 0 = [ leaf ]-binaryTreesNaive n = -  [ Branch l r -  | i <- [0..n-1] -  , l <- binaryTreesNaive i -  , r <- binaryTreesNaive (n-1-i) -  ]---- | Generates an uniformly random binary tree, using 'fasc4A_algorithm_R'.-randomBinaryTree :: RandomGen g => Int -> g -> (BinTree (), g)-randomBinaryTree n rnd = (tree,rnd') where-  (decorated,rnd') = fasc4A_algorithm_R n rnd      -  tree = fmap (const ()) $ forgetNodeDecorations decorated---- | Grows a uniformly random binary tree. --- \"Algorithm R\" (Remy's procudere) in Knuth.--- Nodes are decorated with odd numbers, leaves with even numbers (from the--- set @[0..2n]@). Uses mutable arrays internally.-fasc4A_algorithm_R :: RandomGen g => Int -> g -> (BinTree' Int Int, g)-fasc4A_algorithm_R n0 rnd = res where-  res = runST $ do-    ar <- newArray (0,2*n0) 0-    rnd' <- worker rnd 1 ar-    links <- unsafeFreeze ar-    return (toTree links, rnd')-  toTree links = f (links!0) where-    f i = if odd i -      then Branch' (f $ links!i) i (f $ links!(i+1)) -      else Leaf' i  -  worker :: RandomGen g => g -> Int -> STUArray s Int Int -> ST s g-  worker rnd n ar = do -    if n > n0-      then return rnd-      else do-        writeArray ar (n2-b)   n2-        lk <- readArray ar k-        writeArray ar (n2-1+b) lk-        writeArray ar k        (n2-1)-        worker rnd' (n+1) ar      -    where  -      n2 = n+n-      (x,rnd') = randomR (0,4*n-3) rnd-      (k,b) = x `divMod` 2-      ---------------------------------------------------------------------------------      -  -
− Math/Combinat/Trees/Nary.hs 
@@ -1,127 +0,0 @@---- | N-ary trees.--module Math.Combinat.Trees.Nary -  ( -    derivTrees-    -- * unique labels-  , addUniqueLabelsTree-  , addUniqueLabelsForest-  , addUniqueLabelsTree_-  , addUniqueLabelsForest_-    -- * labelling by depth-  , labelDepthTree-  , labelDepthForest-  , labelDepthTree_-  , labelDepthForest_-    -- * labelling by number of children-  , labelNChildrenTree-  , labelNChildrenForest-  , labelNChildrenTree_-  , labelNChildrenForest_-    -  ) where-------------------------------------------------------------------------------------import Data.Tree--import Control.Applicative----import Control.Monad.State-import Control.Monad.Trans.State-import Data.Traversable (traverse)--import Math.Combinat.Sets (listTensor)-import Math.Combinat.Partitions (partitionMultiset)-------------------------------------------------------------------------------------- | Adds unique labels to a 'Tree'.-addUniqueLabelsTree :: Tree a -> Tree (a,Int) -addUniqueLabelsTree tree = head (addUniqueLabelsForest [tree])---- | Adds unique labels to a 'Forest'-addUniqueLabelsForest :: Forest a -> Forest (a,Int) -addUniqueLabelsForest forest = evalState (mapM globalAction forest) 1 where-  globalAction tree = -    unwrapMonad $ traverse localAction tree -  localAction x = WrapMonad $ do-    i <- get-    put (i+1)-    return (x,i)--addUniqueLabelsTree_ :: Tree a -> Tree Int-addUniqueLabelsTree_ = fmap snd . addUniqueLabelsTree  --addUniqueLabelsForest_ :: Forest a -> Forest Int-addUniqueLabelsForest_ = map (fmap snd) . addUniqueLabelsForest-----------------------------------------------------------------------------------    --- | Attaches the depth to each node. The depth of the root is 0. -labelDepthTree :: Tree a -> Tree (a,Int) -labelDepthTree tree = worker 0 tree where-  worker depth (Node label subtrees) = Node (label,depth) (map (worker (depth+1)) subtrees)--labelDepthForest :: Forest a -> Forest (a,Int) -labelDepthForest forest = map labelDepthTree forest-    -labelDepthTree_ :: Tree a -> Tree Int-labelDepthTree_ = fmap snd . labelDepthTree--labelDepthForest_ :: Forest a -> Forest Int -labelDepthForest_ = map (fmap snd) . labelDepthForest-------------------------------------------------------------------------------------- | Attaches the number of children to each node. -labelNChildrenTree :: Tree a -> Tree (a,Int)-labelNChildrenTree (Node x subforest) = -  Node (x, length subforest) (map labelNChildrenTree subforest)-  -labelNChildrenForest :: Forest a -> Forest (a,Int) -labelNChildrenForest forest = map labelNChildrenTree forest--labelNChildrenTree_ :: Tree a -> Tree Int-labelNChildrenTree_ = fmap snd . labelNChildrenTree--labelNChildrenForest_ :: Forest a -> Forest Int -labelNChildrenForest_ = map (fmap snd) . labelNChildrenForest-    ------------------------------------------------------------------------------------- | Computes the set of equivalence classes of rooted trees (in the --- sense that the leaves of a node are /unordered/) --- with @n = length ks@ leaves where the set of heights of --- the leaves matches the given set of numbers. --- The height is defined as the number of /edges/ from the leaf to the root. ------ TODO: better name?-derivTrees :: [Int] -> [Tree ()]-derivTrees xs = derivTrees' (map (+1) xs)--derivTrees' :: [Int] -> [Tree ()]-derivTrees' [] = []-derivTrees' [n] = -  if n>=1 -    then [unfoldTree f 1] -    else [] -  where -    f k = if k<n then ((),[k+1]) else ((),[])-derivTrees' ks = -  if and (map (>0) ks)-    then-      [ Node () sub -      | part <- parts-      , let subtrees = map g part-      , sub <- listTensor subtrees -      ] -    else []-  where-    parts = partitionMultiset ks-    g xs = derivTrees' (map (\x->x-1) xs)-----------------------------------------------------------------------------------
− Math/Combinat/Tuples.hs 
@@ -1,61 +0,0 @@---- | Tuples.--module Math.Combinat.Tuples where--import Math.Combinat.Helper------------------------------------------------------------ Tuples---- | \"Tuples\" fitting into a give shape. The order is lexicographic, that is,------ > sort ts == ts where ts = tuples' shape------   Example: ------ > tuples' [2,3] = --- >   [[0,0],[0,1],[0,2],[0,3],[1,0],[1,1],[1,2],[1,3],[2,0],[2,1],[2,2],[2,3]]----tuples' :: [Int] -> [[Int]]-tuples' [] = [[]]-tuples' (s:ss) = [ x:xs | x <- [0..s] , xs <- tuples' ss ] ---- | positive \"tuples\" fitting into a give shape.-tuples1' :: [Int] -> [[Int]]-tuples1' [] = [[]]-tuples1' (s:ss) = [ x:xs | x <- [1..s] , xs <- tuples1' ss ] ---- | # = \\prod_i (m_i + 1)-countTuples' :: [Int] -> Integer-countTuples' shape = product $ map f shape where-  f k = 1 + fromIntegral k---- | # = \\prod_i m_i-countTuples1' :: [Int] -> Integer-countTuples1' shape = product $ map fromIntegral shape--tuples -  :: Int    -- ^ length (width)-  -> Int    -- ^ maximum (height)-  -> [[Int]]-tuples len k = tuples' (replicate len k)--tuples1 -  :: Int    -- ^ length (width)-  -> Int    -- ^ maximum (height)-  -> [[Int]]-tuples1 len k = tuples1' (replicate len k)---- | # = (m+1) ^ len-countTuples :: Int -> Int -> Integer-countTuples len k = (1 + fromIntegral k) ^ len---- | # = m ^ len-countTuples1 :: Int -> Int -> Integer-countTuples1 len k = fromIntegral k ^ len--binaryTuples :: Int -> [[Bool]]-binaryTuples len = map (map intToBool) (tuples len 1)---------------------------------------------------------
+ README.md view
@@ -0,0 +1,31 @@+combinat - a Haskell combinatorics library+------------------------------------------++For the API docs, [check out Hackage](https://hackage.haskell.org/package/combinat).++This is a combinatorics library for Haskell. It contains functions +enumerating, counting, visualizing, manipulating, and sometimes randomly sampling +from many standard combinatorial objects, including:++* subsets+* compositions+* trees+* numbers:+    * natural numbers+    * prime numbers+    * formal power series+* permutations+* partitions:+    * integer partitions+    * set partitions, multiset partitions, non-crossing partitions+    * plane partitions+    * vector partitions+    * skew partitions, ribbons+* Young tableaux, Littlewood-Richardson coefficients+* lattice paths, Dyck paths+* groups:+    * permutation groups+    * braid groups+    * free groups, free products of cyclic groups+    * Thompson's group F+
combinat.cabal view
@@ -1,72 +1,139 @@ Name:                combinat-Version:             0.2.4.1-Synopsis:            Generation of various combinatorial objects.-Description:         A collection of functions to generate combinatorial-                     objects like partitions, combinations, permutations,-                     Young tableaux, various trees, etc.+Version:             0.2.10.1+Synopsis:            Generate and manipulate various combinatorial objects.+Description:         A collection of functions to generate, count, manipulate+                     and visualize all kinds of combinatorial objects like +                     partitions, compositions, trees, permutations, braids, +                     Young tableaux, and so on. License:             BSD3 License-file:        LICENSE Author:              Balazs Komuves-Copyright:           (c) 2008-2011 Balazs Komuves+Copyright:           (c) 2008-2023 Balazs Komuves Maintainer:          bkomuves (plus) hackage (at) gmail (dot) com-Homepage:            http://code.haskell.org/~bkomuves/+Homepage:            https://github.com/bkomuves/combinat Stability:           Experimental Category:            Math-Tested-With:         GHC == 6.12.3-Cabal-Version:       >= 1.2+Tested-With:         GHC == 8.6.5, GHC == 9.4.7+Cabal-Version:       1.24 Build-Type:          Simple -Flag withQuickCheck-  Description: Compile with the QuickCheck tests. -  default: False+extra-doc-files:     svg/*.svg +                     README.md -Flag splitBase-  Description: Choose the new smaller, split-up base package.+extra-source-files:  svg/*.svg+                     svg/src/gen_figures.hs                      -Flag base4-  Description: Base v4-  +source-repository head+  type:                git+  location:            https://github.com/bkomuves/combinat++--------------------------------------------------------------------------------+ Library-  if flag(splitBase)-    if flag(base4)-      Build-Depends:       base >= 4 && < 5, array, containers, random, transformers-      cpp-options:         -DBASE_VERSION=4-    else -      Build-Depends:       base >= 3 && < 4, array, containers, random, transformers-      cpp-options:         -DBASE_VERSION=3-    if flag(withQuickCheck)-      Build-Depends:       QuickCheck-  else-    Build-Depends:       base < 3-    cpp-options:         -DBASE_VERSION=2 +  Build-Depends:       base >= 4 && < 5, +                       array >= 0.5 && < 0.7, +                       containers >= 0.6 && < 0.9, +                       random >= 1.1 && < 1.4, +                       transformers >= 0.4.2 && < 0.8,+                       compact-word-vectors >= 0.2.0.2 && < 0.4    Exposed-Modules:     Math.Combinat+                       Math.Combinat.Classes                        Math.Combinat.Numbers-                       Math.Combinat.Numbers.Series+                       Math.Combinat.Numbers.Integers+                       Math.Combinat.Numbers.Sequences                        Math.Combinat.Numbers.Primes+                       Math.Combinat.Numbers.Series+                       Math.Combinat.Sign                        Math.Combinat.Sets+                       Math.Combinat.Sets.VennDiagrams                        Math.Combinat.Tuples -                       Math.Combinat.Combinations                        Math.Combinat.Compositions+                       Math.Combinat.Groups.Thompson.F+                       Math.Combinat.Groups.Free+                       Math.Combinat.Groups.Braid+                       Math.Combinat.Groups.Braid.NF                        Math.Combinat.Partitions+                       Math.Combinat.Partitions.Integer+                       Math.Combinat.Partitions.Integer.Count+                       Math.Combinat.Partitions.Integer.Compact+                       Math.Combinat.Partitions.Integer.Naive+                       Math.Combinat.Partitions.Integer.IntList+                       Math.Combinat.Partitions.Skew+                       Math.Combinat.Partitions.Skew.Ribbon+                       Math.Combinat.Partitions.Set+                       Math.Combinat.Partitions.NonCrossing+                       Math.Combinat.Partitions.Plane+                       Math.Combinat.Partitions.Multiset+                       Math.Combinat.Partitions.Vector                        Math.Combinat.Permutations                        Math.Combinat.Tableaux-                       Math.Combinat.Tableaux.Kostka+                       Math.Combinat.Tableaux.Skew+                       Math.Combinat.Tableaux.GelfandTsetlin+                       Math.Combinat.Tableaux.GelfandTsetlin.Cone+                       Math.Combinat.Tableaux.LittlewoodRichardson                        Math.Combinat.Trees                        Math.Combinat.Trees.Binary                        Math.Combinat.Trees.Nary-                       Math.Combinat.Graphviz-  -  Other-Modules:       Math.Combinat.Helper+                       Math.Combinat.Trees.Graphviz+                       Math.Combinat.LatticePaths+                       Math.Combinat.RootSystems+                       Math.Combinat.ASCII+                       Math.Combinat.Helper+                       Math.Combinat.TypeLevel -  Extensions:          CPP, MultiParamTypeClasses, ScopedTypeVariables, -                       GeneralizedNewtypeDeriving +  Default-Extensions:  CPP, BangPatterns+  Other-Extensions:    MultiParamTypeClasses, ScopedTypeVariables, +                       GeneralizedNewtypeDeriving,+                       DataKinds, KindSignatures -  Hs-Source-Dirs:      .+  Default-Language:    Haskell2010 -  if flag(withQuickCheck)-    cpp-options:         -DQUICKCHECK+  Hs-Source-Dirs:      src -  ghc-options:         -Wall -fno-warn-unused-matches+  ghc-options:         -fwarn-tabs -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports+     +--------------------------------------------------------------------------------++test-suite combinat-tests+                      +  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             TestSuite.hs+  +  other-modules:       Tests.Braid+                       Tests.Common+                       Tests.LatticePaths+                       Tests.Permutations+                       Tests.Series+                       Tests.SkewTableaux+                       Tests.Thompson+                       Tests.Partitions.Integer+                       Tests.Partitions.Compact  +                       Tests.Partitions.Skew+                       Tests.Partitions.Ribbon+                       Tests.Numbers.Primes   +                       Tests.Numbers.Sequences+                       +  build-depends:       base >= 4 && < 5, +                       array >= 0.5 && < 0.7, +                       containers >= 0.6 && < 0.9, +                       random >= 1.1 && < 1.4, +                       transformers >= 0.4.2 && < 0.8,+                       compact-word-vectors >= 0.2.0.2 && < 0.4,+                       combinat, +                       test-framework > 0.8.1 && < 0.10, +                       test-framework-quickcheck2 >= 0.3 && < 0.5, +                       QuickCheck >= 2 && < 0.3,+                       tasty >= 0.11 && < 1.7, +                       tasty-quickcheck >= 0.9 && < 1.0, +                       tasty-hunit >= 0.10 && < 1.0++  Default-Language:    Haskell2010+  Default-Extensions:  CPP, BangPatterns++--------------------------------------------------------------------------------++
+ src/Math/Combinat.hs view
@@ -0,0 +1,76 @@++-- | A collection of functions to generate, manipulate,+-- visualize and count combinatorial objects like partitions, +-- compositions, permutations, braids, Young tableaux, +-- lattice paths, various tree structures, etc etc.+--+-- +-- See also the @combinat-diagrams@ library for generating+-- graphical representations of (some of) these structure using +-- the @diagrams@ library (<http://projects.haskell.org/diagrams>).+--+--+-- The long-term goals are +--+--  (1) generate most of the standard structures;+-- +--  (2) manipulate these structures;+--+--  (3) visualize these structures;+--+--  (4) the generation should be efficient; +--+--  (5) to be able to enumerate the structures +--      with constant memory usage;+--+--  (6) to be able to randomly sample from them;+--   +--  (7) finally, to be a repository of algorithms.+--+--+-- The short-term goal is simply to generate +-- and manipulate many interesting structures.+--+--+-- Naming conventions (subject to change): +--+--  * prime suffix: additional constrains, typically more general;+--+--  * underscore prefix: use plain lists instead of other types with +--    enforced invariants;+--+--  * \"random\" prefix: generates random objects +--    (typically with uniform distribution); +--+--  * \"count\" prefix: counting functions.+--+--+-- This module re-exports the most commonly used modules.+--++module Math.Combinat +  ( module Math.Combinat.Numbers+  , module Math.Combinat.Sign+  , module Math.Combinat.Sets+  , module Math.Combinat.Tuples+  , module Math.Combinat.Compositions+  , module Math.Combinat.Partitions+  , module Math.Combinat.Permutations+  , module Math.Combinat.Tableaux+  , module Math.Combinat.Trees+  , module Math.Combinat.LatticePaths+  , module Math.Combinat.ASCII+  ) +  where++import Math.Combinat.Numbers+import Math.Combinat.Sign+import Math.Combinat.Sets+import Math.Combinat.Tuples+import Math.Combinat.Compositions+import Math.Combinat.Partitions+import Math.Combinat.Permutations+import Math.Combinat.Tableaux+import Math.Combinat.Trees+import Math.Combinat.LatticePaths+import Math.Combinat.ASCII
+ src/Math/Combinat/ASCII.hs view
@@ -0,0 +1,438 @@++-- | A mini-DSL for ASCII drawing of structures.+--+--+-- From some structures there is also Graphviz and\/or @diagrams@ +-- (<http://projects.haskell.org/diagrams>) visualization support +-- (the latter in the separate libray @combinat-diagrams@).+--++module Math.Combinat.ASCII where++--------------------------------------------------------------------------------++import Data.Char ( isSpace )+import Data.List ( transpose , intercalate )++import Math.Combinat.Helper++--------------------------------------------------------------------------------+-- * The basic ASCII type++-- | The type of a (rectangular) ASCII figure. +-- Internally it is a list of lines of the same length plus the size.+--+-- Note: The Show instance is pretty-printing, so that it\'s convenient in ghci.+--+data ASCII = ASCII +  { asciiSize  :: (Int,Int) +  , asciiLines :: [String]+  }++-- | A type class to have a simple way to draw things +class DrawASCII a where+  ascii :: a -> ASCII++instance Show ASCII where+  show = asciiString++-- | An empty (0x0) rectangle+emptyRect :: ASCII+emptyRect = ASCII (0,0) []++asciiXSize, asciiYSize :: ASCII -> Int+asciiXSize = fst . asciiSize+asciiYSize = snd . asciiSize++asciiString :: ASCII -> String+asciiString (ASCII sz ls) = unlines ls++printASCII :: ASCII -> IO ()+printASCII = putStrLn . asciiString++asciiFromLines :: [String] -> ASCII+asciiFromLines ls = ASCII (x,y) (map f ls) where+  y   = length ls+  x   = maximum (map length ls)+  f l = l ++ replicate (x - length l) ' '++asciiFromString :: String -> ASCII+asciiFromString = asciiFromLines . lines++--------------------------------------------------------------------------------+-- * Alignment++-- | Horizontal alignment+data HAlign +  = HLeft +  | HCenter +  | HRight +  deriving (Eq,Show)++-- | Vertical alignment+data VAlign +  = VTop +  | VCenter +  | VBottom +  deriving (Eq,Show)++data Alignment = Align HAlign VAlign++--------------------------------------------------------------------------------+-- * Separators++-- | Horizontal separator+data HSep +  = HSepEmpty           -- ^ empty separator+  | HSepSpaces Int      -- ^ @n@ spaces+  | HSepString String   -- ^ some custom string, eg. @\" | \"@+  deriving Show++hSepSize :: HSep -> Int+hSepSize hsep = case hsep of+  HSepEmpty    -> 0+  HSepSpaces k -> k+  HSepString s -> length s++hSepString :: HSep -> String+hSepString hsep = case hsep of+  HSepEmpty    -> ""+  HSepSpaces k -> replicate k ' '+  HSepString s -> s++-- | Vertical separator+data VSep +  = VSepEmpty           -- ^ empty separator+  | VSepSpaces Int      -- ^ @n@ spaces+  | VSepString [Char]   -- ^ some custom list of characters, eg. @\" - \"@ (the characters are interpreted as below each other)+  deriving Show++vSepSize :: VSep -> Int+vSepSize vsep = case vsep of+  VSepEmpty    -> 0+  VSepSpaces k -> k+  VSepString s -> length s++vSepString :: VSep -> [Char]+vSepString vsep = case vsep of+  VSepEmpty    -> []+  VSepSpaces k -> replicate k ' '+  VSepString s -> s+                                        +--------------------------------------------------------------------------------+-- * Concatenation++-- | Horizontal append, centrally aligned, no separation.+(|||) :: ASCII -> ASCII -> ASCII+(|||) p q = hCatWith VCenter HSepEmpty [p,q]++-- | Vertical append, centrally aligned, no separation.+(===) :: ASCII -> ASCII -> ASCII+(===) p q = vCatWith HCenter VSepEmpty [p,q]++-- | Horizontal concatenation, top-aligned, no separation+hCatTop :: [ASCII] -> ASCII+hCatTop = hCatWith VTop HSepEmpty++-- | Horizontal concatenation, bottom-aligned, no separation+hCatBot :: [ASCII] -> ASCII+hCatBot = hCatWith VBottom HSepEmpty++-- | Vertical concatenation, left-aligned, no separation+vCatLeft :: [ASCII] -> ASCII+vCatLeft = vCatWith HLeft VSepEmpty++-- | Vertical concatenation, right-aligned, no separation+vCatRight :: [ASCII] -> ASCII+vCatRight = vCatWith HRight VSepEmpty++-- | General horizontal concatenation+hCatWith :: VAlign -> HSep -> [ASCII] -> ASCII+hCatWith valign hsep rects = ASCII (x',maxy) final where+  n    = length rects+  maxy = maximum [ y | ASCII (_,y) _ <- rects ]+  xsz  =         [ x | ASCII (x,_) _ <- rects ]+  sep   = hSepString hsep+  sepx  = length sep+  rects1 = map (vExtendTo valign maxy) rects+  x' = sum' xsz + (n-1)*sepx+  final = map (intercalate sep) $ transpose (map asciiLines rects1)++-- | General vertical concatenation+vCatWith :: HAlign -> VSep -> [ASCII] -> ASCII+vCatWith halign vsep rects = ASCII (maxx,y') final where+  n    = length rects+  maxx = maximum [ x | ASCII (x,_) _ <- rects ]+  ysz  =         [ y | ASCII (_,y) _ <- rects ]+  sepy    = vSepSize vsep+  fullsep = transpose (replicate maxx $ vSepString vsep) :: [String]+  rects1  = map (hExtendTo halign maxx) rects+  y'    = sum' ysz + (n-1)*sepy+  final = intercalate fullsep $ map asciiLines rects1++--------------------------------------------------------------------------------+-- * Padding++-- | Horizontally pads with the given number of spaces, on both sides+hPad :: Int -> ASCII -> ASCII+hPad k (ASCII (x,y) ls) = ASCII (x+2*k,y) (map f ls) where+  f l = pad ++ l ++ pad +  pad = replicate k ' '++-- | Vertically pads with the given number of empty lines, on both sides+vPad :: Int -> ASCII -> ASCII+vPad k (ASCII (x,y) ls) = ASCII (x,y+2*k) (pad ++ ls ++ pad) where+  pad = replicate k (replicate x ' ')++-- | Pads by single empty lines vertically and two spaces horizontally+pad :: ASCII -> ASCII+pad = vPad 1 . hPad 2 ++--------------------------------------------------------------------------------+-- * Extension++-- | Extends an ASCII figure with spaces horizontally to the given width.+-- Note: the alignment is the alignment of the original picture in the new bigger picture!+hExtendTo :: HAlign -> Int -> ASCII -> ASCII+hExtendTo halign n0 rect@(ASCII (x,y) ls) = hExtendWith halign (max n0 x - x) rect+  +-- | Extends an ASCII figure with spaces vertically to the given height.+-- Note: the alignment is the alignment of the original picture in the new bigger picture!+vExtendTo :: VAlign -> Int -> ASCII -> ASCII+vExtendTo valign n0 rect@(ASCII (x,y) ls) = vExtendWith valign (max n0 y - y) rect++-- | Extend horizontally with the given number of spaces.+hExtendWith :: HAlign -> Int -> ASCII -> ASCII+hExtendWith alignment d (ASCII (x,y) ls) = ASCII (x+d,y) (map f ls) where+  f l = case alignment of+    HLeft   -> l ++ replicate d ' '   +    HRight  -> replicate d ' ' ++ l+    HCenter -> replicate a ' ' ++ l ++ replicate (d-a) ' ' +  a = div d 2++-- | Extend vertically with the given number of empty lines.+vExtendWith :: VAlign -> Int -> ASCII -> ASCII+vExtendWith valign d (ASCII (x,y) ls) = ASCII (x,y+d) (f ls) where+  f ls = case valign of+    VTop     -> ls ++ replicate d emptyline   +    VBottom  -> replicate d emptyline ++ ls+    VCenter  -> replicate a emptyline ++ ls ++ replicate (d-a) emptyline+  a = div d 2+  emptyline = replicate x ' '++-- | Horizontal indentation+hIndent :: Int -> ASCII -> ASCII+hIndent d = hExtendWith HRight d++-- | Vertical indentation+vIndent :: Int -> ASCII -> ASCII+vIndent d = vExtendWith VBottom d++--------------------------------------------------------------------------------+-- * Cutting++-- | Cuts the given number of columns from the picture. +-- The alignment is the alignment of the /picture/, not the cuts.+--+-- This should be the (left) inverse of 'hExtendWith'.+hCut :: HAlign -> Int -> ASCII -> ASCII+hCut halign k (ASCII (x,y) ls) = ASCII (x',y) (map f ls) where+  x' = max 0 (x-k)+  f  = case halign of+    HLeft   -> reverse . drop  k    . reverse+    HCenter -> reverse . drop (k-a) . reverse . drop a+    HRight  -> drop k +  a = div k 2++-- | Cuts the given number of rows from the picture. +-- The alignment is the alignment of the /picture/, not the cuts.+--+-- This should be the (left) inverse of 'vExtendWith'.+vCut :: VAlign -> Int -> ASCII -> ASCII+vCut valign k (ASCII (x,y) ls) = ASCII (x,y') (g ls) where+  y' = max 0 (y-k)+  g  = case valign of+    VTop    -> reverse . drop  k    . reverse+    VCenter -> reverse . drop (k-a) . reverse . drop a+    VBottom -> drop k +  a = div k 2++--------------------------------------------------------------------------------+-- * Pasting++-- | Pastes the first ASCII graphics onto the second, keeping the second one's dimension+-- (that is, overlapping parts of the first one are ignored). +-- The offset is relative to the top-left corner of the second picture.+-- Spaces at treated as transparent.+--+-- Example:+--+-- > tabulate (HCenter,VCenter) (HSepSpaces 2, VSepSpaces 1)+-- >  [ [ caption (show (x,y)) $+-- >      pasteOnto (x,y) (filledBox '@' (4,3)) (asciiBox (7,5))+-- >    | x <- [-4..7] ] +-- >  | y <- [-3..5] ]+--+pasteOnto :: (Int,Int) -> ASCII -> ASCII -> ASCII+pasteOnto = pasteOnto' isSpace ++-- | Pastes the first ASCII graphics onto the second, keeping the second one's dimension.+-- The first argument specifies the transparency condition (on the first picture).+-- The offset is relative to the top-left corner of the second picture.+-- +pasteOnto' +  :: (Char -> Bool)      -- ^ transparency condition+  -> (Int,Int)           -- ^ offset relative to the top-left corner of the second picture+  -> ASCII               -- ^ picture to paste+  -> ASCII               -- ^ picture to paste onto+  -> ASCII+pasteOnto' transparent (xpos,ypos) small big = new where+  new = ASCII (xbig,ybig) lines'+  (xbig,ybig) = asciiSize  big+  bigLines    = asciiLines big+  small'      = (if (ypos>=0) then vExtendWith VBottom ypos else vCut VBottom (-ypos))+              $ (if (xpos>=0) then hExtendWith HRight  xpos else hCut HRight  (-xpos))+              $ small+  smallLines  = asciiLines small'+  lines'  = zipWith f bigLines (smallLines ++ repeat "")+  f bl sl = zipWith g bl (sl ++ repeat ' ')+  g b  s  = if transparent s then b else s++-- | A version of 'pasteOnto' where we can specify the corner of the second picture+-- to which the offset is relative:+--+-- > pasteOntoRel (HLeft,VTop) == pasteOnto+--+pasteOntoRel :: (HAlign,VAlign) -> (Int,Int) -> ASCII -> ASCII -> ASCII+pasteOntoRel = pasteOntoRel' isSpace++pasteOntoRel' :: (Char -> Bool) -> (HAlign,VAlign) -> (Int,Int) -> ASCII -> ASCII -> ASCII+pasteOntoRel' transparent (halign,valign) (xpos,ypos) small big = new where+  new = pasteOnto' transparent (xpos',ypos') small big +  (xsize,ysize) = asciiSize big+  xpos' = case halign of+    HLeft   -> xpos+    HCenter -> xpos + div xsize 2+    HRight  -> xpos +     xsize+  ypos' = case valign of+    VTop    -> ypos+    VCenter -> ypos + div ysize 2+    VBottom -> ypos +     ysize++--------------------------------------------------------------------------------+-- * Tabulate++-- | Tabulates the given matrix of pictures. Example:+--+-- > tabulate (HCenter, VCenter) (HSepSpaces 2, VSepSpaces 1)+-- >   [ [ asciiFromLines [ "x=" ++ show x , "y=" ++ show y ] | x<-[7..13] ] +-- >   | y<-[98..102] ]+--+tabulate :: (HAlign,VAlign) -> (HSep,VSep) -> [[ASCII]] -> ASCII+tabulate (halign,valign) (hsep,vsep) rects0 = final where+  n = length rects0+  m = maximum (map length rects0)+  rects1 = map (\rs -> rs ++ replicate (m - length rs) emptyRect) rects0+  ys = map (\rs -> maximum (map asciiYSize rs)) rects1+  xs = map (\rs -> maximum (map asciiXSize rs)) (transpose rects1)+  rects2 = map (\rs -> [      hExtendTo halign x  r  | (x,r ) <- zip xs rs     ]) rects1+  rects3 =             [ map (vExtendTo valign y) rs | (y,rs) <- zip ys rects2 ]  +  final  = vCatWith HLeft vsep +         $ map (hCatWith VTop hsep) rects3++-- | Order of elements in a matrix+data MatrixOrder +  = RowMajor+  | ColMajor+  deriving (Eq,Ord,Show,Read)++-- | Automatically tabulates ASCII rectangles.+--+autoTabulate +  :: MatrixOrder      -- ^ whether to use row-major or column-major ordering of the elements+  -> Either Int Int   -- ^ @(Right x)@ creates x columns, while @(Left y)@ creates y rows+  -> [ASCII]          -- ^ list of ASCII rectangles+  -> ASCII+autoTabulate mtxorder ei list = final where+  +  final = tabulate (HLeft,VBottom) (HSepSpaces 2,VSepSpaces 1) rects ++  n = length list++  rects = case ei of++    Left y  -> case mtxorder of+                 ColMajor -> transpose (parts y list)+                 RowMajor -> invparts y list++    Right x -> case mtxorder of+                 ColMajor -> transpose (invparts x list)+                 RowMajor -> parts x list++  transposeIf b = if b then transpose else id++  -- chops into parts (the last one can be smaller)+  parts d = go where+    go [] = []+    go xs = take d xs : go (drop d xs)++  invparts d xs = parts' ds xs where+    (q,r) = divMod n d+    ds = replicate r (q+1) ++ replicate (d-r) q++  parts' ds xs = go ds xs where+    go _  [] = []                                      +    go [] _  = []+    go (d:ds) xs = take d xs : go ds (drop d xs)++--------------------------------------------------------------------------------+-- * Captions++-- | Adds a caption to the bottom, with default settings.+caption :: String -> ASCII -> ASCII+caption = caption' False HLeft++-- | Adds a caption to the bottom. The @Bool@ flag specifies whether to add an empty between +-- the caption and the figure+caption' :: Bool -> HAlign -> String -> ASCII -> ASCII+caption' emptyline halign str rect = vCatWith halign sep [rect,capt] where+  sep  = if emptyline then VSepSpaces 1 else VSepEmpty +  capt = asciiFromString str++--------------------------------------------------------------------------------+-- * Ready-made boxes++-- | An ASCII border box of the given size +asciiBox :: (Int,Int) -> ASCII+asciiBox (x,y) = ASCII (max x 2, max y 2) (h : replicate (y-2) m ++ [h]) where+  h = "+" ++ replicate (x-2) '-' ++ "+"+  m = "|" ++ replicate (x-2) ' ' ++ "|"++-- | An \"rounded\" ASCII border box of the given size+roundedAsciiBox :: (Int,Int) -> ASCII+roundedAsciiBox (x,y) = ASCII (max x 2, max y 2) (a : replicate (y-2) m ++ [b]) where+  a = "/"  ++ replicate (x-2) '-' ++ "\\"+  m = "|"  ++ replicate (x-2) ' ' ++ "|"+  b = "\\" ++ replicate (x-2) '-' ++ "/"++-- | A box simply filled with the given character+filledBox :: Char -> (Int,Int) -> ASCII+filledBox c (x0,y0) = asciiFromLines $ replicate y (replicate x c) where+  x = max 0 x0+  y = max 0 y0++-- | A box of spaces+transparentBox :: (Int,Int) -> ASCII+transparentBox = filledBox ' '++--------------------------------------------------------------------------------+-- * Testing \/ miscellanea++-- | An integer+asciiNumber :: Int -> ASCII+asciiNumber = asciiShow++asciiShow :: Show a => a -> ASCII+asciiShow = asciiFromLines . (:[]) . show++--------------------------------------------------------------------------------
+ src/Math/Combinat/Classes.hs view
@@ -0,0 +1,66 @@++-- | Type classes for some common properties shared by different objects++{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+module Math.Combinat.Classes where++--------------------------------------------------------------------------------++-- | Emptyness+class CanBeEmpty a where+  isEmpty :: a -> Bool+  empty   :: a++--------------------------------------------------------------------------------+-- * Partitions++-- | Number of parts+class HasNumberOfParts a where+  numberOfParts :: a -> Int++--------------------------------------------------------------------------------++class HasWidth a where+  width :: a -> Int++class HasHeight a where+  height :: a -> Int++--------------------------------------------------------------------------------++-- | Weight (of partitions, tableaux, etc)+class HasWeight a where+  weight :: a -> Int++--------------------------------------------------------------------------------++-- | Duality (of partitions, tableaux, etc)+class HasDuality a where+  dual :: a -> a++--------------------------------------------------------------------------------+-- * Tableau++-- | Shape (of tableaux, skew tableaux)+class HasShape a s | a -> s where+  shape :: a -> s++--------------------------------------------------------------------------------+-- * Trees++-- | Number of nodes (of trees)+class HasNumberOfNodes t where+  numberOfNodes :: t -> Int++-- | Number of leaves (of trees)+class HasNumberOfLeaves t where+  numberOfLeaves :: t -> Int++--------------------------------------------------------------------------------+-- * Permutations++-- | Number of cycles (of partitions)+class HasNumberOfCycles p where+  numberOfCycles :: p -> Int++--------------------------------------------------------------------------------
+ src/Math/Combinat/Compositions.hs view
@@ -0,0 +1,109 @@++-- | Compositions. +--+-- See eg. <http://en.wikipedia.org/wiki/Composition_%28combinatorics%29>+--++module Math.Combinat.Compositions where++--------------------------------------------------------------------------------++import System.Random++import Math.Combinat.Sets    ( randomChoice )+import Math.Combinat.Numbers ( factorial , binomial )+import Math.Combinat.Helper++--------------------------------------------------------------------------------+-- * generating all compositions++-- | A /composition/ of an integer @n@ into @k@ parts is an ordered @k@-tuple of nonnegative (sometimes positive) integers+-- whose sum is @n@.+type Composition = [Int]++-- | Compositions fitting into a given shape and having a given degree.+--   The order is lexicographic, that is, +--+-- > sort cs == cs where cs = compositions' shape k+--+compositions'  +  :: [Int]         -- ^ shape+  -> Int           -- ^ sum+  -> [[Int]]+compositions' [] 0 = [[]]+compositions' [] _ = []+compositions' shape@(s:ss) n = +  [ x:xs | x <- [0..min s n] , xs <- compositions' ss (n-x) ] ++countCompositions' :: [Int] -> Int -> Integer+countCompositions' [] 0 = 1+countCompositions' [] _ = 0+countCompositions' shape@(s:ss) n = sum +  [ countCompositions' ss (n-x) | x <- [0..min s n] ] ++-- | All positive compositions of a given number (filtrated by the length). +-- Total number of these is @2^(n-1)@+allCompositions1 :: Int -> [[Composition]]+allCompositions1 n = map (\d -> compositions1 d n) [1..n] ++-- | All compositions fitting into a given shape.+allCompositions' :: [Int] -> [[Composition]]+allCompositions' shape = map (compositions' shape) [0..d] where d = sum shape++-- | Nonnegative compositions of a given length.+compositions +  :: Integral a +  => a       -- ^ length+  -> a       -- ^ sum+  -> [[Int]]+compositions len' d' = compositions' (replicate len d) d where+  len = fromIntegral len'+  d   = fromIntegral d'++-- | # = \\binom { len+d-1 } { len-1 }+countCompositions :: Integral a => a -> a -> Integer+countCompositions len d = binomial (len+d-1) (len-1)++-- | Positive compositions of a given length.+compositions1  +  :: Integral a +  => a       -- ^ length+  -> a       -- ^ sum+  -> [[Int]]+compositions1 len d +  | len > d   = []+  | otherwise = map plus1 $ compositions len (d-len)+  where+    plus1 = map (+1)+    -- len = fromIntegral len'+    -- d   = fromIntegral d'++countCompositions1 :: Integral a => a -> a -> Integer+countCompositions1 len d = countCompositions len (d-len)++--------------------------------------------------------------------------------+-- * random compositions++-- | @randomComposition k n@ returns a uniformly random composition +-- of the number @n@ as an (ordered) sum of @k@ /nonnegative/ numbers+randomComposition :: RandomGen g => Int -> Int -> g -> ([Int],g)+randomComposition k n g0 = +  if k<1 || n<0 +    then error "randomComposition: k should be positive, and n should be nonnegative" +    else (comp, g1) +  where+    (cs,g1) = randomChoice (k-1) (n+k-1) g0+    comp = pairsWith (\x y -> y-x-1) (0 : cs ++ [n+k])+  +-- | @randomComposition1 k n@ returns a uniformly random composition +-- of the number @n@ as an (ordered) sum of @k@ /positive/ numbers+randomComposition1 :: RandomGen g => Int -> Int -> g -> ([Int],g)+randomComposition1 k n g0 = +  if k<1 || n<k +    then error "randomComposition1: we require 0 < k <= n" +    else (comp, g1) +  where+    (cs,g1) = randomComposition k (n-k) g0 +    comp = map (+1) cs++--------------------------------------------------------------------------------
+ src/Math/Combinat/Groups/Braid.hs view
@@ -0,0 +1,744 @@++-- | Braids. See eg. <https://en.wikipedia.org/wiki/Braid_group>+--+--+-- Based on: +--+--  * Joan S. Birman, Tara E. Brendle: BRAIDS - A SURVEY+--    <https://www.math.columbia.edu/~jb/Handbook-21.pdf>+--+--+-- Note: This module GHC 7.8, since we use type-level naturals+-- to parametrize the 'Braid' type.+--+++{-# LANGUAGE +      CPP, BangPatterns, +      ScopedTypeVariables, ExistentialQuantification,+      DataKinds, KindSignatures, Rank2Types,+      TypeOperators, TypeFamilies,+      StandaloneDeriving #-}++module Math.Combinat.Groups.Braid where++--------------------------------------------------------------------------------++import Data.Proxy+import GHC.TypeLits++import Control.Monad++import Data.List ( mapAccumL , foldl' )++import Data.Array.Unboxed+import Data.Array.ST+import Data.Array.IArray+import Data.Array.MArray+import Data.Array.Unsafe+import Data.Array.Base++import Control.Monad.ST++import System.Random++import Math.Combinat.ASCII+import Math.Combinat.Sign+import Math.Combinat.Helper+import Math.Combinat.TypeLevel+import Math.Combinat.Numbers.Series++import Math.Combinat.Permutations ( Permutation(..) , (!!!) )+import qualified Math.Combinat.Permutations as P++--------------------------------------------------------------------------------+-- * Artin generators++-- | A standard Artin generator of a braid: @Sigma i@ represents twisting +-- the neighbour strands @i@ and @(i+1)@, such that strand @i@ goes /under/ strand @(i+1)@.+--+-- Note: The strands are numbered @1..n@.+data BrGen+  = Sigma    !Int         -- ^ @i@ goes under @(i+1)@+  | SigmaInv !Int         -- ^ @i@ goes above @(i+1)@+  deriving (Eq,Ord,Show)+ +-- | The strand (more precisely, the first of the two strands) the generator twistes+brGenIdx :: BrGen -> Int+brGenIdx g = case g of+  Sigma    i -> i+  SigmaInv i -> i++brGenSign :: BrGen -> Sign+brGenSign g = case g of+  Sigma    _ -> Plus+  SigmaInv _ -> Minus++brGenSignIdx :: BrGen -> (Sign,Int)        +brGenSignIdx g = case g of+  Sigma    i -> (Plus ,i)+  SigmaInv i -> (Minus,i) ++-- | The inverse of a braid generator+invBrGen :: BrGen -> BrGen+invBrGen  g = case g of+  Sigma    i -> SigmaInv i+  SigmaInv i -> Sigma    i++--------------------------------------------------------------------------------+-- * The braid type+  +-- | The braid group @B_n@ on @n@ strands.+-- The number @n@ is encoded as a type level natural in the type parameter.+--+-- Braids are represented as words in the standard generators and their+-- inverses.+newtype Braid (n :: Nat) = Braid [BrGen] deriving (Show)++-- | The number of strands in the braid+numberOfStrands :: KnownNat n => Braid n -> Int+numberOfStrands = fromInteger . natVal . braidProxy where                                                         +  braidProxy :: Braid n -> Proxy n+  braidProxy _ = Proxy++-- | Sometimes we want to hide the type-level parameter @n@, for example when+-- dynamically creating braids whose size is known only at runtime.+data SomeBraid = forall n. KnownNat n => SomeBraid (Braid n)++someBraid :: Int -> (forall (n :: Nat). KnownNat n => Braid n) -> SomeBraid+someBraid n polyBraid = +  case snat of    +    SomeNat pxy -> SomeBraid (asProxyTypeOf1 polyBraid pxy)+  where+    snat = case someNatVal (fromIntegral n :: Integer) of+      Just sn -> sn+      Nothing -> error "someBraid: input is not a natural number"++withSomeBraid :: SomeBraid -> (forall n. KnownNat n => Braid n -> a) -> a+withSomeBraid sbraid f = case sbraid of SomeBraid braid -> f braid++mkBraid :: (forall n. KnownNat n => Braid n -> a) -> Int -> [BrGen] -> a+mkBraid f n w = y where+  sb = someBraid n (Braid w)+  y  = withSomeBraid sb f++withBraid +  :: Int+  -> (forall (n :: Nat). KnownNat n => Braid n)+  -> (forall (n :: Nat). KnownNat n => Braid n -> a) +  -> a+withBraid n polyBraid f = +  case snat of    +    SomeNat pxy -> f (asProxyTypeOf1 polyBraid pxy)+  where+    snat = case someNatVal (fromIntegral n :: Integer) of+      Just sn -> sn+      Nothing -> error "withBraid: input is not a natural number"++--------------------------------------------------------------------------------++braidWord :: Braid n -> [BrGen]+braidWord (Braid gs) = gs++braidWordLength :: Braid n -> Int+braidWordLength (Braid gs) = length gs++-- | Embeds a smaller braid group into a bigger braid group    +extend :: (n1 <= n2) => Braid n1 -> Braid n2+extend (Braid gs) = Braid gs++-- | Apply \"free reduction\" to the word, that is, iteratively remove @sigma_i sigma_i^-1@ pairs.+-- The resulting braid is clearly equivalent to the original.+freeReduceBraidWord :: Braid n -> Braid n+freeReduceBraidWord (Braid orig) = Braid (loop orig) where++  loop w = case reduceStep w of+    Nothing -> w+    Just w' -> loop w'+  +  reduceStep :: [BrGen] -> Maybe [BrGen]+  reduceStep = go False where    +    go !changed w = case w of+      (Sigma    x : SigmaInv y : rest) | x==y   -> go True rest+      (SigmaInv x : Sigma    y : rest) | x==y   -> go True rest+      (this : rest)                             -> liftM (this:) $ go changed rest+      _                                         -> if changed then Just w else Nothing++--------------------------------------------------------------------------------+-- * Some specific braids++-- | The braid generator @sigma_i@ as a braid+sigma :: KnownNat n => Int -> Braid (n :: Nat)+sigma k = braid where+  braid = if k > 0 && k < numberOfStrands braid+    then Braid [Sigma k]+    else error "sigma: braid generator index out of range"++-- | The braid generator @sigma_i^(-1)@ as a braid+sigmaInv :: KnownNat n => Int -> Braid (n :: Nat)+sigmaInv k = braid where+  braid = if k > 0 && k < numberOfStrands braid+    then Braid [SigmaInv k]+    else error "sigma: braid generator index out of range"++-- | @doubleSigma s t@ (for s<t)is the generator @sigma_{s,t}@ in Birman-Ko-Lee's+-- \"new presentation\". It twistes the strands @s@ and @t@ while going over all+-- other strands. For @t==s+1@ we get back @sigma s@+-- +doubleSigma :: KnownNat n => Int -> Int -> Braid (n :: Nat)+doubleSigma s t = braid where+  n = numberOfStrands braid+  braid+    | s < 1 || s > n   = error "doubleSigma: s index out of range"+    | t < 1 || t > n   = error "doubleSigma: t index out of range"+    | s >= t           = error "doubleSigma: s >= t"+    | otherwise        = Braid $+       [ Sigma i | i<-[t-1,t-2..s] ] ++ [ SigmaInv i | i<-[s+1..t-1] ]++-- | @positiveWord [2,5,1]@ is shorthand for the word @sigma_2*sigma_5*sigma_1@.+positiveWord :: KnownNat n => [Int] -> Braid (n :: Nat)+positiveWord idxs = braid where+  braid = Braid (map gen idxs) +  n     = numberOfStrands braid+  gen i = if i>0 && i<n then Sigma i else error "positiveWord: index out of range"+       +-- | The (positive) half-twist of all the braid strands, usually denoted by @Delta@.+halfTwist :: KnownNat n => Braid n+halfTwist = braid where+  braid = Braid $ map Sigma $ _halfTwist n +  n     = numberOfStrands braid++-- | The untyped version of 'halfTwist'+_halfTwist :: Int -> [Int]+_halfTwist n = gens where+  gens  = concat [ sub k | k<-[1..n-1] ]+  sub k = [ j | j<-[n-1,n-2..k] ]+  +-- | Synonym for 'halfTwist'+theGarsideBraid :: KnownNat n => Braid n+theGarsideBraid = halfTwist ++-- | The inner automorphism defined by @tau(X) = Delta^-1 X Delta@, +-- where @Delta@ is the positive half-twist.+-- +-- This sends each generator @sigma_j@ to @sigma_(n-j)@.+--+tau :: KnownNat n => Braid n -> Braid n+tau braid@(Braid gens) = Braid (map f gens) where+  n = numberOfStrands braid+  f (Sigma    i) = Sigma    (n-i)+  f (SigmaInv i) = SigmaInv (n-i)+++-- | The involution @tau@ on permutations (permutation braids)+--+tauPerm :: Permutation -> Permutation+tauPerm perm = P.toPermutationUnsafeN n [ (n+1) - perm !!! (n-i) | i<-[0..n-1] ] where+  n = P.permutationSize perm++--------------------------------------------------------------------------------+-- * Group operations++-- | The trivial braid+identity :: Braid n+identity = Braid []++-- | The inverse of a braid. Note: we do not perform reduction here,+-- as a word is reduced if and only if its inverse is reduced.+inverse :: Braid n -> Braid n+inverse = Braid . reverse . map invBrGen . braidWord++-- | Composes two braids, doing free reduction on the result +-- (that is, removing @(sigma_k * sigma_k^-1)@ pairs@)+compose :: Braid n -> Braid n -> Braid n+compose (Braid gs) (Braid hs) = freeReduceBraidWord $ Braid (gs++hs)++composeMany :: [Braid n] -> Braid n+composeMany = freeReduceBraidWord . Braid . concat . map braidWord ++-- | Composes two braids without doing any reduction.+composeDontReduce :: Braid n -> Braid n -> Braid n+composeDontReduce (Braid gs) (Braid hs) = Braid (gs++hs)++--------------------------------------------------------------------------------+-- * Braid permutations++-- | A braid is pure if its permutation is trivial+isPureBraid :: KnownNat n => Braid n -> Bool+isPureBraid braid = (braidPermutation braid == P.identityPermutation n) where+  n = numberOfStrands braid++-- | Returns the left-to-right permutation associated to the braid. +-- We follow the strands /from the left to the right/ (or from the top to the +-- bottom), and return the permutation taking the left side to the right side.+--+-- This is compatible with /right/ (standard) action of the permutations:+-- @permuteRight (braidPermutationRight b1)@ corresponds to the left-to-right+-- permutation of the strands; also:+--+-- > (braidPermutation b1) `multiply` (braidPermutation b2) == braidPermutation (b1 `compose` b2)+--+-- Writing the right numbering of the strands below the left numbering,+-- we got the two-line notation of the permutation.+--+braidPermutation :: KnownNat n => Braid n -> Permutation+braidPermutation braid@(Braid gens) = perm where+  n    = numberOfStrands braid+  perm = _braidPermutation n (map brGenIdx gens)++-- | This is an untyped version of 'braidPermutation'+_braidPermutation :: Int -> [Int] -> Permutation+_braidPermutation n idxs = P.uarrayToPermutationUnsafe (runSTUArray action) where++  action :: forall s. ST s (STUArray s Int Int) +  action = do +    arr <- newArray_ (1,n) +    forM_ [1..n] $ \i -> writeArray arr i i+    worker arr idxs+    return arr+    +  worker arr = go where+    go []     = return arr +    go (i:is) = do+      a <- readArray arr  i+      b <- readArray arr (i+1)+      writeArray arr  i    b+      writeArray arr (i+1) a+      go is++--------------------------------------------------------------------------------+-- * Permutation braids++-- | A positive braid word contains only positive (@Sigma@) generators.+isPositiveBraidWord :: KnownNat n => Braid n -> Bool+isPositiveBraidWord (Braid gs) = all (isPlus . brGenSign) gs ++-- | A /permutation braid/ is a positive braid where any two strands cross+-- at most one, and /positively/. +--+isPermutationBraid :: KnownNat n => Braid n -> Bool+isPermutationBraid braid = isPositiveBraidWord braid && crosses where+  crosses     = and [ check i j | i<-[1..n-1], j<-[i+1..n] ] +  check i j   = zeroOrOne (lkMatrix ! (i,j)) +  zeroOrOne a = (a==1 || a==0)+  lkMatrix    = linkingMatrix   braid+  n           = numberOfStrands braid++-- | Untyped version of 'isPermutationBraid' for positive words.+_isPermutationBraid :: Int -> [Int] -> Bool+_isPermutationBraid n gens = crosses where+  crosses     = and [ check i j | i<-[1..n-1], j<-[i+1..n] ] +  check i j   = zeroOrOne (lkMatrix ! (i,j)) +  zeroOrOne a = (a==1 || a==0)+  lkMatrix    = _linkingMatrix n $ map Sigma gens++-- | For any permutation this functions returns a /permutation braid/ realizing+-- that permutation. Note that this is not unique, so we make an arbitrary choice+-- (except for the permutation @[n,n-1..1]@ reversing the order, in which case +-- the result must be the half-twist braid).+-- +-- The resulting braid word will have a length at most @choose n 2@ (and will have+-- that length only for the permutation @[n,n-1..1]@)+--+-- > braidPermutationRight (permutationBraid perm) == perm+-- > isPermutationBraid    (permutationBraid perm) == True+--+permutationBraid :: KnownNat n => Permutation -> Braid n+permutationBraid perm = braid where+  n1 = numberOfStrands braid+  n2 = P.permutationSize perm+  braid = if n1 == n2+    then Braid (map Sigma $ _permutationBraid perm)+    else error $ "permutationBraid: incompatible n: " ++ show n1 ++ " vs. " ++ show n2++-- | Untyped version of 'permutationBraid'+_permutationBraid :: Permutation -> [Int]+_permutationBraid = concat . _permutationBraid'++-- | Returns the individual \"phases\" of the a permutation braid realizing the+-- given permutation.+_permutationBraid' :: Permutation -> [[Int]]+_permutationBraid' perm = runST action where+  n = P.permutationSize perm++  action :: forall s. ST s [[Int]]+  action = do++    -- cfwd = the current state of strands    : cfwd!j = where is strand #j now?+    -- cinv = the inverse of that permutation : cinv!i = which strand is on the #i position now?++    cfwd <- newArray_ (1,n) :: ST s (STUArray s Int Int)+    cinv <- newArray_ (1,n) :: ST s (STUArray s Int Int)+    forM_ [1..n] $ \j -> do+      writeArray cfwd j j+      writeArray cinv j j++    let doSwap i = do     +          a <- readArray cinv  i+          b <- readArray cinv (i+1)+          writeArray cinv  i    b+          writeArray cinv (i+1) a++          u <- readArray cfwd a+          v <- readArray cfwd b+          writeArray cfwd a v+          writeArray cfwd b u++    -- at the k-th phase, we move the (inv!k)-th strand, which is the k-th strand /on the RHS/, to correct position.+    let worker phase+          | phase >= n  = return []+          | otherwise   = do+              let tgt = P.lookupPermutation perm phase  -- (arr ! phase)+              src <- readArray cfwd tgt+              let this = [src-1,src-2..phase]+              mapM_ doSwap $ this +              rest <- worker (phase+1)+              return (this:rest)++    worker 1+ ++-- | We compute the linking numbers between all pairs of strands:+--+-- > linkingMatrix braid ! (i,j) == strandLinking braid i j +--+linkingMatrix :: KnownNat n => Braid n -> UArray (Int,Int) Int+linkingMatrix braid@(Braid gens) = _linkingMatrix (numberOfStrands braid) gens where++-- | Untyped version of 'linkingMatrix'+_linkingMatrix :: Int -> [BrGen] -> UArray (Int,Int) Int+_linkingMatrix n gens = runSTUArray action where++  action :: forall s. ST s (STUArray s (Int,Int) Int)+  action = do+    perm <- newArray_ (1,n) :: ST s (STUArray s Int Int)+    forM_ [1..n] $ \i -> writeArray perm i i+    let doSwap :: Int -> ST s ()+        doSwap i = do+          a <- readArray perm  i+          b <- readArray perm (i+1)+          writeArray perm  i    b+          writeArray perm (i+1) a+               +    mat <- newArray ((1,1),(n,n)) 0 :: ST s (STUArray s (Int,Int) Int)+    let doAdd :: Int -> Int -> Int -> ST s ()+        doAdd i j pm1 = do+          x <- readArray mat (i,j)+          writeArray mat (i,j) (x+pm1) +          writeArray mat (j,i) (x+pm1)+       +    forM_ gens $ \g -> do+      let (sgn,k) = brGenSignIdx g+      u <- readArray perm  k +      v <- readArray perm (k+1)+      doAdd u v (signValue sgn)+      doSwap k +        +    return mat+    +    +-- | The linking number between two strands numbered @i@ and @j@ +-- (numbered such on the /left/ side).+strandLinking :: KnownNat n => Braid n -> Int -> Int -> Int+strandLinking braid@(Braid gens) i0 j0 +  | i0 < 1 || i0 > n  = error $ "strandLinkingNumber: invalid strand index i: " ++ show i0+  | j0 < 1 || j0 > n  = error $ "strandLinkingNumber: invalid strand index j: " ++ show j0+  | i0 == j0          = 0+  | otherwise         = go i0 j0 gens+  where+    n = numberOfStrands braid+    +    go !i !j []     = 0+    go !i !j (g:gs)  +      | i == k   && j == k+1  = s + go (i+1) (j-1) gs+      | j == k   && i == k+1  = s + go (i-1) (j+1) gs+      | i == k                =     go (i+1)  j    gs+      |             i == k+1  =     go (i-1)  j    gs+      | j == k                =     go  i    (j+1) gs+      |             j == k+1  =     go  i    (j-1) gs+      | otherwise             =     go  i     j    gs+      where+        (sgn,k) = brGenSignIdx g+        s = signValue sgn++--------------------------------------------------------------------------------+-- * Growth ++-- | Bronfman's recursive formula for the reciprocial of the growth function +-- of /positive/ braids. It was already known (by Deligne) that these generating functions +-- are reciprocials of polynomials; Bronfman [1] gave a recursive formula for them.+--+-- > let count n l = length $ nub $ [ braidNormalForm w | w <- allPositiveBraidWords n l ]+-- > let convertPoly (1:cs) = zip (map negate cs) [1..]+-- > pseries' (convertPoly $ bronfmanH n) == expandBronfmanH n == [ count n l | l <- [0..] ] +--+-- * [1] Aaron Bronfman: Growth functions of a class of monoids. Preprint, 2001+--+bronfmanH :: Int -> [Int]+bronfmanH n = bronfmanHsList !! n++-- | An infinite list containing the Bronfman polynomials:+--+-- > bronfmanH n = bronfmanHsList !! n+--+bronfmanHsList :: [[Int]]+bronfmanHsList = list where+  list = map go [0..]+  go 0 = [1]+  go n = sumSeries [ sgn i $ replicate (choose2 i) 0 ++ list !! (n-i) | i<-[1..n] ]+  sgn i = if odd i then id else map negate+  choose2 k = div (k*(k-1)) 2++-- | Expands the reciprocial of @H(n)@ into an infinite power series,+-- giving the growth function of the positive braids on @n@ strands.+expandBronfmanH :: Int -> [Int]+expandBronfmanH n = pseries' (convertPoly $ bronfmanH n) where+  convertPoly (1:cs) = zip (map negate cs) [1..]+   +--------------------------------------------------------------------------------+-- * ASCII diagram++instance KnownNat n => DrawASCII (Braid n) where+  ascii = horizBraidASCII++-- | Horizontal braid diagram, drawn from left to right,+-- with strands numbered from the bottom to the top+horizBraidASCII :: KnownNat n => Braid n -> ASCII+horizBraidASCII = horizBraidASCII' True++-- | Horizontal braid diagram, drawn from left to right.+-- The boolean flag indicates whether to flip the strands+-- vertically ('True' means bottom-to-top, 'False' means top-to-bottom) +horizBraidASCII' :: KnownNat n => Bool -> Braid n -> ASCII+horizBraidASCII' flipped braid@(Braid gens) = final where++  n = numberOfStrands braid+ +  final        = vExtendWith VTop 1 $ hCatTop allBlocks+  allBlocks    = prelude ++ middleBlocks ++ epilogue+  prelude      = [ numberBlock   , spaceBlock , beginEndBlock ] +  epilogue     = [ beginEndBlock , spaceBlock , numberBlock'  ]+  middleBlocks = map block gens +  +  block g = case g of+    Sigma    i -> block' i $ if flipped then over  else under+    SigmaInv i -> block' i $ if flipped then under else over++  block' i middle = asciiFromLines $ drop 2 $ concat +                  $ replicate a horiz ++ [space3, middle] ++ replicate b horiz+    where +      (a,b) = if flipped then (n-i-1,i-1) else (i-1,n-i-1)++  -- cycleN :: Int -> [a] -> [a]+  -- cycleN n = concat . replicate n++  spaceBlock    = transparentBox (1,n*3-2)+  beginEndBlock = asciiFromLines $ drop 2 $ concat $ replicate n horiz+  numberBlock   = mkNumbers [1..n]+  numberBlock'  = mkNumbers $ P.fromPermutation $ braidPermutation braid++  mkNumbers :: [Int] -> ASCII+  mkNumbers list = vCatWith HRight (VSepSpaces 2) $ map asciiShow +                 $ (if flipped then reverse else id) $ list++  under  = [ "\\ /" , " / "  , "/ \\" ]+  over   = [ "\\ /" , " \\ " , "/ \\" ]+  horiz  = [ "   "  , "   "  , "___"  ]+  space3 = [ "   "  , "   "  , "   "  ]++--------------------------------------------------------------------------------++{- this is unusably ugly and vertically loooong++-- | Vertical braid diagram, drawn from the top to the bottom.+-- Strands are numbered from the left to the right.+--+-- Writing down the strand numbers from the top and and the bottom+-- gives the two-line notation of the permutation realized by the braid.+--+verticalBraidASCII :: KnownNat n => Braid n -> ASCII+verticalBraidASCII braid@(Braid gens) = final where++  n = numberOfStrands braid+ +  final        = hExtendWith HLeft 1 $ vCatLeft allBlocks+  allBlocks    = prelude ++ middleBlocks ++ epilogue+  prelude      = [ numberBlock   , spaceBlock , beginEndBlock ] +  epilogue     = [ beginEndBlock , spaceBlock , numberBlock'  ]+  middleBlocks = map block gens +  +  block g = case g of+    Sigma    i -> block' i under+    SigmaInv i -> block' i over++  block' i middle = asciiFromLines (map f middle) where+    f xs = drop 1 $ concat $ h (i-1) ++ ["   ",xs] ++ h (n-i-1)+    h k  = replicate k "  |"++  spaceBlock    = transparentBox (n*3-2,1)+  beginEndBlock = asciiFromLines $ replicate 3 $ drop 1 $ concat (replicate n "  |")+  numberBlock   = mkNumbers [1..n]+  numberBlock'  = mkNumbers $ P.fromPermutation $ braidPermutation braid++  mkNumbers :: [Int] -> ASCII+  mkNumbers list = asciiFromString (drop 1 $ concatMap show3 list)+  show3 k = let s = show k +            in  replicate (3-length s) ' ' ++ s++  under  = [ "\\ /" , " / "  , "/ \\" ]+  over   = [ "\\ /" , " \\ " , "/ \\" ]++-}++--------------------------------------------------------------------------------+-- * List of all words++-- | All positive braid words of the given length+allPositiveBraidWords :: KnownNat n => Int -> [Braid n]+allPositiveBraidWords l = braids where+  n = numberOfStrands (head braids)+  braids = map Braid $ _allPositiveBraidWords n l ++-- | All braid words of the given length+allBraidWords :: KnownNat n => Int -> [Braid n]+allBraidWords l = braids where+  n = numberOfStrands (head braids)+  braids = map Braid $ _allBraidWords n l ++-- | Untyped version of 'allPositiveBraidWords'+_allPositiveBraidWords :: Int -> Int -> [[BrGen]]+_allPositiveBraidWords n = go where+  go 0 = [[]]+  go k = [ Sigma i : rest | i<-[1..n-1] , rest <- go (k-1) ]++-- | Untyped version of 'allBraidWords'+_allBraidWords :: Int -> Int -> [[BrGen]]+_allBraidWords n = go where+  go 0 = [[]]+  go k = [ gen : rest | gen <- gens , rest <- go (k-1) ]+  gens = concat [ [ Sigma i , SigmaInv i ] | i<-[1..n-1] ]++--------------------------------------------------------------------------------+-- * Random braids  ++-- | Random braid word of the given length+randomBraidWord :: (RandomGen g, KnownNat n) => Int -> g -> (Braid n, g)+randomBraidWord len g = (braid, g') where+  braid  = Braid w+  n      = numberOfStrands braid+  (w,g') = _randomBraidWord n len g++-- | Random /positive/ braid word of the given length+randomPositiveBraidWord :: (RandomGen g, KnownNat n) => Int -> g -> (Braid n, g)+randomPositiveBraidWord len g = (braid, g') where+  braid  = Braid w+  n      = numberOfStrands braid+  (w,g') = _randomPositiveBraidWord n len g++--------------------------------------------------------------------------------++-- | Given a braid word, we perturb it randomly @m@ times using the braid relations,+-- so that the resulting new braid word is equivalent to the original.+--+-- Useful for testing.+--+randomPerturbBraidWord :: forall n g. (RandomGen g, KnownNat n) => Int -> Braid n -> g -> (Braid n, g)+randomPerturbBraidWord m braid@(Braid xs) g = (Braid word' , g') where++  (word',g') = go m (length xs) xs g ++  n = numberOfStrands braid++  -- | A random pair cancelling each other+  rndE :: g -> ([BrGen],g)+  rndE g = (e1,g'') where+    (i , g'  ) = randomR (1,n-1) g +    (b , g'' ) = random          g'+    e0 = [SigmaInv i, Sigma i] +    e1 = if b then reverse e0 else e0++  brg    s i = case s of { Plus -> Sigma    i ; Minus -> SigmaInv i }+  brginv s i = case s of { Plus -> SigmaInv i ; Minus -> Sigma    i }++  go :: Int -> Int -> [BrGen] -> g -> ([BrGen], g)+  go !cnt !len !word !g ++    | cnt <= 0   = (word, g)++    | len <  2   = let w' = if b1 then (e++word) else (word++e)        -- if it is short, we just add a trivial pair somewhere+                   in  continue g4 (len+2) w'++    | abs (i-j) >= 2            = continue g4  len    (as ++ v:u:bs)         -- they commute, so we just commute them++    | i == j && s/=t            = continue g4 (len-2) (as ++ bs    )         -- they are inverse of each other, so we kill them++    | abs (i-j) == 1 && s == t  = let mid = if b1 +                                        then [ brg s j , brg s i , brg s j , brginv s i ]   -- insert pair and+                                        else [ brginv s j , brg s i , brg s j , brg s i ]   -- apply ternary relation +                                  in  continue g4 (len+2) (as ++ mid ++ bs)++    | otherwise                 = let mid = if b1+                                        then (u : e ++ [v])+                                        else if b2+                                          then [u,v] ++ e+                                          else e ++ [u,v]+                                  in continue g4 (len+2) (as++(u:e)++[v]++bs)          -- otherwise we just insert an trivial pair         ++    where++      (pos         , g1 ) = randomR (0,len-2) g+      (b1 :: Bool  , g2 ) = random g1+      (b2 :: Bool  , g3 ) = random g2+      (e           , g4 ) = rndE   g3+      (as,u:v:bs) = splitAt pos word+      (s,i) = brGenSignIdx u+      (t,j) = brGenSignIdx v+  +      continue g' len' word' = go (cnt-1) len' word' g'++--------------------------------------------------------------------------------++-- | This version of 'randomBraidWord' may be convenient to avoid the type level stuff+withRandomBraidWord +  :: RandomGen g +  => (forall n. KnownNat n => Braid n -> a) +  -> Int                -- ^ number of strands+  -> Int                -- ^ length of the random word+  -> g -> (a, g)+withRandomBraidWord f n len = runRand $ do+  withSelectedM f (rand $ randomBraidWord len) n++-- | This version of 'randomPositiveBraidWord' may be convenient to avoid the type level stuff+withRandomPositiveBraidWord +  :: RandomGen g +  => (forall n. KnownNat n => Braid n -> a) +  -> Int                -- ^ number of strands+  -> Int                -- ^ length of the random word+  -> g -> (a, g)+withRandomPositiveBraidWord f n len = runRand $ do+  withSelectedM f (rand $ randomPositiveBraidWord len) n++-- | Untyped version of 'randomBraidWord'+_randomBraidWord +  :: (RandomGen g) +  => Int                -- ^ number of strands+  -> Int                -- ^ length of the random word+  -> g -> ([BrGen], g)+_randomBraidWord n len = runRand $ replicateM len $ do+  k <- randChoose (1,n-1)+  s <- randRoll+  return $ case s of+    Plus  -> Sigma k+    Minus -> SigmaInv k++-- | Untyped version of 'randomPositiveBraidWord'+_randomPositiveBraidWord +  :: (RandomGen g) +  => Int             -- ^ number of strands+  -> Int             -- ^ length of the random word+  -> g -> ([BrGen], g)+_randomPositiveBraidWord n len = runRand $ replicateM len $ do+  liftM Sigma $ randChoose (1,n-1)++--------------------------------------------------------------------------------+
+ src/Math/Combinat/Groups/Braid/NF.hs view
@@ -0,0 +1,536 @@++-- | Normal form of braids, take 1.+--+-- We implement the Adyan-Thurston-ElRifai-Morton solution to the word problem in braid groups.+--+--+-- Based on:+--+-- * [1] Joan S. Birman, Tara E. Brendle: BRAIDS - A SURVEY+--   <https://www.math.columbia.edu/~jb/Handbook-21.pdf> (chapter 5.1)+--+-- * [2] Elsayed A. Elrifai, Hugh R. Morton: Algorithms for positive braids+--++{-# LANGUAGE +      CPP, BangPatterns, +      ScopedTypeVariables, ExistentialQuantification,+      DataKinds, KindSignatures, Rank2Types #-}++module Math.Combinat.Groups.Braid.NF  +  ( -- * Normal form+    BraidNF (..)+  , nfReprWord+  , braidNormalForm+  , braidNormalForm'+  , braidNormalFormNaive'+    -- * Starting and finishing sets+  , permWordStartingSet+  , permWordFinishingSet    +  , permutationStartingSet+  , permutationFinishingSet    +  )+  where++--------------------------------------------------------------------------------++import Data.Proxy+import GHC.TypeLits++import Control.Monad++import Data.List ( mapAccumL , foldl' , (\\) )++import Data.Array.Unboxed+import Data.Array.ST+import Data.Array.IArray+import Data.Array.MArray+import Data.Array.Unsafe+import Data.Array.Base++import Control.Monad.ST++import Math.Combinat.Helper+import Math.Combinat.Sign++import Math.Combinat.Permutations ( Permutation(..) , (!!!) , isIdentityPermutation , isReversePermutation )+import qualified Math.Combinat.Permutations as P++import Math.Combinat.Groups.Braid++--------------------------------------------------------------------------------++-- | A unique normal form for braids, called the /left-greedy normal form/.+-- It looks like @Delta^i*P@, where @Delta@ is the positive half-twist, @i@ is an integer,+-- and @P@ is a positive word, which can be further decomposed into non-@Delta@ /permutation words/; +-- these words themselves are not unique, but the permutations they realize /are/ unique.+--+-- This will solve the word problem relatively fast, +-- though it is not the fastest known algorithm.+--+data BraidNF (n :: Nat) = BraidNF+  { _nfDeltaExp :: !Int              -- ^ the exponent of @Delta@+  , _nfPerms    :: [Permutation]     -- ^ the permutations+  }+  deriving (Eq,Ord,Show)++-- | A braid word representing the given normal form+nfReprWord :: KnownNat n => BraidNF n -> Braid n+nfReprWord (BraidNF k perms) = freeReduceBraidWord $ composeMany (deltas ++ rest) where++  deltas +    | k > 0     = replicate   k           halfTwist+    | k < 0     = replicate (-k) (inverse halfTwist)+    | otherwise = []++  rest = map permutationBraid perms++--------------------------------------------------------------------------------++-- | Computes the normal form of a braid. We apply free reduction first, it should be faster that way.+braidNormalForm :: KnownNat n => Braid n -> BraidNF n+braidNormalForm = braidNormalForm' . freeReduceBraidWord++-- | This function does not apply free reduction before computing the normal form+braidNormalForm' :: KnownNat n => Braid n -> BraidNF n+braidNormalForm' braid@(Braid gens) = BraidNF (dexp+pexp) perms where+  n = numberOfStrands braid+  invless = replaceInverses n gens+  (dexp,posxword) = moveDeltasLeft n invless+  factors = leftGreedyFactors n $ expandPosXWord n posxword+  (pexp,perms) = normalizePermFactors n $ map (_braidPermutation n) factors++-- | This one uses the naive inverse replacement method. Probably somewhat slower than 'braidNormalForm''.+braidNormalFormNaive' :: KnownNat n => Braid n -> BraidNF n+braidNormalFormNaive' braid@(Braid gens) = BraidNF (dexp+pexp) perms where+  n = numberOfStrands braid+  invless = replaceInversesNaive gens+  (dexp,posxword) = moveDeltasLeft n invless+  factors = leftGreedyFactors n $ expandPosXWord n posxword+  (pexp,perms) = normalizePermFactors n $ map (_braidPermutation n) factors++--------------------------------------------------------------------------------++-- | Replaces groups of @sigma_i^-1@ generators by @(Delta^-1 * P)@, +-- where @P@ is a positive word.+--+-- This should be more clever (resulting in shorter words) than the naive version below+--+replaceInverses :: Int -> [BrGen] -> [XGen]+replaceInverses n gens = worker gens where++  worker [] = []+  worker xs = replaceNegs neg ++ map (XSigma . brGenIdx) pos ++ worker rest where +    (neg,tmp ) = span (isMinus . brGenSign) xs+    (pos,rest) = span (isPlus  . brGenSign) tmp+  +  replaceNegs gs = concatMap replaceFac facs where+    facs = leftGreedyFactors n $ map brGenIdx gs+  +  replaceFac idxs = XDelta (-1) : map XSigma (_permutationBraid perm) where+    perm = (P.reversePermutation n) `P.multiplyPermutation` (P.adjacentTranspositions n idxs)+++-- | Replaces @sigma_i^-1@ generators by @(Delta^-1 * L_i)@.+replaceInversesNaive :: [BrGen] -> [XGen]+replaceInversesNaive gens = concatMap f gens where +  f (Sigma    i) = [ XSigma i ]+  f (SigmaInv i) = [ XDelta (-1) , XL i ]++--------------------------------------------------------------------------------++-- | Temporary data structure to be used during the normal form computation+data XGen+  = XDelta !Int   -- ^ @Delta^k@+  | XSigma !Int   -- ^ @Sigma_j@+  | XL     !Int   -- ^ @L_j = Delta * sigma_j^-1@+  | XTauL  !Int   -- ^ @tau(L_j)@+  deriving (Eq,Show)++isXDelta :: XGen -> Bool+isXDelta x = case x of { XDelta {} -> True ; _ -> False }++-- | We move the all @Delta@'s to the left+moveDeltasLeft :: Int -> [XGen] -> (Int,[XGen])+moveDeltasLeft n input = (finalExp, finalPosWord) where+  +  (XDelta finalExp : finalPosWord) =  reverse $ worker 0 (reverse input) ++  -- we start from the right end, and work towards the left end+  worker  dexp [] = [ XDelta dexp ]+  worker !dexp xs = this' ++ worker dexp' rest where +    (delta,notdelta) = span isXDelta xs+    (this ,rest    ) = span (not . isXDelta) notdelta+    dexp' = dexp + sumDeltas delta+    this' = if even dexp' +      then this+      else map xtau this++  sumDeltas :: [XGen] -> Int+  sumDeltas xs = foldl' (+) 0 [ k | XDelta k <- xs ]++  -- | The @X -> Delta^-1 * X * Delta@ inner automorphism+  xtau :: XGen -> XGen+  xtau (XSigma j) = XSigma (n-j)+  xtau (XDelta k) = XDelta k  +  xtau (XL     k) = XTauL  k  +  xtau (XTauL  k) = XL     k  ++--------------------------------------------------------------------------------++-- | Expands a /positive/ \"X-word\" into a positive braid word+expandPosXWord :: Int -> [XGen] -> [Int]+expandPosXWord n = concatMap f where++  posHalfTwist = _halfTwist n++  jtau :: Int -> Int+  jtau j = n-j++  posLTable    = listArray (1,n-1) [ _permutationBraid (posLPerm n i) | i<-[1..n-1] ] :: Array Int [Int]+  posTauLTable = amap (map jtau) posLTable++  -- posRTable = listArray (1,n-1) [ _permutationBraid (posRPerm n i) | i<-[1..n-1] ] :: Array Int [Int]++  f x = case x of+    XSigma i -> [i]+    XL     i -> posLTable    ! i+    XTauL  i -> posTauLTable ! i+    XDelta i +      | i > 0     -> concat (replicate i posHalfTwist)+      | i < 0     -> error "expandPosXWord: negative delta power"+      | otherwise -> []++  -- word :: Braid n -> [Int]+  -- word (Braid gens) = map brGenIdx gens+++-- | Expands an \"X-word\" into a braid word. Useful for debugging.+expandAnyXWord :: forall n. KnownNat n => [XGen] -> Braid n+expandAnyXWord xgens = braid where+  n = numberOfStrands braid++  braid = composeMany (map f xgens)++  posHalfTwist = halfTwist            :: Braid n+  negHalfTwist = inverse posHalfTwist :: Braid n++  posLTable    = listArray (1,n-1) [ permutationBraid (posLPerm n i) | i<-[1..n-1] ] :: Array Int (Braid n)+  posTauLTable = amap tau posLTable++  -- posRTable = listArray (1,n-1) [ permutationBraid (posRPerm n i) | i<-[1..n-1] ] :: Array Int (Braid n)++  f :: XGen -> Braid n+  f x = case x of+    XSigma i -> sigma i+    XL     i -> posLTable    ! i+    XTauL  i -> posTauLTable ! i+    XDelta i +      | i > 0     -> composeMany (replicate   i  posHalfTwist)+      | i < 0     -> composeMany (replicate (-i) negHalfTwist)+      | otherwise -> identity++--------------------------------------------------------------------------------++-- | @posL k@ (denoted as @L_k@) is a /positive word/ which +-- satisfies @Delta = L_k * sigma_k@, or:+-- +-- > (inverse halfTwist) `compose` (posL k) ~=~ sigmaInv k@+-- +-- Thus we can replace any word with a positive word plus some @Delta^-1@\'s+--+posL :: KnownNat n => Int -> Braid n+posL k = braid where+  n = numberOfStrands braid+  braid = permutationBraid (posLPerm n k)++-- | @posR k n@ (denoted as @R_k@) is a /permutation braid/ which +-- satisfies @Delta = sigma_k * R_k@+-- +-- > (posR k) `compose` (inverse halfTwist) ~=~ sigmaInv k@+-- +-- Thus we can replace any word with a positive word plus some @Delta^-1@'s+--+posR :: KnownNat n => Int -> Braid n+posR k = braid where+  n = numberOfStrands braid+  braid = permutationBraid (posRPerm n k)++-- | The permutation @posL k :: Braid n@ is realizing+posLPerm :: Int -> Int -> Permutation+posLPerm n k +  | k>0 && k<n  = (P.reversePermutation n `P.multiplyPermutation` P.adjacentTransposition n k)+  | otherwise   = error "posLPerm: index out of range"++-- | The permutation @posR k :: Braid n@ is realizing+posRPerm :: Int -> Int -> Permutation+posRPerm n k +  | k>0 && k<n  = (P.adjacentTransposition n k `P.multiplyPermutation` P.reversePermutation n )+  | otherwise   = error "posRPerm: index out of range"++--------------------------------------------------------------------------------++-- | We recognize left-greedy factors which are @Delta@-s (easy, since they are the only ones+-- with length @(n choose 2)@), and move them to the left, returning their summed exponent+-- and the filtered new factors. We also filter trivial permutations (which should only happen +-- for the trivial braid, but it happens there?)+--+filterDeltaFactors :: Int -> [[Int]] -> (Int, [[Int]])+filterDeltaFactors n facs = (exp',facs'') where++  (exp',facs') = go 0 (reverse facs)++  jtau j = n-j+  facs'' = reverse facs'+  maxlen = div (n*(n-1)) 2++  go !e []       = (e,[])+  go !e (xs:xxs)  +    | null xs             = go e xxs+    | length xs == maxlen = go (e+1) xxs+    | otherwise           =  +        if even e+          then let (e',yys) = go e xxs in (e' ,          xs : yys) +          else let (e',yys) = go e xxs in (e' , map jtau xs : yys)  ++-------------------------------------------------------------------------------- ++-- | The /starting set/ of a positive braid P is the subset of @[1..n-1]@ defined by+-- +-- > S(P) = [ i | P = sigma_i * Q , Q is positive ] = [ i | (sigma_i^-1 * P) is positive ] +--+-- This function returns the starting set a positive word, assuming it +-- is a /permutation braid/ (see Lemma 2.4 in [2])+--+permWordStartingSet :: Int -> [Int] -> [Int]+permWordStartingSet n xs = permWordFinishingSet n (reverse xs)++-- | The /finishing set/ of a positive braid P is the subset of @[1..n-1]@ defined by+-- +-- > F(P) = [ i | P = Q * sigma_i , Q is positive ] = [ i | (P * sigma_i^-1) is positive ] +--+-- This function returns the finishing set, assuming the input is a /permutation braid/+--+permWordFinishingSet :: Int -> [Int] -> [Int]+permWordFinishingSet n input = runST action where++  action :: forall s. ST s [Int]+  action = do+    perm <- newArray_ (1,n) :: ST s (STUArray s Int Int)+    forM_ [1..n] $ \i -> writeArray perm i i+    forM_ input $ \i -> do+      a <- readArray perm  i+      b <- readArray perm (i+1)+      writeArray perm  i    b+      writeArray perm (i+1) a+    flip filterM [1..n-1] $ \i -> do+      a <- readArray perm  i+      b <- readArray perm (i+1) +      return (b<a)                    -- Lemma 2.4 in [2]++-- | This satisfies+-- +-- > permutationStartingSet p == permWordStartingSet n (_permutationBraid p)+--+permutationStartingSet :: Permutation -> [Int]+permutationStartingSet = permutationFinishingSet . P.inversePermutation++-- | This satisfies+-- +-- > permutationFinishingSet p == permWordFinishingSet n (_permutationBraid p)+--+permutationFinishingSet :: Permutation -> [Int]+permutationFinishingSet perm+  = [ i | i<-[1..n-1] , perm !!! i > perm !!! (i+1) ] where n = P.permutationSize perm++-- | Returns the list of permutations failing Lemma 2.5 in [2] +-- (so an empty list means the implementaton is correct)+fails_lemmma_2_5 :: Int -> [Permutation]+fails_lemmma_2_5 n = [ p | p <- P.permutations n , not (test p) ] where+  test p = and [ check i | i<-[1..n-1] ] where+    w = _permutationBraid p+    s = permWordStartingSet n w+    check i = _isPermutationBraid n (i:w) == (not $ elem i s)++-------------------------------------------------------------------------------- +                    +-- | Given factors defined as permutation braids, we normalize them+-- to /left-canonical form/ by ensuring that+--+-- * for each consecutive pair @(P,Q)@ the finishing set F(P) contains the starting set S(Q)+--+-- * all @Delta@-s (corresponding to the reverse permutation) are moved to the left+--+-- * all trivial factors are filtered out+--+-- Unfortunately, it seems that we may need multiple sweeps to do that...+--+normalizePermFactors :: Int -> [Permutation] -> (Int,[Permutation])+normalizePermFactors n = go 0 where+  go !acc input = +    if (exp==0 && input == output) +      then (acc,input) +      else go (acc+exp) output +    where +      (exp,output) = normalizePermFactors1 n input++-- | Does 1 sweep of the above normalization process.+-- Unfortunately, it seems that we may need to do this multiple times...+--+normalizePermFactors1 :: Int -> [Permutation] -> (Int,[Permutation])+normalizePermFactors1 n input = (exp, reverse output) where+  (exp, output) = worker 0 (reverse input)++  -- Notes: We work in reverse order, from the right to the left.+  -- We maintain the number of Delta-s pushed through; the tau involutions+  -- are implicit in the parity of this number+  --+  worker :: Int -> [Permutation] -> (Int,[Permutation])+  worker = worker' 0 0+  +  -- We also maintain additional 0/1 flip flags for the first two permutations+  -- this is a little bit of hack but it should work nicely+  --+  worker' :: Int -> Int -> Int -> [Permutation] -> (Int,[Permutation])+  worker' !ep !eq !e (!p : rest@(!q : rest')) ++    -- check if the very first element is identity or Delta +    -- (note: these are tau-invariants)++    | isIdentityPermutation p  = worker'  eq  0  e    rest+    | isReversePermutation  p  = worker'  eq  0 (e+1) rest++    -- check if the second element is identity or Delta +    -- this is necessary since we "fatten" the second element and it can possibly+    -- become Delta after a while (?)++    | isIdentityPermutation q  = worker'  ep    0  e    (p : rest')+    | isReversePermutation  q  = worker' (ep-1) 0 (e+1) (p : rest')    ++    -- ok so we have something like "... : Q : P"+    -- if F(Q) contains S(P) then we can move on; +    -- otherwise there is an element j in S(P) \\ F(Q), so we can +    -- replace it by "... : Qj : jP"++    | otherwise = +        case permutationStartingSet preal \\ permutationFinishingSet qreal of  +          []    -> let (e',rs) = worker' eq 0 e rest in (e', preal : rs)+          (j:_) -> worker' (-e) (-e) e (p':q':rest') where +                     s  = P.adjacentTransposition n j+                     p' = P.multiplyPermutation s preal+                     q' = P.multiplyPermutation qreal s+        where+          preal = oddTau (e+ep) p       -- the "real" p+          qreal = oddTau (e+eq) q       -- the "real" q++  worker' _   _  !e [ ] = (e,[])+  worker' !ep _  !e [p] +    | isIdentityPermutation p  = (e   , [])+    | isReversePermutation  p  = (e+1 , [])+    | otherwise                = (e   , [oddTau (e+ep) p] )++  oddTau :: Int -> Permutation -> Permutation+  oddTau !e p = if even e then p else tauPerm p++{-+  checkDelta :: Int -> Permutation -> [Permutation] -> (Int,[Permutation])+  checkDelta !e !p !rest +    | P.isIdentityPermutation p  = worker  e    rest+    | isReversePermutation    p  = worker (e+1) rest+    | otherwise                  = let (e',rs) = worker e rest in (e', oddTau e p : rs)+-}        ++-------------------------------------------------------------------------------- ++-- | Given a /positive/ word, we apply left-greedy factorization of+-- that word into subwords representing /permutation braids/.+--+-- Example 5.1 from the above handbook:+--+-- > leftGreedyFactors 7 [1,3,2,2,1,3,3,2,3,2] == [[1,3,2],[2,1,3],[3,2,3],[2]]+--+leftGreedyFactors :: Int -> [Int] -> [[Int]]+leftGreedyFactors n input = filter (not . null) $ runST (action input) where++  action :: forall s. [Int] -> ST s [[Int]]+  action input = do++    perm <- newArray_ (1,n) :: ST s (STUArray s Int Int)+    forM_ [1..n] $ \i -> writeArray perm i i+    let doSwap :: Int -> ST s ()+        doSwap i = do+          a <- readArray perm  i+          b <- readArray perm (i+1)+          writeArray perm  i    b+          writeArray perm (i+1) a+               +    mat <- newArray ((1,1),(n,n)) 0 :: ST s (STUArray s (Int,Int) Int)+    let clearMat = forM_ [1..n] $ \i -> +          forM_ [1..n] $ \j -> writeArray mat (i,j) 0+          +    let doAdd1 :: Int -> Int -> ST s Int+        doAdd1 i j = do+          x <- readArray mat (i,j)+          let y = x+1+          writeArray mat (i,j) y +          writeArray mat (j,i) y+          return y+           +    let worker :: [Int] -> ST s [[Int]]+        worker []     = return [[]]+        worker (p:ps) = do+          u <- readArray perm  p +          v <- readArray perm (p+1)+          c <- doAdd1 u v +          doSwap p+          if c<=1+            then do+              ffs <- worker ps+              case ffs of+                (f:fs) -> return ((p:f):fs)+                _      -> error "Braid/NF/leftGreedyFactors/worker: fatal error; should not happen"+            else do+              clearMat+              fs <- worker (p:ps)+              return ([]:fs)+              +    worker input++--------------------------------------------------------------------------------++{-++-- | Finds ternary braid relations, and returns them as a list of indices, decorated+-- with a flag specifying which side of the relation we found, a sign specifying+-- whether it is a relation between positive or negative generators.+--+findTernaryBraidRelations :: Braid n -> [(Int,Bool,Sign)]+findTernaryBraidRelations (Braid gens) = go 0 gens where+  go !k (Sigma a : rest@(Sigma b : Sigma c : _))  +    | a==c && b==a+1 = (k,True ,Plus) : go (k+1) rest+    | a==c && b==a-1 = (k,False,Plus) : go (k+1) rest+    | otherwise      =                  go (k+1) rest+  go !k (SigmaInv a : rest@(SigmaInv b : SigmaInv c : _))  +    | a==c && b==a+1 = (k,True ,Minus) : go (k+1) rest+    | a==c && b==a-1 = (k,False,Minus) : go (k+1) rest+    | otherwise      =                   go (k+1) rest+  go !k (x:xs) = go (k+1) xs+  go _  []     = []++-- | Finds subsequences like @(i,i+1,i)@ and @(i+1,i,i+1)@, and returns them+-- and a list of indices, plus a flag specifying which one we found (the first +-- one is 'True', second one is 'False')+--+_findTernaryBraidRelations :: [Int] -> [(Int,Bool)]+_findTernaryBraidRelations = go 0 where+  go !k (a:rest@(b:c:_))  +    | a==c && b==a+1 = (k,True ) : go (k+1) rest+    | a==c && b==a-1 = (k,False) : go (k+1) rest+    | otherwise      =             go (k+1) rest+  go !k (x:xs) = go (k+1) xs+  go _  []     = []++-}++--------------------------------------------------------------------------------+
+ src/Math/Combinat/Groups/Free.hs view
@@ -0,0 +1,523 @@++-- | Words in free groups (and free powers of cyclic groups).+--+-- This module is not re-exported by "Math.Combinat"+--+{-# LANGUAGE CPP, BangPatterns, PatternGuards #-}+module Math.Combinat.Groups.Free where++--------------------------------------------------------------------------------++-- new Base exports "Word" from Data.Word...+#ifdef MIN_VERSION_base+#if MIN_VERSION_base(4,7,1)+import Prelude hiding ( Word )+#endif+#elif __GLASGOW_HASKELL__ >= 709+import Prelude hiding ( Word )+#endif++import Data.Char     ( chr )+import Data.List     ( mapAccumL , groupBy )++import Control.Monad ( liftM )+import System.Random++import Math.Combinat.Numbers+import Math.Combinat.Sign+import Math.Combinat.Helper++--------------------------------------------------------------------------------+-- * Words++-- | A generator of a (free) group, indexed by which \"copy\" of the group we are dealing with.+data Generator idx+  = Gen !idx          -- @a@+  | Inv !idx          -- @a^(-1)@+  deriving (Eq,Ord,Show,Read)++-- | The index of a generator+genIdx :: Generator idx -> idx+genIdx g = case g of+  Gen x -> x+  Inv x -> x++-- | The sign of the (exponent of the) generator (that is, the generator is 'Plus', the inverse is 'Minus')+genSign :: Generator idx -> Sign+genSign g = case g of { Gen _ -> Plus ; Inv _ -> Minus }  ++genSignValue :: Generator idx -> Int+genSignValue g = case g of { Gen _ -> (1::Int) ; Inv _ -> (-1::Int) } ++-- | keep the index, but return always the 'Gen' one.+absGen :: Generator idx -> Generator idx +absGen g = case g of+  Gen x -> Gen x+  Inv x -> Gen x++-- | A /word/, describing (non-uniquely) an element of a group.+-- The identity element is represented (among others) by the empty word.+type Word idx = [Generator idx] ++--------------------------------------------------------------------------------++-- | Generators are shown as small letters: @a@, @b@, @c@, ...+-- and their inverses are shown as capital letters, so @A=a^-1@, @B=b^-1@, etc.+showGen :: Generator Int -> Char+showGen (Gen i) = chr (96+i)+showGen (Inv i) = chr (64+i)++showWord :: Word Int -> String+showWord = map showGen++--------------------------------------------------------------------------------+  +instance Functor Generator where+  fmap f g = case g of +    Gen x -> Gen (f x) +    Inv y -> Inv (f y)+    +--------------------------------------------------------------------------------++-- | The inverse of a generator+inverseGen :: Generator a -> Generator a+inverseGen g = case g of+  Gen x -> Inv x+  Inv x -> Gen x++-- | The inverse of a word+inverseWord :: Word a -> Word a+inverseWord = map inverseGen . reverse++-- | Lists all words of the given length (total number will be @(2g)^n@).+-- The numbering of the generators is @[1..g]@.+allWords +  :: Int         -- ^ @g@ = number of generators +  -> Int         -- ^ @n@ = length of the word+  -> [Word Int]+allWords g = go where+  go !0 = [[]]+  go !n = [ x:xs | xs <- go (n-1) , x <- elems ]+  elems =  [ Gen a | a<-[1..g] ]+        ++ [ Inv a | a<-[1..g] ]++-- | Lists all words of the given length which do not contain inverse generators+-- (total number will be @g^n@).+-- The numbering of the generators is @[1..g]@.+allWordsNoInv +  :: Int         -- ^ @g@ = number of generators +  -> Int         -- ^ @n@ = length of the word+  -> [Word Int]+allWordsNoInv g = go where+  go !0 = [[]]+  go !n = [ x:xs | xs <- go (n-1) , x <- elems ]+  elems = [ Gen a | a<-[1..g] ]++--------------------------------------------------------------------------------+-- * Random words++-- | A random group generator (or its inverse) between @1@ and @g@+randomGenerator+  :: RandomGen g+  => Int         -- ^ @g@ = number of generators +  -> g -> (Generator Int, g)+randomGenerator !d !g0 = (gen, g2) where+  (b, !g1) = random        g0+  (k, !g2) = randomR (1,d) g1+  gen = if b then Gen k else Inv k++-- | A random group generator (but never its inverse) between @1@ and @g@+randomGeneratorNoInv+  :: RandomGen g+  => Int         -- ^ @g@ = number of generators +  -> g -> (Generator Int, g)+randomGeneratorNoInv !d !g0 = (Gen k, g1) where+  (!k, !g1) = randomR (1,d) g0++-- | A random word of length @n@ using @g@ generators (or their inverses)+randomWord +  :: RandomGen g+  => Int         -- ^ @g@ = number of generators +  -> Int         -- ^ @n@ = length of the word+  -> g -> (Word Int, g)+randomWord !d !n !g0 = (word,g1) where+  (g1,word) = mapAccumL (\g _ -> swap (randomGenerator d g)) g0 [1..n]   ++-- | A random word of length @n@ using @g@ generators (but not their inverses)+randomWordNoInv+  :: RandomGen g+  => Int         -- ^ @g@ = number of generators +  -> Int         -- ^ @n@ = length of the word+  -> g -> (Word Int, g)+randomWordNoInv !d !n !g0 = (word,g1) where+  (g1,word) = mapAccumL (\g _ -> swap (randomGeneratorNoInv d g)) g0 [1..n]   +  +--------------------------------------------------------------------------------+-- * The free group on @g@ generators++{-# SPECIALIZE multiplyFree        :: Word Int -> Word Int -> Word Int #-}+{-# SPECIALIZE equivalentFree      :: Word Int -> Word Int -> Bool     #-}+{-# SPECIALIZE reduceWordFree      :: Word Int -> Word Int #-}+{-# SPECIALIZE reduceWordFreeNaive :: Word Int -> Word Int #-}++-- | Multiplication of the free group (returns the reduced result). It is true+-- for any two words w1 and w2 that+--+-- > multiplyFree (reduceWordFree w1) (reduceWord w2) = multiplyFree w1 w2+--+multiplyFree :: Eq idx => Word idx -> Word idx -> Word idx+multiplyFree w1 w2 = reduceWordFree (w1 ++ w2)++-- | Decides whether two words represent the same group element in the free group+equivalentFree :: Eq idx => Word idx -> Word idx -> Bool+equivalentFree w1 w2 = null $ reduceWordFree $ w1 ++ inverseWord w2++-- | Reduces a word in a free group by repeatedly removing @x*x^(-1)@ and+-- @x^(-1)*x@ pairs. The set of /reduced words/ forms the free group; the+-- multiplication is obtained by concatenation followed by reduction.+--+reduceWordFree :: Eq idx => Word idx -> Word idx+reduceWordFree = loop where++  loop w = case reduceStep w of+    Nothing -> w+    Just w' -> loop w'+  +  reduceStep :: Eq a => Word a -> Maybe (Word a)+  reduceStep = go False where    +    go !changed w = case w of+      (Gen x : Inv y : rest) | x==y   -> go True rest+      (Inv x : Gen y : rest) | x==y   -> go True rest+      (this : rest)                   -> liftM (this:) $ go changed rest+      _                               -> if changed then Just w else Nothing+++-- | Naive (but canonical) reduction algorithm for the free groups+reduceWordFreeNaive :: Eq idx => Word idx -> Word idx+reduceWordFreeNaive = loop where+  loop w = let w' = step w in if w/=w' then loop w' else w+  step   = concatMap worker . groupBy (equating genIdx) where+  worker gs +    | s>0       = replicate      s  (Gen i)+    | s<0       = replicate (abs s) (Inv i)+    | otherwise = []+    where +      i = genIdx (head gs)+      s = sum' (map genSignValue gs)++--------------------------------------------------------------------------------++-- | Counts the number of words of length @n@ which reduce to the identity element.+--+-- Generating function is @Gf_g(u) = \\frac {2g-1} { g-1 + g \\sqrt{ 1 - (8g-4)u^2 } }@+--+countIdentityWordsFree+  :: Int   -- ^ g = number of generators in the free group+  -> Int   -- ^ n = length of the unreduced word+  -> Integer+countIdentityWordsFree g n = countWordReductionsFree g n 0+  +-- | Counts the number of words of length @n@ whose reduced form has length @k@+-- (clearly @n@ and @k@ must have the same parity for this to be nonzero):+--+-- > countWordReductionsFree g n k == sum [ 1 | w <- allWords g n, k == length (reduceWordFree w) ]+--+countWordReductionsFree +  :: Int   -- ^ g = number of generators in the free group+  -> Int   -- ^ n = length of the unreduced word+  -> Int   -- ^ k = length of the reduced word+  -> Integer+countWordReductionsFree gens_ nn_ kk_+  | nn==0              = if k==0 then 1 else 0+  | even nn && kk == 0 = sum [ ( binomial (nn-i) (n  -i) * gg^(i  ) * (gg-1)^(n  -i  ) * (   i) ) `div` (nn-i) | i<-[0..n  ] ]+  | even nn && even kk = sum [ ( binomial (nn-i) (n-k-i) * gg^(i+1) * (gg-1)^(n+k-i-1) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] +  | odd  nn && odd  kk = sum [ ( binomial (nn-i) (n-k-i) * gg^(i+1) * (gg-1)^(n+k-i  ) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ]+  | otherwise          = 0  +  where+    g  = fromIntegral gens_ :: Integer+    nn = fromIntegral nn_   :: Integer+    kk = fromIntegral kk_   :: Integer+    +    gg = 2*g+    n = div nn 2+    k = div kk 2+    +--------------------------------------------------------------------------------+-- * Free powers of cyclic groups++{-# SPECIALIZE multiplyZ2 ::        Word Int -> Word Int -> Word Int #-}+{-# SPECIALIZE multiplyZ3 ::        Word Int -> Word Int -> Word Int #-}+{-# SPECIALIZE multiplyZm :: Int -> Word Int -> Word Int -> Word Int #-}++-- | Multiplication in free products of Z2's+multiplyZ2 :: Eq idx => Word idx -> Word idx -> Word idx+multiplyZ2 w1 w2 = reduceWordZ2 (w1 ++ w2)++-- | Multiplication in free products of Z3's+multiplyZ3 :: Eq idx => Word idx -> Word idx -> Word idx+multiplyZ3 w1 w2 = reduceWordZ3 (w1 ++ w2)++-- | Multiplication in free products of Zm's+multiplyZm :: Eq idx => Int -> Word idx -> Word idx -> Word idx+multiplyZm k w1 w2 = reduceWordZm k (w1 ++ w2)++--------------------------------------------------------------------------------++{-# SPECIALIZE equivalentZ2 ::        Word Int -> Word Int -> Bool #-}+{-# SPECIALIZE equivalentZ3 ::        Word Int -> Word Int -> Bool #-}+{-# SPECIALIZE equivalentZm :: Int -> Word Int -> Word Int -> Bool #-}++-- | Decides whether two words represent the same group element in free products of Z2+equivalentZ2 :: Eq idx => Word idx -> Word idx -> Bool+equivalentZ2 w1 w2 = null $ reduceWordZ2 $ w1 ++ inverseWord w2++-- | Decides whether two words represent the same group element in free products of Z3+equivalentZ3 :: Eq idx => Word idx -> Word idx -> Bool+equivalentZ3 w1 w2 = null $ reduceWordZ3 $ w1 ++ inverseWord w2++-- | Decides whether two words represent the same group element in free products of Zm+equivalentZm :: Eq idx => Int -> Word idx -> Word idx -> Bool+equivalentZm m w1 w2 = null $ reduceWordZm m $ w1 ++ inverseWord w2++--------------------------------------------------------------------------------++{-# SPECIALIZE reduceWordZ2 ::        Word Int -> Word Int #-}+{-# SPECIALIZE reduceWordZ3 ::        Word Int -> Word Int #-}+{-# SPECIALIZE reduceWordZm :: Int -> Word Int -> Word Int #-}++--------------------------------------------------------------------------------++-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^2=1@+-- (that is, free products of Z2's)+reduceWordZ2 :: Eq idx => Word idx -> Word idx+reduceWordZ2 = loop where+  loop w = case reduceStep w of+    Nothing -> w+    Just w' -> loop w'+ +  reduceStep :: Eq a => Word a -> Maybe (Word a)+  reduceStep = go False where   +    go !changed w = case w of+      (Gen x : Gen y : rest) | x==y   -> go True rest+      (Gen x : Inv y : rest) | x==y   -> go True rest+      (Inv x : Gen y : rest) | x==y   -> go True rest+      (Inv x : Inv y : rest) | x==y   -> go True rest+      (this : rest)                   -> liftM (absGen this:) $ go changed rest+      _                               -> if changed then Just w else Nothing++-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^3=1@+-- (that is, free products of Z3's)+reduceWordZ3 :: Eq idx => Word idx -> Word idx+reduceWordZ3 = loop where+  loop w = case reduceStep w of+    Nothing -> w+    Just w' -> loop w'+ +  reduceStep :: Eq a => Word a -> Maybe (Word a)+  reduceStep = go False where   +    go !changed w = case w of+      (Gen x : Inv y : rest)         | x==y           -> go True rest+      (Inv x : Gen y : rest)         | x==y           -> go True rest+      (Gen x : Gen y : Gen z : rest) | x==y && y==z   -> go True rest+      (Inv x : Inv y : Inv z : rest) | x==y && y==z   -> go True rest+      (Gen x : Gen y : rest)         | x==y           -> go True (Inv x : rest)       -- !!!+      (Inv x : Inv y : rest)         | x==y           -> go True (Gen x : rest)+      (this : rest)                                   -> liftM (this:) $ go changed rest+      _                                               -> if changed then Just w else Nothing+      +-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^m=1@+-- (that is, free products of Zm's)+reduceWordZm :: Eq idx => Int -> Word idx -> Word idx+reduceWordZm m = loop where++  loop w = case reduceStep w of+    Nothing -> w+    Just w' -> loop w'++  halfm = div m 2  -- if we encounter strictly more than m/2 equal elements in a row, we replace them by the inverses+ +  -- reduceStep :: Eq a => Word a -> Maybe (Word a)+  reduceStep = go False where   +    go !changed w = case w of+      (Gen x : Inv y : rest) | x==y                        -> go True rest+      (Inv x : Gen y : rest) | x==y                        -> go True rest+      something | Just (k,rest) <- dropIfMoreThanHalf w    -> go True (replicate (m-k) (inverseGen (head w)) ++ rest)+      (this : rest)                                        -> liftM (this:) $ go changed rest+      _                                                    -> if changed then Just w else Nothing+  +  -- dropIfMoreThanHalf :: Eq a => Word a -> Maybe (Int, Word a)+  dropIfMoreThanHalf w = +    let (!k,rest) = dropWhileEqual w +    in  if k > halfm then Just (k,rest)+                     else Nothing+                     +  -- dropWhileEqual :: Eq a => Word a -> (Int, Word a) +  dropWhileEqual []     = (0,[])+  dropWhileEqual (x0:rest) = go 1 rest where+    go !k []         = (k,[])+    go !k xxs@(x:xs) = if k==m then (m,xxs) +                               else if x==x0 then go (k+1) xs +                                             else (k,xxs)++{-  +  dropm :: Eq a => Word a -> Maybe (Word a)    +  dropm []     = Nothing+  dropm (x:xs) = go (m-1) xs where+    go 0 rest    = Just rest+    go j (y:ys)  = if y==x +      then go (j-1) ys+      else Nothing +    go j []      = Nothing+-}++--------------------------------------------------------------------------------++{-# SPECIALIZE reduceWordZ2Naive ::        Word Int -> Word Int #-}+{-# SPECIALIZE reduceWordZ3Naive ::        Word Int -> Word Int #-}+{-# SPECIALIZE reduceWordZmNaive :: Int -> Word Int -> Word Int #-}++-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^2=1@+-- (that is, free products of Z2's). Naive (but canonical) algorithm.+reduceWordZ2Naive :: Eq idx => Word idx -> Word idx+reduceWordZ2Naive = loop where+  loop w = let w' = step w in if w/=w' then loop w' else w+  step   = concatMap worker . groupBy (equating genIdx) where+  worker gs = +    case mod s 2 of+      1 -> [Gen i]+      0 -> []+      _ -> error "reduceWordZ2: fatal error, shouldn't happen"+    where +      i = genIdx (head gs)+      s = sum' (map genSignValue gs)++-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^3=1@+-- (that is, free products of Z3's). Naive (but canonical) algorithm.+reduceWordZ3Naive :: Eq idx => Word idx -> Word idx+reduceWordZ3Naive = loop where+  loop w = let w' = step w in if w/=w' then loop w' else w+  step   = concatMap worker . groupBy (equating genIdx) where+  worker gs = +    case mod s 3 of+      0 -> []+      1 -> [Gen i]+      2 -> [Inv i]+      _ -> error "reduceWordZ3: fatal error, shouldn't happen"+    where +      i = genIdx (head gs)+      s = sum' (map genSignValue gs)++-- | Reduces a word, where each generator @x@ satisfies the additional relation @x^m=1@+-- (that is, free products of Zm's). Naive (but canonical) algorithm.+reduceWordZmNaive :: Eq idx => Int -> Word idx -> Word idx+reduceWordZmNaive m = loop where+  loop w = let w' = step w in if w/=w' then loop w' else w+  step   = concatMap worker . groupBy (equating genIdx) where+  halfm1 = div (m+1) 2+  worker gs +    | mods <= halfm1  = replicate    mods  (Gen i)+    | otherwise       = replicate (m-mods) (Inv i)+    where +      i = genIdx (head gs)+      s = sum' (map genSignValue gs)+      mods = mod s m++--------------------------------------------------------------------------------++-- | Counts the number of words (without inverse generators) of length @n@ +-- which reduce to the identity element, using the relations @x^2=1@.+--+-- Generating function is @Gf_g(u) = \\frac {2g-2} { g-2 + g \\sqrt{ 1 - (4g-4)u^2 } }@+--+-- The first few @g@ cases:+--+-- > A000984 = [ countIdentityWordsZ2 2 (2*n) | n<-[0..] ] = [1,2,6,20,70,252,924,3432,12870,48620,184756...]+-- > A089022 = [ countIdentityWordsZ2 3 (2*n) | n<-[0..] ] = [1,3,15,87,543,3543,23823,163719,1143999,8099511,57959535...]+-- > A035610 = [ countIdentityWordsZ2 4 (2*n) | n<-[0..] ] = [1,4,28,232,2092,19864,195352,1970896,20275660,211823800,2240795848...]+-- > A130976 = [ countIdentityWordsZ2 5 (2*n) | n<-[0..] ] = [1,5,45,485,5725,71445,925965,12335685,167817405,2321105525,32536755565...]+--+countIdentityWordsZ2+  :: Int   -- ^ g = number of generators in the free group+  -> Int   -- ^ n = length of the unreduced word+  -> Integer+countIdentityWordsZ2 g n = countWordReductionsZ2 g n 0++-- | Counts the number of words (without inverse generators) of length @n@ whose +-- reduced form in the product of Z2-s (that is, for each generator @x@ we have @x^2=1@) +-- has length @k@+-- (clearly @n@ and @k@ must have the same parity for this to be nonzero):+--+-- > countWordReductionsZ2 g n k == sum [ 1 | w <- allWordsNoInv g n, k == length (reduceWordZ2 w) ]+--+countWordReductionsZ2 +  :: Int   -- ^ g = number of generators in the free group+  -> Int   -- ^ n = length of the unreduced word+  -> Int   -- ^ k = length of the reduced word+  -> Integer+countWordReductionsZ2 gens_ nn_ kk_+  | nn==0              = if k==0 then 1 else 0+  | even nn && kk == 0 = sum [ ( binomial (nn-i) (n  -i) * g^(i  ) * (g-1)^(n  -i  ) * (   i) ) `div` (nn-i) | i<-[0..n  ] ]+  | even nn && even kk = sum [ ( binomial (nn-i) (n-k-i) * g^(i+1) * (g-1)^(n+k-i-1) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ] +  | odd  nn && odd  kk = sum [ ( binomial (nn-i) (n-k-i) * g^(i+1) * (g-1)^(n+k-i  ) * (kk+i) ) `div` (nn-i) | i<-[0..n-k] ]+  | otherwise          = 0  +  where+    g  = fromIntegral gens_ :: Integer+    nn = fromIntegral nn_   :: Integer+    kk = fromIntegral kk_   :: Integer+    +    n = div nn 2+    k = div kk 2++-- | Counts the number of words (without inverse generators) of length @n@ +-- which reduce to the identity element, using the relations @x^3=1@.+--+-- > countIdentityWordsZ3NoInv g n == sum [ 1 | w <- allWordsNoInv g n, 0 == length (reduceWordZ2 w) ]+--+-- In mathematica, the formula is: @Sum[ g^k * (g-1)^(n-k) * k/n * Binomial[3*n-k-1, n-k] , {k, 1,n} ]@+--+countIdentityWordsZ3NoInv+  :: Int   -- ^ g = number of generators in the free group+  -> Int   -- ^ n = length of the unreduced word+  -> Integer+countIdentityWordsZ3NoInv gens_ nn_ +  | nn==0           = 1+  | mod nn 3 == 0   = sum [ ( binomial (3*n-i-1) (n-i) * g^i * (g-1)^(n-i) * i ) `div` n | i<-[1..n] ]+  | otherwise       = 0+  where+    g  = fromIntegral gens_ :: Integer+    nn = fromIntegral nn_   :: Integer+    +    n = div nn 3+  +--------------------------------------------------------------------------------+      +{-++-- some basic testing. TODO: real tests++import Math.Combinat.Helper+import Math.Combinat.Groups.Free++g    = 3 :: Int+maxn = 8 :: Int++bad_free = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordFree w `equivalentFree` reduceWordFreeNaive w) ]+bad_z2   = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordZ2   w `equivalentZ2`   reduceWordZ2Naive   w) ]+bad_z3   = [ w | n<-[0..maxn] , w <- allWords g n , not (reduceWordZ3   w `equivalentZ3`   reduceWordZ3Naive   w) ]+bad_zm m = [ w | n<-[0..maxn] , w <- allWords g n , not (equivalentZm m (reduceWordZm m w) (reduceWordZmNaive m w)) ]++speed_free = sum' [ length (reduceWordFree w) | n<-[0..maxn] , w <- allWords g n ]+speed_z2   = sum' [ length (reduceWordZ2   w) | n<-[0..maxn] , w <- allWords g n ]+speed_z3   = sum' [ length (reduceWordZ3   w) | n<-[0..maxn] , w <- allWords g n ]+speed_zm m = sum' [ length (reduceWordZm m w) | n<-[0..maxn] , w <- allWords g n ]++naive_speed_free = sum' [ length (reduceWordFreeNaive w) | n<-[0..maxn] , w <- allWords g n ]+naive_speed_z2   = sum' [ length (reduceWordZ2Naive   w) | n<-[0..maxn] , w <- allWords g n ]+naive_speed_z3   = sum' [ length (reduceWordZ3Naive   w) | n<-[0..maxn] , w <- allWords g n ]+naive_speed_zm m = sum' [ length (reduceWordZmNaive m w) | n<-[0..maxn] , w <- allWords g n ]++-}++--------------------------------------------------------------------------------++
+ src/Math/Combinat/Groups/Thompson/F.hs view
@@ -0,0 +1,404 @@++-- | Thompson's group F.+--+-- See eg. <https://en.wikipedia.org/wiki/Thompson_groups>+--+-- Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\";+-- see <http://www.math.u-psud.fr/~breuilla/Belk.pdf>+--++{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-}+module Math.Combinat.Groups.Thompson.F where++--------------------------------------------------------------------------------++import Data.List++import Math.Combinat.Classes+import Math.Combinat.ASCII++import Math.Combinat.Trees.Binary ( BinTree )+import qualified Math.Combinat.Trees.Binary as B++--------------------------------------------------------------------------------+-- * Tree diagrams++-- | A tree diagram, consisting of two binary trees with the same number of leaves, +-- representing an element of the group F.+data TDiag = TDiag +  { _width  :: !Int      -- ^ the width is the number of leaves, minus 1, of both diagrams+  , _domain :: !T        -- ^ the top diagram correspond to the /domain/+  , _range  :: !T        -- ^ the bottom diagram corresponds to the /range/+  }+  deriving (Eq,Ord,Show)++instance DrawASCII TDiag where+  ascii = asciiTDiag++instance HasWidth TDiag where+  width = _width++-- | Creates a tree diagram from two trees+mkTDiag :: T -> T -> TDiag +mkTDiag d1 d2 = reduce $ mkTDiagDontReduce d1 d2++-- | Creates a tree diagram, but does not reduce it.+mkTDiagDontReduce :: T -> T -> TDiag +mkTDiagDontReduce top bot = +  if w1 == w2 +    then TDiag w1 top bot +    else error "mkTDiag: widths do not match"+  where+    w1 = treeWidth top +    w2 = treeWidth bot+++isValidTDiag :: TDiag -> Bool+isValidTDiag (TDiag w top bot) = (treeWidth top == w && treeWidth bot == w)++isPositive :: TDiag -> Bool+isPositive (TDiag w top bot) = (bot == rightVine w)++isReduced :: TDiag -> Bool+isReduced diag = (reduce diag == diag)++-- | The generator x0+x0 :: TDiag+x0 = TDiag 2 top bot where+  top = branch caret leaf+  bot = branch leaf  caret++-- | The generator x1+x1 :: TDiag+x1 = xk 1++-- | The generators x0, x1, x2 ...+xk :: Int -> TDiag+xk = go where+  go k | k< 0      = error "xk: negative indexed generator"+       | k==0      = x0+       | otherwise = let TDiag _ t b = go (k-1) +                     in  TDiag (k+2) (branch leaf t) (branch leaf b)++-- | The identity element in the group F                     +identity :: TDiag+identity = TDiag 0 Lf Lf++-- | A /positive diagram/ is a diagram whose bottom tree (the range) is a right vine.+positive :: T -> TDiag+positive t = TDiag w t (rightVine w) where w = treeWidth t++-- | Swaps the top and bottom of a tree diagram. This is the inverse in the group F.+-- (Note: we don't do reduction here, as this operation keeps the reducedness)+inverse :: TDiag -> TDiag+inverse (TDiag w top bot) = TDiag w bot top++-- | Decides whether two (possibly unreduced) tree diagrams represents the same group element in F.+equivalent :: TDiag -> TDiag -> Bool+equivalent diag1 diag2 = (identity == reduce (compose diag1 (inverse diag2)))++--------------------------------------------------------------------------------+-- * Reduction of tree diagrams++-- | Reduces a diagram. The result is a normal form of an element in the group F.+reduce :: TDiag -> TDiag+reduce = worker where++  worker :: TDiag -> TDiag+  worker diag = case step diag of+    Nothing    -> diag+    Just diag' -> worker diag'++  step :: TDiag -> Maybe TDiag+  step (TDiag w top bot) = +    if null idxs +      then Nothing+      else Just $ TDiag w' top' bot'+    where+      cs1  = treeCaretList top+      cs2  = treeCaretList bot+      idxs = sortedIntersect cs1 cs2+      w'   = w - length idxs+      top' = removeCarets idxs top+      bot' = removeCarets idxs bot++  -- | Intersects sorted lists      +  sortedIntersect :: [Int] -> [Int] -> [Int]+  sortedIntersect = go where+    go [] _  = []+    go _  [] = []+    go xxs@(x:xs) yys@(y:ys) = case compare x y of+      LT ->     go  xs yys+      EQ -> x : go  xs  ys+      GT ->     go xxs  ys++-- | List of carets at the bottom of the tree, indexed by their left edge position+treeCaretList :: T -> [Int]+treeCaretList = snd . go 0 where+  go !x t = case t of +    Lf        ->  (x+1 , []  )+    Ct        ->  (x+2 , [x] )+    Br t1 t2  ->  (x2  , cs1++cs2) where+      (x1 , cs1) = go x  t1+      (x2 , cs2) = go x1 t2++-- | Remove the carets with the given indices +-- (throws an error if there is no caret at the given index)+removeCarets :: [Int] -> T -> T+removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where++  (_,rem,final) =  go 0 idxs tree where++  go :: Int -> [Int] -> T -> (Int,[Int],T)+  go !x []         t  = (x + treeWidth t , [] , t)+  go !x iis@(i:is) t  = case t of+    Lf        ->  (x+1 , iis , t)+    Ct        ->  if x==i then (x+2 , is , Lf) else (x+2 , iis , Ct)+    Br t1 t2  ->  (x2  , iis2 , Br t1' t2') where+      (x1 , iis1 , t1') = go x  iis  t1+      (x2 , iis2 , t2') = go x1 iis1 t2+      +--------------------------------------------------------------------------------+-- * Composition of tree diagrams++-- | If @diag1@ corresponds to the PL function @f@, and @diag2@ to @g@, then @compose diag1 diag2@ +-- will correspond to @(g.f)@ (note that the order is opposite than normal function composition!)+--+-- This is the multiplication in the group F.+--+compose :: TDiag -> TDiag -> TDiag+compose d1 d2 = reduce (composeDontReduce d1 d2)++-- | Compose two tree diagrams without reducing the result+composeDontReduce :: TDiag -> TDiag -> TDiag+composeDontReduce (TDiag w1 top1 bot1) (TDiag w2 top2 bot2) = new where+  new = mkTDiagDontReduce top' bot' +  (list1,list2) = extensionToCommonTree bot1 top2+  top' = listGraft list1 top1+  bot' = listGraft list2 bot2++-- | Given two binary trees, we return a pair of list of subtrees which, grafted the to leaves of+-- the first (resp. the second) tree, results in the same extended tree.+extensionToCommonTree :: T -> T -> ([T],[T])+extensionToCommonTree t1 t2 = snd $ go (0,0) (t1,t2) where+  go (!x1,!x2) (!t1,!t2) = +    case (t1,t2) of+      ( Lf       , Lf       ) -> ( (x1+n1 , x2+n2 ) , (             [Lf] ,             [Lf] ) )+      ( Lf       , Br _  _  ) -> ( (x1+n1 , x2+n2 ) , (             [t2] , replicate n2 Lf  ) )+      ( Br _  _  , Lf       ) -> ( (x1+n1 , x2+n2 ) , ( replicate n1 Lf  ,             [t1] ) )+      ( Br l1 r1 , Br l2 r2 ) +        -> let ( (x1' ,x2' ) , (ps1,ps2) ) = go (x1 ,x2 ) (l1,l2)+               ( (x1'',x2'') , (qs1,qs2) ) = go (x1',x2') (r1,r2)+           in  ( (x1'',x2'') , (ps1++qs1, ps2++qs2) )+    where+      n1 = numberOfLeaves t1+      n2 = numberOfLeaves t2++--------------------------------------------------------------------------------+-- * Subdivions++-- | Returns the list of dyadic subdivision points+subdivision1 :: T -> [Rational]+subdivision1 = go 0 1 where+  go !a !b t = case t of+    Leaf   _   -> [a,b]+    Branch l r -> go a c l ++ tail (go c b r) where c = (a+b)/2++-- | Returns the list of dyadic intervals+subdivision2 :: T -> [(Rational,Rational)]+subdivision2 = go 0 1 where+  go !a !b t = case t of+    Leaf   _   -> [(a,b)]+    Branch l r -> go a c l ++ go c b r where c = (a+b)/2+++--------------------------------------------------------------------------------+-- * Binary trees++-- | A (strict) binary tree with labelled leaves (but unlabelled nodes)+data Tree a+  = Branch !(Tree a) !(Tree a)+  | Leaf   !a+  deriving (Eq,Ord,Show,Functor)++-- | The monadic join operation of binary trees+graft :: Tree (Tree a) -> Tree a+graft = go where+  go (Branch l r) = Branch (go l) (go r)+  go (Leaf   t  ) = t ++-- | A list version of 'graft'+listGraft :: [Tree a] -> Tree b -> Tree a+listGraft subs big = snd $ go subs big where  +  go ggs@(g:gs) t = case t of+    Leaf   _   -> (gs,g)+    Branch l r -> (gs2, Branch l' r') where+                    (gs1,l') = go ggs l+                    (gs2,r') = go gs1 r++-- | A completely unlabelled binary tree+type T = Tree ()++instance DrawASCII T where+  ascii = asciiT ++instance HasNumberOfLeaves (Tree a) where+  numberOfLeaves = treeNumberOfLeaves++instance HasWidth (Tree a) where+  width = treeWidth++leaf :: T+leaf = Leaf ()++branch :: T -> T -> T+branch = Branch++caret :: T+caret = branch leaf leaf++treeNumberOfLeaves :: Tree a -> Int+treeNumberOfLeaves = go where+  go (Branch l r) = go l + go r+  go (Leaf   _  ) = 1  ++-- | The width of the tree is the number of leaves minus 1.+treeWidth :: Tree a -> Int+treeWidth t = numberOfLeaves t - 1++-- | Enumerates the leaves a tree, starting from 0+enumerate_ :: Tree a -> Tree Int+enumerate_ = snd . enumerate++-- | Enumerates the leaves a tree, and also returns the number of leaves+enumerate :: Tree a -> (Int, Tree Int)+enumerate = go 0 where+  go !k t = case t of+    Leaf   _   -> (k+1 , Leaf k)+    Branch l r -> let (k' ,l') = go k  l+                      (k'',r') = go k' r+                  in (k'', Branch l' r') ++-- | \"Right vine\" of the given width +rightVine :: Int -> T+rightVine k +  | k< 0      = error "rightVine: negative width"+  | k==0      = leaf+  | otherwise = branch leaf (rightVine (k-1))++-- | \"Left vine\" of the given width +leftVine :: Int -> T+leftVine k +  | k< 0      = error "leftVine: negative width"+  | k==0      = leaf+  | otherwise = branch (leftVine (k-1)) leaf ++-- | Flips each node of a binary tree+flipTree :: Tree a -> Tree a+flipTree = go where+  go t = case t of+    Leaf   _   -> t+    Branch l r -> Branch (go r) (go l)++--------------------------------------------------------------------------------+-- * Conversion to\/from BinTree++-- | 'Tree' and 'BinTree' are the same type, except that 'Tree' is strict.+--+-- TODO: maybe unify these two types? Until that, you can convert between the two+-- with these functions if necessary.+--+toBinTree :: Tree a -> B.BinTree a+toBinTree = go where+  go (Branch l r) = B.Branch (go l) (go r)+  go (Leaf   y  ) = B.Leaf   y++fromBinTree :: B.BinTree a -> Tree a +fromBinTree = go where+  go (B.Branch l r) = Branch (go l) (go r)+  go (B.Leaf   y  ) = Leaf   y+    +--------------------------------------------------------------------------------+-- * Pattern synonyms++pattern Lf     = Leaf ()+pattern Br l r = Branch l r+pattern Ct     = Br Lf Lf+pattern X0     = TDiag 2        (Br Ct Lf)         (Br Lf Ct)+pattern X1     = TDiag 3 (Br Lf (Br Ct Lf)) (Br Lf (Br Lf Ct))++--------------------------------------------------------------------------------+-- * ASCII++-- | Draws a binary tree, with all leaves at the same (bottom) row+asciiT :: T -> ASCII+asciiT = asciiT' False++-- | Draws a binary tree; when the boolean flag is @True@, we draw upside down+asciiT' :: Bool -> T -> ASCII+asciiT' inv = go where++  go t = case t of+    Leaf _                   -> emptyRect +    Branch l r -> +      if yl >= yr+        then pasteOnto (yl+yr+1,if inv then yr else 0) (rs $ yl+1) $ +               vcat HCenter +                 (bc $ yr+1) +                 (hcat bot al ar)+        else pasteOnto (yl, if inv then yl else 0) (ls $ yr+1) $+               vcat HCenter +                 (bc $ yl+1) +                 (hcat bot al ar)+      where+        al = go l+        ar = go r+        yl = asciiYSize al +        yr = asciiYSize ar ++  bot = if inv then VTop else VBottom+  hcat align p q = hCatWith align (HSepString "  ") [p,q]+  vcat align p q = vCatWith align VSepEmpty $ if inv then [q,p] else [p,q]+  bc = if inv then asciiBigInvCaret   else asciiBigCaret+  ls = if inv then asciiBigRightSlope else asciiBigLeftSlope+  rs = if inv then asciiBigLeftSlope  else asciiBigRightSlope++  asciiBigCaret :: Int -> ASCII+  asciiBigCaret k = hCatWith VTop HSepEmpty [ asciiBigLeftSlope k , asciiBigRightSlope k ]++  asciiBigInvCaret :: Int -> ASCII+  asciiBigInvCaret k = hCatWith VTop HSepEmpty [ asciiBigRightSlope k , asciiBigLeftSlope k ]++  asciiBigLeftSlope :: Int -> ASCII  +  asciiBigLeftSlope k = if k>0 +    then asciiFromLines [ replicate l ' ' ++ "/" | l<-[k-1,k-2..0] ]+    else emptyRect++  asciiBigRightSlope :: Int -> ASCII  +  asciiBigRightSlope k = if k>0 +    then asciiFromLines [ replicate l ' ' ++ "\\" | l<-[0..k-1] ]+    else emptyRect+  +-- | Draws a binary tree, with all leaves at the same (bottom) row, and labelling+-- the leaves starting with 0 (continuing with letters after 9)+asciiTLabels :: T -> ASCII+asciiTLabels = asciiTLabels' False++-- | When the flag is true, we draw upside down+asciiTLabels' :: Bool -> T -> ASCII+asciiTLabels' inv t = +  if inv +    then vCatWith HLeft VSepEmpty [ labels , asciiT' inv t ]+    else vCatWith HLeft VSepEmpty [ asciiT' inv t , labels ]+  where+    w = treeWidth t+    labels = asciiFromString $ intersperse ' ' $ take (w+1) allLabels+    allLabels = ['0'..'9'] ++ ['a'..'z']+    +-- | Draws a tree diagram+asciiTDiag :: TDiag -> ASCII+asciiTDiag (TDiag _ top bot) = vCatWith HLeft (VSepString " ") [asciiT' False top , asciiT' True bot]++--------------------------------------------------------------------------------++
+ src/Math/Combinat/Helper.hs view
@@ -0,0 +1,329 @@++-- | Miscellaneous helper functions used internally++{-# LANGUAGE BangPatterns, PolyKinds, GeneralizedNewtypeDeriving #-}+module Math.Combinat.Helper where++--------------------------------------------------------------------------------++import Control.Monad+import Control.Applicative ( Applicative(..) )    -- required before AMP (before GHC 7.10)+import Data.Functor.Identity++import Data.List+import Data.Ord+import Data.Proxy++import Data.Set (Set) ; import qualified Data.Set as Set+import Data.Map (Map) ; import qualified Data.Map as Map++import Debug.Trace++import System.Random+import Control.Monad.Trans.State++--------------------------------------------------------------------------------+-- * debugging++debug :: Show a => a -> b -> b+debug x y = trace ("-- " ++ show x ++ "\n") y++--------------------------------------------------------------------------------+-- * pairs++swap :: (a,b) -> (b,a)+swap (x,y) = (y,x)++pairs :: [a] -> [(a,a)]+pairs = go where+  go (x:xs@(y:_)) = (x,y) : go xs+  go _            = []++pairsWith :: (a -> a -> b) -> [a] -> [b]+pairsWith f = go where+  go (x:xs@(y:_)) = f x y : go xs+  go _            = []++--------------------------------------------------------------------------------+-- * lists++{-# SPECIALIZE sum' :: [Int]     -> Int     #-}+{-# SPECIALIZE sum' :: [Integer] -> Integer #-}+sum' :: Num a => [a] -> a+sum' = foldl' (+) 0++interleave :: [a] -> [a] -> [a]+interleave (x:xs) (y:ys) = x : y : interleave xs ys+interleave [x]    []     = x : []+interleave []     []     = []+interleave _      _      = error "interleave: shouldn't happen"++evens, odds :: [a] -> [a] +evens (x:xs) = x : odds xs+evens [] = []+odds (x:xs) = evens xs+odds [] = []++--------------------------------------------------------------------------------+-- * multiplication++-- | Product of list of integers, but in interleaved order (for a list of big numbers,+-- it should be faster than the linear order)+productInterleaved :: [Integer] -> Integer+productInterleaved = go where+  go []    = 1+  go [x]   = x+  go [x,y] = x*y+  go list  = go (evens list) * go (odds list)++-- | Faster implementation of @product [ i | i <- [a+1..b] ]@+productFromTo :: Integral a => a -> a -> Integer+productFromTo = go where+  go !a !b +    | dif < 1     = 1+    | dif < 5     = product [ fromIntegral i | i<-[a+1..b] ]+    | otherwise   = go a half * go half b+    where+      dif  = b - a+      half = div (a+b+1) 2++-- | Faster implementation of product @[ i | i <- [a+1,a+3,..b] ]@+productFromToStride2 :: Integral a => a -> a -> Integer+productFromToStride2 = go where+  go !a !b +    | dif < 1     = 1+    | dif < 9     = product [ fromIntegral i | i<-[a+1,a+3..b] ]+    | otherwise   = go a half * go half b+    where+      dif  = b - a+      half = a + 2*(div dif 4)++--------------------------------------------------------------------------------+-- * equality and ordering ++equating :: Eq b => (a -> b) -> a -> a -> Bool+equating f x y = (f x == f y)++reverseOrdering :: Ordering -> Ordering+reverseOrdering LT = GT+reverseOrdering GT = LT+reverseOrdering EQ = EQ++reverseComparing :: Ord b => (a -> b) -> a -> a -> Ordering+reverseComparing f x y = compare (f y) (f x)++reverseCompare :: Ord a => a -> a -> Ordering+reverseCompare x y = compare y x   -- reverseOrdering $ compare x y++reverseSort :: Ord a => [a] -> [a]+reverseSort = sortBy reverseCompare++groupSortBy :: (Eq b, Ord b) => (a -> b) -> [a] -> [[a]]+groupSortBy f = groupBy (equating f) . sortBy (comparing f) ++nubOrd :: Ord a => [a] -> [a]+nubOrd = worker Set.empty where+  worker _ [] = []+  worker s (x:xs) +    | Set.member x s = worker s xs+    | otherwise      = x : worker (Set.insert x s) xs++--------------------------------------------------------------------------------+-- * increasing \/ decreasing sequences++{-# SPECIALIZE isWeaklyIncreasing :: [Int] -> Bool #-}+isWeaklyIncreasing :: Ord a => [a] -> Bool+isWeaklyIncreasing = go where+  go xs = case xs of +    (a:rest@(b:_)) -> a <= b && go rest+    [_]            -> True+    []             -> True++{-# SPECIALIZE isStrictlyIncreasing :: [Int] -> Bool #-}+isStrictlyIncreasing :: Ord a => [a] -> Bool+isStrictlyIncreasing = go where+  go xs = case xs of +    (a:rest@(b:_)) -> a < b && go rest+    [_]            -> True+    []             -> True++{-# SPECIALIZE isWeaklyDecreasing :: [Int] -> Bool #-}+isWeaklyDecreasing :: Ord a => [a] -> Bool+isWeaklyDecreasing = go where+  go xs = case xs of +    (a:rest@(b:_)) -> a >= b && go rest+    [_]            -> True+    []             -> True++{-# SPECIALIZE isStrictlyDecreasing :: [Int] -> Bool #-}+isStrictlyDecreasing :: Ord a => [a] -> Bool+isStrictlyDecreasing = go where+  go xs = case xs of +    (a:rest@(b:_)) -> a > b && go rest+    [_]            -> True+    []             -> True++--------------------------------------------------------------------------------+-- * first \/ last ++-- | The boolean argument will @True@ only for the last element+mapWithLast :: (Bool -> a -> b) -> [a] -> [b]+mapWithLast f = go where+  go (x : []) = f True  x : []+  go (x : xs) = f False x : go xs++mapWithFirst :: (Bool -> a -> b) -> [a] -> [b]+mapWithFirst f = go True where+  go b (x:xs) = f b x : go False xs +  +mapWithFirstLast :: (Bool -> Bool -> a -> b) -> [a] -> [b]+mapWithFirstLast f = go True where+  go b (x : []) = f b True  x : []+  go b (x : xs) = f b False x : go False xs++--------------------------------------------------------------------------------+-- * older helpers for ASCII drawing++-- | extend lines with spaces so that they have the same line+mkLinesUniformWidth :: [String] -> [String]+mkLinesUniformWidth old = zipWith worker ls old where+  ls = map length old+  m  = maximum ls+  worker l s = s ++ replicate (m-l) ' '++mkBlocksUniformHeight :: [[String]] -> [[String]]+mkBlocksUniformHeight old = zipWith worker ls old where+  ls = map length old+  m  = maximum ls+  worker l s = s ++ replicate (m-l) ""+    +mkUniformBlocks :: [[String]] -> [[String]] +mkUniformBlocks = map mkLinesUniformWidth . mkBlocksUniformHeight+    +hConcatLines :: [[String]] -> [String]+hConcatLines = map concat . transpose . mkUniformBlocks++vConcatLines :: [[String]] -> [String]  +vConcatLines = concat++--------------------------------------------------------------------------------+-- * counting++-- helps testing the random rutines +count :: Eq a => a -> [a] -> Int+count x xs = length $ filter (==x) xs++histogram :: (Eq a, Ord a) => [a] -> [(a,Int)]+histogram xs = Map.toList table where+  table = Map.fromListWith (+) [ (x,1) | x<-xs ] ++--------------------------------------------------------------------------------+-- * maybe++fromJust :: Maybe a -> a+fromJust (Just x) = x+fromJust Nothing = error "fromJust: Nothing"++--------------------------------------------------------------------------------+-- * bool++intToBool :: Int -> Bool+intToBool 0 = False+intToBool 1 = True+intToBool _ = error "intToBool"++boolToInt :: Bool -> Int +boolToInt False = 0+boolToInt True  = 1++--------------------------------------------------------------------------------+-- * iteration+    +-- iterated function application+nest :: Int -> (a -> a) -> a -> a+nest !0 _ x = x+nest !n f x = nest (n-1) f (f x)++unfold1 :: (a -> Maybe a) -> a -> [a]+unfold1 f x = case f x of +  Nothing -> [x] +  Just y  -> x : unfold1 f y +  +unfold :: (b -> (a,Maybe b)) -> b -> [a]+unfold f y = let (x,m) = f y in case m of +  Nothing -> [x]+  Just y' -> x : unfold f y'++unfoldEither :: (b -> Either c (b,a)) -> b -> (c,[a])+unfoldEither f y = case f y of+  Left z -> (z,[])+  Right (y,x) -> let (z,xs) = unfoldEither f y in (z,x:xs)+  +unfoldM :: Monad m => (b -> m (a,Maybe b)) -> b -> m [a]+unfoldM f y = do+  (x,m) <- f y+  case m of+    Nothing -> return [x]+    Just y' -> do+      xs <- unfoldM f y'+      return (x:xs)++mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])+mapAccumM _ s [] = return (s, [])+mapAccumM f s (x:xs) = do+  (s1,y) <- f s x+  (s2,ys) <- mapAccumM f s1 xs+  return (s2, y:ys)++--------------------------------------------------------------------------------+-- * long zipwith    ++longZipWith :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]+longZipWith a0 b0 f = go where+  go (x:xs) (y:ys)  =   f x  y : go xs ys+  go []     ys      = [ f a0 y | y<-ys ]+  go xs     []      = [ f x b0 | x<-xs ]++{-+longZipWithZero :: (Num a, Num b) => (a -> b -> c) -> [a] -> [b] -> [c]+longZipWithZero = longZipWith 0 0 +-}++--------------------------------------------------------------------------------+-- * random++-- | A simple random monad to make life suck less+type Rand g = RandT g Identity++runRand :: Rand g a -> g -> (a,g)+runRand action g = runIdentity (runRandT action g)++flipRunRand :: Rand s a -> s -> (s,a)+flipRunRand action g = runIdentity (flipRunRandT action g)+++-- | The Rand monad transformer+newtype RandT g m a = RandT (StateT g m a) deriving (Functor,Applicative,Monad)++runRandT :: RandT g m a -> g -> m (a,g)+runRandT (RandT stuff) = runStateT stuff++-- | This may be occasionally useful+flipRunRandT :: Monad m => RandT s m a -> s -> m (s,a)+flipRunRandT action ini = liftM swap $ runRandT action ini+++-- | Puts a standard-conforming random function into the monad+rand :: (g -> (a,g)) -> Rand g a+rand user = RandT (state user)++randRoll :: (RandomGen g, Random a) => Rand g a+randRoll = rand random++randChoose :: (RandomGen g, Random a) => (a,a) -> Rand g a+randChoose uv = rand (randomR uv)++randProxy1 :: Rand g (f n) -> Proxy n -> Rand g (f n)+randProxy1 action _ = action++--------------------------------------------------------------------------------
+ src/Math/Combinat/LatticePaths.hs view
@@ -0,0 +1,386 @@++-- | Dyck paths, lattice paths, etc+--+-- For example, the following figure represents a Dyck path of height 5 with 3 zero-touches (not counting the starting point,+-- but counting the endpoint) and 7 peaks:+--+-- <<svg/dyck_path.svg>>+--++{-# LANGUAGE BangPatterns, FlexibleInstances, TypeSynonymInstances #-}+module Math.Combinat.LatticePaths where++--------------------------------------------------------------------------------++import Data.List+import System.Random++import Math.Combinat.Classes+import Math.Combinat.Numbers+import Math.Combinat.Trees.Binary+import Math.Combinat.ASCII as ASCII++--------------------------------------------------------------------------------+-- * Types++-- | A step in a lattice path+data Step +  = UpStep         -- ^ the step @(1,1)@+  | DownStep       -- ^ the step @(1,-1)@+  deriving (Eq,Ord,Show)++-- | A lattice path is a path using only the allowed steps, never going below the zero level line @y=0@. +--+-- Note that if you rotate such a path by 45 degrees counterclockwise,+-- you get a path which uses only the steps @(1,0)@ and @(0,1)@, and stays+-- above the main diagonal (hence the name, we just use a different convention).+--+type LatticePath = [Step]++--------------------------------------------------------------------------------+-- * ascii drawing of paths++-- | Draws the path into a list of lines. For example try:+--+-- > autotabulate RowMajor (Right 5) (map asciiPath $ dyckPaths 4)+--+asciiPath :: LatticePath -> ASCII+asciiPath p = asciiFromLines $ transpose (go 0 p) where++  go !h [] = []+  go !h (x:xs) = case x of+    UpStep   -> ee  h    x : go (h+1) xs+    DownStep -> ee (h-1) x : go (h-1) xs++  maxh   = pathHeight p++  ee h x = replicate (maxh-h-1) ' ' ++ [ch x] ++ replicate h ' '+  ch x   = case x of +    UpStep   -> '/' +    DownStep -> '\\' ++instance DrawASCII LatticePath where +  ascii = asciiPath++--------------------------------------------------------------------------------+-- * elementary queries++-- | A lattice path is called \"valid\", if it never goes below the @y=0@ line.+isValidPath :: LatticePath -> Bool+isValidPath = go 0 where+  go :: Int -> LatticePath -> Bool+  go !y []     = y>=0+  go !y (t:ts) = let y' = case t of { UpStep -> y+1 ; DownStep -> y-1 }+                 in  if y'<0 then False +                             else go y' ts++-- | A Dyck path is a lattice path whose last point lies on the @y=0@ line+isDyckPath :: LatticePath -> Bool+isDyckPath = go 0 where+  go :: Int -> LatticePath -> Bool+  go !y []     = y==0+  go !y (t:ts) = let y' = case t of { UpStep -> y+1 ; DownStep -> y-1 }+                 in  if y'<0 then False +                             else go y' ts++-- | Maximal height of a lattice path+pathHeight :: LatticePath -> Int+pathHeight = go 0 0 where+  go :: Int -> Int -> LatticePath -> Int+  go !h !y []     = h+  go !h !y (t:ts) = case t of+    UpStep   -> go (max h (y+1)) (y+1) ts+    DownStep -> go      h        (y-1) ts++instance HasHeight LatticePath where+  height = pathHeight++instance HasWidth LatticePath where+  width = length++-- | Endpoint of a lattice path, which starts from @(0,0)@.+pathEndpoint :: LatticePath -> (Int,Int)+pathEndpoint = go 0 0 where+  go :: Int -> Int -> LatticePath -> (Int,Int)+  go !x !y []     = (x,y)+  go !x !y (t:ts) = case t of                         +    UpStep   -> go (x+1) (y+1) ts+    DownStep -> go (x+1) (y-1) ts++-- | Returns the coordinates of the path (excluding the starting point @(0,0)@, but including+-- the endpoint)+pathCoordinates :: LatticePath -> [(Int,Int)]+pathCoordinates = go 0 0 where+  go :: Int -> Int -> LatticePath -> [(Int,Int)]+  go _  _  []     = []+  go !x !y (t:ts) = let x' = x + 1+                        y' = case t of { UpStep -> y+1 ; DownStep -> y-1 }+                    in  (x',y') : go x' y' ts++-- | Counts the up-steps+pathNumberOfUpSteps :: LatticePath -> Int+pathNumberOfUpSteps   = fst . pathNumberOfUpDownSteps++-- | Counts the down-steps+pathNumberOfDownSteps :: LatticePath -> Int+pathNumberOfDownSteps = snd . pathNumberOfUpDownSteps++-- | Counts both the up-steps and down-steps+pathNumberOfUpDownSteps :: LatticePath -> (Int,Int)+pathNumberOfUpDownSteps = go 0 0 where +  go :: Int -> Int -> LatticePath -> (Int,Int)+  go !u !d (p:ps) = case p of +    UpStep   -> go (u+1)  d    ps  +    DownStep -> go  u    (d+1) ps    +  go !u !d []     = (u,d)++--------------------------------------------------------------------------------+-- * path-specific queries++-- | Number of peaks of a path (excluding the endpoint)+pathNumberOfPeaks :: LatticePath -> Int+pathNumberOfPeaks = go 0 where+  go :: Int -> LatticePath -> Int+  go !k (x:xs@(y:_)) = go (if x==UpStep && y==DownStep then k+1 else k) xs+  go !k [x] = k+  go !k [ ] = k++-- | Number of points on the path which touch the @y=0@ zero level line+-- (excluding the starting point @(0,0)@, but including the endpoint; that is, for Dyck paths it this is always positive!).+pathNumberOfZeroTouches :: LatticePath -> Int+pathNumberOfZeroTouches = pathNumberOfTouches' 0++-- | Number of points on the path which touch the level line at height @h@+-- (excluding the starting point @(0,0)@, but including the endpoint).+pathNumberOfTouches' +  :: Int       -- ^ @h@ = the touch level+  -> LatticePath -> Int+pathNumberOfTouches' h = go 0 0 0 where+  go :: Int -> Int -> Int -> LatticePath -> Int+  go !cnt _  _  []     = cnt+  go !cnt !x !y (t:ts) = let y'   = case t of { UpStep -> y+1 ; DownStep -> y-1 }+                             cnt' = if y'==h then cnt+1 else cnt+                         in  go cnt' (x+1) y' ts++--------------------------------------------------------------------------------+-- * Dyck paths++-- | @dyckPaths m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@. +-- +-- Remark: Dyck paths are obviously in bijection with nested parentheses, and thus+-- also with binary trees.+--+-- Order is reverse lexicographical:+--+-- > sort (dyckPaths m) == reverse (dyckPaths m)+-- +dyckPaths :: Int -> [LatticePath]+dyckPaths = map nestedParensToDyckPath . nestedParentheses ++-- | @dyckPaths m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@. +--+-- > sort (dyckPathsNaive m) == sort (dyckPaths m) +--  +-- Naive recursive algorithm, order is ad-hoc+--+dyckPathsNaive :: Int -> [LatticePath]+dyckPathsNaive = worker where+  worker  0 = [[]]+  worker  m = as ++ bs where+    as = [ bracket p      | p <- worker (m-1) ] +    bs = [ bracket p ++ q | k <- [1..m-1] , p <- worker (k-1) , q <- worker (m-k) ]+  bracket p = UpStep : p ++ [DownStep]++-- | The number of Dyck paths from @(0,0)@ to @(2m,0)@ is simply the m\'th Catalan number.+countDyckPaths :: Int -> Integer+countDyckPaths m = catalan m++-- | The trivial bijection+nestedParensToDyckPath :: [Paren] -> LatticePath+nestedParensToDyckPath = map f where+  f p = case p of { LeftParen -> UpStep ; RightParen -> DownStep }++-- | The trivial bijection in the other direction+dyckPathToNestedParens :: LatticePath -> [Paren]+dyckPathToNestedParens = map g where+  g s = case s of { UpStep -> LeftParen ; DownStep -> RightParen }++--------------------------------------------------------------------------------+-- * Bounded Dyck paths++-- | @boundedDyckPaths h m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ whose height is at most @h@.+-- Synonym for 'boundedDyckPathsNaive'.+--+boundedDyckPaths+  :: Int   -- ^ @h@ = maximum height+  -> Int   -- ^ @m@ = half-length+  -> [LatticePath]+boundedDyckPaths = boundedDyckPathsNaive ++-- | @boundedDyckPathsNaive h m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ whose height is at most @h@.+--+-- > sort (boundedDyckPaths h m) == sort [ p | p <- dyckPaths m , pathHeight p <= h ]+-- > sort (boundedDyckPaths m m) == sort (dyckPaths m) +--+-- Naive recursive algorithm, resulting order is pretty ad-hoc.+--+boundedDyckPathsNaive+  :: Int   -- ^ @h@ = maximum height+  -> Int   -- ^ @m@ = half-length+  -> [LatticePath]+boundedDyckPathsNaive = worker where+  worker !h !m +    | h<0        = []+    | m<0        = []+    | m==0       = [[]]+    | h<=0       = []+    | otherwise  = as ++ bs +    where+      bracket p = UpStep : p ++ [DownStep]+      as = [ bracket p      |                 p <- boundedDyckPaths (h-1) (m-1)                                 ]+      bs = [ bracket p ++ q | k <- [1..m-1] , p <- boundedDyckPaths (h-1) (k-1) , q <- boundedDyckPaths h (m-k) ]++--------------------------------------------------------------------------------+-- * More general lattice paths++-- | All lattice paths from @(0,0)@ to @(x,y)@. Clearly empty unless @x-y@ is even.+-- Synonym for 'latticePathsNaive'+--+latticePaths :: (Int,Int) -> [LatticePath]+latticePaths = latticePathsNaive++-- | All lattice paths from @(0,0)@ to @(x,y)@. Clearly empty unless @x-y@ is even.+--+-- Note that+--+-- > sort (dyckPaths n) == sort (latticePaths (0,2*n))+--+-- Naive recursive algorithm, resulting order is pretty ad-hoc.+--+latticePathsNaive :: (Int,Int) -> [LatticePath]+latticePathsNaive (x,y) = worker x y where+  worker !x !y +    | odd (x-y)     = []+    | x<0           = []+    | y<0           = []+    | y==0          = dyckPaths (div x 2)+    | x==1 && y==1  = [[UpStep]]+    | otherwise     = as ++ bs+    where+      bracket p = UpStep : p ++ [DownStep] +      as = [ UpStep : p     | p <- worker (x-1) (y-1) ]+      bs = [ bracket p ++ q | k <- [1..(div x 2)] , p <- dyckPaths (k-1) , q <- worker (x-2*k) y ]++-- | Lattice paths are counted by the numbers in the Catalan triangle.+countLatticePaths :: (Int,Int) -> Integer+countLatticePaths (x,y) +  | even (x+y)  = catalanTriangle (div (x+y) 2) (div (x-y) 2)+  | otherwise   = 0++--------------------------------------------------------------------------------+-- * Zero-level touches++-- | @touchingDyckPaths k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ which touch the +-- zero level line @y=0@ exactly @k@ times (excluding the starting point, but including the endpoint;+-- thus, @k@ should be positive). Synonym for 'touchingDyckPathsNaive'.+touchingDyckPaths+  :: Int   -- ^ @k@ = number of zero-touches+  -> Int   -- ^ @m@ = half-length+  -> [LatticePath]+touchingDyckPaths = touchingDyckPathsNaive+++-- | @touchingDyckPathsNaive k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ which touch the +-- zero level line @y=0@ exactly @k@ times (excluding the starting point, but including the endpoint;+-- thus, @k@ should be positive).+--+-- > sort (touchingDyckPathsNaive k m) == sort [ p | p <- dyckPaths m , pathNumberOfZeroTouches p == k ]+-- +-- Naive recursive algorithm, resulting order is pretty ad-hoc.+--+touchingDyckPathsNaive+  :: Int   -- ^ @k@ = number of zero-touches+  -> Int   -- ^ @m@ = half-length+  -> [LatticePath]+touchingDyckPathsNaive = worker where+  worker !k !m +    | m == 0    = if k==0 then [[]] else []+    | k <= 0    = []+    | m <  0    = []+    | k == 1    = [ bracket p      |                 p <- dyckPaths (m-1)                           ]+    | otherwise = [ bracket p ++ q | l <- [1..m-1] , p <- dyckPaths (l-1) , q <- worker (k-1) (m-l) ]+    where+      bracket p = UpStep : p ++ [DownStep] +++-- | There is a bijection from the set of non-empty Dyck paths of length @2n@ which touch the zero lines @t@ times,+-- to lattice paths from @(0,0)@ to @(2n-t-1,t-1)@ (just remove all the down-steps just before touching+-- the zero line, and also the very first up-step). This gives us a counting formula.+countTouchingDyckPaths +  :: Int   -- ^ @k@ = number of zero-touches+  -> Int   -- ^ @m@ = half-length+  -> Integer+countTouchingDyckPaths t n+  | t==0 && n==0   = 1+  | otherwise      = countLatticePaths (2*n-t-1,t-1)++--------------------------------------------------------------------------------+-- * Dyck paths with given number of peaks++-- | @peakingDyckPaths k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ with exactly @k@ peaks.+--+-- Synonym for 'peakingDyckPathsNaive'+--+peakingDyckPaths+  :: Int      -- ^ @k@ = number of peaks+  -> Int      -- ^ @m@ = half-length+  -> [LatticePath]+peakingDyckPaths = peakingDyckPathsNaive ++-- | @peakingDyckPathsNaive k m@ lists all Dyck paths from @(0,0)@ to @(2m,0)@ with exactly @k@ peaks.+--+-- > sort (peakingDyckPathsNaive k m) = sort [ p | p <- dyckPaths m , pathNumberOfPeaks p == k ]+--  +-- Naive recursive algorithm, resulting order is pretty ad-hoc.+--+peakingDyckPathsNaive +  :: Int      -- ^ @k@ = number of peaks+  -> Int      -- ^ @m@ = half-length+  -> [LatticePath]+peakingDyckPathsNaive = worker where+  worker !k !m+    | m == 0    = if k==0 then [[]] else []       +    | k <= 0    = []+    | m <  0    = []+    | k == 1    = [ singlePeak m ] +    | otherwise = as ++ bs ++ cs+    where+      as = [ bracket p      |                                 p <- worker k (m-1)                           ]+      bs = [ smallHill ++ q |                                                       q <- worker (k-1) (m-1) ]+      cs = [ bracket p ++ q | l <- [2..m-1] , a <- [1..k-1] , p <- worker a (l-1) , q <- worker (k-a) (m-l) ]+      smallHill     = [ UpStep , DownStep ]+      singlePeak !m = replicate m UpStep ++ replicate m DownStep +      bracket p = UpStep : p ++ [DownStep] ++-- | Dyck paths of length @2m@ with @k@ peaks are counted by the Narayana numbers @N(m,k) = \binom{m}{k} \binom{m}{k-1} / m@+countPeakingDyckPaths+  :: Int      -- ^ @k@ = number of peaks+  -> Int      -- ^ @m@ = half-length+  -> Integer+countPeakingDyckPaths k m +  | m == 0    = if k==0 then 1 else 0+  | k <= 0    = 0+  | m <  0    = 0+  | k == 1    = 1+  | otherwise = div (binomial m k * binomial m (k-1)) (fromIntegral m)++--------------------------------------------------------------------------------+-- * Random lattice paths++-- | A uniformly random Dyck path of length @2m@+randomDyckPath :: RandomGen g => Int -> g -> (LatticePath,g)+randomDyckPath m g0 = (nestedParensToDyckPath parens, g1) where+  (parens,g1) = randomNestedParentheses m g0++--------------------------------------------------------------------------------+
+ src/Math/Combinat/Numbers.hs view
@@ -0,0 +1,12 @@++module Math.Combinat.Numbers +  ( module Math.Combinat.Numbers.Integers+  , module Math.Combinat.Numbers.Primes+  , module Math.Combinat.Numbers.Sequences+  ) +  where++import Math.Combinat.Numbers.Integers+import Math.Combinat.Numbers.Primes+import Math.Combinat.Numbers.Sequences+
+ src/Math/Combinat/Numbers/Integers.hs view
@@ -0,0 +1,113 @@++-- | Operations on integers++module Math.Combinat.Numbers.Integers +  ( -- * Integer logarithm+    integerLog2+  , ceilingLog2+    -- * Integer square root+  , isSquare+  , integerSquareRoot+  , ceilingSquareRoot+  , integerSquareRoot' +  , integerSquareRootNewton'+  )+  where++--------------------------------------------------------------------------------++-- import Math.Combinat.Numbers++import Data.List ( group , sort )+import Data.Bits++import System.Random++--------------------------------------------------------------------------------+-- Integer logarithm++-- | Largest integer @k@ such that @2^k@ is smaller or equal to @n@+integerLog2 :: Integer -> Integer+integerLog2 n = go n where+  go 0 = -1+  go k = 1 + go (shiftR k 1)++-- | Smallest integer @k@ such that @2^k@ is larger or equal to @n@+ceilingLog2 :: Integer -> Integer+ceilingLog2 0 = 0+ceilingLog2 n = 1 + go (n-1) where+  go 0 = -1+  go k = 1 + go (shiftR k 1)+  +--------------------------------------------------------------------------------+-- Integer square root++isSquare :: Integer -> Bool+isSquare n = +  if (fromIntegral $ mod n 32) `elem` rs +    then snd (integerSquareRoot' n) == 0+    else False+  where+    rs = [0,1,4,9,16,17,25] :: [Int]+    +-- | Integer square root (largest integer whose square is smaller or equal to the input)+-- using Newton's method, with a faster (for large numbers) inital guess based on bit shifts.+integerSquareRoot :: Integer -> Integer+integerSquareRoot = fst . integerSquareRoot'++-- | Smallest integer whose square is larger or equal to the input+ceilingSquareRoot :: Integer -> Integer+ceilingSquareRoot n = (if r>0 then u+1 else u) where (u,r) = integerSquareRoot' n ++-- | We also return the excess residue; that is+--+-- > (a,r) = integerSquareRoot' n+-- +-- means that+--+-- > a*a + r = n+-- > a*a <= n < (a+1)*(a+1)+integerSquareRoot' :: Integer -> (Integer,Integer)+integerSquareRoot' n+  | n<0 = error "integerSquareRoot: negative input"+  | n<2 = (n,0)+  | otherwise = go firstGuess +  where+    k = integerLog2 n+    firstGuess = 2^(div (k+2) 2) -- !! note that (div (k+1) 2) is NOT enough !!+    go a = +      if m < a+        then go a' +        else (a, r + a*(m-a))+      where+        (m,r) = divMod n a+        a' = div (m + a) 2++-- | Newton's method without an initial guess. For very small numbers (<10^10) it+-- is somewhat faster than the above version.+integerSquareRootNewton' :: Integer -> (Integer,Integer)+integerSquareRootNewton' n+  | n<0 = error "integerSquareRootNewton: negative input"+  | n<2 = (n,0)+  | otherwise = go (div n 2) +  where+    go a = +      if m < a+        then go a' +        else (a, r + a*(m-a))+      where+        (m,r) = divMod n a+        a' = div (m + a) 2++{-+-- brute force test of integer square root+isqrt_test n1 n2 = +  [ k +  | k<-[n1..n2] +  , let (a,r) = integerSquareRoot' k+  , (a*a+r/=k) || (a*a>k) || (a+1)*(a+1)<=k +  ]+-}++--------------------------------------------------------------------------------+
+ src/Math/Combinat/Numbers/Primes.hs view
@@ -0,0 +1,361 @@++-- | Prime numbers and related number theoretical stuff.++module Math.Combinat.Numbers.Primes +  ( -- * Elementary number theory+    divides+  , divisors, squareFreeDivisors, squareFreeDivisors_  +  , divisorSum , divisorSum'+  , moebiusMu , eulerTotient , liouvilleLambda+    -- * List of prime numbers+  , primes+  , primesSimple+  , primesTMWE+    -- * Prime factorization+  , factorize, factorizeNaive+  , productOfFactors+  , integerFactorsTrialDivision+  , groupIntegerFactors+    -- * Modulo @m@ arithmetic+  , powerMod+    -- * Prime testing+  , millerRabinPrimalityTest+  , isProbablyPrime+  , isVeryProbablyPrime+  )+  where++--------------------------------------------------------------------------------++import Data.List ( group , sort , foldl' )++import Math.Combinat.Sign+import Math.Combinat.Helper+import Math.Combinat.Numbers.Integers++-- import Math.Combinat.Sets   ( sublists )       -- cyclic dependency...+import Math.Combinat.Tuples ( tuples'  )++import Data.Bits++import System.Random++--------------------------------------------------------------------------------++-- | @d `divides` n@+divides :: Integer -> Integer -> Bool+divides d n = (mod n d == 0)++{-# SPECIALIZE moebiusMu :: Int     -> Int     #-}+{-# SPECIALIZE moebiusMu :: Integer -> Integer #-}+-- | The Moebius mu function+moebiusMu :: (Integral a, Num b) => a -> b+moebiusMu n +  | any (>1) expos       =  0+  | even (length primes) =  1+  | otherwise            = -1+  where+    factors = groupIntegerFactors $ integerFactorsTrialDivision $ fromIntegral n+    (primes,expos) = unzip factors++{-# SPECIALIZE liouvilleLambda :: Int     -> Int     #-}+{-# SPECIALIZE liouvilleLambda :: Integer -> Integer #-}+-- | The Liouville lambda function+liouvilleLambda :: (Integral a, Num b) => a -> b+liouvilleLambda n = +  if odd (foldl' (+) 0 $ map snd grps)+    then -1+    else  1+  where+    grps = groupIntegerFactors $ integerFactorsTrialDivision $ fromIntegral n++-- | Sum ofthe of the divisors+divisorSum :: Integer -> Integer+divisorSum n = foldl' (+) 0 [ d | d <- divisors n]++-- | Sum of @k@-th powers of the divisors+divisorSum' :: Int -> Integer -> Integer+divisorSum' k n = foldl' (+) 0 [ d^k | d <- divisors n]++-- | Euler's totient function+eulerTotient :: Integer -> Integer+eulerTotient n = div n prodp * prodp1 where+  grps   = groupIntegerFactors $ integerFactorsTrialDivision n+  ps     = map fst grps+  prodp  = foldl' (*) 1 [ p   | p <- ps ] +  prodp1 = foldl' (*) 1 [ p-1 | p <- ps ] ++-- | Divisors of @n@ (note: the result is /not/ ordered!)+divisors :: Integer -> [Integer]+divisors n = [ f tup | tup <- tuples' expos ] where+  grps = groupIntegerFactors $ integerFactorsTrialDivision n+  (ps,expos) = unzip grps+  f es = foldl' (*) 1 $ zipWith (^) ps es++-- | List of square-free divisors together with their Mobius mu value+-- (note: the result is /not/ ordered!)+squareFreeDivisors :: Integer -> [(Integer,Sign)]+squareFreeDivisors n = map f (sublists primes) where+  grps = groupIntegerFactors $ integerFactorsTrialDivision n+  primes = map fst grps+  f ps = ( foldl' (*) 1 ps , if even (length ps) then Plus else Minus)++-- | List of square-free divisors +-- (note: the result is /not/ ordered!)+squareFreeDivisors_ :: Integer -> [Integer]+squareFreeDivisors_ n = map f (sublists primes) where+  grps = groupIntegerFactors $ integerFactorsTrialDivision n+  primes = map fst grps+  f ps = foldl' (*) 1 ps++-- | To avoid cyclic dependencies, I made a local copy of this...+sublists :: [a] -> [[a]]+sublists [] = [[]]+sublists (x:xs) = sublists xs ++ map (x:) (sublists xs)  ++--------------------------------------------------------------------------------+-- List of prime numbers ++-- | Infinite list of primes, using the TMWE algorithm.+primes :: [Integer]+primes = primesTMWE++-- | A relatively simple but still quite fast implementation of list of primes.+-- By Will Ness <http://www.haskell.org/pipermail/haskell-cafe/2009-November/068441.html>+primesSimple :: [Integer]+primesSimple = 2 : 3 : sieve 0 primes' 5 where+  primes' = tail primesSimple+  sieve k (p:ps) x = noDivs k h ++ sieve (k+1) ps (t+2) where+    t = p*p +    h = [x,x+2..t-2]+  noDivs k = filter (\x -> all (\y -> rem x y /= 0) (take k primes'))+  +-- | List of primes, using tree merge with wheel. Code by Will Ness.+primesTMWE :: [Integer]+primesTMWE = 2:3:5:7: gaps 11 wheel (fold3t $ roll 11 wheel primes') where                                                             ++  primes' = 11: gaps 13 (tail wheel) (fold3t $ roll 11 wheel primes')+  fold3t ((x:xs): ~(ys:zs:t)) +    = x : union xs (union ys zs) `union` fold3t (pairs t)            +  pairs ((x:xs):ys:t) = (x : union xs ys) : pairs t +  wheel = 2:4:2:4:6:2:6:4:2:4:6:6:2:6:4:2:6:4:6:8:4:2:4:2:  +          4:8:6:4:6:2:4:6:2:6:6:4:2:4:6:2:6:4:2:4:2:10:2:10:wheel +  gaps k ws@(w:t) cs@(~(c:u))+    | k==c  = gaps (k+w) t u              +    | True  = k : gaps (k+w) t cs  +  roll k ws@(w:t) ps@(~(p:u)) +    | k==p  = scanl (\c d->c+p*d) (p*p) ws : roll (k+w) t u              +    | True  = roll (k+w) t ps   ++  minus xxs@(x:xs) yys@(y:ys) = case compare x y of +    LT -> x : minus xs  yys+    EQ ->     minus xs  ys +    GT ->     minus xxs ys+  minus xs [] = xs+  minus [] _  = []+  +  union xxs@(x:xs) yys@(y:ys) = case compare x y of +    LT -> x : union xs  yys+    EQ -> x : union xs  ys +    GT -> y : union xxs ys+  union xs [] = xs+  union [] ys =ys++--------------------------------------------------------------------------------+-- Prime factorization++factorize :: Integer -> [(Integer,Int)]+factorize = factorizeNaive++factorizeNaive :: Integer -> [(Integer,Int)]+factorizeNaive = groupIntegerFactors . integerFactorsTrialDivision++productOfFactors :: [(Integer,Int)] -> Integer+productOfFactors = productInterleaved . map (uncurry pow) where+  pow _ 0 = 1+  pow p 1 = p+  pow 2 n = shiftL 1 n+  pow p 2 = p*p+  pow p n = if even n+              then     (pow p (shiftR n 1))^2+              else p * (pow p (shiftR n 1))^2 ++-- | Groups integer factors. Example: from [2,2,2,3,3,5] we produce [(2,3),(3,2),(5,1)]  +groupIntegerFactors :: [Integer] -> [(Integer,Int)]+groupIntegerFactors = map f . group . sort where+  f xs = (head xs, length xs)++-- | The naive trial division algorithm.+integerFactorsTrialDivision :: Integer -> [Integer]+integerFactorsTrialDivision n +  | n<1 = error "integerFactorsTrialDivision: n should be at least 1"+  | otherwise = go primes n +  where+    go _  1 = []+    go rs k = sub ps k where+      sub [] k = [k]+      sub qqs@(q:qs) k = case mod k q of+        0 -> q : go qqs (div k q)+        _ -> sub qs k+      ps = takeWhile (\p -> p*p <= k) rs  +{-+    go 1 = []+    go k = sub ps k where+      sub [] k = [k]+      sub (q:qs) k = case mod k q of+        0 -> q : go (div k q)+        _ -> sub qs k+      ps = takeWhile (\p -> p*p <= k) primes+-}++{-    +-- brute force testing of factors+ifactorsTest :: (Integer -> [Integer]) -> Integer -> Bool+ifactorsTest alg n = and [ product (alg k) == k | k<-[1..n] ]   +-}++--------------------------------------------------------------------------------+-- Modulo @m@ arithmetic++-- | Efficient powers modulo m.+-- +-- > powerMod a k m == (a^k) `mod` m+powerMod :: Integer -> Integer -> Integer -> Integer+powerMod a' k m = {- debug bs $ -} go a bs where++  bs = bin k++  bin 0 = []+  bin x = (x .&. 1 /= 0) : bin (shiftR x 1)++  a = mod a' m++  go _ [] = 1+  go x (b:bs) = -- debug (x,b) $ +    if b +      then mod (x*rest) m+      else rest+    where +      rest = go (mod (x*x) m) bs +      +--------------------------------------------------------------------------------+-- Prime testing+ +-- | Miller-Rabin Primality Test (taken from Haskell wiki). +-- We test the primality of the first argument @n@ by using the second argument @a@ as a candidate witness.+-- If it returs @False@, then @n@ is composite. If it returns @True@, then @n@ is either prime or composite.+--+-- A random choice between @2@ and @(n-2)@ is a good choice for @a@.+millerRabinPrimalityTest :: Integer -> Integer -> Bool+millerRabinPrimalityTest n a+  | a <= 1 || a >= n-1 = +      error $ "millerRabinPrimalityTest: a out of range (" ++ show a ++ " for "++ show n ++ ")" +  | n < 2 = False+  | even n = False+  | b0 == 1 || b0 == n' = True+  | otherwise = iter (tail b)+  where+    n' = n-1+    (k,m) = find2km n'+    b0 = powMod n a m+    b = take (fromIntegral k) $ iterate (squareMod n) b0+    iter [] = False+    iter (x:xs)+      | x == 1 = False+      | x == n' = True+      | otherwise = iter xs+++{-# SPECIALIZE find2km :: Integer -> (Integer,Integer) #-}+find2km :: Integral a => a -> (a,a)+find2km n = f 0 n where +  f k m+    | r == 1 = (k,m)+    | otherwise = f (k+1) q+    where (q,r) = quotRem m 2        + +{-# SPECIALIZE pow' :: (Integer -> Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer -> Integer #-}+pow' :: (Num a, Integral b) => (a -> a -> a) -> (a -> a) -> a -> b -> a+pow' _ _ _ 0 = 1+pow' mul sq x' n' = f x' n' 1 where +  f x n y+    | n == 1 = x `mul` y+    | r == 0 = f x2 q y+    | otherwise = f x2 q (x `mul` y)+    where+      (q,r) = quotRem n 2+      x2 = sq x+ +{-# SPECIALIZE mulMod :: Integer -> Integer -> Integer -> Integer #-}+mulMod :: Integral a => a -> a -> a -> a+mulMod a b c = (b * c) `mod` a++{-# SPECIALIZE squareMod :: Integer -> Integer -> Integer #-}+squareMod :: Integral a => a -> a -> a+squareMod a b = (b * b) `rem` a++{-# SPECIALIZE powMod :: Integer -> Integer -> Integer -> Integer #-}+powMod :: Integral a => a -> a -> a -> a+powMod m = pow' (mulMod m) (squareMod m)++--------------------------------------------------------------------------------++-- | For very small numbers, we use trial division, for larger numbers, we apply the +-- Miller-Rabin primality test @log4(n)@ times, with candidate witnesses derived +-- deterministically from @n@ using a pseudo-random sequence +-- (which /should be/ based on a cryptographic hash function, but isn\'t, yet). +--+-- Thus the candidate witnesses should behave essentially like random, but the +-- resulting function is still a deterministic, pure function.+--+-- TODO: implement the hash sequence, at the moment we use 'System.Random' instead...+--+isProbablyPrime :: Integer -> Bool+isProbablyPrime n +  | n < 2      = False+  | even n     = (n==2)+  | n < 1000   = length (integerFactorsTrialDivision n) == 1+  | otherwise  = and [ millerRabinPrimalityTest n a | a <- witnessList ]+  where+    log2n       = integerLog2 n +    nchecks     = 1 + fromInteger (div log2n 2) :: Int+    witnessList = take nchecks pseudoRnds+    pseudoRnds  = 2 : [ a | a <- integerRndSequence n , a > 1 && a < (n-1) ]++-- | A more exhaustive version of 'isProbablyPrime', this one tests candidate+-- witnesses both the first log4(n) prime numbers and then log4(n) pseudo-random+-- numbers+isVeryProbablyPrime :: Integer -> Bool+isVeryProbablyPrime n+  | n < 2      = False+  | even n     = (n==2)+  | n < 1000   = length (integerFactorsTrialDivision n) == 1+  | otherwise  = and [ millerRabinPrimalityTest n a | a <- witnessList ]+  where+    log2n       = integerLog2 n +    nchecks     = 1 + fromInteger (div log2n 2) :: Int+    witnessList = take nchecks primes ++ take nchecks pseudoRnds+    pseudoRnds  = [ a | a <- integerRndSequence (n+3) , a > 1 && a < (n-1) ]++--------------------------------------------------------------------------------++{-+-- | Given an integer @n@, we return an infinite sequence of pseudo-random integers +-- between @0..n-1@, generated using a crypographic hash function.+--+integerHashSequence :: Integer -> [Integer]+integerHashSequence = error "integerHashSequence: not implemented yet"+-}++-- | Given an integer @n@, we initialize a system random generator with using a +-- seed derived from @n@ (note that this uses at most 32 or 64 bits), and generate +-- an infinite sequence of pseudo-random integers between @0..n-1@, generated by +-- that random generator. +--+-- Note that this is not really a preferred way of generating such sequences!+-- +integerRndSequence :: Integer -> [Integer]+integerRndSequence n = randomRs (0,n-1) gen where+  gen = mkStdGen $ fromInteger (n + 17 * integerLog2 n)++--------------------------------------------------------------------------------
+ src/Math/Combinat/Numbers/Sequences.hs view
@@ -0,0 +1,307 @@++-- | Some important number sequences. +--  +-- See the \"On-Line Encyclopedia of Integer Sequences\",+-- <https://oeis.org> .++{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+module Math.Combinat.Numbers.Sequences where++--------------------------------------------------------------------------------++import Data.Array+import Data.Bits ( shiftL , shiftR , (.&.) )++import Math.Combinat.Helper +import Math.Combinat.Sign++import Math.Combinat.Numbers.Primes ( primes , factorize , productOfFactors )++import qualified Data.Map.Strict as Map   -- used for factorialPrimeExponentsNaive++--------------------------------------------------------------------------------+-- * Factorial++-- | The factorial function (A000142).+factorial :: Integral a => a -> Integer+factorial = factorialSplit++-- | Faster implementation of the factorial function+factorialSplit :: Integral a => a -> Integer+factorialSplit n = productFromTo 1 n++-- | Naive implementation of factorial+factorialNaive :: Integral a => a -> Integer+factorialNaive n+  | n <  0    = error "factorialNaive: input should be nonnegative"+  | n == 0    = 1+  | otherwise = product [1..fromIntegral n]++-- | \"Swing factorial\" algorithm+factorialSwing :: Integral a => a -> Integer+factorialSwing n = productOfFactors (factorialPrimeExponents $ fromIntegral n) where++--------------------------------------------------------------------------------++-- | Prime factorization of the factorial (using the \"swing factorial\" algorithm)+factorialPrimeExponents :: Int -> [(Integer,Int)]+factorialPrimeExponents n = filter cond $ zip primes (factorialPrimeExponents_ n) where+  cond (_,!e) = e > 0++factorialPrimeExponentsNaive :: forall a. Integral a => a -> [(Integer,Int)]+factorialPrimeExponentsNaive n = result where+  fi = fromIntegral :: a -> Integer+  result = Map.toList +         $ Map.unionsWith (+) +         $ map Map.fromList +         $ map factorize +         $ map fi [1..n] ++factorialPrimeExponents_ :: Int -> [Int]+factorialPrimeExponents_ = go where+  go  0 = []+  go  1 = []+  go  2 = [1]+  go !n = longAdd half swing where+    half  = map (flip shiftL 1) $ go (shiftR n 1)+    swing = swingFactorialExponents_ n++  longAdd :: [Int] -> [Int] -> [Int]+  longAdd xs [] = xs+  longAdd [] ys = ys+  longAdd (!x:xs) (!y:ys) = (x+y) : longAdd xs ys++-- | Prime factorizaiton of the \"swing factorial\" function)+swingFactorialExponents_ :: Int -> [Int]+swingFactorialExponents_ = go where+  go 0 = []+  go 1 = []+  go 2 = [1]+  go n = expo2 : map expo (tail ps) where++    nn = fromIntegral n :: Integer++    ps :: [Integer]+    ps = takeWhile (<=nn) primes ++    expo2 :: Int+    expo2 = go 0 (shiftR n 1) where+      go :: Int -> Int -> Int+      go !acc !r  +        | r < 1     = acc+        | otherwise = go acc' r' +        where+          acc' = acc + (r .&. 1)+          r'   = shiftR r 1++    expo :: Integer -> Int+    expo pp = go 0 (div n p) where+      p = fromInteger pp :: Int+      go :: Int -> Int -> Int+      go !acc !r  +        | r < 1     = acc+        | otherwise = go acc' r' +        where+          acc' = acc + (r .&. 1)+          r'   = div r p++--------------------------------------------------------------------------------++-- | The double factorial+doubleFactorial :: Integral a => a -> Integer+doubleFactorial = doubleFactorialSplit++-- | Faster implementation of the double factorial function+doubleFactorialSplit :: Integral a => a -> Integer+doubleFactorialSplit n+  | n <  0    = error "doubleFactorialSplit: input should be nonnegative"+  | n == 0    = 1+  | odd n     = productFromToStride2 2 n+  | otherwise = let halfn = div n 2 +                in  shiftL (factorialSplit halfn) (fromIntegral halfn)++-- | Naive implementation of the double factorial (A006882).+doubleFactorialNaive :: Integral a => a -> Integer+doubleFactorialNaive n+  | n <  0    = error "doubleFactorialNaive: input should be nonnegative"+  | n == 0    = 1+  | odd n     = product [1,3..fromIntegral n]+  | otherwise = product [2,4..fromIntegral n]++--------------------------------------------------------------------------------+-- * Binomial and multinomial++-- | Binomial numbers (A007318). Note: This is zero for @n<0@ or @k<0@; see also 'signedBinomial' below.+binomial :: Integral a => a -> a -> Integer+binomial = binomialSplit++-- | Faster implementation of binomial+binomialSplit :: Integral a => a -> a -> Integer+binomialSplit n k +  | k > n = 0+  | k < 0 = 0+  | k > (n `div` 2) = binomialSplit n (n-k)+  | otherwise = (productFromTo (n-k) n) `div` (productFromTo 1 k)++-- | A007318. Note: This is zero for @n<0@ or @k<0@; see also 'signedBinomial' below.+binomialNaive :: Integral a => a -> a -> Integer+binomialNaive n k +  | k > n = 0+  | k < 0 = 0+  | k > (n `div` 2) = binomial n (n-k)+  | otherwise = (product [n'-k'+1 .. n']) `div` (product [1..k'])+  where +    k' = fromIntegral k+    n' = fromIntegral n++-- | The extension of the binomial function to negative inputs. This should satisfy the following properties:+--+-- > for n,k >=0 : signedBinomial n k == binomial n k+-- > for any n,k : signedBinomial n k == signedBinomial n (n-k) +-- > for k >= 0  : signedBinomial (-n) k == (-1)^k * signedBinomial (n+k-1) k+--+-- Note: This is compatible with Mathematica's @Binomial@ function.+--+signedBinomial :: Int -> Int -> Integer+signedBinomial n k+  | n >= 0     = binomial n k+  | k >= 0     = negateIfOdd    k  $ binomial (k-n-1)   k  +  | otherwise  = negateIfOdd (n+k) $ binomial (-k-1) (-n-1)++{-+test_signed_0 = [ signedBinomial ( n) k == signedBinomial ( n) ( n-k)                | n<-[-30..40] , k<-[-30..40] ]+test_signed_1 = [ signedBinomial (-n) k == signedBinomial (-n) (-n-k)                | n<-[-30..40] , k<-[-30..40] ]+test_signed_2 = [ signedBinomial (-n) k == negateIfOdd k $ signedBinomial (n+k-1) k  | n<-[-30..40] , k<-[0..30] ]+-}++-- | A given row of the Pascal triangle; equivalent to a sequence of binomial +-- numbers, but much more efficient. You can also left-fold over it.+--+-- > pascalRow n == [ binomial n k | k<-[0..n] ]+pascalRow :: Integral a => a -> [Integer]+pascalRow n' = worker 0 1 where+  n = fromIntegral n'+  worker j x+    | j>n   = [] +    | True  = let j'=j+1 in x : worker j' (div (x*(n-j)) j') ++multinomial :: Integral a => [a] -> Integer+multinomial xs = div+  (factorial (sum xs))+  (product [ factorial x | x<-xs ])  +  +--------------------------------------------------------------------------------+-- * Catalan numbers++-- | Catalan numbers. OEIS:A000108.+catalan :: Integral a => a -> Integer+catalan n +  | n < 0     = 0+  | otherwise = binomial (n+n) n `div` fromIntegral (n+1)++-- | Catalan's triangle. OEIS:A009766.+-- Note:+--+-- > catalanTriangle n n == catalan n+-- > catalanTriangle n k == countStandardYoungTableaux (toPartition [n,k])+--+catalanTriangle :: Integral a => a -> a -> Integer+catalanTriangle n k+  | k > n     = 0+  | k < 0     = 0+  | otherwise = (binomial (n+k) n * fromIntegral (n-k+1)) `div` fromIntegral (n+1)++--------------------------------------------------------------------------------+-- * Stirling numbers++-- | Rows of (signed) Stirling numbers of the first kind. OEIS:A008275.+-- Coefficients of the polinomial @(x-1)*(x-2)*...*(x-n+1)@.+-- This function uses the recursion formula.+signedStirling1stArray :: Integral a => a -> Array Int Integer+signedStirling1stArray n+  | n <  1    = error "stirling1stArray: n should be at least 1"+  | n == 1    = listArray (1,1 ) [1]+  | otherwise = listArray (1,n') [ lkp (k-1) - fromIntegral (n-1) * lkp k | k<-[1..n'] ] +  where+    prev = signedStirling1stArray (n-1)+    n' = fromIntegral n :: Int+    lkp j | j <  1    = 0+          | j >= n'   = 0+          | otherwise = prev ! j +        +-- | (Signed) Stirling numbers of the first kind. OEIS:A008275.+-- This function uses 'signedStirling1stArray', so it shouldn't be used+-- to compute /many/ Stirling numbers.+--+-- Argument order: @signedStirling1st n k@+--+signedStirling1st :: Integral a => a -> a -> Integer+signedStirling1st n k +  | k==0 && n==0 = 1+  | k < 1        = 0+  | k > n        = 0+  | otherwise    = signedStirling1stArray n ! (fromIntegral k)++-- | (Unsigned) Stirling numbers of the first kind. See 'signedStirling1st'.+unsignedStirling1st :: Integral a => a -> a -> Integer+unsignedStirling1st n k = abs (signedStirling1st n k)++-- | Stirling numbers of the second kind. OEIS:A008277.+-- This function uses an explicit formula.+-- +-- Argument order: @stirling2nd n k@+--+stirling2nd :: Integral a => a -> a -> Integer+stirling2nd n k +  | k==0 && n==0 = 1+  | k < 1        = 0+  | k > n        = 0+  | otherwise = sum xs `div` factorial k where+      xs = [ negateIfOdd (k-i) $ binomial k i * (fromIntegral i)^n | i<-[0..k] ]++--------------------------------------------------------------------------------+-- * Bernoulli numbers++-- | Bernoulli numbers. @bernoulli 1 == -1%2@ and @bernoulli k == 0@ for+-- k>2 and /odd/. This function uses the formula involving Stirling numbers+-- of the second kind. Numerators: A027641, denominators: A027642.+bernoulli :: Integral a => a -> Rational+bernoulli n +  | n <  0    = error "bernoulli: n should be nonnegative"+  | n == 0    = 1+  | n == 1    = -1/2+  | otherwise = sum [ f k | k<-[1..n] ] +  where+    f k = toRational (negateIfOdd (n+k) $ factorial k * stirling2nd n k) +        / toRational (k+1)++--------------------------------------------------------------------------------+-- * Bell numbers++-- | Bell numbers (Sloane's A000110) from B(0) up to B(n). B(0)=B(1)=1, B(2)=2, etc. +--+-- The Bell numbers count the number of /set partitions/ of a set of size @n@+-- +-- See <http://en.wikipedia.org/wiki/Bell_number>+--+bellNumbersArray :: Integral a => a -> Array Int Integer+bellNumbersArray nn = arr where+  arr = array (0::Int,n) kvs +  n = fromIntegral nn :: Int+  kvs = (0,1) : [ (k, f k) | k<-[1..n] ] +  f n = sum' [ binomial (n-1) k * arr ! k | k<-[0..n-1] ]++-- | The n-th Bell number B(n), using the Stirling numbers of the second kind.+-- This may be slower than using 'bellNumbersArray'.+bellNumber :: Integral a => a -> Integer+bellNumber nn+  | n <  0     = error "bellNumber: expecting a nonnegative index"+  | n == 0     = 1+  | otherwise  = sum' [ stirling2nd n k | k<-[1..n] ] +  where+    n = fromIntegral nn :: Int++--------------------------------------------------------------------------------+++
+ src/Math/Combinat/Numbers/Series.hs view
@@ -0,0 +1,434 @@++-- | Some basic univariate power series expansions.+-- This module is not re-exported by "Math.Combinat".+--+-- Note: the \"@convolveWithXXX@\" functions are much faster than the equivalent+-- @(XXX \`convolve\`)@!+-- +-- TODO: better names for these functions.+--++{-# LANGUAGE CPP, BangPatterns, GeneralizedNewtypeDeriving #-}+module Math.Combinat.Numbers.Series where++--------------------------------------------------------------------------------++import Data.List++import Math.Combinat.Sign+import Math.Combinat.Numbers+import Math.Combinat.Partitions.Integer+import Math.Combinat.Helper++--------------------------------------------------------------------------------+-- * Trivial series++-- | The series [1,0,0,0,0,...], which is the neutral element for the convolution.+{-# SPECIALIZE unitSeries :: [Integer] #-}+unitSeries :: Num a => [a]+unitSeries = 1 : repeat 0++-- | Constant zero series+zeroSeries :: Num a => [a]+zeroSeries = repeat 0++-- | Power series representing a constant function+constSeries :: Num a => a -> [a]+constSeries x = x : repeat 0++-- | The power series representation of the identity function @x@+idSeries :: Num a => [a]+idSeries = 0 : 1 : repeat 0++-- | The power series representation of @x^n@+powerTerm :: Num a => Int -> [a]+powerTerm n = replicate n 0 ++ (1 : repeat 0)++--------------------------------------------------------------------------------+-- * Basic operations on power series++addSeries :: Num a => [a] -> [a] -> [a]+addSeries xs ys = longZipWith 0 0 (+) xs ys++sumSeries :: Num a => [[a]] -> [a]+sumSeries [] = [0]+sumSeries xs = foldl1' addSeries xs++subSeries :: Num a => [a] -> [a] -> [a]+subSeries xs ys = longZipWith 0 0 (-) xs ys++negateSeries :: Num a => [a] -> [a]+negateSeries = map negate++scaleSeries :: Num a => a -> [a] -> [a]+scaleSeries s = map (*s)++-- | A different implementation, taken from:+--+-- M. Douglas McIlroy: Power Series, Power Serious +mulSeries :: Num a => [a] -> [a] -> [a]+mulSeries xs ys = go (xs ++ repeat 0) (ys ++ repeat 0) where+  go (f:fs) ggs@(g:gs) = f*g : (scaleSeries f gs) `addSeries` go fs ggs++-- | Multiplication of power series. This implementation is a synonym for 'convolve'+mulSeriesNaive :: Num a => [a] -> [a] -> [a]+mulSeriesNaive = convolve++productOfSeries :: Num a => [[a]] -> [a]+productOfSeries = convolveMany++--------------------------------------------------------------------------------+-- * Convolution (product)++-- | Convolution of series (that is, multiplication of power series). +-- The result is always an infinite list. Warning: This is slow!+convolve :: Num a => [a] -> [a] -> [a]+convolve xs1 ys1 = res where+  res = [ foldl' (+) 0 (zipWith (*) xs (reverse (take n ys)))+        | n<-[1..] +        ]+  xs = xs1 ++ repeat 0+  ys = ys1 ++ repeat 0++-- | Convolution (= product) of many series. Still slow!+convolveMany :: Num a => [[a]] -> [a]+convolveMany []  = 1 : repeat 0+convolveMany xss = foldl1 convolve xss++--------------------------------------------------------------------------------+-- * Reciprocals of general power series++-- | Division of series.+--+-- Taken from: M. Douglas McIlroy: Power Series, Power Serious +divSeries :: (Eq a, Fractional a) => [a] -> [a] -> [a]+divSeries xs ys = go (xs ++ repeat 0) (ys ++ repeat 0) where+  go (0:fs)     (0:gs) = go fs gs+  go (f:fs) ggs@(g:gs) = let q = f/g in q : go (fs `subSeries` scaleSeries q gs) ggs++-- | Given a power series, we iteratively compute its multiplicative inverse+reciprocalSeries :: (Eq a, Fractional a) => [a] -> [a]+reciprocalSeries series = case series of+  [] -> error "reciprocalSeries: empty input series (const 0 function does not have an inverse)"+  (a:as) -> case a of+    0 -> error "reciprocalSeries: input series has constant term 0"+    _ -> map (/a) $ integralReciprocalSeries $ map (/a) series++-- | Given a power series starting with @1@, we can compute its multiplicative inverse+-- without divisions.+--+{-# SPECIALIZE integralReciprocalSeries :: [Int]     -> [Int]     #-}+{-# SPECIALIZE integralReciprocalSeries :: [Integer] -> [Integer] #-}+integralReciprocalSeries :: (Eq a, Num a) => [a] -> [a]+integralReciprocalSeries series = case series of +  [] -> error "integralReciprocalSeries: empty input series (const 0 function does not have an inverse)"+  (a:as) -> case a of+    1 -> 1 : worker [1]+    _ -> error "integralReciprocalSeries: input series must start with 1"+  where+    worker bs = let b' = - sum (zipWith (*) (tail series) bs) +                in  b' : worker (b':bs)++--------------------------------------------------------------------------------+-- * Composition of formal power series++-- | @g \`composeSeries\` f@ is the power series expansion of @g(f(x))@.+-- This is a synonym for @flip substitute@.+--+-- This implementation is taken from+--+-- M. Douglas McIlroy: Power Series, Power Serious +composeSeries :: (Eq a, Num a) => [a] -> [a] -> [a]+composeSeries xs ys = go (xs ++ repeat 0) (ys ++ repeat 0) where+  go (f:fs) (0:gs) = f : mulSeries gs (go fs (0:gs))+  go (f:fs) (_:gs) = error "PowerSeries/composeSeries: we expect the the constant term of the inner series to be zero"++-- | @substitute f g@ is the power series corresponding to @g(f(x))@. +-- Equivalently, this is the composition of univariate functions (in the \"wrong\" order).+--+-- Note: for this to be meaningful in general (not depending on convergence properties),+-- we need that the constant term of @f@ is zero.+substitute :: (Eq a, Num a) => [a] -> [a] -> [a]+substitute f g = composeSeries g f++-- | Naive implementation of 'composeSeries' (via 'substituteNaive')+composeSeriesNaive :: (Eq a, Num a) => [a] -> [a] -> [a]+composeSeriesNaive g f = substituteNaive f g++-- | Naive implementation of 'substitute'+substituteNaive :: (Eq a, Num a) => [a] -> [a] -> [a]+substituteNaive as_ bs_ = +  case head as of+    0 -> [ f n | n<-[0..] ]+    _ -> error "PowerSeries/substituteNaive: we expect the the constant term of the inner series to be zero"+  where+    as = as_ ++ repeat 0+    bs = bs_ ++ repeat 0+    a i = as !! i+    b j = bs !! j+    f n = sum+            [ b m * product [ (a i)^j | (i,j)<-es ] * fromInteger (multinomial (map snd es))+            | p <- partitions n +            , let es = toExponentialForm p+            , let m  = partitionWidth    p+            ]++--------------------------------------------------------------------------------+-- * Lagrange inversions++-- | We expect the input series to match @(0:a1:_)@. with a1 nonzero The following is true for the result (at least with exact arithmetic):+--+-- > substitute f (lagrangeInversion f) == (0 : 1 : repeat 0)+-- > substitute (lagrangeInversion f) f == (0 : 1 : repeat 0)+--+-- This implementation is taken from:+--+-- M. Douglas McIlroy: Power Series, Power Serious +lagrangeInversion :: (Eq a, Fractional a) => [a] -> [a]+lagrangeInversion xs = go (xs ++ repeat 0) where+  go (0:fs) = rs where rs = 0 : divSeries unitSeries (composeSeries fs rs)+  go (_:fs) = error "lagrangeInversion: the series should start with (0 + a1*x + a2*x^2 + ...) where a1 is non-zero"++-- | Coefficients of the Lagrange inversion+lagrangeCoeff :: Partition -> Integer+lagrangeCoeff p = div numer denom where+  numer = (-1)^m * product (map fromIntegral [n+1..n+m])+  denom = fromIntegral (n+1) * product (map (factorial . snd) es)+  m  = partitionWidth    p+  n  = partitionWeight   p+  es = toExponentialForm p++-- | We expect the input series to match @(0:1:_)@. The following is true for the result (at least with exact arithmetic):+--+-- > substitute f (integralLagrangeInversion f) == (0 : 1 : repeat 0)+-- > substitute (integralLagrangeInversion f) f == (0 : 1 : repeat 0)+--+integralLagrangeInversionNaive :: (Eq a, Num a) => [a] -> [a]+integralLagrangeInversionNaive series_ = +  case series of+    (0:1:rest) -> 0 : 1 : [ f n | n<-[1..] ]+    _ -> error "integralLagrangeInversionNaive: the series should start with (0 + x + a2*x^2 + ...)"+  where+    series = series_ ++ repeat 0+    as  = tail series +    a i = as !! i+    f n = sum [ fromInteger (lagrangeCoeff p) * product [ (a i)^j | (i,j) <- toExponentialForm p ]+              | p <- partitions n+              ] ++-- | Naive implementation of 'lagrangeInversion'+lagrangeInversionNaive :: (Eq a, Fractional a) => [a] -> [a]+lagrangeInversionNaive series_ = +  case series of+    (0:a1:rest) -> if a1 ==0 +      then err +      else 0 : (1/a1) : [ f n / a1^(n+1) | n<-[1..] ]+    _ -> err+  where+    err    = error "lagrangeInversionNaive: the series should start with (0 + a1*x + a2*x^2 + ...) where a1 is non-zero"+    series = series_ ++ repeat 0+    a1  = series !! 1+    as  = map (/a1) (tail series)+    a i = as !! i+    f n = sum [ fromInteger (lagrangeCoeff p) * product [ (a i)^j | (i,j) <- toExponentialForm p ]+              | p <- partitions n+              ] +++--------------------------------------------------------------------------------+-- * Differentiation and integration++differentiateSeries :: Num a => [a] -> [a]+differentiateSeries (y:ys) = go (1::Int) ys where+  go !n (x:xs) = fromIntegral n * x : go (n+1) xs+  go _  []     = []++integrateSeries :: Fractional a => [a] -> [a]+integrateSeries ys = 0 : go (1::Int) ys where+  go !n (x:xs) = x / (fromIntegral n) : go (n+1) xs+  go _  []     = []++--------------------------------------------------------------------------------+-- * Power series expansions of elementary functions++-- | Power series expansion of @exp(x)@+expSeries :: Fractional a => [a]+expSeries = go 0 1 where+  go i e = e : go (i+1) (e / (i+1))++-- | Power series expansion of @cos(x)@+cosSeries :: Fractional a => [a]+cosSeries = go 0 1 where+  go i e = e : 0 : go (i+2) (-e / ((i+1)*(i+2)))++-- | Power series expansion of @sin(x)@+sinSeries :: Fractional a => [a]+sinSeries = go 1 1 where+  go i e = 0 : e : go (i+2) (-e / ((i+1)*(i+2)))++-- | Alternative implementation using differential equations.+--+-- Taken from: M. Douglas McIlroy: Power Series, Power Serious+cosSeries2, sinSeries2 :: Fractional a => [a]+cosSeries2 = unitSeries `subSeries` integrateSeries sinSeries2+sinSeries2 =                        integrateSeries cosSeries2++-- | Power series expansion of @cosh(x)@+coshSeries :: Fractional a => [a]+coshSeries = go 0 1 where+  go i e = e : 0 : go (i+2) (e / ((i+1)*(i+2)))++-- | Power series expansion of @sinh(x)@+sinhSeries :: Fractional a => [a]+sinhSeries = go 1 1 where+  go i e = 0 : e : go (i+2) (e / ((i+1)*(i+2)))++-- | Power series expansion of @log(1+x)@+log1Series :: Fractional a => [a]+log1Series = 0 : go 1 1 where+  go i e = (e/i) : go (i+1) (-e)++-- | Power series expansion of @(1-Sqrt[1-4x])/(2x)@ (the coefficients are the Catalan numbers)+dyckSeries :: Num a => [a]+dyckSeries = [ fromInteger (catalan i) | i<-[(0::Int)..] ]++--------------------------------------------------------------------------------+-- * \"Coin\" series++-- | Power series expansion of +-- +-- > 1 / ( (1-x^k_1) * (1-x^k_2) * ... * (1-x^k_n) )+--+-- Example:+--+-- @(coinSeries [2,3,5])!!k@ is the number of ways +-- to pay @k@ dollars with coins of two, three and five dollars.+--+-- TODO: better name?+coinSeries :: [Int] -> [Integer]+coinSeries [] = 1 : repeat 0+coinSeries (k:ks) = xs where+  xs = zipWith (+) (coinSeries ks) (replicate k 0 ++ xs) ++-- | Generalization of the above to include coefficients: expansion of +--  +-- > 1 / ( (1-a_1*x^k_1) * (1-a_2*x^k_2) * ... * (1-a_n*x^k_n) ) +-- +coinSeries' :: Num a => [(a,Int)] -> [a]+coinSeries' [] = 1 : repeat 0+coinSeries' ((a,k):aks) = xs where+  xs = zipWith (+) (coinSeries' aks) (replicate k 0 ++ map (*a) xs) ++convolveWithCoinSeries :: [Int] -> [Integer] -> [Integer]+convolveWithCoinSeries ks series1 = worker ks where+  series = series1 ++ repeat 0+  worker [] = series+  worker (k:ks) = xs where+    xs = zipWith (+) (worker ks) (replicate k 0 ++ xs)++convolveWithCoinSeries' :: Num a => [(a,Int)] -> [a] -> [a]+convolveWithCoinSeries' ks series1 = worker ks where+  series = series1 ++ repeat 0+  worker [] = series+  worker ((a,k):aks) = xs where+    xs = zipWith (+) (worker aks) (replicate k 0 ++ map (*a) xs)++--------------------------------------------------------------------------------+-- * Reciprocals of products of polynomials++-- | Convolution of many 'pseries', that is, the expansion of the reciprocal+-- of a product of polynomials+productPSeries :: [[Int]] -> [Integer]+productPSeries = foldl (flip convolveWithPSeries) unitSeries++-- | The same, with coefficients.+productPSeries' :: Num a => [[(a,Int)]] -> [a]+productPSeries' = foldl (flip convolveWithPSeries') unitSeries++convolveWithProductPSeries :: [[Int]] -> [Integer] -> [Integer]+convolveWithProductPSeries kss ser = foldl (flip convolveWithPSeries) ser kss++-- | This is the most general function in this module; all the others+-- are special cases of this one.  +convolveWithProductPSeries' :: Num a => [[(a,Int)]] -> [a] -> [a] +convolveWithProductPSeries' akss ser = foldl (flip convolveWithPSeries') ser akss+  +--------------------------------------------------------------------------------+-- * Reciprocals of polynomials++-- Reciprocals of polynomials, without coefficients++-- | The power series expansion of +--+-- > 1 / (1 - x^k_1 - x^k_2 - x^k_3 - ... - x^k_n)+--+pseries :: [Int] -> [Integer]+pseries ks = convolveWithPSeries ks unitSeries++-- | Convolve with (the expansion of) +--+-- > 1 / (1 - x^k_1 - x^k_2 - x^k_3 - ... - x^k_n)+--+convolveWithPSeries :: [Int] -> [Integer] -> [Integer]+convolveWithPSeries ks series1 = ys where +  series = series1 ++ repeat 0 +  ys = worker ks ys +  worker [] _ = series +  worker (k:ks) ys = xs where+    xs = zipWith (+) (replicate k 0 ++ ys) (worker ks ys)++--------------------------------------------------------------------------------+--  Reciprocals of polynomials, with coefficients++-- | The expansion of +--+-- > 1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3 - ... - a_n*x^k_n)+--+pseries' :: Num a => [(a,Int)] -> [a]+pseries' aks = convolveWithPSeries' aks unitSeries++-- | Convolve with (the expansion of) +--+-- > 1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3 - ... - a_n*x^k_n)+--+convolveWithPSeries' :: Num a => [(a,Int)] -> [a] -> [a]+convolveWithPSeries' aks series1 = ys where +  series = series1 ++ repeat 0 +  ys = worker aks ys +  worker [] _ = series+  worker ((a,k):aks) ys = xs where+    xs = zipWith (+) (replicate k 0 ++ map (*a) ys) (worker aks ys)++{-+data Sign = Plus | Minus deriving (Eq,Show)++signValue :: Num a => Sign -> a+signValue Plus  =  1+signValue Minus = -1+-}++signedPSeries :: [(Sign,Int)] -> [Integer] +signedPSeries aks = convolveWithSignedPSeries aks unitSeries++-- | Convolve with (the expansion of) +--+-- > 1 / (1 +- x^k_1 +- x^k_2 +- x^k_3 +- ... +- x^k_n)+--+-- Should be faster than using `convolveWithPSeries'`.+-- Note: 'Plus' corresponds to the coefficient @-1@ in `pseries'` (since+-- there is a minus sign in the definition there)!+convolveWithSignedPSeries :: [(Sign,Int)] -> [Integer] -> [Integer]+convolveWithSignedPSeries aks series1 = ys where +  series = series1 ++ repeat 0 +  ys = worker aks ys +  worker [] _ = series+  worker ((a,k):aks) ys = xs where+    xs = case a of+      Minus -> zipWith (+) one two +      Plus  -> zipWith (-) one two+    one = worker aks ys+    two = replicate k 0 ++ ys+     +--------------------------------------------------------------------------------++
+ src/Math/Combinat/Partitions.hs view
@@ -0,0 +1,22 @@++-- | Partitions of integers and multisets. +-- Integer partitions are nonincreasing sequences of positive integers.+--+-- See:+--+--  * Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 3B.+--+--  * <http://en.wikipedia.org/wiki/Partition_(number_theory)>+--++{-# LANGUAGE BangPatterns #-}+module Math.Combinat.Partitions+  ( module Math.Combinat.Partitions.Integer+  )+  where++--------------------------------------------------------------------------------++import Math.Combinat.Partitions.Integer++--------------------------------------------------------------------------------
+ src/Math/Combinat/Partitions/Integer.hs view
@@ -0,0 +1,459 @@++-- | Partitions of integers.+-- Integer partitions are nonincreasing sequences of positive integers.+--+-- See:+--+--  * Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 3B.+--+--  * <http://en.wikipedia.org/wiki/Partition_(number_theory)>+--+-- For example the partition+--+-- > Partition [8,6,3,3,1]+--+-- can be represented by the (English notation) Ferrers diagram:+--+-- <<svg/ferrers.svg>>+-- ++{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-}+module Math.Combinat.Partitions.Integer +  ( -- module Math.Combinat.Partitions.Integer.Count+    module Math.Combinat.Partitions.Integer.Naive+    -- * Types and basic stuff+  , Partition+    -- * Conversion to\/from lists+  , fromPartition +  , mkPartition +  , toPartition +  , toPartitionUnsafe +  , isPartition +    -- * Conversion to\/from exponent vectors+  , toExponentVector+  , fromExponentVector+  , dropTailingZeros+    -- * Union and sum+  , unionOfPartitions+  , sumOfPartitions+    -- * Generating partitions+  , partitions +  , partitions'+  , allPartitions +  , allPartitionsGrouped +  , allPartitions'  +  , allPartitionsGrouped'  +    -- * Counting partitions+  , countPartitions+  , countPartitions'+  , countAllPartitions+  , countAllPartitions'+  , countPartitionsWithKParts +    -- * Random partitions+  , randomPartition+  , randomPartitions+    -- * Dominating \/ dominated partitions+  , dominanceCompare+  , dominatedPartitions +  , dominatingPartitions +    -- * Conjugate lexicographic ordering+  , conjugateLexicographicCompare +  , ConjLex (..) , fromConjLex +    -- * Partitions with given number of parts+  , partitionsWithKParts+    -- * Partitions with only odd\/distinct parts+  , partitionsWithOddParts +  , partitionsWithDistinctParts+    -- * Sub- and super-partitions of a given partition+  , subPartitions +  , allSubPartitions +  , superPartitions +    -- * ASCII Ferrers diagrams+  , PartitionConvention(..)+  , asciiFerrersDiagram +  , asciiFerrersDiagram'+  )+  where++--------------------------------------------------------------------------------++import Data.List+import Control.Monad ( liftM , replicateM )++-- import Data.Map (Map)+-- import qualified Data.Map as Map++import Math.Combinat.Classes+import Math.Combinat.ASCII as ASCII+import Math.Combinat.Numbers (factorial,binomial,multinomial)+import Math.Combinat.Helper++import Data.Array+import System.Random++import Math.Combinat.Partitions.Integer.Naive hiding ()    -- this is for haddock!+import Math.Combinat.Partitions.Integer.IntList+import Math.Combinat.Partitions.Integer.Count++---------------------------------------------------------------------------------+-- * Conversion to\/from lists++fromPartition :: Partition -> [Int]+fromPartition (Partition_ part) = part+  +-- | Sorts the input, and cuts the nonpositive elements.+mkPartition :: [Int] -> Partition+mkPartition xs = toPartitionUnsafe $ sortBy (reverseCompare) $ filter (>0) xs++-- | Checks whether the input is an integer partition. See the note at 'isPartition'!+toPartition :: [Int] -> Partition+toPartition xs = if isPartition xs+  then toPartitionUnsafe xs+  else error "toPartition: not a partition"++-- | Assumes that the input is decreasing.+toPartitionUnsafe :: [Int] -> Partition+toPartitionUnsafe = Partition_+  +-- | This returns @True@ if the input is non-increasing sequence of +-- /positive/ integers (possibly empty); @False@ otherwise.+--+isPartition :: [Int] -> Bool+isPartition []  = True+isPartition [x] = x > 0+isPartition (x:xs@(y:_)) = (x >= y) && isPartition xs++--------------------------------------------------------------------------------+-- * Conversion to\/from exponent vectors+     +-- | Converts a partition to an exponent vector.+--+-- For example, +--+-- > toExponentVector (Partition [4,4,2,2,2,1]) == [1,3,0,2]+--+-- meaning @(1^1,2^3,3^0,4^2)@.+--+toExponentVector :: Partition -> [Int]+toExponentVector part = fun 1 $ reverse $ group (fromPartition part) where+  fun _  [] = []+  fun !k gs@(this@(i:_):rest) +    | k < i      = replicate (i-k) 0 ++ fun i gs+    | otherwise  = length this : fun (k+1) rest++fromExponentVector :: [Int] -> Partition+fromExponentVector expos = Partition $ concat $ reverse $ zipWith f [1..] expos where+  f !i !e = replicate e i++dropTailingZeros :: [Int] -> [Int]+dropTailingZeros = reverse . dropWhile (==0) . reverse++{-+-- alternative implementation+toExponentialVector2 :: Partition -> [Int]+toExponentialVector2 p = go 1 (toExponentialForm p) where+  go _  []              = []+  go !i ef@((j,e):rest) = if i<j +    then 0 : go (i+1) ef+    else e : go (i+1) rest+-}++--------------------------------------------------------------------------------+-- * Union and sum++-- | This is simply the union of parts. For example +--+-- > Partition [4,2,1] `unionOfPartitions` Partition [4,3,1] == Partition [4,4,3,2,1,1]+--+-- Note: This is the dual of pointwise sum, 'sumOfPartitions'+--+unionOfPartitions :: Partition -> Partition -> Partition +unionOfPartitions (Partition_ xs) (Partition_ ys) = mkPartition (xs ++ ys)++-- | Pointwise sum of the parts. For example:+--+-- > Partition [3,2,1,1] `sumOfPartitions` Partition [4,3,1] == Partition [7,5,2,1]+--+-- Note: This is the dual of 'unionOfPartitions'+--+sumOfPartitions :: Partition -> Partition -> Partition +sumOfPartitions (Partition_ xs) (Partition_ ys) = Partition_ (longZipWith 0 0 (+) xs ys)++--------------------------------------------------------------------------------+-- * Generating partitions++-- | Partitions of @d@.+partitions :: Int -> [Partition]+partitions = map toPartitionUnsafe . _partitions++-- | Partitions of d, fitting into a given rectangle. The order is again lexicographic.+partitions'  +  :: (Int,Int)     -- ^ (height,width)+  -> Int           -- ^ d+  -> [Partition]+partitions' hw d = map toPartitionUnsafe $ _partitions' hw d        ++--------------------------------------------------------------------------------++-- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@)+allPartitions :: Int -> [Partition]+allPartitions d = concat [ partitions i | i <- [0..d] ]++-- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@),+-- grouped by weight+allPartitionsGrouped :: Int -> [[Partition]]+allPartitionsGrouped d = [ partitions i | i <- [0..d] ]++-- | All integer partitions fitting into a given rectangle.+allPartitions'  +  :: (Int,Int)        -- ^ (height,width)+  -> [Partition]+allPartitions' (h,w) = concat [ partitions' (h,w) i | i <- [0..d] ] where d = h*w++-- | All integer partitions fitting into a given rectangle, grouped by weight.+allPartitionsGrouped'  +  :: (Int,Int)        -- ^ (height,width)+  -> [[Partition]]+allPartitionsGrouped' (h,w) = [ partitions' (h,w) i | i <- [0..d] ] where d = h*w+++---------------------------------------------------------------------------------+-- * Random partitions++-- | Uniformly random partition of the given weight. +--+-- NOTE: This algorithm is effective for small @n@-s (say @n@ up to a few hundred \/ one thousand it should work nicely),+-- and the first time it is executed may be slower (as it needs to build the table of partitions counts first)+--+-- Algorithm of Nijenhuis and Wilf (1975); see+--+-- * Knuth Vol 4A, pre-fascicle 3B, exercise 47;+--+-- * Nijenhuis and Wilf: Combinatorial Algorithms for Computers and Calculators, chapter 10+--+randomPartition :: RandomGen g => Int -> g -> (Partition, g)+randomPartition n g = (p, g') where+  ([p], g') = randomPartitions 1 n g++-- | Generates several uniformly random partitions of @n@ at the same time.+-- Should be a little bit faster then generating them individually.+--+randomPartitions +  :: forall g. RandomGen g +  => Int   -- ^ number of partitions to generate+  -> Int   -- ^ the weight of the partitions+  -> g -> ([Partition], g)+randomPartitions howmany n = runRand $ replicateM howmany (worker n []) where++  cnt = countPartitions+ +  finish :: [(Int,Int)] -> Partition+  finish = mkPartition . concatMap f where f (j,d) = replicate j d++  fi :: Int -> Integer +  fi = fromIntegral++  find_jd :: Int -> Integer -> (Int,Int)+  find_jd m capm = go 0 [ (j,d) | j<-[1..n], d<-[1..div m j] ] where+    go :: Integer -> [(Int,Int)] -> (Int,Int)+    go !s []   = (1,1)       -- ??+    go !s [jd] = jd          -- ??+    go !s (jd@(j,d):rest) = +      if s' > capm +        then jd +        else go s' rest+      where+        s' = s + fi d * cnt (m - j*d)++  worker :: Int -> [(Int,Int)] -> Rand g Partition+  worker  0 acc = return $ finish acc+  worker !m acc = do+    capm <- randChoose (0, (fi m) * cnt m - 1)+    let jd@(!j,!d) = find_jd m capm+    worker (m - j*d) (jd:acc)++--------------------------------------------------------------------------------+-- * Dominating \/ dominated partitions++-- | Dominance partial ordering as a partial ordering.+dominanceCompare :: Partition -> Partition -> Maybe Ordering+dominanceCompare p q  +  | p==q             = Just EQ+  | p `dominates` q  = Just GT+  | q `dominates` p  = Just LT+  | otherwise        = Nothing++-- | Lists all partitions of the same weight as @lambda@ and also dominated by @lambda@+-- (that is, all partial sums are less or equal):+--+-- > dominatedPartitions lam == [ mu | mu <- partitions (weight lam), lam `dominates` mu ]+-- +dominatedPartitions :: Partition -> [Partition]    +dominatedPartitions (Partition_ lambda) = map Partition_ (_dominatedPartitions lambda)++-- | Lists all partitions of the sime weight as @mu@ and also dominating @mu@+-- (that is, all partial sums are greater or equal):+--+-- > dominatingPartitions mu == [ lam | lam <- partitions (weight mu), lam `dominates` mu ]+-- +dominatingPartitions :: Partition -> [Partition]    +dominatingPartitions (Partition_ mu) = map Partition_ (_dominatingPartitions mu)++--------------------------------------------------------------------------------+-- * Conjugate lexicographic ordering++conjugateLexicographicCompare :: Partition -> Partition -> Ordering+conjugateLexicographicCompare p q = compare (dualPartition q) (dualPartition p) ++newtype ConjLex = ConjLex Partition deriving (Eq,Show)++fromConjLex :: ConjLex -> Partition+fromConjLex (ConjLex p) = p++instance Ord ConjLex where+  compare (ConjLex p) (ConjLex q) = conjugateLexicographicCompare p q++-- {- CONJUGATE LEXICOGRAPHIC ordering is a refinement of dominance partial ordering -}+-- let test n = [ ConjLex p >= ConjLex q | p <- partitions n , q <-partitions n ,  p `dominates` q ]+-- and (test 20)++-- {- LEXICOGRAPHIC ordering is a refinement of dominance partial ordering -}+-- let test n = [ p >= q | p <- partitions n , q <-partitions n ,  p `dominates` q ]+-- and (test 20)++--------------------------------------------------------------------------------+-- * Partitions with given number of parts++-- | Lists partitions of @n@ into @k@ parts.+--+-- > sort (partitionsWithKParts k n) == sort [ p | p <- partitions n , numberOfParts p == k ]+--+-- Naive recursive algorithm.+--+partitionsWithKParts +  :: Int    -- ^ @k@ = number of parts+  -> Int    -- ^ @n@ = the integer we partition+  -> [Partition]+partitionsWithKParts k n = map Partition_ $ go n k n where+{-+  h = max height+  k = number of parts+  n = integer+-}+  go !h !k !n +    | k <  0     = []+    | k == 0     = if h>=0 && n==0 then [[] ] else []+    | k == 1     = if h>=n && n>=1 then [[n]] else []+    | otherwise  = [ a:p | a <- [1..(min h (n-k+1))] , p <- go a (k-1) (n-a) ]++--------------------------------------------------------------------------------+-- * Partitions with only odd\/distinct parts++-- | Partitions of @n@ with only odd parts+partitionsWithOddParts :: Int -> [Partition]+partitionsWithOddParts d = map Partition_ (go d d) where+  go _  0  = [[]]+  go !h !n = [ a:as | a<-[1,3..min n h], as <- go a (n-a) ]++{-+-- | Partitions of @n@ with only even parts+--+-- Note: this is not very interesting, it's just @(map.map) (2*) $ _partitions (div n 2)@+--+partitionsWithEvenParts :: Int -> [Partition]+partitionsWithEvenParts d = map Partition (go d d) where+  go _  0  = [[]]+  go !h !n = [ a:as | a<-[2,4..min n h], as <- go a (n-a) ]+-}++-- | Partitions of @n@ with distinct parts.+-- +-- Note:+--+-- > length (partitionsWithDistinctParts d) == length (partitionsWithOddParts d)+--+partitionsWithDistinctParts :: Int -> [Partition]+partitionsWithDistinctParts d = map Partition_ (go d d) where+  go _  0  = [[]]+  go !h !n = [ a:as | a<-[1..min n h], as <- go (a-1) (n-a) ]++--------------------------------------------------------------------------------+-- * Sub- and super-partitions of a given partition++-- | Sub-partitions of a given partition with the given weight:+--+-- > sort (subPartitions d q) == sort [ p | p <- partitions d, isSubPartitionOf p q ]+--+subPartitions :: Int -> Partition -> [Partition]+subPartitions d (Partition_ ps) = map Partition_ (_subPartitions d ps)++-- | All sub-partitions of a given partition+allSubPartitions :: Partition -> [Partition]+allSubPartitions (Partition_ ps) = map Partition_ (_allSubPartitions ps)++-- | Super-partitions of a given partition with the given weight:+--+-- > sort (superPartitions d p) == sort [ q | q <- partitions d, isSubPartitionOf p q ]+--+superPartitions :: Int -> Partition -> [Partition]+superPartitions d (Partition_ ps) = map toPartitionUnsafe (_superPartitions d ps)+    ++--------------------------------------------------------------------------------+-- * ASCII Ferrers diagrams++-- | Which orientation to draw the Ferrers diagrams.+-- For example, the partition [5,4,1] corrsponds to:+--+-- In standard English notation:+-- +-- >  @@@@@+-- >  @@@@+-- >  @+--+--+-- In English notation rotated by 90 degrees counter-clockwise:+--+-- > @  +-- > @@+-- > @@+-- > @@+-- > @@@+--+--+-- And in French notation:+--+-- +-- >  @+-- >  @@@@+-- >  @@@@@+--+--+data PartitionConvention+  = EnglishNotation          -- ^ English notation+  | EnglishNotationCCW       -- ^ English notation rotated by 90 degrees counterclockwise+  | FrenchNotation           -- ^ French notation (mirror of English notation to the x axis)+  deriving (Eq,Show)++-- | Synonym for @asciiFerrersDiagram\' EnglishNotation \'\@\'@+--+-- Try for example:+--+-- > autoTabulate RowMajor (Right 8) (map asciiFerrersDiagram $ partitions 9)+--+asciiFerrersDiagram :: Partition -> ASCII+asciiFerrersDiagram = asciiFerrersDiagram' EnglishNotation '@'++asciiFerrersDiagram' :: PartitionConvention -> Char -> Partition -> ASCII+asciiFerrersDiagram' conv ch part = ASCII.asciiFromLines (map f ys) where+  f n = replicate n ch +  ys  = case conv of+          EnglishNotation    -> fromPartition part+          EnglishNotationCCW -> reverse $ fromPartition $ dualPartition part+          FrenchNotation     -> reverse $ fromPartition $ part++instance DrawASCII Partition where+  ascii = asciiFerrersDiagram++--------------------------------------------------------------------------------+
+ src/Math/Combinat/Partitions/Integer/Compact.hs view
@@ -0,0 +1,355 @@++{- | 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 Eq++instance Show Partition where+  showsPrec = showsPrecPartition++showsPrecPartition :: Int -> Partition -> ShowS+showsPrecPartition prec (Partition vec)+  = showParen (prec > 10) +  $ showString "Partition"+  . showChar ' ' +  . shows (V.toList vec)++instance Ord Partition where+  compare = cmpLexico+               +--------------------------------------------------------------------------------+-- * 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+cmpLexico :: Partition -> Partition -> Ordering+cmpLexico (Partition vec1) (Partition vec2) = compare (V.toList vec1) (V.toList vec2)++--------------------------------------------------------------------------------+-- * Basic (de)constructrion++empty :: Partition+empty = Partition (V.empty)++isEmpty :: Partition -> Bool+isEmpty (Partition vec) = V.null vec++--------------------------------------------------------------------------------++singleton :: Int -> Partition+singleton x +  | x >  0     = Partition (V.singleton $ i2w x)+  | x == 0     = empty+  | otherwise  = error "Parittion/singleton: negative input"++--------------------------------------------------------------------------------++uncons :: Partition -> Maybe (Int,Partition)+uncons (Partition vec) = case V.uncons vec of+  Nothing     -> Nothing+  Just (h,tl) -> Just (w2i h, Partition tl)++-- | @partitionTail p == snd (uncons p)@+partitionTail :: Partition -> Partition+partitionTail (Partition vec) = Partition (V.tail vec)++-------------------------------------------------------------------------------++-- | We assume that @x >= partitionHeight p@!+cons :: Int -> Partition -> Partition+cons !x (Partition !vec) +  | V.null vec = Partition (if x > 0 then V.singleton y else V.empty) +  | y >= h     = Partition (V.cons y vec)+  | otherwise  = error "Partition/cons: invalid element to cons"+  where  +    y = i2w x+    h = V.head vec++--------------------------------------------------------------------------------++-- | We assume that the element is not bigger than the last element!+snoc :: Partition -> Int -> Partition+snoc (Partition !vec) !x+  | x == 0           = Partition vec+  | V.null vec       = Partition (V.singleton y)+  | y <= V.last vec  = Partition (V.snoc vec y)+  | otherwise        = error "Partition/snoc: invalid element to snoc"+  where+    y = i2w 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 (Partition vec) = V.vecLen vec++-- | Height, or the first (that is, the largest) element+height :: Partition -> Int+height (Partition vec) = w2i (V.head vec)++-- | Width and height +widthHeight :: Partition -> (Int,Int)+widthHeight (Partition vec) = (V.vecLen vec , w2i (V.head 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 = go . toDescList 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 p = go (0 : toAscList p) where+  go (x:ys@(y:_)) = (y-x) : go ys +  go [x] = []+  go []  = []++--------------------------------------------------------------------------------+-- *  Dual partition++dualPartition :: Partition -> Partition+dualPartition compact@(Partition vec) +  | V.null vec  = Partition V.empty+  | otherwise   = Partition (V.fromList' shape $ map i2w dual)+  where+    height = V.head   vec+    len    = V.vecLen vec+    shape  = Shape (w2i height) (V.bitsNeededFor $ i2w len)+    dual   = concat+      [ replicate d j+      | (j,d) <- zip (descendToOne len) (reverseDiffSequence compact)+      ]++--------------------------------------------------------------------------------+-- * Conversion to list++toList :: Partition -> [Int]+toList = toDescList++-- | returns a descending (non-increasing) list+toDescList :: Partition -> [Int]+toDescList (Partition vec) = map w2i (V.toList vec)++-- | Returns a reversed (ascending; non-decreasing) list+toAscList :: Partition -> [Int]+toAscList (Partition vec) = map w2i (V.toRevList vec)++--------------------------------------------------------------------------------+-- * 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' !len !list = Partition (V.fromList' (Shape len bits) $ map i2w list) where+  bits = case list of+    []     -> 4+    (x:xs) -> V.bitsNeededFor (i2w x)++--------------------------------------------------------------------------------+-- * Partial orderings++-- @ |p `isSubPartitionOf` q@+isSubPartitionOf :: Partition -> Partition -> Bool+isSubPartitionOf p q = and $ zipWith (<=) (toList p) (toList q ++ repeat 0)++-- | @q `dominates` p@+dominates :: Partition -> Partition -> Bool+dominates (Partition vec_q) (Partition vec_p) = and $ zipWith (>=) (sums (qs ++ repeat 0)) (sums ps) where +  sums = tail . scanl' (+) 0+  ps = V.toList vec_p+  qs = V.toList 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 = error "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 = fromIntegral++{-# INLINE w2i #-}+w2i :: Word -> Int+w2i = fromIntegral++{-# INLINE sum' #-}+sum' :: [Word] -> Word+sum' = foldl' (+) 0++{-# INLINE safeTail #-}+safeTail :: [Int] -> [Int]+safeTail xs = case xs of { [] -> [] ; _ -> tail xs }++{-# INLINE descendToZero #-}+descendToZero :: Int -> [Int]+descendToZero !n+  | n >  0  = n : descendToZero (n-1) +  | n == 0  = [0]+  | n <  0  = []++{-# INLINE descendToOne #-}+descendToOne :: Int -> [Int]+descendToOne !n+  | n >  1  = n : descendToOne (n-1) +  | n == 1  = [1]+  | n <  1  = []++--------------------------------------------------------------------------------++
+ src/Math/Combinat/Partitions/Integer/Count.hs view
@@ -0,0 +1,215 @@++-- | Counting partitions of integers.++{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-}+module Math.Combinat.Partitions.Integer.Count where++--------------------------------------------------------------------------------++import Data.List+import Control.Monad ( liftM , replicateM )++-- import Data.Map (Map)+-- import qualified Data.Map as Map++import Math.Combinat.Numbers ( factorial , binomial , multinomial )+import Math.Combinat.Numbers.Integers -- Primes+import Math.Combinat.Helper++import Data.Array+import System.Random++--------------------------------------------------------------------------------+-- * Infinite tables of integers++-- | A data structure which is essentially an infinite list of @Integer@-s,+-- but fast lookup (for reasonable small inputs)+newtype TableOfIntegers = TableOfIntegers [Array Int Integer]++lookupInteger :: TableOfIntegers -> Int -> Integer+lookupInteger (TableOfIntegers table) !n +  | n >= 0  = (table !! k) ! r+  | n <  0  = 0+  where+    (k,r) = divMod n 1024++makeTableOfIntegers+  :: ((Int -> Integer) -> (Int -> Integer))+  -> TableOfIntegers+makeTableOfIntegers user = table where+  calc  = user lkp+  lkp   = lookupInteger table+  table = TableOfIntegers+    [ listArray (0,1023) (map calc [a..b]) +    | k<-[0..] +    , let a = 1024*k +    , let b = 1024*(k+1) - 1 +    ]++--------------------------------------------------------------------------------+-- * Counting partitions++-- | Number of partitions of @n@ (looking up a table built using Euler's algorithm)+countPartitions :: Int -> Integer+countPartitions = lookupInteger partitionCountTable ++-- | This uses the power series expansion of the infinite product. It is slower than the above.+countPartitionsInfiniteProduct :: Int -> Integer+countPartitionsInfiniteProduct k = partitionCountListInfiniteProduct !! k++-- | This uses 'countPartitions'', and is (very) slow+countPartitionsNaive :: Int -> Integer+countPartitionsNaive d = countPartitions' (d,d) d++--------------------------------------------------------------------------------++-- | This uses Euler's algorithm to compute p(n)+--+-- See eg.:+-- NEIL CALKIN, JIMENA DAVIS, KEVIN JAMES, ELIZABETH PEREZ, AND CHARLES SWANNACK+-- COMPUTING THE INTEGER PARTITION FUNCTION+-- <http://www.math.clemson.edu/~kevja/PAPERS/ComputingPartitions-MathComp.pdf>+--+partitionCountTable :: TableOfIntegers+partitionCountTable = table where++  table = makeTableOfIntegers fun++  fun lkp !n +    | n >  1 = foldl' (+) 0 +             [ (if even k then negate else id) +                 ( lkp (n - div (k*(3*k+1)) 2)+                 + lkp (n - div (k*(3*k-1)) 2)+                 )+             | k <- [1..limit n]+             ]+    | n <  0 = 0+    | n == 0 = 1+    | n == 1 = 1++  limit :: Int -> Int+  limit !n = fromInteger $ ceilingSquareRoot (1 + div (nn+nn+1) 3) where+    nn = fromIntegral n :: Integer++-- | An infinite list containing all @p(n)@, starting from @p(0)@.+partitionCountList :: [Integer]+partitionCountList = map countPartitions [0..]++--------------------------------------------------------------------------------++-- | Infinite list of number of partitions of @0,1,2,...@+--+-- This uses the infinite product formula the generating function of partitions, +-- recursively expanding it; it is reasonably fast for small numbers.+--+-- > partitionCountListInfiniteProduct == map countPartitions [0..]+--+partitionCountListInfiniteProduct :: [Integer]+partitionCountListInfiniteProduct = final where++  final = go 1 (1:repeat 0) ++  go !k (x:xs) = x : go (k+1) ys where+    ys = zipWith (+) xs (take k final ++ ys)+    -- explanation:+    --   xs == drop k $ f (k-1)+    --   ys == drop k $ f (k  )  ++{-++Full explanation of 'partitionCountList':+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++let f k = productPSeries $ map (:[]) [1..k]++f 0 = [1,0,0,0,0,0,0,0...]+f 1 = [1,1,1,1,1,1,1,1...]+f 2 = [1,1,2,2,3,3,4,4...]+f 3 = [1,1,2,3,4,5,7,8...]++observe: ++* take (k+1) (f k) == take (k+1) partitionCountList+* f (k+1) == zipWith (+) (f k) (replicate (k+1) 0 ++ f (k+1))++now apply (drop (k+1)) to the second one : ++* drop (k+1) (f (k+1)) == zipWith (+) (drop (k+1) $ f k) (f (k+1))+* f (k+1) = take (k+1) final ++ drop (k+1) (f (k+1))++-}++--------------------------------------------------------------------------------++-- | Naive infinite list of number of partitions of @0,1,2,...@+--+-- > partitionCountListNaive == map countPartitionsNaive [0..]+--+-- This is very slow.+--+partitionCountListNaive :: [Integer]+partitionCountListNaive = map countPartitionsNaive [0..]++--------------------------------------------------------------------------------+-- * Counting all partitions++countAllPartitions :: Int -> Integer+countAllPartitions d = sum' [ countPartitions i | i <- [0..d] ]++-- | Count all partitions fitting into a rectangle.+-- # = \\binom { h+w } { h }+countAllPartitions' :: (Int,Int) -> Integer+countAllPartitions' (h,w) = +  binomial (h+w) (min h w)+  --sum [ countPartitions' (h,w) i | i <- [0..d] ] where d = h*w++--------------------------------------------------------------------------------+-- * Counting fitting into a rectangle++-- | Number of of d, fitting into a given rectangle. Naive recursive algorithm.+countPartitions' :: (Int,Int) -> Int -> Integer+countPartitions' _ 0 = 1+countPartitions' (0,_) d = if d==0 then 1 else 0+countPartitions' (_,0) d = if d==0 then 1 else 0+countPartitions' (h,w) d = sum+  [ countPartitions' (i,w-1) (d-i) | i <- [1..min d h] ] ++--------------------------------------------------------------------------------+-- * Partitions with given number of parts++-- | Count partitions of @n@ into @k@ parts.+--+-- Naive recursive algorithm.+--+countPartitionsWithKParts +  :: Int    -- ^ @k@ = number of parts+  -> Int    -- ^ @n@ = the integer we partition+  -> Integer+countPartitionsWithKParts k n = go n k n where+  go !h !k !n +    | k <  0     = 0+    | k == 0     = if h>=0 && n==0 then 1 else 0+    | k == 1     = if h>=n && n>=1 then 1 else 0+    | otherwise  = sum' [ go a (k-1) (n-a) | a<-[1..(min h (n-k+1))] ]++--------------------------------------------------------------------------------+-- Partitions with only odd\/distinct parts++{-+-- | Partitions of @n@ with only odd parts+partitionsWithOddParts :: Int -> [Partition]+partitionsWithOddParts d = map Partition (go d d) where+  go _  0  = [[]]+  go !h !n = [ a:as | a<-[1,3..min n h], as <- go a (n-a) ]+-}++{-+-- > length (partitionsWithDistinctParts d) == length (partitionsWithOddParts d)+--+partitionsWithDistinctParts :: Int -> [Partition]+partitionsWithDistinctParts d = map Partition (go d d) where+  go _  0  = [[]]+  go !h !n = [ a:as | a<-[1..min n h], as <- go (a-1) (n-a) ]+-}++--------------------------------------------------------------------------------
+ src/Math/Combinat/Partitions/Integer/IntList.hs view
@@ -0,0 +1,398 @@++-- | Partition functions working on lists of integers.+-- +-- It's not recommended to use this module directly.++{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-}+module Math.Combinat.Partitions.Integer.IntList where++--------------------------------------------------------------------------------++import Data.List+import Control.Monad ( liftM , replicateM )++import Math.Combinat.Numbers ( factorial , binomial , multinomial )+import Math.Combinat.Helper++import Data.Array+import System.Random++import Math.Combinat.Partitions.Integer.Count ( countPartitions )++--------------------------------------------------------------------------------+-- * Type and basic stuff++-- | Sorts the input, and cuts the nonpositive elements.+_mkPartition :: [Int] -> [Int]+_mkPartition xs = sortBy (reverseCompare) $ filter (>0) xs+ +-- | This returns @True@ if the input is non-increasing sequence of +-- /positive/ integers (possibly empty); @False@ otherwise.+--+_isPartition :: [Int] -> Bool+_isPartition []  = True+_isPartition [x] = x > 0+_isPartition (x:xs@(y:_)) = (x >= y) && _isPartition xs+++_dualPartition :: [Int] -> [Int]+_dualPartition [] = []+_dualPartition xs = go 0 (_diffSequence xs) [] where+  go !i (d:ds) acc = go (i+1) ds (d:acc)+  go n  []     acc = finish n acc +  finish !j (k:ks) = replicate k j ++ finish (j-1) ks+  finish _  []     = []++--------------------------------------------------------------------------------++{-+-- more variations:++_dualPartition_b :: [Int] -> [Int]+_dualPartition_b [] = []+_dualPartition_b xs = go 1 (diffSequence xs) [] where+  go !i (d:ds) acc = go (i+1) ds ((d,i):acc)+  go _  []     acc = concatMap (\(d,i) -> replicate d i) acc++_dualPartition_c :: [Int] -> [Int]+_dualPartition_c [] = []+_dualPartition_c xs = reverse $ concat $ zipWith f [1..] (diffSequence xs) where+  f _ 0 = []+  f k d = replicate d k+-}++-- | A simpler, but bit slower (about twice?) implementation of dual partition+_dualPartitionNaive :: [Int] -> [Int]+_dualPartitionNaive [] = []+_dualPartitionNaive xs@(k:_) = [ length $ filter (>=i) xs | i <- [1..k] ]++-- | From a sequence @[a1,a2,..,an]@ computes the sequence of differences+-- @[a1-a2,a2-a3,...,an-0]@+_diffSequence :: [Int] -> [Int]+_diffSequence = go where+  go (x:ys@(y:_)) = (x-y) : go ys +  go [x] = [x]+  go []  = []++-- | Example:+--+-- > _elements [5,4,1] ==+-- >   [ (1,1), (1,2), (1,3), (1,4), (1,5)+-- >   , (2,1), (2,2), (2,3), (2,4)+-- >   , (3,1)+-- >   ]+--++_elements :: [Int] -> [(Int,Int)]+_elements shape = [ (i,j) | (i,l) <- zip [1..] shape, j<-[1..l] ] ++---------------------------------------------------------------------------------+-- * Exponential form++-- | We convert a partition to exponential form.+-- @(i,e)@ mean @(i^e)@; for example @[(1,4),(2,3)]@ corresponds to @(1^4)(2^3) = [2,2,2,1,1,1,1]@. Another example:+--+-- > toExponentialForm (Partition [5,5,3,2,2,2,2,1,1]) == [(1,2),(2,4),(3,1),(5,2)]+--+_toExponentialForm :: [Int] -> [(Int,Int)]+_toExponentialForm = reverse . map (\xs -> (head xs,length xs)) . group++_fromExponentialForm :: [(Int,Int)] -> [Int]+_fromExponentialForm = sortBy reverseCompare . go where+  go ((j,e):rest) = replicate e j ++ go rest+  go []           = []   ++---------------------------------------------------------------------------------+-- * Generating partitions++-- | Partitions of @d@, as lists+_partitions :: Int -> [[Int]]+_partitions d = go d d where+  go _  0  = [[]]+  go !h !n = [ a:as | a<-[1..min n h], as <- go a (n-a) ]++-- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@)+_allPartitions :: Int -> [[Int]]+_allPartitions d = concat [ _partitions i | i <- [0..d] ]++-- | All integer partitions up to a given degree (that is, all integer partitions whose sum is less or equal to @d@),+-- grouped by weight+_allPartitionsGrouped :: Int -> [[[Int]]]+_allPartitionsGrouped d = [ _partitions i | i <- [0..d] ]++---------------------------------------------------------------------------------++-- | Integer partitions of @d@, fitting into a given rectangle, as lists.+_partitions' +  :: (Int,Int)     -- ^ (height,width)+  -> Int           -- ^ d+  -> [[Int]]        +_partitions' _ 0 = [[]] +_partitions' ( 0 , _) d = if d==0 then [[]] else []+_partitions' ( _ , 0) d = if d==0 then [[]] else []+_partitions' (!h ,!w) d = +  [ i:xs | i <- [1..min d h] , xs <- _partitions' (i,w-1) (d-i) ]++---------------------------------------------------------------------------------+-- * Random partitions++-- | Uniformly random partition of the given weight. +--+-- NOTE: This algorithm is effective for small @n@-s (say @n@ up to a few hundred \/ one thousand it should work nicely),+-- and the first time it is executed may be slower (as it needs to build the table 'partitionCountList' first)+--+-- Algorithm of Nijenhuis and Wilf (1975); see+--+-- * Knuth Vol 4A, pre-fascicle 3B, exercise 47;+--+-- * Nijenhuis and Wilf: Combinatorial Algorithms for Computers and Calculators, chapter 10+--+_randomPartition :: RandomGen g => Int -> g -> ([Int], g)+_randomPartition n g = (p, g') where+  ([p], g') = _randomPartitions 1 n g++-- | Generates several uniformly random partitions of @n@ at the same time.+-- Should be a little bit faster then generating them individually.+--+_randomPartitions +  :: forall g. RandomGen g +  => Int   -- ^ number of partitions to generate+  -> Int   -- ^ the weight of the partitions+  -> g -> ([[Int]], g)+_randomPartitions howmany n = runRand $ replicateM howmany (worker n []) where++  cnt = countPartitions+ +  finish :: [(Int,Int)] -> [Int]+  finish = _mkPartition . concatMap f where f (j,d) = replicate j d++  fi :: Int -> Integer +  fi = fromIntegral++  find_jd :: Int -> Integer -> (Int,Int)+  find_jd m capm = go 0 [ (j,d) | j<-[1..n], d<-[1..div m j] ] where+    go :: Integer -> [(Int,Int)] -> (Int,Int)+    go !s []   = (1,1)       -- ??+    go !s [jd] = jd          -- ??+    go !s (jd@(j,d):rest) = +      if s' > capm +        then jd +        else go s' rest+      where+        s' = s + fi d * cnt (m - j*d)++  worker :: Int -> [(Int,Int)] -> Rand g [Int]+  worker  0 acc = return $ finish acc+  worker !m acc = do+    capm <- randChoose (0, (fi m) * cnt m - 1)+    let jd@(!j,!d) = find_jd m capm+    worker (m - j*d) (jd:acc)+++---------------------------------------------------------------------------------+-- * Dominance order ++-- | @q \`dominates\` p@ returns @True@ if @q >= p@ in the dominance order of partitions+-- (this is partial ordering on the set of partitions of @n@).+--+-- See <http://en.wikipedia.org/wiki/Dominance_order>+--+_dominates :: [Int] -> [Int] -> Bool+_dominates qs ps+  = and $ zipWith (>=) (sums (qs ++ repeat 0)) (sums ps)+  where+    sums = scanl (+) 0++-- | Lists all partitions of the same weight as @lambda@ and also dominated by @lambda@+-- (that is, all partial sums are less or equal):+--+-- > dominatedPartitions lam == [ mu | mu <- partitions (weight lam), lam `dominates` mu ]+-- +_dominatedPartitions :: [Int] -> [[Int]]+_dominatedPartitions []     = [[]]+_dominatedPartitions lambda = go (head lambda) w dsums 0 where++  n = length lambda+  w = sum    lambda+  dsums = scanl1 (+) (lambda ++ repeat 0)++  go _   0 _       _  = [[]]+  go !h !w (!d:ds) !e  +    | w >  0  = [ (a:as) | a <- [1..min h (d-e)] , as <- go a (w-a) ds (e+a) ] +    | w == 0  = [[]]+    | w <  0  = error "_dominatedPartitions: fatal error; shouldn't happen"++-- | Lists all partitions of the sime weight as @mu@ and also dominating @mu@+-- (that is, all partial sums are greater or equal):+--+-- > dominatingPartitions mu == [ lam | lam <- partitions (weight mu), lam `dominates` mu ]+-- +_dominatingPartitions :: [Int] -> [[Int]]+_dominatingPartitions []     = [[]]+_dominatingPartitions mu     = go w w dsums 0 where++  n = length mu+  w = sum    mu+  dsums = scanl1 (+) (mu ++ repeat 0)++  go _   0 _       _  = [[]]+  go !h !w (!d:ds) !e  +    | w >  0  = [ (a:as) | a <- [max 0 (d-e)..min h w] , as <- go a (w-a) ds (e+a) ] +    | w == 0  = [[]]+    | w <  0  = error "_dominatingPartitions: fatal error; shouldn't happen"++--------------------------------------------------------------------------------+-- * Partitions with given number of parts++-- | Lists partitions of @n@ into @k@ parts.+--+-- > sort (partitionsWithKParts k n) == sort [ p | p <- partitions n , numberOfParts p == k ]+--+-- Naive recursive algorithm.+--+_partitionsWithKParts +  :: Int    -- ^ @k@ = number of parts+  -> Int    -- ^ @n@ = the integer we partition+  -> [[Int]]+_partitionsWithKParts k n = go n k n where+{-+  h = max height+  k = number of parts+  n = integer+-}+  go !h !k !n +    | k <  0     = []+    | k == 0     = if h>=0 && n==0 then [[] ] else []+    | k == 1     = if h>=n && n>=1 then [[n]] else []+    | otherwise  = [ a:p | a <- [1..(min h (n-k+1))] , p <- go a (k-1) (n-a) ]++--------------------------------------------------------------------------------+-- * Partitions with only odd\/distinct parts++-- | Partitions of @n@ with only odd parts+_partitionsWithOddParts :: Int -> [[Int]]+_partitionsWithOddParts d = (go d d) where+  go _  0  = [[]]+  go !h !n = [ a:as | a<-[1,3..min n h], as <- go a (n-a) ]++{-+-- | Partitions of @n@ with only even parts+--+-- Note: this is not very interesting, it's just @(map.map) (2*) $ _partitions (div n 2)@+--+_partitionsWithEvenParts :: Int -> [[Int]]+_partitionsWithEvenParts d = (go d d) where+  go _  0  = [[]]+  go !h !n = [ a:as | a<-[2,4..min n h], as <- go a (n-a) ]+-}++-- | Partitions of @n@ with distinct parts.+-- +-- Note:+--+-- > length (partitionsWithDistinctParts d) == length (partitionsWithOddParts d)+--+_partitionsWithDistinctParts :: Int -> [[Int]]+_partitionsWithDistinctParts d = (go d d) where+  go _  0  = [[]]+  go !h !n = [ a:as | a<-[1..min n h], as <- go (a-1) (n-a) ]++--------------------------------------------------------------------------------+-- * Sub- and super-partitions of a given partition++-- | Returns @True@ of the first partition is a subpartition (that is, fit inside) of the second.+-- This includes equality+_isSubPartitionOf :: [Int] -> [Int] -> Bool+_isSubPartitionOf ps qs = and $ zipWith (<=) ps (qs ++ repeat 0)++-- | This is provided for convenience\/completeness only, as:+--+-- > isSuperPartitionOf q p == isSubPartitionOf p q+--+_isSuperPartitionOf :: [Int] -> [Int] -> Bool+_isSuperPartitionOf qs ps = and $ zipWith (<=) ps (qs ++ repeat 0)+++-- | Sub-partitions of a given partition with the given weight:+--+-- > sort (subPartitions d q) == sort [ p | p <- partitions d, isSubPartitionOf p q ]+--+_subPartitions :: Int -> [Int] -> [[Int]]+_subPartitions d big+  | null big       = if d==0 then [[]] else []+  | d > sum' big   = []+  | d < 0          = []+  | otherwise      = go d (head big) big+  where+    go :: Int -> Int -> [Int] -> [[Int]]+    go !k !h []      = if k==0 then [[]] else []+    go !k !h (b:bs) +      | k<0 || h<0   = []+      | k==0         = [[]]+      | h==0         = []+      | otherwise    = [ this:rest | this <- [1..min h b] , rest <- go (k-this) this bs ]++----------------------------------------++-- | All sub-partitions of a given partition+_allSubPartitions :: [Int] -> [[Int]]+_allSubPartitions big +  | null big   = [[]]+  | otherwise  = go (head big) big+  where+    go _  [] = [[]]+    go !h (b:bs) +      | h==0         = []+      | otherwise    = [] : [ this:rest | this <- [1..min h b] , rest <- go this bs ]++----------------------------------------++-- | Super-partitions of a given partition with the given weight:+--+-- > sort (superPartitions d p) == sort [ q | q <- partitions d, isSubPartitionOf p q ]+--+_superPartitions :: Int -> [Int] -> [[Int]]+_superPartitions dd small+  | dd < w0     = []+  | null small  = _partitions dd+  | otherwise   = go dd w1 dd (small ++ repeat 0)+  where+    w0 = sum' small+    w1 = w0 - head small+    -- d = remaining weight of the outer partition we are constructing+    -- w = remaining weight of the inner partition (we need to reserve at least this amount)+    -- h = max height (decreasing)+    go !d !w !h (!a:as@(b:_)) +      | d < 0     = []+      | d == 0    = if a == 0 then [[]] else []+      | otherwise = [ this:rest | this <- [max 1 a .. min h (d-w)] , rest <- go (d-this) (w-b) this as ]+    +--------------------------------------------------------------------------------+-- * The Pieri rule++-- | The Pieri rule computes @s[lambda]*h[n]@ as a sum of @s[mu]@-s (each with coefficient 1).+--+-- See for example <http://en.wikipedia.org/wiki/Pieri's_formula>+--+-- | We assume here that @lambda@ is a partition (non-increasing sequence of /positive/ integers)! +_pieriRule :: [Int] -> Int -> [[Int]] +_pieriRule lambda n+    | n == 0     = [lambda]+    | n <  0     = [] +    | otherwise  = go n diffs dsums (lambda++[0]) +    where+      diffs = n : _diffSequence lambda                 -- maximum we can add to a given row+      dsums = reverse $ scanl1 (+) (reverse diffs)    -- partial sums of remaining total we can add+      go !k (d:ds) (p:ps@(q:_)) (l:ls) +        | k > p     = []+        | otherwise = [ h:tl | a <- [ max 0 (k-q) .. min d k ] , let h = l+a , tl <- go (k-a) ds ps ls ]+      go !k [d]    _      [l]    = if k <= d +                                     then if l+k>0 then [[l+k]] else [[]]+                                     else []+      go !k []     _      _      = if k==0 then [[]] else []++-- | The dual Pieri rule computes @s[lambda]*e[n]@ as a sum of @s[mu]@-s (each with coefficient 1)+_dualPieriRule :: [Int] -> Int -> [[Int]] +_dualPieriRule lam n = map _dualPartition $ _pieriRule (_dualPartition lam) n++--------------------------------------------------------------------------------
+ src/Math/Combinat/Partitions/Integer/Naive.hs view
@@ -0,0 +1,214 @@++-- | Naive implementation of partitions of integers, encoded as list of @Int@-s.+--+-- Integer partitions are nonincreasing sequences of positive integers.+--+-- This is an internal module, you are not supposed to import it directly.+--+ ++{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, PatternSynonyms, ViewPatterns #-}+module Math.Combinat.Partitions.Integer.Naive where++--------------------------------------------------------------------------------++import Data.List +import Control.Monad ( liftM , replicateM )++-- import Data.Map (Map)+-- import qualified Data.Map as Map++import Math.Combinat.Classes+import Math.Combinat.ASCII as ASCII+import Math.Combinat.Numbers (factorial,binomial,multinomial)+import Math.Combinat.Helper++import Data.Array+import System.Random++import Math.Combinat.Partitions.Integer.IntList+import Math.Combinat.Partitions.Integer.Count ( countPartitions )++--------------------------------------------------------------------------------+-- * Type and basic stuff++-- | A partition of an integer. The additional invariant enforced here is that partitions +-- are monotone decreasing sequences of /positive/ integers. The @Ord@ instance is lexicographical.+newtype Partition = Partition [Int] deriving (Eq,Ord,Show,Read)++instance HasNumberOfParts Partition where+  numberOfParts (Partition p) = length p++---------------------------------------------------------------------------------++toList :: Partition -> [Int]+toList (Partition xs) = xs++fromList :: [Int] -> Partition +fromList = mkPartition where+  mkPartition xs = Partition $ sortBy (reverseCompare) $ filter (>0) xs++fromListUnsafe :: [Int] -> Partition+fromListUnsafe = Partition++---------------------------------------------------------------------------------++isEmptyPartition :: Partition -> Bool+isEmptyPartition (Partition p) = null p++emptyPartition :: Partition+emptyPartition = Partition []++instance CanBeEmpty Partition where+  empty   = emptyPartition+  isEmpty = isEmptyPartition++-- | The first element of the sequence.+partitionHeight :: Partition -> Int+partitionHeight (Partition part) = case part of+  (p:_) -> p+  []    -> 0+  +-- | The length of the sequence (that is, the number of parts).+partitionWidth :: Partition -> Int+partitionWidth (Partition part) = length part++instance HasHeight Partition where+  height = partitionHeight+ +instance HasWidth Partition where+  width = partitionWidth++heightWidth :: Partition -> (Int,Int)+heightWidth part = (height part, width part)++-- | The weight of the partition +--   (that is, the sum of the corresponding sequence).+partitionWeight :: Partition -> Int+partitionWeight (Partition part) = sum' part++instance HasWeight Partition where +  weight = partitionWeight++-- | The dual (or conjugate) partition.+dualPartition :: Partition -> Partition+dualPartition (Partition part) = Partition (_dualPartition part)++instance HasDuality Partition where +  dual = dualPartition++-- | Example:+--+-- > elements (toPartition [5,4,1]) ==+-- >   [ (1,1), (1,2), (1,3), (1,4), (1,5)+-- >   , (2,1), (2,2), (2,3), (2,4)+-- >   , (3,1)+-- >   ]+--+elements :: Partition -> [(Int,Int)]+elements (Partition part) = _elements part++--------------------------------------------------------------------------------+-- * 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  <- (unconsPartition -> Just (x,xs)) where+        Cons x (Partition xs) = Partition (x:xs)++-- | Simulated newtype constructor +pattern Partition_ :: [Int] -> Partition+pattern Partition_ xs = Partition xs++pattern Head :: Int -> Partition +pattern Head h <- (head . toDescList -> h)++pattern Tail :: Partition -> Partition+pattern Tail xs <- (Partition . tail . toDescList -> xs)++pattern Length :: Int -> Partition +pattern Length n <- (partitionWidth -> n)        + +---------------------------------------------------------------------------------+-- * Exponential form++-- | We convert a partition to exponential form.+-- @(i,e)@ mean @(i^e)@; for example @[(1,4),(2,3)]@ corresponds to @(1^4)(2^3) = [2,2,2,1,1,1,1]@. Another example:+--+-- > toExponentialForm (Partition [5,5,3,2,2,2,2,1,1]) == [(1,2),(2,4),(3,1),(5,2)]+--+toExponentialForm :: Partition -> [(Int,Int)]+toExponentialForm = _toExponentialForm . toDescList++fromExponentialForm :: [(Int,Int)] -> Partition+fromExponentialForm = Partition . _fromExponentialForm where++--------------------------------------------------------------------------------+-- * List-like operations++-- | From a sequence @[a1,a2,..,an]@ computes the sequence of differences+-- @[a1-a2,a2-a3,...,an-0]@+diffSequence :: Partition -> [Int]+diffSequence = go . toDescList where+  go (x:ys@(y:_)) = (x-y) : go ys +  go [x] = [x]+  go []  = []++unconsPartition :: Partition -> Maybe (Int,Partition)+unconsPartition (Partition xs) = case xs of+  (y:ys) -> Just (y, Partition ys)+  []     -> Nothing++toDescList :: Partition -> [Int]+toDescList (Partition xs) = xs++---------------------------------------------------------------------------------+-- * Dominance order ++-- | @q \`dominates\` p@ returns @True@ if @q >= p@ in the dominance order of partitions+-- (this is partial ordering on the set of partitions of @n@).+--+-- See <http://en.wikipedia.org/wiki/Dominance_order>+--+dominates :: Partition -> Partition -> Bool+dominates (Partition qs) (Partition ps) +  = and $ zipWith (>=) (sums (qs ++ repeat 0)) (sums ps)+  where+    sums = scanl (+) 0++--------------------------------------------------------------------------------+-- * Containment partial ordering++-- | Returns @True@ of the first partition is a subpartition (that is, fit inside) of the second.+-- This includes equality+isSubPartitionOf :: Partition -> Partition -> Bool+isSubPartitionOf (Partition ps) (Partition qs) = and $ zipWith (<=) ps (qs ++ repeat 0)++-- | This is provided for convenience\/completeness only, as:+--+-- > isSuperPartitionOf q p == isSubPartitionOf p q+--+isSuperPartitionOf :: Partition -> Partition -> Bool+isSuperPartitionOf (Partition qs) (Partition ps) = and $ zipWith (<=) ps (qs ++ repeat 0)+    +--------------------------------------------------------------------------------+-- * The Pieri rule++-- | The Pieri rule computes @s[lambda]*h[n]@ as a sum of @s[mu]@-s (each with coefficient 1).+--+-- See for example <http://en.wikipedia.org/wiki/Pieri's_formula>+--+pieriRule :: Partition -> Int -> [Partition] +pieriRule (Partition lambda) n = map Partition (_pieriRule lambda n) where++-- | The dual Pieri rule computes @s[lambda]*e[n]@ as a sum of @s[mu]@-s (each with coefficient 1)+dualPieriRule :: Partition -> Int -> [Partition] +dualPieriRule lam n = map dualPartition $ pieriRule (dualPartition lam) n++--------------------------------------------------------------------------------++
+ src/Math/Combinat/Partitions/Multiset.hs view
@@ -0,0 +1,24 @@++-- | Partitions of a multiset+module Math.Combinat.Partitions.Multiset where++--------------------------------------------------------------------------------++import Data.Array.Unboxed+import Data.List++import Math.Combinat.Partitions.Vector++--------------------------------------------------------------------------------+                              +-- | Partitions of a multiset. Internally, this uses the vector partition algorithm+partitionMultiset :: (Eq a, Ord a) => [a] -> [[[a]]]+partitionMultiset xs = parts where+  parts = (map . map) (f . elems) temp+  f ns = concat (zipWith replicate ns zs)+  temp = fasc3B_algorithm_M counts+  counts = map length ys+  ys = group (sort xs) +  zs = map head ys++--------------------------------------------------------------------------------
+ src/Math/Combinat/Partitions/NonCrossing.hs view
@@ -0,0 +1,205 @@++-- | Non-crossing partitions.+--+-- See eg. <http://en.wikipedia.org/wiki/Noncrossing_partition>+--+-- Non-crossing partitions of the set @[1..n]@ are encoded as lists of lists+-- in standard form: Entries decreasing in each block  and blocks listed in increasing order of their first entries.+-- For example the partition in the diagram+--+-- <<svg/noncrossing.svg>>+--+-- is represented as+--+-- > NonCrossing [[3],[5,4,2],[7,6,1],[9,8]]+--++{-# LANGUAGE BangPatterns #-}+module Math.Combinat.Partitions.NonCrossing where++--------------------------------------------------------------------------------++import Control.Applicative++import Data.List+import Data.Ord++import System.Random++import Math.Combinat.Numbers+import Math.Combinat.LatticePaths+import Math.Combinat.Helper+import Math.Combinat.Partitions.Set+import Math.Combinat.Classes++--------------------------------------------------------------------------------+-- * The type of non-crossing partitions++-- | A non-crossing partition of the set @[1..n]@ in standard form: +-- entries decreasing in each block  and blocks listed in increasing order of their first entries.+newtype NonCrossing = NonCrossing [[Int]] deriving (Eq,Ord,Show,Read)++-- | Checks whether a set partition is noncrossing.+--+-- Implementation method: we convert to a Dyck path and then back again, and finally compare. +-- Probably not very efficient, but should be better than a naive check for crosses...)+--+_isNonCrossing :: [[Int]] -> Bool+_isNonCrossing zzs0 = _isNonCrossingUnsafe (_standardizeNonCrossing zzs0)++-- | Warning: This function assumes the standard ordering!+_isNonCrossingUnsafe :: [[Int]] -> Bool+_isNonCrossingUnsafe zzs = +  case _nonCrossingPartitionToDyckPathMaybe zzs of+    Nothing   -> False+    Just dyck -> case dyckPathToNonCrossingPartitionMaybe dyck of+      Nothing                -> False+      Just (NonCrossing yys) -> yys == zzs++-- | Convert to standard form: entries decreasing in each block +-- and blocks listed in increasing order of their first entries.+_standardizeNonCrossing :: [[Int]] -> [[Int]]+_standardizeNonCrossing = sortBy (comparing myhead) . map reverseSort where+  myhead xs = case xs of+    (x:xs) -> x+    []     -> error "_standardizeNonCrossing: empty subset"++fromNonCrossing :: NonCrossing -> [[Int]]+fromNonCrossing (NonCrossing xs) = xs++toNonCrossingUnsafe :: [[Int]] -> NonCrossing+toNonCrossingUnsafe = NonCrossing++-- | Throws an error if the input is not a non-crossing partition+toNonCrossing :: [[Int]] -> NonCrossing+toNonCrossing xxs = case toNonCrossingMaybe xxs of+  Just nc -> nc+  Nothing -> error "toNonCrossing: not a non-crossing partition"++toNonCrossingMaybe :: [[Int]] -> Maybe NonCrossing+toNonCrossingMaybe xxs0 = +  if _isNonCrossingUnsafe xxs+    then Just $ NonCrossing xxs+    else Nothing+  where +    xxs = _standardizeNonCrossing xxs0++-- | If a set partition is actually non-crossing, then we can convert it+setPartitionToNonCrossing :: SetPartition -> Maybe NonCrossing+setPartitionToNonCrossing (SetPartition zzs0) =+  if _isNonCrossingUnsafe zzs+    then Just $ NonCrossing zzs+    else Nothing+  where+    zzs = _standardizeNonCrossing zzs0++instance HasNumberOfParts NonCrossing where+  numberOfParts (NonCrossing p) = length p++--------------------------------------------------------------------------------+-- * Bijection to Dyck paths++-- | Bijection between Dyck paths and noncrossing partitions+--+-- Based on: David Callan: /Sets, Lists and Noncrossing Partitions/+--+-- Fails if the input is not a Dyck path.+dyckPathToNonCrossingPartition :: LatticePath -> NonCrossing+dyckPathToNonCrossingPartition = NonCrossing . go 0 [] [] [] where+  go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> [[Int]] +  go !cnt stack small big path =+    case path of+      (x:xs) -> case x of +        UpStep   -> let cnt' = cnt + 1 in case xs of+          (y:ys)   -> case y of+            UpStep   -> go cnt' (cnt':stack) small                  big  xs  +            DownStep -> go cnt' (cnt':stack) []    (reverse small : big) xs+          []       -> error "dyckPathToNonCrossingPartition: last step is an UpStep (thus input was not a Dyck path)"+        DownStep -> case stack of+          (k:ks)   -> go cnt ks (k:small) big xs+          []       -> error "dyckPathToNonCrossingPartition: empty stack, shouldn't happen (thus input was not a Dyck path)"+      [] -> tail $ reverse (reverse small : big)++-- | Safe version of 'dyckPathToNonCrossingPartition'+dyckPathToNonCrossingPartitionMaybe :: LatticePath -> Maybe NonCrossing+dyckPathToNonCrossingPartitionMaybe = fmap NonCrossing . go 0 [] [] [] where+  go :: Int -> [Int] -> [Int] -> [[Int]] -> LatticePath -> Maybe [[Int]] +  go !cnt stack small big path =+    case path of+      (x:xs) -> case x of +        UpStep   -> let cnt' = cnt + 1 in case xs of+          (y:ys)   -> case y of+            UpStep   -> go cnt' (cnt':stack) small                  big  xs  +            DownStep -> go cnt' (cnt':stack) []    (reverse small : big) xs+          []       -> Nothing+        DownStep -> case stack of+          (k:ks)   -> go cnt ks (k:small) big xs+          []       -> Nothing+      [] -> Just $ tail $ reverse (reverse small : big)++-- | The inverse bijection (should never fail proper 'NonCrossing'-s)+nonCrossingPartitionToDyckPath :: NonCrossing -> LatticePath+nonCrossingPartitionToDyckPath (NonCrossing zzs) = go 0 zzs where+  go !k (ys@(y:_):yys) = replicate (y-k) UpStep ++ replicate (length ys) DownStep ++ go y yys+  go !k []             = []+  go _  _              = error "nonCrossingPartitionToDyckPath: shouldnt't happen"++-- | Safe version 'nonCrossingPartitionToDyckPath'+_nonCrossingPartitionToDyckPathMaybe :: [[Int]] -> Maybe LatticePath+_nonCrossingPartitionToDyckPathMaybe = go 0 where+  go !k (ys@(y:_):yys) = fmap (\zs -> replicate (y-k) UpStep ++ replicate (length ys) DownStep ++ zs) (go y yys)+  go !k []             = Just []+  go _  _              = Nothing++--------------------------------------------------------------------------------++{- +-- this should be mapped to NonCrossing [[3],[5,4,2],[7,6,1],[9,8]]+testpath = [u,u,u,d,u,u,d,d,d,u,u,d,d,d,u,u,d,d] where+  u = UpStep+  d = DownStep++testnc = NonCrossing [[3],[5,4,2],[7,6,1],[9,8]]+-}++--------------------------------------------------------------------------------+-- * Generating non-crossing partitions++-- | Lists all non-crossing partitions of @[1..n]@+--+-- Equivalent to (but orders of magnitude faster than) filtering out the non-crossing ones:+--+-- > (sort $ catMaybes $ map setPartitionToNonCrossing $ setPartitions n) == sort (nonCrossingPartitions n)+--+nonCrossingPartitions :: Int -> [NonCrossing]+nonCrossingPartitions = map dyckPathToNonCrossingPartition . dyckPaths++-- | Lists all non-crossing partitions of @[1..n]@ into @k@ parts.+--+-- > sort (nonCrossingPartitionsWithKParts k n) == sort [ p | p <- nonCrossingPartitions n , numberOfParts p == k ]+--+nonCrossingPartitionsWithKParts +  :: Int   -- ^ @k@ = number of parts +  -> Int   -- ^ @n@ = size of the set+  -> [NonCrossing]+nonCrossingPartitionsWithKParts k n = map dyckPathToNonCrossingPartition $ peakingDyckPaths k n++-- | Non-crossing partitions are counted by the Catalan numbers+countNonCrossingPartitions :: Int -> Integer+countNonCrossingPartitions = countDyckPaths++-- | Non-crossing partitions with @k@ parts are counted by the Naranaya numbers+countNonCrossingPartitionsWithKParts +  :: Int   -- ^ @k@ = number of parts +  -> Int   -- ^ @n@ = size of the set+  -> Integer+countNonCrossingPartitionsWithKParts = countPeakingDyckPaths++--------------------------------------------------------------------------------++-- | Uniformly random non-crossing partition+randomNonCrossingPartition :: RandomGen g => Int -> g -> (NonCrossing,g)+randomNonCrossingPartition n g0 = (dyckPathToNonCrossingPartition dyck, g1) where+  (dyck,g1) = randomDyckPath n g0++--------------------------------------------------------------------------------
+ src/Math/Combinat/Partitions/Plane.hs view
@@ -0,0 +1,124 @@++-- | Plane partitions. See eg. <http://en.wikipedia.org/wiki/Plane_partition>+--+-- Plane partitions are encoded as lists of lists of Z heights. For example the plane +-- partition in the picture+-- +-- <<svg/plane_partition.svg>>+--+-- is encoded as+--+-- > PlanePart [ [5,4,3,3,1]+-- >           , [4,4,2,1]+-- >           , [3,2]+-- >           , [2,1]+-- >           , [1]+-- >           , [1]+-- >           ]+-- +{-# LANGUAGE BangPatterns #-}+module Math.Combinat.Partitions.Plane where++--------------------------------------------------------------------------------++import Data.List+import Data.Array++import Math.Combinat.Classes+import Math.Combinat.Partitions+import Math.Combinat.Tableaux as Tableaux+import Math.Combinat.Helper++--------------------------------------------------------------------------------+-- * the type of plane partitions++-- | A plane partition encoded as a tablaeu (the \"Z\" heights are the numbers)+newtype PlanePart = PlanePart [[Int]] deriving (Eq,Ord,Show)++fromPlanePart :: PlanePart -> [[Int]]+fromPlanePart (PlanePart xs) = xs++isValidPlanePart :: [[Int]] -> Bool+isValidPlanePart pps = +  and [ table!(i,j) >= table!(i  ,j+1) &&+        table!(i,j) >= table!(i+1,j  )+      | i<-[0..y-1] , j<-[0..x-1] +      ]+  where+    table :: Array (Int,Int) Int+    table = accumArray const 0 ((0,0),(y,x)) [ ((i,j),k) | (i,ps) <- zip [0..] pps , (j,k) <- zip [0..] ps ]+    y = length pps+    x = maximum (map length pps)++instance CanBeEmpty PlanePart where+  isEmpty = null . fromPlanePart+  empty   = PlanePart []++-- | Throws an exception if the input is not a plane partition+toPlanePart :: [[Int]] -> PlanePart+toPlanePart pps = if isValidPlanePart pps+  then PlanePart $ filter (not . null) $ map (filter (>0)) $ pps+  else error "toPlanePart: not a plane partition"++-- | The XY projected shape of a plane partition, as an integer partition+planePartShape :: PlanePart -> Partition+planePartShape = Tableaux.tableauShape . fromPlanePart++-- | The Z height of a plane partition+planePartZHeight :: PlanePart -> Int+planePartZHeight (PlanePart xs) = +  case xs of+    ((h:_):_) -> h+    _         -> 0++planePartWeight :: PlanePart -> Int+planePartWeight (PlanePart xs) = sum' (map sum' xs)++instance HasWeight PlanePart where+  weight = planePartWeight++--------------------------------------------------------------------------------+-- * constructing plane partitions++singleLayer :: Partition -> PlanePart+singleLayer = PlanePart . map (\k -> replicate k 1) . fromPartition ++-- |  Stacks layers of partitions into a plane partition.+-- Throws an exception if they do not form a plane partition.+stackLayers :: [Partition] -> PlanePart+stackLayers layers = if and [ isSubPartitionOf p q | (q,p) <- pairs layers ]+  then unsafeStackLayers layers+  else error "stackLayers: the layers do not form a plane partition"++-- | Stacks layers of partitions into a plane partition.+-- This is unsafe in the sense that we don't check that the partitions fit on the top of each other.+unsafeStackLayers :: [Partition] -> PlanePart+unsafeStackLayers []            = PlanePart []+unsafeStackLayers (bottom:rest) = PlanePart $ foldl addLayer (fromPlanePart $ singleLayer bottom) rest where+  addLayer :: [[Int]] -> Partition -> [[Int]]+  addLayer xxs (Partition ps) = [ zipWith (+) xs (replicate p 1 ++ repeat 0) | (xs,p) <- zip xxs (ps ++ repeat 0) ] ++-- | The \"layers\" of a plane partition (in direction @Z@). We should have+--+-- > unsafeStackLayers (planePartLayers pp) == pp+-- +planePartLayers :: PlanePart -> [Partition]+planePartLayers pp@(PlanePart xs) = [ layer h | h<-[1..planePartZHeight pp] ] where+  layer h = Partition $ filter (>0) $ map sum' $ (map . map) (f h) xs+  f h = \k -> if k>=h then 1 else 0++--------------------------------------------------------------------------------+-- * generating plane partitions++-- | Plane partitions of a given weight+planePartitions :: Int -> [PlanePart]+planePartitions d +  | d <  0     = []+  | d == 0     = [PlanePart []]+  | otherwise  = concat [ go (d-n) [p] | n<-[1..d] , p<-partitions n ]+  where+    go :: Int -> [Partition] -> [PlanePart]+    go  0   acc       = [unsafeStackLayers (reverse acc)]+    go !rem acc@(h:_) = concat [ go (rem-k) (this:acc) | k<-[1..rem] , this <- subPartitions k h ]++--------------------------------------------------------------------------------
+ src/Math/Combinat/Partitions/Set.hs view
@@ -0,0 +1,109 @@++-- | Set partitions.+--+-- See eg. <http://en.wikipedia.org/wiki/Partition_of_a_set>+-- ++{-# LANGUAGE BangPatterns #-}+module Math.Combinat.Partitions.Set where++--------------------------------------------------------------------------------++import Data.List+import Data.Ord++import System.Random++import Math.Combinat.Sets+import Math.Combinat.Numbers+import Math.Combinat.Helper+import Math.Combinat.Classes+import Math.Combinat.Partitions.Integer++--------------------------------------------------------------------------------+-- * The type of set partitions++-- | A partition of the set @[1..n]@ (in standard order)+newtype SetPartition = SetPartition [[Int]] deriving (Eq,Ord,Show,Read)++_standardizeSetPartition :: [[Int]] -> [[Int]]+_standardizeSetPartition = sortBy (comparing myhead) . map sort where+  myhead xs = case xs of+    (x:xs) -> x+    []     -> error "_standardizeSetPartition: empty subset"++fromSetPartition :: SetPartition -> [[Int]]+fromSetPartition (SetPartition zzs) = zzs++toSetPartitionUnsafe :: [[Int]] -> SetPartition+toSetPartitionUnsafe = SetPartition++toSetPartition :: [[Int]] -> SetPartition+toSetPartition zzs = if _isSetPartition zzs+  then SetPartition (_standardizeSetPartition zzs)+  else error "toSetPartition: not a set partition"++_isSetPartition :: [[Int]] -> Bool+_isSetPartition zzs = sort (concat zzs) == [1..n] where +  n = sum' (map length zzs)++instance HasNumberOfParts SetPartition where+  numberOfParts (SetPartition p) = length p++--------------------------------------------------------------------------------+-- * Forgetting the set structure++-- | The \"shape\" of a set partition is the partition we get when we forget the+-- set structure, keeping only the cardinalities.+--+setPartitionShape :: SetPartition -> Partition+setPartitionShape (SetPartition pps) = mkPartition (map length pps)++--------------------------------------------------------------------------------+-- * Generating set partitions++-- | Synonym for 'setPartitionsNaive'+setPartitions :: Int -> [SetPartition]+setPartitions = setPartitionsNaive++-- | Synonym for 'setPartitionsWithKPartsNaive'+--+-- > sort (setPartitionsWithKParts k n) == sort [ p | p <- setPartitions n , numberOfParts p == k ]+-- +setPartitionsWithKParts   +  :: Int    -- ^ @k@ = number of parts+  -> Int    -- ^ @n@ = size of the set+  -> [SetPartition]+setPartitionsWithKParts = setPartitionsWithKPartsNaive++-- | List all set partitions of @[1..n]@, naive algorithm+setPartitionsNaive :: Int -> [SetPartition]+setPartitionsNaive n = map (SetPartition . _standardizeSetPartition) $ go [1..n] where+  go :: [Int] -> [[[Int]]]+  go []     = [[]]+  go (z:zs) = [ s : rest | k <- [1..n] , s0 <- choose (k-1) zs , let s = z:s0 , rest <- go (zs \\ s) ]++-- | Set partitions of the set @[1..n]@ into @k@ parts+setPartitionsWithKPartsNaive +  :: Int    -- ^ @k@ = number of parts+  -> Int    -- ^ @n@ = size of the set+  -> [SetPartition]+setPartitionsWithKPartsNaive k n = map (SetPartition . _standardizeSetPartition) $ go k [1..n] where+  go :: Int -> [Int] -> [[[Int]]]+  go !k []     = if k==0 then [[]] else []+  go  1 zs     = [[zs]]+  go !k (z:zs) = [ s : rest | l <- [1..n] , s0 <- choose (l-1) zs , let s = z:s0 , rest <- go (k-1) (zs \\ s) ]+++-- | Set partitions are counted by the Bell numbers+countSetPartitions :: Int -> Integer+countSetPartitions = bellNumber ++-- | Set partitions of size @k@ are counted by the Stirling numbers of second kind+countSetPartitionsWithKParts +  :: Int    -- ^ @k@ = number of parts+  -> Int    -- ^ @n@ = size of the set+  -> Integer+countSetPartitionsWithKParts k n = stirling2nd n k++--------------------------------------------------------------------------------
+ src/Math/Combinat/Partitions/Skew.hs view
@@ -0,0 +1,153 @@++-- | Skew partitions.+--+-- Skew partitions are the difference of two integer partitions, denoted by @lambda/mu@.+--+-- For example+--+-- > mkSkewPartition (Partition [9,7,3,2,2,1] , Partition [5,3,2,1])+--+-- creates the skew partition @(9,7,3,2,2,1) / (5,3,2,1)@, which looks like+--+-- <<svg/skew3.svg>>+--++{-# LANGUAGE CPP, BangPatterns #-}+module Math.Combinat.Partitions.Skew where++--------------------------------------------------------------------------------++import Data.List++import Math.Combinat.Classes+import Math.Combinat.Partitions.Integer+import Math.Combinat.ASCII++--------------------------------------------------------------------------------+-- * Basics++-- | A skew partition @lambda/mu@ is internally represented by the list @[ (mu_i , lambda_i-mu_i) | i<-[1..n] ]@+newtype SkewPartition = SkewPartition [(Int,Int)] deriving (Eq,Ord,Show)++-- | @mkSkewPartition (lambda,mu)@ creates the skew partition @lambda/mu@.+-- Throws an error if @mu@ is not a sub-partition of @lambda@.+mkSkewPartition :: (Partition,Partition) -> SkewPartition+mkSkewPartition ( lam@(Partition bs) , mu@(Partition as)) = if mu `isSubPartitionOf` lam +  then SkewPartition $ zipWith (\b a -> (a,b-a)) bs (as ++ repeat 0)+  else error "mkSkewPartition: mu should be a subpartition of lambda!" ++-- | Returns 'Nothing' if @mu@ is not a sub-partition of @lambda@.+safeSkewPartition :: (Partition,Partition) -> Maybe SkewPartition+safeSkewPartition ( lam@(Partition bs) , mu@(Partition as)) = if mu `isSubPartitionOf` lam +  then Just $ SkewPartition $ zipWith (\b a -> (a,b-a)) bs (as ++ repeat 0)+  else Nothing++-- | The weight of a skew partition is the weight of the outer partition minus the+-- the weight of the inner partition (that is, the number of boxes present).+skewPartitionWeight :: SkewPartition -> Int+skewPartitionWeight (SkewPartition abs) = foldl' (+) 0 (map snd abs)++instance HasWeight SkewPartition where+  weight = skewPartitionWeight++-- | This function \"cuts off\" the \"uninteresting parts\" of a skew partition+normalizeSkewPartition :: SkewPartition -> SkewPartition+normalizeSkewPartition (SkewPartition abs) = SkewPartition abs' where+  (as,bs) = unzip abs+  a0 = minimum as+  k  = length (takeWhile (==0) bs)+  abs' = zip [ a-a0 | a <- drop k as ] (drop k bs)+   +-- | Returns the outer and inner partition of a skew partition, respectively:+--+-- > mkSkewPartition . fromSkewPartition == id+--+fromSkewPartition :: SkewPartition -> (Partition,Partition)+fromSkewPartition (SkewPartition list) = (toPartition (zipWith (+) as bs) , toPartition (filter (>0) as)) where+  (as,bs) = unzip list++-- | The @lambda@ part of @lambda/mu@+outerPartition :: SkewPartition -> Partition  +outerPartition = fst . fromSkewPartition ++-- | The @mu@ part of @lambda/mu@+innerPartition :: SkewPartition -> Partition  +innerPartition = snd . fromSkewPartition ++-- | The dual skew partition (that is, the mirror image to the main diagonal)+dualSkewPartition :: SkewPartition -> SkewPartition+dualSkewPartition = mkSkewPartition . f . fromSkewPartition where+  f (lam,mu) = (dualPartition lam, dualPartition mu)++instance HasDuality SkewPartition where+  dual = dualSkewPartition++-- | See "partitionElements"+skewPartitionElements :: SkewPartition -> [(Int, Int)]+skewPartitionElements (SkewPartition abs) = concat+  [ [ (i,j) | j <- [a+1 .. a+b] ]+  | (i,(a,b)) <- zip [1..] abs+  ]++--------------------------------------------------------------------------------+-- * Listing skew partitions++-- | Lists all skew partitions with the given outer shape and given (skew) weight+skewPartitionsWithOuterShape :: Partition -> Int -> [SkewPartition]+skewPartitionsWithOuterShape outer skewWeight +  | innerWeight < 0 || innerWeight > outerWeight = []+  | otherwise = [ mkSkewPartition (outer,inner) | inner <- subPartitions innerWeight outer ]+  where+    outerWeight = weight outer+    innerWeight = outerWeight - skewWeight ++-- | Lists all skew partitions with the given outer shape and any (skew) weight+allSkewPartitionsWithOuterShape :: Partition -> [SkewPartition]+allSkewPartitionsWithOuterShape outer +  = concat [ skewPartitionsWithOuterShape outer w | w<-[0..outerWeight] ]+  where+    outerWeight = weight outer++-- | Lists all skew partitions with the given inner shape and given (skew) weight+skewPartitionsWithInnerShape :: Partition -> Int -> [SkewPartition]+skewPartitionsWithInnerShape inner skewWeight +  | innerWeight > outerWeight = []+  | otherwise = [ mkSkewPartition (outer,inner) | outer <- superPartitions outerWeight inner ]+  where+    outerWeight = innerWeight + skewWeight +    innerWeight = weight inner ++--------------------------------------------------------------------------------+-- connected components++{-+connectedComponents :: SkewPartition -> [((Int,Int),SkewPartition)]+connectedComponents = error "connectedComponents: not implemented yet"++isConnectedSkewPartition :: SkewPartition -> Bool+isConnectedSkewPartition skewp = length (connectedComponents skewp) == 1+-}++--------------------------------------------------------------------------------+-- * ASCII++asciiSkewFerrersDiagram :: SkewPartition -> ASCII+asciiSkewFerrersDiagram = asciiSkewFerrersDiagram' ('@','.') EnglishNotation++asciiSkewFerrersDiagram' +  :: (Char,Char)       +  -> PartitionConvention -- Orientation+  -> SkewPartition +  -> ASCII+asciiSkewFerrersDiagram' (outer,inner) orient (SkewPartition abs) = asciiFromLines stuff where+  stuff = case orient of+    EnglishNotation    -> ls+    EnglishNotationCCW -> reverse (transpose ls)+    FrenchNotation     -> reverse ls+  ls = [ replicate a inner ++ replicate b outer | (a,b) <- abs ]++instance DrawASCII SkewPartition where+  ascii = asciiSkewFerrersDiagram     ++--------------------------------------------------------------------------------+
+ src/Math/Combinat/Partitions/Skew/Ribbon.hs view
@@ -0,0 +1,364 @@++-- | Ribbons (also called border strips, skew hooks, skew rim hooks, etc...).+--+-- Ribbons are skew partitions that are 1) connected, 2) do not contain+-- 2x2 blocks. Intuitively, they are 1-box wide continuous strips on+-- the boundary.+--+-- An alternative definition that they are skew partitions whose projection+-- to the diagonal line is a continuous segment of width 1.++{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+module Math.Combinat.Partitions.Skew.Ribbon where++--------------------------------------------------------------------------------++import Data.Array+import Data.List+import Data.Maybe++import qualified Data.Map as Map++import Math.Combinat.Sets+import Math.Combinat.Partitions.Integer+import Math.Combinat.Partitions.Integer.IntList ( _diffSequence )+import Math.Combinat.Partitions.Skew+import Math.Combinat.Tableaux+import Math.Combinat.Tableaux.LittlewoodRichardson+import Math.Combinat.Tableaux.GelfandTsetlin+import Math.Combinat.Helper++--------------------------------------------------------------------------------+-- * Corners (TODO: move to Partitions - but we also want to refactor that)++-- | The coordinates of the outer corners +outerCorners :: Partition -> [(Int,Int)]+outerCorners = outerCornerBoxes++-- | The coordinates of the inner corners, including the two on the two coordinate+-- axes. For the partition @[5,4,1]@ the result should be @[(0,5),(1,4),(2,1),(3,0)]@+extendedInnerCorners:: Partition -> [(Int,Int)]+extendedInnerCorners (Partition_ ps) = (0, head ps') : catMaybes mbCorners where+  ps' = ps ++ [0]+  mbCorners = zipWith3 f [1..] (tail ps') (_diffSequence ps') +  f !y !x !k = if k > 0 then Just (y,x) else Nothing++-- | Sequence of all the (extended) corners+extendedCornerSequence :: Partition -> [(Int,Int)]+extendedCornerSequence (Partition_ ps) = {- if null ps then [(0,0)] else -} interleave inner outer where+  inner = (0, head ps') : [ (y,x) | (y,x,k) <- zip3 [1..] (tail ps') diff , k>0 ]+  outer =                 [ (y,x) | (y,x,k) <- zip3 [1..] ps'        diff , k>0 ]+  diff = _diffSequence ps'+  ps' = ps ++ [0]++-- | The inner corner /boxes/ of the partition. Coordinates are counted from 1+-- (cf.the 'elements' function), and the first coordinate is the row, the second+-- the column (in English notation).+--+-- For the partition @[5,4,1]@ the result should be @[(1,4),(2,1)]@+--+-- > innerCornerBoxes lambda == (tail $ init $ extendedInnerCorners lambda)+--+innerCornerBoxes :: Partition -> [(Int,Int)]+innerCornerBoxes (Partition_ ps) = +  case ps of+    []  -> []+    _   -> catMaybes mbCorners +  where+    mbCorners = zipWith3 f [1..] (tail ps) (_diffSequence ps) +    f !y !x !k = if k > 0 then Just (y,x) else Nothing++-- | The outer corner /boxes/ of the partition. Coordinates are counted from 1+-- (cf.the 'elements' function), and the first coordinate is the row, the second+-- the column (in English notation).+--+-- For the partition @[5,4,1]@ the result should be @[(1,5),(2,4),(3,1)]@+outerCornerBoxes :: Partition -> [(Int,Int)]+outerCornerBoxes (Partition_ ps) = catMaybes mbCorners where+  mbCorners = zipWith3 f [1..] ps (_diffSequence ps) +  f !y !x !k = if k > 0 then Just (y,x) else Nothing++-- | The outer and inner corner boxes interleaved, so together they form +-- the turning points of the full border strip+cornerBoxSequence :: Partition -> [(Int,Int)]+cornerBoxSequence (Partition_ ps) = if null ps then [] else interleave outer inner where+  inner = [ (y,x) | (y,x,k) <- zip3 [1..] tailps diff , k>0 ]+  outer = [ (y,x) | (y,x,k) <- zip3 [1..] ps     diff , k>0 ]+  diff = _diffSequence ps+  tailps = case ps of { [] -> [] ; _-> tail ps }++--------------------------------------------------------------------------------++-- | Naive (and very slow) implementation of @innerCornerBoxes@, for testing purposes+innerCornerBoxesNaive :: Partition -> [(Int,Int)]+innerCornerBoxesNaive part = filter f boxes where+  boxes = elements part+  f (y,x) =       elem (y+1,x  ) boxes+          &&      elem (y  ,x+1) boxes+          && not (elem (y+1,x+1) boxes)++-- | Naive (and very slow) implementation of @outerCornerBoxes@, for testing purposes+outerCornerBoxesNaive :: Partition -> [(Int,Int)]+outerCornerBoxesNaive part = filter f boxes where+  boxes = elements part+  f (y,x) =  not (elem (y+1,x  ) boxes)+          && not (elem (y  ,x+1) boxes)+          && not (elem (y+1,x+1) boxes)++--------------------------------------------------------------------------------+-- * Ribbon++-- | A skew partition is a a ribbon (or border strip) if and only if projected+-- to the diagonals the result is an interval.+isRibbon :: SkewPartition -> Bool+isRibbon skewp = go Nothing proj where+  proj = Map.toList +       $ Map.fromListWith (+) [ (x-y , 1) | (y,x) <- skewPartitionElements skewp ]+  go Nothing   []            = False+  go (Just _)  []            = True+  go Nothing   ((a,h):rest)  = (h == 1) &&               go (Just a) rest  +  go (Just b)  ((a,h):rest)  = (h == 1) && (a == b+1) && go (Just a) rest++{-+-- | Naive (and slow) reference implementation of "isRibbon"+isRibbonNaive :: SkewPartition -> Bool+isRibbonNaive skewp = isConnectedSkewPartition skewp && no2x2 where+  boxes = skewPartitionElements skewp+  no2x2 = and +    [ not ( elem (y+1,x  ) boxes &&             +            elem (y  ,x+1) boxes &&  +            elem (y+1,x+1) boxes )        -- no 2x2 blocks +    | (y,x) <- boxes +    ]+-}++toRibbon :: SkewPartition -> Maybe Ribbon+toRibbon skew = +  if not (isRibbon skew)+    then Nothing+    else Just ribbon +  where+    ribbon =  Ribbon+      { rbShape  = skew+      , rbLength = skewPartitionWeight skew+      , rbHeight = height+      , rbWidth  = width+      }+    elems  = skewPartitionElements skew+    height = (length $ group $ sort $ map fst elems) - 1    -- TODO: optimize these+    width  = (length $ group $ sort $ map snd elems) - 1++-- | Border strips (or ribbons) are defined to be skew partitions which are +-- connected and do not contain 2x2 blocks.+-- +-- The /length/ of a border strip is the number of boxes it contains,+-- and its /height/ is defined to be one less than the number of rows+-- (in English notation) it occupies. The /width/ is defined symmetrically to +-- be one less than the number of columns it occupies.+--+data Ribbon = Ribbon+  { rbShape  :: SkewPartition+  , rbLength :: Int+  , rbHeight :: Int+  , rbWidth  :: Int+  }+  deriving (Eq,Ord,Show)++--------------------------------------------------------------------------------+-- * Inner border strips++-- | Ribbons (or border strips) are defined to be skew partitions which are +-- connected and do not contain 2x2 blocks. This function returns the+-- border strips whose outer partition is the given one.+innerRibbons :: Partition -> [Ribbon]+innerRibbons part@(Partition ps) = if null ps then [] else strips where++  strips  = [ mkStrip i j +            | i<-[1..n] , _canStartStrip (annArr!i)+            , j<-[i..n] , _canEndStrip   (annArr!j)+            ]++  n       = length annList+  annList = annotatedInnerBorderStrip part+  annArr  = listArray (1,n) annList++  mkStrip !i1 !i2 = Ribbon shape len height width where+    ps'   = ps ++ [0]+    shape = SkewPartition [ (p-k,k) | (i,p,q) <- zip3 [1..] ps (tail ps') , let k = indent i p q ] +    indent !i !p !q +      | i <  y1    = 0+      | i >  y2    = 0+      | i == y2    = p - x2 + 1     -- the order is important here !!!+      | otherwise  = p - q  + 1     -- because of the case y1 == y2 == i++    len    = i2 - i1 + 1+    height = y2 - y1+    width  = x1 - x2+    BorderBox _ _ y1 x1 = annArr ! i1+    BorderBox _ _ y2 x2 = annArr ! i2++-- | Inner border strips (or ribbons) of the given length+innerRibbonsOfLength :: Partition -> Int -> [Ribbon]+innerRibbonsOfLength part@(Partition ps) givenLength = if null ps then [] else strips where++  strips  = [ mkStrip i j +            | i<-[1..n] , _canStartStrip (annArr!i)+            , j<-[i..n] , _canEndStrip   (annArr!j)+            , j-i+1 == givenLength+            ]++  n       = length annList+  annList = annotatedInnerBorderStrip part+  annArr  = listArray (1,n) annList++  mkStrip !i1 !i2 = Ribbon shape givenLength height width where+    ps'   = ps ++ [0]+    shape = SkewPartition [ (p-k,k) | (i,p,q) <- zip3 [1..] ps (tail ps') , let k = indent i p q ] +    indent !i !p !q +      | i <  y1    = 0+      | i >  y2    = 0+      | i == y2    = p - x2 + 1     -- the order is important here !!!+      | otherwise  = p - q  + 1     -- because of the case y1 == y2 == i++    height = y2 - y1+    width  = x1 - x2+    BorderBox _ _ y1 x1 = annArr ! i1+    BorderBox _ _ y2 x2 = annArr ! i2+++--------------------------------------------------------------------------------+-- * Outer border strips++-- | Hooks of length @n@ (TODO: move to the partition module)+listHooks :: Int -> [Partition]+listHooks 0 = []+listHooks 1 = [ Partition [1] ]+listHooks n = [ Partition (k : replicate (n-k) 1) | k<-[1..n] ]++-- | Outer border strips (or ribbons) of the given length+outerRibbonsOfLength :: Partition -> Int -> [Ribbon]+outerRibbonsOfLength part@(Partition ps) givenLength = result where++  result = if null ps +    then [ Ribbon shape givenLength ht wd+         | p <- listHooks givenLength+         , let shape = mkSkewPartition (p,part)+         , let ht = partitionWidth  p - 1        -- pretty inconsistent names here :(((+         , let wd = partitionHeight p - 1+         ]+    else strips ++  strips  = [ mkStrip i j +            | i<-[1..n] , _canStartStrip (annArr!i)+            , j<-[i..n] , _canEndStrip   (annArr!j)+            , j-i+1 == givenLength+            ]+ +  ysize = partitionWidth  part+  xsize = partitionHeight part+ +  annList  =  [ BorderBox True False 1 x | x <- reverse [xsize+2 .. xsize+givenLength ] ]+           ++ annList0 +           ++ [ BorderBox False True y 1 | y <-         [ysize+2 .. ysize+givenLength ] ]+ +  n        = length annList+  annList0 = annotatedOuterBorderStrip part+  annArr   = listArray (1,n) annList++  mkStrip !i1 !i2 = Ribbon shape len height width where+    ps'   = (-666) : ps ++ replicate (givenLength) 0+    shape = SkewPartition [ (p,k) | (i,p,q) <- zip3 [1..max ysize y2] (tail ps') ps' , let k = indent i p q ] +    indent !i !p !q +      | i <  y1    = 0+      | i >  y2    = 0+      | i == y1    = x1 - p    -- the order is important here !!!+--      | i == y2    = x2 - p     +      | otherwise  = q - p  + 1   ++    len    = i2 - i1 + 1+    height = y2 - y1+    width  = x1 - x2+    BorderBox _ _ y1 x1 = annArr ! i1+    BorderBox _ _ y2 x2 = annArr ! i2++--------------------------------------------------------------------------------+-- * Naive implementations (for testing)++-- | Naive (and slow) implementation listing all inner border strips+innerRibbonsNaive :: Partition -> [Ribbon]+innerRibbonsNaive outer = list where+  list = [ Ribbon skew (len skew) (ht skew) (wt skew)+         | skew <- allSkewPartitionsWithOuterShape outer+         , isRibbon skew+         ]+  len skew = length (skewPartitionElements skew)+  ht  skew = (length $ group $ sort $ map fst $ skewPartitionElements skew) - 1+  wt  skew = (length $ group $ sort $ map snd $ skewPartitionElements skew) - 1+++-- | Naive (and slow) implementation listing all inner border strips of the given length+innerRibbonsOfLengthNaive :: Partition -> Int -> [Ribbon]+innerRibbonsOfLengthNaive outer givenLength = list where+  pweight = partitionWeight outer+  list = [ Ribbon skew (len skew) (ht skew) (wt skew)+         | skew <- skewPartitionsWithOuterShape outer givenLength+         , isRibbon skew+         ]+  len skew = length (skewPartitionElements skew)+  ht  skew = (length $ group $ sort $ map fst $ skewPartitionElements skew) - 1+  wt  skew = (length $ group $ sort $ map snd $ skewPartitionElements skew) - 1++-- | Naive (and slow) implementation listing all outer border strips of the given length+outerRibbonsOfLengthNaive :: Partition -> Int -> [Ribbon]+outerRibbonsOfLengthNaive inner givenLength = list where+  pweight = partitionWeight inner+  list = [ Ribbon skew (len skew) (ht skew) (wt skew)+         | skew <- skewPartitionsWithInnerShape inner givenLength+         , isRibbon skew+         ]+  len skew = length (skewPartitionElements skew)+  ht  skew = (length $ group $ sort $ map fst $ skewPartitionElements skew) - 1+  wt  skew = (length $ group $ sort $ map snd $ skewPartitionElements skew) - 1++--------------------------------------------------------------------------------+-- * Annotated borders++-- | A box on the border of a partition+data BorderBox = BorderBox+  { _canStartStrip :: !Bool+  , _canEndStrip   :: !Bool+  , _yCoord :: !Int+  , _xCoord :: !Int+  }+  deriving Show+ +-- | The boxes of the full inner border strip, annotated with whether a border strip +-- can start or end there.+annotatedInnerBorderStrip :: Partition -> [BorderBox]+annotatedInnerBorderStrip partition = if isEmptyPartition partition then [] else list where+  list    = goVert (head corners) (tail corners) +  corners = extendedCornerSequence partition  ++  goVert  (y1,x ) ((y2,_ ):rest) = [ BorderBox True (y==y2) y x | y<-[y1+1..y2] ] ++ goHoriz (y2,x) rest+  goVert  _       []             = [] ++  goHoriz (y ,x1) ((_, x2):rest) = case rest of+    [] -> [ BorderBox False True    y x | x<-[x1-1,x1-2..x2+1] ]+    _  -> [ BorderBox False (x/=x2) y x | x<-[x1-1,x1-2..x2  ] ] ++ goVert (y,x2) rest++-- | The boxes of the full outer border strip, annotated with whether a border strip +-- can start or end there.+annotatedOuterBorderStrip :: Partition -> [BorderBox]+annotatedOuterBorderStrip partition = if isEmptyPartition partition then [] else list where+  list    = goVert (head corners) (tail corners) +  corners = extendedCornerSequence partition  ++  goVert  (y1,x ) ((y2,_ ):rest) = [ BorderBox (y==y1) (y/=y2) (y+1) (x+1) | y<-[y1..y2] ] ++ goHoriz (y2,x) rest+  goVert  _       []             = [] ++  goHoriz (y ,x1) ((_, x2):rest) = case rest of+    [] -> [ BorderBox True (x==0) (y+1) (x+1) | x<-[x1-1,x1-2..x2  ] ]+    _  -> [ BorderBox True False  (y+1) (x+1) | x<-[x1-1,x1-2..x2+1] ] ++ goVert (y,x2) rest+++--------------------------------------------------------------------------------
+ src/Math/Combinat/Partitions/Vector.hs view
@@ -0,0 +1,82 @@++-- | 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 = fasc3B_algorithm_M . elems++_vectorPartitions :: [Int] -> [[[Int]]]+_vectorPartitions = map (map elems) . 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 xs = worker [start] where++  -- n = sum xs+  m = length xs++  start = [ (j,x,x) | (j,x) <- zip [1..] xs ]  +  +  worker stack@(last:_) = +    case decrease stack' of+      Nothing -> [visited]+      Just stack'' -> visited : worker stack''+    where+      stack'  = subtract_rec stack+      visited = map to_vector stack'+      +  decrease (last:rest) = +    case span (\(_,_,v) -> v==0) (reverse last) of+      ( _ , [(_,_,1)] ) -> case rest of+        [] -> Nothing+        _  -> decrease rest+      ( second , (c,u,v):first ) -> Just (modified:rest) where +        modified =   +          reverse first ++ +          (c,u,v-1) :  +          [ (c,u,u) | (c,u,_) <- reverse second ] +      _ -> error "fasc3B_algorithm_M: should not happen"+        +  to_vector cuvs = +    accumArray (flip const) 0 (1,m)+      [ (c,v) | (c,_,v) <- cuvs ] ++  subtract_rec all@(last:_) = +    case subtract last of +      []  -> all+      new -> subtract_rec (new:all) ++  subtract [] = []+  subtract full@((c,u,v):rest) = +    if w >= v +      then (c,w,v) : subtract   rest+      else           subtract_b full+    where w = u - v+    +  subtract_b [] = []+  subtract_b ((c,u,v):rest) = +    if w /= 0 +      then (c,w,w) : subtract_b rest+      else           subtract_b rest+    where w = u - v++--------------------------------------------------------------------------------
+ src/Math/Combinat/Permutations.hs view
@@ -0,0 +1,969 @@++-- | Permutations. +--+-- See eg.:+-- Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 2B.+--+-- WARNING: As of version 0.2.8.0, I changed the convention of how permutations+-- are represented internally. Also now they act on the /right/ by default!+--++{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleContexts #-}+module Math.Combinat.Permutations +  ( -- * The Permutation type+    Permutation (..)+  , fromPermutation+  , lookupPermutation , (!!!)+  , permutationArray+  , permutationUArray+  , uarrayToPermutationUnsafe+  , isPermutation+  , maybePermutation+  , toPermutation+  , toPermutationUnsafe+  , toPermutationUnsafeN+  , permutationSize+    -- * Disjoint cycles+  , DisjointCycles (..)+  , fromDisjointCycles+  , disjointCyclesUnsafe+  , permutationToDisjointCycles+  , disjointCyclesToPermutation+  , numberOfCycles+  , concatPermutations+    -- * Queries+  , isIdentityPermutation+  , isReversePermutation+  , isEvenPermutation+  , isOddPermutation+  , signOfPermutation  +  , signValueOfPermutation  +  , module Math.Combinat.Sign   --  , Sign(..)+  , isCyclicPermutation+    -- * Some concrete permutations+  , transposition+  , transpositions+  , adjacentTransposition+  , adjacentTranspositions+  , cycleLeft+  , cycleRight+  , reversePermutation+    -- * Inversions+  , inversions+  , numberOfInversions+  , numberOfInversionsNaive+  , numberOfInversionsMerge+  , bubbleSort2+  , bubbleSort+    -- * Permutation groups+  , identityPermutation+  , inversePermutation+  , multiplyPermutation+  , productOfPermutations+  , productOfPermutations'+    -- * Action of the permutation group+  , permuteArray +  , permuteList+  , permuteArrayLeft , permuteArrayRight+  , permuteListLeft  , permuteListRight+    -- * Sorting+  , sortingPermutationAsc +  , sortingPermutationDesc+    -- * ASCII drawing+  , asciiPermutation+  , asciiDisjointCycles+  , twoLineNotation +  , inverseTwoLineNotation+  , genericTwoLineNotation+    -- * List of permutations+  , permutations+  , _permutations+  , permutationsNaive+  , _permutationsNaive+  , countPermutations+    -- * Random permutations+  , randomPermutation+  , _randomPermutation+  , randomCyclicPermutation+  , _randomCyclicPermutation+  , randomPermutationDurstenfeld+  , randomCyclicPermutationSattolo+    -- * Multisets+  , permuteMultiset+  , countPermuteMultiset+  , fasc2B_algorithm_L+  ) +  where++--------------------------------------------------------------------------------++import Control.Monad+import Control.Monad.ST++import Data.List hiding ( permutations )+import Data.Ord ( comparing )++import Data.Array (Array)+import Data.Array.ST+import Data.Array.Unboxed+import Data.Array.IArray+import Data.Array.MArray+import Data.Array.Unsafe++import Data.Vector.Compact.WordVec ( WordVec )+import qualified Data.Vector.Compact.WordVec as V++import Math.Combinat.ASCII+import Math.Combinat.Classes+import Math.Combinat.Helper+import Math.Combinat.Sign+import Math.Combinat.Numbers ( factorial , binomial )++import System.Random++--------------------------------------------------------------------------------+-- WordVec helpers++toUArray :: WordVec -> UArray Int Int+toUArray vec = listArray (1,n) (map fromIntegral $ V.toList vec) where n = V.vecLen vec++fromUArray :: UArray Int Int -> WordVec+fromUArray arr = fromPermListN n (map fromIntegral $ elems arr) where+  (1,n) = bounds arr++-- | maximum = length+fromPermListN :: Int -> [Int] -> WordVec+fromPermListN n perm = V.fromList' shape (map fromIntegral perm) where+  shape = V.Shape n bits+  bits  = V.bitsNeededFor (fromIntegral n :: Word)++fromPermList :: [Int] -> WordVec+fromPermList perm = V.fromList (map fromIntegral perm)++(.!) :: WordVec -> Int -> Int+(.!) vec idx = fromIntegral (V.unsafeIndex (idx-1) vec)++_elems :: WordVec -> [Int]+_elems = map fromIntegral . V.toList++_assocs :: WordVec -> [(Int,Int)]+_assocs vec = zip [1..] (_elems vec)++_bound :: WordVec -> Int+_bound = V.vecLen++{- +-- the old internal representation (UArray Int Int)++_elems :: UArray Int Int -> [Int]+_elems = elems++_assocs :: UArray Int Int -> [(Int,Int)]+_assocs = elems++_bound :: UArray Int Int -> Int+_bound = snd . bounds+-}+++toPermN :: Int -> [Int] -> Permutation+toPermN n xs = Permutation (fromPermListN n xs)++--------------------------------------------------------------------------------+-- * Types++-- | A permutation. Internally it is an (compact) vector +-- of the integers @[1..n]@.+--+-- If this array of integers is @[p1,p2,...,pn]@, then in two-line +-- notations, that represents the permutation+--+-- > ( 1  2  3  ... n  )+-- > ( p1 p2 p3 ... pn )+--+-- That is, it is the permutation @sigma@ whose (right) action on the set @[1..n]@ is+--+-- > sigma(1) = p1+-- > sigma(2) = p2 +-- > ...+--+-- (NOTE: this changed at version 0.2.8.0!)+--+newtype Permutation = Permutation WordVec deriving (Eq,Ord) -- ,Show,Read)++instance Show Permutation where+  showsPrec d (Permutation arr) +    = showParen (d > 10)  +    $ showString "toPermutation " . showsPrec 11 (_elems arr)       -- app_prec = 10++instance Read Permutation where+  readsPrec d r = readParen (d > 10) fun r where+    fun r = [ (toPermutation p,t) +            | ("toPermutation",s) <- lex r+            , (p,t) <- readsPrec 11 s                              -- app_prec = 10+            ] ++instance DrawASCII Permutation where+  ascii = asciiPermutation++-- | Disjoint cycle notation for permutations. Internally it is @[[Int]]@.+--+-- The cycles are to be understood as follows: a cycle @[c1,c2,...,ck]@ means+-- the permutation+--+-- > ( c1 c2 c3 ... ck )+-- > ( c2 c3 c4 ... c1 )+--+newtype DisjointCycles = DisjointCycles [[Int]] deriving (Eq,Ord,Show,Read)++fromPermutation :: Permutation -> [Int]+fromPermutation (Permutation ar) = _elems ar++permutationUArray :: Permutation -> UArray Int Int+permutationUArray (Permutation ar) = toUArray ar++permutationArray :: Permutation -> Array Int Int+permutationArray (Permutation ar) = listArray (1,n) (_elems ar) where+  n = _bound ar++-- | Assumes that the input is a permutation of the numbers @[1..n]@.+toPermutationUnsafe :: [Int] -> Permutation+toPermutationUnsafe xs = Permutation (fromPermList xs) ++-- | This is faster than 'toPermutationUnsafe', but you need to supply @n@.+toPermutationUnsafeN :: Int -> [Int] -> Permutation+toPermutationUnsafeN n xs = Permutation (fromPermListN n xs) ++-- | Note: Indexing starts from 1.+uarrayToPermutationUnsafe :: UArray Int Int -> Permutation+uarrayToPermutationUnsafe = Permutation . fromUArray++-- | Checks whether the input is a permutation of the numbers @[1..n]@.+isPermutation :: [Int] -> Bool+isPermutation xs = (ar!0 == 0) && and [ ar!j == 1 | j<-[1..n] ] where+  n = length xs+  -- the zero index is an unidiomatic hack+  ar = (accumArray (+) 0 (0,n) $ map f xs) :: UArray Int Int+  f :: Int -> (Int,Int)+  f !j = if j<1 || j>n then (0,1) else (j,1)++-- | Checks whether the input is a permutation of the numbers @[1..n]@.+maybePermutation :: [Int] -> Maybe Permutation+maybePermutation input = runST action where+  n = length input+  action :: forall s. ST s (Maybe Permutation)+  action = do+    ar <- newArray (1,n) 0 :: ST s (STUArray s Int Int)+    let go []     = return $ Just (toPermutationUnsafe input)+        go (j:js) = if j<1 || j>n +          then return Nothing+          else do+            z <- readArray ar j+            writeArray ar j (z+1)+            if z==0 then go js+                    else return Nothing               +    go input+    +-- | Checks the input.+toPermutation :: [Int] -> Permutation+toPermutation xs = case maybePermutation xs of+  Just p  -> p+  Nothing -> error "toPermutation: not a permutation"++-- | Returns @n@, where the input is a permutation of the numbers @[1..n]@+permutationSize :: Permutation -> Int+permutationSize (Permutation ar) = _bound ar++-- | Returns the image @sigma(k)@ of @k@ under the permutation @sigma@.+-- +-- Note: we don't check the bounds! It may even crash if you index out of bounds!+lookupPermutation :: Permutation -> Int -> Int+lookupPermutation (Permutation ar) idx = ar .! idx++-- infix 8 !!!++-- | Infix version of 'lookupPermutation'+(!!!) :: Permutation -> Int -> Int+(!!!) (Permutation ar) idx = ar .! idx++instance HasWidth Permutation where+  width = permutationSize++-- | Checks whether the permutation is the identity permutation+isIdentityPermutation :: Permutation -> Bool+isIdentityPermutation (Permutation ar) = (_elems ar == [1..n]) where+  n = _bound ar++-- | Given a permutation of @n@ and a permutation of @m@, we return+-- a permutation of @n+m@ resulting by putting them next to each other.+-- This should satisfy+--+-- > permuteList p1 xs ++ permuteList p2 ys == permuteList (concatPermutations p1 p2) (xs++ys)+--+concatPermutations :: Permutation -> Permutation -> Permutation +concatPermutations perm1 perm2 = toPermutationUnsafe list where+  n    = permutationSize perm1+  list = fromPermutation perm1 ++ map (+n) (fromPermutation perm2)++--------------------------------------------------------------------------------+-- * ASCII++-- | Synonym for 'twoLineNotation'+asciiPermutation :: Permutation -> ASCII+asciiPermutation = twoLineNotation ++asciiDisjointCycles :: DisjointCycles -> ASCII+asciiDisjointCycles (DisjointCycles cycles) = final where+  final = hCatWith VTop (HSepSpaces 1) boxes +  boxes = [ genericTwoLineNotation (f cyc) | cyc <- cycles ]+  f cyc = pairs (cyc ++ [head cyc])++-- | The standard two-line notation, moving the element indexed by the top row into+-- the place indexed by the corresponding element in the bottom row.+twoLineNotation :: Permutation -> ASCII+twoLineNotation (Permutation arr) = genericTwoLineNotation $ zip [1..] (_elems arr)++-- | The inverse two-line notation, where the it\'s the bottom line +-- which is in standard order. The columns of this are a permutation+-- of the columns 'twoLineNotation'.+--+-- Remark: the top row of @inverseTwoLineNotation perm@ is the same +-- as the bottom row of @twoLineNotation (inversePermutation perm)@.+--+inverseTwoLineNotation :: Permutation -> ASCII+inverseTwoLineNotation (Permutation arr) =+  genericTwoLineNotation $ sortBy (comparing snd) $ zip [1..] (_elems arr) ++-- | Two-line notation for any set of numbers+genericTwoLineNotation :: [(Int,Int)] -> ASCII+genericTwoLineNotation xys = asciiFromLines [ topLine, botLine ] where+  topLine = "( " ++ intercalate " " us ++ " )"+  botLine = "( " ++ intercalate " " vs ++ " )"+  pairs   = [ (show x, show y) | (x,y) <- xys ]+  (us,vs) = unzip (map f pairs) +  f (s,t) = (s',t') where+    a = length s +    b = length t+    c = max a b+    s' = replicate (c-a) ' ' ++ s+    t' = replicate (c-b) ' ' ++ t++--------------------------------------------------------------------------------+-- * Disjoint cycles++fromDisjointCycles :: DisjointCycles -> [[Int]]+fromDisjointCycles (DisjointCycles cycles) = cycles++disjointCyclesUnsafe :: [[Int]] -> DisjointCycles +disjointCyclesUnsafe = DisjointCycles++instance DrawASCII DisjointCycles where+  ascii = asciiDisjointCycles++instance HasNumberOfCycles DisjointCycles where+  numberOfCycles (DisjointCycles cycles) = length cycles++instance HasNumberOfCycles Permutation where+  numberOfCycles = numberOfCycles . permutationToDisjointCycles+  +disjointCyclesToPermutation :: Int -> DisjointCycles -> Permutation+disjointCyclesToPermutation n (DisjointCycles cycles) = Permutation $ fromUArray perm where++  pairs :: [Int] -> [(Int,Int)]+  pairs xs@(x:_) = worker (xs++[x]) where+    worker (x:xs@(y:_)) = (x,y):worker xs+    worker _ = [] +  pairs [] = error "disjointCyclesToPermutation: empty cycle"++  perm = runSTUArray $ do+    ar <- newArray_ (1,n) :: ST s (STUArray s Int Int)+    forM_ [1..n] $ \i -> writeArray ar i i +    forM_ cycles $ \cyc -> forM_ (pairs cyc) $ \(i,j) -> writeArray ar i j+    return ar -- freeze ar+  +-- | Convert to disjoint cycle notation.+--+-- This is compatible with Maple's @convert(perm,\'disjcyc\')@ +-- and also with Mathematica's @PermutationCycles[perm]@+--+-- Note however, that for example Mathematica uses the +-- /top row/ to represent a permutation, while we use the+-- /bottom row/ - thus even though this function looks+-- identical, the /meaning/ of both the input and output+-- is different!+-- +permutationToDisjointCycles :: Permutation -> DisjointCycles+permutationToDisjointCycles (Permutation perm) = res where++  n = _bound perm++  -- we don't want trivial cycles+  f :: [Int] -> Bool+  f [_] = False+  f _ = True+  +  res = runST $ do+    tag <- newArray (1,n) False +    cycles <- unfoldM (step tag) 1 +    return (DisjointCycles $ filter f cycles)+    +  step :: STUArray s Int Bool -> Int -> ST s ([Int],Maybe Int)+  step tag k = do+    cyc <- worker tag k k [k] +    m <- next tag (k+1)+    return (reverse cyc, m) +    +  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)+  next tag k = if k > n+    then return Nothing+    else readArray tag k >>= \b -> if b +      then next tag (k+1)  +      else return (Just k)+       +  worker :: STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int]+  worker tag k l cyc = do+    writeArray tag l True+    let m = perm .! l+    if m == k +      then return cyc+      else worker tag k m (m:cyc)      ++isEvenPermutation :: Permutation -> Bool+isEvenPermutation (Permutation perm) = res where++  n = _bound perm+  res = runST $ do+    tag <- newArray (1,n) False +    cycles <- unfoldM (step tag) 1 +    return $ even (sum cycles)+    +  step :: STUArray s Int Bool -> Int -> ST s (Int,Maybe Int)+  step tag k = do+    cyclen <- worker tag k k 0+    m <- next tag (k+1)+    return (cyclen,m)+    +  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)+  next tag k = if k > n+    then return Nothing+    else readArray tag k >>= \b -> if b +      then next tag (k+1)  +      else return (Just k)+      +  worker :: STUArray s Int Bool -> Int -> Int -> Int -> ST s Int+  worker tag k l cyclen = do+    writeArray tag l True+    let m = perm .! l+    if m == k +      then return cyclen+      else worker tag k m (1+cyclen)      ++isOddPermutation :: Permutation -> Bool+isOddPermutation = not . isEvenPermutation++signOfPermutation :: Permutation -> Sign+signOfPermutation perm = case isEvenPermutation perm of+  True  -> Plus+  False -> Minus++-- | Plus 1 or minus 1.+{-# SPECIALIZE signValueOfPermutation :: Permutation -> Int     #-}+{-# SPECIALIZE signValueOfPermutation :: Permutation -> Integer #-}+signValueOfPermutation :: Num a => Permutation -> a+signValueOfPermutation = signValue . signOfPermutation+  +isCyclicPermutation :: Permutation -> Bool+isCyclicPermutation perm = +  case cycles of+    []    -> True+    [cyc] -> (length cyc == n)+    _     -> False+  where +    n = permutationSize perm+    DisjointCycles cycles = permutationToDisjointCycles perm++--------------------------------------------------------------------------------+-- * Inversions++-- | An /inversion/ of a permutation @sigma@ is a pair @(i,j)@ such that+-- @i<j@ and @sigma(i) > sigma(j)@.+--+-- This functions returns the inversion of a permutation.+--+inversions :: Permutation -> [(Int,Int)]+inversions (Permutation arr) = list where+  n =  _bound arr+  list = [ (i,j) | i<-[1..n-1], j<-[i+1..n], arr.!i > arr.!j ]++-- | Returns the number of inversions:+--+-- > numberOfInversions perm = length (inversions perm)+--+-- Synonym for 'numberOfInversionsMerge'+--+numberOfInversions :: Permutation -> Int+numberOfInversions = numberOfInversionsMerge++-- | Returns the number of inversions, using the merge-sort algorithm.+-- This should be @O(n*log(n))@+--+numberOfInversionsMerge :: Permutation -> Int+numberOfInversionsMerge (Permutation arr) = fst (sortCnt n $ _elems arr) where+  n = _bound arr+                                        +  -- | First argument is length of the list.+  -- Returns also the inversion count.+  sortCnt :: Int -> [Int] -> (Int,[Int])+  sortCnt 0 _     = (0,[] )+  sortCnt 1 [x]   = (0,[x])+  sortCnt 2 [x,y] = if x>y then (1,[y,x]) else (0,[x,y])+  sortCnt n xs    = mergeCnt (sortCnt k us) (sortCnt l vs) where+    k = div n 2+    l = n - k +    (us,vs) = splitAt k xs++  mergeCnt :: (Int,[Int]) -> (Int,[Int]) -> (Int,[Int])+  mergeCnt (!c,us) (!d,vs) = (c+d+e,ws) where++    (e,ws) = go 0 us vs ++    go !k xs [] = ( k*length xs , xs )+    go _  [] ys = ( 0 , ys)+    go !k xxs@(x:xs) yys@(y:ys) = if x < y+      then let (a,zs) = go  k     xs yys in (a+k, x:zs)+      else let (a,zs) = go (k+1) xxs  ys in (a  , y:zs)++-- | Returns the number of inversions, using the definition, thus it's @O(n^2)@.+--+numberOfInversionsNaive :: Permutation -> Int+numberOfInversionsNaive (Permutation arr) = length list where+  n    = _bound arr+  list = [ (0::Int) | i<-[1..n-1], j<-[i+1..n], arr.!i > arr.!j ]++-- | Bubble sorts breaks a permutation into the product of adjacent transpositions:+--+-- > multiplyMany' n (map (transposition n) $ bubbleSort2 perm) == perm+--+-- Note that while this is not unique, the number of transpositions +-- equals the number of inversions.+--+bubbleSort2 :: Permutation -> [(Int,Int)]+bubbleSort2 = map f . bubbleSort where f i = (i,i+1)++-- | Another version of bubble sort. An entry @i@ in the return sequence means+-- the transposition @(i,i+1)@:+--+-- > multiplyMany' n (map (adjacentTransposition n) $ bubbleSort perm) == perm+--+bubbleSort :: Permutation -> [Int]+bubbleSort perm@(Permutation tgt) = runST action where+  n = _bound tgt++  action :: forall s. ST s [Int]+  action = do+    fwd <- newArray_ (1,n) :: ST s (STUArray s Int Int)+    inv <- newArray_ (1,n) :: ST s (STUArray s Int Int)+    forM_ [1..n] $ \i -> writeArray fwd i i+    forM_ [1..n] $ \i -> writeArray inv i i++    list <- forM [1..n] $ \x -> do++      let k = tgt .! x       -- we take the number which will be at the @x@-th position at the end+      i <- readArray inv k   -- number @k@ is at the moment at position @i@+      let j = x              -- but the final place is at @x@      ++      let swaps = move i j+      forM_ swaps $ \y -> do++        a <- readArray fwd  y+        b <- readArray fwd (y+1)+        writeArray fwd (y+1) a+        writeArray fwd  y    b++        u <- readArray inv a+        v <- readArray inv b+        writeArray inv b u+        writeArray inv a v++      return swaps+  +    return (concat list)++  move :: Int -> Int -> [Int]+  move !i !j+    | j == i  = []+    | j >  i  = [i..j-1]+    | j <  i  = [i-1,i-2..j]++--------------------------------------------------------------------------------+-- * Some concrete permutations++-- | The permutation @[n,n-1,n-2,...,2,1]@. Note that it is the inverse of itself.+reversePermutation :: Int -> Permutation+reversePermutation n = Permutation $ fromPermListN n [n,n-1..1]++-- | Checks whether the permutation is the reverse permutation @[n,n-1,n-2,...,2,1].+isReversePermutation :: Permutation -> Bool+isReversePermutation (Permutation arr) = _elems arr == [n,n-1..1] where n = _bound arr++-- | A transposition (swapping two elements). +--+-- @transposition n (i,j)@ is the permutation of size @n@ which swaps @i@\'th and @j@'th elements.+--+transposition :: Int -> (Int,Int) -> Permutation+transposition n (i,j) = +  if i>=1 && j>=1 && i<=n && j<=n +    then Permutation $ fromPermListN n [ f k | k<-[1..n] ]+    else error "transposition: index out of range"+  where+    f k | k == i    = j+        | k == j    = i+        | otherwise = k++-- | Product of transpositions.+--+-- > transpositions n list == multiplyMany [ transposition n pair | pair <- list ]+--+transpositions :: Int -> [(Int,Int)] -> Permutation+transpositions n list = Permutation (fromUArray $ runSTUArray action) where++  action :: ST s (STUArray s Int Int)+  action = do+    arr <- newArray_ (1,n) +    forM_ [1..n] $ \i -> writeArray arr i i    +    let doSwap (i,j) = do+          u <- readArray arr i+          v <- readArray arr j+          writeArray arr i v+          writeArray arr j u          +    mapM_ doSwap list+    return arr++-- | @adjacentTransposition n k@ swaps the elements @k@ and @(k+1)@.+adjacentTransposition :: Int -> Int -> Permutation+adjacentTransposition n k +  | k>0 && k<n  = transposition n (k,k+1)+  | otherwise   = error "adjacentTransposition: index out of range"++-- | Product of adjacent transpositions.+--+-- > adjacentTranspositions n list == multiplyMany [ adjacentTransposition n idx | idx <- list ]+--+adjacentTranspositions :: Int -> [Int] -> Permutation+adjacentTranspositions n list = Permutation (fromUArray $ runSTUArray action) where++  action :: ST s (STUArray s Int Int)+  action = do+    arr <- newArray_ (1,n) +    forM_ [1..n] $ \i -> writeArray arr i i    +    let doSwap i+          | i<0 || i>=n  = error "adjacentTranspositions: index out of range"+          | otherwise    = do+              u <- readArray arr  i+              v <- readArray arr (i+1)+              writeArray arr  i    v+              writeArray arr (i+1) u          +    mapM_ doSwap list+    return arr++-- | The permutation which cycles a list left by one step:+-- +-- > permuteList (cycleLeft 5) "abcde" == "bcdea"+--+-- Or in two-line notation:+--+-- > ( 1 2 3 4 5 )+-- > ( 2 3 4 5 1 )+-- +cycleLeft :: Int -> Permutation+cycleLeft n = Permutation $ fromPermListN n ([2..n] ++ [1])++-- | The permutation which cycles a list right by one step:+-- +-- > permuteList (cycleRight 5) "abcde" == "eabcd"+--+-- Or in two-line notation:+--+-- > ( 1 2 3 4 5 )+-- > ( 5 1 2 3 4 )+-- +cycleRight :: Int -> Permutation+cycleRight n = Permutation $ fromPermListN n (n : [1..n-1])+   +--------------------------------------------------------------------------------+-- * Permutation groups++-- | Multiplies two permutations together: @p `multiplyPermutation` q@+-- means the permutation when we first apply @p@, and then @q@+-- (that is, the natural action is the /right/ action)+--+-- See also 'permuteArray' for our conventions.  +--+multiplyPermutation :: Permutation -> Permutation -> Permutation+multiplyPermutation pi1@(Permutation perm1) pi2@(Permutation perm2) = +  if (n==m) +    then Permutation $ fromUArray result+    else error "multiplyPermutation: permutations of different sets"  +  where+    n = _bound perm1+    m = _bound perm2    +    result = permuteArray pi2 (toUArray perm1)+  +infixr 7 `multiplyPermutation`  ++-- | The inverse permutation.+inversePermutation :: Permutation -> Permutation    +inversePermutation (Permutation perm1) = Permutation $ fromUArray result+  where+    result = array (1,n) $ map swap $ _assocs perm1+    n = _bound perm1+    +-- | The identity (or trivial) permutation.+identityPermutation :: Int -> Permutation +identityPermutation n = Permutation $ fromPermListN n [1..n]++-- | Multiply together a /non-empty/ list of permutations (the reason for requiring the list to+-- be non-empty is that we don\'t know the size of the result). See also 'multiplyMany''.+productOfPermutations :: [Permutation] -> Permutation +productOfPermutations [] = error "productOfPermutations: empty list, we don't know size of the result"+productOfPermutations ps = foldl1' multiplyPermutation ps    ++-- | Multiply together a (possibly empty) list of permutations, all of which has size @n@+productOfPermutations' :: Int -> [Permutation] -> Permutation +productOfPermutations' n []       = identityPermutation n+productOfPermutations' n ps@(p:_) = if n == permutationSize p +  then foldl1' multiplyPermutation ps    +  else error "productOfPermutations': incompatible permutation size(s)"++--------------------------------------------------------------------------------+-- * Action of the permutation group++-- | /Right/ action of a permutation on a set. If our permutation is +-- encoded with the sequence @[p1,p2,...,pn]@, then in the+-- two-line notation we have+--+-- > ( 1  2  3  ... n  )+-- > ( p1 p2 p3 ... pn )+--+-- We adopt the convention that permutations act /on the right/ +-- (as in Knuth):+--+-- > permuteArray pi2 (permuteArray pi1 set) == permuteArray (pi1 `multiplyPermutation` pi2) set+--+-- Synonym to 'permuteArrayRight'+--+{-# SPECIALIZE permuteArray :: Permutation -> Array  Int b   -> Array  Int b   #-}+{-# SPECIALIZE permuteArray :: Permutation -> UArray Int Int -> UArray Int Int #-}+permuteArray :: IArray arr b => Permutation -> arr Int b -> arr Int b    +permuteArray = permuteArrayRight++-- | Right action on lists. Synonym to 'permuteListRight'+--+permuteList :: Permutation -> [a] -> [a]+permuteList = permuteListRight+    +-- | The right (standard) action of permutations on sets. +-- +-- > permuteArrayRight pi2 (permuteArrayRight pi1 set) == permuteArrayRight (pi1 `multiplyPermutation` pi2) set+--   +-- The second argument should be an array with bounds @(1,n)@.+-- The function checks the array bounds.+--+{-# SPECIALIZE permuteArrayRight :: Permutation -> Array  Int b   -> Array  Int b   #-}+{-# SPECIALIZE permuteArrayRight :: Permutation -> UArray Int Int -> UArray Int Int #-}+permuteArrayRight :: IArray arr b => Permutation -> arr Int b -> arr Int b    +permuteArrayRight pi@(Permutation perm) ar = +  if (a==1) && (b==n) +    then listArray (1,n) [ ar!(perm.!i) | i <- [1..n] ] +    else error "permuteArrayRight: array bounds do not match"+  where+    n     = _bound perm+    (a,b) = bounds ar   ++-- | The right (standard) action on a list. The list should be of length @n@.+--+-- > fromPermutation perm == permuteListRight perm [1..n]+-- +permuteListRight :: forall a . Permutation -> [a] -> [a]    +permuteListRight perm xs = elems $ permuteArrayRight perm $ arr where+  arr = listArray (1,n) xs :: Array Int a+  n   = permutationSize perm++-- | The left (opposite) action of the permutation group.+--+-- > permuteArrayLeft pi2 (permuteArrayLeft pi1 set) == permuteArrayLeft (pi2 `multiplyPermutation` pi1) set+--+-- It is related to 'permuteLeftArray' via:+--+-- > permuteArrayLeft  pi arr == permuteArrayRight (inversePermutation pi) arr+-- > permuteArrayRight pi arr == permuteArrayLeft  (inversePermutation pi) arr+--+{-# SPECIALIZE permuteArrayLeft :: Permutation -> Array  Int b   -> Array  Int b   #-}+{-# SPECIALIZE permuteArrayLeft :: Permutation -> UArray Int Int -> UArray Int Int #-}+permuteArrayLeft :: IArray arr b => Permutation -> arr Int b -> arr Int b    +permuteArrayLeft pi@(Permutation perm) ar =    +  -- permuteRight (inverse pi) ar+  if (a==1) && (b==n) +    then array (1,n) [ ( perm.!i , ar!i ) | i <- [1..n] ] +    else error "permuteArrayLeft: array bounds do not match"+  where+    n     = _bound perm+    (a,b) = bounds ar   ++-- | The left (opposite) action on a list. The list should be of length @n@.+--+-- > permuteListLeft perm set == permuteList (inversePermutation perm) set+-- > fromPermutation (inversePermutation perm) == permuteListLeft perm [1..n]+--+permuteListLeft :: forall a. Permutation -> [a] -> [a]    +permuteListLeft perm xs = elems $ permuteArrayLeft perm $ arr where+  arr = listArray (1,n) xs :: Array Int a+  n   = permutationSize perm++--------------------------------------------------------------------------------++-- | Given a list of things, we return a permutation which sorts them into+-- ascending order, that is:+--+-- > permuteList (sortingPermutationAsc xs) xs == sort xs+--+-- Note: if the things are not unique, then the sorting permutations is not+-- unique either; we just return one of them.+--+sortingPermutationAsc :: Ord a => [a] -> Permutation+sortingPermutationAsc xs = toPermutation (map fst sorted) where+  sorted = sortBy (comparing snd) $ zip [1..] xs++-- | Given a list of things, we return a permutation which sorts them into+-- descending order, that is:+--+-- > permuteList (sortingPermutationDesc xs) xs == reverse (sort xs)+--+-- Note: if the things are not unique, then the sorting permutations is not+-- unique either; we just return one of them.+--+sortingPermutationDesc :: Ord a => [a] -> Permutation+sortingPermutationDesc xs = toPermutation (map fst sorted) where+  sorted = sortBy (reverseComparing snd) $ zip [1..] xs++--------------------------------------------------------------------------------+-- * Permutations of distinct elements++-- | A synonym for 'permutationsNaive'+permutations :: Int -> [Permutation]+permutations = permutationsNaive++_permutations :: Int -> [[Int]]+_permutations = _permutationsNaive++-- | All permutations of @[1..n]@ in lexicographic order, naive algorithm.+permutationsNaive :: Int -> [Permutation]+permutationsNaive n = map toPermutationUnsafe $ _permutations n ++_permutationsNaive :: Int -> [[Int]]  +_permutationsNaive 0 = [[]]+_permutationsNaive 1 = [[1]]+_permutationsNaive n = helper [1..n] where+  helper [] = [[]]+  helper xs = [ i : ys | i <- xs , ys <- helper (xs `minus` i) ]+  minus [] _ = []+  minus (x:xs) i = if x < i then x : minus xs i else xs+          +-- | # = n!+countPermutations :: Int -> Integer+countPermutations = factorial++--------------------------------------------------------------------------------+-- * Random permutations++-- | A synonym for 'randomPermutationDurstenfeld'.+randomPermutation :: RandomGen g => Int -> g -> (Permutation,g)+randomPermutation = randomPermutationDurstenfeld++_randomPermutation :: RandomGen g => Int -> g -> ([Int],g)+_randomPermutation n rndgen = (fromPermutation perm, rndgen') where+  (perm, rndgen') = randomPermutationDurstenfeld n rndgen ++-- | A synonym for 'randomCyclicPermutationSattolo'.+randomCyclicPermutation :: RandomGen g => Int -> g -> (Permutation,g)+randomCyclicPermutation = randomCyclicPermutationSattolo++_randomCyclicPermutation :: RandomGen g => Int -> g -> ([Int],g)+_randomCyclicPermutation n rndgen = (fromPermutation perm, rndgen') where+  (perm, rndgen') = randomCyclicPermutationSattolo n rndgen ++-- | Generates a uniformly random permutation of @[1..n]@.+-- Durstenfeld's algorithm (see <http://en.wikipedia.org/wiki/Knuth_shuffle>).+randomPermutationDurstenfeld :: RandomGen g => Int -> g -> (Permutation,g)+randomPermutationDurstenfeld = randomPermutationDurstenfeldSattolo False++-- | Generates a uniformly random /cyclic/ permutation of @[1..n]@.+-- Sattolo's algorithm (see <http://en.wikipedia.org/wiki/Knuth_shuffle>).+randomCyclicPermutationSattolo :: RandomGen g => Int -> g -> (Permutation,g)+randomCyclicPermutationSattolo = randomPermutationDurstenfeldSattolo True++randomPermutationDurstenfeldSattolo :: RandomGen g => Bool -> Int -> g -> (Permutation,g)+randomPermutationDurstenfeldSattolo isSattolo n rnd = res where+  res = runST $ do+    ar <- newArray_ (1,n) +    forM_ [1..n] $ \i -> writeArray ar i i+    rnd' <- worker n (if isSattolo then n-1 else n) rnd ar +    perm <- Data.Array.Unsafe.unsafeFreeze ar+    return (Permutation (fromUArray perm), rnd')+  worker :: RandomGen g => Int -> Int -> g -> STUArray s Int Int -> ST s g +  worker n m rnd ar = +    if n==1 +      then return rnd +      else do+        let (k,rnd') = randomR (1,m) rnd+        when (k /= n) $ do+          y <- readArray ar k +          z <- readArray ar n+          writeArray ar n y+          writeArray ar k z+        worker (n-1) (m-1) rnd' ar ++--------------------------------------------------------------------------------+-- * Permutations of a multiset++-- | Generates all permutations of a multiset.  +--   The order is lexicographic. A synonym for 'fasc2B_algorithm_L'+permuteMultiset :: (Eq a, Ord a) => [a] -> [[a]] +permuteMultiset = fasc2B_algorithm_L++-- | # = \\frac { (\sum_i n_i) ! } { \\prod_i (n_i !) }    +countPermuteMultiset :: (Eq a, Ord a) => [a] -> Integer+countPermuteMultiset xs = factorial n `div` product [ factorial (length z) | z <- group ys ] +  where+    ys = sort xs+    n = length xs+  +-- | Generates all permutations of a multiset +--   (based on \"algorithm L\" in Knuth; somewhat less efficient). +--   The order is lexicographic.  +fasc2B_algorithm_L :: (Eq a, Ord a) => [a] -> [[a]] +fasc2B_algorithm_L xs = unfold1 next (sort xs) where++  -- next :: [a] -> Maybe [a]+  next xs = case findj (reverse xs,[]) of +    Nothing -> Nothing+    Just ( (l:ls) , rs) -> Just $ inc l ls (reverse rs,[]) +    Just ( [] , _ ) -> error "permute: should not happen"++  -- we use simple list zippers: (left,right)+  -- findj :: ([a],[a]) -> Maybe ([a],[a])   +  findj ( xxs@(x:xs) , yys@(y:_) ) = if x >= y +    then findj ( xs , x : yys )+    else Just ( xxs , yys )+  findj ( x:xs , [] ) = findj ( xs , [x] )  +  findj ( [] , _ ) = Nothing+  +  -- inc :: a -> [a] -> ([a],[a]) -> [a]+  inc !u us ( (x:xs) , yys ) = if u >= x+    then inc u us ( xs , x : yys ) +    else reverse (x:us)  ++ reverse (u:yys) ++ xs+  inc _ _ ( [] , _ ) = error "permute: should not happen"+      +--------------------------------------------------------------------------------++
+ src/Math/Combinat/RootSystems.hs view
@@ -0,0 +1,319 @@+
+-- | Naive (very inefficient) algorithm to generate the irreducible (Dynkin) root systems
+--
+-- Based on <https://en.wikipedia.org/wiki/Root_system>
+
+{-# LANGUAGE BangPatterns, FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-}
+module Math.Combinat.RootSystems where
+
+--------------------------------------------------------------------------------
+
+import Control.Monad
+
+import Data.Array
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Data.List
+import Data.Ord
+
+import Math.Combinat.Numbers.Primes
+import Math.Combinat.Sets
+
+--------------------------------------------------------------------------------
+-- * Half-integers
+
+-- | The type of half-integers (internally represented by their double)
+--
+-- TODO: refactor this into its own module
+newtype HalfInt 
+  = HalfInt Int  
+  deriving (Eq,Ord)
+
+half :: HalfInt
+half = HalfInt 1
+
+divByTwo :: Int -> HalfInt
+divByTwo n = HalfInt n
+
+mulByTwo :: HalfInt -> Int
+mulByTwo (HalfInt n) = n
+
+scaleBy :: Int -> HalfInt -> HalfInt
+scaleBy k (HalfInt n) = HalfInt (k*n)
+
+instance Show HalfInt where
+  show (HalfInt n) = case divMod n 2 of
+    (k,0) -> show k
+    (_,1) -> show n ++ "/2"
+
+instance Num HalfInt where
+  fromInteger = HalfInt . (*2) . fromInteger
+  a + b = divByTwo $ mulByTwo a + mulByTwo b
+  a - b = divByTwo $ mulByTwo a - mulByTwo b
+  a * b = case divMod (mulByTwo a * mulByTwo b) 4 of
+            (k,0) -> HalfInt (2*k)
+            (k,2) -> HalfInt (2*k+1)
+            _     -> error "the result of multiplication is not a half-integer"
+  negate = divByTwo . negate . mulByTwo
+  signum = divByTwo . signum . mulByTwo
+  abs    = divByTwo . abs    . mulByTwo
+
+--------------------------------------------------------------------------------
+-- * Vectors of half-integers
+
+type HalfVec = [HalfInt]
+
+instance Num HalfVec where
+  fromInteger = error "HalfVec/fromInteger"
+  (+) = safeZip (+)
+  (-) = safeZip (-)
+  (*) = safeZip (*)
+  negate = map negate
+  abs    = map abs
+  signum = map signum
+
+scaleVec :: Int -> HalfVec -> HalfVec  
+scaleVec k = map (scaleBy k)
+
+negateVec :: HalfVec -> HalfVec
+negateVec = map negate
+
+-- dotProd :: HalfVec -> HalfVec
+-- dotProd xs ys = foldl' (+) 0 $ safeZip (*) xs ys
+
+safeZip :: (a -> b -> c) -> [a] -> [b] -> [c]
+safeZip f = go where
+  go (x:xs) (y:ys) = f x y : go xs ys
+  go []     []     = []
+  go _      _      = error "safeZip: the lists do not have equal length"
+
+--------------------------------------------------------------------------------
+-- * Dynkin diagrams
+
+data Dynkin
+  = A !Int
+  | B !Int
+  | C !Int
+  | D !Int
+  | E6 | E7 | E8
+  | F4
+  | G2
+  deriving (Eq,Show)
+
+--------------------------------------------------------------------------------
+-- * The roots of root systems
+
+-- | The ambient dimension of (our representation of the) system (length of the vector)
+ambientDim :: Dynkin -> Int
+ambientDim d = case d of
+  A n -> n+1   -- it's an n dimensional subspace of (n+1) dimensions
+  B n -> n
+  C n -> n
+  D n -> n
+  E6  -> 6
+  E7  -> 8     -- sublattice of E8 ?
+  E8  -> 8
+  F4  -> 4
+  G2  -> 3     -- it's a 2 dimensional subspace of 3 dimensions
+
+simpleRootsOf :: Dynkin -> [HalfVec]
+simpleRootsOf d = 
+
+  case d of
+
+    A n -> [ e i - e (i+1) | i <- [1..n]   ]
+
+    B n -> [ e i - e (i+1) | i <- [1..n-1] ] ++ [e n]
+
+    C n -> [ e i - e (i+1) | i <- [1..n-1] ] ++ [scaleVec 2 (e n)]
+
+    D n -> [ e i - e (i+1) | i <- [1..n-1] ] ++ [e (n-1) + e n]
+
+    E6  -> simpleRootsE6_123
+    E7  -> simpleRootsE7_12
+    E8  -> simpleRootsE8_even 
+
+    F4  -> [ [ 1,-1, 0, 0]
+           , [ 0, 1,-1, 0]
+           , [ 0, 0, 1, 0]
+           , [-h,-h,-h,-h]
+           ]
+
+    G2  -> [ [ 1,-1, 0]
+           , [-1, 2,-1]
+           ]
+
+  where
+    h = half
+    n = ambientDim d
+
+    e :: Int -> HalfVec
+    e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0
+
+positiveRootsOf :: Dynkin -> Set HalfVec
+positiveRootsOf = positiveRoots . simpleRootsOf
+
+negativeRootsOf :: Dynkin -> Set HalfVec
+negativeRootsOf = Set.map negate . positiveRootsOf
+
+allRootsOf :: Dynkin -> Set HalfVec
+allRootsOf dynkin = Set.unions [  pos , neg ] where
+  simple = simpleRootsOf dynkin
+  pos   = positiveRoots simple
+  neg   = Set.map negate pos
+
+--------------------------------------------------------------------------------
+-- * Positive roots
+
+-- | Finds a vector, which is hopefully not orthognal to any root
+-- (generated by the given simple roots), and has positive dot product with each of them.
+findPositiveHyperplane :: [HalfVec] -> [Double]
+findPositiveHyperplane vs = w where
+  n  = length (head vs)
+  w0 = map (fromIntegral . mulByTwo) (foldl1 (+) vs) :: [Double]
+  w  = zipWith (+) w0 perturb
+  perturb = map small $ map fromIntegral $ take n primes
+  small :: Double -> Double
+  small x = x / (10**10) 
+
+positiveRoots :: [HalfVec] -> Set HalfVec
+positiveRoots simples = Set.fromList pos where
+  roots = mirrorClosure simples
+  w     = findPositiveHyperplane simples
+  pos   = [ r | r <- Set.toList roots , dot4 r > 0 ] where
+
+  dot4 :: HalfVec -> Double
+  dot4 a = foldl' (+) 0 $ safeZip (*) w $ map (fromIntegral . mulByTwo) a
+
+basisOfPositives :: Set HalfVec -> [HalfVec]
+basisOfPositives set = Set.toList (Set.difference set set2) where
+  set2 = Set.fromList [ a + b | [a,b] <- choose 2 (Set.toList set) ]
+
+
+--------------------------------------------------------------------------------
+-- * Operations on half-integer vectors
+
+-- | bracket b a = (a,b)/(a,a) 
+bracket :: HalfVec -> HalfVec -> HalfInt
+bracket b a = 
+  case divMod (2*a_dot_b) (a_dot_a) of
+    (n,0) -> divByTwo n
+    _     -> error "bracket: result is not a half-integer"
+  where
+    a_dot_b = foldl' (+) 0 $ safeZip (*) (map mulByTwo a) (map mulByTwo b)
+    a_dot_a = foldl' (+) 0 $ safeZip (*) (map mulByTwo a) (map mulByTwo a)
+
+-- | mirror b a = b - 2*(a,b)/(a,a) * a
+mirror :: HalfVec -> HalfVec -> HalfVec
+mirror b a = b - scaleVec (mulByTwo $ bracket b a) a
+
+-- | Cartan matrix of a list of (simple) roots
+cartanMatrix :: [HalfVec] -> Array (Int,Int) Int
+cartanMatrix list = array ((1,1),(n,n)) [ ((i,j), f i j) | i<-[1..n] , j<-[1..n] ] where
+  n   = length list
+  arr = listArray (1,n) list
+  f !i !j = mulByTwo $ bracket (arr!j) (arr!i)
+
+printMatrix :: Show a => Array (Int,Int) a -> IO ()
+printMatrix arr = do
+  let ((1,1),(n,m)) = bounds arr
+      arr' = fmap show arr
+  let ks   = [ 1 + maximum [ length (arr'!(i,j)) | i<-[1..n] ] | j<-[1..m] ]
+  forM_ [1..n] $ \i -> do
+    putStrLn $ flip concatMap [1..m] $ \j -> extendTo (ks!!(j-1)) $ arr' ! (i,j)
+  where
+    extendTo n s = replicate (n-length s) ' ' ++ s
+
+--------------------------------------------------------------------------------
+-- * Mirroring 
+
+-- | We mirror stuff until there is no more things happening
+-- (very naive algorithm, but seems to work)
+mirrorClosure :: [HalfVec] -> Set HalfVec
+mirrorClosure = go . Set.fromList where 
+  
+  go set 
+    | n'  > n   = go set'
+    | n'' > n   = go set''
+    | otherwise = set
+    where
+      n   = Set.size set
+      n'  = Set.size set'
+      n'' = Set.size set''
+      set'  = mirrorStep set
+      set'' = Set.union set (Set.map negateVec set) 
+
+mirrorStep :: Set HalfVec -> Set HalfVec
+mirrorStep old = Set.union old new where
+  new = Set.fromList [ mirror b a | [a,b] <- choose 2 $ Set.toList old ] 
+
+--------------------------------------------------------------------------------
+-- * E6, E7 and E8
+
+-- | This is a basis of E6 as the subset of the even E8 root system
+-- where the first three coordinates agree (they are consolidated 
+-- into the first coordinate here)
+simpleRootsE6_123:: [HalfVec]
+simpleRootsE6_123 = roots where
+  h = half
+  roots =
+    [ [-h,-h,-h,-h,-h,-h,-h,-h]
+    , [ h, h, h, h, h, h,-h,-h]
+    , [ 0, 0, 0, 0,-1, 0, 1, 0]
+    , [ 0, 0, 0, 0, 0, 0,-1, 1]
+    , [-h,-h,-h, h, h, h, h,-h]
+    , [ 0, 0, 0,-1, 1, 0, 0, 0]
+    ]
+
+-- | This is a basis of E8 as the subset of the even E8 root system
+-- where the first two coordinates agree (they are consolidated 
+-- into the first coordinate here)
+simpleRootsE7_12:: [HalfVec]
+simpleRootsE7_12 = roots where
+  h = half
+  roots =
+    [ [-h,-h,-h,-h,-h,-h,-h,-h]
+    , [ h, h, h, h, h, h,-h,-h]
+    , [ h, h,-h,-h,-h,-h, h, h]
+    , [-h,-h, h, h,-h, h, h,-h]
+    , [ 0, 0, 0,-1, 1, 0, 0, 0]
+    , [ 0, 0,-1, 1, 0, 0, 0, 0]
+    , [ 0, 0, 0, 0, 0, 0,-1, 1]
+    ]
+
+-- | This is a basis of E7 as the subset of the even E8 root system
+-- for which the sum of coordinates sum to zero
+simpleRootsE7_diag :: [HalfVec]
+simpleRootsE7_diag = roots where
+  roots = [ e i - e (i+1) | i <-[2..7] ] ++ [[h,h,h,h,-h,-h,-h,-h]]
+  h = half
+  n = 8
+
+  e :: Int -> HalfVec
+  e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 
+
+simpleRootsE8_even :: [HalfVec]
+simpleRootsE8_even = roots where
+  roots = [v1,v2,v3,v4,v5,v7,v8,v6]
+
+  [v1,v2,v3,v4,v5,v6,v7,v8] = roots0
+  roots0 = [ e i - e (i+1) | i <-[1..6] ] ++ [ e 6 + e 7 , replicate 8 (-h)  ]
+    
+  h = half
+  n = 8
+
+  e :: Int -> HalfVec
+  e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0
+
+simpleRootsE8_odd :: [HalfVec]
+simpleRootsE8_odd = roots where
+  roots = [ e i - e (i+1) | i <-[1..7] ] ++ [[-h,-h,-h,-h,-h , h,h,h]]
+  h = half
+  n = 8
+
+  e :: Int -> HalfVec
+  e i = replicate (i-1) 0 ++ [1] ++ replicate (n-i) 0 
+
+--------------------------------------------------------------------------------
+ src/Math/Combinat/Sets.hs view
@@ -0,0 +1,212 @@++-- | Subsets. ++{-# LANGUAGE BangPatterns, Rank2Types #-}+module Math.Combinat.Sets +  ( +    -- * Choices+    choose_ , choose , choose' , choose'' , chooseTagged+    -- * Compositions+  , combine , compose+    -- * Tensor products+  , tuplesFromList+  , listTensor+    -- * Sublists+  , kSublists+  , sublists+  , countKSublists+  , countSublists+    -- * Random choice+  , randomChoice+  ) +  where++--------------------------------------------------------------------------------++import Data.List ( sort , mapAccumL )+import System.Random++import Control.Monad+import Control.Monad.ST+import Data.Array.ST+import Data.Array.MArray++-- import Data.Map (Map)+-- import qualified Data.Map as Map++import Math.Combinat.Numbers ( binomial )+import Math.Combinat.Helper  ( swap )++--------------------------------------------------------------------------------+-- * choices+++-- | @choose_ k n@ returns all possible ways of choosing @k@ disjoint elements from @[1..n]@+--+-- > choose_ k n == choose k [1..n]+--+choose_ :: Int -> Int -> [[Int]]+choose_ k n  = if n<0 || k<0+  then error "choose_: n and k should nonnegative"+  else if k>n || k<0 +    then []+    else choose k [1..n]++-- | All possible ways to choose @k@ elements from a list, without+-- repetitions. \"Antisymmetric power\" for lists. Synonym for 'kSublists'.+choose :: Int -> [a] -> [[a]]+choose 0 _  = [[]]+choose k [] = []+choose k (x:xs) = map (x:) (choose (k-1) xs) ++ choose k xs  ++-- | A version of 'choose' which also returns the complementer sets.+--+-- > choose k = map fst . choose' k+--+choose' :: Int -> [a] -> [([a],[a])]+choose' 0 xs = [([],xs)]+choose' k [] = []+choose' k (x:xs) = map f (choose' (k-1) xs) ++ map g (choose' k xs) where+  f (as,bs) = (x:as ,   bs)+  g (as,bs) = (  as , x:bs)++-- | Another variation of 'choose''. This satisfies+--+-- > choose'' k == map (\(xs,ys) -> (map fst xs, map snd ys)) . choose' k+--+choose'' :: Int -> [(a,b)] -> [([a],[b])]+choose'' 0 xys = [([] , map snd xys)]+choose'' k []  = []+choose'' k ((x,y):xs) = map f (choose'' (k-1) xs) ++ map g (choose'' k xs) where+  f (as,bs) = (x:as ,   bs)+  g (as,bs) = (  as , y:bs)++-- | Another variation on 'choose' which tags the elements based on whether they are part of+-- the selected subset ('Right') or not ('Left'):+--+-- > choose k = map rights . chooseTagged k+--+chooseTagged :: Int -> [a] -> [[Either a a]]+chooseTagged 0 xs = [map Left xs]+chooseTagged k [] = []+chooseTagged k (x:xs) = map f (chooseTagged (k-1) xs) ++ map g (chooseTagged k xs) where+  f eis = Right x : eis+  g eis = Left  x : eis++-- | All possible ways to choose @k@ elements from a list, /with repetitions/. +-- \"Symmetric power\" for lists. See also "Math.Combinat.Compositions".+-- TODO: better name?+combine :: Int -> [a] -> [[a]]+combine 0 _  = [[]]+combine k [] = []+combine k xxs@(x:xs) = map (x:) (combine (k-1) xxs) ++ combine k xs  ++-- | A synonym for 'combine'.+compose :: Int -> [a] -> [[a]]+compose = combine++--------------------------------------------------------------------------------+-- * tensor products++-- | \"Tensor power\" for lists. Special case of 'listTensor':+--+-- > tuplesFromList k xs == listTensor (replicate k xs)+-- +-- See also "Math.Combinat.Tuples".+-- TODO: better name?+tuplesFromList :: Int -> [a] -> [[a]]+tuplesFromList 0 _  = [[]]+tuplesFromList k xs = [ (y:ys) | ys <- tuplesFromList (k-1) xs , y <- xs ]+--the order seems to be very important, the wrong order causes a memory leak!+--tuplesFromList k xs = [ (y:ys) | y <- xs, ys <- tuplesFromList (k-1) xs ]+ +-- | \"Tensor product\" for lists.+listTensor :: [[a]] -> [[a]]+listTensor [] = [[]]+listTensor (xs:xss) = [ y:ys | ys <- listTensor xss , y <- xs ]+--the order seems to be very important, the wrong order causes a memory leak!+--listTensor (xs:xss) = [ y:ys | y <- xs, ys <- listTensor xss ]++--------------------------------------------------------------------------------+-- * sublists++-- | Sublists of a list having given number of elements. Synonym for 'choose'.+kSublists :: Int -> [a] -> [[a]]+kSublists = choose++-- | @# = \binom { n } { k }@.+countKSublists :: Int -> Int -> Integer+countKSublists k n = binomial n k ++-- | All sublists of a list.+sublists :: [a] -> [[a]]+sublists [] = [[]]+sublists (x:xs) = sublists xs ++ map (x:) (sublists xs)  +--the order seems to be very important, the wrong order causes a memory leak!+--sublists (x:xs) = map (x:) (sublists xs) ++ sublists xs ++-- | @# = 2^n@.+countSublists :: Int -> Integer+countSublists n = 2 ^ n++--------------------------------------------------------------------------------+-- * random choice++-- | @randomChoice k n@ returns a uniformly random choice of @k@ elements from the set @[1..n]@+--+-- Example:+--+-- > do+-- >   cs <- replicateM 10000 (getStdRandom (randomChoice 3 7))+-- >   mapM_ print $ histogram cs+-- +randomChoice :: RandomGen g => Int -> Int -> g -> ([Int],g)+randomChoice k n g0 = +  if k>n || k<0 +    then error "randomChoice: k out of range" +    else (makeChoiceFromIndicesKnuth n as, g1) +  where+    -- choose numbers from [1..n], [1..n-1], [1..n-2] etc+    (g1,as) = mapAccumL (\g m -> swap (randomR (1,m) g)) g0 [n,n-1..n-k+1]   ++--------------------------------------------------------------------------------+   +-- | From a list of $k$ numbers, where the first is in the interval @[1..n]@, +-- the second in @[1..n-1]@, the third in @[1..n-2]@, we create a size @k@ subset of @n@.+--+-- Knuth's method. The first argument is the number @n@.+--+makeChoiceFromIndicesKnuth :: Int -> [Int] -> [Int]+makeChoiceFromIndicesKnuth n xs = +  runST $ do+    arr <- newArray_ (1,n) :: forall s. ST s (STUArray s Int Int)+    forM_ [1..n] $ \(!j) -> writeArray arr j j+    forM_ (zip [n,n-1..] xs) $ \(!j,!i) -> do+      a <- readArray arr j+      b <- readArray arr i+      writeArray arr j b+      writeArray arr i a+    sel <- forM (zip [n,n-1..] xs) $ \(!j,_) -> readArray arr j+    return (sort sel)++-- | From a list of $k$ numbers, where the first is in the interval @[1..n]@, +-- the second in @[1..n-1]@, the third in @[1..n-2]@, we create a size @k@ subset of @n@.+makeChoiceFromIndicesNaive :: [Int] -> [Int]+makeChoiceFromIndicesNaive = sort . go [] where++  go :: [Int] -> [Int] -> [Int]+  go acc (b:bs) = b' : go (insert b' acc) bs where b' = skip b acc+  go _   [] = []++  -- skip over the already occupied positions. Second argument should be a sorted list+  skip :: Int -> [Int] -> Int+  skip x (y:ys) = if x>=y then skip (x+1) ys else x+  skip x [] = x++  -- insert into a sorted list+  insert :: Int -> [Int] -> [Int]+  insert x (y:ys) = if x<=y then x:y:ys else y : insert x ys+  insert x [] = [x]++--------------------------------------------------------------------------------+
+ src/Math/Combinat/Sets/VennDiagrams.hs view
@@ -0,0 +1,150 @@++-- | Venn diagrams. See <https://en.wikipedia.org/wiki/Venn_diagram>+--+-- TODO: write a more efficient implementation (for example an array of size @2^n@)+--++{-# LANGUAGE BangPatterns #-}+module Math.Combinat.Sets.VennDiagrams where++--------------------------------------------------------------------------------++import Data.List++import GHC.TypeLits+import Data.Proxy++import qualified Data.Map as Map+import Data.Map (Map)++import Math.Combinat.Compositions+import Math.Combinat.ASCII++--------------------------------------------------------------------------------++-- | Venn diagrams of @n@ sets. Each possible zone is annotated with a value+-- of type @a@. A typical use case is to annotate with the cardinality of the+-- given zone.+--+-- Internally this is representated by a map from @[Bool]@, where @True@ means element +-- of the set, @False@ means not.+--+-- TODO: write a more efficient implementation (for example an array of size 2^n)+newtype VennDiagram a = VennDiagram { vennTable :: Map [Bool] a } deriving (Eq,Ord,Show)++-- | How many sets are in the Venn diagram+vennDiagramNumberOfSets :: VennDiagram a -> Int+vennDiagramNumberOfSets (VennDiagram table) = length $ fst $ Map.findMin table++-- | How many zones are in the Venn diagram+--+-- > vennDiagramNumberOfZones v == 2 ^ (vennDiagramNumberOfSets v)+--+vennDiagramNumberOfZones :: VennDiagram a -> Int+vennDiagramNumberOfZones venn = 2 ^ (vennDiagramNumberOfSets venn)++-- | How many /nonempty/ zones are in the Venn diagram+vennDiagramNumberOfNonemptyZones :: VennDiagram Int -> Int+vennDiagramNumberOfNonemptyZones (VennDiagram table) = length $ filter (/=0) $ Map.elems table++unsafeMakeVennDiagram :: [([Bool],a)] -> VennDiagram a+unsafeMakeVennDiagram = VennDiagram . Map.fromList++-- | We call venn diagram trivial if all the intersection zones has zero cardinality+-- (that is, the original sets are all disjoint)+isTrivialVennDiagram :: VennDiagram Int -> Bool+isTrivialVennDiagram (VennDiagram table) = and [ c == 0 | (bs,c) <- Map.toList table , isIntersection bs ] where+  isIntersection bs = case filter id bs of+    []  -> False+    [_] -> False+    _   -> True++printVennDiagram :: Show a => VennDiagram a -> IO ()+printVennDiagram = putStrLn . prettyVennDiagram++prettyVennDiagram :: Show a => VennDiagram a -> String+prettyVennDiagram = unlines . asciiLines . asciiVennDiagram++asciiVennDiagram :: Show a => VennDiagram a -> ASCII+asciiVennDiagram (VennDiagram table) = asciiFromLines $ map f (Map.toList table) where+  f (bs,a) = "{" ++ extendTo (length bs) [ if b then z else ' ' | (b,z) <- zip bs abc ] ++ "} -> " ++ show a+  extendTo k str = str ++ replicate (k - length str) ' '+  abc = ['A'..'Z']++instance Show a => DrawASCII (VennDiagram a) where+  ascii = asciiVennDiagram++-- | Given a Venn diagram of cardinalities, we compute the cardinalities of the+-- original sets (note: this is slow!)+vennDiagramSetCardinalities :: VennDiagram Int -> [Int]+vennDiagramSetCardinalities (VennDiagram table) = go n list where+  list = Map.toList table+  n = length $ fst $ head list+  go :: Int -> [([Bool],Int)] -> [Int]+  go !0 _  = []+  go !k xs = this : go (k-1) (map xtail xs) where+    this = foldl' (+) 0 [ c | ((True:_) , c) <- xs ]+  xtail (bs,c) = (tail bs,c)++--------------------------------------------------------------------------------++-- | Given the cardinalities of some finite sets, we list all possible+-- Venn diagrams.+--+-- Note: we don't include the empty zone in the tables, because it's always empty.+--+-- Remark: if each sets is a singleton set, we get back set partitions:+--+-- > > [ length $ enumerateVennDiagrams $ replicate k 1 | k<-[1..8] ]+-- > [1,2,5,15,52,203,877,4140]+-- >+-- > > [ countSetPartitions k | k<-[1..8] ]+-- > [1,2,5,15,52,203,877,4140]+--+-- Maybe this could be called multiset-partitions?+--+-- Example:+--+-- > autoTabulate RowMajor (Right 6) $ map ascii $ enumerateVennDiagrams [2,3,3]+--+enumerateVennDiagrams :: [Int] -> [VennDiagram Int]+enumerateVennDiagrams dims = +  case dims of+    []     -> []+    [d]    -> venns1 d+    (d:ds) -> concatMap (worker (length ds) d) $ enumerateVennDiagrams ds+  where++    worker !n !d (VennDiagram table) = result where++      list   = Map.toList table+      falses = replicate n False++      comps k = compositions' (map snd list) k+      result = +        [ unsafeMakeVennDiagram $ +            [ (False:tfs    , m-c) | ((tfs,m),c) <- zip list comp ] +++            [ (True :tfs    ,   c) | ((tfs,m),c) <- zip list comp ] +++            [ (True :falses , d-k) ]+        | k <- [0..d]+        , comp <- comps k+        ]++    venns1 :: Int -> [VennDiagram Int]+    venns1 p = [ theVenn ] where +      theVenn = unsafeMakeVennDiagram [ ([True],p) ] ++--------------------------------------------------------------------------------++{-++-- | for testing only+venns2 :: Int -> Int -> [Venn Int]+venns2 p q = +  [ mkVenn [ ([t,f],p-k) , ([f,t],q-k) , ([t,t],k) ]+  | k <- [0..min p q] +  ]+  where+    t = True+    f = False+-}
+ src/Math/Combinat/Sign.hs view
@@ -0,0 +1,114 @@++-- | Signs++{-# LANGUAGE CPP, BangPatterns #-}+module Math.Combinat.Sign where++--------------------------------------------------------------------------------++import Data.Monoid++-- Semigroup became a superclass of Monoid+#if MIN_VERSION_base(4,11,0)     +import Data.Foldable+import Data.Semigroup+#endif++import System.Random++--------------------------------------------------------------------------------++data Sign+  = Plus                            -- hmm, this way @Plus < Minus@, not sure about that+  | Minus+  deriving (Eq,Ord,Show,Read)++--------------------------------------------------------------------------------++-- Semigroup became a superclass of Monoid+#if MIN_VERSION_base(4,11,0)        ++instance Semigroup Sign where+  (<>)    = mulSign+  sconcat = foldl1 mulSign++instance Monoid Sign where+  mempty  = Plus+  mconcat = productOfSigns++#else++instance Monoid Sign where+  mempty  = Plus+  mappend = mulSign+  mconcat = productOfSigns++#endif++--------------------------------------------------------------------------------++instance Random Sign where+  random        g = let (b,g') = random g in (if b    then Plus else Minus, g')+  randomR (u,v) g = let (y,g') = random g in (if u==v then u    else y    , g') ++isPlus, isMinus :: Sign -> Bool+isPlus  s = case s of { Plus  -> True ; _ -> False }+isMinus s = case s of { Minus -> True ; _ -> False }++{-# SPECIALIZE signValue :: Sign -> Int     #-}+{-# SPECIALIZE signValue :: Sign -> Integer #-}++-- | @+1@ or @-1@+signValue :: Num a => Sign -> a+signValue s = case s of +  Plus  ->  1 +  Minus -> -1 ++{-# SPECIALIZE signed :: Sign -> Int     -> Int     #-}+{-# SPECIALIZE signed :: Sign -> Integer -> Integer #-}++-- | Negate the second argument if the first is 'Minus'+signed :: Num a => Sign -> a -> a+signed s y = case s of+  Plus  -> y+  Minus -> negate y++{-# SPECIALIZE paritySign :: Int     -> Sign #-}+{-# SPECIALIZE paritySign :: Integer -> Sign #-}++-- | 'Plus' if even, 'Minus' if odd+paritySign :: Integral a => a -> Sign+paritySign x = if even x then Plus else Minus ++{-# SPECIALIZE paritySignValue :: Int     -> Integer #-}+{-# SPECIALIZE paritySignValue :: Integer -> Integer #-}++-- | @(-1)^k@+paritySignValue :: Integral a => a -> Integer+paritySignValue k = if odd k then (-1) else 1++{-# SPECIALIZE negateIfOdd :: Int     -> Int     -> Int     #-}+{-# SPECIALIZE negateIfOdd :: Int     -> Integer -> Integer #-}++-- | Negate the second argument if the first is odd+negateIfOdd :: (Integral a, Num b) => a -> b -> b+negateIfOdd k y = if even k then y else negate y++oppositeSign :: Sign -> Sign+oppositeSign s = case s of+  Plus  -> Minus+  Minus -> Plus++mulSign :: Sign -> Sign -> Sign+mulSign s1 s2 = case s1 of+  Plus  -> s2+  Minus -> oppositeSign s2++productOfSigns :: [Sign] -> Sign+productOfSigns = go Plus where+  go !acc []     = acc+  go !acc (x:xs) = case x of+    Plus  -> go acc xs+    Minus -> go (oppositeSign acc) xs++--------------------------------------------------------------------------------
+ src/Math/Combinat/Tableaux.hs view
@@ -0,0 +1,242 @@++-- | Young tableaux and similar gadgets. +--+--   See e.g. William Fulton: Young Tableaux, with Applications to +--   Representation theory and Geometry (CUP 1997).+-- +--   The convention is that we use +--   the English notation, and we store the tableaux as lists of the rows.+-- +--   That is, the following standard Young tableau of shape [5,4,1]+-- +-- >  1  3  4  6  7+-- >  2  5  8 10+-- >  9+--+-- <<svg/young_tableau.svg>>+--+--   is encoded conveniently as+-- +-- > [ [ 1 , 3 , 4 , 6 , 7 ]+-- > , [ 2 , 5 , 8 ,10 ]+-- > , [ 9 ]+-- > ]+--++{-# LANGUAGE CPP, BangPatterns, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}+module Math.Combinat.Tableaux where++--------------------------------------------------------------------------------++import Data.List++import Math.Combinat.Classes+import Math.Combinat.Numbers ( factorial , binomial )+import Math.Combinat.Partitions.Integer+import Math.Combinat.Partitions.Integer.IntList ( _dualPartition )+import Math.Combinat.ASCII+import Math.Combinat.Helper++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++--------------------------------------------------------------------------------+-- * Basic stuff++-- | A tableau is simply represented as a list of lists.+type Tableau a = [[a]]++-- | ASCII diagram of a tableau+asciiTableau :: Show a => Tableau a -> ASCII+asciiTableau t = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) +           $ (map . map) asciiShow+           $ t++instance CanBeEmpty (Tableau a) where+  empty   = []+  isEmpty = null++instance Show a => DrawASCII (Tableau a) where +  ascii = asciiTableau++_tableauShape :: Tableau a -> [Int]+_tableauShape t = map length t ++-- | The shape of a tableau+tableauShape :: Tableau a -> Partition+tableauShape t = toPartition (_tableauShape t)++instance HasShape (Tableau a) Partition where+  shape = tableauShape++-- | Number of entries+tableauWeight :: Tableau a -> Int+tableauWeight = sum' . map length++instance HasWeight (Tableau a) where+  weight = tableauWeight++-- | The dual of the tableau is the mirror image to the main diagonal.+dualTableau :: Tableau a -> Tableau a+dualTableau = transpose++instance HasDuality (Tableau a) where+  dual = dualTableau++-- | The content of a tableau is the list of its entries. The ordering is from the left to the right and+-- then from the top to the bottom+tableauContent :: Tableau a -> [a]+tableauContent = concat++-- | An element @(i,j)@ of the resulting tableau (which has shape of the+-- given partition) means that the vertical part of the hook has length @i@,+-- and the horizontal part @j@. The /hook length/ is thus @i+j-1@. +--+-- Example:+--+-- > > mapM_ print $ hooks $ toPartition [5,4,1]+-- > [(3,5),(2,4),(2,3),(2,2),(1,1)]+-- > [(2,4),(1,3),(1,2),(1,1)]+-- > [(1,1)]+--+hooks :: Partition -> Tableau (Int,Int)+hooks part = zipWith f p [1..] where +  p = fromPartition part+  q = _dualPartition p+  f l i = zipWith (\x y -> (x-i+1,y)) q [l,l-1..1] ++hookLengths :: Partition -> Tableau Int+hookLengths part = (map . map) (\(i,j) -> i+j-1) (hooks part) ++--------------------------------------------------------------------------------+-- * Row and column words++-- | The /row word/ of a tableau is the list of its entry read from the right to the left and then+-- from the top to the bottom.+rowWord :: Tableau a -> [a]+rowWord = concat . reverse++-- | /Semistandard/ tableaux can be reconstructed from their row words+rowWordToTableau :: Ord a => [a] -> Tableau a+rowWordToTableau xs = reverse rows where+  rows = break xs+  break [] = [[]]+  break [x] = [[x]]+  break (x:xs@(y:_)) = if x>y+    then [x] : break xs+    else let (h:t) = break xs in (x:h):t++-- | The /column word/ of a tableau is the list of its entry read from the bottom to the top and then from the left to the right+columnWord :: Tableau a -> [a]+columnWord = rowWord . transpose++-- | /Standard/ tableaux can be reconstructed from either their column or row words+columnWordToTableau :: Ord a => [a] -> Tableau a+columnWordToTableau = transpose . rowWordToTableau++-- | Checks whether a sequence of positive integers is a /lattice word/, +-- which means that in every initial part of the sequence any number @i@+-- occurs at least as often as the number @i+1@+--+isLatticeWord :: [Int] -> Bool+isLatticeWord = go Map.empty where+  go :: Map Int Int -> [Int] -> Bool+  go _      []     = True+  go !table (i:is) =+    if check i+      then go table' is+      else False+    where+      table'  = Map.insertWith (+) i 1 table+      check j = j==1 || cnt (j-1) >= cnt j+      cnt j   = case Map.lookup j table' of+        Just k  -> k+        Nothing -> 0++--------------------------------------------------------------------------------+-- * Semistandard Young tableaux++-- | A tableau is /semistandard/ if its entries are weekly increasing horizontally+-- and strictly increasing vertically+isSemiStandardTableau :: Tableau Int -> Bool+isSemiStandardTableau t = weak && strict where+  weak   = and [ isWeaklyIncreasing   xs | xs <- t  ]+  strict = and [ isStrictlyIncreasing ys | ys <- dt ]+  dt     = dualTableau t+   +-- | Semistandard Young tableaux of given shape, \"naive\" algorithm    +semiStandardYoungTableaux :: Int -> Partition -> [Tableau Int]+semiStandardYoungTableaux n part = worker (repeat 0) shape where+  shape = fromPartition part+  worker _ [] = [[]] +  worker prevRow (s:ss) +    = [ (r:rs) | r <- row n s 1 prevRow, rs <- worker (map (+1) r) ss ]++  -- weekly increasing lists of length @len@, pointwise at least @xs@, +  -- maximum value @n@, minimum value @prev@.+  row :: Int -> Int -> Int -> [Int] -> [[Int]]+  row _ 0   _    _      = [[]]+  row n len prev (x:xs) = [ (a:as) | a <- [max x prev..n] , as <- row n (len-1) a xs ]++-- | Stanley's hook formula (cf. Fulton page 55)+countSemiStandardYoungTableaux :: Int -> Partition -> Integer+countSemiStandardYoungTableaux n shape = k `div` h where+  h = product $ map fromIntegral $ concat $ hookLengths shape +  k = product [ fromIntegral (n+j-i) | (i,j) <- elements shape ]++   +--------------------------------------------------------------------------------+-- * Standard Young tableaux++-- | A tableau is /standard/ if it is semistandard and its content is exactly @[1..n]@,+-- where @n@ is the weight.+isStandardTableau :: Tableau Int -> Bool+isStandardTableau t = isSemiStandardTableau t && sort (concat t) == [1..n] where+  n = sum [ length xs | xs <- t ]++-- | Standard Young tableaux of a given shape.+--   Adapted from John Stembridge, +--   <http://www.math.lsa.umich.edu/~jrs/software/SFexamples/tableaux>.+standardYoungTableaux :: Partition -> [Tableau Int]+standardYoungTableaux shape' = map rev $ tableaux shape where+  shape = fromPartition shape'+  rev = reverse . map reverse+  tableaux :: [Int] -> [Tableau Int]+  tableaux p = +    case p of+      []  -> [[]]+      [n] -> [[[n,n-1..1]]]+      _   -> worker (n,k) 0 [] p+    where+      n = sum p+      k = length p+  worker :: (Int,Int) -> Int -> [Int] -> [Int] -> [Tableau Int]+  worker _ _ _ [] = []+  worker nk i ls (x:rs) = case rs of+    (y:_) -> if x==y +      then worker nk (i+1) (x:ls) rs+      else worker2 nk i ls x rs+    [] ->  worker2 nk i ls x rs+  worker2 :: (Int,Int) -> Int -> [Int] -> Int -> [Int] -> [Tableau Int]+  worker2 nk@(n,k) i ls x rs = new ++ worker nk (i+1) (x:ls) rs where+    old = if x>1 +      then             tableaux $ reverse ls ++ (x-1) : rs+      else map ([]:) $ tableaux $ reverse ls ++ rs   +    a = k-1-i+    new = {- debug ( i , a , head old , f a (head old) ) $ -}+      map (f a) old+    f :: Int -> Tableau Int -> Tableau Int+    f _ [] = []+    f 0 (t:ts) = (n:t) : f (-1) ts+    f j (t:ts) = t : f (j-1) ts+  +-- | hook-length formula+countStandardYoungTableaux :: Partition -> Integer+countStandardYoungTableaux part = {- debug (hookLengths part) $ -}+  factorial n `div` h where+    h = product $ map fromIntegral $ concat $ hookLengths part +    n = weight part++--------------------------------------------------------------------------------+        +
+ src/Math/Combinat/Tableaux/GelfandTsetlin.hs view
@@ -0,0 +1,341 @@++-- | Gelfand-Tsetlin patterns and Kostka numbers.+--+-- Gelfand-Tsetlin patterns (or tableaux) are triangular arrays like+--+-- > [ 3 ]+-- > [ 3 , 2 ]+-- > [ 3 , 1 , 0 ]+-- > [ 2 , 0 , 0 , 0 ]+--+-- with both rows and columns non-increasing non-negative integers.+-- Note: these are in bijection with the semi-standard Young tableaux.+--+-- If we add the further restriction that+-- the top diagonal reads @lambda@, +-- and the diagonal sums are partial sums of @mu@, where @lambda@ and @mu@ are two+-- partitions (in this case @lambda=[3,2]@ and @mu=[2,1,1,1]@), +-- then the number of the resulting patterns +-- or tableaux is the Kostka number @K(lambda,mu)@.+-- Actually @mu@ doesn't even need to the be non-increasing.+--++{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+module Math.Combinat.Tableaux.GelfandTsetlin where++--------------------------------------------------------------------------------++import Data.List+import Data.Maybe+import Data.Monoid+import Data.Ord++import Control.Monad+import Control.Monad.Trans.State++import Data.Map (Map)+import qualified Data.Map as Map++import Math.Combinat.Partitions.Integer+import Math.Combinat.Tableaux+import Math.Combinat.Helper+import Math.Combinat.ASCII++--------------------------------------------------------------------------------+-- * Kostka numbers++-- | Kostka numbers (via counting Gelfand-Tsetlin patterns). See for example <http://en.wikipedia.org/wiki/Kostka_number>+--+-- @K(lambda,mu)==0@ unless @lambda@ dominates @mu@:+--+-- > [ mu | mu <- partitions (weight lam) , kostkaNumber lam mu > 0 ] == dominatedPartitions lam+--+kostkaNumber :: Partition -> Partition -> Int+kostkaNumber = countKostkaGelfandTsetlinPatterns++-- | Very naive (and slow) implementation of Kostka numbers, for reference.+kostkaNumberReferenceNaive :: Partition -> Partition -> Int+kostkaNumberReferenceNaive plambda pmu@(Partition mu) = length stuff where+  stuff  = [ (1::Int) | t <- semiStandardYoungTableaux k plambda , cond t ]+  k      = length mu+  cond t = [ (head xs, length xs) | xs <- group (sort $ concat t) ] == zip [1..] mu ++--------------------------------------------------------------------------------++-- | Lists all (positive) Kostka numbers @K(lambda,mu)@ with the given @lambda@:+--+-- > kostkaNumbersWithGivenLambda lambda == Map.fromList [ (mu , kostkaNumber lambda mu) | mu <- dominatedPartitions lambda ]+--+-- It's much faster than computing the individual Kostka numbers, but not as fast+-- as it could be.+--+{-# SPECIALIZE kostkaNumbersWithGivenLambda :: Partition -> Map Partition Int     #-}+{-# SPECIALIZE kostkaNumbersWithGivenLambda :: Partition -> Map Partition Integer #-}+kostkaNumbersWithGivenLambda :: forall coeff. Num coeff => Partition -> Map Partition coeff+kostkaNumbersWithGivenLambda plambda@(Partition lam) = evalState (worker lam) Map.empty where++  worker :: [Int] -> State (Map Partition (Map Partition coeff)) (Map Partition coeff)+  worker unlam = case unlam of+    [] -> return $ Map.singleton (Partition []) 1+    _  -> do+      cache <- get+      case Map.lookup (Partition unlam) cache of+        Just sol -> return sol+        Nothing  -> do+          let s = foldl' (+) 0 unlam+          subsols <- forM (prevLambdas0 unlam) $ \p -> do+            sub <- worker p +            let t = s - foldl' (+) 0 p              +                f (Partition xs , c) = case xs of+                  (y:_) -> if t >= y then Just (Partition (t:xs) , c) else Nothing+                  []    -> if t >  0 then Just (Partition [t]    , c) else Nothing+            if t > 0+              then return $ Map.fromList $ mapMaybe f $ Map.toList sub+              else return $ Map.empty++          let sol = Map.unionsWith (+) subsols+          put $! (Map.insert (Partition unlam) sol cache)+          return sol++  -- needs decreasing sequence+  prevLambdas0 :: [Int] -> [[Int]]+  prevLambdas0 (l:ls) = go l ls where+    go b [a]    = [ [x]   | x <- [a..b] ] ++ [ [x,y] | x <- [a..b] , y<-[1..a] ]+    go b (a:as) = [ x:xs  | x <- [a..b] , xs <- go a as ]+    go b []     = [] : [ [j] | j <- [1..b] ]+  prevLambdas0 []  = []++-- | Lists all (positive) Kostka numbers @K(lambda,mu)@ with the given @mu@:+--+-- > kostkaNumbersWithGivenMu mu == Map.fromList [ (lambda , kostkaNumber lambda mu) | lambda <- dominatingPartitions mu ]+--+-- This function uses the iterated Pieri rule, and is relatively fast.+--+kostkaNumbersWithGivenMu :: Partition -> Map Partition Int+kostkaNumbersWithGivenMu (Partition mu) = iteratedPieriRule (reverse mu)++--------------------------------------------------------------------------------+-- * Gelfand-Tsetlin patterns++-- | A Gelfand-Tstetlin tableau+type GT = [[Int]]++asciiGT :: GT -> ASCII+asciiGT gt = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) +           $ (map . map) asciiShow+           $ gt++kostkaGelfandTsetlinPatterns :: Partition -> Partition -> [GT]+kostkaGelfandTsetlinPatterns lambda (Partition mu) = kostkaGelfandTsetlinPatterns' lambda mu++-- | Generates all Kostka-Gelfand-Tsetlin tableau, that is, triangular arrays like+--+-- > [ 3 ]+-- > [ 3 , 2 ]+-- > [ 3 , 1 , 0 ]+-- > [ 2 , 0 , 0 , 0 ]+--+-- with both rows and column non-increasing such that+-- the top diagonal read lambda (in this case @lambda=[3,2]@) and the diagonal sums+-- are partial sums of mu (in this case @mu=[2,1,1,1]@)+--+-- The number of such GT tableaux is the Kostka+-- number K(lambda,mu).+--+kostkaGelfandTsetlinPatterns' :: Partition -> [Int] -> [GT]+kostkaGelfandTsetlinPatterns' plam@(Partition lambda0) mu0+  | minimum mu0 < 0                       = []+  | wlam == 0                             = if wmu == 0 then [ [] ] else []+  | wmu  == wlam && plam `dominates` pmu  = list+  | otherwise                             = []+  where++    pmu = mkPartition mu0++    nlam = length lambda0+    nmu  = length mu0++    n = max nlam nmu++    lambda = lambda0 ++ replicate (n - nlam) 0+    mu     = mu0     ++ replicate (n - nmu ) 0++    revlam = reverse lambda++    wmu  = sum' mu+    wlam = sum' lambda++    list = worker +             revlam +             (scanl1 (+) mu) +             (replicate (n-1) 0) +             (replicate (n  ) 0) +             []++    worker+      :: [Int]       -- lambda_i in reverse order+      -> [Int]       -- partial sums of mu+      -> [Int]       -- sums of the tails of previous rows+      -> [Int]       -- last row+      -> [[Int]]     -- the lower part of GT tableau we accumulated so far (this is not needed if we only want to count)+      -> [GT]   ++    worker (rl:rls) (smu:smus) (a:acc) (lastx0:lastrowt) table = stuff +      where+        x0 = smu - a+        stuff = concat +          [ worker rls smus (zipWith (+) acc (tail row)) (init row) (row:table)+          | row <- boundedNonIncrSeqs' x0 (map (max rl) (max lastx0 x0 : lastrowt)) lambda+          ]+    worker [rl] _ _ _ table = [ [rl]:table ] +    worker []   _ _ _ _     = [ []         ]++    boundedNonIncrSeqs' :: Int -> [Int] -> [Int] -> [[Int]]+    boundedNonIncrSeqs' = go where+      go h0 (a:as) (b:bs) = [ h:hs | h <- [(max 0 a)..(min h0 b)] , hs <- go h as bs ]+      go _  []     _      = [[]]+      go _  _      []     = [[]]++--------------------------------------------------------------------------------++-- | This returns the corresponding Kostka number:+--+-- > countKostkaGelfandTsetlinPatterns lambda mu == length (kostkaGelfandTsetlinPatterns lambda mu)+-- +countKostkaGelfandTsetlinPatterns :: Partition -> Partition -> Int+countKostkaGelfandTsetlinPatterns plam@(Partition lambda0) pmu@(Partition mu0) +  | wlam == 0                             = if wmu == 0 then 1 else 0+  | wmu  == wlam && plam `dominates` pmu  = cnt+  | otherwise                             = 0+  where++    nlam = length lambda0+    nmu  = length mu0++    n = max nlam nmu++    lambda = lambda0 ++ replicate (n - nlam) 0+    mu     = mu0     ++ replicate (n - nmu ) 0++    revlam = reverse lambda++    wmu  = sum' mu+    wlam = sum' lambda++    cnt = worker +            revlam +            (scanl1 (+) mu) +            (replicate (n-1) 0) +            (replicate (n  ) 0) ++    worker+      :: [Int]       -- lambda_i in reverse order+      -> [Int]       -- partial sums of mu+      -> [Int]       -- sums of the tails of previous rows+      -> [Int]       -- last row+      -> Int++    worker (rl:rls) (smu:smus) (a:acc) (lastx0:lastrowt) = stuff +      where+        x0 = smu - a+        stuff = sum'+          [ worker rls smus (zipWith (+) acc (tail row)) (init row) +          | row <- boundedNonIncrSeqs' x0 (map (max rl) (max lastx0 x0 : lastrowt)) lambda+          ]+    worker [rl] _ _ _ = 1 +    worker []   _ _ _ = 1++    boundedNonIncrSeqs' :: Int -> [Int] -> [Int] -> [[Int]]+    boundedNonIncrSeqs' = go where+      go h0 (a:as) (b:bs) = [ h:hs | h <- [(max 0 a)..(min h0 b)] , hs <- go h as bs ]+      go _  []     _      = [[]]+      go _  _      []     = [[]]++--------------------------------------------------------------------------------++{-++-- | All non-increasing sentences between a lower and an upper bound+boundedNonIncrSeqs :: [Int] -> [Int] -> [[Int]]+boundedNonIncrSeqs as bs = case bs of  +  (h0:_) -> boundedNonIncrSeqs' h0 as bs+  []     -> [[]]++-- | All non-increasing sentences between a lower and an upper bound, and also less-or-equal than the given number+boundedNonIncrSeqs' :: Int -> [Int] -> [Int] -> [[Int]]+boundedNonIncrSeqs' = go where+  go h0 (a:as) (b:bs) = [ h:hs | h <- [(max 0 a)..(min h0 b)] , hs <- go h as bs ]+  go _  []     _      = [[]]+  go _  _      []     = [[]]++-- | All non-decreasing sentences between a lower and an upper bound+boundedNonDecrSeqs :: [Int] -> [Int] -> [[Int]]+boundedNonDecrSeqs = boundedNonDecrSeqs' 0++-- | All non-decreasing sentences between a lower and an upper bound, and also greator-or-equal then the given number+boundedNonDecrSeqs' :: Int -> [Int] -> [Int] -> [[Int]]+boundedNonDecrSeqs' h0 = go (max 0 h0) where+  go h0 (a:as) (b:bs) = [ h:hs | h <- [(max h0 a)..b] , hs <- go h as bs ]+  go _  []     _      = [[]]+  go _  _      []     = [[]]++-}++--------------------------------------------------------------------------------+-- * The iterated Pieri rule ++-- | Computes the Schur expansion of @h[n1]*h[n2]*h[n3]*...*h[nk]@ via iterating the Pieri rule.+-- Note: the coefficients are actually the Kostka numbers; the following is true:+--+-- > Map.toList (iteratedPieriRule (fromPartition mu))  ==  [ (lam, kostkaNumber lam mu) | lam <- dominatingPartitions mu ]+-- +-- This should be faster than individually computing all these Kostka numbers.+--+iteratedPieriRule :: Num coeff => [Int] -> Map Partition coeff+iteratedPieriRule = iteratedPieriRule' (Partition [])++-- | Iterating the Pieri rule, we can compute the Schur expansion of+-- @h[lambda]*h[n1]*h[n2]*h[n3]*...*h[nk]@+iteratedPieriRule' :: Num coeff => Partition -> [Int] -> Map Partition coeff+iteratedPieriRule' plambda ns = iteratedPieriRule'' (plambda,1) ns++{-# SPECIALIZE iteratedPieriRule'' :: (Partition,Int    ) -> [Int] -> Map Partition Int     #-}+{-# SPECIALIZE iteratedPieriRule'' :: (Partition,Integer) -> [Int] -> Map Partition Integer #-}+iteratedPieriRule'' :: Num coeff => (Partition,coeff) -> [Int] -> Map Partition coeff+iteratedPieriRule'' (plambda,coeff0) ns = worker (Map.singleton plambda coeff0) ns where+  worker old []     = old+  worker old (n:ns) = worker new ns where+    stuff = [ (coeff, pieriRule lam n) | (lam,coeff) <- Map.toList old ] +    new   = foldl' f Map.empty stuff +    f t0 (c,ps) = foldl' (\t p -> Map.insertWith (+) p c t) t0 ps  ++--------------------------------------------------------------------------------++-- | Computes the Schur expansion of @e[n1]*e[n2]*e[n3]*...*e[nk]@ via iterating the Pieri rule.+-- Note: the coefficients are actually the Kostka numbers; the following is true:+--+-- > Map.toList (iteratedDualPieriRule (fromPartition mu))  ==  +-- >   [ (dualPartition lam, kostkaNumber lam mu) | lam <- dominatingPartitions mu ]+-- +-- This should be faster than individually computing all these Kostka numbers.+-- It is a tiny bit slower than 'iteratedPieriRule'.+--+iteratedDualPieriRule :: Num coeff => [Int] -> Map Partition coeff+iteratedDualPieriRule = iteratedDualPieriRule' (Partition [])++-- | Iterating the Pieri rule, we can compute the Schur expansion of+-- @e[lambda]*e[n1]*e[n2]*e[n3]*...*e[nk]@+iteratedDualPieriRule' :: Num coeff => Partition -> [Int] -> Map Partition coeff+iteratedDualPieriRule' plambda ns = iteratedDualPieriRule'' (plambda,1) ns++{-# SPECIALIZE iteratedDualPieriRule'' :: (Partition,Int    ) -> [Int] -> Map Partition Int     #-}+{-# SPECIALIZE iteratedDualPieriRule'' :: (Partition,Integer) -> [Int] -> Map Partition Integer #-}+iteratedDualPieriRule'' :: Num coeff => (Partition,coeff) -> [Int] -> Map Partition coeff+iteratedDualPieriRule'' (plambda,coeff0) ns = worker (Map.singleton plambda coeff0) ns where+  worker old []     = old+  worker old (n:ns) = worker new ns where+    stuff = [ (coeff, dualPieriRule lam n) | (lam,coeff) <- Map.toList old ] +    new   = foldl' f Map.empty stuff +    f t0 (c,ps) = foldl' (\t p -> Map.insertWith (+) p c t) t0 ps  ++--------------------------------------------------------------------------------
+ src/Math/Combinat/Tableaux/GelfandTsetlin/Cone.hs view
@@ -0,0 +1,261 @@++-- TODO: better name?++-- | This module contains a function to generate (equivalence classes of) +-- triangular tableaux of size /k/, strictly increasing to the right and +-- to the bottom. For example+-- +-- >  1  +-- >  2  4  +-- >  3  5  8  +-- >  6  7  9  10 +--+-- is such a tableau of size 4.+-- The numbers filling a tableau always consist of an interval @[1..c]@;+-- @c@ is called the /content/ of the tableaux. There is a unique tableau+-- of minimal content @2k-1@:+--+-- >  1  +-- >  2  3  +-- >  3  4  5 +-- >  4  5  6  7 +-- +-- Let us call the tableaux with maximal content (that is, @m = binomial (k+1) 2@)+-- /standard/. The number of such standard tableaux are+--+-- > 1, 1, 2, 12, 286, 33592, 23178480, ...+--+-- OEIS:A003121, \"Strict sense ballot numbers\", +-- <https://oeis.org/A003121>.+--+-- See +-- R. M. Thrall, A combinatorial problem, Michigan Math. J. 1, (1952), 81-88.+-- +-- The number of tableaux with content @c=m-d@ are+-- +-- >  d=  |     0      1      2      3    ...+-- > -----+----------------------------------------------+-- >  k=2 |     1+-- >  k=3 |     2      1+-- >  k=4 |    12     18      8      1+-- >  k=5 |   286    858   1001    572    165     22     1+-- >  k=6 | 33592 167960 361114 436696 326196 155584 47320 8892 962 52 1 +--+-- We call these \"GT simplex tableaux\" (in the lack of a better name), since+-- they are in bijection with the simplicial cones in a canonical simplicial +-- decompositions of the Gelfand-Tsetlin cones (the content corresponds+-- to the dimension), which encode the combinatorics of Kostka numbers.+--++{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+module Math.Combinat.Tableaux.GelfandTsetlin.Cone+  ( +    -- * Types+    Tableau+  , Tri(..)+  , TriangularArray+  , fromTriangularArray+  , triangularArrayUnsafe+    -- * ASCII+  , asciiTriangularArray+  , asciiTableau+    -- * Content+  , gtSimplexContent+  , _gtSimplexContent+  , invertGTSimplexTableau+  , _invertGTSimplexTableau+    -- * Enumeration+  , gtSimplexTableaux+  , _gtSimplexTableaux+  , countGTSimplexTableaux+  ) +  where++--------------------------------------------------------------------------------++import Data.Ix+import Data.Ord+import Data.List++import Control.Monad+import Control.Monad.ST+import Data.Array.IArray+import Data.Array.Unboxed+import Data.Array.ST++import Math.Combinat.Tableaux (Tableau)+import Math.Combinat.Helper+import Math.Combinat.ASCII++--------------------------------------------------------------------------------++-- | Triangular arrays+type TriangularArray a = Array Tri a++-- | Set of @(i,j)@ pairs with @i>=j>=1@.+newtype Tri = Tri { unTri :: (Int,Int) } deriving (Eq,Ord,Show)++binom2 :: Int -> Int+binom2 n = (n*(n-1)) `div` 2++index' :: Tri -> Int+index' (Tri (i,j)) = binom2 i + j - 1++-- it should be (1+8*m), +-- the 2 is a hack to be safe with the floating point stuff+deIndex' :: Int -> Tri +deIndex' m = Tri ( i+1 , m - binom2 (i+1) + 1 ) where+  i = ( (floor.sqrt.(fromIntegral::Int->Double)) (2+8*m) - 1 ) `div` 2  ++instance Ix Tri where+  index   (a,b) x = index' x - index' a +  inRange (a,b) x = (u<=j && j<=v) where+    u = index' a +    v = index' b+    j = index' x+  range     (a,b) = map deIndex' [ index' a .. index' b ] +  rangeSize (a,b) = index' b - index' a + 1 ++triangularArrayUnsafe :: Tableau a -> TriangularArray a+triangularArrayUnsafe tableau = listArray (Tri (1,1),Tri (k,k)) (concat tableau) +  where k = length tableau++fromTriangularArray :: TriangularArray a -> Tableau a+fromTriangularArray arr = (map.map) snd $ groupBy (equating f) $ assocs arr+  where f = fst . unTri . fst++--------------------------------------------------------------------------------++asciiTriangularArray :: Show a => TriangularArray a -> ASCII+asciiTriangularArray = asciiTableau . fromTriangularArray++asciiTableau :: Show a => Tableau a -> ASCII+asciiTableau xxs = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) +                 $ (map . map) asciiShow+                 $ xxs++instance Show a => DrawASCII (TriangularArray a) where+  ascii = asciiTriangularArray++-- instance Show a => DrawASCII (Tableau a) where+--   ascii = asciiTableau++--------------------------------------------------------------------------------++-- "fractional fillings"+data Hole = Hole Int Int deriving (Eq,Ord,Show)++type ReverseTableau      = [[Int ]] +type ReverseHoleTableau  = [[Hole]]      ++toHole :: Int -> Hole+toHole k = Hole k 0++nextHole :: Hole -> Hole+nextHole (Hole k l) = Hole k (l+1)++reverseTableau :: [[a]] -> [[a]]+reverseTableau = reverse . map reverse++--------------------------------------------------------------------------------++gtSimplexContent :: TriangularArray Int -> Int+gtSimplexContent arr = max (arr ! (fst (bounds arr))) (arr ! (snd (bounds arr)))   -- we also handle inverted tableau++_gtSimplexContent :: Tableau Int -> Int+_gtSimplexContent t = max (head $ head t) (last $ last t)   -- we also handle inverted tableau+ +normalize :: ReverseHoleTableau -> TriangularArray Int +normalize = snd . normalize'++-- returns ( content , tableau )+normalize' :: ReverseHoleTableau -> ( Int , TriangularArray Int )   +normalize' holes = ( c , array (Tri (1,1), Tri (k,k)) xys ) where+  k = length holes+  c = length sorted+  xys = concat $ zipWith hs [1..] sorted+  hs a xs     = map (h a) xs+  h  a (ij,_) = (Tri ij , a)  +  sorted = groupSortBy snd (concat withPos)+  withPos = zipWith f [1..] (reverseTableau holes) +  f i xs = zipWith (g i) [1..] xs +  g i j hole = ((i,j),hole) ++--------------------------------------------------------------------------------++startHole :: [Hole] -> [Int] -> Hole +startHole (t:ts) (p:ps) = max t (toHole p)+startHole (t:ts) []     = t+startHole []     (p:ps) = toHole p+startHole []     []     = error "startHole"++-- c is the "content" of the small tableau+enumHoles :: Int -> Hole -> [Hole]+enumHoles c start@(Hole k l) +  = nextHole start +  : [ Hole i 0 | i <- [k+1..c] ] ++ [ Hole i 1 | i <- [k+1..c] ]++helper :: Int -> [Int] -> [Hole] -> [[Hole]]+helper c [] this = [[]] +helper c prev@(p:ps) this = +  [ t:rest | t <- enumHoles c (startHole this prev), rest <- helper c ps (t:this) ]++newLines' :: Int -> [Int] -> [[Hole]]+newLines' c lastReversed = helper c last []  +  where+    top  = head lastReversed+    last = reverse (top : lastReversed)++newLines :: [Int] -> [[Hole]]+newLines lastReversed = newLines' (head lastReversed) lastReversed++-- | Generates all tableaux of size @k@. Effective for @k<=6@.+gtSimplexTableaux :: Int -> [TriangularArray Int]+gtSimplexTableaux 0 = [ triangularArrayUnsafe [] ]+gtSimplexTableaux 1 = [ triangularArrayUnsafe [[1]] ]+gtSimplexTableaux k = map normalize $ concatMap f smalls where+  smalls :: [ [[Int]] ]+  smalls = map (reverseTableau . fromTriangularArray) $ gtSimplexTableaux (k-1)+  f :: [[Int]] -> [ [[Hole]] ]+  f small = map (:smallhole) $ map reverse $ newLines (head small) where+    smallhole = map (map toHole) small++_gtSimplexTableaux :: Int -> [Tableau Int]+_gtSimplexTableaux k = map fromTriangularArray $ gtSimplexTableaux k++--------------------------------------------------------------------------------++-- | Note: This is slow (it actually generates all the tableaux)+countGTSimplexTableaux :: Int -> [Int]+countGTSimplexTableaux = elems . sizes'++sizes' :: Int -> UArray Int Int+sizes' k = +  runSTUArray $ do+    let (a,b) = ( 2*k-1 , binom2 (k+1) )+    ar <- newArray (a,b) 0 :: ST s (STUArray s Int Int)   +    mapM_ (worker ar) $ gtSimplexTableaux k +    return ar+  where+    worker :: STUArray s Int Int -> TriangularArray Int -> ST s ()+    worker ar t = do+      let c = gtSimplexContent t +      n <- readArray ar c  +      writeArray ar c (n+1)+     +--------------------------------------------------------------------------------++-- | We can flip the numbers in the tableau so that the interval @[1..c]@ becomes+-- @[c..1]@. This way we a get a maybe more familiar form, when each row and each+-- column is strictly /decreasing/ (to the right and to the bottom).+invertGTSimplexTableau :: TriangularArray Int -> TriangularArray Int +invertGTSimplexTableau t = amap f t where+  c = gtSimplexContent t +  f x = c+1-x  ++_invertGTSimplexTableau :: [[Int]] -> [[Int]]+_invertGTSimplexTableau t = (map . map) f t where+  c = _gtSimplexContent t  +  f x = c+1-x++--------------------------------------------------------------------------------
+ src/Math/Combinat/Tableaux/LittlewoodRichardson.hs view
@@ -0,0 +1,399 @@++-- | The Littlewood-Richardson rule++module Math.Combinat.Tableaux.LittlewoodRichardson +  ( lrCoeff , lrCoeff'+  , lrMult+  , lrRule  , _lrRule , lrRuleNaive+  , lrScalar , _lrScalar+  ) +  where++--------------------------------------------------------------------------------++import Data.List+import Data.Maybe++import Math.Combinat.Partitions.Integer+import Math.Combinat.Partitions.Skew+import Math.Combinat.Tableaux+import Math.Combinat.Tableaux.Skew+import Math.Combinat.Helper++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++--------------------------------------------------------------------------------++-- | Naive (very slow) reference implementation of the Littlewood-Richardson rule, based +-- on the definition "count the semistandard skew tableaux whose row content is a lattice word"+--+lrRuleNaive :: SkewPartition -> Map Partition Int+lrRuleNaive skew = final where+  n     = skewPartitionWeight skew+  ssst  = semiStandardSkewTableaux n skew +  final = foldl' f Map.empty $ catMaybes [ skewTableauRowContent skew | skew <- ssst  ]+  f old nu = Map.insertWith (+) nu 1 old++--------------------------------------------------------------------------------+-- SKEW EXPANSION++-- | @lrRule@ computes the expansion of a skew Schur function +-- @s[lambda\/mu]@ via the Littlewood-Richardson rule.+--+-- Adapted from John Stembridge's Maple code: +-- <http://www.math.lsa.umich.edu/~jrs/software/SFexamples/LR_rule>+--+-- > lrRule (mkSkewPartition (lambda,nu)) == Map.fromList list where+-- >   muw  = weight lambda - weight nu+-- >   list = [ (mu, coeff) +-- >          | mu <- partitions muw +-- >          , let coeff = lrCoeff lambda (mu,nu)+-- >          , coeff /= 0+-- >          ] +--+lrRule :: SkewPartition -> Map Partition Int+lrRule skew = _lrRule lam mu where+  (lam,mu) = fromSkewPartition skew++-- | @_lrRule lambda mu@ computes the expansion of the skew+-- Schur function @s[lambda\/mu]@ via the Littlewood-Richardson rule.+--+_lrRule :: Partition -> Partition -> Map Partition Int+_lrRule plam@(Partition lam) pmu@(Partition mu0) = +  if not (pmu `isSubPartitionOf` plam) +    then Map.empty+    else foldl' f Map.empty [ nu | (nu,_) <- fillings n diagram ]+  where+    f old nu = Map.insertWith (+) (Partition nu) 1 old+    diagram  = [ (i,j) | (i,a,b) <- reverse (zip3 [1..] lam mu) , j <- [b+1..a] ]    +    mu       = mu0 ++ repeat 0+    n        = sum' $ zipWith (-) lam mu    -- n == length diagram++{-+LR_rule:=proc(lambda) local l,mu,alpha,beta,i,j,dgrm;+  if not `LR_rule/fit`(lambda,args[2]) then RETURN(0) fi;+  l:=nops(lambda); mu:=[op(args[2]),0$l];+  dgrm:=[seq(seq([i,-j],j=-lambda[i]..-1-mu[i]),i=1..l)];+  if nargs>2 then alpha:=args[3];+    if nargs>3 then beta:=args[4] else beta:=[] fi;+    if not `LR_rule/fit`(alpha,beta) then RETURN(0) fi;+    l:=convert([op(lambda),op(beta)],`+`);+    if l<>convert([op(alpha),op(mu)],`+`) then RETURN(0) fi;+    nops(LR_fillings(dgrm,[alpha,beta]))+  else+    convert([seq(s[op(i[1])],i=LR_fillings(dgrm))],`+`)+  fi+end;+-}++--------------------------------------------------------------------------------++-- | A filling is a pair consisting a shape @nu@ and a lattice permutation @lp@+type Filling = ( [Int] , [Int] )++-- | A diagram is a set of boxes in a skew shape (in the right order)+type Diagram = [ (Int,Int) ]++-- | Note: we use reverse ordering in Diagrams compared the Stembridge's code.+-- Also, for performance reasons, we need the length of the diagram+fillings :: Int -> Diagram -> [Filling]+fillings _ []                   = [ ([],[]) ]+fillings n diagram@((x,y):rest) = concatMap (nextLetter lower upper) (fillings (n-1) rest) where+  upper = case findIndex (==(x  ,y+1)) diagram of { Just j -> n-j ; Nothing -> 0 }+  lower = case findIndex (==(x-1,y  )) diagram of { Just j -> n-j ; Nothing -> 0 }++{-+LR_fillings:=proc(dgrm) local n,x,upper,lower;+  if dgrm=[] then+    if nargs=1 then x:=[] else x:=args[2][2] fi;+    RETURN([[x,[]]])+  fi;+  n:=nops(dgrm); x:=dgrm[n];+  if not member([x[1],x[2]+1],dgrm,'upper') then upper:=0 fi;+  if not member([x[1]-1,x[2]],dgrm,'lower') then lower:=0 fi;+  if nargs=1 then+    map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)]),lower,upper)+  else+    map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)],args[2]),+      lower,upper,args[2][1])+  fi;+end:+-}++--------------------------------------------------------------------------------++nextLetter :: Int -> Int -> Filling -> [Filling]+nextLetter lower upper (nu,lpart) = stuff where+  stuff = [ ( incr i shape , lpart++[i] ) | i<-nlist ] +  shape = nu ++ [0] +  lb = if lower>0+    then lpart !! (lower-1)+    else 0+  ub = if upper>0 +    then min (length shape) (lpart !! (upper-1))  +    else      length shape++  nlist = filter (>0) $ map f [lb+1..ub] +  f j   = if j==1 || shape!!(j-2) > shape!!(j-1) then j else 0++{-+  -- another nlist implementation, but doesn't seem to be faster+  (h0:hs0) = drop lb (-666:shape)+  nlist = go h0 hs0 [lb+1..ub] where+    go !lasth (h:hs) (j:js) = if j==1 || lasth > h +      then j : go h hs js +      else     go h hs js+    go _      _      []     = []+-}++  -- increments the i-th element (starting from 1)+  incr :: Int -> [Int] -> [Int]+  incr i (x:xs) = case i of+    0 ->         finish (x:xs)+    1 -> (x+1) : finish xs+    _ -> x     : incr (i-1) xs+  incr _ []     = []++  -- removes tailing zeros+  finish :: [Int] -> [Int]+  finish (x:xs) = if x>0 then x : finish xs else []    +  finish []     = [] ++{-+`LR/nextletter`:=proc(T) local shape,lp,lb,ub,i,nl;+  shape:=[op(T[1]),0]; lp:=T[2]; ub:=nops(shape);+  if nargs>3 then ub:=min(ub,nops(args[4])) fi;+  if args[2]=0 then lb:=0 else lb:=lp[args[2]] fi;+  if args[3]>0 then ub:=min(lp[args[3]],ub) fi;+  if nargs<4 then+    nl:=map(proc(x,y) if x=1 or y[x-1]>y[x] then x fi end,[$lb+1..ub],shape)+  else+    nl:=map(proc(x,y,z) if y[x]<z[x] and (x=1 or y[x-1]>y[x]) then x fi end,+      [$lb+1..ub],shape,args[4])+  fi;+  nl:=[seq([subsop(i=shape[i]+1,shape),[op(lp),i]],i=nl)];+  op(subs(0=NULL,nl))+end:+-}++--------------------------------------------------------------------------------+-- COEFF++-- | @lrCoeff lam (mu,nu)@ computes the coressponding Littlewood-Richardson coefficients.+-- This is also the coefficient of @s[lambda]@ in the product @s[mu]*s[nu]@+--+-- Note: This is much slower than using 'lrRule' or 'lrMult' to compute several coefficients+-- at the same time!+lrCoeff :: Partition -> (Partition,Partition) -> Int+lrCoeff lam (mu,nu) = +  if nu `isSubPartitionOf` lam+    then lrScalar (mkSkewPartition (lam,nu)) (mkSkewPartition (mu,emptyPartition))+    else 0++-- | @lrCoeff (lam\/nu) mu@ computes the coressponding Littlewood-Richardson coefficients.+-- This is also the coefficient of @s[mu]@ in the product @s[lam\/nu]@+--+-- Note: This is much slower than using 'lrRule' or 'lrMult' to compute several coefficients+-- at the same time!+lrCoeff' :: SkewPartition -> Partition -> Int+lrCoeff' skew p = lrScalar skew (mkSkewPartition (p,emptyPartition))+  +--------------------------------------------------------------------------------+-- SCALAR PRODUCT++-- | @lrScalar (lambda\/mu) (alpha\/beta)@ computes the scalar product of the two skew+-- Schur functions @s[lambda\/mu]@ and @s[alpha\/beta]@ via the Littlewood-Richardson rule.+--+-- Adapted from John Stembridge Maple code: +-- <http://www.math.lsa.umich.edu/~jrs/software/SFexamples/LR_rule>+--+lrScalar :: SkewPartition -> SkewPartition -> Int+lrScalar lambdaMu alphaBeta = _lrScalar (fromSkewPartition lambdaMu) (fromSkewPartition alphaBeta)++_lrScalar :: (Partition,Partition) -> (Partition,Partition) -> Int+_lrScalar ( plam@(  Partition lam  ) , pmu@(  Partition mu0 ) ) +          ( palpha@(Partition alpha) , pbeta@(Partition beta) ) = +  if    not (pmu   `isSubPartitionOf` plam  ) +     || not (pbeta `isSubPartitionOf` palpha) +     || (sum' lam + sum' beta) /= (sum' alpha + sum' mu0)     -- equivalent to (lambda-mu) /= (alpha-beta)+    then 0+    else length $ fillings' n diagram (alpha,beta) +  where+    f old nu = Map.insertWith (+) (Partition nu) 1 old+    diagram  = [ (i,j) | (i,a,b) <- reverse (zip3 [1..] lam mu) , j <- [b+1..a] ]    +    mu       = mu0 ++ repeat 0+    n        = sum' $ zipWith (-) lam mu    -- n == length diagram++{-+LR_rule:=proc(lambda) local l,mu,alpha,beta,i,j,dgrm;+  if not `LR_rule/fit`(lambda,args[2]) then RETURN(0) fi;+  l:=nops(lambda); mu:=[op(args[2]),0$l];+  dgrm:=[seq(seq([i,-j],j=-lambda[i]..-1-mu[i]),i=1..l)];+  if nargs>2 then alpha:=args[3];+    if nargs>3 then beta:=args[4] else beta:=[] fi;+    if not `LR_rule/fit`(alpha,beta) then RETURN(0) fi;+    l:=convert([op(lambda),op(beta)],`+`);+    if l<>convert([op(alpha),op(mu)],`+`) then RETURN(0) fi;+    nops(LR_fillings(dgrm,[alpha,beta]))+  else+    convert([seq(s[op(i[1])],i=LR_fillings(dgrm))],`+`)+  fi+end;+-}++--------------------------------------------------------------------------------++-- | Note: we use reverse ordering in Diagrams compared the Stembridge's code.+-- Also, for performance reasons, we need the length of the diagram+fillings' :: Int -> Diagram -> ([Int],[Int]) -> [Filling]+fillings' _         []                     (alpha,beta) = [ (beta,[]) ]+fillings' n diagram@((x,y):rest) alphaBeta@(alpha,beta) = stuff where+  stuff = concatMap (nextLetter' lower upper alpha) (fillings' (n-1) rest alphaBeta) +  upper = case findIndex (==(x  ,y+1)) diagram of { Just j -> n-j ; Nothing -> 0 }+  lower = case findIndex (==(x-1,y  )) diagram of { Just j -> n-j ; Nothing -> 0 }++{-+LR_fillings:=proc(dgrm) local n,x,upper,lower;+  if dgrm=[] then+    if nargs=1 then x:=[] else x:=args[2][2] fi;+    RETURN([[x,[]]])+  fi;+  n:=nops(dgrm); x:=dgrm[n];+  if not member([x[1],x[2]+1],dgrm,'upper') then upper:=0 fi;+  if not member([x[1]-1,x[2]],dgrm,'lower') then lower:=0 fi;+  if nargs=1 then+    map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)]),lower,upper)+  else+    map(`LR/nextletter`,LR_fillings([op(1..n-1,dgrm)],args[2]),+      lower,upper,args[2][1])+  fi;+end:+-}++--------------------------------------------------------------------------------++nextLetter' :: Int -> Int -> [Int] -> Filling -> [Filling]+nextLetter' lower upper alpha (nu,lpart) = stuff where+  stuff = [ ( incr i shape , lpart++[i] ) | i<-nlist ] +  shape = nu ++ [0] +  lb = if lower>0+    then lpart !! (lower-1)+    else 0+  ub1 = if upper>0 +    then min (length shape) (lpart !! (upper-1))  +    else      length shape+  ub = min (length alpha) ub1+  nlist = filter (>0) $ map f [lb+1..ub] +  f j   = if (        shape!!(j-1) < alpha!!(j-1)) &&+             (j==1 || shape!!(j-2) > shape!!(j-1)) +          then j +          else 0++  -- increments the i-th element (starting from 1)+  incr :: Int -> [Int] -> [Int]+  incr i (x:xs) = case i of+    0 ->         finish (x:xs)+    1 -> (x+1) : finish xs+    _ -> x     : incr (i-1) xs+  incr _ []     = []++  -- removes tailing zeros+  finish :: [Int] -> [Int]+  finish (x:xs) = if x>0 then x : finish xs else []    +  finish []     = [] ++{-+`LR/nextletter`:=proc(T) local shape,lp,lb,ub,i,nl;+  shape:=[op(T[1]),0]; lp:=T[2]; ub:=nops(shape);+  if nargs>3 then ub:=min(ub,nops(args[4])) fi;+  if args[2]=0 then lb:=0 else lb:=lp[args[2]] fi;+  if args[3]>0 then ub:=min(lp[args[3]],ub) fi;+  if nargs<4 then+    nl:=map(proc(x,y) if x=1 or y[x-1]>y[x] then x fi end,[$lb+1..ub],shape)+  else+    nl:=map(proc(x,y,z) if y[x]<z[x] and (x=1 or y[x-1]>y[x]) then x fi end,+      [$lb+1..ub],shape,args[4])+  fi;+  nl:=[seq([subsop(i=shape[i]+1,shape),[op(lp),i]],i=nl)];+  op(subs(0=NULL,nl))+end:+-}++--------------------------------------------------------------------------------+-- MULTIPLICATION++type Part = [Int]++-- | Computes the expansion of the product of Schur polynomials @s[mu]*s[nu]@ using the+-- Littlewood-Richardson rule. Note: this is symmetric in the two arguments.+--+-- Based on the wikipedia article <https://en.wikipedia.org/wiki/Littlewood-Richardson_rule>+--+-- > lrMult mu nu == Map.fromList list where+-- >   lamw = weight nu + weight mu+-- >   list = [ (lambda, coeff) +-- >          | lambda <- partitions lamw +-- >          , let coeff = lrCoeff lambda (mu,nu)+-- >          , coeff /= 0+-- >          ] +--+lrMult :: Partition -> Partition -> Map Partition Int+lrMult pmu@(Partition mu) pnu@(Partition nu) = result where+  result = foldl' add Map.empty (addMu mu nu) where+  add !old lambda = Map.insertWith (+) (Partition lambda) 1 old++-- | This basically lists all the outer shapes (with multiplicities) which can be result from the LR rule+addMu :: Part -> Part -> [Part]+addMu mu part = go ubs0 mu dmu part where++  go _   []     _      part = [part]+  go ubs (m:ms) (d:ds) part = concat [ go (drop d ubs') ms ds part' | (ubs',part') <- addRowOf ubs part ]++  ubs0 = take (headOrZero mu) [headOrZero part + 1..]+  dmu  = diffSeq mu+++-- | Adds a full row of @(length pcols)@ boxes containing to a partition, with+-- pcols being the upper bounds of the columns, respectively. We also return the+-- newly added columns+addRowOf :: [Int] -> Part -> [([Int],Part)]+addRowOf pcols part = go 0 pcols part [] where+  go !lb []        p ncols = [(reverse ncols , p)]+  go !lb (!ub:ubs) p ncols = concat [ go col ubs (addBox ij p) (col:ncols) | ij@(row,col) <- newBoxes (lb+1) ub p ]++-- | Returns the (row,column) pairs of the new boxes which +-- can be added to the given partition with the given column bounds+-- and the 1-Rieri rule +newBoxes :: Int -> Int -> Part -> [(Int,Int)]+newBoxes lb ub part = reverse $ go [1..] part (headOrZero part + 1) where+  go (!i:_ ) []      !lp+    | lb <= 1 && 1 <= ub && lp > 0  =  [(i,1)]+    | otherwise                     =  []+  go (!i:is) (!j:js) !lp +    | j1 <  lb            =  []+    | j1 <= ub && lp > j  =  (i,j1) : go is js j       +    | otherwise           =           go is js j+    where +      j1 = j+1++-- | Adds a box to a partition+addBox :: (Int,Int) -> Part -> Part+addBox (k,_) part = go 1 part where+  go !i (p:ps) = if i==k then (p+1):ps else p : go (i+1) ps+  go !i []     = if i==k then [1] else error "addBox: shouldn't happen"++-- | Safe head defaulting to zero           +headOrZero :: [Int] -> Int+headOrZero xs = case xs of +  (!x:_) -> x+  []     -> 0++-- | Computes the sequence of differences from a partition (including the last difference to zero)+diffSeq :: Part -> [Int]+diffSeq = go where+  go (p:ps@(q:_)) = (p-q) : go ps+  go [p]          = [p]+  go []           = []++--------------------------------------------------------------------------------
+ src/Math/Combinat/Tableaux/Skew.hs view
@@ -0,0 +1,224 @@++-- | Skew tableaux are skew partitions filled with numbers.+--+-- For example:+--+-- <<svg/skew_tableau.svg>>+--++{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, MultiParamTypeClasses #-}++module Math.Combinat.Tableaux.Skew where++--------------------------------------------------------------------------------++import Data.List++import Math.Combinat.Classes+import Math.Combinat.Partitions.Integer+import Math.Combinat.Partitions.Integer.IntList ( _diffSequence )+import Math.Combinat.Partitions.Skew+import Math.Combinat.Tableaux+import Math.Combinat.ASCII+import Math.Combinat.Helper++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++--------------------------------------------------------------------------------+-- * Basics+-- | A skew tableau is represented by a list of offsets and entries+newtype SkewTableau a = SkewTableau [(Int,[a])] deriving (Eq,Ord,Show)++-- unSkewTableau :: SkewTableau a -> [(Int,[a])]+-- unSkewTableau (SkewTableau a) = a++instance Functor SkewTableau where+  fmap f (SkewTableau t) = SkewTableau [ (a, map f xs) | (a,xs) <- t ]++-- | The shape of a skew tableau +skewTableauShape :: SkewTableau a -> SkewPartition+skewTableauShape (SkewTableau list) = SkewPartition [ (o,length xs) | (o,xs) <- list ]++instance HasShape (SkewTableau a) SkewPartition where+  shape = skewTableauShape++-- | The weight of a tableau is the weight of its shape, or the number of entries+skewTableauWeight :: SkewTableau a -> Int+skewTableauWeight = skewPartitionWeight . skewTableauShape++instance HasWeight (SkewTableau a) where+  weight = skewTableauWeight++--------------------------------------------------------------------------------++-- | The dual of a skew tableau, that is, its mirror image to the main diagonal+dualSkewTableau :: forall a. SkewTableau a -> SkewTableau a+dualSkewTableau (SkewTableau axs) = SkewTableau (go axs) where++  go []  = []  +  go axs = case sub 0 axs of+    (0,[]) -> []+    this   -> this : go (strip axs)++  strip :: [(Int,[a])] -> [(Int,[a])]+  strip []            = []+  strip ((a,xs):rest) = if a>0 +    then (a-1,xs) : strip rest+    else case xs of+      []     -> []+      (z:zs) -> case zs of+        []      -> []+        _       -> (0,zs) : strip rest++  sub :: Int -> [(Int,[a])] -> (Int,[a])+  sub !b [] = (b,[])+  sub !b ((a,this):rest) = if a>0 +    then sub (b+1) rest  +    else (b,ys) where      +      ys = map head $ takeWhile (not . null) (this : map snd rest)++{-+test_dualSkewTableau :: [SkewTableau Int]+test_dualSkewTableau = bad where +  ps = allPartitions 11+  bad = [ st +        | p<-ps , q<-ps +        , (q `isSubPartitionOf` p) +        , let sp = mkSkewPartition (p,q) +        , let st = fillSkewPartitionWithRowWord sp [1..] +        , dualSkewTableau (dualSkewTableau st) /= st+        ]+-}++instance HasDuality (SkewTableau a) where+  dual = dualSkewTableau++--------------------------------------------------------------------------------+-- * Semistandard tableau++-- | A tableau is /semistandard/ if its entries are weekly increasing horizontally+-- and strictly increasing vertically+isSemiStandardSkewTableau :: SkewTableau Int -> Bool+isSemiStandardSkewTableau st@(SkewTableau axs) = weak && strict where+  weak   = and [ isWeaklyIncreasing   xs | (a,xs) <- axs ]+  strict = and [ isStrictlyIncreasing ys | (b,ys) <- bys ]+  SkewTableau bys = dualSkewTableau st++-- | A tableau is /standard/ if it is semistandard and its content is exactly @[1..n]@,+-- where @n@ is the weight.+isStandardSkewTableau :: SkewTableau Int -> Bool+isStandardSkewTableau st = isSemiStandardSkewTableau st && sort (skewTableauRowWord st) == [1..n] where+  n = skewTableauWeight st+  +--------------------------------------------------------------------------------++-- | All semi-standard skew tableaux filled with the numbers @[1..n]@+semiStandardSkewTableaux :: Int -> SkewPartition -> [SkewTableau Int]+semiStandardSkewTableaux n (SkewPartition abs) = map SkewTableau stuff where++  stuff = worker as bs ds (repeat 1) +  (as,bs) = unzip abs+  ds = _diffSequence as+  +  -- | @worker inner outerMinusInner innerdiffs lowerbound+  worker :: [Int] -> [Int] -> [Int] -> [Int] -> [[(Int,[Int])]]+  worker (a:as) (b:bs) (d:ds) lb = [ (a,this):rest +                                   | this <- row b 1 lb +                                   , let lb' = (replicate d 1 ++ map (+1) this) +                                   , rest <- worker as bs ds lb' ] +  worker []     _      _      _  = [ [] ]++  -- @row length minimum lowerbound@+  row 0  _  _       = [[]]+  row _  _  []      = []+  row !k !m (!a:as) = [ x:xs | x <- [(max a m)..n] , xs <- row (k-1) x as ] ++{-+-- | from a sequence @[a1,a2,..,an]@ computes the sequence of differences+-- @[a1-a2,a2-a3,...,an-0]@+diffSequence :: [Int] -> [Int]+diffSequence = go where+  go (x:ys@(y:_)) = (x-y) : go ys +  go [x] = [x]+  go []  = []+-}++--------------------------------------------------------------------------------+-- * ASCII++-- | ASCII drawing of a skew tableau (using the English notation)+asciiSkewTableau :: Show a => SkewTableau a -> ASCII+asciiSkewTableau = asciiSkewTableau' "." EnglishNotation++asciiSkewTableau' +  :: Show a+  => String               -- ^ string representing the elements of the inner (unfilled) partition+  -> PartitionConvention  -- ^ orientation+  -> SkewTableau a +  -> ASCII+asciiSkewTableau' innerstr orient (SkewTableau axs) = tabulate (HRight,VTop) (HSepSpaces 1, VSepEmpty) stuff where+  stuff = case orient of+    EnglishNotation    -> es+    EnglishNotationCCW -> reverse (transpose es)+    FrenchNotation     -> reverse es+  inner = asciiFromString innerstr+  es = [ replicate a inner ++ map asciiShow xs | (a,xs) <- axs ]++instance Show a => DrawASCII (SkewTableau a) where+  ascii = asciiSkewTableau++--------------------------------------------------------------------------------+-- * Row \/ column words++-- | The reversed (right-to-left) rows, concatenated+skewTableauRowWord :: SkewTableau a -> [a]+skewTableauRowWord (SkewTableau axs) = concatMap (reverse . snd) axs++-- | The reversed (bottom-to-top) columns, concatenated+skewTableauColumnWord :: SkewTableau a -> [a]+skewTableauColumnWord = skewTableauRowWord . dualSkewTableau++-- | Fills a skew partition with content, in row word order +fillSkewPartitionWithRowWord :: SkewPartition -> [a] -> SkewTableau a+fillSkewPartitionWithRowWord (SkewPartition abs) xs = SkewTableau $ go abs xs where+  go ((b,a):rest) xs = let (ys,zs) = splitAt a xs in (b,reverse ys) : go rest zs+  go []           xs = []++-- | Fills a skew partition with content, in column word order +fillSkewPartitionWithColumnWord :: SkewPartition -> [a] -> SkewTableau a+fillSkewPartitionWithColumnWord shape content +  = dualSkewTableau +  $ fillSkewPartitionWithRowWord (dualSkewPartition shape) content++--------------------------------------------------------------------------------++-- | If the skew tableau's row word is a lattice word, we can make a partition from its content+skewTableauRowContent :: SkewTableau Int -> Maybe Partition+skewTableauRowContent (SkewTableau axs) = go Map.empty rowword where++  rowword = concatMap (reverse . snd) axs++  finish table = Partition (f 1) where+    f !i = case lkp i of+      0 -> []+      y -> y : f (i+1) +    lkp j = case Map.lookup j table of+      Just k  -> k+      Nothing -> 0++  go :: Map Int Int -> [Int] -> Maybe Partition+  go !table []     = Just (finish table)+  go !table (i:is) =+    if check i+      then go table' is+      else Nothing+    where+      table'  = Map.insertWith (+) i 1 table+      check j = j==1 || cnt (j-1) >= cnt j+      cnt j   = case Map.lookup j table' of+        Just k  -> k+        Nothing -> 0++--------------------------------------------------------------------------------+
+ src/Math/Combinat/Trees.hs view
@@ -0,0 +1,9 @@++module Math.Combinat.Trees+  ( module Math.Combinat.Trees.Binary+  , module Math.Combinat.Trees.Nary+  ) where++import Math.Combinat.Trees.Binary+import Math.Combinat.Trees.Nary+
+ src/Math/Combinat/Trees/Binary.hs view
@@ -0,0 +1,492 @@++-- | Binary trees, forests, etc. See:+--   Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 4A.+--+-- For example, here are all the binary trees on 4 nodes:+--+-- <<svg/bintrees.svg>>+--++{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+module Math.Combinat.Trees.Binary +  ( -- * Types+    BinTree(..)+  , leaf +  , graft+  , BinTree'(..)+  , forgetNodeDecorations+  , Paren(..)+  , parenthesesToString+  , stringToParentheses  +  , numberOfNodes+  , numberOfLeaves+    -- * Conversion to rose trees (@Data.Tree@)+  , toRoseTree , toRoseTree'+  , module Data.Tree +    -- * Enumerate leaves+  , enumerateLeaves_ +  , enumerateLeaves +  , enumerateLeaves'+    -- * Nested parentheses+  , nestedParentheses +  , randomNestedParentheses+  , nthNestedParentheses+  , countNestedParentheses+  , fasc4A_algorithm_P+  , fasc4A_algorithm_W+  , fasc4A_algorithm_U+    -- * Generating binary trees+  , binaryTrees+  , countBinaryTrees+  , binaryTreesNaive+  , randomBinaryTree+  , fasc4A_algorithm_R+    -- * ASCII drawing+  , asciiBinaryTree_+    -- * Graphviz drawing+  , Dot+  , graphvizDotBinTree+  , graphvizDotBinTree'+  , graphvizDotForest+  , graphvizDotTree  +    -- * Bijections+  , forestToNestedParentheses+  , forestToBinaryTree+  , nestedParenthesesToForest+  , nestedParenthesesToForestUnsafe+  , nestedParenthesesToBinaryTree+  , nestedParenthesesToBinaryTreeUnsafe+  , binaryTreeToForest+  , binaryTreeToNestedParentheses+  ) +  where++--------------------------------------------------------------------------------++import Control.Applicative+import Control.Monad+import Control.Monad.ST++import Data.Array+import Data.Array.ST+import Data.Array.Unsafe++import Data.List+import Data.Tree (Tree(..),Forest(..))++import Data.Monoid+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))++import System.Random++import Math.Combinat.Numbers (factorial,binomial)++import Math.Combinat.Trees.Graphviz +  ( Dot +  , graphvizDotBinTree , graphvizDotBinTree' +  , graphvizDotForest  , graphvizDotTree +  )+import Math.Combinat.Classes+import Math.Combinat.Helper+import Math.Combinat.ASCII as ASCII++--------------------------------------------------------------------------------+-- * Types++-- | A binary tree with leaves decorated with type @a@.+data BinTree a+  = Branch (BinTree a) (BinTree a)+  | Leaf a+  deriving (Eq,Ord,Show,Read)++leaf :: BinTree ()+leaf = Leaf ()++-- | The monadic join operation of binary trees+graft :: BinTree (BinTree a) -> BinTree a+graft = go where+  go (Branch l r) = Branch (go l) (go r)+  go (Leaf   t  ) = t ++--------------------------------------------------------------------------------++-- | A binary tree with leaves and internal nodes decorated +-- with types @a@ and @b@, respectively.+data BinTree' a b+  = Branch' (BinTree' a b) b (BinTree' a b)+  | Leaf' a+  deriving (Eq,Ord,Show,Read)++forgetNodeDecorations :: BinTree' a b -> BinTree a+forgetNodeDecorations = go where+  go (Branch' left _ right) = Branch (go left) (go right)+  go (Leaf'   decor       ) = Leaf decor ++--------------------------------------------------------------------------------++instance HasNumberOfNodes (BinTree a) where+  numberOfNodes = go where+    go (Leaf   _  ) = 0+    go (Branch l r) = go l + go r + 1++instance HasNumberOfLeaves (BinTree a) where+  numberOfLeaves = go where+    go (Leaf   _  ) = 1+    go (Branch l r) = go l + go r +++instance HasNumberOfNodes (BinTree' a b) where+  numberOfNodes = go where+    go (Leaf'   _    ) = 0+    go (Branch' l _ r) = go l + go r + 1++instance HasNumberOfLeaves (BinTree' a b) where+  numberOfLeaves = go where+    go (Leaf'   _    ) = 1+    go (Branch' l _ r) = go l + go r ++--------------------------------------------------------------------------------+-- * Enumerate leaves++-- | Enumerates the leaves a tree, starting from 0, ignoring old labels+enumerateLeaves_ :: BinTree a -> BinTree Int+enumerateLeaves_ = snd . go 0 where+  go !k t = case t of+    Leaf   _   -> (k+1 , Leaf k)+    Branch l r -> (k'', Branch l' r')  where+                    (k' ,l') = go k  l+                    (k'',r') = go k' r++-- | Enumerates the leaves a tree, starting from zero, and also returns the number of leaves+enumerateLeaves' :: BinTree a -> (Int, BinTree (a,Int))+enumerateLeaves' = go 0 where+  go !k t = case t of+    Leaf   y   -> (k+1 , Leaf (y,k))+    Branch l r -> (k'', Branch l' r')  where+                    (k' ,l') = go k  l+                    (k'',r') = go k' r++-- | Enumerates the leaves a tree, starting from zero+enumerateLeaves :: BinTree a -> BinTree (a,Int)+enumerateLeaves = snd . enumerateLeaves'++--------------------------------------------------------------------------------+-- * conversion to 'Data.Tree'++-- | Convert a binary tree to a rose tree (from "Data.Tree")+toRoseTree :: BinTree a -> Tree (Maybe a)+toRoseTree = go where+  go (Branch t1 t2) = Node Nothing  [go t1, go t2]+  go (Leaf x)       = Node (Just x) [] ++toRoseTree' :: BinTree' a b -> Tree (Either b a)+toRoseTree' = go where+  go (Branch' t1 y t2) = Node (Left  y) [go t1, go t2]+  go (Leaf' x)         = Node (Right x) [] +  +--------------------------------------------------------------------------------+-- instances+  +instance Functor BinTree where+  fmap f = go where+    go (Branch left right) = Branch (go left) (go right)+    go (Leaf x) = Leaf (f x)+  +instance Foldable BinTree where+  foldMap f = go where+    go (Leaf x) = f x+    go (Branch left right) = (go left) `mappend` (go right)  ++instance Traversable BinTree where+  traverse f = go where +    go (Leaf x) = Leaf <$> f x+    go (Branch left right) = Branch <$> go left <*> go right++instance Applicative BinTree where+  pure    = Leaf+  u <*> t = go u where+    go (Branch l r) = Branch (go l) (go r)+    go (Leaf   f  ) = fmap f t++instance Monad BinTree where+  return    = Leaf+  (>>=) t f = go t where+    go (Branch l r) = Branch (go l) (go r)+    go (Leaf   y  ) = f y ++--------------------------------------------------------------------------------+-- * Nested parentheses++data Paren +  = LeftParen +  | RightParen +  deriving (Eq,Ord,Show,Read)++parenToChar :: Paren -> Char+parenToChar LeftParen = '('+parenToChar RightParen = ')'++parenthesesToString :: [Paren] -> String+parenthesesToString = map parenToChar++stringToParentheses :: String -> [Paren]+stringToParentheses [] = []+stringToParentheses (x:xs) = p : stringToParentheses xs where+  p = case x of+    '(' -> LeftParen+    ')' -> RightParen+    _ -> error "stringToParentheses: invalid character"++--------------------------------------------------------------------------------+-- * Bijections++forestToNestedParentheses :: Forest a -> [Paren]+forestToNestedParentheses = forest where+  -- forest :: Forest a -> [Paren]+  forest = concatMap tree +  -- tree :: Tree a -> [Paren]+  tree (Node _ sf) = LeftParen : forest sf ++ [RightParen]++forestToBinaryTree :: Forest a -> BinTree ()+forestToBinaryTree = forest where+  -- forest :: Forest a -> BinTree ()+  forest = foldr Branch leaf . map tree +  -- tree :: Tree a -> BinTree ()+  tree (Node _ sf) = case sf of+    [] -> leaf+    _  -> forest sf +   +nestedParenthesesToForest :: [Paren] -> Maybe (Forest ())+nestedParenthesesToForest ps = +  case parseForest ps of +    (rest,forest) -> case rest of+      [] -> Just forest+      _  -> Nothing+  where  +    parseForest :: [Paren] -> ( [Paren] , Forest () )+    parseForest ps = unfoldEither parseTree ps+    parseTree :: [Paren] -> Either [Paren] ( [Paren] , Tree () )  +    parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of+      (RightParen:qs) -> Right (qs, Node () ts)+      _ -> Left orig+    parseTree qs = Left qs++nestedParenthesesToForestUnsafe :: [Paren] -> Forest ()+nestedParenthesesToForestUnsafe = fromJust . nestedParenthesesToForest++nestedParenthesesToBinaryTree :: [Paren] -> Maybe (BinTree ())+nestedParenthesesToBinaryTree ps = +  case parseForest ps of +    (rest,forest) -> case rest of+      [] -> Just forest+      _  -> Nothing+  where  +    parseForest :: [Paren] -> ( [Paren] , BinTree () )+    parseForest ps = let (rest,ts) = unfoldEither parseTree ps in (rest , foldr Branch leaf ts)+    parseTree :: [Paren] -> Either [Paren] ( [Paren] , BinTree () )  +    parseTree orig@(LeftParen:ps) = let (rest,ts) = parseForest ps in case rest of+      (RightParen:qs) -> Right (qs, ts)+      _ -> Left orig+    parseTree qs = Left qs+    +nestedParenthesesToBinaryTreeUnsafe :: [Paren] -> BinTree ()+nestedParenthesesToBinaryTreeUnsafe = fromJust . nestedParenthesesToBinaryTree++binaryTreeToNestedParentheses :: BinTree a -> [Paren]+binaryTreeToNestedParentheses = worker where+  worker (Branch l r) = LeftParen : worker l ++ RightParen : worker r+  worker (Leaf _) = []++binaryTreeToForest :: BinTree a -> Forest ()+binaryTreeToForest = worker where+  worker (Branch l r) = Node () (worker l) : worker r+  worker (Leaf _) = []++--------------------------------------------------------------------------------+-- * Nested parentheses++-- | Generates all sequences of nested parentheses of length @2n@ in+-- lexigraphic order.+-- +-- Synonym for 'fasc4A_algorithm_P'.+--+nestedParentheses :: Int -> [[Paren]]+nestedParentheses = fasc4A_algorithm_P++-- | Synonym for 'fasc4A_algorithm_W'.+randomNestedParentheses :: RandomGen g => Int -> g -> ([Paren],g)+randomNestedParentheses = fasc4A_algorithm_W++-- | Synonym for 'fasc4A_algorithm_U'.+nthNestedParentheses :: Int -> Integer -> [Paren]+nthNestedParentheses = fasc4A_algorithm_U++countNestedParentheses :: Int -> Integer+countNestedParentheses = countBinaryTrees++-- | Generates all sequences of nested parentheses of length 2n.+-- Order is lexicographical (when right parentheses are considered +-- smaller then left ones).+-- Based on \"Algorithm P\" in Knuth, but less efficient because of+-- the \"idiomatic\" code.+fasc4A_algorithm_P :: Int -> [[Paren]]+fasc4A_algorithm_P 0 = [[]]+fasc4A_algorithm_P 1 = [[LeftParen,RightParen]]+fasc4A_algorithm_P n = unfold next ( start , [] ) where +  start = concat $ replicate n [RightParen,LeftParen]  -- already reversed!+   +  next :: ([Paren],[Paren]) -> ( [Paren] , Maybe ([Paren],[Paren]) )+  next ( (a:b:ls) , [] ) = next ( ls , b:a:[] )+  next ( lls@(l:ls) , rrs@(r:rs) ) = ( visit , new ) where+    visit = reverse lls ++ rrs+    new = +      {- debug (reverse ls,l,r,rs) $ -} +      case l of +        RightParen -> Just ( ls , LeftParen:RightParen:rs )+        LeftParen  -> +          {- debug ("---",reverse ls,l,r,rs) $ -}+          findj ( lls , [] ) ( reverse (RightParen:rs) , [] ) +  next _ = error "fasc4A_algorithm_P: fatal error shouldn't happen"++  findj :: ([Paren],[Paren]) -> ([Paren],[Paren]) -> Maybe ([Paren],[Paren])+  findj ( [] , _ ) _ = Nothing+  findj ( lls@(l:ls) , rs) ( xs , ys ) = +    {- debug ((reverse ls,l,rs),(reverse xs,ys)) $ -}+    case l of+      LeftParen  -> case xs of+        (a:_:as) -> findj ( ls, RightParen:rs ) ( as , LeftParen:a:ys )+        _ -> findj ( lls, [] ) ( reverse rs ++ xs , ys) +      RightParen -> Just ( reverse ys ++ xs ++ reverse (LeftParen:rs) ++ ls , [] )+  findj _ _ = error "fasc4A_algorithm_P: fatal error shouldn't happen"+    +-- | Generates a uniformly random sequence of nested parentheses of length 2n.    +-- Based on \"Algorithm W\" in Knuth.+fasc4A_algorithm_W :: RandomGen g => Int -> g -> ([Paren],g)+fasc4A_algorithm_W n' rnd = worker (rnd,n,n,[]) where+  n = fromIntegral n' :: Integer  +  -- the numbers we use are of order n^2, so for n >> 2^16 +  -- on a 32 bit machine, we need big integers.+  worker :: RandomGen g => (g,Integer,Integer,[Paren]) -> ([Paren],g)+  worker (rnd,_,0,parens) = (parens,rnd)+  worker (rnd,p,q,parens) = +    if x<(q+1)*(q-p) +      then worker (rnd' , p   , q-1 , LeftParen :parens)+      else worker (rnd' , p-1 , q   , RightParen:parens)+    where +      (x,rnd') = randomR ( 0 , (q+p)*(q-p+1)-1 ) rnd++-- | Nth sequence of nested parentheses of length 2n. +-- The order is the same as in 'fasc4A_algorithm_P'.+-- Based on \"Algorithm U\" in Knuth.+fasc4A_algorithm_U +  :: Int               -- ^ n+  -> Integer           -- ^ N; should satisfy 1 <= N <= C(n) +  -> [Paren]+fasc4A_algorithm_U n' bign0 = reverse $ worker (bign0,c0,n,n,[]) where+  n = fromIntegral n' :: Integer+  c0 = foldl f 1 [2..n]  +  f c p = ((4*p-2)*c) `div` (p+1) +  worker :: (Integer,Integer,Integer,Integer,[Paren]) -> [Paren]+  worker (_   ,_,_,0,parens) = parens+  worker (bign,c,p,q,parens) = +    if bign <= c' +      then worker (bign    , c'   , p   , q-1 , RightParen:parens)+      else worker (bign-c' , c-c' , p-1 , q   , LeftParen :parens)+    where+      c' = ((q+1)*(q-p)*c) `div` ((q+p)*(q-p+1))+  +--------------------------------------------------------------------------------+-- * Generating binary trees++-- | Generates all binary trees with @n@ nodes. +--   At the moment just a synonym for 'binaryTreesNaive'.+binaryTrees :: Int -> [BinTree ()]+binaryTrees = binaryTreesNaive++-- | # = Catalan(n) = \\frac { 1 } { n+1 } \\binom { 2n } { n }.+--+-- This is also the counting function for forests and nested parentheses.+countBinaryTrees :: Int -> Integer+countBinaryTrees n = binomial (2*n) n `div` (1 + fromIntegral n)+    +-- | Generates all binary trees with n nodes. The naive algorithm.+binaryTreesNaive :: Int -> [BinTree ()]+binaryTreesNaive 0 = [ leaf ]+binaryTreesNaive n = +  [ Branch l r +  | i <- [0..n-1] +  , l <- binaryTreesNaive i +  , r <- binaryTreesNaive (n-1-i) +  ]++-- | Generates an uniformly random binary tree, using 'fasc4A_algorithm_R'.+randomBinaryTree :: RandomGen g => Int -> g -> (BinTree (), g)+randomBinaryTree n rnd = (tree,rnd') where+  (decorated,rnd') = fasc4A_algorithm_R n rnd      +  tree = fmap (const ()) $ forgetNodeDecorations decorated++-- | Grows a uniformly random binary tree. +-- \"Algorithm R\" (Remy's procudere) in Knuth.+-- Nodes are decorated with odd numbers, leaves with even numbers (from the+-- set @[0..2n]@). Uses mutable arrays internally.+fasc4A_algorithm_R :: RandomGen g => Int -> g -> (BinTree' Int Int, g)+fasc4A_algorithm_R n0 rnd = res where+  res = runST $ do+    ar <- newArray (0,2*n0) 0+    rnd' <- worker rnd 1 ar+    links <- Data.Array.Unsafe.unsafeFreeze ar+    return (toTree links, rnd')+  toTree links = f (links!0) where+    f i = if odd i +      then Branch' (f $ links!i) i (f $ links!(i+1)) +      else Leaf' i  +  worker :: RandomGen g => g -> Int -> STUArray s Int Int -> ST s g+  worker rnd n ar = do +    if n > n0+      then return rnd+      else do+        writeArray ar (n2-b)   n2+        lk <- readArray ar k+        writeArray ar (n2-1+b) lk+        writeArray ar k        (n2-1)+        worker rnd' (n+1) ar      +    where  +      n2 = n+n+      (x,rnd') = randomR (0,4*n-3) rnd+      (k,b) = x `divMod` 2+      +--------------------------------------------------------------------------------      +-- * ASCII drawing  ++-- | Draws a binary tree in ASCII, ignoring node labels.+--+-- Example:+--+-- > autoTabulate RowMajor (Right 5) $ map asciiBinaryTree_ $ binaryTrees 4+--+asciiBinaryTree_ :: BinTree a -> ASCII+asciiBinaryTree_ = ASCII.asciiFromLines . fst . go where++  go :: BinTree a -> ([String],Int)+  go (Leaf x) = ([],0)+  go (Branch t1 t2) = ( new , j1+m ) where+    (ls1,j1) = go t1+    (ls2,j2) = go t2+    w1 = blockWidth ls1+    w2 = blockWidth ls2+    m = max 1 $ (w1-j1+j2+2) `div` 2+    s = 2*m - (w1-j1+j2)+    spaces = [replicate s ' ']+    ls = hConcatLines [ ls1 , spaces , ls2 ]+    top = [ replicate (j1+m-i) ' ' ++ "/" ++ replicate (2*(i-1)) ' ' ++ "\\" | i<-[1..m] ]+    new = mkLinesUniformWidth $ vConcatLines [ top , ls ] +        +  blockWidth ls = case ls of+    (l:_) -> length l+    []    -> 0++instance DrawASCII (BinTree ()) where+  ascii = asciiBinaryTree_ ++--------------------------------------------------------------------------------
+ src/Math/Combinat/Trees/Binary.hs-boot view
@@ -0,0 +1,22 @@+++module Math.Combinat.Trees.Binary where++--------------------------------------------------------------------------------++import Data.Tree ( Tree(..) , Forest(..) )++--------------------------------------------------------------------------------++-- | A binary tree with leaves decorated with type @a@.+data BinTree a+  = Branch (BinTree a) (BinTree a)+  | Leaf a++-- | A binary tree with leaves and internal nodes decorated +-- with types @a@ and @b@, respectively.+data BinTree' a b+  = Branch' (BinTree' a b) b (BinTree' a b)+  | Leaf' a++--------------------------------------------------------------------------------
+ src/Math/Combinat/Trees/Graphviz.hs view
@@ -0,0 +1,115 @@++-- | Creates graphviz @.dot@ files from trees.++module Math.Combinat.Trees.Graphviz +  ( Dot+  , graphvizDotBinTree+  , graphvizDotBinTree'+  , graphvizDotForest+  , graphvizDotTree+  )+  where++--------------------------------------------------------------------------------++import Data.Tree++import Control.Applicative++import {-# SOURCE #-} Math.Combinat.Trees.Binary ( BinTree(..)         , BinTree'(..)          )+import {-# SOURCE #-} Math.Combinat.Trees.Nary   ( addUniqueLabelsTree , addUniqueLabelsForest )++--------------------------------------------------------------------------------++type Dot = String++digraphBracket :: String -> [String] -> String   +digraphBracket name lines = +  "digraph " ++ name ++ " {\n" ++ +  concatMap (\xs -> "  "++xs++"\n") lines    +  ++ "}\n"+  +--------------------------------------------------------------------------------++graphvizDotBinTree :: Show a => String -> BinTree a -> Dot+graphvizDotBinTree graphname tree = +  digraphBracket graphname $ binTreeDot' tree++graphvizDotBinTree' :: (Show a, Show b) => String -> BinTree' a b -> Dot+graphvizDotBinTree' graphname tree = +  digraphBracket graphname $ binTree'Dot' tree+  +binTreeDot' :: Show a => BinTree a -> [String]+binTreeDot' tree = lines where+  lines = worker (0::Int) "r" tree +  name path = "node_"++path+  worker depth path (Leaf x) = +    [ name path ++ "[shape=box,label=\"" ++ show x ++ "\"" ++ "];" ]+  worker depth path (Branch left right) +    = [vertex,leftedge,rightedge] ++ +      worker (depth+1) ('l':path) left ++ +      worker (depth+1) ('r':path) right+    where +      vertex = name path ++ "[shape=circle,style=filled,height=0.25,label=\"\"];"+      leftedge  = name path ++ " -> " ++ name ('l':path) ++ "[tailport=sw];"+      rightedge = name path ++ " -> " ++ name ('r':path) ++ "[tailport=se];"++binTree'Dot' :: (Show a, Show b) => BinTree' a b -> [String]+binTree'Dot' tree = lines where+  lines = worker (0::Int) "r" tree +  name path = "node_"++path+  worker depth path (Leaf' x) = +    [ name path ++ "[shape=box,label=\"" ++ show x ++ "\"" ++ "];" ]+  worker depth path (Branch' left y right) +    = [vertex,leftedge,rightedge] ++ +      worker (depth+1) ('l':path) left ++ +      worker (depth+1) ('r':path) right+    where +      vertex = name path ++ "[shape=ellipse,label=\"" ++ show y ++ "\"];"+      leftedge  = name path ++ " -> " ++ name ('l':path) ++ "[tailport=sw];"+      rightedge = name path ++ " -> " ++ name ('r':path) ++ "[tailport=se];"++--------------------------------------------------------------------------------+    +-- | Generates graphviz @.dot@ file from a forest. The first argument tells whether+-- to make the individual trees clustered subgraphs; the second is the name of the+-- graph.+graphvizDotForest+  :: Show a +  => Bool        -- ^ make the individual trees clustered subgraphs+  -> Bool        -- ^ reverse the direction of the arrows+  -> String      -- ^ name of the graph+  -> Forest a +  -> Dot+graphvizDotForest clustered revarrows graphname forest = digraphBracket graphname lines where+  lines = concat $ zipWith cluster [(1::Int)..] (addUniqueLabelsForest forest) +  name unique = "node_"++show unique+  cluster j tree = let treelines = worker (0::Int) tree in case clustered of+    False -> treelines+    True  -> ("subgraph cluster_"++show j++" {") : map ("  "++) treelines ++ ["}"] +  worker depth (Node (label,unique) subtrees) = vertex : edges ++ concatMap (worker (depth+1)) subtrees where+    vertex = name unique ++ "[label=\"" ++ show label ++ "\"" ++ "];"+    edges = map edge subtrees+    edge (Node (_,unique') _) = if not revarrows +      then name unique  ++ " -> " ++ name unique'   +      else name unique' ++ " -> " ++ name unique+      +-- | Generates graphviz @.dot@ file from a tree. The first argument is+-- the name of the graph.+graphvizDotTree+  :: Show a +  => Bool     -- ^ reverse the direction of the arrow+  -> String   -- ^ name of the graph+  -> Tree a +  -> Dot+graphvizDotTree revarrows graphname tree = digraphBracket graphname lines where+  lines = worker (0::Int) (addUniqueLabelsTree tree) +  name unique = "node_"++show unique+  worker depth (Node (label,unique) subtrees) = vertex : edges ++ concatMap (worker (depth+1)) subtrees where+    vertex = name unique ++ "[label=\"" ++ show label ++ "\"" ++ "];"+    edges = map edge subtrees+    edge (Node (_,unique') _) = if not revarrows +      then name unique  ++ " -> " ++ name unique'   +      else name unique' ++ " -> " ++ name unique++--------------------------------------------------------------------------------
+ src/Math/Combinat/Trees/Nary.hs view
@@ -0,0 +1,430 @@++-- | N-ary trees.++{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+module Math.Combinat.Trees.Nary +  (      +    -- * Types+    module Data.Tree+  , Tree(..)+    -- * Regular trees  +  , ternaryTrees+  , regularNaryTrees+  , semiRegularTrees+  , countTernaryTrees+  , countRegularNaryTrees+    -- * \"derivation trees\"+  , derivTrees+    -- * ASCII drawings+  , asciiTreeVertical_+  , asciiTreeVertical+  , asciiTreeVerticalLeavesOnly+    -- * Graphviz drawing+  , Dot+  , graphvizDotTree  +  , graphvizDotForest+    -- * Classifying nodes+  , classifyTreeNode+  , isTreeLeaf  , isTreeNode+  , isTreeLeaf_ , isTreeNode_+  , treeNodeNumberOfChildren +    -- * Counting nodes+  , countTreeNodes+  , countTreeLeaves+  , countTreeLabelsWith+  , countTreeNodesWith +    -- * Left and right spines+  , leftSpine  , leftSpine_+  , rightSpine , rightSpine_+  , leftSpineLength , rightSpineLength+    -- * Unique labels+  , addUniqueLabelsTree+  , addUniqueLabelsForest+  , addUniqueLabelsTree_+  , addUniqueLabelsForest_+    -- * Labelling by depth+  , labelDepthTree+  , labelDepthForest+  , labelDepthTree_+  , labelDepthForest_+    -- * Labelling by number of children+  , labelNChildrenTree+  , labelNChildrenForest+  , labelNChildrenTree_+  , labelNChildrenForest_+    +  ) where+++--------------------------------------------------------------------------------++import Data.Tree+import Data.List++import Control.Applicative++--import Control.Monad.State+import Control.Monad.Trans.State+import Data.Traversable (traverse)++import Math.Combinat.Sets                  ( listTensor )+import Math.Combinat.Partitions.Multiset   ( partitionMultiset )+import Math.Combinat.Compositions          ( compositions )+import Math.Combinat.Numbers               ( factorial, binomial )++import Math.Combinat.Trees.Graphviz ( Dot , graphvizDotForest , graphvizDotTree )++import Math.Combinat.Classes+import Math.Combinat.ASCII as ASCII+import Math.Combinat.Helper++--------------------------------------------------------------------------------++instance HasNumberOfNodes (Tree a) where+  numberOfNodes = go where+    go (Node label subforest) = if null subforest +      then 0 +      else 1 + sum' (map go subforest)++instance HasNumberOfLeaves (Tree a) where+  numberOfLeaves = go where+    go (Node label subforest) = if null subforest +      then 1+      else sum' (map go subforest)++--------------------------------------------------------------------------------++-- | @regularNaryTrees d n@ returns the list of (rooted) trees on @n@ nodes where each+-- node has exactly @d@ children. Note that the leaves do not count in @n@.+-- Naive algorithm.+regularNaryTrees +  :: Int         -- ^ degree = number of children of each node+  -> Int         -- ^ number of nodes+  -> [Tree ()]+regularNaryTrees d = go where+  go 0 = [ Node () [] ]+  go n = [ Node () cs+         | is <- compositions d (n-1) +         , cs <- listTensor [ go i | i<-is ] +         ]+  +-- | Ternary trees on @n@ nodes (synonym for @regularNaryTrees 3@)+ternaryTrees :: Int -> [Tree ()]  +ternaryTrees = regularNaryTrees 3++-- | We have +--+-- > length (regularNaryTrees d n) == countRegularNaryTrees d n == \frac {1} {(d-1)n+1} \binom {dn} {n} +--+countRegularNaryTrees :: (Integral a, Integral b) => a -> b -> Integer+countRegularNaryTrees d n = binomial (dd*nn) nn `div` ((dd-1)*nn+1) where+  dd = fromIntegral d :: Integer+  nn = fromIntegral n :: Integer ++-- | @\# = \\frac {1} {(2n+1} \\binom {3n} {n}@+countTernaryTrees :: Integral a => a -> Integer  +countTernaryTrees = countRegularNaryTrees (3::Int)++--------------------------------------------------------------------------------++-- | All trees on @n@ nodes where the number of children of all nodes is+-- in element of the given set. Example:+--+-- > autoTabulate RowMajor (Right 5) $ map asciiTreeVertical +-- >                                 $ map labelNChildrenTree_ +-- >                                 $ semiRegularTrees [2,3] 2+-- >+-- > [ length $ semiRegularTrees [2,3] n | n<-[0..] ] == [1,2,10,66,498,4066,34970,312066,2862562,26824386,...]+--+-- The latter sequence is A027307 in OEIS: <https://oeis.org/A027307>+--+-- Remark: clearly, we have+--+-- > semiRegularTrees [d] n == regularNaryTrees d n+--+-- +semiRegularTrees +  :: [Int]         -- ^ set of allowed number of children+  -> Int           -- ^ number of nodes+  -> [Tree ()]+semiRegularTrees []    n = if n==0 then [Node () []] else []+semiRegularTrees dset_ n = +  if head dset >=1 +    then go n+    else error "semiRegularTrees: expecting a list of positive integers"+  where+    dset = map head $ group $ sort $ dset_+    +    go 0 = [ Node () [] ]+    go n = [ Node () cs+           | d <- dset+           , is <- compositions d (n-1) +           , cs <- listTensor [ go i | i<-is ]+           ]+           +{- ++NOTES:++A006318 = [ length $ semiRegularTrees [1,2] n | n<-[0..] ] == [1,2,6,22,90,394,1806,8558,41586,206098,1037718.. ]+??      = [ length $ semiRegularTrees [1,3] n | n<-[0..] ] == [1,2,8,44,280,1936,14128,107088,834912,6652608 .. ]+??      = [ length $ semiRegularTrees [1,4] n | n<-[0..] ] == [1,2,10,74,642,6082,60970,635818,6826690++A027307 = [ length $ semiRegularTrees [2,3] n | n<-[0..] ] == [1,2,10,66,498,4066,34970,312066,2862562,26824386,...]+A219534 = [ length $ semiRegularTrees [2,4] n | n<-[0..] ] == [1,2,12,100,968,10208,113792,1318832 ..]+??      = [ length $ semiRegularTrees [2,5] n | n<-[0..] ] == [1,2,14,142,1690,21994,303126,4348102 ..]++A144097 = [ length $ semiRegularTrees [3,4] n | n<-[0..] ] == [1,2,14,134,1482,17818,226214,2984206,40503890..]++A107708 = [ length $ semiRegularTrees [1,2,3]   n | n<-[0..] ] == [1,3,18,144,1323,13176,138348,1507977 .. ]+??      = [ length $ semiRegularTrees [1,2,3,4] n | n<-[0..] ] == [1,4,40,560,9120,161856,3036800,59242240 .. ] ++-}+             +--------------------------------------------------------------------------------++-- | Vertical ASCII drawing of a tree, without labels. Example:+--+-- > autoTabulate RowMajor (Right 5) $ map asciiTreeVertical_ $ regularNaryTrees 2 4 +--+-- Nodes are denoted by @\@@, leaves by @*@.+--+asciiTreeVertical_ :: Tree a -> ASCII+asciiTreeVertical_ tree = ASCII.asciiFromLines (go tree) where+  go :: Tree b -> [String]+  go (Node _ cs) = case cs of+    [] -> ["-*"]+    _  -> concat $ mapWithFirstLast f $ map go cs+    +  f :: Bool -> Bool -> [String] -> [String] +  f bf bl (l:ls) = let indent = if bl           then "  "  else  "| "+                       gap    = if bl           then []    else ["| "]+                       branch = if bl && not bf +                                  then "\\-" +                                  else if bf then "@-"+                                             else "+-"+                   in  (branch++l) : map (indent++) ls ++ gap++instance DrawASCII (Tree ()) where+  ascii = asciiTreeVertical_++-- | Prints all labels. Example:+-- +-- > asciiTreeVertical $ addUniqueLabelsTree_ $ (regularNaryTrees 3 9) !! 666+--+-- Nodes are denoted by @(label)@, leaves by @label@.+--+asciiTreeVertical :: Show a => Tree a -> ASCII+asciiTreeVertical tree = ASCII.asciiFromLines (go tree) where+  go :: Show b => Tree b -> [String]+  go (Node x cs) = case cs of+    [] -> ["-- " ++ show x]+    _  -> concat $ mapWithFirstLast (f (show x)) $ map go cs+    +  f :: String -> Bool -> Bool -> [String] -> [String] +  f label bf bl (l:ls) =+        let spaces = (map (const ' ') label  ) +            dashes = (map (const '-') spaces ) +            indent = if bl then "  " ++spaces++"  " else  " |" ++ spaces ++ "  "+            gap    = if bl then []                  else [" |" ++ spaces ++ "  "]+            branch = if bl && not bf+                           then " \\"++dashes++"--" +                           else if bf +                             then "-(" ++ label  ++ ")-"+                             else " +" ++ dashes ++ "--"+        in  (branch++l) : map (indent++) ls ++ gap++-- | Prints the labels for the leaves, but not for the  nodes.+asciiTreeVerticalLeavesOnly :: Show a => Tree a -> ASCII+asciiTreeVerticalLeavesOnly tree = ASCII.asciiFromLines (go tree) where+  go :: Show b => Tree b -> [String]+  go (Node x cs) = case cs of+    [] -> ["- " ++ show x]+    _  -> concat $ mapWithFirstLast f $ map go cs+    +  f :: Bool -> Bool -> [String] -> [String] +  f bf bl (l:ls) = let indent = if bl           then "  "  else  "| "+                       gap    = if bl           then []    else ["| "]+                       branch = if bl && not bf +                                  then "\\-" +                                  else if bf then "@-"+                                             else "+-"+                   in  (branch++l) : map (indent++) ls ++ gap+  +--------------------------------------------------------------------------------+  +-- | The leftmost spine (the second element of the pair is the leaf node)+leftSpine  :: Tree a -> ([a],a)+leftSpine = go where+  go (Node x cs) = case cs of+    [] -> ([],x)+    _  -> let (xs,y) = go (head cs) in (x:xs,y) ++rightSpine  :: Tree a -> ([a],a)+rightSpine = go where+  go (Node x cs) = case cs of+    [] -> ([],x)+    _  -> let (xs,y) = go (last cs) in (x:xs,y) ++-- | The leftmost spine without the leaf node+leftSpine_  :: Tree a -> [a]+leftSpine_ = go where+  go (Node x cs) = case cs of+    [] -> []+    _  -> x : go (head cs)++rightSpine_ :: Tree a -> [a] +rightSpine_ = go where+  go (Node x cs) = case cs of+    [] -> []+    _  -> x : go (last cs) ++-- | The length (number of edges) on the left spine +--+-- > leftSpineLength tree == length (leftSpine_ tree)+--+leftSpineLength  :: Tree a -> Int  +leftSpineLength = go 0 where+  go n (Node x cs) = case cs of+    [] -> n+    _  -> go (n+1) (head cs)+  +rightSpineLength :: Tree a -> Int  +rightSpineLength = go 0 where+  go n (Node x cs) = case cs of+    [] -> n+    _  -> go (n+1) (last cs)++--------------------------------------------------------------------------------++-- | 'Left' is leaf, 'Right' is node+classifyTreeNode :: Tree a -> Either a a+classifyTreeNode (Node x cs) = case cs of { [] -> Left x ; _ -> Right x }++isTreeLeaf :: Tree a -> Maybe a  +isTreeLeaf (Node x cs) = case cs of { [] -> Just x ; _ -> Nothing }  ++isTreeNode :: Tree a -> Maybe a  +isTreeNode (Node x cs) = case cs of { [] -> Nothing ; _ -> Just x }  ++isTreeLeaf_ :: Tree a -> Bool  +isTreeLeaf_ (Node x cs) = case cs of { [] -> True ; _ -> False }  +  +isTreeNode_ :: Tree a -> Bool  +isTreeNode_ (Node x cs) = case cs of { [] -> False ; _ -> True }  ++treeNodeNumberOfChildren :: Tree a -> Int+treeNodeNumberOfChildren (Node _ cs) = length cs++--------------------------------------------------------------------------------+-- counting++countTreeNodes :: Tree a -> Int+countTreeNodes = go where+  go (Node x cs) = case cs of+    [] -> 0+    _  -> 1 + sum (map go cs)++countTreeLeaves :: Tree a -> Int+countTreeLeaves = go where+  go (Node x cs) = case cs of+    [] -> 1+    _  -> sum (map go cs)++countTreeLabelsWith :: (a -> Bool) -> Tree a -> Int+countTreeLabelsWith f = go where+  go (Node label cs) = (if f label then 1 else 0) + sum (map go cs)++countTreeNodesWith :: (Tree a -> Bool) -> Tree a -> Int+countTreeNodesWith f = go where+  go node@(Node _ cs) = (if f node then 1 else 0) + sum (map go cs)++--------------------------------------------------------------------------------++-- | Adds unique labels to the nodes (including leaves) of a 'Tree'.+addUniqueLabelsTree :: Tree a -> Tree (a,Int) +addUniqueLabelsTree tree = head (addUniqueLabelsForest [tree])++-- | Adds unique labels to the nodes (including leaves) of a 'Forest'+addUniqueLabelsForest :: Forest a -> Forest (a,Int) +addUniqueLabelsForest forest = evalState (mapM globalAction forest) 1 where+  globalAction tree = +    unwrapMonad $ traverse localAction tree +  localAction x = WrapMonad $ do+    i <- get+    put (i+1)+    return (x,i)++addUniqueLabelsTree_ :: Tree a -> Tree Int+addUniqueLabelsTree_ = fmap snd . addUniqueLabelsTree  ++addUniqueLabelsForest_ :: Forest a -> Forest Int+addUniqueLabelsForest_ = map (fmap snd) . addUniqueLabelsForest++--------------------------------------------------------------------------------+    +-- | Attaches the depth to each node. The depth of the root is 0. +labelDepthTree :: Tree a -> Tree (a,Int) +labelDepthTree tree = worker 0 tree where+  worker depth (Node label subtrees) = Node (label,depth) (map (worker (depth+1)) subtrees)++labelDepthForest :: Forest a -> Forest (a,Int) +labelDepthForest forest = map labelDepthTree forest+    +labelDepthTree_ :: Tree a -> Tree Int+labelDepthTree_ = fmap snd . labelDepthTree++labelDepthForest_ :: Forest a -> Forest Int +labelDepthForest_ = map (fmap snd) . labelDepthForest++--------------------------------------------------------------------------------++-- | Attaches the number of children to each node. +labelNChildrenTree :: Tree a -> Tree (a,Int)+labelNChildrenTree (Node x subforest) = +  Node (x, length subforest) (map labelNChildrenTree subforest)+  +labelNChildrenForest :: Forest a -> Forest (a,Int) +labelNChildrenForest forest = map labelNChildrenTree forest++labelNChildrenTree_ :: Tree a -> Tree Int+labelNChildrenTree_ = fmap snd . labelNChildrenTree++labelNChildrenForest_ :: Forest a -> Forest Int +labelNChildrenForest_ = map (fmap snd) . labelNChildrenForest+    +--------------------------------------------------------------------------------++-- | Computes the set of equivalence classes of rooted trees (in the +-- sense that the leaves of a node are /unordered/) +-- with @n = length ks@ leaves where the set of heights of +-- the leaves matches the given set of numbers. +-- The height is defined as the number of /edges/ from the leaf to the root. +--+-- TODO: better name?+derivTrees :: [Int] -> [Tree ()]+derivTrees xs = derivTrees' (map (+1) xs)++derivTrees' :: [Int] -> [Tree ()]+derivTrees' [] = []+derivTrees' [n] = +  if n>=1 +    then [unfoldTree f 1] +    else [] +  where +    f k = if k<n then ((),[k+1]) else ((),[])+derivTrees' ks = +  if and (map (>0) ks)+    then+      [ Node () sub +      | part <- parts+      , let subtrees = map g part+      , sub <- listTensor subtrees +      ] +    else []+  where+    parts = partitionMultiset ks+    g xs = derivTrees' (map (\x->x-1) xs)++--------------------------------------------------------------------------------+
+ src/Math/Combinat/Trees/Nary.hs-boot view
@@ -0,0 +1,16 @@++module Math.Combinat.Trees.Nary where++--------------------------------------------------------------------------------++import Data.Tree++--------------------------------------------------------------------------------++addUniqueLabelsTree   :: Tree   a -> Tree   (a,Int) +addUniqueLabelsForest :: Forest a -> Forest (a,Int) ++addUniqueLabelsTree_   :: Tree   a -> Tree   Int+addUniqueLabelsForest_ :: Forest a -> Forest Int++--------------------------------------------------------------------------------
+ src/Math/Combinat/Tuples.hs view
@@ -0,0 +1,61 @@++-- | Tuples.++module Math.Combinat.Tuples where++import Math.Combinat.Helper++-------------------------------------------------------+-- Tuples++-- | \"Tuples\" fitting into a give shape. The order is lexicographic, that is,+--+-- > sort ts == ts where ts = tuples' shape+--+--   Example: +--+-- > tuples' [2,3] = +-- >   [[0,0],[0,1],[0,2],[0,3],[1,0],[1,1],[1,2],[1,3],[2,0],[2,1],[2,2],[2,3]]+--+tuples' :: [Int] -> [[Int]]+tuples' [] = [[]]+tuples' (s:ss) = [ x:xs | x <- [0..s] , xs <- tuples' ss ] ++-- | positive \"tuples\" fitting into a give shape.+tuples1' :: [Int] -> [[Int]]+tuples1' [] = [[]]+tuples1' (s:ss) = [ x:xs | x <- [1..s] , xs <- tuples1' ss ] ++-- | # = \\prod_i (m_i + 1)+countTuples' :: [Int] -> Integer+countTuples' shape = product $ map f shape where+  f k = 1 + fromIntegral k++-- | # = \\prod_i m_i+countTuples1' :: [Int] -> Integer+countTuples1' shape = product $ map fromIntegral shape++tuples +  :: Int    -- ^ length (width)+  -> Int    -- ^ maximum (height)+  -> [[Int]]+tuples len k = tuples' (replicate len k)++tuples1 +  :: Int    -- ^ length (width)+  -> Int    -- ^ maximum (height)+  -> [[Int]]+tuples1 len k = tuples1' (replicate len k)++-- | # = (m+1) ^ len+countTuples :: Int -> Int -> Integer+countTuples len k = (1 + fromIntegral k) ^ len++-- | # = m ^ len+countTuples1 :: Int -> Int -> Integer+countTuples1 len k = fromIntegral k ^ len++binaryTuples :: Int -> [[Bool]]+binaryTuples len = map (map intToBool) (tuples len 1)++-------------------------------------------------------
+ src/Math/Combinat/TypeLevel.hs view
@@ -0,0 +1,117 @@++-- | Type-level hackery.+--+-- This module is used for groups whose parameters are encoded as type-level natural numbers,+-- for example finite cyclic groups, free groups, symmetric groups and braid groups.+--++{-# LANGUAGE PolyKinds, DataKinds, KindSignatures, ScopedTypeVariables, +             ExistentialQuantification, Rank2Types #-}++module Math.Combinat.TypeLevel +  ( -- * Proxy+    Proxy(..)+  , proxyUndef+  , proxyOf+  , proxyOf1+  , proxyOf2+  , asProxyTypeOf   -- defined in Data.Proxy+  , asProxyTypeOf1+    -- * Type-level naturals as type arguments+  , typeArg +  , iTypeArg+    -- * Hiding the type parameter+  , Some (..)+  , withSome , withSomeM+  , selectSome , selectSomeM+  , withSelected , withSelectedM+  )+  where++--------------------------------------------------------------------------------++import Data.Proxy ( Proxy(..) , asProxyTypeOf )+import GHC.TypeLits++import Math.Combinat.Numbers.Primes ( isProbablyPrime )++--------------------------------------------------------------------------------+-- * Proxy++proxyUndef :: Proxy a -> a+proxyUndef _ = error "proxyUndef"++proxyOf :: a -> Proxy a+proxyOf _ = Proxy++proxyOf1 :: f a -> Proxy a+proxyOf1 _ = Proxy++proxyOf2 :: g (f a) -> Proxy a+proxyOf2 _ = Proxy++asProxyTypeOf1 :: f a -> Proxy a -> f a +asProxyTypeOf1 y _ = y++--------------------------------------------------------------------------------+-- * Type-level naturals as type arguments++typeArg :: KnownNat n => f (n :: Nat) -> Integer+typeArg = natVal . proxyOf1++iTypeArg :: KnownNat n => f (n :: Nat) -> Int+iTypeArg = fromIntegral . typeArg++--------------------------------------------------------------------------------+-- * Hiding the type parameter++-- | Hide the type parameter of a functor. Example: @Some Braid@+data Some f = forall n. KnownNat n => Some (f n)++-- | Uses the value inside a 'Some'+withSome :: Some f -> (forall n. KnownNat n => f n -> a) -> a+withSome some polyFun = case some of { Some stuff -> polyFun stuff }++-- | Monadic version of 'withSome'+withSomeM :: Monad m => Some f -> (forall n. KnownNat n => f n -> m a) -> m a+withSomeM some polyAct = case some of { Some stuff -> polyAct stuff }++-- | Given a polymorphic value, we select at run time the+-- one specified by the second argument+selectSome :: Integral int => (forall n. KnownNat n => f n) -> int -> Some f+selectSome poly n = case someNatVal (fromIntegral n :: Integer) of+  Nothing   -> error "selectSome: not a natural number"+  Just snat -> case snat of+    SomeNat pxy -> Some (asProxyTypeOf1 poly pxy)++-- | Monadic version of 'selectSome'+selectSomeM :: forall m f int. (Integral int, Monad m) => (forall n. KnownNat n => m (f n)) -> int -> m (Some f)+selectSomeM runPoly n = case someNatVal (fromIntegral n :: Integer) of+  Nothing   -> error "selectSomeM: not a natural number"+  Just snat -> case snat of+    SomeNat pxy -> do+      poly <- runPoly +      return $ Some (asProxyTypeOf1 poly pxy)++-- | Combination of 'selectSome' and 'withSome': we make a temporary structure+-- of the given size, but we immediately consume it.+withSelected +  :: Integral int +  => (forall n. KnownNat n => f n -> a) +  -> (forall n. KnownNat n => f n) +  -> int +  -> a+withSelected f x n = withSome (selectSome x n) f++-- | (Half-)monadic version of 'withSelected'+withSelectedM +  :: forall m f int a. (Integral int, Monad m) +  => (forall n. KnownNat n => f n -> a) +  -> (forall n. KnownNat n => m (f n)) +  -> int +  -> m a+withSelectedM f mx n = do +  s <- selectSomeM mx n+  return (withSome s f)++--------------------------------------------------------------------------------
+ svg/bintrees.svg view
@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" width="750.0" height="206.08695652173907" font-size="1" viewBox="0 0 750 206" stroke="rgb(0,0,0)" stroke-opacity="1"><g><g fill="rgb(0,0,0)" fill-opacity="0.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" stroke-width="1.5725913258888558" stroke-linecap="butt" stroke-linejoin="miter" font-size="1.0em" stroke-miterlimit="10.0"><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 618.3370976849237,109.9350649350649 l 33.879164313946916,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 618.3370976849237,109.9350649350649 l -8.469791078486729,18.068887634105018 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 655.0395256916995,130.26256352343304 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 609.867306606437,128.0039525691699 l 25.409373235460187,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 609.867306606437,128.0039525691699 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 638.0999435347261,148.33145115753805 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 601.3975155279502,146.07284020327495 l 16.939582156973458,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 601.3975155279502,146.07284020327495 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 621.1603613777526,166.4003387916431 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 592.9277244494634,164.14172783737996 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 592.9277244494634,164.14172783737996 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 604.220779220779,184.4692264257481 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 587.2811970638056,184.4692264257481 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 596.3156408808582,164.14172783737996 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 604.7854319593449,146.07284020327495 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 613.2552230378317,128.0039525691699 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 621.7250141163184,109.9350649350649 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 522.3461321287408,109.9350649350649 l 33.879164313946916,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 522.3461321287408,109.9350649350649 l -8.469791078486729,18.068887634105018 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 559.0485601355166,130.26256352343304 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 513.876341050254,128.0039525691699 l 25.409373235460187,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 513.876341050254,128.0039525691699 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 542.1089779785432,148.33145115753805 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 505.40654997176733,146.07284020327495 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 505.40654997176733,146.07284020327495 l -16.939582156973458,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 513.876341050254,164.14172783737996 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 513.876341050254,164.14172783737996 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 525.1693958215698,184.4692264257481 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 508.22981366459624,184.4692264257481 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 517.2642574816488,164.14172783737996 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 491.29023150762276,166.4003387916431 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 508.794466403162,146.07284020327495 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 517.2642574816488,128.0039525691699 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 525.7340485601355,109.9350649350649 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 426.35516657255783,118.9695087521174 l 33.879164313946916,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 426.35516657255783,118.9695087521174 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 463.0575945793337,139.29700734048555 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 417.8853754940711,137.03839638622242 l 16.939582156973458,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 417.8853754940711,137.03839638622242 l -16.939582156973458,18.06888763410502 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 434.82495765104454,155.10728402032743 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 434.82495765104454,155.10728402032743 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 446.1180124223602,175.43478260869557 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 429.17843026538674,175.43478260869557 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 438.2128740824392,155.10728402032743 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 400.94579333709765,155.10728402032743 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 400.94579333709765,155.10728402032743 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 412.2388481084133,175.43478260869557 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 395.29926595143985,175.43478260869557 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 404.3337097684923,155.10728402032743 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 421.2732919254658,137.03839638622242 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 429.7430830039525,118.9695087521174 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 330.3642010163749,109.9350649350649 l 33.879164313946916,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 330.3642010163749,109.9350649350649 l -8.469791078486729,18.068887634105018 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 367.06662902315077,130.26256352343304 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 321.8944099378882,128.0039525691699 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 321.8944099378882,128.0039525691699 l -25.409373235460187,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 330.364201016375,146.07284020327495 l 16.939582156973458,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 330.364201016375,146.07284020327495 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 350.12704686617735,166.4003387916431 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 321.89440993788827,164.14172783737996 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 321.89440993788827,164.14172783737996 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 333.18746470920394,184.4692264257481 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 316.24788255223046,184.4692264257481 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 325.28232636928294,164.14172783737996 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 333.75211744776965,146.07284020327495 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 299.30830039525694,148.33145115753805 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 325.2823263692829,128.0039525691699 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 333.7521174477696,109.9350649350649 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 234.37323546019198,109.9350649350649 l 33.879164313946916,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 234.37323546019198,109.9350649350649 l -8.469791078486729,18.068887634105018 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 271.0756634669678,130.26256352343304 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 225.90344438170524,128.0039525691699 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 225.90344438170524,128.0039525691699 l -25.409373235460187,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 234.37323546019198,146.07284020327495 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 234.37323546019198,146.07284020327495 l -16.939582156973458,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 242.8430265386787,164.14172783737996 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 242.8430265386787,164.14172783737996 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 254.13608130999432,184.4692264257481 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 237.19649915302088,184.4692264257481 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 246.23094297007341,164.14172783737996 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 220.25691699604744,166.4003387916431 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 237.76115189158668,146.07284020327495 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 203.31733483907396,148.33145115753805 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 229.29136081309994,128.0039525691699 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 237.76115189158668,109.9350649350649 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 138.38226990400904,118.9695087521174 l 25.409373235460187,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 138.38226990400904,118.9695087521174 l -16.939582156973458,18.06888763410502 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 163.79164313946922,137.03839638622242 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 163.79164313946922,137.03839638622242 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 175.08469791078483,157.36589497459056 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 158.14511575381138,157.36589497459056 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 167.17955957086392,137.03839638622242 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 121.44268774703558,137.03839638622242 l 16.939582156973458,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 121.44268774703558,137.03839638622242 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 141.20553359683794,157.36589497459056 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 112.97289666854886,155.10728402032743 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 112.97289666854886,155.10728402032743 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 124.2659514398645,175.43478260869557 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 107.32636928289104,175.43478260869557 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 116.36081309994354,155.10728402032743 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 124.83060417843026,137.03839638622242 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 141.77018633540374,118.9695087521174 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 42.39130434782612,118.9695087521174 l 25.409373235460187,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 42.39130434782612,118.9695087521174 l -16.939582156973458,18.06888763410502 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 67.8006775832863,137.03839638622242 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 67.8006775832863,137.03839638622242 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 79.09373235460195,157.36589497459056 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 62.15415019762848,157.36589497459056 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 71.18859401468099,137.03839638622242 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 25.451722190852664,137.03839638622242 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 25.451722190852664,137.03839638622242 l -16.939582156973458,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 33.92151326933939,155.10728402032743 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 33.92151326933939,155.10728402032743 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 45.21456804065503,175.43478260869557 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 28.274985883681573,175.43478260869557 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 37.309429700734086,155.10728402032743 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 11.335403726708115,157.36589497459056 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 28.839638622247357,137.03839638622242 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 45.779220779220815,118.9695087521174 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 618.3370976849237,18.461321287408232 l 16.939582156973458,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 618.3370976849237,18.461321287408232 l -25.409373235460187,18.06888763410502 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 635.2766798418971,36.53020892151325 l 16.939582156973458,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 635.2766798418971,36.53020892151325 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 655.0395256916995,56.8577075098814 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 626.8068887634104,54.59909655561827 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 626.8068887634104,54.59909655561827 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 638.099943534726,74.92659514398642 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 621.1603613777526,74.92659514398642 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 630.1948051948051,54.59909655561827 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 638.6645962732919,36.53020892151325 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 592.9277244494635,36.53020892151326 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 592.9277244494635,36.53020892151326 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 604.2207792207791,56.85770750988141 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 587.2811970638057,56.85770750988141 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 596.3156408808583,36.53020892151326 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 621.7250141163184,18.461321287408232 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 522.3461321287408,18.461321287408232 l 16.939582156973458,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 522.3461321287408,18.461321287408232 l -25.409373235460187,18.06888763410502 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 539.2857142857142,36.53020892151325 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 539.2857142857142,36.53020892151325 l -16.939582156973458,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 547.755505364201,54.59909655561827 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 547.755505364201,54.59909655561827 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 559.0485601355166,74.92659514398642 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 542.1089779785432,74.92659514398642 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 551.1434217955957,54.59909655561827 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 525.1693958215698,56.8577075098814 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 542.673630717109,36.53020892151325 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 496.9367588932806,36.53020892151326 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 496.9367588932806,36.53020892151326 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 508.2298136645963,56.85770750988141 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 491.2902315076228,56.85770750988141 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 500.3246753246753,36.53020892151326 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 525.7340485601355,18.461321287408232 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 426.35516657255783,9.42687747035572 l 8.469791078486729,18.068887634105018 " /></g><g stroke-width="0.9034443817052511"><path d="M 426.35516657255783,9.42687747035572 l -33.879164313946916,17.504234895539238 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 434.8249576510446,27.495765104460737 l 25.409373235460187,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 434.8249576510446,27.495765104460737 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 463.05759457933374,47.82326369282889 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 426.3551665725579,45.564652738565755 l 16.939582156973458,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 426.3551665725579,45.564652738565755 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 446.11801242236027,65.89215132693391 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 417.8853754940712,63.63354037267077 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 417.8853754940712,63.63354037267077 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 429.17843026538685,83.96103896103892 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 412.2388481084134,83.96103896103892 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 421.27329192546586,63.63354037267077 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 429.74308300395256,45.564652738565755 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 438.21287408243927,27.495765104460737 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 395.29926595143985,29.754376058723867 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 429.7430830039525,9.42687747035572 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 330.3642010163749,9.42687747035572 l 8.469791078486729,18.068887634105018 " /></g><g stroke-width="0.9034443817052511"><path d="M 330.3642010163749,9.42687747035572 l -33.879164313946916,17.504234895539238 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 338.8339920948617,27.495765104460737 l 25.409373235460187,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 338.8339920948617,27.495765104460737 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 367.0666290231508,47.82326369282889 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 330.364201016375,45.564652738565755 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 330.364201016375,45.564652738565755 l -16.939582156973458,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 338.8339920948617,63.63354037267077 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 338.8339920948617,63.63354037267077 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 350.12704686617735,83.96103896103892 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 333.1874647092039,83.96103896103892 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 342.22190852625636,63.63354037267077 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 316.2478825522304,65.89215132693391 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 333.75211744776965,45.564652738565755 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 342.22190852625636,27.495765104460737 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 299.30830039525694,29.754376058723867 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 333.7521174477696,9.42687747035572 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 234.37323546019198,18.461321287408232 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 234.37323546019198,18.461321287408232 l -33.879164313946916,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 242.8430265386787,36.53020892151325 l 16.939582156973458,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 242.8430265386787,36.53020892151325 l -16.939582156973458,18.06888763410502 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 259.78260869565213,54.59909655561827 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 259.78260869565213,54.59909655561827 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 271.07566346696774,74.92659514398642 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 254.1360813099943,74.92659514398642 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 263.1705251270468,54.59909655561827 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 225.90344438170524,54.59909655561827 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 225.90344438170524,54.59909655561827 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 237.19649915302085,74.92659514398642 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 220.2569169960474,74.92659514398642 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 229.29136081309994,54.59909655561827 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 246.23094297007341,36.53020892151325 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 203.31733483907396,38.78881987577638 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 237.76115189158668,18.461321287408232 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 138.38226990400904,9.42687747035572 l 8.469791078486729,18.068887634105018 " /></g><g stroke-width="0.9034443817052511"><path d="M 138.38226990400904,9.42687747035572 l -33.879164313946916,17.504234895539238 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 146.85206098249577,27.495765104460737 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 146.85206098249577,27.495765104460737 l -25.409373235460187,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 155.3218520609825,45.564652738565755 l 16.939582156973458,17.50423489553924 " /></g><g stroke-width="0.9034443817052511"><path d="M 155.3218520609825,45.564652738565755 l -8.469791078486729,18.06888763410502 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 175.08469791078485,65.89215132693391 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 146.85206098249577,63.63354037267077 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 146.85206098249577,63.63354037267077 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 158.1451157538114,83.96103896103892 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 141.20553359683794,83.96103896103892 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 150.23997741389047,63.63354037267077 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 158.7097684923772,45.564652738565755 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 124.26595143986451,47.82326369282889 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 150.23997741389047,27.495765104460737 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 107.32636928289104,29.754376058723867 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 141.77018633540374,9.42687747035572 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 42.39130434782612,9.42687747035572 l 8.469791078486729,18.068887634105018 " /></g><g stroke-width="0.9034443817052511"><path d="M 42.39130434782612,9.42687747035572 l -33.879164313946916,17.504234895539238 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 50.86109542631285,27.495765104460737 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 50.86109542631285,27.495765104460737 l -25.409373235460187,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 59.33088650479958,45.564652738565755 l 8.469791078486729,18.06888763410502 " /></g><g stroke-width="0.9034443817052511"><path d="M 59.33088650479958,45.564652738565755 l -16.939582156973458,17.50423489553924 " /></g><g><g><g stroke-width="0.9034443817052511"><g stroke-width="0.9034443817052511"><path d="M 67.8006775832863,63.63354037267077 l 8.469791078486729,17.504234895539238 " /></g><g stroke-width="0.9034443817052511"><path d="M 67.8006775832863,63.63354037267077 l -8.469791078486729,17.504234895539238 " /></g><g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 79.09373235460195,83.96103896103892 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 62.15415019762848,83.96103896103892 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 71.18859401468099,63.63354037267077 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 45.21456804065503,65.89215132693391 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 62.71880293619427,45.564652738565755 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 28.274985883681573,47.82326369282889 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 54.24901185770754,27.495765104460737 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g><g><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.9034443817052511"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"></g><g fill="rgb(0,0,255)" fill-opacity="1.0"><path d="M 11.335403726708115,29.754376058723867 l -6.268904712733802e-16,-5.646527385657819 h -5.646527385657819 l -6.268904712733802e-16,5.646527385657819 Z" /></g></g></g></g></g></g><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"></g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 45.779220779220815,9.42687747035572 c 0.0,-1.8710945787604518 -1.5168218526342394,-3.3879164313946917 -3.387916431394691 -3.3879164313946917c -1.8710945787604518,-1.145677154876327e-16 -3.3879164313946917,1.5168218526342394 -3.3879164313946917 3.3879164313946903c -2.291354309752654e-16,1.8710945787604518 1.5168218526342392,3.3879164313946917 3.3879164313946903 3.3879164313946917c 1.8710945787604518,3.4370314646289805e-16 3.3879164313946917,-1.516821852634239 3.387916431394692 -3.3879164313946903Z" /></g></g></g><g fill="rgb(255,0,0)" fill-opacity="1.0"></g></g></g></g></g></g></g></g></g></g></g></svg>
+ svg/dyck_path.svg view
@@ -0,0 +1,3 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"><svg stroke="rgb(0,0,0)" version="1.1" xmlns="http://www.w3.org/2000/svg" height="97.7011" viewBox="0 0 500 98" stroke-opacity="1" font-size="1" xmlns:xlink="http://www.w3.org/1999/xlink" width="500.0000"><defs></defs><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 453.7182,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 436.3027,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 418.8871,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 401.4716,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 384.0561,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 366.6405,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 349.2250,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 331.8095,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 314.3939,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 296.9784,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 279.5629,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 262.1473,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 244.7318,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 227.3163,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 209.9007,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 192.4852,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 175.0697,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 157.6541,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 140.2386,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 122.8231,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 105.4075,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 87.9920,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 70.5765,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 53.1609,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 35.7454,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 18.3299,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 0.9143,87.9920 v -87.0777 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 0.9143,0.9143 h 452.8039 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 0.9143,18.3299 h 452.8039 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 0.9143,35.7454 h 452.8039 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 0.9143,53.1609 h 452.8039 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 0.9143,70.5765 h 452.8039 "/></g><defs></defs><g stroke="rgb(128,128,128)" fill="rgb(0,0,0)" stroke-width="0.4353883664228493" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 0.9143,87.9920 h 452.8039 "/></g><defs></defs><g stroke="rgb(255,0,0)" fill="rgb(0,0,0)" stroke-width="0.8707767328456986" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 0.9143,87.9920 l 17.4155,-17.4155 l 17.4155,-17.4155 l 17.4155,17.4155 l 17.4155,-17.4155 l 17.4155,-17.4155 l 17.4155,-17.4155 l 17.4155,17.4155 l 17.4155,-17.4155 l 17.4155,17.4155 l 17.4155,17.4155 l 17.4155,-17.4155 l 17.4155,17.4155 l 17.4155,-17.4155 l 17.4155,-17.4155 l 17.4155,-17.4155 l 17.4155,17.4155 l 17.4155,17.4155 l 17.4155,17.4155 l 17.4155,17.4155 l 17.4155,17.4155 l 17.4155,-17.4155 l 17.4155,17.4155 l 17.4155,-17.4155 l 17.4155,-17.4155 l 17.4155,17.4155 l 17.4155,17.4155 "/></g></svg>
+ svg/ferrers.svg view
@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" width="256.0" height="160.0" font-size="1" viewBox="0 0 256 160" stroke="rgb(0,0,0)" stroke-opacity="1"><g><g fill="rgb(0,0,0)" fill-opacity="0.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" stroke-width="0.8095430810031051" stroke-linecap="butt" stroke-linejoin="miter" font-size="1.0em" stroke-miterlimit="10.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" stroke-width="1.4545454545454546"><g><path d="M 232.72727272727272,0.0 v 29.09090909090909 " /></g><g><path d="M 203.63636363636363,0.0 v 29.09090909090909 " /></g><g><path d="M 174.54545454545453,0.0 v 58.18181818181818 " /></g><g><path d="M 145.45454545454544,0.0 v 58.18181818181818 " /></g><g><path d="M 116.36363636363636,0.0 v 58.18181818181818 " /></g><g><path d="M 87.27272727272727,0.0 v 116.36363636363636 " /></g><g><path d="M 58.18181818181818,0.0 v 116.36363636363636 " /></g><g><path d="M 29.09090909090909,0.0 v 145.45454545454544 " /></g><g><path d="M 0.0,0.0 v 145.45454545454544 " /></g><g><path d="M 0.0,145.45454545454544 h 29.09090909090909 " /></g><g><path d="M 0.0,116.36363636363636 h 87.27272727272727 " /></g><g><path d="M 0.0,87.27272727272727 h 87.27272727272727 " /></g><g><path d="M 0.0,58.18181818181818 h 174.54545454545453 " /></g><g><path d="M 0.0,29.09090909090909 h 232.72727272727272 " /></g><g><path d="M 0.0,0.0 h 232.72727272727272 " /></g></g><g stroke="rgb(255,0,0)" stroke-opacity="1.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 23.272727272727273,130.9090909090909 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 81.45454545454544,101.81818181818181 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 52.36363636363636,101.81818181818181 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 23.272727272727273,101.81818181818181 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 81.45454545454544,72.72727272727272 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 52.36363636363636,72.72727272727272 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 23.272727272727273,72.72727272727272 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 168.72727272727272,43.63636363636363 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 139.63636363636363,43.63636363636363 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 110.54545454545453,43.63636363636363 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 81.45454545454544,43.63636363636363 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 52.36363636363636,43.63636363636363 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 23.272727272727273,43.63636363636363 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 226.9090909090909,14.545454545454545 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 197.8181818181818,14.545454545454545 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 168.72727272727272,14.545454545454545 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 139.63636363636363,14.545454545454545 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 110.54545454545453,14.545454545454545 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 81.45454545454544,14.545454545454545 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 52.36363636363636,14.545454545454545 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,0,0)" fill-opacity="1.0" stroke-width="0.7272727272727273"><g fill="rgb(255,0,0)" fill-opacity="1.0"><g fill="rgb(255,0,0)" fill-opacity="1.0"><path d="M 23.272727272727273,14.545454545454545 c 0.0,-4.819939634886924 -3.907333092385801,-8.727272727272727 -8.727272727272725 -8.727272727272727c -4.819939634886924,-2.951264350961418e-16 -8.727272727272727,3.9073330923858007 -8.727272727272727 8.727272727272723c -5.902528701922836e-16,4.819939634886924 3.9073330923858003,8.727272727272727 8.727272727272723 8.727272727272727c 4.819939634886924,8.853793052884255e-16 8.727272727272727,-3.9073330923858 8.72727272727273 -8.727272727272723Z" /></g></g></g></g></g></g></g></svg>
+ svg/noncrossing.svg view
@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" width="256.0" height="252.11078477112528" font-size="1" viewBox="0 0 256 252" stroke="rgb(0,0,0)" stroke-opacity="1"><g><g fill="rgb(0,0,0)" fill-opacity="0.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" stroke-width="1.0161918000173635" stroke-linecap="butt" stroke-linejoin="miter" font-size="1.0em" stroke-miterlimit="10.0"><g fill="rgb(0,0,255)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><text transform="matrix(24.788545388692057,0.0,0.0,24.788545388692057,58.9536640353175,45.86642929392933)" dominant-baseline="middle" text-anchor="middle" stroke="none">9</text></g></g><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><text transform="matrix(24.788545388692057,0.0,0.0,24.788545388692057,22.214876033057877,109.49987672234495)" dominant-baseline="middle" text-anchor="middle" stroke="none">8</text></g></g></g><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><text transform="matrix(24.788545388692057,0.0,0.0,24.788545388692057,34.97412320562606,181.86116324413933)" dominant-baseline="middle" text-anchor="middle" stroke="none">7</text></g></g></g><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><text transform="matrix(24.788545388692057,0.0,0.0,24.788545388692057,91.26121199774039,229.09163868964527)" dominant-baseline="middle" text-anchor="middle" stroke="none">6</text></g></g></g><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><text transform="matrix(24.788545388692057,0.0,0.0,24.788545388692057,164.7387880022597,229.09163868964527)" dominant-baseline="middle" text-anchor="middle" stroke="none">5</text></g></g></g><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><text transform="matrix(24.788545388692057,0.0,0.0,24.788545388692057,221.02587679437403,181.86116324413928)" dominant-baseline="middle" text-anchor="middle" stroke="none">4</text></g></g></g><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><text transform="matrix(24.788545388692057,0.0,0.0,24.788545388692057,233.78512396694217,109.49987672234491)" dominant-baseline="middle" text-anchor="middle" stroke="none">3</text></g></g></g><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><text transform="matrix(24.788545388692057,0.0,0.0,24.788545388692057,197.04633596468253,45.8664292939293)" dominant-baseline="middle" text-anchor="middle" stroke="none">2</text></g></g></g><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,255)" fill-opacity="1.0"><text transform="matrix(24.788545388692057,0.0,0.0,24.788545388692057,128.00000000000003,20.735618217640905)" dominant-baseline="middle" text-anchor="middle" stroke="none">1</text></g></g></g></g></g><g stroke="rgb(255,0,0)" stroke-opacity="1.0" stroke-width="6.6102787703178825"><path d="M 210.62848462897355,119.47665734926427 c 0.0,-45.63445196221021 -36.99403266676331,-82.62848462897352 -82.62848462897351 -82.62848462897352c -45.63445196221021,-2.7942119913062335e-15 -82.62848462897352,36.9940326667633 -82.62848462897352 82.6284846289735c -5.588423982612467e-15,45.63445196221021 36.9940326667633,82.62848462897352 82.62848462897348 82.62848462897352c 45.63445196221021,8.3826359739187e-15 82.62848462897352,-36.994032666763296 82.62848462897357 -82.6284846289735Z" /></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(255,165,0)" fill-opacity="1.0" stroke-width="1.6525696925794706"><g fill="rgb(255,165,0)" fill-opacity="1.0"><g fill="rgb(255,165,0)" fill-opacity="1.0"><g fill="rgb(255,165,0)" fill-opacity="1.0"><g fill="rgb(255,165,0)" fill-opacity="1.0"><g><g fill="rgb(255,165,0)" fill-opacity="1.0"><g fill="rgb(255,165,0)" fill-opacity="1.0"><path d="M 67.73159719683085,52.04814162444856 l -28.260606155584327,48.94880571416585 c -2.281722598110509,3.952059468705467 -0.9276470236638324,9.005538309828474 3.0244124450416336 11.287260907938983c 3.952059468705467,2.2817225981105094 9.005538309828474,0.9276470236638328 11.287260907938983 -3.0244124450416328l 28.260606155584327,-48.94880571416585 c 2.281722598110509,-3.952059468705467 0.927647023663832,-9.005538309828474 -3.0244124450416345 -11.287260907938983c -3.952059468705467,-2.2817225981105094 -9.005538309828474,-0.9276470236638324 -11.287260907938986 3.0244124450416336Z" /></g></g></g><g><g fill="rgb(255,165,0)" fill-opacity="1.0"><g fill="rgb(255,165,0)" fill-opacity="1.0"><path d="M 51.13037662242908,167.12060881308778 l 43.29776060931872,36.331134958081485 c 3.495801834043109,2.933326029614429 8.707639732390161,2.4773492973742828 11.64096576200459 -1.0184525366688244c 0.9323202645137305,-1.1110960246826247 1.5557430576990043,-2.448030519071843 1.8076080788896125 -3.8764280347477618l 28.260606155584334,-160.2738619015418 c 0.7924339422066867,-4.494116209684779 -2.20837244062142,-8.779711863939754 -6.702488650306198 -9.57214580614644c -3.4209150223784612,-0.6031996171562244 -6.853821179049025,0.9975908134267045 -8.59066525441043 4.005892996777644l -71.55836676490306,123.94272694346033 c -2.004953927164585,3.472682068683816 -1.2271875654055806,7.883614296037856 1.84458006382242 10.46113338078537Z" /></g></g></g></g><g><g fill="rgb(255,165,0)" fill-opacity="1.0"><g fill="rgb(255,165,0)" fill-opacity="1.0"><path d="M 161.57186276825226,203.45174377116925 l 43.29776060931873,-36.33113495808153 c 2.2613872731848765,-1.8975292268784263 3.3386754938661554,-4.8573542874446884 2.8260606155584305 -7.764537727256825l -18.44580063822424,-104.61133380785381 c -0.7924339422066877,-4.494116209684778 -5.078029596461661,-7.494922592512885 -9.57214580614644 -6.702488650306197c -3.4209150223784626,0.603199617156225 -6.099289033149974,3.281573627927738 -6.702488650306198 6.7024886503062l -24.851959971094487,140.94246876593533 c -0.7924339422066862,4.494116209684779 2.208372440621421,8.779711863939752 6.702488650306198 9.57214580614644c 2.4053330636402883,0.4241251167099334 4.875068211267832,-0.23763842161562668 6.746085190588008 -1.807608078889615Z" /></g></g></g></g><g><g fill="rgb(255,165,0)" fill-opacity="1.0"><g fill="rgb(255,165,0)" fill-opacity="1.0"><path d="M 217.63602074516058,105.12837157006305 c 0.0,-4.5634451962210205 -3.699403266676331,-8.262848462897352 -8.26284846289735 -8.262848462897352c -4.5634451962210205,-2.794211991306233e-16 -8.262848462897352,3.6994032666763306 -8.262848462897352 8.262848462897349c -5.588423982612466e-16,4.5634451962210205 3.69940326667633,8.262848462897352 8.262848462897349 8.262848462897352c 4.5634451962210205,8.3826359739187e-16 8.262848462897352,-3.6994032666763297 8.262848462897356 -8.262848462897349Z" /></g></g></g></g></g></g><g fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><path d="M 79.01885810476983,56.17956585589723 c 0.0,-2.2817225981105103 -1.8497016333381655,-4.131424231448676 -4.131424231448675 -4.131424231448676c -2.2817225981105103,-1.3971059956531165e-16 -4.131424231448676,1.8497016333381653 -4.131424231448676 4.131424231448674c -2.794211991306233e-16,2.2817225981105103 1.849701633338165,4.131424231448676 4.131424231448674 4.131424231448676c 2.2817225981105103,4.19131798695935e-16 4.131424231448676,-1.8497016333381648 4.131424231448678 -4.131424231448674Z" /></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><path d="M 50.75825194918551,105.12837157006308 c 0.0,-2.2817225981105103 -1.8497016333381655,-4.131424231448676 -4.131424231448675 -4.131424231448676c -2.2817225981105103,-1.3971059956531165e-16 -4.131424231448676,1.8497016333381653 -4.131424231448676 4.131424231448674c -2.794211991306233e-16,2.2817225981105103 1.849701633338165,4.131424231448676 4.131424231448674 4.131424231448676c 2.2817225981105103,4.19131798695935e-16 4.131424231448676,-1.8497016333381648 4.131424231448678 -4.131424231448674Z" /></g></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><path d="M 60.57305746654565,160.79089966375108 c 0.0,-2.2817225981105103 -1.8497016333381655,-4.131424231448676 -4.131424231448675 -4.131424231448676c -2.2817225981105103,-1.3971059956531165e-16 -4.131424231448676,1.8497016333381653 -4.131424231448676 4.131424231448674c -2.794211991306233e-16,2.2817225981105103 1.849701633338165,4.131424231448676 4.131424231448674 4.131424231448676c 2.2817225981105103,4.19131798695935e-16 4.131424231448676,-1.8497016333381648 4.131424231448678 -4.131424231448674Z" /></g></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><path d="M 103.87081807586438,197.12203462183254 c 0.0,-2.2817225981105103 -1.8497016333381655,-4.131424231448676 -4.131424231448675 -4.131424231448676c -2.2817225981105103,-1.3971059956531165e-16 -4.131424231448676,1.8497016333381653 -4.131424231448676 4.131424231448674c -2.794211991306233e-16,2.2817225981105103 1.849701633338165,4.131424231448676 4.131424231448674 4.131424231448676c 2.2817225981105103,4.19131798695935e-16 4.131424231448676,-1.8497016333381648 4.131424231448678 -4.131424231448674Z" /></g></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><path d="M 160.39203038703306,197.12203462183254 c 0.0,-2.2817225981105103 -1.8497016333381655,-4.131424231448676 -4.131424231448675 -4.131424231448676c -2.2817225981105103,-1.3971059956531165e-16 -4.131424231448676,1.8497016333381653 -4.131424231448676 4.131424231448674c -2.794211991306233e-16,2.2817225981105103 1.849701633338165,4.131424231448676 4.131424231448674 4.131424231448676c 2.2817225981105103,4.19131798695935e-16 4.131424231448676,-1.8497016333381648 4.131424231448678 -4.131424231448674Z" /></g></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><path d="M 203.68979099635177,160.79089966375102 c 0.0,-2.2817225981105103 -1.8497016333381655,-4.131424231448676 -4.131424231448675 -4.131424231448676c -2.2817225981105103,-1.3971059956531165e-16 -4.131424231448676,1.8497016333381653 -4.131424231448676 4.131424231448674c -2.794211991306233e-16,2.2817225981105103 1.849701633338165,4.131424231448676 4.131424231448674 4.131424231448676c 2.2817225981105103,4.19131798695935e-16 4.131424231448676,-1.8497016333381648 4.131424231448678 -4.131424231448674Z" /></g></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><path d="M 213.5045965137119,105.12837157006305 c 0.0,-2.2817225981105103 -1.8497016333381655,-4.131424231448676 -4.131424231448675 -4.131424231448676c -2.2817225981105103,-1.3971059956531165e-16 -4.131424231448676,1.8497016333381653 -4.131424231448676 4.131424231448674c -2.794211991306233e-16,2.2817225981105103 1.849701633338165,4.131424231448676 4.131424231448674 4.131424231448676c 2.2817225981105103,4.19131798695935e-16 4.131424231448676,-1.8497016333381648 4.131424231448678 -4.131424231448674Z" /></g></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><path d="M 185.24399035812755,56.179565855897216 c 0.0,-2.2817225981105103 -1.8497016333381655,-4.131424231448676 -4.131424231448675 -4.131424231448676c -2.2817225981105103,-1.3971059956531165e-16 -4.131424231448676,1.8497016333381653 -4.131424231448676 4.131424231448674c -2.794211991306233e-16,2.2817225981105103 1.849701633338165,4.131424231448676 4.131424231448674 4.131424231448676c 2.2817225981105103,4.19131798695935e-16 4.131424231448676,-1.8497016333381648 4.131424231448678 -4.131424231448674Z" /></g></g></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><path d="M 132.1314242314487,36.84817272029075 c 0.0,-2.2817225981105103 -1.8497016333381655,-4.131424231448676 -4.131424231448675 -4.131424231448676c -2.2817225981105103,-1.3971059956531165e-16 -4.131424231448676,1.8497016333381653 -4.131424231448676 4.131424231448674c -2.794211991306233e-16,2.2817225981105103 1.849701633338165,4.131424231448676 4.131424231448674 4.131424231448676c 2.2817225981105103,4.19131798695935e-16 4.131424231448676,-1.8497016333381648 4.131424231448678 -4.131424231448674Z" /></g></g></g></g></g></g></g></g></g></svg>
+ svg/plane_partition.svg view
@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" width="320.0" height="285.52595130832407" font-size="1" viewBox="0 0 320 286" stroke="rgb(0,0,0)" stroke-opacity="1"><g><g fill="rgb(0,0,0)" fill-opacity="0.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" stroke-width="1.209087619115596" stroke-linecap="butt" stroke-linejoin="miter" font-size="1.0em" stroke-miterlimit="10.0"><g fill="rgb(124,252,0)" fill-opacity="1.0" stroke-width="1.5268767449642997"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 174.54545454545453,15.268767449643008 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 174.54545454545453,76.343837248215 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 148.099173553719,61.075069798572 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 200.99173553719007,61.075069798572 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g></g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 121.65289256198346,106.881372147501 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 253.88429752066116,122.15013959714398 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 227.4380165289256,106.881372147501 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g></g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 95.20661157024792,152.68767449643 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 148.099173553719,152.68767449643 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 200.99173553719007,152.68767449642996 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g></g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 42.31404958677686,213.76274429500197 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 68.7603305785124,198.493976845359 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 121.65289256198346,198.493976845359 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 227.4380165289256,198.49397684535896 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g><g><g fill="rgb(124,252,0)" fill-opacity="1.0"><g fill="rgb(124,252,0)" fill-opacity="1.0"><path d="M 280.3305785123967,198.49397684535896 l -26.446280991735534,15.268767449642999 l 26.446280991735538,15.268767449642993 l 26.446280991735534,-15.268767449642999 Z" /></g></g></g></g></g></g></g><g fill="rgb(205,92,92)" fill-opacity="1.0" stroke-width="1.5268767449642997"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 200.99173553719007,61.075069798572 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 200.99173553719007,122.15013959714398 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 227.4380165289256,106.881372147501 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g></g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 148.099173553719,152.68767449643 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 200.99173553719007,152.68767449642996 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 280.3305785123967,167.95644194607297 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g></g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 121.65289256198346,198.493976845359 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 174.54545454545453,198.49397684535896 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 227.4380165289256,198.49397684535896 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 280.3305785123967,198.49397684535896 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g></g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 68.76033057851241,259.56904664393096 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 95.20661157024793,244.30027919428795 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 148.099173553719,244.30027919428795 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 174.54545454545453,229.03151174464494 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 253.88429752066116,244.30027919428795 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(205,92,92)" fill-opacity="1.0"><g fill="rgb(205,92,92)" fill-opacity="1.0"><path d="M 306.77685950413223,244.30027919428795 v -30.53753489928599 l -26.446280991735534,15.268767449642999 v 30.53753489928599 Z" /></g></g></g></g></g></g></g><g fill="rgb(95,158,160)" fill-opacity="1.0" stroke-width="1.5268767449642997"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 148.099173553719,61.075069798572 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 148.099173553719,122.15013959714399 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 121.65289256198346,106.881372147501 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g></g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 227.4380165289256,167.95644194607297 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 200.99173553719007,152.68767449642996 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 148.099173553719,152.68767449643 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 95.20661157024792,152.68767449643 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g></g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 227.4380165289256,198.49397684535896 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 174.54545454545453,198.49397684535896 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 121.65289256198346,198.493976845359 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 68.7603305785124,198.493976845359 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g></g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 253.88429752066116,244.30027919428795 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 200.99173553719007,244.30027919428795 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 174.54545454545453,229.03151174464494 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 95.20661157024793,244.30027919428795 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g><g><g fill="rgb(95,158,160)" fill-opacity="1.0"><g fill="rgb(95,158,160)" fill-opacity="1.0"><path d="M 15.867768595041298,259.56904664393096 v -30.53753489928599 l 26.446280991735538,15.268767449642993 v 30.53753489928599 Z" /></g></g></g></g></g></g></g></g></g></g></svg>
+ svg/skew3.svg view
@@ -0,0 +1,3 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"><svg stroke="rgb(0,0,0)" version="1.1" xmlns="http://www.w3.org/2000/svg" height="171.6044" viewBox="0 0 256 172" stroke-opacity="1" font-size="1" xmlns:xlink="http://www.w3.org/1999/xlink" width="256.0000"><defs></defs><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 231.5125,1.3427 v 25.5744 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 205.9381,1.3427 v 25.5744 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 180.3636,1.3427 v 51.1489 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 154.7892,1.3427 v 51.1489 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 129.2148,1.3427 v 51.1489 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 103.6404,26.9171 v 25.5744 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 78.0659,26.9171 v 51.1489 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 52.4915,52.4915 v 76.7233 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 26.9171,78.0659 v 76.7233 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.3427,103.6404 v 51.1489 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.3427,154.7892 h 25.5744 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.3427,129.2148 h 51.1489 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.3427,103.6404 h 51.1489 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 26.9171,78.0659 h 51.1489 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 52.4915,52.4915 h 127.8721 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 78.0659,26.9171 h 153.4466 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.2787212787212787" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 129.2148,1.3427 h 102.2977 "/></g></svg>
+ svg/skew_tableau.svg view
@@ -0,0 +1,3 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"><svg stroke="rgb(0,0,0)" version="1.1" xmlns="http://www.w3.org/2000/svg" height="214.5055" viewBox="0 0 320 215" stroke-opacity="1" font-size="1" xmlns:xlink="http://www.w3.org/1999/xlink" width="320.0000"><defs></defs><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 161.5185,1.6783 v 31.9680 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 129.5504,1.6783 v 31.9680 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 97.5824,1.6783 v 63.9361 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 65.6144,1.6783 v 95.9041 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 33.6464,1.6783 v 127.8721 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,1.6783 v 127.8721 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,129.5504 h 31.9680 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,97.5824 h 63.9361 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,65.6144 h 95.9041 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,33.6464 h 159.8402 "/></g><defs></defs><g stroke="rgb(211,211,211)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,1.6783 h 159.8402 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 289.3906,1.6783 v 31.9680 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 257.4226,1.6783 v 31.9680 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 225.4545,1.6783 v 63.9361 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 193.4865,1.6783 v 63.9361 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 161.5185,1.6783 v 63.9361 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 129.5504,33.6464 v 31.9680 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 97.5824,33.6464 v 63.9361 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 65.6144,65.6144 v 95.9041 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 33.6464,97.5824 v 95.9041 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,129.5504 v 63.9361 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,193.4865 h 31.9680 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,161.5185 h 63.9361 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 1.6783,129.5504 h 63.9361 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 33.6464,97.5824 h 63.9361 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 65.6144,65.6144 h 159.8402 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 97.5824,33.6464 h 191.8082 "/></g><defs></defs><g stroke="rgb(0,0,0)" fill="rgb(0,0,0)" stroke-width="1.5984015984015982" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0"><path d="M 161.5185,1.6783 h 127.8721 "/></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,17.6623,186.4535)" dominant-baseline="middle">7</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,49.6304,154.4855)" dominant-baseline="middle">5</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,17.6623,154.4855)" dominant-baseline="middle">1</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,49.6304,122.5175)" dominant-baseline="middle">2</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,81.5984,90.5495)" dominant-baseline="middle">1</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,209.4705,58.5814)" dominant-baseline="middle">2</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,177.5025,58.5814)" dominant-baseline="middle">2</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,145.5345,58.5814)" dominant-baseline="middle">1</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,113.5664,58.5814)" dominant-baseline="middle">1</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,273.4066,26.6134)" dominant-baseline="middle">1</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,241.4386,26.6134)" dominant-baseline="middle">1</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,209.4705,26.6134)" dominant-baseline="middle">1</text></g><defs></defs><g stroke="rgb(0,0,255)" fill="rgb(0,0,255)" stroke-width="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="1.0" font-size="27.172827172827166px"><text stroke="none" text-anchor="middle" transform="matrix(1.0000,0.0000,0.0000,1.0000,177.5025,26.6134)" dominant-baseline="middle">1</text></g></svg>
+ svg/src/gen_figures.hs view
@@ -0,0 +1,81 @@++-- | A script to generate the SVG figures in the documentation.+-- We use the @combinat-diagrams@ library for that.++module Main where++--------------------------------------------------------------------------------++import Math.Combinat.Partitions.Integer+import Math.Combinat.Partitions.Plane+import Math.Combinat.Partitions.NonCrossing+import Math.Combinat.Partitions.Skew+import Math.Combinat.Tableaux+import Math.Combinat.Tableaux.Skew+import Math.Combinat.LatticePaths+import Math.Combinat.Trees.Binary++import Math.Combinat.Diagrams.Partitions.Integer+import Math.Combinat.Diagrams.Partitions.Plane+import Math.Combinat.Diagrams.Partitions.NonCrossing+import Math.Combinat.Diagrams.Partitions.Skew+import Math.Combinat.Diagrams.Tableaux+import Math.Combinat.Diagrams.Tableaux.Skew+import Math.Combinat.Diagrams.LatticePaths+import Math.Combinat.Diagrams.Trees.Binary++import Diagrams.Core+import Diagrams.Prelude+import Diagrams.Backend.SVG++--------------------------------------------------------------------------------++export fpath size what = renderSVG fpath size $ pad 1.10 what++vcatSep = vcat' (with & sep .~ 1) +hcatSep = hcat' (with & sep .~ 1) ++boxSep m xs = pad 1.05 $ vcatSep $ map hcatSep $ yys where+  yys = go xs where+    go [] = []+    go zs = take m zs : go (drop m zs) ++padding fac diag = pad fac $ centerXY diag+margin  siz diag = hcat [ strutX siz , vcat [ strutY siz , centerXY diag , strutY siz ] , strutX siz ]++--------------------------------------------------------------------------------++main = do ++  export "plane_partition.svg" (mkWidth 320) $ margin 0.05 $ drawPlanePartition3D $+    PlanePart [[5,4,3,3,1],[4,4,2,1],[3,2],[2,1],[1],[1]] ++  export "noncrossing.svg" (mkWidth 256) $ padding 1.10 $ drawNonCrossingCircleDiagram' orange True $+    NonCrossing [[3],[5,4,2],[7,6,1],[9,8]]++  export "young_tableau.svg" (mkWidth 256) $ margin 0.05 $ drawTableau $ +    [ [ 1 , 3 , 4 , 6 , 7 ]+    , [ 2 , 5 , 8 ,10 ]+    , [ 9 ]+    ]++  let u = UpStep+      d = DownStep+      path = [ u,u,d,u,u,u,d,u,d,d,u,d,u,u,u,d,d,d,d,d,u,d,u,u,d,d ]     +  export "dyck_path.svg" (mkWidth 500) $ margin 0.05 $ drawLatticePath $ path+  -- print (pathHeight path, pathNumberOfZeroTouches path, pathNumberOfPeaks path)++  export "ferrers.svg" (mkWidth 256) $ margin 0.05 $ drawFerrersDiagram' EnglishNotation red True $+    Partition [8,6,3,3,1]++  export "bintrees.svg" (mkWidth 750) $ boxSep 7 $ map drawBinTree_ (binaryTrees 4)++  let skew = mkSkewPartition (Partition [9,7,3,2,2,1] , Partition [5,3,2,1])+  -- export "skew.svg"  (mkWidth 256) $ margin 0.05 $ drawSkewFerrersDiagram  skew+  -- export "skew2.svg" (mkWidth 256) $ margin 0.05 $ drawSkewFerrersDiagram' EnglishNotation green True (True,True) skew+  export "skew3.svg" (mkWidth 256) $ margin 0.05 $ drawSkewPartitionBoxes  EnglishNotation skew++  let skewtableau  = (semiStandardSkewTableaux 7 skew) !! 123+  export "skew_tableau.svg" (mkWidth 320) $ margin 0.05 $ drawSkewTableau' EnglishNotation blue True skewtableau++--------------------------------------------------------------------------------
+ svg/young_tableau.svg view
@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" version="1.1" width="256.0" height="153.60000000000002" font-size="1" viewBox="0 0 256 154" stroke="rgb(0,0,0)" stroke-opacity="1"><g><g fill="rgb(0,0,0)" fill-opacity="0.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" stroke-width="0.793186989303279" stroke-linecap="butt" stroke-linejoin="miter" font-size="1.0em" stroke-miterlimit="10.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" stroke-width="2.3272727272727276"><g><path d="M 232.72727272727275,0.0 v 46.54545454545455 " /></g><g><path d="M 186.1818181818182,0.0 v 93.0909090909091 " /></g><g><path d="M 139.63636363636363,0.0 v 93.0909090909091 " /></g><g><path d="M 93.0909090909091,0.0 v 93.0909090909091 " /></g><g><path d="M 46.54545454545455,0.0 v 139.63636363636363 " /></g><g><path d="M 0.0,0.0 v 139.63636363636363 " /></g><g><path d="M 0.0,139.63636363636363 h 46.54545454545455 " /></g><g><path d="M 0.0,93.0909090909091 h 186.1818181818182 " /></g><g><path d="M 0.0,46.54545454545455 h 232.72727272727275 " /></g><g><path d="M 0.0,0.0 h 232.72727272727275 " /></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0"><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,23.272727272727273,129.39636363636365)" dominant-baseline="middle" text-anchor="middle" stroke="none">9</text></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,162.9090909090909,82.8509090909091)" dominant-baseline="middle" text-anchor="middle" stroke="none">10</text></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,116.36363636363637,82.8509090909091)" dominant-baseline="middle" text-anchor="middle" stroke="none">8</text></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,69.81818181818181,82.8509090909091)" dominant-baseline="middle" text-anchor="middle" stroke="none">5</text></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,23.272727272727273,82.8509090909091)" dominant-baseline="middle" text-anchor="middle" stroke="none">2</text></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,209.45454545454547,36.305454545454545)" dominant-baseline="middle" text-anchor="middle" stroke="none">7</text></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,162.9090909090909,36.305454545454545)" dominant-baseline="middle" text-anchor="middle" stroke="none">6</text></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,116.36363636363637,36.305454545454545)" dominant-baseline="middle" text-anchor="middle" stroke="none">4</text></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,69.81818181818181,36.305454545454545)" dominant-baseline="middle" text-anchor="middle" stroke="none">3</text></g></g><g stroke="rgb(0,0,0)" stroke-opacity="1.0" fill="rgb(0,0,0)" fill-opacity="1.0" stroke-width="0.0"><g fill="rgb(0,0,0)" fill-opacity="1.0"><text transform="matrix(39.56363636363636,0.0,0.0,39.56363636363636,23.272727272727273,36.305454545454545)" dominant-baseline="middle" text-anchor="middle" stroke="none">1</text></g></g></g></g></g></g></svg>
+ test/TestSuite.hs view
@@ -0,0 +1,54 @@++module Main where++--------------------------------------------------------------------------------++import Test.Framework+import Test.Framework.Providers.QuickCheck2++import Tests.Permutations       ( testgroup_Permutations      )+import Tests.Partitions.Integer ( testgroup_IntegerPartitions )+import Tests.Partitions.Skew    ( testgroup_SkewPartitions    )+import Tests.Partitions.Ribbon  ( testgroup_Ribbon      )+import Tests.Braid              ( testgroup_Braid +                                , testgroup_Braid_NF          )+import Tests.Series             ( testgroup_PowerSeries       )+import Tests.SkewTableaux       ( testgroup_SkewTableaux      )+import Tests.Thompson           ( testgroup_ThompsonF         )+import Tests.LatticePaths       ( testgroup_LatticePaths      )++--------------------------------------------------------------------------------++main :: IO ()+main = defaultMain tests++{- ++----- missing (because tasty, not test-framework): -----++Partitions.Compact+Numbers.Primes+Numbers.Sequences++-}+++tests :: [Test]+tests = +  [ testgroup_Permutations+  , testgroup_PowerSeries  +  , testGroup "Partitions" +      [ testgroup_IntegerPartitions+      , testgroup_SkewPartitions+      , testgroup_Ribbon+      ]+  , testgroup_SkewTableaux+  , testgroup_ThompsonF+  , testgroup_LatticePaths+  , testGroup "Braids" +      [ testgroup_Braid +      , testgroup_Braid_NF +      ]+  ]++--------------------------------------------------------------------------------
+ test/Tests/Braid.hs view
@@ -0,0 +1,278 @@++-- | Tests for braids. ++{-# LANGUAGE +      CPP, BangPatterns, +      ScopedTypeVariables, ExistentialQuantification,+      DataKinds, KindSignatures, Rank2Types,+      TypeOperators, TypeFamilies,+      StandaloneDeriving #-}++module Tests.Braid where++--------------------------------------------------------------------------------++import Math.Combinat.Groups.Braid+import Math.Combinat.Groups.Braid.NF++import Tests.Permutations ()     -- arbitrary instance+import Tests.Common++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.QuickCheck.Gen++import Data.Proxy+import GHC.TypeLits++import Control.Monad++import Data.List ( mapAccumL , foldl' )++import Data.Array.Unboxed+import Data.Array.ST+import Data.Array.IArray+import Data.Array.MArray+import Data.Array.Unsafe+import Data.Array.Base++import Control.Monad.ST++import System.Random++import Math.Combinat.Sign+import Math.Combinat.Helper+import Math.Combinat.TypeLevel+import Math.Combinat.Numbers.Series++import Math.Combinat.Permutations ( Permutation(..) )+import qualified Math.Combinat.Permutations as P++--------------------------------------------------------------------------------+-- * Types and instances++maxBraidWordLen :: Int+maxBraidWordLen = 600++maxStrands :: Int+maxStrands = 18         -- normal forms are very slow for large ones++shrinkBraid :: KnownNat n => Braid n -> [Braid n]+shrinkBraid (Braid gens) = map Braid list where+  len  = length gens+  list = [ take i gens ++ drop (i+1) gens | i<-[0..len-1] ]++-- someRndBraid :: Int -> (forall (n :: Nat). KnownNat n => g -> (Braid n, g)) -> g -> (SomeBraid, g)+-- someRndBraid n f = \g -> let (x,g') = f g in (someBraid n x, g')++-- | equality as /braid words/+(=:=) :: Braid n -> Braid n -> Bool+(=:=) (Braid gens1) (Braid gens2) = (gens1 == gens2)++data UnreducedBraid   = forall n. KnownNat n => Unreduced (Braid n)              +data ReducedBraid     = forall n. KnownNat n => Reduced   (Braid n)              +data PositiveBraid    = forall n. KnownNat n => PositiveB (Braid n)              +data PerturbedBraid   = forall n. KnownNat n => Perturbed (Braid n)   (Braid n)  +data PermutationBraid = forall n. KnownNat n => PermBraid Permutation (Braid n)  +data TwoBraids        = forall n. KnownNat n => TwoBraids (Braid n)   (Braid n)  ++deriving instance Show UnreducedBraid+deriving instance Show ReducedBraid+deriving instance Show PositiveBraid+deriving instance Show PerturbedBraid+deriving instance Show PermutationBraid+deriving instance Show TwoBraids++instance KnownNat n => Random (Braid n) where+  randomR _ = random+  random g0 = (b, g2) where+    n = numberOfStrands b+    (l,g1) = randomR (0,maxBraidWordLen) g0+    (b,g2) = randomBraidWord l g1++instance Random UnreducedBraid where+  randomR _ = random+  random = runRand $ do+    n <- randChoose (2,maxStrands)+    l <- randChoose (0,maxBraidWordLen)+    withSelectedM Unreduced (rand $ randomBraidWord l) n++instance Random PositiveBraid where+  randomR _ = random+  random  = runRand $ do+    n <- randChoose (2,maxStrands)+    l <- randChoose (0,maxBraidWordLen)+    withSelectedM PositiveB (rand $ randomPositiveBraidWord l) n++instance Random PerturbedBraid where+  randomR _ = random+  random  = runRand $ do+    Unreduced b <- rand random+    k <- randChoose (20,1000)+    c <- rand $ randomPerturbBraidWord k b +    return (Perturbed b c)++instance KnownNat n => Arbitrary (Braid n) where+  arbitrary = choose_+  shrink    = shrinkBraid++instance Arbitrary UnreducedBraid where+  arbitrary = choose_+  shrink (Unreduced b) = map Unreduced (shrinkBraid b)++instance Arbitrary PositiveBraid where+  arbitrary = choose_+  shrink (PositiveB b) = map PositiveB (shrinkBraid b)++instance Arbitrary ReducedBraid where+  arbitrary = do+    Unreduced braid <- arbitrary+    return $ Reduced $ freeReduceBraidWord braid++instance Arbitrary PerturbedBraid where+  arbitrary = choose_+  shrink _  = []++instance Arbitrary TwoBraids where+  shrink _  = []+  arbitrary = do+    n <- choose (2::Int, maxStrands)+    let snat = case someNatVal (fromIntegral n :: Integer) of+          Just sn -> sn+          Nothing -> error "TwoBraids/arbitrary: shouldn't happen"+    case snat of +      SomeNat pxy -> do+        (braid1,braid2) <- choosePair_+        return $ TwoBraids (asProxyTypeOf1 braid1 pxy) (asProxyTypeOf1 braid2 pxy)++mkPermBraid :: Permutation -> PermutationBraid+mkPermBraid perm = +  case snat of    +    SomeNat pxy -> PermBraid perm (asProxyTypeOf1 (permutationBraid perm) pxy)+  where+    n = P.permutationSize perm+    Just snat = someNatVal (fromIntegral n :: Integer)++instance Arbitrary PermutationBraid where+  arbitrary = do+    perm <- arbitrary+    return $ mkPermBraid perm+  shrink (PermBraid x b) = [ PermBraid (braidPermutation s) s | s <- shrinkBraid b ]++--------------------------------------------------------------------------------+-- * test groups++testgroup_Braid :: Test+testgroup_Braid = testGroup "Braid"+  +  [ testProperty "linking matrix is invariant of reduction"    prop_link_reduce +  , testProperty "linking matrix is invariant of perturbation" prop_link_perturb+  +  , testProperty "tau^2 = identity"                    prop_tau_square+  , testProperty "tau commutes with braidPermutation"  prop_permTau_1++  , testProperty "braidPermutation . permutationBraid = identity"  prop_permBraid_perm+  , testProperty "permutation braid is indeed a permutation braid" prop_permBraid_valid+  , testProperty "multiplication commutes with braidPermutation" prop_braidPerm_comp++  , testProperty "positive braids have positive links" prop_link_positive+  , testProperty "definition of linking"               prop_linking++  ] ++--------------------------------------------------------------------------------++testgroup_Braid_NF :: Test+testgroup_Braid_NF = testGroup "Braid/NF"+  +  [ testProperty "NF with naive inverse elimination == less naive inverse elimination"  prop_braidnf_naive+  , testProperty "NF with reduction == NF without reduction"                            prop_braidnf_reduce++  , testProperty "NF = NF of representative word of NF"   prop_braidnf_reprs+  , testProperty "NF = NF of perturbed word"              prop_braidnf_perturb++  , testProperty "linking of word == linking of representative of NF"   prop_braidnf_link++  , testProperty "NF of positive word is positive"   prop_braidnf_pos++  , testProperty "Lemma 2.5"   prop_lemma_2_5++  , testProperty "permutationBraid and tau commutes, up to NF"   prop_permTau_2+  ]++--------------------------------------------------------------------------------+-- * braid properties++prop_link_reduce :: UnreducedBraid -> Bool+prop_link_reduce (Unreduced braid) = linkingMatrix braid == linkingMatrix braid' where+  braid' = freeReduceBraidWord braid++prop_link_perturb :: PerturbedBraid -> Bool+prop_link_perturb (Perturbed braid1 braid2) = linkingMatrix braid1 == linkingMatrix braid2 ++prop_tau_square :: ReducedBraid -> Bool+prop_tau_square (Reduced braid) = braidWord (tau (tau braid)) == braidWord braid++prop_permTau_1 :: PermutationBraid -> Bool+prop_permTau_1 (PermBraid perm braid) = tauPerm perm == braidPermutation (tau braid)++prop_permBraid_perm :: PermutationBraid -> Bool+prop_permBraid_perm (PermBraid perm braid) = (braidPermutation braid == perm)++prop_permBraid_valid :: PermutationBraid -> Bool+prop_permBraid_valid (PermBraid perm braid) = isPermutationBraid braid++prop_braidPerm_comp :: TwoBraids -> Bool+prop_braidPerm_comp (TwoBraids b1 b2) = (p == q) where+  p = braidPermutation (compose b1 b2) +  q = braidPermutation b1 `P.multiplyPermutation` braidPermutation b2++prop_link_positive :: PositiveBraid -> Bool+prop_link_positive (PositiveB braid) = all (>=0) $ elems $ linkingMatrix braid++prop_linking :: UnreducedBraid -> Bool+prop_linking (Unreduced braid) = (linkingMatrix braid == matrix) where+  n = numberOfStrands braid+  matrix = array ((1,1),(n,n)) [ ((i,j),strandLinking braid i j) | i<-[1..n], j<-[1..n] ]++--------------------------------------------------------------------------------++prop_braidnf_naive :: UnreducedBraid -> Bool+prop_braidnf_naive (Unreduced braid) = (braidNormalFormNaive' braid == braidNormalForm' braid)++prop_braidnf_reduce :: UnreducedBraid -> Bool+prop_braidnf_reduce (Unreduced braid) = (braidNormalForm' braid == braidNormalForm braid)++prop_braidnf_reprs :: ReducedBraid -> Bool+prop_braidnf_reprs (Reduced braid) = (nf == nf') where+  nf  = braidNormalForm braid +  nf' = braidNormalForm braid'+  braid' = nfReprWord nf++prop_braidnf_perturb :: PerturbedBraid -> Bool+prop_braidnf_perturb (Perturbed braid1 braid2) = (braidNormalForm braid1 == braidNormalForm braid2)++prop_braidnf_link :: UnreducedBraid -> Bool+prop_braidnf_link (Unreduced braid) = (linkingMatrix braid == linkingMatrix braid') where+  nf  = braidNormalForm braid +  braid' = nfReprWord nf++prop_braidnf_pos :: PositiveBraid -> Bool+prop_braidnf_pos (PositiveB braid) = (_nfDeltaExp (braidNormalForm braid) >= 0)+ +prop_lemma_2_5 :: Permutation -> Bool+prop_lemma_2_5 p = and [ check i | i<-[1..n-1] ] where+  n = P.permutationSize p+  w = _permutationBraid p+  s = permWordStartingSet n w+  check i = _isPermutationBraid n (i:w) == (not $ elem i s)++prop_permTau_2 :: PermutationBraid -> Bool+prop_permTau_2 (PermBraid perm braid) = (nf1 == nf2) where+  nf1 = braidNormalForm $ permutationBraid (tauPerm perm)+  nf2 = braidNormalForm $ tau braid++--------------------------------------------------------------------------------++
+ test/Tests/Common.hs view
@@ -0,0 +1,39 @@+
+-- | Helper routines for tests
+
+{-# LANGUAGE Rank2Types #-}
+module Tests.Common where
+
+--------------------------------------------------------------------------------
+
+import Test.QuickCheck
+import Test.QuickCheck.Gen
+
+import System.Random
+
+--------------------------------------------------------------------------------
+
+-- | Generates a random element.
+choose_ :: Random a => Gen a
+choose_ = MkGen (\r _ -> let (x,_) = random r in x)
+
+-- | Generates two random elements 
+choosePair_ :: Random a => Gen (a,a)
+choosePair_ = do
+  x <- choose_
+  y <- choose_
+  return (x,y)
+
+-- | Generates a random element.
+myMkGen :: (forall g. RandomGen g => g -> (a,g)) -> Gen a
+myMkGen fun = MkGen (\r _ -> let (x,_) = fun r in x)
+
+-- | Generates a random element.
+myMkGen' :: (a -> b) -> (forall g. RandomGen g => g -> (a,g)) -> Gen b
+myMkGen' h fun = MkGen (\r _ -> let (x,_) = fun r in h x)
+
+-- | Generates a random element.
+myMkSizedGen :: (forall g. RandomGen g => Int -> g -> (a,g)) -> Gen a
+myMkSizedGen fun = MkGen (\r siz -> let (x,_) = fun siz r in x)
+
+--------------------------------------------------------------------------------
+ test/Tests/LatticePaths.hs view
@@ -0,0 +1,111 @@++-- | Tests for lattice paths +--++{-# LANGUAGE CPP, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleContexts #-}+module Tests.LatticePaths where++--------------------------------------------------------------------------------++import Math.Combinat.LatticePaths++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import System.Random++import Control.Monad++import Data.List  ++import Math.Combinat.Classes+import Math.Combinat.Helper+import Math.Combinat.Sign+import Math.Combinat.Numbers ( factorial , binomial )++--------------------------------------------------------------------------------+-- * instances++-- | Half-length of a Dyck path+newtype Half = Half Int deriving (Eq,Show)++-- | First number is (usually) less or equal than the second+data HalfPair = HalfPair Int Int deriving (Eq,Show)++maxHalfSize :: Int+maxHalfSize = 11     -- number of paths grow exponentially++instance Arbitrary Half where+  arbitrary = liftM Half $ choose (0,maxHalfSize)    ++instance Arbitrary HalfPair where+  arbitrary = do+    n <- choose (0,maxHalfSize)     +    k <- choose (0,n+1)+    return (HalfPair k n)++fi :: Int -> Integer+fi = fromIntegral++--------------------------------------------------------------------------------+-- * test group++testgroup_LatticePaths :: Test+testgroup_LatticePaths = testGroup "Lattice paths"+  +  [ testProperty "dyck paths are in reverse lexicographic order"      prop_revlex+  , testProperty "naive Dyck path algorithm = less naive algorithm"   prop_dyck_naive+  , testProperty "counting Dyck paths"                                prop_count+  , testProperty "counting Lattice paths"                             prop_count_lattice++  , testProperty "bounded Dyck paths, def, v1"                        prop_bounded_1+  , testProperty "bounded Dyck paths, def, v2"                        prop_bounded_2+  , testProperty "bounded Dyck paths w/ high bound = all dyck paths"  prop_not_bounded++  , testProperty "zero-touching Dyck paths"              prop_touching+  , testProperty "Dyck paths w/ k peaks"                 prop_peaking++  ]++--------------------------------------------------------------------------------+-- * test properties         ++prop_revlex :: Bool+prop_revlex = and [ sort (dyckPaths m) == reverse (dyckPaths m) | m <- [0..maxHalfSize] ]++prop_dyck_naive :: Bool+prop_dyck_naive = and [ sort (dyckPathsNaive m) == sort (dyckPaths m) | m <- [0..maxHalfSize] ]++prop_count :: Bool+prop_count = and [ fi (length (dyckPaths m)) == countDyckPaths m | m <- [0..maxHalfSize] ]++prop_count_lattice :: HalfPair -> Bool+prop_count_lattice (HalfPair y x) = fi (length (latticePaths (x,y))) == countLatticePaths (x,y)++prop_bounded_1 :: HalfPair -> Bool+prop_bounded_1 (HalfPair h m) = (one == two) where+  one = sort (boundedDyckPaths h m ) +  two = sort [ p | p <- dyckPaths m  , pathHeight p <= h ]+  +prop_bounded_2 :: Half -> Half -> Bool+prop_bounded_2 (Half h) (Half m) = (one == two) where+  one = sort (boundedDyckPaths h  m ) +  two = sort [ p | p <- dyckPaths m  , pathHeight p <= h  ]++prop_not_bounded :: Bool+prop_not_bounded = and [ sort (boundedDyckPaths m m) == sort (dyckPaths m) | m <- [0..maxHalfSize] ]++prop_touching :: HalfPair -> Bool+prop_touching (HalfPair k m) = (one == two && fi (length one) == cnt) where+  one = sort (touchingDyckPaths k m) +  two = sort [ p | p <- dyckPaths m , pathNumberOfZeroTouches p == k ]+  cnt = countTouchingDyckPaths k m++prop_peaking :: HalfPair -> Bool+prop_peaking (HalfPair k m) = (one == two && fi (length one) == cnt) where+  one = sort (peakingDyckPaths k m) +  two = sort [ p | p <- dyckPaths m , pathNumberOfPeaks p == k ]+  cnt = countPeakingDyckPaths k m++--------------------------------------------------------------------------------+
+ test/Tests/Numbers/Primes.hs view
@@ -0,0 +1,106 @@+++-- | Tests for number theory+--++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DataKinds, KindSignatures #-}+module Tests.Numbers.Primes where++--------------------------------------------------------------------------------++{-+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+-}++import Test.Tasty+import Test.Tasty.HUnit      as U+import Test.Tasty.QuickCheck as Q ++import System.Random++import Data.List+import Data.Ratio++import GHC.TypeLits+import Data.Proxy++import Math.Combinat.Sign+import Math.Combinat.Numbers+import Math.Combinat.Numbers.Primes+import Math.Combinat.Helper++--------------------------------------------------------------------------------++prop_primes_sum_100    =  sum (take    100 primes)  @=?       24133 +prop_primes_sum_1000   =  sum (take   1000 primes)  @=?     3682913+prop_primes_sum_10000  =  sum (take  10000 primes)  @=?   496165411+prop_primes_sum_100000 =  sum (take 100000 primes)  @=? 62260698721++prop_divisorsigma1_sum_1000   =  sum [ divisorSum    n | n <- [1..1000] ]  @=?  823081+prop_divisorsigma1_sum_1000_b =  sum [ divisorSum' 1 n | n <- [1..1000] ]  @=?  823081+prop_divisorsigma2_sum_1000   =  sum [ divisorSum' 2 n | n <- [1..1000] ]  @=?  401382971+prop_divisorsigma3_sum_1000   =  sum [ divisorSum' 3 n | n <- [1..1000] ]  @=?  271161435595++prop_divisors_def n  =  sort (divisors n) == [ d | d<-[1..n] , d `divides` n ]++prop_moebius_inversion n   =  sum [ moebiusMu d | d <- divisors n ] == (if n==1 then 1 else 0)++prop_totient_divisorsum n  =  n == sum [ eulerTotient d | d <- divisors n ]++prop_totient_mobius_inv n  =  eulerTotient n == sum [ moebiusMu d * div n d | d <- divisors n ]++prop_Liouville_squaredivs n =  liouvilleLambda n == rhs where+  rhs = sum [ moebiusMu (div n d2) +            | d <- divisors n , let d2 = d*d , d2 <= n , d2 `divides` n+            ] ++prop_Liouville_sum n = sum [ liouvilleLambda d | d <- divisors n ] == (if isSquare n then 1 else 0) ++--------------------------------------------------------------------------------++prop_product_of_factors n  =  productOfFactors (factorize n) == n+prop_factorize_vs_naive n  =  factorize n == factorizeNaive n++--------------------------------------------------------------------------------++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [{-properties,-} unitTests]++unitTests :: TestTree+unitTests = testGroup "Primes module"+  [ unitTests1+  , unitTests2+  ]++unitTests1 :: TestTree+unitTests1 = testGroup "Elementary number theory unit tests "+  [ testCase "sum first 100 primes"         $ prop_primes_sum_100+  , testCase "sum first 1000 primes"        $ prop_primes_sum_1000+  , testCase "sum first 10000 primes"       $ prop_primes_sum_10000+  , testCase "sum first 100000 primes"      $ prop_primes_sum_100000+  , testCase "divisor set"                  $ allTrue [ prop_divisors_def n | n<-[1..1000] ]+  , testCase "sum 1000 divisor sigma_1"     $ prop_divisorsigma1_sum_1000+  , testCase "sum 1000 divisor sigma_1 /b"  $ prop_divisorsigma1_sum_1000_b+  , testCase "sum 1000 divisor sigma_2"     $ prop_divisorsigma2_sum_1000+  , testCase "sum 1000 divisor sigma_3"     $ prop_divisorsigma3_sum_1000+  , testCase "moebius inversion"            $ allTrue [ prop_moebius_inversion    n | n<-[1..1000] ]+  , testCase "totient divisor sum"          $ allTrue [ prop_totient_divisorsum   n | n<-[1..1000] ]+  , testCase "totient moebius inversion"    $ allTrue [ prop_totient_mobius_inv   n | n<-[1..1000] ]+  , testCase "Liouville square divs sumn"   $ allTrue [ prop_Liouville_squaredivs n | n<-[1..1000] ]+  , testCase "Liouville divisor sum"        $ allTrue [ prop_Liouville_sum        n | n<-[1..1000] ]+  ]++unitTests2 :: TestTree+unitTests2 = testGroup "Integer factorization"+  [ testCase "productOfFactors . factorize = id" $ allTrue [ prop_product_of_factors n | n<-[1..1000] ]+  , testCase "factorize vs. factorizeNaive"      $ allTrue [ prop_factorize_vs_naive n | n<-[1..1000] ]+  ]++allTrue :: [Bool] -> Assertion+allTrue bools = (and bools @=? True)++--------------------------------------------------------------------------------
+ test/Tests/Numbers/Sequences.hs view
@@ -0,0 +1,66 @@+++-- | Tests for integer sequences+--++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DataKinds, KindSignatures #-}+module Tests.Numbers.Sequences where++--------------------------------------------------------------------------------++{-+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+-}++import Test.Tasty+import Test.Tasty.HUnit      as U+import Test.Tasty.QuickCheck as Q ++import System.Random++import Data.List+import Data.Ratio++import GHC.TypeLits+import Data.Proxy++import Math.Combinat.Sign+import Math.Combinat.Numbers.Sequences+import Math.Combinat.Numbers.Primes+import Math.Combinat.Helper++--------------------------------------------------------------------------------++prop_factorial_naive_vs_split n = factorialNaive n == factorialSplit n+prop_factorial_split_vs_swing n = factorialSplit n == factorialSwing n++prop_fac_exponents_vs_naive n  = factorialPrimeExponents n == factorialPrimeExponentsNaive n+prop_factorial_vs_fac_expos n  = productOfFactors (factorialPrimeExponents n) == factorial n++prop_double_factorial_naive_vs_split n = doubleFactorialNaive n == doubleFactorialSplit n++prop_binomial_naive_vs_split n k = binomialNaive n k == binomialSplit n k++--------------------------------------------------------------------------------++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [{-properties,-} unitTests]++unitTests :: TestTree+unitTests = testGroup "Numbers.Sequences module"+  [ testCase "naive vs. split factorial"          $ allTrue [ prop_factorial_naive_vs_split n | n<-[1..1000] ]+  , testCase "split vs. swing factorial"          $ allTrue [ prop_factorial_split_vs_swing n | n<-[1..1000] ]+  , testCase "naive vs. fast factorial expos"     $ allTrue [ prop_fac_exponents_vs_naive   n | n<-[1..1000] ]+  , testCase "factorial vs. fac exponents"        $ allTrue [ prop_factorial_vs_fac_expos   n | n<-[1..1000] ]+  , testCase "naive vs. split double factorial"   $ allTrue [ prop_double_factorial_naive_vs_split n | n<-[1..1000]  ]+  , testCase "naive vs. split binomial"           $ allTrue [ prop_binomial_naive_vs_split n k | n<-[1..100] , k<-[-3..n+3] ]+  ]++allTrue :: [Bool] -> Assertion+allTrue bools = (and bools @=? True)++--------------------------------------------------------------------------------
+ test/Tests/Partitions/Compact.hs view
@@ -0,0 +1,397 @@++module Tests.Partitions.Compact where ++--------------------------------------------------------------------------------++import Data.List hiding ( uncons , singleton )+import Data.Ord++import Test.Tasty+import Test.Tasty.HUnit      as U+import Test.Tasty.QuickCheck as Q ++import qualified Data.Vector.Compact.WordVec as Vec++import Math.Combinat.Partitions.Integer.Compact+-- import qualified Math.Combinat.Partitions.Integer as P+import qualified Math.Combinat.Partitions.Integer.IntList as P ++--------------------------------------------------------------------------------++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [properties, unitTests]++--------------------------------------------------------------------------------++cmp :: Partition -> Partition -> Ordering+cmp (Partition x) (Partition y) = Vec.cmpExtZero x y++--------------------------------------------------------------------------------++unitTests :: TestTree+unitTests = testGroup "Unit tests"+  [ testCase "toList . fromList == id /1" $ allTrue [ xs == toList (fromDescList xs) | xs <- _testPartitions ]+  , testCase "toList . fromList == id /2" $ allTrue [ xs == toList (fromDescList xs) | xs <- _allparts 18    ]+  , testCase "toAscList . fromList == reverse /1" $ allTrue [ reverse xs == toAscList (fromDescList xs) | xs <- _testPartitions ]+  , testCase "toAscList . fromList == reverse /2" $ allTrue [ reverse xs == toAscList (fromDescList xs) | xs <- _allparts 18    ]+  , testCase "fromList . toList == id"    $ allTrue [ p ==  fromDescList (toList p ) | p  <- testPartitions  ]+  , testCase "singleton"               $ allTrue [ toList (singleton n) == [n] | n <- [1..300] ]+  , testCase "singleton 0 is empty"    $ allTrue [ toList (singleton 0) == [] ]+  , testCase "uncons empty"            $ allTrue [ uncons empty == Nothing ]+  , testCase "uncons singleton"        $ allTrue [ uncons (singleton x) == Just (x,empty) | x <- [1..300] ]+  , testCase "cons/snoc 0 empty"       $ allTrue [ (cons 0 empty) == empty , (snoc empty 0) == empty ] +  , testCase "cons empty"              $ allTrue [ toList (cons n empty) == [n] | n <- [1..300] ]+  , testCase "snoc empty"              $ allTrue [ toList (snoc empty n) == [n] | n <- [1..300] ]+  , testCase "width/height of empty"   $ allTrue [ width empty == 0 , height empty == 0 ]+  , testCase "width of all "           $ allTrue [ length   xs == width  p | xs <- _testPartitions , let p = fromDescList xs ]+  , testCase "height of all"           $ allTrue [ safeHead xs == height p | xs <- _testPartitions , let p = fromDescList xs ]+  , testCase "(width,height)"          $ allTrue [ widthHeight p == (width p, height p) | p <- testPartitions ]+  , testCase "tail of all"             $ allTrue [ safeTail xs == toList (partitionTail p) | xs <- _testPartitions , let p = fromDescList xs ]+  , testCase "toList using uncons"     $ allTrue [ xs == toListViaUncons p                      | xs <- _testPartitionsSmall , let p = fromDescList xs ] +  , testCase "fromList using cons"     $ allTrue [ xs == toList (fromListViaCons (DescList xs)) | xs <- _testPartitionsSmall ]+  , testCase "fromList using snoc"     $ allTrue [ xs == toList (fromListViaSnoc (DescList xs)) | xs <- _testPartitionsSmall ]+  , testCase "reflexivity"             $ allTrue [ (fromDescList xs == p) | xs <- _testPartitions , let p = fromDescList xs]+  , testCase "snoc1"                   $ allTrue [ toList (snoc     p 1)  == xs ++ [1]           | xs <- _testPartitions , let p = fromDescList xs]+  , testCase "snocN/2..5"              $ allTrue [ toList (snocN n (p,1)) == xs ++ replicate n 1 | xs <- _testPartitions , let p = fromDescList xs , n <- [2..5] ]+  , testCase "compare/staircase"       $ allTrue [ compare xs1 xs2 == cmp p1 p2 | n1<-[0..100] , n2<-[0..100], let xs1 = _staircase n1 , let xs2 = _staircase n2 , let p1 = staircase n1 , let p2 = staircase n2 ]+  , testCase "compare/slope"           $ allTrue [ compare xs1 xs2 == cmp p1 p2 | n1<-[0..100] , n2<-[0..100], let xs1 = _slope n1 , let xs2 = _slope n2 , let p1 = slope n1 , let p2 = slope n2 ]+  , testCase "compare/steep"           $ allTrue [ compare xs1 xs2 == cmp p1 p2 | n1<-[0..100] , n2<-[0..100], let xs1 = _steep n1 , let xs2 = _steep n2 , let p1 = steep n1 , let p2 = steep n2 ]+  , testCase "compare/small"           $ allTrue [ compare xs1 xs2 == cmp p1 p2 | xs1 <- _allparts 12 , xs2 <- _allparts 12 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "compare/15"              $ allTrue [ compare xs1 xs2 == cmp p1 p2 | xs1 <- _parts    15 , xs2 <- _parts    15 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "compare/16"              $ allTrue [ compare xs1 xs2 == cmp p1 p2 | xs1 <- _parts    16 , xs2 <- _parts    16 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "compare/17"              $ allTrue [ compare xs1 xs2 == cmp p1 p2 | xs1 <- _parts    17 , xs2 <- _parts    17 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "ineq/small"              $ allTrue [ ineqTestPartition p1 p2 | xs1 <- _allparts 13 , xs2 <- _allparts 13 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "consN 15 / staircase"    $ allTrue [ (replicate k 15  ++ xs) == toList (consN k (15,p)) | n<-[0..15] , let xs = _staircase n , let p = fromDescList xs , k <- [1..80] ]+  , testCase "consN 15 / slope"        $ allTrue [ (replicate k 15  ++ xs) == toList (consN k (15,p)) | n<-[0..15] , let xs = _slope n , let p = fromDescList xs , k <- [1..80] ]+  , testCase "consN 15 / steep"        $ allTrue [ (replicate k 15  ++ xs) == toList (consN k (15,p)) | n<-[0..15] , let xs = _steep n , let p = fromDescList xs , k <- [1..40] ]+  , testCase "consN 16 / staircase"    $ allTrue [ (replicate k  16 ++ xs) == toList (consN k (16,p)) | n<-[0..16] , let xs = _staircase n , let p = fromDescList xs , k <- [1..80] ]+  , testCase "consN 16 / slope"        $ allTrue [ (replicate k  16 ++ xs) == toList (consN k (16,p)) | n<-[0..16] , let xs = _slope n , let p = fromDescList xs , k <- [1..80] ]+  , testCase "consN 16 / steep"        $ allTrue [ (replicate k  16 ++ xs) == toList (consN k (16,p)) | n<-[0..16] , let xs = _steep n , let p = fromDescList xs , k <- [1..40] ]+  , testCase "consN 256 / staircase"   $ allTrue [ (replicate k 256 ++ xs) == toList (consN k (256,p)) | n<-[0..40] , let xs = _staircase n , let p = fromDescList xs , k <- [1..40] ]+  , testCase "consN 256 / slope"       $ allTrue [ (replicate k 256 ++ xs) == toList (consN k (256,p)) | n<-[0..40] , let xs = _slope n , let p = fromDescList xs , k <- [1..35] ]+  , testCase "consN 256 / steep"       $ allTrue [ (replicate k 256 ++ xs) == toList (consN k (256,p)) | n<-[0..40] , let xs = _steep n , let p = fromDescList xs , k <- [1..35] ]+  , testCase "diffSequence"            $ allTrue [ diffSequence p == refDiffSeq xs | xs <- _testPartitions , let p = fromDescList xs ]+  , testCase "reverseDiffSequence"     $ allTrue [ reverseDiffSequence p == reverse (refDiffSeq xs) | xs <- _testPartitions , let p = fromDescList xs ]+  , testCase "dual . dual == id"       $ allTrue [ dualPartition (dualPartition p) == p | p <- testPartitions ]+  , testCase "dual == reference impl." $ allTrue [ toList (dualPartition p) == P._dualPartition xs | xs <- _testPartitions , let p = fromDescList xs ]+  , testCase "toExponentialForm"       $ allTrue [ toExponentialForm p == P._toExponentialForm xs | xs <- _testPartitions , let p = fromDescList xs ]+  , testCase "fromExponentialForm"     $ allTrue [ toList (fromExponentialForm ef) == xs | xs <- _testPartitions , let p = fromDescList xs , let ef = P._toExponentialForm xs ]+  , testCase "to / from expo. form"    $ allTrue [ toList (fromExponentialForm $ toExponentialForm p) == xs | xs <- _testPartitions , let p = fromDescList xs ]+  , testCase "isSubPartitionOf/small"  $ allTrue [ P._isSubPartitionOf xs1 xs2 == isSubPartitionOf p1 p2 | xs1 <- _allparts 12 , xs2 <- _allparts 12 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "isSubPartitionOf/15"     $ allTrue [ P._isSubPartitionOf xs1 xs2 == isSubPartitionOf p1 p2 | xs1 <- _parts    15 , xs2 <- _parts    15 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "isSubPartitionOf/16"     $ allTrue [ P._isSubPartitionOf xs1 xs2 == isSubPartitionOf p1 p2 | xs1 <- _parts    16 , xs2 <- _parts    16 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "isSubPartitionOf/17"     $ allTrue [ P._isSubPartitionOf xs1 xs2 == isSubPartitionOf p1 p2 | xs1 <- _parts    17 , xs2 <- _parts    17 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "dominates/small"         $ allTrue [ P._dominates xs1 xs2 == dominates p1 p2 | xs1 <- _allparts 12 , xs2 <- _allparts 12 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "dominates/15"            $ allTrue [ P._dominates xs1 xs2 == dominates p1 p2 | xs1 <- _parts    15 , xs2 <- _parts    15 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "dominates/16"            $ allTrue [ P._dominates xs1 xs2 == dominates p1 p2 | xs1 <- _parts    16 , xs2 <- _parts    16 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+  , testCase "dominates/17"            $ allTrue [ P._dominates xs1 xs2 == dominates p1 p2 | xs1 <- _parts    17 , xs2 <- _parts    17 , let p1 = fromDescList xs1 , let p2 = fromDescList xs2 ]+--  , testCase "pieriRuleSingleBox"      $ allTrue [ pieriRuleSingleBox p =%%= map fromDescList (P._pieriRule xs 1) | xs <- _testPartitions      , let p = fromDescList xs ] +  , testCase "pieriRule"               $ allTrue [ pieriRule p k        =%%= map fromDescList (P._pieriRule xs k) | xs <- every10th _testPartitionsSmall , let p = fromDescList xs , k <- [1..2] ] +  ]++--------------------------------------------------------------------------------++properties :: TestTree+properties = localOption (QuickCheckTests 1000)  -- 200+           $ testGroup "Properties" +  [ prop "toList . fromList == id" $ \(DescList xs) -> (toList (fromDescList xs) == xs)+  , prop "toAscList . fromList == reverse" $ \(DescList xs) -> (toAscList (fromDescList xs) == reverse xs)+  , prop "snoc1/list"              $ \(DescList xs) -> toList (snoc (fromDescList xs) 1) == xs ++ [1]+  , prop "snocN/list"              $ \(DescList xs) (SmallN n) -> toList (snocN n (fromDescList xs,1)) == xs ++ replicate n 1+  , prop "fromList . toList == id" $ \p    -> (fromDescList (toList p ) == p )+  , prop "compare"                 $ \p q  -> cmp p q == compare (toList p) (toList q)+  , prop "uncons"                  $ \p    -> (unconsTest p) == unconsList (toList p)+  , prop "width"                   $ \p    -> width  p == length   (toList p)+  , prop "height"                  $ \p    -> height p == safeHead (toList p)+  , prop "(width,height)"          $ \p    -> let xs = toList p in widthHeight p == (length xs, safeHead xs)+  , prop "snoc1"                   $ \p    -> toList (snoc p 1) == toList p ++ [1]+  , prop "snocN"                   $ \p (SmallN n) -> toList (snocN n (p,1)) == toList p ++ replicate n 1+  , prop "cons/head"               $ \p            -> let a = max 1 (height p) in toList (cons a p) == a : toList p +  , prop "cons/head+1"             $ \p            -> let a = height p + 1     in toList (cons a p) == a : toList p +  , prop "cons/head+k"             $ \p (SmallN k) -> let a = height p + k     in toList (cons a p) == a : toList p +  , prop "consN/head"              $ \p (SmallN n) -> let a = max 1 (height p) in toList (consN n (a,p)) == replicate n a ++ toList p +  , prop "consN/head+1"            $ \p (SmallN n) -> let a = height p + 1     in toList (consN n (a,p)) == replicate n a ++ toList p +  , prop "consN/head+k"            $ \p (SmallN n) (SmallN k) -> let a = height p + k  in toList (consN n (a,p)) == replicate n a ++ toList p +  , prop "tailN"                   $ \p (SmallN n) -> toList (tailN n p) == drop n (toList p)+  , prop "isEmpty of tail length  "  $ \p ->                      isEmpty (tailN (width p    ) p)  +  , prop "isEmpty of tail length-1"  $ \p -> width p == 0 || not (isEmpty (tailN (width p - 1) p))+  , prop "toList using uncons"     $ \p  -> toList p == toListViaUncons p+  , prop "fromList using cons"     $ \dlist@(DescList xs) -> fromDescList xs == fromListViaCons dlist+  , prop "fromList using snoc"     $ \dlist@(DescList xs) -> fromDescList xs == fromListViaSnoc dlist+  , prop "cmp a b vs. cmp b a"     $ \p q -> cmp p q == reverseOrdering (cmp q p)+  , prop "ineq"                    $ \p q -> ineqTestPartition p q+  , prop "diffSequence"            $ \p -> diffSequence p == refDiffSeq (toList p)+  , prop "reverseDiffSequence"     $ \p -> reverseDiffSequence p == reverse (refDiffSeq (toList p))+  , prop "dual . dual == id"       $ \p -> dualPartition (dualPartition p) == p+  , prop "dual = reference impl."  $ \p -> toList (dualPartition p) == P._dualPartition (toList p)+  , prop "fromExpo . toExpo == id" $ \p -> fromExponentialForm (toExponentialForm p) == p+  , prop "isSubPartitionOf"        $ \p q -> isSubPartitionOf p q == P._isSubPartitionOf (toList p) (toList q)+  , prop "dominates"               $ \p q -> dominates p q == P._dominates (toList p) (toList q)+--  , prop "pieriRuleSingleBox"      $ \p -> map toList (pieriRuleSingleBox p) =%%= P._pieriRule (toList p) 1 ++  , localOption (QuickCheckTests 100) +  $ prop "pieriRule /1"            $ \p (PieriK k) -> map toList (pieriRule p k) =%%= P._pieriRule (toList p) k +  , localOption (QuickCheckTests 100) +  $ prop "pieriRule /2"            $ \p (PieriK k) -> (pieriRule p k) =%%= map fromDescList (P._pieriRule (toList p) k) +  ]++ineqTestPartition :: Partition -> Partition -> Bool+ineqTestPartition = ineqTest++--------------------------------------------------------------------------------++ineqTest :: Ord a => a -> a -> Bool+ineqTest a b = case (a<b , a==b , a>b) of+  (True ,False,False) -> True+  (False,True ,False) -> True+  (False,False,True ) -> True+  _                   -> False++every10th :: [a] -> [a]+every10th = everyNth 10++everyNth :: Int -> [a] -> [a]+everyNth k = go where+  go []     = []+  go (x:xs) = x : drop (k-1) xs++infix 4 =%%=+(=%%=) :: Ord a => [a] -> [a] -> Bool+(=%%=) xs ys = (sort xs == sort ys)++allTrue :: [Bool] -> Assertion+allTrue bools = (and bools @=? True)++prop :: Testable a => TestName -> a -> TestTree+prop = Q.testProperty++(<#>) :: (a -> c) -> (b -> d) -> (a,b) -> (c,d)+(<#>) f g (x,y) = (f x, g y)++reverseOrdering :: Ordering -> Ordering+reverseOrdering ord = case ord of+  LT -> GT+  GT -> LT+  EQ -> EQ++--------------------------------------------------------------------------------++newtype SmallN = SmallN Int deriving (Eq,Ord,Show)++instance Arbitrary SmallN where+  arbitrary = SmallN <$> choose (1,80)++newtype PieriK = PieriK Int deriving (Eq,Ord,Show)++instance Arbitrary PieriK where+  arbitrary = PieriK <$> choose (1,3)++newtype DescList = DescList [Int] deriving (Eq,Ord,Show)++instance Arbitrary DescList where+  arbitrary = (DescList . reverse . sort . map getPositive) <$> arbitrary++instance Arbitrary Partition where+  arbitrary = do+    DescList xs <- arbitrary+    return $ fromDescList xs++--------------------------------------------------------------------------------++_allparts n = P._allPartitions n+_parts    n = P._partitions    n ++_staircase n   = [n,n-1..1]+_rectangle h n = replicate n h++_slope  n =         concatMap (\x->[x,x]) [n,n-1..1]+_slope1 n =         concatMap (\x->[x,x]) [n,n-1..1] ++ [1]+_slope2 n = (n+1) : concatMap (\x->[x,x]) [n,n-1..1] +_slope3 n = (n+1) : concatMap (\x->[x,x]) [n,n-1..1] ++ [1]++_steep  n = [n,n-2..1]++--------------------------------------------------------------------------------++allparts = map fromDescList . _allparts+parts    = map fromDescList . _parts++staircase n   = fromDescList $ _staircase n +rectangle h n = fromDescList $ _rectangle h n ++slope n = fromDescList $ _slope n+steep n = fromDescList $ _steep n++--------------------------------------------------------------------------------++testPartitionsSmall = map fromDescList _testPartitionsSmall+testPartitions      = map fromDescList _testPartitions++_testPartitionsSmall = concat+  [ _allparts 25+  , [ _rectangle 1   n | n <- [1..75] ]+  , [ _rectangle 15  n | n <- [1..75] ]+  , [ _rectangle 16  n | n <- [1..75] ]+  , [ _rectangle 255 n | n <- [1..75] ]+  , [ _rectangle 256 n | n <- [1..75] ]+  , [ _staircase n     | n <- [1..75] ]+  , [ _slope  n        | n <- [1..75] ]+  , [ _slope1 n        | n <- [1..75] ]+  , [ _slope2 n        | n <- [1..75] ]+  , [ _slope3 n        | n <- [1..75] ]+  , [ _steep  n        | n <- [1..75] ] +  , [ _staircase n     | n <- [200,255,256,257,258] ]+  ]++_testPartitions = _testPartitionsSmall ++ _testPartRandom++_testPartRandom = concat+  [ [ drop n seq       | seq <- randomSequences , n<-[0..79] ] +  , [ take n seq       | seq <- randomSequences , n<-[0..79] ] +  ]++--------------------------------------------------------------------------------+-- * reference++snocN :: Int -> (Partition,Int) -> Partition+snocN n (p,x) +  | n <= 0    = p+  | otherwise = snocN (n-1) (snoc p x, x)++consN :: Int -> (Int,Partition) -> Partition+consN n (x,p) +  | n <= 0    = p+  | otherwise = consN (n-1) (x, cons x p)++tailN :: Int -> Partition -> Partition+tailN n p +  | n <= 0    = p +  | otherwise = tailN (n-1) (partitionTail p)++unconsTest :: Partition -> Maybe (Int,[Int])+unconsTest xs = case uncons xs of+  Nothing    -> Nothing+  Just (x,p) -> Just (x, toList p)++unconsList :: [Int] -> Maybe (Int,[Int])+unconsList xs = case xs of+  []     -> Nothing+  (x:xs) -> Just (x,xs)++safeHead :: [Int] -> Int+safeHead xs = case xs of+  []     -> 0+  (x:xs) -> x++refDiffSeq :: [Int] -> [Int]+refDiffSeq = go where+  go (x:ys@(y:_)) = (x-y) : go ys +  go [x] = [x]+  go []  = []++--------------------------------------------------------------------------------++toListViaUncons :: Partition -> [Int]+toListViaUncons = go where+  go p = case uncons p of+    Nothing    -> []+    Just (x,p) -> x : go p+  +fromListViaCons :: DescList -> Partition+fromListViaCons (DescList list) = go list where+  go xs = case xs of+    []     -> empty+    (x:xs) -> cons x (go xs)++fromListViaSnoc :: DescList -> Partition+fromListViaSnoc (DescList list) = go (reverse list) where+  go xs = case xs of+    []     -> empty+    (x:xs) -> snoc (go xs) x++--------------------------------------------------------------------------------++{- +-- generated by:+import Data.List ; import Control.Monad ; import System.Random+genseq = (reverse . sort) <$> (replicateM 80 $ randomRIO (1::Int,255))+main = do+  seqs <- replicateM 64 genseq+  writeFile "rnd.txt" $ unlines $ map show seqs+-}++randomSequences =   +  [ [255,255,251,249,245,239,238,235,233,232,224,222,214,214,213,209,202,197,197,194,193,189,181,168,165,164,164,162,156,152,152,152,151,148,147,142,136,132,130,127,124,123,120,119,117,115,112,112,107,105,90,84,81,75,74,69,64,57,56,55,53,49,48,47,44,43,39,38,31,20,19,18,18,17,17,15,14,10,9,7]+  , [252,246,241,240,238,233,232,230,229,228,227,221,219,214,212,212,204,203,201,195,192,192,188,186,186,182,180,179,176,174,170,166,162,162,153,149,147,141,140,140,139,139,135,133,128,127,126,126,125,125,124,124,114,114,113,112,108,102,94,91,82,82,80,73,71,67,57,56,51,41,36,34,24,22,18,9,8,7,1,1]+  , [255,254,250,250,248,247,245,243,239,236,223,217,215,209,208,205,203,200,199,198,196,194,191,187,184,174,174,172,164,161,159,158,157,153,152,150,149,149,144,135,133,128,127,122,119,119,118,115,115,113,111,103,98,91,88,86,86,74,72,72,67,65,65,56,55,52,51,49,48,38,38,37,34,32,20,17,14,13,8,1]+  , [249,224,224,218,210,206,204,196,193,189,188,188,182,177,174,174,173,173,170,163,151,151,150,147,147,145,142,139,138,134,132,129,126,124,123,121,120,113,112,112,112,109,109,108,106,103,98,89,89,85,85,85,82,82,82,79,75,72,70,66,64,63,56,56,47,45,45,42,27,24,22,20,20,19,16,13,4,4,1,1]+  , [255,254,252,247,246,240,238,233,232,227,226,225,223,213,213,212,209,203,200,195,194,193,193,188,188,185,182,180,175,172,171,170,166,161,158,154,150,146,146,144,142,140,133,131,128,125,119,118,117,115,114,110,109,103,96,91,89,88,81,76,74,59,57,46,37,32,31,24,24,23,16,12,12,9,8,6,6,6,5,2]+  , [253,248,241,234,230,228,226,225,224,222,220,219,217,213,212,207,200,196,183,179,179,173,173,165,162,157,154,147,147,142,137,136,135,134,134,132,128,127,118,113,106,105,104,104,102,94,90,89,81,77,73,68,65,63,63,59,56,54,46,45,44,40,32,32,31,28,26,26,25,22,21,21,16,13,12,11,11,10,5,3]+  , [253,253,253,252,252,246,245,243,241,236,235,234,232,227,224,222,219,210,209,205,200,198,198,195,194,194,188,184,177,175,171,170,169,167,163,162,162,155,138,138,131,125,119,114,106,99,97,95,87,85,85,83,79,71,71,69,65,57,56,49,46,40,37,33,31,29,28,24,23,16,16,16,15,13,12,11,8,8,4,2]+  , [254,252,252,248,233,231,230,228,225,224,218,194,190,190,186,184,177,177,176,171,170,166,165,164,151,149,147,143,136,134,134,133,128,124,122,121,115,114,107,106,105,101,100,98,94,92,92,91,86,84,81,80,76,76,74,71,70,67,67,67,65,58,54,54,53,53,52,52,48,46,46,43,41,37,36,24,19,14,12,7]+  , [255,254,253,251,249,248,248,245,242,236,231,224,221,214,212,205,203,198,195,194,194,190,184,183,183,178,175,163,154,154,149,148,147,145,144,136,134,127,120,117,115,113,112,109,107,107,104,102,91,86,86,84,83,81,81,80,78,77,76,74,73,69,58,57,55,46,39,39,39,38,37,33,32,31,29,27,21,21,15,8]+  , [253,252,252,252,247,242,236,227,227,224,218,214,213,211,209,207,203,202,198,196,191,189,183,183,176,170,169,168,166,164,163,159,157,157,151,145,138,133,130,128,123,119,112,111,109,106,105,101,100,99,96,94,91,76,74,69,69,69,66,66,65,64,61,60,59,45,44,43,41,39,30,28,26,24,21,16,11,6,1,1]+  , [254,253,250,248,238,236,235,232,231,228,228,216,213,213,211,210,207,205,201,200,198,187,182,180,180,178,175,171,168,159,157,157,152,150,143,139,138,138,133,124,123,122,120,120,118,117,115,114,112,111,111,105,105,98,92,92,86,83,80,78,76,70,69,66,65,57,55,54,45,41,36,36,34,21,20,19,12,6,5,3]+  , [252,252,250,249,245,239,229,228,223,218,211,210,207,204,202,201,200,197,189,187,185,181,180,177,175,173,170,168,159,158,158,156,152,145,140,140,137,135,134,133,132,111,108,105,100,97,91,90,89,83,79,78,76,68,67,66,61,58,57,56,50,48,48,47,41,37,33,33,27,27,26,14,13,10,9,9,8,8,8,5]+  , [255,255,246,238,236,235,231,227,226,224,217,214,214,207,204,203,200,200,198,196,191,189,189,187,185,181,179,177,173,172,167,164,164,163,159,154,149,149,143,142,140,136,135,135,126,125,120,112,112,101,100,98,96,96,93,92,89,89,80,79,77,76,76,56,50,48,41,41,40,37,32,29,21,19,19,19,17,11,7,4]+  , [248,246,242,237,235,233,233,232,231,229,229,227,222,222,214,213,208,204,203,199,197,194,192,192,192,190,189,184,183,179,175,175,174,173,171,166,162,160,155,155,153,149,146,145,144,137,127,119,103,100,99,99,96,95,93,87,86,86,84,82,80,80,79,74,66,65,63,59,57,49,47,45,39,32,31,29,25,13,9,3]+  , [252,251,246,243,236,232,228,226,225,217,214,212,206,204,202,201,198,195,194,193,189,187,184,181,177,170,170,165,164,161,157,156,156,145,142,138,136,136,129,128,118,117,116,115,106,97,96,96,96,94,88,84,84,83,83,78,76,75,74,71,70,67,67,64,54,51,47,37,34,31,26,19,14,10,9,9,6,5,3,1]+  , [254,253,247,245,244,244,241,240,237,234,234,233,231,222,217,205,202,199,196,195,192,192,190,184,181,180,179,166,166,162,161,160,157,156,155,149,140,137,134,130,130,129,122,122,111,109,101,100,98,96,96,90,84,83,83,81,74,69,68,64,54,51,51,50,41,41,37,36,34,30,23,21,20,20,16,12,9,5,4,2]+  , [247,241,241,240,240,237,236,231,230,222,216,206,202,201,200,187,185,179,174,170,169,168,165,160,158,155,154,153,147,145,140,137,136,133,132,132,116,111,108,100,98,94,92,90,89,87,87,87,87,84,77,74,74,71,71,70,67,65,63,58,57,56,49,48,47,46,43,43,42,38,37,33,26,19,17,17,17,11,6,3]+  , [253,250,250,248,246,244,235,229,228,225,223,222,219,219,218,218,217,217,214,213,212,210,210,208,206,197,194,190,184,181,179,173,171,169,164,162,159,143,133,132,130,114,112,107,107,106,105,100,88,87,86,85,83,79,78,78,78,78,66,64,62,61,61,52,49,35,31,28,25,24,22,21,20,18,18,16,15,8,2,1]+  , [252,243,243,234,232,231,219,219,218,210,208,194,193,191,186,184,181,178,172,171,169,168,162,154,148,148,144,143,131,129,126,125,121,119,115,114,111,106,103,101,99,97,92,88,84,82,79,74,71,66,66,63,58,47,47,47,44,43,42,41,39,38,33,33,32,31,29,29,27,24,24,20,20,19,17,16,15,13,11,9]+  , [255,255,245,240,240,236,236,236,236,234,232,227,225,221,218,214,213,207,206,199,192,190,190,186,181,176,168,167,165,164,162,162,156,155,155,151,150,149,143,143,143,142,139,136,136,132,131,130,125,121,121,120,117,100,95,88,88,88,87,82,81,73,70,67,66,64,57,54,46,44,41,35,30,30,19,15,13,12,9,6]+  , [254,252,249,249,248,247,247,241,239,232,231,228,224,220,214,214,213,206,202,200,198,195,194,192,185,184,183,180,179,176,157,149,144,142,138,138,136,132,130,125,123,123,123,117,117,117,113,112,105,103,97,84,82,79,78,72,71,67,61,57,53,53,52,51,44,41,36,34,30,28,27,27,26,23,22,21,13,5,5,3]+  , [253,250,243,239,235,228,228,225,218,217,217,211,209,209,206,202,199,196,188,185,181,179,178,174,173,172,170,170,168,166,153,153,149,146,146,145,143,139,138,122,118,117,110,109,107,106,98,95,93,88,86,85,83,77,68,66,63,62,62,62,59,55,50,49,48,47,47,47,41,35,34,33,32,26,24,16,15,12,11,9]+  , [254,252,248,245,244,243,238,238,238,232,231,227,225,220,219,218,217,216,214,211,211,209,207,205,204,203,201,200,195,193,186,180,178,174,173,173,170,170,165,157,151,150,148,140,134,123,116,109,105,105,105,96,95,94,91,89,86,81,76,73,71,57,53,50,47,47,47,47,46,45,42,38,34,27,25,19,17,14,7,7]+  , [253,250,246,245,241,241,239,238,235,231,230,230,223,213,205,199,199,198,197,195,193,190,187,184,184,175,174,173,172,170,169,168,167,165,163,154,152,140,140,139,134,131,130,128,126,119,118,112,112,101,95,94,94,91,88,86,86,83,76,75,75,75,70,58,58,57,49,46,42,41,41,34,33,32,31,29,28,17,16,7]+  , [253,253,251,246,246,240,232,228,225,223,218,218,212,211,210,202,197,192,192,192,192,189,186,186,182,180,177,168,163,163,158,155,150,149,141,134,130,130,130,126,118,115,115,110,103,103,103,92,90,85,81,79,75,70,69,69,54,54,51,49,47,44,42,38,35,35,30,27,18,13,11,11,10,8,7,6,4,3,3,3]+  , [254,251,242,239,238,233,230,227,225,225,215,215,212,209,207,205,205,203,195,195,189,187,187,187,186,182,175,172,171,169,165,160,158,157,157,149,148,143,143,142,142,136,132,129,120,119,117,112,111,110,108,107,100,99,93,91,88,88,86,80,80,77,76,73,70,70,69,67,62,60,51,49,29,25,19,18,16,9,8,1]+  , [251,250,250,249,239,238,233,233,227,227,224,222,221,220,220,218,212,203,199,199,195,193,193,189,186,182,176,175,168,163,162,147,145,145,139,138,136,130,128,128,126,124,122,114,109,106,99,98,90,87,87,83,82,76,72,71,68,65,64,63,62,62,59,56,55,46,41,40,35,31,29,29,28,14,13,10,10,8,7,6]+  , [250,245,239,237,235,235,232,231,224,224,222,219,218,215,211,206,191,190,190,188,179,177,173,170,169,167,166,162,162,160,159,158,155,145,142,140,140,135,131,129,121,116,116,108,106,102,101,96,95,91,89,88,84,80,77,75,70,70,68,60,58,55,54,52,49,44,43,42,39,36,33,32,32,29,23,21,18,17,14,11]+  , [254,254,250,247,241,241,239,232,230,223,221,217,214,200,197,196,194,194,188,185,184,183,183,174,172,171,168,164,164,158,148,146,144,141,133,131,126,125,124,124,123,122,120,114,113,111,110,106,104,104,99,99,92,88,84,74,71,70,67,66,66,59,57,56,55,52,51,50,44,41,39,37,32,29,28,27,25,9,6,3]+  , [248,243,241,232,227,226,225,225,220,218,218,218,214,211,206,203,201,198,196,195,190,189,186,175,174,163,155,150,146,142,141,139,137,136,135,135,133,126,123,118,118,113,110,108,107,106,105,102,102,102,101,100,100,99,96,95,95,91,87,84,80,79,74,73,73,72,60,55,54,54,52,49,44,38,20,19,19,18,14,5]+  , [255,253,253,250,249,245,243,242,239,237,233,233,224,224,222,219,218,210,208,204,192,180,176,168,164,160,160,158,156,155,154,151,150,149,149,142,141,139,138,131,129,126,123,123,114,114,110,110,110,103,99,98,92,92,88,88,87,85,81,79,76,72,67,65,63,63,62,59,57,52,51,50,46,44,41,36,23,15,7,1]+  , [251,248,246,243,236,235,230,227,226,224,221,219,218,216,215,214,214,207,204,202,202,196,192,186,181,179,179,178,176,175,174,169,164,152,149,147,144,139,136,135,134,134,129,125,123,114,105,102,99,89,84,84,81,80,78,75,62,62,59,59,58,58,57,56,55,54,45,38,35,30,29,22,22,16,15,13,11,7,6,4]+  , [255,254,253,243,241,230,230,228,228,227,225,223,223,213,213,205,204,203,198,192,192,190,186,180,180,177,177,174,173,161,156,155,134,127,125,123,120,111,108,102,100,100,97,89,86,80,78,76,75,74,74,74,71,71,70,70,66,66,62,60,59,56,49,47,44,42,38,35,30,30,17,17,17,15,13,13,9,9,6,3]+  , [255,251,249,245,239,239,237,235,230,229,225,224,221,219,213,211,209,207,204,201,194,194,190,186,185,185,183,171,168,166,164,160,159,153,148,140,137,136,133,128,125,121,121,121,118,112,112,109,108,108,106,100,95,94,90,88,88,87,85,84,81,70,68,67,67,66,56,48,43,38,36,35,33,32,32,24,22,19,17,5]+  , [252,252,252,249,245,243,240,236,228,227,224,222,222,216,212,209,206,204,201,192,191,190,185,179,173,172,169,169,165,162,158,158,149,148,147,140,133,128,124,122,122,121,116,115,114,108,103,102,101,98,97,93,93,92,88,87,86,86,78,69,64,63,57,52,45,43,37,35,34,31,26,22,21,18,16,13,9,5,3,2]+  , [254,254,251,248,248,247,245,235,223,222,207,207,206,204,197,194,192,188,184,182,180,178,175,175,173,167,167,165,164,163,163,160,157,155,150,144,141,138,135,131,125,124,121,114,109,101,99,96,91,90,88,85,79,76,67,66,65,59,57,57,57,53,47,34,32,27,26,26,24,22,20,18,18,10,6,5,4,3,2,1]+  , [254,253,250,249,241,240,239,238,234,233,230,229,226,226,226,225,222,219,218,212,207,207,202,199,196,194,189,189,188,184,175,170,166,165,161,160,158,157,154,136,132,128,125,124,122,119,118,116,112,108,108,104,94,91,90,86,80,78,76,72,72,69,58,57,56,52,52,45,44,41,34,27,26,24,18,12,11,5,3,3]+  , [251,245,242,240,237,236,234,227,226,225,225,225,224,223,221,219,209,206,206,206,200,200,198,197,195,195,195,194,192,190,189,186,180,172,169,163,161,155,150,150,148,146,145,135,135,128,120,118,116,113,112,108,108,105,103,102,102,94,92,86,82,80,76,72,61,61,54,52,52,49,46,42,38,34,31,30,26,24,16,14]+  , [255,254,246,245,242,241,239,236,234,233,231,229,227,226,219,217,217,216,214,213,212,205,203,197,195,194,192,191,186,182,179,166,160,158,157,156,156,148,146,138,133,131,129,119,113,112,111,108,107,106,105,103,101,97,86,86,78,77,77,74,63,61,59,55,47,45,45,40,39,36,35,33,31,26,24,18,17,15,11,8]+  , [255,245,245,244,240,239,233,232,228,227,225,224,217,211,211,209,206,205,203,201,200,198,197,192,187,174,172,161,161,157,153,152,151,146,146,145,144,142,139,135,131,128,127,123,121,114,113,112,110,97,90,87,85,82,78,78,78,76,75,70,69,69,68,68,66,56,49,45,45,43,43,34,34,33,32,27,26,19,15,7]+  , [252,246,244,234,223,218,218,217,215,209,206,202,201,198,197,196,196,192,190,183,179,178,176,176,172,163,162,162,159,153,150,149,142,141,134,134,133,128,127,117,114,112,110,109,108,105,102,97,92,87,84,79,77,75,74,71,70,66,65,56,56,53,53,50,44,36,36,33,27,22,20,14,10,9,9,8,7,5,4,1]+  , [254,252,251,251,250,248,247,238,235,235,231,227,225,216,212,212,208,193,189,188,186,179,162,160,158,157,156,150,148,148,141,141,140,134,133,133,131,123,118,116,112,109,106,106,106,106,94,91,88,86,84,80,79,72,71,71,61,56,55,53,49,43,40,36,33,33,29,29,29,22,21,18,16,11,11,8,7,4,4,4]+  , [254,250,248,246,238,238,237,237,229,225,225,224,221,220,216,216,214,212,210,209,208,197,193,192,181,181,179,170,168,166,161,159,156,156,148,146,139,127,125,125,124,120,115,113,109,101,96,85,82,81,77,71,71,67,65,59,59,57,51,51,48,47,46,45,45,44,43,43,41,38,36,31,24,24,11,9,8,7,4,3]+  , [252,237,235,230,228,223,221,220,209,206,206,203,200,195,191,189,185,176,174,168,166,166,159,159,159,156,155,151,149,146,146,143,143,138,137,131,129,120,118,117,116,115,111,108,105,104,103,102,98,98,97,96,95,91,85,70,62,60,55,54,54,47,45,38,37,35,26,25,25,21,18,17,14,12,12,11,10,6,4,3]+  , [247,247,247,245,238,234,234,230,229,227,225,224,223,221,219,215,209,207,206,204,202,200,199,199,193,185,184,182,181,174,171,171,166,162,162,158,156,155,153,151,148,145,136,134,132,122,116,115,111,106,104,97,95,94,93,89,82,73,70,63,63,60,56,51,47,47,45,42,40,39,38,33,31,29,24,18,18,18,12,3]+  , [254,252,249,247,241,239,236,230,228,228,228,228,223,222,222,219,212,205,203,202,201,199,196,195,194,194,191,183,177,169,168,167,166,164,159,157,155,153,151,147,145,144,136,132,129,121,118,110,110,108,106,104,102,98,96,96,95,93,84,80,73,65,64,62,55,53,48,46,44,43,43,40,33,30,27,26,20,18,14,9]+  , [253,245,245,245,244,238,236,235,230,230,230,223,221,220,220,217,213,210,203,201,193,182,165,163,162,161,161,155,154,153,152,148,147,140,133,132,128,120,118,116,114,114,113,96,91,89,81,80,79,76,76,68,68,67,65,63,55,51,50,49,46,44,41,40,39,37,32,32,30,29,21,21,20,18,15,13,13,10,7,5]+  , [253,242,239,238,238,237,234,233,229,228,227,225,222,222,221,217,212,208,203,197,197,191,190,190,187,185,184,182,178,175,173,169,164,164,163,158,146,145,144,140,134,131,127,125,113,111,107,106,98,97,97,97,96,95,89,89,83,82,77,71,60,60,59,55,54,51,39,37,35,31,28,22,22,21,19,14,14,8,4,3]+  , [253,245,243,237,237,227,226,224,222,221,218,217,216,214,213,206,201,192,192,191,190,189,188,188,182,179,169,167,159,148,140,139,138,135,132,126,125,124,122,117,116,114,100,96,90,85,82,81,80,79,77,75,72,69,69,64,61,58,53,53,51,50,49,49,47,44,43,39,38,38,37,37,33,26,17,16,11,8,5,2]+  , [254,252,248,245,244,242,238,235,235,233,233,228,227,219,208,205,202,200,199,194,190,190,188,183,181,178,177,173,166,163,162,153,143,138,136,128,126,120,119,118,117,114,110,109,108,107,104,103,96,95,94,92,84,80,78,72,70,69,68,67,64,64,63,59,54,50,48,43,40,35,28,27,26,25,22,18,17,16,6,3]+  , [254,250,249,242,239,239,234,233,219,219,218,215,215,205,201,201,199,199,198,198,195,194,191,187,184,184,184,183,182,179,175,175,162,161,161,158,158,154,153,153,149,147,138,127,126,123,119,114,113,108,106,106,105,104,101,101,100,99,98,92,90,88,88,86,86,82,77,71,68,68,60,53,44,42,37,30,23,9,4,1]+  , [255,255,250,249,247,243,242,234,233,229,228,228,227,225,223,218,213,212,211,210,210,198,190,186,184,184,175,173,171,166,160,156,155,152,151,151,147,143,138,134,131,131,118,117,115,115,105,97,95,95,91,90,83,77,73,70,70,68,66,54,50,49,45,38,33,32,30,25,24,20,17,13,13,13,10,8,7,6,5,2]+  , [253,251,249,247,245,243,237,231,230,224,223,222,218,217,214,212,212,209,202,201,186,179,174,171,169,166,164,164,162,157,155,152,148,142,139,134,128,123,120,110,106,104,104,101,100,98,97,97,93,85,80,80,78,77,76,74,70,65,65,54,54,54,43,42,37,32,28,27,26,26,25,22,16,15,14,14,11,5,3,1]+  , [252,250,243,241,238,232,232,223,211,211,211,208,207,206,205,204,201,201,201,199,190,189,188,179,166,158,156,155,152,150,148,148,147,146,144,139,135,132,131,128,118,116,115,114,114,107,99,94,93,89,85,83,82,80,77,73,71,70,68,66,60,58,57,55,53,49,43,40,39,33,28,28,27,27,13,7,6,6,3,1]+  , [255,252,250,250,249,249,244,237,233,232,231,231,228,227,227,218,217,211,201,199,198,198,196,189,189,189,189,181,181,178,173,168,168,167,162,160,160,158,156,155,149,145,145,143,141,137,137,130,130,126,120,116,112,109,105,103,102,100,92,90,89,88,86,82,73,71,71,70,67,66,65,63,50,49,46,26,22,18,17,8]+  , [255,252,246,245,239,237,237,233,233,232,231,231,220,220,218,214,210,206,206,203,199,197,196,194,194,188,185,184,179,156,156,154,149,146,146,143,138,136,136,135,133,130,130,110,109,108,108,102,98,94,93,91,88,88,87,83,79,79,78,78,75,75,74,74,69,58,53,51,50,47,33,31,31,22,15,10,8,5,1,1]+  , [253,247,246,244,244,242,241,235,234,228,225,212,210,209,207,204,203,201,199,194,192,187,185,184,180,180,177,174,172,171,170,167,165,155,155,154,150,148,144,141,139,137,130,118,117,116,114,112,102,102,96,90,83,81,79,74,70,68,61,57,49,48,47,46,45,45,42,40,34,32,28,27,19,17,14,9,8,3,2,1]+  , [242,239,237,234,232,229,225,221,214,212,210,202,202,199,196,196,194,193,184,183,182,181,177,176,175,170,167,167,166,164,161,157,155,155,152,146,144,138,137,132,130,130,124,115,115,114,114,111,101,97,92,87,78,78,78,73,70,68,62,58,57,55,51,51,50,43,43,40,39,36,34,33,32,31,24,23,22,16,11,9]+  , [255,253,251,251,251,249,249,246,245,244,242,236,224,216,210,210,206,205,199,199,197,195,193,192,191,190,189,182,181,180,173,171,170,169,160,159,149,144,142,140,139,136,130,125,123,117,95,92,91,85,79,77,76,75,63,61,59,57,57,53,48,47,41,41,38,29,28,27,27,24,17,17,17,15,13,9,6,5,4,4]+  , [252,252,246,245,237,232,232,228,221,218,215,214,211,208,206,202,201,200,198,198,194,191,191,180,178,174,169,166,166,164,163,162,159,159,158,149,146,144,138,132,127,125,123,122,121,118,115,113,107,107,106,105,102,101,100,92,86,83,80,75,74,73,72,72,65,61,59,55,54,47,47,43,31,24,17,14,14,9,8,4]+  , [253,250,249,246,242,241,236,230,226,223,219,213,201,199,198,191,182,182,179,174,171,168,168,166,161,156,155,153,149,144,140,137,136,132,129,129,126,123,121,118,106,102,101,100,99,95,93,89,89,87,86,81,80,78,74,73,73,72,66,62,59,57,55,49,49,43,41,38,35,32,28,27,24,20,17,15,11,6,5,2]+  , [254,253,249,246,240,229,223,216,212,210,207,206,206,203,203,201,197,195,189,184,183,182,178,175,172,170,166,164,154,151,145,142,141,140,138,125,124,118,117,116,114,107,103,103,94,92,89,86,84,83,81,78,68,66,64,56,56,54,50,47,46,44,40,35,29,27,27,26,26,25,24,24,18,17,12,8,8,7,3,2]+  , [255,248,244,243,238,237,237,231,229,228,228,219,214,211,208,202,202,199,195,192,191,184,183,179,174,170,168,166,163,159,158,158,154,133,130,130,127,126,125,123,121,119,114,98,98,89,89,88,87,83,79,73,69,65,62,58,57,56,51,49,49,48,43,43,40,36,34,33,31,26,23,22,20,19,18,17,17,14,11,7]+  , [254,247,246,246,242,240,237,236,236,229,224,224,219,217,217,215,214,202,201,197,193,189,177,172,172,170,168,164,161,156,155,153,152,152,146,145,144,144,140,138,127,124,123,121,115,110,106,99,99,98,94,91,90,90,89,77,77,73,72,70,69,68,66,65,63,60,58,56,54,47,47,41,40,35,34,22,19,18,12,2]+    ----+  , [510,509,496,489,477,476,462,455,452,443,442,426,424,422,407,406,394,380,377,376,375,335,333,328,323,314,309,299,292,288,287,285,271,265,232,231,212,204,192,191,190,184,182,181,181,164,163,156,154,145,141,141,139,136,128,123,122,112,112,97,97,94,91,86,84,72,67,65,58,56,56,55,50,49,48,47,38,24,14,13]+  , [505,488,475,470,467,466,462,461,437,423,419,399,395,390,390,386,384,381,379,378,372,371,369,365,355,344,344,336,332,322,306,298,296,292,285,278,268,264,252,241,236,229,227,225,219,213,211,205,205,192,189,189,185,172,167,161,156,151,150,150,146,144,139,132,128,123,117,96,80,72,63,43,42,37,37,37,24,22,20,4]+  , [508,498,496,482,476,473,468,460,435,433,427,423,423,402,393,392,387,381,367,360,357,353,353,348,343,335,324,313,311,299,298,297,291,281,263,263,258,258,246,245,239,223,220,213,211,205,198,195,190,181,180,151,150,147,133,125,122,111,109,108,98,89,87,84,82,77,72,67,64,63,62,57,42,34,33,32,15,9,5,4]+  , [506,505,495,488,487,485,485,483,450,448,443,440,435,427,426,422,400,398,396,389,375,369,367,366,358,358,353,350,338,334,326,316,316,306,296,291,288,287,271,237,234,228,221,214,210,207,202,192,192,190,190,183,182,181,175,170,165,159,155,150,145,139,136,134,132,114,113,105,103,83,82,71,70,59,34,24,12,7,5,4]+  ]++--------------------------------------------------------------------------------
+ test/Tests/Partitions/Integer.hs view
@@ -0,0 +1,166 @@++-- | Tests for integer partitions.++{-# LANGUAGE CPP, BangPatterns, DataKinds, KindSignatures, ScopedTypeVariables #-}+module Tests.Partitions.Integer where++--------------------------------------------------------------------------------++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import Tests.Common++import Math.Combinat.Partitions.Integer+import Math.Combinat.Partitions.Integer.Count++import Data.List+import Control.Monad++-- import Data.Map (Map)+-- import qualified Data.Map as Map++import Math.Combinat.Classes+import Math.Combinat.Numbers ( factorial , binomial , multinomial )+import Math.Combinat.Helper++import Data.Proxy+import GHC.TypeLits++--------------------------------------------------------------------------------++-- | Partitions of size at most n+newtype Part (n :: Nat) = Part (Partition) deriving (Eq,Show)++-- | usage: fromPart @20+fromPart :: Part n -> Partition+fromPart (Part p) = p++fromPart20 :: Part 20 -> Partition+fromPart20 (Part p) = p++fromPart30 :: Part 30 -> Partition+fromPart30 (Part p) = p ++instance forall n. KnownNat n => Arbitrary (Part n) where+  arbitrary = do+    n <- choose (0, fromInteger (natVal (Proxy :: Proxy n)))+    myMkGen' Part (randomPartition n)++newtype Expo = Expo [Int] deriving (Eq,Show)++instance Arbitrary Expo where+  arbitrary = do+    n  <- choose (0, 10)+    es <- replicateM n $ choose (0,4)+    return $ Expo es++--------------------------------------------------------------------------------+-- * Types and instances++newtype PartitionWeight     = PartitionWeight     Int              deriving (Eq,Show)+data    PartitionWeightPair = PartitionWeightPair Int Int          deriving (Eq,Show)+data    PartitionIntPair    = PartitionIntPair    Partition Int    deriving (Eq,Show)+maxPartitionSize :: Int+maxPartitionSize = 44++instance Arbitrary Partition where+  arbitrary = do+    n <- choose (0,maxPartitionSize)+    myMkGen (randomPartition n)++instance Arbitrary PartitionWeight where+  arbitrary = liftM PartitionWeight $ choose (0,maxPartitionSize)++instance Arbitrary PartitionWeightPair where+  arbitrary = do+    n <- choose (0,maxPartitionSize)+    k <- choose (0,n+2)+    return (PartitionWeightPair n k)++instance Arbitrary PartitionIntPair where+  arbitrary = do+    part <- arbitrary+    k <- choose (0,partitionWeight part + 2)+    return (PartitionIntPair part k)++--------------------------------------------------------------------------------++-- {- CONJUGATE LEXICOGRAPHIC ordering is a refinement of dominance partial ordering -}+-- let test n = [ ConjLex p >= ConjLex q | p <- partitions n , q <-partitions n ,  p `dominates` q ]+-- and (test 20)++-- {- LEXICOGRAPHIC ordering is a refinement of dominance partial ordering -}+-- let test n = [ p >= q | p <- partitions n , q <-partitions n ,  p `dominates` q ]+-- and (test 20)++--------------------------------------------------------------------------------+-- * test group++testgroup_IntegerPartitions :: Test+testgroup_IntegerPartitions = testGroup "Integer Partitions"  ++  [ testProperty "partitions in a box"             prop_partitions_in_bigbox+  , testProperty "partitions with k parts"         prop_kparts+  , testProperty "odd partitions"                  prop_odd_partitions +  , testProperty "partitions with distinct parts"  prop_distinct_partitions  +  , testProperty "subpartitions"                   prop_subparts+  , testProperty "dual^2 is identity"              prop_dual_dual+  , testProperty "dominated partitions"            prop_dominated_list+  , testProperty "dominating partitions"           prop_dominating_list+  , testProperty "counting partitions"             prop_countParts+  , testProperty "union/sum duality"               prop_union_sum_duality+    --+  , testProperty "to/from expo vector"             prop_to_from_expo_vector+  , testProperty "to/from expo form"               prop_to_from_expo_form+  , testProperty "from/to expo vector"             prop_from_to_expo_vector+  , testProperty "from/to expo form"               prop_from_to_expo_form+  ]++--------------------------------------------------------------------------------+-- * properties++prop_partitions_in_bigbox :: PartitionWeight -> Bool+prop_partitions_in_bigbox (PartitionWeight n) = (partitions n == partitions' (n,n) n)++prop_kparts :: PartitionWeightPair -> Bool+prop_kparts (PartitionWeightPair n k) = (partitionsWithKParts k n == [ mu | mu <- partitions n, numberOfParts mu == k ])++prop_odd_partitions :: PartitionWeight -> Bool+prop_odd_partitions (PartitionWeight n) = +  (partitionsWithOddParts n == [ mu | mu <- partitions n, and (map odd (fromPartition mu)) ])++prop_distinct_partitions :: PartitionWeight -> Bool+prop_distinct_partitions (PartitionWeight n) = +  (partitionsWithDistinctParts n == [ mu | mu <- partitions n, let xs = fromPartition mu, xs == nub xs ])++prop_subparts :: PartitionIntPair -> Bool+prop_subparts (PartitionIntPair lam d) = (subPartitions d lam) == sort [ p | p <- partitions d, isSubPartitionOf p lam ]++prop_dual_dual :: Partition -> Bool+prop_dual_dual lam = (lam == dualPartition (dualPartition lam))++prop_dominated_list :: Partition -> Bool+prop_dominated_list lam = (dominatedPartitions  lam == [ mu  | mu  <- partitions (weight lam), lam `dominates` mu ])++prop_dominating_list :: Partition -> Bool+prop_dominating_list mu  = (dominatingPartitions mu  == [ lam | lam <- partitions (weight mu ), lam `dominates` mu ])++prop_countParts :: Bool+prop_countParts = (take 50 partitionCountList == take 50 partitionCountListNaive)++prop_union_sum_duality :: Partition -> Partition -> Bool+prop_union_sum_duality p q = dualPartition (sumOfPartitions p q) == unionOfPartitions (dualPartition p) (dualPartition q)++--------------------------------------------------------------------------------++prop_to_from_expo_vector p  =  fromExponentVector  (toExponentVector  p) == p+prop_to_from_expo_form   p  =  fromExponentialForm (toExponentialForm p) == p++prop_from_to_expo_vector (Expo es) = toExponentVector (fromExponentVector es) == dropTailingZeros es++prop_from_to_expo_form   p  =  let ef = toExponentialForm p+                               in  toExponentialForm (fromExponentialForm ef) == ef++--------------------------------------------------------------------------------
+ test/Tests/Partitions/Ribbon.hs view
@@ -0,0 +1,86 @@++-- | Tests for ribbons (border strip skew partitions).+--++{-# LANGUAGE CPP, BangPatterns #-}+module Tests.Partitions.Ribbon where++--------------------------------------------------------------------------------++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import Tests.Common+import Tests.Partitions.Integer ( Part(..) , fromPart20 , fromPart30 )     -- Arbitrary instances++import Math.Combinat.Partitions.Integer+import Math.Combinat.Partitions.Skew+import Math.Combinat.Partitions.Skew.Ribbon++import Data.List++import Math.Combinat.Classes++--------------------------------------------------------------------------------+-- * instances++data Inner = Inner Partition Int deriving (Eq,Show)++data Outer = Outer Partition Int deriving (Eq,Show)++instance Arbitrary Inner where+  arbitrary = do+    p <- arbitrary+    let (w,h) = (partitionWidth p, partitionHeight p)+        n = w+h-1+    d <- choose (1,n)+    return $ Inner p d++instance Arbitrary Outer where+  arbitrary = do+    pp <- arbitrary+    let p = fromPart30 pp    -- smaller partitions+    let (w,h) = (partitionWidth p, partitionHeight p)+        n = w+h+10   +    d <- choose (1,n)+    return $ Outer p d++--------------------------------------------------------------------------------+-- * test group++testgroup_Ribbon :: Test+testgroup_Ribbon = testGroup "Ribbons and Corners" +  [ testGroup "Ribbons"  +      [ testProperty "all inner ribbons vs. naive"        prop_inner_all+      , testProperty "inner ribbons of length vs. naive"  prop_inner_length+      , testProperty "outer ribbons of length vs. naive"  prop_outer_length+      ]+  , testGroup "Corners"+      [ testProperty "inner corner boxes vs. naive" prop_innerCornerBoxes+      , testProperty "outer corner boxes vs. naive" prop_outerCornerBoxes +      ]+  ]++--------------------------------------------------------------------------------+-- * ribbon properties++prop_inner_all :: Partition -> Bool+prop_inner_all p = sort (innerRibbons p) == sort (innerRibbonsNaive p)++prop_inner_length :: Inner -> Bool+prop_inner_length (Inner p n) = sort (innerRibbonsOfLength p n) == sort (innerRibbonsOfLengthNaive p n)++prop_outer_length :: Outer -> Bool+prop_outer_length (Outer p n) = sort (outerRibbonsOfLength p n) == sort (outerRibbonsOfLengthNaive p n)++--------------------------------------------------------------------------------+-- * corner properties++prop_innerCornerBoxes :: Partition -> Bool+prop_innerCornerBoxes p  =  (innerCornerBoxes p == innerCornerBoxesNaive p)++prop_outerCornerBoxes :: Partition -> Bool+prop_outerCornerBoxes p  =  (outerCornerBoxes p == outerCornerBoxesNaive p)++--------------------------------------------------------------------------------
+ test/Tests/Partitions/Skew.hs view
@@ -0,0 +1,114 @@++-- | Tests for skew partitions.+--++{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, DataKinds, KindSignatures #-}+module Tests.Partitions.Skew where++--------------------------------------------------------------------------------++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import Tests.Common+import Tests.Partitions.Integer ( Part(..) , fromPart20 , fromPart30 )     -- Arbitrary instances++import Math.Combinat.Partitions.Integer+import Math.Combinat.Partitions.Skew++import Data.List++import Math.Combinat.Classes++import Data.Proxy+import GHC.TypeLits++--------------------------------------------------------------------------------+-- * instances++instance Arbitrary SkewPartition where+  arbitrary = do+    p <- arbitrary+    let n = partitionWeight p+    d <- choose (0,n)+    let qs = subPartitions d p+        ln = length qs+    k <- choose (0,ln-1)+    let q = qs !! k+    return $ mkSkewPartition (p,q) ++--------------------------------------------------------------------------------++-- | Skew partitions of size at most n+newtype Skew (n :: Nat) = Skew (SkewPartition) deriving (Eq,Show)++-- | usage: fromSkew @20+fromSkew :: Skew n -> SkewPartition+fromSkew (Skew p) = p++fromSkew20 :: Skew 20 -> SkewPartition+fromSkew20 (Skew p) = p++fromSkew30 :: Skew 30 -> SkewPartition+fromSkew30 (Skew p) = p ++instance forall nn. KnownNat nn => Arbitrary (Skew nn) where+  arbitrary = do+    Part p <- arbitrary :: Gen (Part nn)+    let n = partitionWeight p+    d <- choose (0,n)+    let qs = subPartitions d p+        ln = length qs+    k <- choose (0,ln-1)+    let q = qs !! k+    return $ Skew $ mkSkewPartition (p,q) ++--------------------------------------------------------------------------------+-- * test group++testgroup_SkewPartitions :: Test+testgroup_SkewPartitions = testGroup "Skew Partitions"  ++  [ testProperty "dual^2 = identity"              prop_dual_dual+  , testProperty "dual vs. inner/outer dual"      prop_dual_from+  , testProperty "to . from = identity"           prop_from_to+  , testProperty "from . to = identity"           prop_to_from+  , testProperty "from . to . from = from"        prop_from_to_from+  , testProperty "weight vs. inner/outer weight"  prop_weight+  ]++--------------------------------------------------------------------------------+-- * properties++prop_dual_dual :: SkewPartition -> Bool+prop_dual_dual sp = (dualSkewPartition (dualSkewPartition sp) == sp)++prop_dual_from :: SkewPartition -> Bool+prop_dual_from sp = (p == dual p' && q == dual q') where+  (p,q)   = fromSkewPartition sp+  sp'     = dualSkewPartition sp+  (p',q') = fromSkewPartition sp'++prop_from_to :: SkewPartition -> Bool+prop_from_to sp = (mkSkewPartition (fromSkewPartition sp) == sp)++prop_to_from :: (Partition,Partition) -> Bool+prop_to_from (p,q) = +  case mb of+    Nothing -> True+    Just sp -> fromSkewPartition sp == (p,q)+  where+    mb = safeSkewPartition (p,q)++prop_from_to_from :: SkewPartition -> Bool+prop_from_to_from sp = (pq == pq') where+  pq  = fromSkewPartition sp+  sp' = mkSkewPartition pq+  pq' = fromSkewPartition sp'++prop_weight :: SkewPartition -> Bool+prop_weight sp = (skewPartitionWeight sp == weight p - weight q) where+  (p,q) = fromSkewPartition sp++--------------------------------------------------------------------------------
+ test/Tests/Permutations.hs view
@@ -0,0 +1,250 @@++-- | Tests for permutations. +--++{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleContexts #-}+module Tests.Permutations where++--------------------------------------------------------------------------------++import Math.Combinat.Permutations++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import System.Random++import Control.Monad+import Control.Monad.ST++import Data.List hiding (permutations)++import Data.Array (Array)+import Data.Array.ST+import Data.Array.Unboxed+import Data.Array.IArray+import Data.Array.MArray+import Data.Array.Unsafe++import Math.Combinat.ASCII+import Math.Combinat.Classes+import Math.Combinat.Helper+import Math.Combinat.Sign+import Math.Combinat.Numbers (factorial,binomial)++--------------------------------------------------------------------------------+-- * generating permutations (random & arbitrary instances, spec types etc)++minPermSize = 1+maxPermSize = 123++newtype Elem = Elem Int deriving Eq+newtype Nat  = Nat { fromNat :: Int } deriving (Eq,Ord,Show,Num,Random)++naturalSet :: Permutation -> Array Int Elem+naturalSet perm = listArray (1,n) [ Elem i | i<-[1..n] ] where+  n = permutationSize perm++permInternalSet :: Permutation -> Array Int Elem+permInternalSet perm@(Permutation arr) = listArray (1,n) [ Elem (perm !!! i) | i<-[1..n] ] where+  n = permutationSize perm++sameSize :: Permutation ->  Permutation -> Bool+sameSize perm1 perm2 = ( permutationSize perm1 == permutationSize perm2)++newtype CyclicPermutation = Cyclic { fromCyclic :: Permutation } deriving Show++data SameSize = SameSize Permutation Permutation deriving Show++data PermWithList = PWL Permutation [Int] deriving (Show)++instance Random Permutation where+  random g = randomPermutation size g1 where+    (size,g1) = randomR (minPermSize,maxPermSize) g+  randomR _ = random++instance Random CyclicPermutation where+  random g = (Cyclic cycl,g2) where+    (size,g1) = randomR (minPermSize,maxPermSize) g+    (cycl,g2) = randomCyclicPermutation size g1+  randomR _ = random++instance Random DisjointCycles where+  random g = (disjcyc,g2) where+    (size,g1) = randomR (minPermSize,maxPermSize) g+    (perm,g2) = randomPermutation size g1+    disjcyc   = permutationToDisjointCycles perm+  randomR _ = random++instance Random SameSize where+  random g = (SameSize prm1 prm2, g3) where+    (size,g1) = randomR (minPermSize,maxPermSize) g+    (prm1,g2) = randomPermutation size g1 +    (prm2,g3) = randomPermutation size g2+  randomR _ = random++randomRList :: (RandomGen g, Random a) => Int -> (a, a) -> g -> ([a],g)+randomRList n ab g0 = go n g0 where+  go 0   g = ([],g)+  go !k !g = let (x ,g' ) = randomR ab g +                 (xs,g'') = go (k-1) g'+             in  (x:xs,g'')++instance Random PermWithList where+  random g = (PWL prm xs, g3) where+    (size,g1) = randomR (minPermSize,maxPermSize) g+    (prm ,g2) = randomPermutation size g1 +    (xs  ,g3) = randomRList size (-100,100) g2+  randomR _ = random++instance Arbitrary Nat where+  arbitrary = choose (Nat 0 , Nat 50)+     +instance Arbitrary Permutation       where arbitrary = choose undefined+instance Arbitrary CyclicPermutation where arbitrary = choose undefined+instance Arbitrary DisjointCycles    where arbitrary = choose undefined+instance Arbitrary SameSize          where arbitrary = choose undefined+instance Arbitrary PermWithList      where arbitrary = choose undefined++--------------------------------------------------------------------------------+-- * test group++testgroup_Permutations :: Test+testgroup_Permutations = testGroup "Permutations"+  +  [ testProperty "disjoint cycles /1" prop_disjcyc_1+  , testProperty "disjoint cycles /2" prop_disjcyc_2 ++  , testProperty "disjoint cycles compatibility" prop_disjcyc_Mathematica++  , testProperty "random cyclic permutation is indeed cyclic" prop_randCyclic+  , testProperty "inverse^2 is identity"                      prop_inverse++  , testProperty "permutation action is group action"              prop_mulPerm+  , testProperty "left permutation action is left group action"    prop_mulPermLeft+  , testProperty "right permutation action is right group action"  prop_mulPermRight++  , testProperty "permutation action convetion"        prop_perm+  , testProperty "left permutation action convention"  prop_permLeft+  , testProperty "right permutation action convention" prop_permRight+  , testProperty "left/right permutation action convention" prop_permLeftRight++  , testProperty "cycle left"  prop_cycleLeft+  , testProperty "cycle right" prop_cycleRight++  , testProperty "sign of permutation is multiplicative"     prop_mulSign      +  , testProperty "inverse is compatible with multiplication" prop_invMul+  , testProperty "sign of permutation is parity of inversions"  prop_sign_inversions++  , testProperty "parity of cyclic permutaiton" prop_cyclSign+  , testProperty "random permutation is valid"  prop_permIsPerm+  , testProperty "definition of parity"         prop_isEven++  , testProperty "bubbleSort works"    prop_bubbleSort+  , testProperty "bubbleSort2 works"   prop_bubbleSort2+  , testProperty "number of inversions = steps in bubble sort"         prop_bubble_inversions+  , testProperty "number of inversions = actual number of inversions"  prop_number_inversions +  , testProperty "number of inversions is the same for the inverse permutation"  prop_ninversions_inverse+  , testProperty "merge sort algorithm = naive inversion count"                  prop_merge_inversions++  , testProperty "sortingPermutationAsc"    prop_sortingPermAsc+  , testProperty "sortingPermutationDesc"   prop_sortingPermDesc+  , testProperty "concatPermutations"       prop_concatPerm+  ]++--------------------------------------------------------------------------------+-- * test properties+          +prop_disjcyc_1 perm = ( perm == disjointCyclesToPermutation n (permutationToDisjointCycles perm) )+  where n = permutationSize perm++prop_disjcyc_2 k dcyc = ( dcyc == permutationToDisjointCycles (disjointCyclesToPermutation n dcyc) )+  where +    n = fromNat k + m +    m = case fromDisjointCycles dcyc of+      []  -> 1+      xxs -> maximum (concat xxs)++-- PermutationCycles[ { 12, 15, 5, 6, 2, 7, 17, 9, 20, 3, 11, 18, 22, 21, 8, 10, 4, 19, 14, 16, 23, 1, 13 } ]+-- Cycles           [ {{1, 12, 18, 19, 14, 21, 23, 13, 22}, {2, 15, 8, 9, 20, 16, 10, 3, 5}, {4, 6, 7, 17}} ]+prop_disjcyc_Mathematica = (permutationToDisjointCycles   perm == disjcyc) +                        && (disjointCyclesToPermutation n disjcyc == perm)+  where+    n       = permutationSize perm+    perm    = toPermutation  [ 12, 15, 5, 6, 2, 7, 17, 9, 20, 3, 11, 18, 22, 21, 8, 10, 4, 19, 14, 16, 23, 1, 13 ]+    disjcyc = DisjointCycles [ [1, 12, 18, 19, 14, 21, 23, 13, 22], [2, 15, 8, 9, 20, 16, 10, 3, 5], [4, 6, 7, 17] ]++xperm    = toPermutation  [ 12, 15, 5, 6, 2, 7, 17, 9, 20, 3, 11, 18, 22, 21, 8, 10, 4, 19, 14, 16, 23, 1, 13 ]+xdisjcyc = DisjointCycles [ [1, 12, 18, 19, 14, 21, 23, 13, 22], [2, 15, 8, 9, 20, 16, 10, 3, 5], [4, 6, 7, 17] ]++prop_randCyclic cycl = ( isCyclicPermutation (fromCyclic cycl) )++prop_inverse perm = ( perm == inversePermutation (inversePermutation perm) ) ++prop_mulPerm (SameSize perm1 perm2) = +    ( permuteArray perm2 (permuteArray perm1 set) == permuteArray (perm1 `multiplyPermutation` perm2) set ) +  where +    set = naturalSet perm1++prop_mulPermRight (SameSize perm1 perm2) = +    ( permuteArrayRight perm2 (permuteArrayRight perm1 set) == permuteArrayRight (perm1 `multiplyPermutation` perm2) set ) +  where +    set = naturalSet perm1++prop_mulPermLeft (SameSize perm1 perm2) = +    ( permuteArrayLeft perm2 (permuteArrayLeft perm1 set) == permuteArrayLeft (perm2 `multiplyPermutation` perm1) set ) +  where +    set = naturalSet perm1++prop_perm          perm = permuteArray      perm (naturalSet perm) == permInternalSet perm+prop_permLeft      perm = permuteArrayLeft  perm (permInternalSet perm) == naturalSet perm+prop_permRight     perm = permuteArrayRight perm (naturalSet perm) == permInternalSet perm+prop_permLeftRight perm = permuteArrayLeft (inversePermutation perm) (naturalSet perm) == permuteArrayRight (perm) (naturalSet perm) ++prop_cycleLeft  = permuteList (cycleLeft  5) "abcde" == "bcdea"+prop_cycleRight = permuteList (cycleRight 5) "abcde" == "eabcd"++prop_mulSign (SameSize perm1 perm2) = +    ( sgn perm1 * sgn perm2 == sgn (perm1 `multiplyPermutation` perm2) ) +  where +    sgn = signValue . signOfPermutation :: Permutation -> Int++prop_sign_inversions perm = signOfPermutation perm == paritySign (numberOfInversions perm)++prop_invMul (SameSize perm1 perm2) =   +  ( inversePermutation perm2 `multiplyPermutation` inversePermutation perm1 == inversePermutation (perm1 `multiplyPermutation` perm2) ) ++prop_cyclSign cycl = ( isEvenPermutation perm == odd n ) where+  perm = fromCyclic cycl+  n = permutationSize perm+  +prop_permIsPerm perm = ( isPermutation (fromPermutation perm) ) ++prop_isEven perm = ( isEvenPermutation perm == isEvenAlternative perm ) where+  isEvenAlternative p = +    even $ sum $ map (\x->x-1) $ map length $ fromDisjointCycles $ permutationToDisjointCycles p++prop_bubbleSort perm = productOfPermutations' n (map (adjacentTransposition n) $ bubbleSort perm) == perm where+  n = permutationSize perm++prop_bubbleSort2 perm = productOfPermutations' n (map (transposition n) $ bubbleSort2 perm) == perm where+  n = permutationSize perm++prop_bubble_inversions perm = length (bubbleSort perm) == numberOfInversions perm++prop_number_inversions perm = length (inversions perm) == numberOfInversions perm++prop_ninversions_inverse perm = numberOfInversions perm == numberOfInversions (inversePermutation perm)++prop_merge_inversions perm = (numberOfInversionsMerge perm == numberOfInversionsNaive perm)++prop_sortingPermAsc :: [Int] -> Bool +prop_sortingPermAsc xs = permuteList (sortingPermutationAsc xs) xs == sort xs++prop_sortingPermDesc :: [Int] ->  Bool+prop_sortingPermDesc xs = permuteList (sortingPermutationDesc xs) xs == reverse (sort xs)++prop_concatPerm (PWL p1 xs) (PWL p2 ys) = permuteList p1 xs ++ permuteList p2 ys == permuteList (concatPermutations p1 p2) (xs++ys)++--------------------------------------------------------------------------------+
+ test/Tests/Series.hs view
@@ -0,0 +1,466 @@++-- | Tests for power series+--++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DataKinds, KindSignatures #-}+module Tests.Series where++--------------------------------------------------------------------------------++import Math.Combinat.Numbers.Series++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import System.Random++import Data.List+import Data.Ratio++import GHC.TypeLits+import Data.Proxy++import Math.Combinat.Sign+import Math.Combinat.Numbers+import Math.Combinat.Partitions.Integer+import Math.Combinat.Helper++--------------------------------------------------------------------------------+-- * code used only for tests++-- | Expansion of @1 / (1-x^k)@. Included for completeness only; +-- it equals to @coinSeries [k]@, and for example+-- for @k=4@ it is simply+-- +-- > [1,0,0,0,1,0,0,0,1,0,0,0,1,0,0,0,1,0,0...]+--+pseries1 :: Int -> [Integer]+pseries1 k1 = convolveWithPSeries1 k1 unitSeries ++-- | The expansion of @1 / (1-x^k_1-x^k_2)@+pseries2 :: Int -> Int -> [Integer]+pseries2 k1 k2 = convolveWithPSeries2 k1 k2 unitSeries ++-- | The expansion of @1 / (1-x^k_1-x^k_2-x^k_3)@+pseries3 :: Int -> Int -> Int -> [Integer]+pseries3 k1 k2 k3 = convolveWithPSeries3 k1 k2 k3 unitSeries++--------------------------------------------------------------------------------++-- | Convolve with (the expansion of) @1 / (1-x^k1)@+convolveWithPSeries1 :: Int -> [Integer] -> [Integer]+convolveWithPSeries1 k1 series1 = xs where+  series = series1 ++ repeat 0 +  xs = zipWith (+) series ( replicate k1 0 ++ xs )++-- | Convolve with (the expansion of) @1 / (1-x^k1-x^k2)@+convolveWithPSeries2 :: Int -> Int -> [Integer] -> [Integer]+convolveWithPSeries2 k1 k2 series1 = xs where+  series = series1 ++ repeat 0 +  xs = zipWith3 (\x y z -> x + y + z)+    series+    ( replicate k1 0 ++ xs )+    ( replicate k2 0 ++ xs )+    +-- | Convolve with (the expansion of) @1 / (1-x^k_1-x^k_2-x^k_3)@+convolveWithPSeries3 :: Int -> Int -> Int -> [Integer] -> [Integer]+convolveWithPSeries3 k1 k2 k3 series1 = xs where+  series = series1 ++ repeat 0 +  xs = zipWith4 (\x y z w -> x + y + z + w)+    series+    ( replicate k1 0 ++ xs )+    ( replicate k2 0 ++ xs )+    ( replicate k3 0 ++ xs )++--------------------------------------------------------------------------------++-- | @1 / (1 - a*x^k)@. +-- For example, for @a=3@ and @k=2@ it is just+-- +-- > [1,0,3,0,9,0,27,0,81,0,243,0,729,0,2187,0,6561,0,19683,0...]+--+pseries1' :: Num a => (a,Int) -> [a]+pseries1' ak1 = convolveWithPSeries1' ak1 unitSeries++-- | @1 / (1 - a_1*x^k_1 - a_2*x^k_2)@+pseries2' :: Num a => (a,Int) -> (a,Int) -> [a]+pseries2' ak1 ak2 = convolveWithPSeries2' ak1 ak2 unitSeries++-- | @1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3)@+pseries3' :: Num a => (a,Int) -> (a,Int) -> (a,Int) -> [a]+pseries3' ak1 ak2 ak3 = convolveWithPSeries3' ak1 ak2 ak3 unitSeries++--------------------------------------------------------------------------------++-- | Convolve with @1 / (1 - a*x^k)@. +convolveWithPSeries1' :: Num a => (a,Int) -> [a] -> [a]+convolveWithPSeries1' (a1,k1) series1 = xs where+  series = series1 ++ repeat 0 +  xs = zipWith (+)+    series+    ( replicate k1 0 ++ map (*a1) xs )++-- | Convolve with @1 / (1 - a_1*x^k_1 - a_2*x^k_2)@+convolveWithPSeries2' :: Num a => (a,Int) -> (a,Int) -> [a] -> [a]+convolveWithPSeries2' (a1,k1) (a2,k2) series1 = xs where+  series = series1 ++ repeat 0 +  xs = zipWith3 (\x y z -> x + y + z)+    series+    ( replicate k1 0 ++ map (*a1) xs )+    ( replicate k2 0 ++ map (*a2) xs )+    +-- | Convolve with @1 / (1 - a_1*x^k_1 - a_2*x^k_2 - a_3*x^k_3)@+convolveWithPSeries3' :: Num a => (a,Int) -> (a,Int) -> (a,Int) -> [a] -> [a]+convolveWithPSeries3' (a1,k1) (a2,k2) (a3,k3) series1 = xs where+  series = series1 ++ repeat 0 +  xs = zipWith4 (\x y z w -> x + y + z + w)+    series+    ( replicate k1 0 ++ map (*a1) xs )+    ( replicate k2 0 ++ map (*a2) xs )+    ( replicate k3 0 ++ map (*a3) xs )++--------------------------------------------------------------------------------+-- * Types and instances++{-+swap :: (a,b) -> (b,a)+swap (x,y) = (y,x)+-}++-- compare the first N elements of the infinite lists+(=..=) :: (Eq a, Num a) => Int -> [a] -> [a] -> Bool+(=..=) n xs1 ys1 = take n xs == take n ys where+  xs = xs1 ++ repeat 0+  ys = ys1 ++ repeat 0++infix 4 =..=++-- compare the first 100 elements of the infinite lists+(=!=) :: (Eq a, Num a) => [a] -> [a] -> Bool+(=!=) xs1 ys1 = (take m xs == take m ys) where +  m = 100+  xs = xs1 ++ repeat 0+  ys = ys1 ++ repeat 0++infix 4 =!=++-- compare the first 500 elements of the infinite lists+(=!!=) :: (Eq a, Num a) => [a] -> [a] -> Bool+(=!!=) xs1 ys1 = (take m xs == take m ys) where +  m = 500+  xs = xs1 ++ repeat 0+  ys = ys1 ++ repeat 0++infix 4 =!!=++newtype XNat   = XNat   { fromXNat   :: Int      } deriving (Eq,Ord,Show,Num,Random)++newtype Rat    = Rat    { fromRat    :: Rational } deriving (Eq,Ord,Show,Num,Fractional)+newtype NZRat  = NZRat  { fromNZRat  :: Rational } deriving (Eq,Ord,Show,Num,Fractional)++-- type parameter is for controlling the size (length), because some tests are too slow+newtype Ser  (n :: Nat) = Ser  { fromSer'  :: [Integer]  } deriving (Eq,Ord,Show)+newtype SerR (n :: Nat) = SerR { fromSerR' :: [Rational] } deriving (Eq,Ord,Show)++newtype Exp  = Exp  { fromExp  ::  Int  } deriving (Eq,Ord,Show,Num,Random)+newtype Exps = Exps { fromExps :: [Int] } deriving (Eq,Ord,Show)+newtype CoeffExp  = CoeffExp  { fromCoeffExp  ::  (Integer,Int)  } deriving (Eq,Ord,Show)+newtype CoeffExps = CoeffExps { fromCoeffExps :: [(Integer,Int)] } deriving (Eq,Ord,Show)++----------------------------------------++serProxy :: f (n :: Nat) -> Proxy n+serProxy _ = Proxy++seriesSize :: KnownNat (n :: Nat) => f (n :: Nat) -> Int+seriesSize ser = fromInteger $ natVal (serProxy ser) where ++----------------------------------------++fromSer  = fromSer500+fromSerR = fromSerR500++fromSer25 :: Ser 25 -> [Integer]+fromSer25 = fromSer'++fromSer100 :: Ser 100 -> [Integer]+fromSer100 = fromSer'++fromSer500 :: Ser 500 -> [Integer]+fromSer500 = fromSer'++----------------------------------------++fromSerR25 :: SerR 25 -> [Rational]+fromSerR25 = fromSerR'++fromSerR50 :: SerR 50 -> [Rational]+fromSerR50 = fromSerR'++fromSerR100 :: SerR 100 -> [Rational]+fromSerR100 = fromSerR'++fromSerR500 :: SerR 500 -> [Rational]+fromSerR500 = fromSerR'++----------------------------------------++{-+minSerSize = 0   :: Int+maxSerSize = 500 :: Int+-}++minSerValue = -10000 :: Int+maxSerValue =  10000 :: Int++rndList :: (RandomGen g, Random a) => Int -> (a, a) -> g -> ([a], g)+rndList n minmax g = swap $ mapAccumL f g [1..n] where+  f g _ = swap $ randomR minmax g ++instance Random Rat where+  random g = (Rat (fromIntegral x % fromIntegral y), g'') where+    (x,g' ) = randomR (-100,100::Int) g+    (y,g'') = randomR (   1, 25::Int) g'        -- hackety hack hack+  randomR _ g = random g++instance Random NZRat where+  random g = let (Rat q , g') = random g+             in  if q /= 0 then (NZRat q, g') else random g'            +  randomR _ g = random g++instance Arbitrary XNat where+  arbitrary = choose (XNat 0 , XNat 750)++instance Arbitrary Exp where+  arbitrary = choose (Exp 1 , Exp 32)++instance Arbitrary CoeffExp where+  arbitrary = do+    coeff <- choose (minSerValue, maxSerValue) :: Gen Int+    exp   <- arbitrary :: Gen Exp+    return $ CoeffExp (fromIntegral coeff, fromExp exp)+   +instance KnownNat (n :: Nat) => Random (Ser n) where+  random g = (series, g2) where+    maxSerSize = seriesSize series+    series     = Ser (map fi list) +    (size,g1) = randomR (0,maxSerSize) g+    (list,g2) = rndList size (minSerValue,maxSerValue) g1+    fi :: Int -> Integer+    fi = fromIntegral +  randomR _ = random++instance KnownNat (n :: Nat) => Random (SerR n) where+  random g = (series, g2) where+    maxSerSize = seriesSize series+    series    = SerR (map fromRat list) +    (size,g1) = randomR (0,maxSerSize) g+    (list,g2) = rndList size (fromIntegral minSerValue, fromIntegral maxSerValue) g1+  randomR _ = random++instance Random Exps where+  random g = (Exps list, g2) where+    (size,g1) = randomR (0,10) g+    (list,g2) = rndList size (1,32) g1+  randomR _ = random++instance Random CoeffExps where+  random g = (CoeffExps (zip (map fromIntegral list2) list1), g3) where+    (size,g1) = randomR (0,10) g+    (list1,g2) = rndList size (1,32) g1+    (list2,g3) = rndList size (minSerValue,maxSerValue) g2+  randomR _ = random++instance Arbitrary Rat where+  arbitrary = choose undefined++instance Arbitrary NZRat where+  arbitrary = choose undefined+  +instance KnownNat n => Arbitrary (Ser n) where+  arbitrary = choose undefined++instance KnownNat n => Arbitrary (SerR n) where+  arbitrary = choose undefined++instance Arbitrary Exps where+  arbitrary = choose undefined++instance Arbitrary CoeffExps where+  arbitrary = choose undefined++--------------------------------------------------------------------------------+-- * test group++testgroup_PowerSeries :: Test+testgroup_PowerSeries = testGroup "Power series"+  [ +    testProperty "mulSeries  == mulSeriesNaive"   prop_mulSeries_vs_naive+  , testProperty "divSeries  == mulWithRecip"     prop_divSeries_vs_mult_with_recip+  , testProperty "recip xs   == 1 / xs"           prop_recipSeries_vs_one_over+  , testProperty "compose    == composeNaive"     prop_compose_vs_naive+  , testProperty "substitute == substituteNaive"  prop_substitute_vs_naive+  , testProperty "inversion  == inversionNaive"   prop_inversion_vs_naive++  , testProperty "lagrange inversion works /1"       prop_lagrange_inversion1+  , testProperty "lagrange inversion works /2"       prop_lagrange_inversion2+  , testProperty "naive lagrange inversion works /1"       prop_lagrange_inversion_naive1+  , testProperty "naive lagrange inversion works /2"       prop_lagrange_inversion_naive2+  , testProperty "integral naive lagrange inversion works /1"       prop_lagrange_inversion_int_naive1+  , testProperty "integral naive lagrange inversion works /2"       prop_lagrange_inversion_int_naive2++  , testProperty "diff . int == id"            prop_diff_integrate+  , testProperty "tail (int . diff) == tail"   prop_integrate_diff+  , testProperty "sin vs sin2"                 prop_sin_vs_sin2+  , testProperty "cos vs cos2"                 prop_cos_vs_cos2++  , testProperty "convPSeries1 vs generic"     prop_conv1_vs_gen+  , testProperty "convPSeries2 vs generic"     prop_conv2_vs_gen+  , testProperty "convPSeries3 vs generic"     prop_conv3_vs_gen+  , testProperty "convPSeries1' vs generic"    prop_conv1_vs_gen'+  , testProperty "convPSeries2' vs generic"    prop_conv2_vs_gen'+  , testProperty "convPSeries3' vs generic"    prop_conv3_vs_gen'+  , testProperty "convolve_pseries"            prop_convolve_pseries +  , testProperty "convolve_pseries'"           prop_convolve_pseries' +  , testProperty "coinSeries vs pseries"       prop_coin_vs_pseries+  , testProperty "coinSeries vs pseries'"      prop_coin_vs_pseries'++    -- these are very slow, because random is slow+  , testProperty "leftIdentity"    prop_leftIdentity+  , testProperty "rightIdentity"   prop_rightIdentity+  , testProperty "commutativity"   prop_commutativity+  , testProperty "associativity"   prop_associativity+  ]++--------------------------------------------------------------------------------+-- * properties++prop_mulSeries_vs_naive ser1 ser2 = (mulSeries xs ys =!= mulSeriesNaive xs ys) where+  xs = fromSer ser1+  ys = fromSer ser2++prop_divSeries_vs_mult_with_recip (NZRat q) ser1 ser2 = (=..=) 60 (divSeries xs ys) (mulSeries xs (reciprocalSeries ys)) where+  xs =     fromSerR100 ser1+  ys = q : fromSerR100 ser2++prop_recipSeries_vs_one_over (NZRat q) ser = (reciprocalSeries xs =!= divSeries unitSeries xs) where+  xs = q : fromSerR100 ser++prop_compose_vs_naive ser1 ser2 = (=..=) 25 (composeSeries xs ys) (composeSeriesNaive xs ys) where+  xs =     fromSer25 ser1+  ys = 0 : fromSer25 ser2++prop_substitute_vs_naive ser1 ser2 = (=..=) 25 (substitute xs ys) (substituteNaive xs ys) where+  xs = 0 : fromSer25 ser1+  ys =     fromSer25 ser2++prop_inversion_vs_naive (NZRat q) ser = (=..=) 25 (lagrangeInversion xs) (lagrangeInversionNaive xs) where+  xs = 0 : q : fromSerR25 ser++prop_lagrange_inversion1 (NZRat q) ser = (=..=) 35 (substitute f (lagrangeInversion f)) (0 : 1 : repeat 0) where f = 0 : q : fromSerR50 ser+prop_lagrange_inversion2 (NZRat q) ser = (=..=) 35 (substitute (lagrangeInversion f) f) (0 : 1 : repeat 0) where f = 0 : q : fromSerR50 ser++prop_lagrange_inversion_naive1 (NZRat q) ser = (=..=) 20 (substituteNaive f (lagrangeInversionNaive f)) (0 : 1 : repeat 0) where f = 0 : q : fromSerR25 ser+prop_lagrange_inversion_naive2 (NZRat q) ser = (=..=) 20 (substituteNaive (lagrangeInversionNaive f) f) (0 : 1 : repeat 0) where f = 0 : q : fromSerR25 ser++prop_lagrange_inversion_int_naive1 ser = (=..=) 20 (substituteNaive f (integralLagrangeInversionNaive f)) (0 : 1 : repeat 0) where f = 0 : 1 : fromSer25 ser+prop_lagrange_inversion_int_naive2 ser = (=..=) 20 (substituteNaive (integralLagrangeInversionNaive f) f) (0 : 1 : repeat 0) where f = 0 : 1 : fromSer25 ser++--------------------------------------------------------------------------------++prop_diff_integrate ser = (xs =!= differentiateSeries (integrateSeries xs)) where+  xs = fromSerR ser++prop_integrate_diff ser = (null xs) || (0 : tail xs =!= integrateSeries (differentiateSeries xs)) where+  xs = fromSerR ser++prop_cos_vs_cos2 = (cosSeries =!= (cosSeries2 :: [Rational])) +prop_sin_vs_sin2 = (sinSeries =!= (sinSeries2 :: [Rational])) ++--------------------------------------------------------------------------------+     +prop_leftIdentity ser = ( xs =!= unitSeries `convolve` xs ) where +  xs = fromSer100 ser ++prop_rightIdentity ser = ( unitSeries `convolve` xs =!= xs ) where +  xs = fromSer100 ser ++prop_commutativity ser1 ser2 = ( xs `convolve` ys =!= ys `convolve` xs ) where +  xs = fromSer100 ser1+  ys = fromSer100 ser2++prop_associativity ser1 ser2 ser3 = ( one =!= two ) where+  one = (xs `convolve` ys) `convolve` zs+  two = xs `convolve` (ys `convolve` zs)+  xs = fromSer100 ser1+  ys = fromSer100 ser2+  zs = fromSer100 ser3++--------------------------------------------------------------------------------+  +prop_conv1_vs_gen exp1 ser = ( one =!= two ) where+  one = convolveWithPSeries1 k1 xs +  two = convolveWithPSeries [k1] xs+  k1 = fromExp exp1+  xs = fromSer ser  ++prop_conv2_vs_gen exp1 exp2 ser = (one =!= two) where+  one = convolveWithPSeries2 k1 k2 xs +  two = convolveWithPSeries [k2,k1] xs+  k1 = fromExp exp1+  k2 = fromExp exp2+  xs = fromSer ser  ++prop_conv3_vs_gen exp1 exp2 exp3 ser = (one =!= two) where+  one = convolveWithPSeries3 k1 k2 k3 xs +  two = convolveWithPSeries [k2,k3,k1] xs+  k1 = fromExp exp1+  k2 = fromExp exp2+  k3 = fromExp exp3+  xs = fromSer ser  ++prop_conv1_vs_gen' exp1 ser = ( one =!= two ) where+  one = convolveWithPSeries1' ak1 xs +  two = convolveWithPSeries' [ak1] xs+  ak1 = fromCoeffExp exp1+  xs = fromSer ser  ++prop_conv2_vs_gen' exp1 exp2 ser = (one =!= two) where+  one = convolveWithPSeries2' ak1 ak2 xs +  two = convolveWithPSeries' [ak2,ak1] xs+  ak1 = fromCoeffExp exp1+  ak2 = fromCoeffExp exp2+  xs = fromSer ser  ++prop_conv3_vs_gen' exp1 exp2 exp3 ser = (one =!= two) where+  one = convolveWithPSeries3' ak1 ak2 ak3 xs +  two = convolveWithPSeries' [ak2,ak3,ak1] xs+  ak1 = fromCoeffExp exp1+  ak2 = fromCoeffExp exp2+  ak3 = fromCoeffExp exp3+  xs = fromSer ser  ++prop_convolve_pseries exps1 ser = (one =!= two) where+  one = convolveWithPSeries ks1 xs +  two = xs `convolve` pseries ks1 +  ks1 = fromExps exps1+  xs = fromSer ser  ++prop_convolve_pseries' cexps1 ser = (one =!= two) where+  one = convolveWithPSeries' aks1 xs +  two = xs `convolve` pseries' aks1 +  aks1 = fromCoeffExps cexps1+  xs = fromSer ser  ++prop_coin_vs_pseries exps1 = (one =!= two) where+  one = coinSeries ks1 +  two = convolveMany (map pseries1 ks1)+  ks1 = fromExps exps1++prop_coin_vs_pseries' cexps1 = (one =!= two) where+  one = coinSeries' aks1 +  two = convolveMany (map pseries1' aks1)+  aks1 = fromCoeffExps cexps1+    +--------------------------------------------------------------------------------+
+ test/Tests/SkewTableaux.hs view
@@ -0,0 +1,104 @@+
+-- | Tests for skew tableaux
+
+{-# LANGUAGE FlexibleInstances, TypeApplications, DataKinds #-}
+module Tests.SkewTableaux where
+
+--------------------------------------------------------------------------------
+
+import Control.Monad
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.QuickCheck.Gen
+
+import Tests.Partitions.Integer ()
+import Tests.Partitions.Skew ( Skew(..) , fromSkew20 , fromSkew30 )     -- Arbitrary instances
+
+import Math.Combinat.Tableaux
+import Math.Combinat.Tableaux.Skew
+import Math.Combinat.Partitions.Integer
+import Math.Combinat.Partitions.Skew
+
+--------------------------------------------------------------------------------
+-- * code
+
+numberOfNonEmptyRows :: SkewPartition -> Int
+numberOfNonEmptyRows (SkewPartition xys) = length [ True | (x,y) <- xys, y/=0 ]
+
+-- | Breaks a skew partition into disjoint parts
+disjointParts :: SkewPartition -> [SkewPartition]
+disjointParts (SkewPartition xys) = map normalizeSkewPartition list where
+
+  list = map SkewPartition $ filter (not . isEmpty) $ break xys
+
+  isEmpty :: [(Int,Int)] -> Bool
+  isEmpty xys = and [ y==0 | (x,y) <- xys ]
+
+  break :: [(Int,Int)] -> [[(Int,Int)]]
+  break []   = [[]]
+  break [xy] = [[xy]]
+  break ( xy@(x,y) : rest@((x',y'):_) ) = if x >= x'+y' 
+    then [xy] : break rest
+    else let (     xys  : rest' ) = break rest
+         in  ( (xy:xys) : rest' )
+  
+  
+
+
+--------------------------------------------------------------------------------
+-- * instances 
+
+instance Arbitrary (SkewTableau Int) where
+  arbitrary = do
+    pshape <- arbitrary
+    let shape = fromSkew20 pshape      -- skew partition of size at most 20
+    let w = skewPartitionWeight shape
+    content <- replicateM w $ choose (1,1000)
+    return $ fillSkewPartitionWithRowWord shape content
+
+--------------------------------------------------------------------------------
+-- * test group
+
+testgroup_SkewTableaux :: Test
+testgroup_SkewTableaux = testGroup "Skew tableaux"
+  [ testProperty "dual^2 = identity"            prop_skew_dual_dual
+  , testProperty "fill . rowWord = identity"    prop_rowWord
+  , testProperty "fill . columnWord = identity" prop_columnWord
+  , testProperty "fill respectes the shape"     prop_fill_shape 
+  , testProperty "semistandard skew tableaux are indeed semistandard"   prop_semistandard 
+  ]
+
+--------------------------------------------------------------------------------
+-- * properties
+
+prop_skew_dual_dual :: SkewTableau Int -> Bool
+prop_skew_dual_dual st = (dualSkewTableau (dualSkewTableau st) == st)
+
+prop_rowWord :: SkewTableau Int -> Bool
+prop_rowWord st = (fillSkewPartitionWithRowWord shape content == st) where
+  shape   = skewTableauShape st
+  content = skewTableauRowWord st
+
+prop_columnWord :: SkewTableau Int -> Bool
+prop_columnWord st = (fillSkewPartitionWithColumnWord shape content == st) where
+  shape   = skewTableauShape st
+  content = skewTableauColumnWord st
+
+prop_fill_shape :: SkewPartition -> Bool
+prop_fill_shape shape = (shape == shape') where
+  tableau = fillSkewPartitionWithColumnWord shape [1..]
+  shape'  = skewTableauShape tableau
+
+prop_semistandard :: Skew 20 -> Bool
+prop_semistandard (Skew shape) = and 
+  [ isSemiStandardSkewTableau st 
+  | n  <- [kk..nn] 
+  , st <- take 500 (semiStandardSkewTableaux n shape)         -- we only take the first 500 because impossibly slow otherwise
+  ]
+  where
+    nn = min (kk + 10) (skewPartitionWeight shape)
+    kk = maximum $ 0 : (map numberOfNonEmptyRows $ disjointParts shape)
+
+--------------------------------------------------------------------------------
+ test/Tests/Thompson.hs view
@@ -0,0 +1,134 @@++-- | Tests for Thompson's group F+--++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances, TypeSynonymInstances #-}+module Tests.Thompson where++--------------------------------------------------------------------------------++import Prelude hiding ( (**) )+import Control.Monad+import Data.List++import Math.Combinat.Groups.Thompson.F+import qualified Math.Combinat.Trees.Binary as B++import Tests.Common++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import System.Random++import Math.Combinat.Helper+++--------------------------------------------------------------------------------+-- * code++(**) :: TDiag -> TDiag -> TDiag+(**) x y = x `compose` y++(//) :: TDiag -> TDiag -> TDiag+(//) x y = x `compose` (inverse y)++growth_n_sphere     = [1,4,12,36,108,314,906,2576,7280,20352] :: [Int]+growth_pos_n_sphere = [1,2, 4, 9, 20, 45,101, 227, 510, 1146] :: [Int]++--------------------------------------------------------------------------------+-- * instances++-- | A pair of trees with the same size+data TPair = TPair !T !T deriving (Eq,Show)++newtype Unreduced = Unreduced TDiag deriving (Eq,Show)++instance Arbitrary T where+  arbitrary = liftM fromBinTree $ myMkSizedGen B.randomBinaryTree++instance Arbitrary TPair where+  arbitrary = myMkSizedGen $ \siz -> runRand $ do+    t1 <- rand (B.randomBinaryTree siz)+    t2 <- rand (B.randomBinaryTree siz)+    return $ TPair (fromBinTree t1) (fromBinTree t2)++instance Arbitrary TDiag where+  arbitrary = do +    TPair t1 t2 <- arbitrary+    return $ mkTDiag t1 t2++instance Arbitrary Unreduced where+  arbitrary = do +    TPair t1 t2 <- arbitrary+    return $ Unreduced $ mkTDiagDontReduce t1 t2++--------------------------------------------------------------------------------+-- * test group++testgroup_ThompsonF :: Test+testgroup_ThompsonF = testGroup "Thompson's group F"+  [ testProperty "identity element"                    prop_identity+  , testProperty "associativity"                       prop_assoc+  , testProperty "standard relations"                  prop_relations+  , testProperty "quotient of positives"               prop_quot_positive+  , testProperty "telescopic product"                  prop_telescope+  , testProperty "cyclic telescopic product (3)"       prop_cyclic_product_3+  , testProperty "cyclic telescopic product (4)"       prop_cyclic_product_4+  , testProperty "positive diagrams form a monoid"     prop_positive_product+  , testProperty "composition commutes with reduction" prop_reduce_composition+  , testProperty "inverse commutes with reduction"     prop_reduce_inverse+  ]++--------------------------------------------------------------------------------+-- * properties+    +prop_relations :: Bool+prop_relations = and [ rel k n | n<-[1..30] , k<-[0..n-1] ] where+  rel k n = (inverse $ xk k) `compose` (xk n) `compose` (xk k) == xk (n+1)++prop_quot_positive :: TPair -> Bool+prop_quot_positive (TPair t1 t2) = (mkTDiag t1 t2) == (positive t1 // positive t2)++prop_identity :: TDiag -> Bool+prop_identity x = (x ** identity) == x && (identity ** x) == x++prop_assoc :: TDiag -> TDiag -> TDiag -> Bool+prop_assoc a b c = (p == q) where+  p = compose (compose a b) c+  q = compose a (compose b c)++prop_telescope :: TDiag -> TDiag -> TDiag -> TDiag -> Bool+prop_telescope u v w z = (a `compose` b `compose` c) == (u // z) where+  a = u // v+  b = v // w+  c = w // z++prop_cyclic_product_3 :: TDiag -> TDiag -> TDiag -> Bool+prop_cyclic_product_3 u v w = (a `compose` b `compose` c) == identity where+  a = u // v+  b = v // w+  c = w // u++prop_cyclic_product_4 :: TDiag -> TDiag -> TDiag -> TDiag -> Bool+prop_cyclic_product_4 u v w z = (a `compose` b `compose` c `compose` d) == identity where+  a = u // v+  b = v // w+  c = w // z+  d = z // u++prop_positive_product :: T -> T -> Bool+prop_positive_product x y = isPositive (positive x `compose` positive y)++prop_reduce_composition :: Unreduced -> Unreduced -> Bool+prop_reduce_composition (Unreduced x) (Unreduced y) = lhs == rhs where+  lhs = reduce (x `composeDontReduce` y)+  rhs = compose (reduce x) (reduce y)++prop_reduce_inverse :: Unreduced -> Bool+prop_reduce_inverse (Unreduced x) = lhs == rhs where+  lhs = reduce (inverse x)+  rhs = inverse (reduce x)++--------------------------------------------------------------------------------+