diff --git a/HaskellForMaths.cabal b/HaskellForMaths.cabal --- a/HaskellForMaths.cabal +++ b/HaskellForMaths.cabal @@ -1,5 +1,5 @@ Name: HaskellForMaths - Version: 0.4.3 + Version: 0.4.4 Category: Math Description: A library of maths code in the areas of combinatorics, group theory, commutative algebra, and non-commutative algebra. The library is mainly intended as an educational resource, but does have efficient implementations of several fundamental algorithms. Synopsis: Combinatorics, group theory, commutative algebra, non-commutative algebra @@ -29,16 +29,19 @@ Math/Test/TAlgebras/TOctonions.hs Math/Test/TAlgebras/TMatrix.hs Math/Test/TAlgebras/TGroupAlgebra.hs - Math/Test/TCombinatorics/TPoset.hs + Math/Test/TCombinatorics/TCombinatorialHopfAlgebra.hs Math/Test/TCombinatorics/TDigraph.hs Math/Test/TCombinatorics/TFiniteGeometry.hs Math/Test/TCombinatorics/TGraphAuts.hs Math/Test/TCombinatorics/TIncidenceAlgebra.hs Math/Test/TCombinatorics/TMatroid.hs + Math/Test/TCombinatorics/TPoset.hs Math/Test/TCommutativeAlgebra/TPolynomial.hs Math/Test/TCommutativeAlgebra/TGroebnerBasis.hs Math/Test/TCore/TField.hs + Math/Test/TCore/TUtils.hs Math/Test/TNumberTheory/TPrimeFactor.hs + Math/Test/TNumberTheory/TQuadraticField.hs Math/Test/TProjects/TMiniquaternionGeometry.hs Library @@ -55,6 +58,7 @@ Math.Algebras.Octonions, Math.Algebras.Quaternions, Math.Algebras.Structures, Math.Algebras.TensorAlgebra, Math.Algebras.TensorProduct, Math.Algebras.VectorSpace, + Math.Combinatorics.CombinatorialHopfAlgebra, Math.Combinatorics.Graph, Math.Combinatorics.GraphAuts, Math.Combinatorics.StronglyRegularGraph, Math.Combinatorics.Design, Math.Combinatorics.FiniteGeometry, Math.Combinatorics.Hypergraph, Math.Combinatorics.LatinSquares, Math.Combinatorics.Poset, Math.Combinatorics.IncidenceAlgebra, @@ -62,7 +66,7 @@ Math.Common.IntegerAsType, Math.Common.ListSet, Math.CommutativeAlgebra.Polynomial, Math.CommutativeAlgebra.GroebnerBasis, Math.Core.Utils, Math.Core.Field, - Math.NumberTheory.Prime, Math.NumberTheory.Factor, + Math.NumberTheory.Prime, Math.NumberTheory.Factor, Math.NumberTheory.QuadraticField, Math.Projects.RootSystem, Math.Projects.Rubik, Math.Projects.MiniquaternionGeometry, Math.Projects.ChevalleyGroup.Classical, Math.Projects.ChevalleyGroup.Exceptional, diff --git a/Math/Algebra/Group/PermutationGroup.hs b/Math/Algebra/Group/PermutationGroup.hs --- a/Math/Algebra/Group/PermutationGroup.hs +++ b/Math/Algebra/Group/PermutationGroup.hs @@ -81,7 +81,8 @@ cycleOf' y ys = let y' = y .^ g in if y' == x then reverse (y:ys) else cycleOf' y' (y:ys) instance (Ord a, Show a) => Show (Permutation a) where - show g = show (toCycles g) + show g | g == 1 = "1" + | otherwise = show (toCycles g) parity g = let cs = toCycles g in (length (concat cs) - length cs) `mod` 2 -- parity' g = length (filter (even . length) $ toCycles g) `mod` 2 diff --git a/Math/Algebras/GroupAlgebra.hs b/Math/Algebras/GroupAlgebra.hs --- a/Math/Algebras/GroupAlgebra.hs +++ b/Math/Algebras/GroupAlgebra.hs @@ -10,61 +10,71 @@ -- would be entered as @p [[1,2,3],[4,5]]@, and displayed as [[1,2,3],[4,5]]. -- -- Given a field K and group G, the group algebra KG is the free K-vector space over the elements of G. --- Elements of the group algebra consists of arbitrary K-linear combinations of elements of G. +-- Elements of the group algebra consist of arbitrary K-linear combinations of elements of G. -- For example, @p [[1,2,3]] + 2 * p [[1,2],[3,4]]@ -module Math.Algebras.GroupAlgebra where +module Math.Algebras.GroupAlgebra (GroupAlgebra, p) where import Math.Core.Field -import Math.Core.Utils +import Math.Core.Utils hiding (elts) import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures import Math.Algebra.Group.PermutationGroup hiding (p, action) -import qualified Math.Algebra.Group.PermutationGroup as P +-- import qualified Math.Algebra.Group.PermutationGroup as P -import Math.Algebra.LinearAlgebra hiding (inverse, (*>) ) +import Math.Algebra.LinearAlgebra (solveLinearSystem) -- hiding (inverse, (*>) ) import Math.CommutativeAlgebra.Polynomial import Math.CommutativeAlgebra.GroebnerBasis +type GroupAlgebra k = Vect k (Permutation Int) + +instance (Eq k, Num k) => Algebra k (Permutation Int) where + unit x = x *> return 1 + mult = nf . fmap (\(g,h) -> g*h) + +{- instance Mon (Permutation Int) where munit = 1 mmult = (*) -type GroupAlgebra k = Vect k (Permutation Int) - -- Monoid Algebra instance instance (Eq k, Num k) => Algebra k (Permutation Int) where - unit 0 = zero -- V [] - unit x = V [(munit,x)] - mult = nf . fmap (\(a,b) -> a `mmult` b) + unit x = x *> return munit + mult = nf . fmap (\(g,h) -> g `mmult` h) +-} -- Set Coalgebra instance -- instance SetCoalgebra (Permutation Int) where {} instance (Eq k, Num k) => Coalgebra k (Permutation Int) where - counit (V ts) = sum [x | (m,x) <- ts] -- trace - comult = fmap (\m -> (m,m)) -- diagonal + -- counit (V ts) = sum [x | (g,x) <- ts] -- trace + counit = unwrap . linear counit' where counit' g = 1 -- trace + comult = fmap (\g -> (g,g)) -- diagonal instance (Eq k, Num k) => Bialgebra k (Permutation Int) where {} -- should check that the algebra and coalgebra structures are compatible instance (Eq k, Num k) => HopfAlgebra k (Permutation Int) where - antipode (V ts) = nf $ V [(g^-1,x) | (g,x) <- ts] + antipode = nf . fmap inverse + -- antipode (V ts) = nf $ V [(g^-1,x) | (g,x) <- ts] -- |Construct a permutation, as an element of the group algebra, from a list of cycles. -- For example, @p [[1,2],[3,4,5]]@ constructs the permutation (1 2)(3 4 5), which is displayed -- as [[1,2],[3,4,5]]. p :: [[Int]] -> GroupAlgebra Q -p cs = return $ P.p cs +p = return . fromCycles instance (Eq k, Num k) => Module k (Permutation Int) Int where action = nf . fmap (\(g,x) -> x .^ g) +instance (Eq k, Num k) => Module k (Permutation Int) [Int] where + action = nf . fmap (\(g,xs) -> xs -^ g) + -- use *. instead -- r *> m = action (r `te` m) @@ -73,7 +83,7 @@ -- Find the inverse of a group algebra element using Groebner basis techniques -- This is overkill, but it was what I had to hand at first inv x@(V ts) = - let gs = P.elts $ map fst $ terms x -- all elements in the group generated by the terms + let gs = elts $ map fst $ terms x -- all elements in the group generated by the terms cs = map (glexvar . X) gs x' = V $ map (\(g,c) -> (g, unit c)) ts one = x' * (V $ zip gs cs) @@ -86,27 +96,26 @@ -- sum [-c *> p g | V [ (Glex (M 1 [(X g, 1)]), 1), (Glex (M 0 []), c) ] <- solution] -- should extract the solution into a group algebra element, but having trouble getting types right --- The following code can be made to work over an arbitrary field by uncommenting the commented code +-- The following code can be made to work over an arbitrary field by using ScopedTypeVariables and var instead of glexvar. -- However, we should then probably also change the signature of p to p :: Fractional k => [[Int]] -> GroupAlgebra k --- instance Fractional k => HasInverses (GroupAlgebra k) where -- |Note that the inverse of a group algebra element can only be efficiently calculated -- if the group generated by the non-zero terms is very small (eg \<100 elements). instance HasInverses (GroupAlgebra Q) where inverse x@(V ts) = - let gs = P.elts $ map fst $ terms x -- all elements in the group generated by the terms - -- cs = map (var . X) gs :: [Vect k (Glex (X (Permutation Int)))] - cs = map (glexvar . X) gs - x' = V $ map (\(g,c) -> (g, unit c)) ts - one = x' * (V $ zip gs cs) - m = [ [coeff (mvar (X j)) c | j <- gs] | i <- gs, let c = coeff i one] - b = 1 : replicate (length gs - 1) 0 - in case solveLinearSystem m b of + let gs = elts $ map fst ts -- all elements in the group generated by the terms + n = length gs + y = V $ zip gs $ map (glexvar . X) [1..n] -- x1*1+x2*g2+...+xn*gn + x' = V $ map (\(g,c) -> (g, unit c)) ts -- lift the coefficients in x into the polynomial algebra + one = x' * y + m = [ [coeff (mvar (X j)) c | j <- [1..n]] | i <- gs, let c = coeff i one] -- matrix of the linear system + b = 1 : replicate (n-1) 0 + in case solveLinearSystem m b of -- find v such that m v == b - ie find the values of x1, x2, ... xn Just v -> nf $ V $ zip gs v Nothing -> error "GroupAlgebra.inverse: not invertible" maybeInverse x@(V ts) = - let gs = P.elts $ map fst $ terms x -- all elements in the group generated by the terms + let gs = elts $ map fst $ terms x -- all elements in the group generated by the terms cs = map (glexvar . X) gs x' = V $ map (\(g,c) -> (g, unit c)) ts one = x' * (V $ zip gs cs) diff --git a/Math/Algebras/Structures.hs b/Math/Algebras/Structures.hs --- a/Math/Algebras/Structures.hs +++ b/Math/Algebras/Structures.hs @@ -45,7 +45,7 @@ instance (Eq k, Num k, Eq b, Ord b, Show b, Algebra k b) => Num (Vect k b) where x+y = x <+> y - negate x = neg x + negate x = negatev x -- negate (V ts) = V $ map (\(b,x) -> (b, negate x)) ts x*y = mult (x `te` y) fromInteger n = unit (fromInteger n) diff --git a/Math/Algebras/VectorSpace.hs b/Math/Algebras/VectorSpace.hs --- a/Math/Algebras/VectorSpace.hs +++ b/Math/Algebras/VectorSpace.hs @@ -8,8 +8,6 @@ import qualified Data.List as L import qualified Data.Set as S -- only needed for toSet --- toSet = S.toList . S.fromList - infixr 7 *> infixl 7 <* infixl 6 <+>, <-> @@ -42,8 +40,12 @@ terms (V ts) = ts +-- |Return the coefficient of the specified basis element in a vector coeff b v = sum [k | (b',k) <- terms v, b' == b] +-- |Remove the term for a specified basis element from a vector +removeTerm b v = v <-> coeff b v *> return b + -- Deprecated zero = V [] @@ -71,13 +73,16 @@ sumv :: (Ord b, Eq k, Num k) => [Vect k b] -> Vect k b sumv = foldl (<+>) zerov --- |Negation of vector -neg :: (Eq k, Num k) => Vect k b -> Vect k b +-- Deprecated neg (V ts) = V $ map (\(b,x) -> (b,-x)) ts +-- |Negation of a vector +negatev :: (Eq k, Num k) => Vect k b -> Vect k b +negatev (V ts) = V $ map (\(b,x) -> (b,-x)) ts + -- |Subtraction of vectors (<->) :: (Ord b, Eq k, Num k) => Vect k b -> Vect k b -> Vect k b -(<->) u v = u <+> neg v +(<->) u v = u <+> negatev v -- |Scalar multiplication (on the left) smultL :: (Eq k, Num k) => k -> Vect k b -> Vect k b diff --git a/Math/Combinatorics/CombinatorialHopfAlgebra.hs b/Math/Combinatorics/CombinatorialHopfAlgebra.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/CombinatorialHopfAlgebra.hs @@ -0,0 +1,660 @@ +-- Copyright (c) 2012, David Amos. All rights reserved. + +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, NoMonomorphismRestriction, ScopedTypeVariables, DeriveFunctor #-} + +-- |A module defining the following Combinatorial Hopf Algebras, together with coalgebra or Hopf algebra morphisms between them: +-- +-- * SSym, the Malvenuto-Reutnenauer Hopf algebra of permutations +-- +-- * YSym, the (dual of the) Loday-Ronco Hopf algebra of binary trees +-- +-- * QSym, the Hopf algebra of quasi-symmetric functions (having a basis indexed by compositions) +-- +-- * Sh, the Shuffle Hopf algebra +module Math.Combinatorics.CombinatorialHopfAlgebra where + +-- Sources: + +-- Structure of the Malvenuto-Reutenauer Hopf algebra of permutations +-- Marcelo Aguiar and Frank Sottile +-- http://www.math.tamu.edu/~sottile/research/pdf/SSym.pdf + +-- Structure of the Loday-Ronco Hopf algebra of trees +-- Marcelo Aguiar and Frank Sottile +-- http://www.math.tamu.edu/~sottile/research/pdf/Loday.pdf + +-- Hopf Structures on the Multiplihedra +-- Stefan Forcey, Aaron Lauve and Frank Sottile +-- http://www.math.tamu.edu/~sottile/research/pdf/MSym.pdf + + +import Data.List as L +import Data.Maybe (fromJust) +import qualified Data.Set as S + +import Math.Core.Field +import Math.Core.Utils + +import Math.Algebras.VectorSpace hiding (E) +import Math.Algebras.TensorProduct +import Math.Algebras.Structures + +import Math.Combinatorics.Poset + +-- import Math.Algebra.Group.PermutationGroup +import Math.CommutativeAlgebra.Polynomial + + +-- SHUFFLE ALGEBRA +-- This is just the tensor algebra, but with shuffle product (and deconcatenation coproduct) + +-- |A basis for the shuffle algebra. As a vector space, the shuffle algebra is identical to the tensor algebra. +-- However, we consider a different algebra structure, based on the shuffle product. Together with the +-- deconcatenation coproduct, this leads to a Hopf algebra structure. +newtype Shuffle a = Sh [a] deriving (Eq,Ord,Show) + +-- |Construct a basis element of the shuffle algebra +sh :: [a] -> Vect Q (Shuffle a) +sh = return . Sh + +shuffles (x:xs) (y:ys) = map (x:) (shuffles xs (y:ys)) ++ map (y:) (shuffles (x:xs) ys) +shuffles xs [] = [xs] +shuffles [] ys = [ys] + +instance (Eq k, Num k, Ord a) => Algebra k (Shuffle a) where + unit x = x *> return (Sh []) + mult = linear mult' + where mult' (Sh xs, Sh ys) = sumv [return (Sh zs) | zs <- shuffles xs ys] + +deconcatenations xs = zip (inits xs) (tails xs) + +instance (Eq k, Num k, Ord a) => Coalgebra k (Shuffle a) where + counit = unwrap . linear counit' where counit' (Sh xs) = if null xs then 1 else 0 + comult = linear comult' + where comult' (Sh xs) = sumv [return (Sh us, Sh vs) | (us, vs) <- deconcatenations xs] + +instance (Eq k, Num k, Ord a) => Bialgebra k (Shuffle a) where {} + +instance (Eq k, Num k, Ord a) => HopfAlgebra k (Shuffle a) where + antipode = linear (\(Sh xs) -> (-1)^length xs *> return (Sh (reverse xs))) + + +-- SSYM: PERMUTATIONS +-- (This is permutations considered as combinatorial objects rather than as algebraic objects) + +-- Permutations with shifted shuffle product +-- This is the Malvenuto-Reutenauer Hopf algebra of permutations, SSym. +-- It is neither commutative nor co-commutative + +-- ssymF xs is the fundamental basis F_xs (Aguiar and Sottile) + +-- |The fundamental basis for the Malvenuto-Reutenauer Hopf algebra of permutations, SSym. +newtype SSymF = SSymF [Int] deriving (Eq) + +instance Ord SSymF where + compare (SSymF xs) (SSymF ys) = compare (length xs, xs) (length ys, ys) + +instance Show SSymF where + show (SSymF xs) = "F " ++ show xs + +-- |Construct a fundamental basis element in SSym. +-- The list of ints must be a permutation of [1..n], eg [1,2], [3,4,2,1]. +ssymF :: [Int] -> Vect Q SSymF +ssymF xs | L.sort xs == [1..n] = return (SSymF xs) + | otherwise = error "Not a permutation of [1..n]" + where n = length xs + +-- so this is a candidate mult. It is associative and SSymF [] is obviously a left and right identity +-- (need quickcheck properties to prove that) +shiftedConcat (SSymF xs) (SSymF ys) = let k = length xs in SSymF (xs ++ map (+k) ys) + +prop_Associative f (x,y,z) = f x (f y z) == f (f x y) z + +-- > quickCheck (prop_Associative shiftedConcat) +-- +++ OK, passed 100 tests. + + +instance (Eq k, Num k) => Algebra k SSymF where + unit x = x *> return (SSymF []) + mult = linear mult' + where mult' (SSymF xs, SSymF ys) = + let k = length xs + in sumv [return (SSymF zs) | zs <- shuffles xs (map (+k) ys)] + + +-- standard permutation, also called flattening, eg [6,2,5] -> [3,1,2] +flatten xs = let mapping = zip (L.sort xs) [1..] + in [y | x <- xs, let Just y = lookup x mapping] + +instance (Eq k, Num k) => Coalgebra k SSymF where + counit = unwrap . linear counit' where counit' (SSymF xs) = if null xs then 1 else 0 + comult = linear comult' + where comult' (SSymF xs) = sumv [return (SSymF (st us), SSymF (st vs)) | (us, vs) <- deconcatenations xs] + st = flatten + +instance (Eq k, Num k) => Bialgebra k SSymF where {} + +instance (Eq k, Num k) => HopfAlgebra k SSymF where + antipode = linear antipode' + where antipode' (SSymF []) = return (SSymF []) + antipode' x@(SSymF xs) = (negatev . mult . (id `tf` antipode) . removeTerm (SSymF [],x) . comult . return) x + -- This expression for antipode is derived from mult . (id `tf` antipode) . comult == unit . counit + -- It's possible because this is a graded, connected Hopf algebra. (connected means the counit is projection onto the grade 0 part) +-- It would be nicer to have an explicit expression for antipode. +{- +instance (Eq k, Num k) => HopfAlgebra k SSymF where + antipode = linear antipode' + where antipode' (SSymF v) = sumv [lambda v w *> return (SSymF w) | w <- L.permutations v] + lambda v w = length [s | s <- powerset [1..n-1], odd (length s), descentSet (w^-1 * v_s) `isSubset` s] + - length [s | s <- powerset [1..n-1], even (length s), descentSet (w^-1 * v_s) `isSubset` s] +-} + +-- |An alternative \"monomial\" basis for the Malvenuto-Reutenauer Hopf algebra of permutations, SSym. +-- This basis is related to the fundamental basis by Mobius inversion in the poset of permutations with the weak order. +newtype SSymM = SSymM [Int] deriving (Eq) + +instance Ord SSymM where + compare (SSymM xs) (SSymM ys) = compare (length xs, xs) (length ys, ys) + +instance Show SSymM where + show (SSymM xs) = "M " ++ show xs + +-- |Construct a monomial basis element in SSym. +-- The list of ints must be a permutation of [1..n], eg [1,2], [3,4,2,1]. +ssymM :: [Int] -> Vect Q SSymM +ssymM xs | L.sort xs == [1..n] = return (SSymM xs) + | otherwise = error "Not a permutation of [1..n]" + where n = length xs + +inversions xs = let ixs = zip [1..] xs + in [(i,j) | ((i,xi),(j,xj)) <- pairs ixs, xi > xj] + +weakOrder xs ys = inversions xs `isSubsetAsc` inversions ys + +mu (set,po) x y = mu' x y where + mu' x y | x == y = 1 + | po x y = negate $ sum [mu' x z | z <- set, po x z, po z y, z /= y] + | otherwise = 0 + +-- |Convert an element of SSym represented in the monomial basis to the fundamental basis +toSSymF :: (Eq k, Num k) => Vect k SSymM -> Vect k SSymF +toSSymF = linear toSSymF' + where toSSymF' (SSymM u) = sumv [mu (set,po) u v *> return (SSymF v) | v <- set, po u v] + where set = L.permutations u + po = weakOrder + +-- |Convert an element of SSym represented in the fundamental basis to the monomial basis +toSSymM :: (Eq k, Num k) => Vect k SSymF -> Vect k SSymM +toSSymM = linear toSSymM' + where toSSymM' (SSymF u) = sumv [return (SSymM v) | v <- set, po u v] + where set = L.permutations u + po = weakOrder + +-- (p,q)-shuffles: permutations of [1..p+q] having at most one descent, at position p +-- denoted S^{(p,q)} in Aguiar&Sottile +-- (Grassmannian permutations?) +-- pqShuffles p q = [u++v | u <- combinationsOf p [1..n], let v = [1..n] `diffAsc` u] where n = p+q + +-- The inverse of a (p,q)-shuffle. +-- The special form of (p,q)-shuffles makes an O(n) algorithm possible +-- pqInverse :: Int -> Int -> [Int] -> [Int] +{- +-- incorrect +pqInverse p q xs = pqInverse' [1..p] [p+1..p+q] xs + where pqInverse' (l:ls) (r:rs) (x:xs) = + if x <= p then l : pqInverse' ls (r:rs) xs else r : pqInverse' (l:ls) rs xs + pqInverse' ls rs _ = ls ++ rs -- one of them is null +-} +-- pqInverseShuffles p q = shuffles [1..p] [p+1..p+q] + + +instance (Eq k, Num k) => Algebra k SSymM where + unit x = x *> return (SSymM []) + mult = toSSymM . mult . (toSSymF `tf` toSSymF) + +{- +mult2 = linear mult' + where mult' (SSymM u, SSymM v) = sumv [alpha u v w *> return (SSymM w) | w <- L.permutations [1..p+q] ] + where p = length u; q = length v + +alpha u v w = length [z | z <- pqInverseShuffles p q, let uv = shiftedConcat u v, + uv * z `weakOrder` w, u and v are maximal, ie no transposition of adjacents in either also works] + where p = length u + q = length v +-- so we need to define (*) for permutations in row form +-} + +instance (Eq k, Num k) => Coalgebra k SSymM where + counit = unwrap . linear counit' where counit' (SSymM xs) = if null xs then 1 else 0 + -- comult = (toSSymM `tf` toSSymM) . comult . toSSymF + comult = linear comult' + where comult' (SSymM xs) = sumv [return (SSymM (flatten ys), SSymM (flatten zs)) + | (ys,zs) <- deconcatenations xs, + minimum (infinity:ys) > maximum (0:zs)] -- ie deconcatenations at a global descent + infinity = maxBound :: Int + +instance (Eq k, Num k) => Bialgebra k SSymM where {} + +instance (Eq k, Num k) => HopfAlgebra k SSymM where + antipode = toSSymM . antipode . toSSymF + + +-- YSYM: PLANAR BINARY TREES +-- These are really rooted planar binary trees. +-- It's because they're planar that we can distinguish left and right child branches. +-- (Non-planar would be if we considered trees where left and right children are swapped relative to one another as the same tree) +-- It is neither commutative nor co-commutative + +-- |A type for (rooted) planar binary trees. The basis elements of the Loday-Ronco Hopf algebra are indexed by these. +-- +-- Although the trees are labelled, we're really only interested in the shapes of the trees, and hence in the type PBT (). +-- The Algebra, Coalgebra and HopfAlgebra instances all ignore the labels. +-- However, it is convenient to allow labels, as they can be useful for seeing what is going on, and they also make it possible +-- to define various ways to create trees from lists of labels. +data PBT a = T (PBT a) a (PBT a) | E deriving (Eq, Show, Functor) + +instance Ord a => Ord (PBT a) where + compare u v = compare (shapeSignature u, prefix u) (shapeSignature v, prefix v) + +-- |The fundamental basis for (the dual of) the Loday-Ronco Hopf algebra of binary trees, YSym. +newtype YSymF a = YSymF (PBT a) deriving (Eq, Ord, Functor) + +instance Show a => Show (YSymF a) where + show (YSymF t) = "F(" ++ show t ++ ")" + +-- |Construct the element of YSym in the fundamental basis indexed by the given tree +ysymF :: PBT a -> Vect Q (YSymF a) +ysymF t = return (YSymF t) + +{- +depth (T l x r) = 1 + max (depth l) (depth r) +depth E = 0 +-} +nodecount (T l x r) = 1 + nodecount l + nodecount r +nodecount E = 0 + +-- in fact leafcount t = 1 + nodecount t (easiest to see with a picture) +leafcount (T l x r) = leafcount l + leafcount r +leafcount E = 1 + +prefix E = [] +prefix (T l x r) = x : prefix l ++ prefix r + +-- The shape signature uniquely identifies the shape of a tree. +-- Trees with distinct shapes have distinct signatures. +-- In addition, if sorting on shapeSignature, smaller trees sort before larger trees, +-- and leftward leaning trees sort before rightward leaning trees +shapeSignature t = shapeSignature' (nodeCountTree t) + where shapeSignature' E = [0] -- not [], otherwise we can't distinguish T (T E () E) () E from T E () (T E () E) + shapeSignature' (T l x r) = x : shapeSignature' r ++ shapeSignature' l + +nodeCountTree E = E +nodeCountTree (T l _ r) = T l' n r' + where l' = nodeCountTree l + r' = nodeCountTree r + n = 1 + (case l' of E -> 0; T _ lc _ -> lc) + (case r' of E -> 0; T _ rc _ -> rc) + +leafCountTree E = E +leafCountTree (T l _ r) = T l' n r' + where l' = leafCountTree l + r' = leafCountTree r + n = (case l' of E -> 1; T _ lc _ -> lc) + (case r' of E -> 1; T _ rc _ -> rc) + +-- A tree that counts nodes in left and right subtrees +lrCountTree E = E +lrCountTree (T l _ r) = T l' (lc,rc) r' + where l' = lrCountTree l + r' = lrCountTree r + lc = case l' of E -> 0; T _ (llc,lrc) _ -> 1 + llc + lrc + rc = case r' of E -> 0; T _ (rlc,rrc) _ -> 1 + rlc + rrc + +shape :: PBT a -> PBT () +shape t = fmap (\_ -> ()) t + +-- label the nodes of a tree in infix order while preserving its shape +numbered t = numbered' 1 t + where numbered' _ E = E + numbered' i (T l x r) = let k = nodecount l in T (numbered' i l) (i+k) (numbered' (i+k+1) r) +-- could also pair the numbers with the input labels + + +splits E = [(E,E)] +splits (T l x r) = [(u, T v x r) | (u,v) <- splits l] ++ [(T l x u, v) | (u,v) <- splits r] + +instance (Eq k, Num k, Ord a) => Coalgebra k (YSymF a) where + counit = unwrap . linear counit' where counit' (YSymF E) = 1; counit' (YSymF (T _ _ _)) = 0 + comult = linear comult' + where comult' (YSymF t) = sumv [return (YSymF u, YSymF v) | (u,v) <- splits t] + -- using sumv rather than sum to avoid requiring Show a + -- so again this is a kind of deconcatenation coproduct + +multisplits 1 t = [ [t] ] +multisplits 2 t = [ [u,v] | (u,v) <- splits t ] +multisplits n t = [ u:ws | (u,v) <- splits t, ws <- multisplits (n-1) v ] + +graft [t] E = t +graft ts (T l x r) = let (ls,rs) = splitAt (leafcount l) ts + in T (graft ls l) x (graft rs r) + +instance (Eq k, Num k, Ord a) => Algebra k (YSymF a) where + unit x = x *> return (YSymF E) + mult = linear mult' + where mult' (YSymF t, YSymF u) = sumv [return (YSymF (graft ts u)) | ts <- multisplits (leafcount u) t] + -- using sumv rather than sum to avoid requiring Show a + +instance (Eq k, Num k, Ord a) => Bialgebra k (YSymF a) where {} + +instance (Eq k, Num k, Ord a) => HopfAlgebra k (YSymF a) where + antipode = linear antipode' + where antipode' (YSymF E) = return (YSymF E) + antipode' x = (negatev . mult . (id `tf` antipode) . removeTerm (YSymF E,x) . comult . return) x + + +-- |An alternative "monomial" basis for (the dual of) the Loday-Ronco Hopf algebra of binary trees, YSym. +newtype YSymM = YSymM (PBT ()) deriving (Eq, Ord) + +instance Show YSymM where + show (YSymM t) = "M(" ++ show t ++ ")" + +-- |Construct the element of YSym in the monomial basis indexed by the given tree +ysymM :: PBT () -> Vect Q YSymM +ysymM t = return (YSymM t) + + +trees 0 = [E] +trees n = [T l () r | i <- [0..n-1], l <- trees (n-1-i), r <- trees i] + +-- |The covering relation for the Tamari partial order on binary trees +covers E = [] +covers (T t@(T u x v) y w) = [T t' y w | t' <- covers t] + ++ [T t y w' | w' <- covers w] + ++ [T u y (T v x w)] + -- Note that this preserves the descending property, and hence the bijection with permutations + -- If we were to swap x and y, we would preserve the binary search tree property instead (if our trees had it) +covers (T E x u) = [T E x u' | u' <- covers u] + +-- |The up-set of a binary tree in the Tamari partial order +tamariUpSet t = upSet' [] [t] + where upSet' interior boundary = + if null boundary + then interior + else let interior' = setUnionAsc interior boundary + boundary' = toSet $ concatMap covers boundary + in upSet' interior' boundary' + +-- tamariOrder1 u v = v `elem` upSet u + +tamariOrder u v = weakOrder (minPerm u) (minPerm v) +-- It should be possible to unpack this to be a statement purely about trees, but probably not worth + +-- |Convert an element of YSym represented in the monomial basis to the fundamental basis +toYSymF :: (Eq k, Num k) => Vect k YSymM -> Vect k (YSymF ()) +toYSymF = linear toYSymF' + where toYSymF' (YSymM t) = sumv [mu (set,po) t s *> return (YSymF s) | s <- set] + where po = tamariOrder + set = tamariUpSet t -- [s | s <- trees (nodecount t), t `tamariOrder` s] + +-- |Convert an element of YSym represented in the fundamental basis to the monomial basis +toYSymM :: (Eq k, Num k) => Vect k (YSymF ()) -> Vect k YSymM +toYSymM = linear toYSymM' + where toYSymM' (YSymF t) = sumv [return (YSymM s) | s <- tamariUpSet t] + -- sumv [return (YSymM s) | s <- trees (nodecount t), t `tamariOrder` s] + + +instance (Eq k, Num k) => Algebra k YSymM where + unit x = x *> return (YSymM E) + mult = toYSymM . mult . (toYSymF `tf` toYSymF) + +instance (Eq k, Num k) => Coalgebra k YSymM where + counit = unwrap . linear counit' where counit' (YSymM E) = 1; counit' (YSymM (T _ _ _)) = 0 + -- comult = (toYSymM `tf` toYSymM) . comult . toYSymF + comult = linear comult' + where comult' (YSymM t) = sumv [return (YSymM r, YSymM s) | (rs,ss) <- deconcatenations (underDecomposition t), + let r = foldl under E rs, let s = foldl under E ss] + + +instance (Eq k, Num k) => Bialgebra k YSymM where {} + +instance (Eq k, Num k) => HopfAlgebra k YSymM where + antipode = toYSymM . antipode . toYSymF + + +-- QSYM: QUASI-SYMMETRIC FUNCTIONS +-- The following is the Hopf algebra QSym of quasi-symmetric functions +-- using the monomial basis (indexed by compositions) + +-- compositions in ascending order +-- might be better to use bfs to get length order +-- |List the compositions of an integer n. For example, the compositions of 4 are [[1,1,1,1],[1,1,2],[1,2,1],[1,3],[2,1,1],[2,2],[3,1],[4]] +compositions :: Int -> [[Int]] +compositions 0 = [[]] +compositions n = [i:is | i <- [1..n], is <- compositions (n-i)] + +-- can retrieve subsets of [1..n-1] from compositions n as follows +-- > map (tail . scanl (+) 0) (map init $ compositions 4) +-- [[],[3],[2],[2,3],[1],[1,3],[1,2],[1,2,3]] + +-- quasi shuffles of two compositions +quasiShuffles :: [Int] -> [Int] -> [[Int]] +quasiShuffles (x:xs) (y:ys) = map (x:) (quasiShuffles xs (y:ys)) ++ + map (y:) (quasiShuffles (x:xs) ys) ++ + map ((x+y):) (quasiShuffles xs ys) +quasiShuffles xs [] = [xs] +quasiShuffles [] ys = [ys] + + +-- |A type for the monomial basis for the quasi-symmetric functions, indexed by compositions. +newtype QSymM = QSymM [Int] deriving (Eq) + +instance Ord QSymM where + compare (QSymM xs) (QSymM ys) = compare (length xs, xs) (length ys, ys) + +instance Show QSymM where + show (QSymM xs) = "M " ++ show xs + +-- |Construct the element of QSym in the monomial basis indexed by the given composition +qsymM :: [Int] -> Vect Q QSymM +qsymM = return . QSymM + +instance (Eq k, Num k) => Algebra k QSymM where + unit x = x *> return (QSymM []) + mult = linear mult' + where mult' (QSymM alpha, QSymM beta) = sum [return (QSymM gamma) | gamma <- quasiShuffles alpha beta] + +instance (Eq k, Num k) => Coalgebra k QSymM where + counit = unwrap . linear counit' where counit' (QSymM alpha) = if null alpha then 1 else 0 + comult = linear comult' where + comult' (QSymM gamma) = sum [return (QSymM alpha, QSymM beta) | (alpha,beta) <- deconcatenations gamma] + +instance (Eq k, Num k) => Bialgebra k QSymM where {} + +instance (Eq k, Num k) => HopfAlgebra k QSymM where + antipode = linear antipode' where + antipode' (QSymM alpha) = (-1)^length alpha * sum [return (QSymM (reverse beta)) | beta <- coarsenings alpha] + +coarsenings (x1:x2:xs) = coarsenings ((x1+x2):xs) ++ map (x1:) (coarsenings (x2:xs)) +coarsenings xs = [xs] -- for xs a singleton or null + +refinements (x:xs) = [y++ys | y <- compositions x, ys <- refinements xs] +refinements [] = [[]] + + +newtype QSymF = QSymF [Int] deriving (Eq) + +instance Ord QSymF where + compare (QSymF xs) (QSymF ys) = compare (length xs, xs) (length ys, ys) + +instance Show QSymF where + show (QSymF xs) = "F " ++ show xs + +-- |Construct the element of QSym in the fundamental basis indexed by the given composition +qsymF :: [Int] -> Vect Q QSymF +qsymF = return . QSymF + +-- |Convert an element of QSym represented in the monomial basis to the fundamental basis +toQSymF :: (Eq k, Num k) => Vect k QSymM -> Vect k QSymF +toQSymF = linear toQSymF' + where toQSymF' (QSymM alpha) = sumv [(-1) ^ (length beta - length alpha) *> return (QSymF beta) | beta <- refinements alpha] + +-- |Convert an element of QSym represented in the fundamental basis to the monomial basis +toQSymM :: (Eq k, Num k) => Vect k QSymF -> Vect k QSymM +toQSymM = linear toQSymM' + where toQSymM' (QSymF alpha) = sumv [return (QSymM beta) | beta <- refinements alpha] -- ie beta <- up-set of alpha + +instance (Eq k, Num k) => Algebra k QSymF where + unit x = x *> return (QSymF []) + mult = toQSymF . mult . (toQSymM `tf` toQSymM) + +instance (Eq k, Num k) => Coalgebra k QSymF where + counit = unwrap . linear counit' where counit' (QSymF xs) = if null xs then 1 else 0 + comult = (toQSymF `tf` toQSymF) . comult . toQSymM + +instance (Eq k, Num k) => Bialgebra k QSymF where {} + +instance (Eq k, Num k) => HopfAlgebra k QSymF where + antipode = toQSymF . antipode . toQSymM + + +-- QUASI-SYMMETRIC POLYNOMIALS + +-- the above induces Hopf algebra structure on quasi-symmetric functions via +-- m_alpha -> sum [product (zipWith (^) (map x_ is) alpha | is <- combinationsOf k [] ] where k = length alpha + +xvars n = [glexvar ("x" ++ show i) | i <- [1..n] ] + +-- compare with Reynolds operator +-- so a basis for quasi-symmetric functions over xvars n consists of [quasiSymM xs is | m <- [0..], is <- compositions m] +quasiSymM xs is = sum [product (zipWith (^) xs' is) | xs' <- combinationsOf r xs] + where r = length is + + +-- MAPS BETWEEN (POSETS AND) HOPF ALGEBRAS + +-- A descending tree is one in which a child is always less than a parent. +descendingTree [] = E +descendingTree [x] = T E x E +descendingTree xs = T l x r + where x = maximum xs + (ls,_:rs) = L.break (== x) xs + l = descendingTree ls + r = descendingTree rs +-- This is a bijection from permutations to "ordered trees". +-- It is order-preserving on trees with the same nodecount. +-- We can recover the permutation by reading the node labels in infix order. +-- This is the map called lambda in Loday.pdf + + +-- |A Hopf algebra morphism from SSymF to YSymF +descendingTreeMap :: (Eq k, Num k) => Vect k SSymF -> Vect k (YSymF ()) +descendingTreeMap = nf . fmap (YSymF . shape . descendingTree') + where descendingTree' (SSymF xs) = descendingTree xs +-- This is the map called Lambda in Loday.pdf, or tau in MSym.pdf +-- It is an algebra morphism. + +-- One of the ideas in the MSym paper is to look at the intermediate result (fmap descendingTree' x), +-- which is an "ordered tree", and consider the map as factored through this + +-- The map is surjective but not injective. The fibers tau^-1(t) are intervals in the weak order on permutations + +-- "inverse" for descendingTree +-- These are the maps called gamma in Loday.pdf +minPerm t = minPerm' (lrCountTree t) + where minPerm' E = [] + minPerm' (T l (lc,rc) r) = minPerm' l ++ [lc+rc+1] ++ map (+lc) (minPerm' r) + +maxPerm t = maxPerm' (lrCountTree t) + where maxPerm' E = [] + maxPerm' (T l (lc,rc) r) = map (+rc) (maxPerm' l) ++ [lc+rc+1] ++ maxPerm' r + + +-- The composition of [1..n] obtained by treating each left-facing leaf as a cut +-- Specifically, we visit the nodes in infix order, cutting after a node if it does not have an E as its right child +-- This is the map called L in Loday.pdf +leftLeafComposition E = [] +leftLeafComposition t = cuts $ tail $ leftLeafs t + where leftLeafs (T l x E) = leftLeafs l ++ [False] + leftLeafs (T l x r) = leftLeafs l ++ leftLeafs r + leftLeafs E = [True] + cuts bs = case break id bs of + (ls,r:rs) -> (length ls + 1) : cuts rs + (ls,[]) -> [length ls] + +leftLeafComposition' (YSymF t) = QSymF (leftLeafComposition t) + +-- |A Hopf algebra morphism from YSymF to QSymF +leftLeafCompositionMap :: (Eq k, Num k) => Vect k (YSymF a) -> Vect k QSymF +leftLeafCompositionMap = nf . fmap leftLeafComposition' + + +-- The descent set of a permutation is [i | x_i > x_i+1], where we start the indexing from 1 +descents [] = [] +descents xs = map (+1) $ L.elemIndices True $ zipWith (>) xs (tail xs) + +-- The composition of [1..n] obtained by treating each descent as a cut +descentComposition [] = [] +descentComposition xs = dc $ zipWith (>) xs (tail xs) ++ [False] + where dc bs = case break id bs of + (ls,r:rs) -> (length ls + 1) : dc rs + (ls,[]) -> [length ls] + +-- |A Hopf algebra morphism from SSymF to QSymF +descentMap :: (Eq k, Num k) => Vect k SSymF -> Vect k QSymF +descentMap = nf . fmap (\(SSymF xs) -> QSymF (descentComposition xs)) +-- descentMap == leftLeafCompositionMap . descendingTreeMap + +underComposition (QSymF ps) = foldr under (SSymF []) [SSymF [1..p] | p <- ps] + where under (SSymF xs) (SSymF ys) = let q = length ys + zs = map (+q) xs ++ ys -- so it has a global descent at the split + in SSymF zs +-- This is a poset morphism (indeed, it forms a Galois connection with descentComposition) +-- but it does not extend to a Hopf algebra morphism. +-- (It does extend to a coalgebra morphism.) +-- (It is picking the maximum permutation having a given descent composition, +-- so there's an element of arbitrariness to it.) +-- This is the map called Z (Zeta?) in Loday.pdf + +{- +-- This is O(n^2), whereas an O(n) implementation should be possible +-- Also, we would really like the associated composition (obtained by treating each global descent as a cut)? +globalDescents xs = globalDescents' 0 [] xs + where globalDescents' i ls (r:rs) = (if minimum (infinity:ls) > maximum (0:r:rs) then [i] else []) + ++ globalDescents' (i+1) (r:ls) rs + globalDescents' n _ [] = [n] + infinity = maxBound :: Int +-- The idea is that this leads to a map from SSymM to QSymM + +globalDescentComposition [] = [] +globalDescentComposition (x:xs) = globalDescents' 1 x xs + where globalDescents' i minl (r:rs) = if minl > maximum (r:rs) + then i : globalDescents' 1 r rs + else globalDescents' (i+1) r rs + globalDescents' i _ [] = [i] + +globalDescentMap :: (Eq k, Num k) => Vect k SSymM -> Vect k QSymM +globalDescentMap = nf . fmap (\(SSymM xs) -> QSymM (globalDescentComposition xs)) +-} + +-- A multiplication operation on trees +-- (Connected with their being cofree) +-- (intended to be used as infix) +under E t = t +under (T l x r) t = T l x (under r t) + +isUnderIrreducible (T l x E) = True +isUnderIrreducible _ = False + +underDecomposition (T l x r) = T l x E : underDecomposition r +underDecomposition E = [] + + +-- GHC7.4.1 doesn't like the following type signature - a bug. +-- ysymmToSh :: (Eq k, Num k) => Vect k (YSymM) => Vect k (Shuffle (PBT ())) +ysymmToSh = fmap ysymmToSh' + where ysymmToSh' (YSymM t) = Sh (underDecomposition t) +-- This is a coalgebra morphism (but not an algebra morphism) +-- It shows that YSym is co-free +{- +-- This one not working yet - perhaps it needs an nf, or to go via S/YSymF, or ... +ssymmToSh = nf . fmap ssymmToSh' + where ssymmToSh' (SSymM xs) = (Sh . underDecomposition . shape . descendingTree) xs +-} diff --git a/Math/Combinatorics/Design.hs b/Math/Combinatorics/Design.hs --- a/Math/Combinatorics/Design.hs +++ b/Math/Combinatorics/Design.hs @@ -15,7 +15,7 @@ import Math.Algebra.Group.PermutationGroup hiding (elts, order, isMember) import Math.Algebra.Group.SchreierSims as SS import Math.Combinatorics.Graph as G hiding (to1n, incidenceMatrix) -import Math.Combinatorics.GraphAuts (refine', isSingleton, graphAuts, incidenceAuts) -- , removeGens) +import Math.Combinatorics.GraphAuts (graphAuts, incidenceAuts) -- , removeGens) import Math.Combinatorics.FiniteGeometry -- Cameron & van Lint, Designs, Graphs, Codes and their Links diff --git a/Math/Combinatorics/GraphAuts.hs b/Math/Combinatorics/GraphAuts.hs --- a/Math/Combinatorics/GraphAuts.hs +++ b/Math/Combinatorics/GraphAuts.hs @@ -1,6 +1,11 @@ -- Copyright (c) David Amos, 2009. All rights reserved. -module Math.Combinatorics.GraphAuts where +module Math.Combinatorics.GraphAuts (isVertexTransitive, isEdgeTransitive, + isArcTransitive, is2ArcTransitive, is3ArcTransitive, isnArcTransitive, + isDistanceTransitive, + graphAuts, incidenceAuts, + graphIsos, incidenceIsos, + isGraphIso, isIncidenceIso) where import Data.Either (lefts) import qualified Data.List as L diff --git a/Math/Combinatorics/IncidenceAlgebra.hs b/Math/Combinatorics/IncidenceAlgebra.hs --- a/Math/Combinatorics/IncidenceAlgebra.hs +++ b/Math/Combinatorics/IncidenceAlgebra.hs @@ -5,6 +5,8 @@ module Math.Combinatorics.IncidenceAlgebra where +import Math.Core.Utils + import Math.Combinatorics.Digraph import Math.Combinatorics.Poset @@ -111,14 +113,14 @@ -- |The unit of the incidence algebra of a poset -unitIA :: (Eq k, Num k, Ord t) => Poset t -> Vect k (Interval t) +unitIA :: (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a) unitIA poset@(Poset (set,_)) = sumv [return (Iv poset (x,x)) | x <- set] -basisIA :: Num k => Poset t -> [Vect k (Interval t)] +basisIA :: Num k => Poset a -> [Vect k (Interval a)] basisIA poset = [return (Iv poset xy) | xy <- intervals poset] -- |The zeta function of a poset -zetaIA :: (Eq k, Num k, Ord t) => Poset t -> Vect k (Interval t) +zetaIA :: (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a) zetaIA poset = sumv $ basisIA poset -- Then for example, zeta^2 counts the number of points in each interval @@ -132,7 +134,7 @@ -- calculate the mobius function of a poset, with memoization -- |The Mobius function of a poset -muIA :: (Eq k, Num k, Ord t) => Poset t -> Vect k (Interval t) +muIA :: (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a) muIA poset@(Poset (set,po)) = sumv [mus M.! (x,y) *> return (Iv poset (x,y)) | x <- set, y <- set] where mu (x,y) | x == y = 1 | po x y = negate $ sum [mus M.! (x,z) | z <- set, po x z, po z y, z /= y] @@ -152,7 +154,7 @@ -- Stanley, Enumerative Combinatorics I, p144 -- |The inverse of an element in the incidence algebra of a poset. -- This is only defined for elements which are non-zero on all intervals (x,x) -invIA :: (Eq k, Fractional k, Ord t) => Vect k (Interval t) -> Maybe (Vect k (Interval t)) +invIA :: (Eq k, Fractional k, Ord a) => Vect k (Interval a) -> Maybe (Vect k (Interval a)) invIA f | f == zerov = Nothing -- error "invIA 0" | any (==0) [f' (x,x) | x <- set] = Nothing -- error "invIA: not invertible" | otherwise = Just g @@ -163,23 +165,24 @@ | otherwise = (-1 / f' (x,x)) * sum [f' (x,z) * (g's M.! (z,y)) | z <- interval poset (x,y), x /= z] g's = M.fromList [(xy, g' xy) | xy <- intervals poset] -invIA' f = case invIA f of - Just g -> g - Nothing -> error "invIA': not invertible" +instance (Eq k, Fractional k, Ord a, Show a) => HasInverses (Vect k (Interval a)) where + inverse f = case invIA f of + Just g -> g + Nothing -> error "IncidenceAlgebra.inverse: not invertible" -- Then for example we can count multichains or chains using the incidence algebra - see Stanley -- |A function (ie element of the incidence algebra) that counts the total number of chains in each interval -numChainsIA :: (Ord a) => Poset a -> Vect Q (Interval a) -numChainsIA poset = invIA' (2 *> unitIA poset <-> zetaIA poset) +numChainsIA :: (Ord a, Show a) => Poset a -> Vect Q (Interval a) +numChainsIA poset = (2 *> unitIA poset <-> zetaIA poset)^-1 -- The eta function on intervals (x,y) is 1 if x -< y (y covers x), 0 otherwise etaIA poset = let DG vs es = hasseDigraph poset in sumv [return (Iv poset (x,y)) | (x,y) <- es] -- |A function (ie element of the incidence algebra) that counts the number of maximal chains in each interval -numMaximalChainsIA :: (Ord a) => Poset a -> Vect Q (Interval a) -numMaximalChainsIA poset = invIA' (unitIA poset <-> etaIA poset) +numMaximalChainsIA :: (Ord a, Show a) => Poset a -> Vect Q (Interval a) +numMaximalChainsIA poset = (unitIA poset <-> etaIA poset)^-1 -- In order to quickCheck this, we would need diff --git a/Math/Combinatorics/Poset.hs b/Math/Combinatorics/Poset.hs --- a/Math/Combinatorics/Poset.hs +++ b/Math/Combinatorics/Poset.hs @@ -1,11 +1,12 @@ -- Copyright (c) 2011, David Amos. All rights reserved. -{-# LANGUAGE NoMonomorphismRestriction, TupleSections #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Math.Combinatorics.Poset where import Math.Common.ListSet as LS -- set operations on strictly ascending lists +import Math.Core.Utils -- for set/multiset operations on ordered lists import Math.Algebra.Field.Base import Math.Combinatorics.FiniteGeometry import Math.Algebra.LinearAlgebra @@ -102,7 +103,7 @@ posetB n = Poset ( powerset [1..n], LS.isSubset ) --- LATTICE OF PARTITIONS OF [1..N] ORDERED BY REFINEMENT +-- LATTICE OF SET PARTITIONS OF [1..N] ORDERED BY REFINEMENT partitions [] = [[]] partitions [x] = [[[x]]] @@ -113,7 +114,7 @@ isRefinement a b = and [or [acell `isSubset` bcell | bcell <- b] | acell <- a] -- if we know that a and b are appropriately sorted, then this can probably be done more efficiently --- |posetP n is the lattice of partitions of [1..n] ordered by refinement +-- |posetP n is the lattice of set partitions of [1..n], ordered by refinement posetP :: Int -> Poset [[Int]] posetP n = Poset ( partitions [1..n], isRefinement ) @@ -130,17 +131,57 @@ intervalPartitions2 [] = [[]] intervalPartitions2 [x] = [[[x]]] -intervalPartitions2 (x:xs) = let ips = intervalPartitions xs in +intervalPartitions2 (x:xs) = let ips = intervalPartitions2 xs in map ([x]:) ips ++ [ (x:head):tail | (head:tail) <- ips] -- we're guaranteed that x+1 is at the head of the head +-- LATTICE OF INTEGER PARTITIONS OF N ORDERED BY REFINEMENT + +integerPartitions1 n = ips (reverse [1..n]) n + where ips [] 0 = [[]] + ips [] _ = [] + ips (x:xs) n | x > n = ips xs n + | otherwise = map (x:) (ips (x:xs) (n-x)) ++ ips xs n + +-- For example, integerPartitions 5 -> [ [5], [4,1], [3,2], [3,1,1], [2,2,1], [2,1,1,1], [1,1,1,1,1] ] +integerPartitions n = dfs ([],n,n) + where dfs (xs, 0, _) = [reverse xs] + dfs (xs, r, i) = concatMap dfs [ (i':xs, r-i', i') | i' <- reverse [1..min r i] ] + +isIPRefinement ys xs = dfs xs ys + where dfs (x:xs) (y:ys) | x < y = False + | x == y = dfs xs ys + | otherwise = or [dfs xs' ys' | y' <- y:ys, let ys' = L.delete y' (y:ys), + let xs' = insertDesc (x-y') xs] + dfs [] [] = True + insertDesc = L.insertBy (flip compare) + +{- +-- In theory it feels like this ought to be faster for large n, but in practice it's unclear +isIPRefinement2 ys xs = isIPRefinement (ys \\ xs) (xs \\ ys) + where (\\) = diffDesc +-} + +-- |posetIP n is the poset of integer partitions of n, ordered by refinement +posetIP :: Int -> Poset [Int] +posetIP n = Poset (integerPartitions n, isIPRefinement) + + +-- Could also implement the Young lattice (or the part up to n) +-- Of integer partitions <= n, ordered by inclusion +-- Kassel, Turaev, Braid Groups, p202 + + +-- INTEGER COMPOSITIONS + + -- LATTICE OF SUBSPACES OF Fq^n subspaces fq n = [] : concatMap (flatsPG (n-1) fq) [0..n-1] -- note that flatsPG returns the subspaces as a matrix of row vectors in reduced row echelon form --- inSpanRE m v returns whether the vector v is in the span of the matrix m, where m is required to be in row echelon form +-- inSpanRE m v returns whether the vector v is in the span of the rows of the matrix m, where m is required to be in row echelon form isSubspace s1 s2 = all (inSpanRE s2) s1 -- This is the projective geometry PG(n,q) @@ -253,12 +294,6 @@ -- This returns all automorphisms -- What we really want is to return generators of the permutation group - - - - -pairs (x:xs) = map (x,) xs ++ pairs xs -- TupleSections -pairs [] = [] -- |A linear extension of a poset is a linear ordering of the elements which extends the partial order. -- Equivalently, it is an ordering [x1..xn] of the underlying set, such that if xi <= xj then i <= j. diff --git a/Math/Core/Utils.hs b/Math/Core/Utils.hs --- a/Math/Core/Utils.hs +++ b/Math/Core/Utils.hs @@ -11,6 +11,7 @@ toSet = S.toList . S.fromList +{- -- Merge two ordered listsets. Elements appearing in both inputs appear only once in the output mergeSet (x:xs) (y:ys) = case compare x y of @@ -18,7 +19,73 @@ EQ -> x : mergeSet xs ys GT -> y : mergeSet (x:xs) ys mergeSet xs ys = xs ++ ys +-} +-- |The set union of two ascending lists. If both inputs are strictly increasing, then the output is their union +-- and is strictly increasing. The code does not check that the lists are strictly increasing. +setUnionAsc :: Ord a => [a] -> [a] -> [a] +setUnionAsc (x:xs) (y:ys) = + case compare x y of + LT -> x : setUnionAsc xs (y:ys) + EQ -> x : setUnionAsc xs ys + GT -> y : setUnionAsc (x:xs) ys +setUnionAsc xs ys = xs ++ ys + +-- |The multiset sum of two ascending lists. If xs and ys are ascending, then multisetSumAsc xs ys == sort (xs++ys). +-- The code does not check that the lists are ascending. +multisetSumAsc :: Ord a => [a] -> [a] -> [a] +multisetSumAsc (x:xs) (y:ys) = + case compare x y of + LT -> x : multisetSumAsc xs (y:ys) + EQ -> x : y : multisetSumAsc xs ys + GT -> y : multisetSumAsc (x:xs) ys +multisetSumAsc xs ys = xs ++ ys + +-- |The multiset sum of two descending lists. If xs and ys are descending, then multisetSumDesc xs ys == sort (xs++ys). +-- The code does not check that the lists are descending. +multisetSumDesc :: Ord a => [a] -> [a] -> [a] +multisetSumDesc (x:xs) (y:ys) = + case compare x y of + GT -> x : multisetSumDesc xs (y:ys) + EQ -> x : y : multisetSumDesc xs ys + LT -> y : multisetSumDesc (x:xs) ys +multisetSumDesc xs ys = xs ++ ys + + +-- |The multiset or set difference between two ascending lists. If xs and ys are ascending, then diffAsc xs ys == xs \\ ys, +-- and diffAsc is more efficient. If xs and ys are sets (that is, have no repetitions), then diffAsc xs ys is the set difference. +-- The code does not check that the lists are ascending. +diffAsc :: Ord a => [a] -> [a] -> [a] +diffAsc (x:xs) (y:ys) = case compare x y of + LT -> x : diffAsc xs (y:ys) + EQ -> diffAsc xs ys + GT -> diffAsc (x:xs) ys +diffAsc xs [] = xs +diffAsc [] _ = [] + +-- |The multiset or set difference between two descending lists. If xs and ys are descending, then diffDesc xs ys == xs \\ ys, +-- and diffDesc is more efficient. If xs and ys are sets (that is, have no repetitions), then diffDesc xs ys is the set difference. +-- The code does not check that the lists are descending. +diffDesc :: Ord a => [a] -> [a] -> [a] +diffDesc (x:xs) (y:ys) = case compare x y of + GT -> x : diffDesc xs (y:ys) + EQ -> diffDesc xs ys + LT -> diffDesc (x:xs) ys +diffDesc xs [] = xs +diffDesc [] _ = [] + + +isSubsetAsc = isSubMultisetAsc + +isSubMultisetAsc (x:xs) (y:ys) = + case compare x y of + LT -> False + EQ -> isSubMultisetAsc xs ys + GT -> isSubMultisetAsc (x:xs) ys +isSubMultisetAsc [] ys = True +isSubMultisetAsc xs [] = False + + pairs (x:xs) = map (x,) xs ++ pairs xs pairs [] = [] @@ -29,11 +96,15 @@ -- fold a comparison operator through a list foldcmpl p (x1:x2:xs) = p x1 x2 && foldcmpl p (x2:xs) foldcmpl _ _ = True --- This can be expressed as a pure fold: --- foldcmpl cmp (x:xs) = snd $ foldl (\(bool,x') x -> (bool && cmp x' x, x)) (True,x) + -- foldcmpl _ [] = True --- However, that is less efficient, as we can't abort as soon as we fail --- (What about using the Maybe monad?) +-- foldcmpl p xs = and $ zipWith p xs (tail xs) + +isWeaklyIncreasing :: Ord t => [t] -> Bool +isWeaklyIncreasing = foldcmpl (<=) + +isStrictlyIncreasing :: Ord t => [t] -> Bool +isStrictlyIncreasing = foldcmpl (<) -- for use with L.sortBy cmpfst x y = compare (fst x) (fst y) diff --git a/Math/NumberTheory/Prime.hs b/Math/NumberTheory/Prime.hs --- a/Math/NumberTheory/Prime.hs +++ b/Math/NumberTheory/Prime.hs @@ -3,7 +3,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -- |A module providing functions to test for primality, and find next and previous primes. -module Math.NumberTheory.Prime where +module Math.NumberTheory.Prime (primes, isTrialDivisionPrime, isMillerRabinPrime, + isPrime, notPrime, prevPrime, nextPrime) where import System.Random import System.IO.Unsafe diff --git a/Math/NumberTheory/QuadraticField.hs b/Math/NumberTheory/QuadraticField.hs new file mode 100644 --- /dev/null +++ b/Math/NumberTheory/QuadraticField.hs @@ -0,0 +1,116 @@ +-- Copyright (c) 2011, David Amos. All rights reserved. + +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-} + +-- |A module for arithmetic in quadratic number fields. A quadratic number field is a field of the form Q(sqrt d), +-- where d is a square-free integer. For example, we can perform the following calculation in Q(sqrt 2): +-- +-- > (1 + sqrt 2) / (2 + sqrt 2) +-- +-- It is also possible to mix different square roots in the same calculation. For example: +-- +-- > (1 + sqrt 2) * (1 + sqrt 3) +-- +-- Square roots of negative numbers are also permitted. For example: +-- +-- > i * sqrt(-3) +module Math.NumberTheory.QuadraticField where + +import Prelude hiding (sqrt) + +import Data.List as L +import Math.Core.Field +import Math.Core.Utils (powersetdfs) +import Math.Algebras.VectorSpace +import Math.Algebras.TensorProduct +import Math.Algebras.Structures +import Math.NumberTheory.Factor + +import Math.Algebra.LinearAlgebra hiding (inverse, (*>) ) +import Math.CommutativeAlgebra.Polynomial + + +-- Q(sqrt n) + +-- |A basis for quadratic number fields Q(sqrt d), where d is a square-free integer. +data QNFBasis = One | Sqrt Integer deriving (Eq,Ord) + +instance Show QNFBasis where + show One = "1" + show (Sqrt d) | d == -1 = "i" + | otherwise = "sqrt(" ++ show d ++ ")" + +-- |The type for elements of quadratic number fields +type QNF = Vect Q QNFBasis + +-- |Although this has the same name as the Prelude.sqrt function, it should be thought of as more like a constructor +-- for creating elements of quadratic fields. +-- +-- Note that for d positive, sqrt d means the positive square root, and sqrt (-d) should be interpreted as the square root +-- with positive imaginary part, that is i * sqrt d. This has the consequence that for example, sqrt (-2) * sqrt (-3) = - sqrt 6. +sqrt :: Integer -> QNF +sqrt d | fr == 1 = fromInteger sq + | otherwise = fromInteger sq * return (Sqrt fr) + where (sq,fr) = squaredFree 1 1 (pfactors d) + squaredFree squared free (d1:d2:ds) = + if d1 == d2 then squaredFree (d1*squared) free ds else squaredFree squared (d1*free) (d2:ds) + squaredFree squared free ds = (squared, free * product ds) + +sqrt2 = sqrt 2 +sqrt3 = sqrt 3 +sqrt5 = sqrt 5 +sqrt6 = sqrt 6 +sqrt7 = sqrt 7 + +i :: QNF +i = sqrt (-1) + +instance (Eq k, Num k) => Algebra k QNFBasis where + unit x = x *> return One + mult = linear mult' + where mult' (One,x) = return x + mult' (x,One) = return x + mult' (Sqrt m, Sqrt n) | m == n = unit (fromInteger m) + | otherwise = let (i,d) = interdiff (pfactors m) (pfactors n) 1 1 + in fromInteger i *> return (Sqrt d) + -- if squarefree a == product ps, b == product qs + -- then sqrt a * sqrt b = product (intersect ps qs) * sqrt (product (symdiff ps qs)) + -- the following calculates these two products + -- in particular, it correctly handles the case that either or both contain -1 + interdiff (p:ps) (q:qs) i d = + case compare p q of + LT -> interdiff ps (q:qs) i (d*p) + EQ -> interdiff ps qs (i*p) d + GT -> interdiff (p:ps) qs i (d*q) + interdiff ps qs i d = (i, d * product (ps ++ qs)) + +{- +instance HasConjugation Q QNFBasis where + conj = (>>= conj') where + conj' One = return One + conj' sqrt_d = -1 *> return sqrt_d + -- ie conj = linear conj', but avoiding unnecessary nf call + sqnorm x = coeff One (x * conj x) +-} + +newtype XVar = X Int deriving (Eq, Ord, Show) + +instance Fractional QNF where + recip x@(V ts) = + let ds = [d | (Sqrt d, _) <- terms x] + fs = (if any (<0) ds then [-1] else []) ++ pfactors (foldl lcm 1 ds) -- lcm is always positive + rs = map (\d -> case d of 1 -> One; d' -> Sqrt d') $ + map product $ powersetdfs $ fs + -- for example, for x == sqrt2 + sqrt3, we would have rs == [One, Sqrt 2, Sqrt 3, Sqrt 6] + n = length rs + y = V $ zip rs $ map (glexvar . X) [1..n] -- x1*1+x2*r2+...+xn*rn + x' = V $ map (\(s,c) -> (s, unit c)) ts -- lift the coefficients in x into the polynomial algebra + one = x' * y + m = [ [coeff (mvar (X j)) c | j <- [1..n]] | i <- rs, let c = coeff i one] -- matrix of the linear system + b = 1 : replicate (n-1) 0 + in case solveLinearSystem m b of -- find v such that m v == b - ie find the values of x1, x2, ... xn + Just v -> nf $ V $ zip rs v + Nothing -> error "QNF.recip 0" + fromRational q = fromRational q *> 1 + + diff --git a/Math/Test/TAlgebras/TGroupAlgebra.hs b/Math/Test/TAlgebras/TGroupAlgebra.hs --- a/Math/Test/TAlgebras/TGroupAlgebra.hs +++ b/Math/Test/TAlgebras/TGroupAlgebra.hs @@ -14,41 +14,41 @@ import Math.Algebras.TensorProduct import Math.Algebras.Structures import Math.Algebras.GroupAlgebra +import Math.Core.Field import Math.Core.Utils -import Math.Test.TAlgebras.TStructures - -instance Arbitrary (GroupAlgebra Integer) where - arbitrary = do ts <- arbitrary :: Gen [(Permutation Int, Integer)] - return $ nf $ V $ take 10 ts +import Math.Test.TAlgebras.TVectorSpace -- for instance Arbitrary Q and (Vect k b) +import Math.Test.TAlgebras.TStructures -- for quickcheck properties prop_Algebra_GroupAlgebra (k,x,y,z) = prop_Algebra (k,x,y,z) - where types = (k,x,y,z) :: (Integer, GroupAlgebra Integer, GroupAlgebra Integer, GroupAlgebra Integer) + where types = (k,x,y,z) :: (Q, GroupAlgebra Q, GroupAlgebra Q, GroupAlgebra Q) -- have to split the 8-tuple into two 4-tuples to avoid having to write Arbitrary instance prop_Algebra_Linear_GroupAlgebra ((k,l,m,n),(x,y,z,w)) = prop_Algebra_Linear (k,l,m,n,x,y,z,w) - where types = (k,l,m,n,x,y,z,w) :: (Integer, Integer, Integer, Integer, - GroupAlgebra Integer, GroupAlgebra Integer, GroupAlgebra Integer, GroupAlgebra Integer) + where types = (k,l,m,n,x,y,z,w) :: (Q, Q, Q, Q, + GroupAlgebra Q, GroupAlgebra Q, GroupAlgebra Q, GroupAlgebra Q) prop_Coalgebra_GroupAlgebra x = prop_Coalgebra x - where types = x :: GroupAlgebra Integer + where types = x :: GroupAlgebra Q prop_Coalgebra_Linear_GroupAlgebra (k,l,x,y) = prop_Coalgebra_Linear (k,l,x,y) - where types = (k,l,x,y) :: (Integer, Integer, GroupAlgebra Integer, GroupAlgebra Integer) + where types = (k,l,x,y) :: (Q, Q, GroupAlgebra Q, GroupAlgebra Q) prop_Bialgebra_GroupAlgebra (k,x,y) = prop_Bialgebra (k,x,y) - where types = (k,x,y) :: (Integer, GroupAlgebra Integer, GroupAlgebra Integer) + where types = (k,x,y) :: (Q, GroupAlgebra Q, GroupAlgebra Q) prop_HopfAlgebra_GroupAlgebra x = prop_HopfAlgebra x - where types = x :: GroupAlgebra Integer + where types = x :: GroupAlgebra Q quickCheckGroupAlgebra = do - putStrLn "Checking that group algebra is an algebra, coalgebra, bialgebra, and Hopf algebra..." + putStrLn "Testing that group algebra is an algebra, coalgebra, bialgebra, and Hopf algebra..." quickCheck prop_Algebra_GroupAlgebra quickCheck prop_Coalgebra_GroupAlgebra quickCheck prop_Bialgebra_GroupAlgebra quickCheck prop_HopfAlgebra_GroupAlgebra + quickCheck (prop_AlgebraAntiMorphism (antipode :: GroupAlgebra Q -> GroupAlgebra Q)) + quickCheck (prop_CoalgebraAntiMorphism (antipode :: GroupAlgebra Q -> GroupAlgebra Q)) testlistGroupAlgebra = TestList [ diff --git a/Math/Test/TAlgebras/TOctonions.hs b/Math/Test/TAlgebras/TOctonions.hs --- a/Math/Test/TAlgebras/TOctonions.hs +++ b/Math/Test/TAlgebras/TOctonions.hs @@ -4,7 +4,8 @@ import Test.QuickCheck -import Math.Algebra.Field.Base +import Math.Core.Field +-- import Math.Algebra.Field.Base import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Quaternions diff --git a/Math/Test/TAlgebras/TStructures.hs b/Math/Test/TAlgebras/TStructures.hs --- a/Math/Test/TAlgebras/TStructures.hs +++ b/Math/Test/TAlgebras/TStructures.hs @@ -32,7 +32,7 @@ -- if we had a way to convert a bilinear function to a tensor function prop_Algebra_Linear :: - (Num k, Ord b, Algebra k b) => + (Eq k, Num k, Ord b, Algebra k b) => (k, k, k, k, Vect k b, Vect k b, Vect k b, Vect k b) -> Bool prop_Algebra_Linear (k,l,m,n,x,y,z,w) = -- (unit (k * m + l * n) :: Vect k b) == (add (smultL k (unit m)) (smultL l (unit n)) :: Vect k b) && @@ -43,7 +43,6 @@ prop_Coalgebra_Linear (k,l,x,y) = prop_Linear counit' (k,l,x,y) && prop_Linear comult (k,l,x,y) --- now need instances for GroupAlgebra etc -- ALGEBRAS @@ -95,6 +94,17 @@ prop_CoalgebraMorphism f x = (counit . f) x == counit x && ( (f `tf` f) . comult) x == (comult . f) x + +-- An antihomomorphism is like a homomorphism except that it reverses the order of multiplication +prop_AlgebraAntiMorphism f (k,x,y) = + (f . unit) k == unit k && + (f . mult) (x `te` y) == (mult . (f `tf` f) . twist) (x `te` y) + +prop_CoalgebraAntiMorphism f x = + (counit . f) x == counit x && + (twist . (f `tf` f) . comult) x == (comult . f) x + +prop_HopfAlgebraMorphism f x = (f . antipode) x == (antipode . f) x -- BIALGEBRAS diff --git a/Math/Test/TAlgebras/TTensorProduct.hs b/Math/Test/TAlgebras/TTensorProduct.hs --- a/Math/Test/TAlgebras/TTensorProduct.hs +++ b/Math/Test/TAlgebras/TTensorProduct.hs @@ -8,7 +8,8 @@ import Test.QuickCheck import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct -import Math.Algebra.Field.Base +import Math.Core.Field +-- import Math.Algebra.Field.Base import Math.Test.TAlgebras.TVectorSpace import Prelude as P @@ -88,7 +89,7 @@ id = Linear P.id (Linear f) . (Linear g) = Linear (f P.. g) -instance Num k => Arrow (Linear k) where +instance (Eq k, Num k) => Arrow (Linear k) where arr f = Linear (fmap f) -- requires nf call afterwards first (Linear f) = Linear f *** Linear P.id second (Linear f) = Linear P.id *** Linear f diff --git a/Math/Test/TAlgebras/TVectorSpace.hs b/Math/Test/TAlgebras/TVectorSpace.hs --- a/Math/Test/TAlgebras/TVectorSpace.hs +++ b/Math/Test/TAlgebras/TVectorSpace.hs @@ -8,7 +8,8 @@ import Test.QuickCheck import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct -import Math.Algebra.Field.Base +import Math.Core.Field +-- import Math.Algebra.Field.Base -- import Control.Monad -- MonadPlus @@ -40,10 +41,10 @@ d <- arbitrary :: Gen Integer return (if d == 0 then fromInteger n else fromInteger n / fromInteger d) -instance (Num k, Ord b, Arbitrary k, Arbitrary b) => Arbitrary (Vect k b) where +instance (Eq k, Num k, Ord b, Arbitrary k, Arbitrary b) => Arbitrary (Vect k b) where arbitrary = do ts <- arbitrary :: Gen [(b, k)] -- ScopedTypeVariables - return $ nf $ V $ take 10 ts - -- we impose complexity bound of 10 terms, to avoid unbounded running time. + return $ nf $ V $ take 3 ts +-- we impose a complexity bound of 3 terms to limit to 27 terms when testing associativity and ensure reasonable running time prop_VecSpQn (a,b,x,y,z) = prop_VecSp (a,b,x,y,z) where types = (a,b,x,y,z) :: (Q, Q, Vect Q EBasis, Vect Q EBasis, Vect Q EBasis) @@ -91,7 +92,7 @@ type LinFun k a b = [(a, Vect k b)] -- a way of representing a linear function as data -linfun :: (Eq a, Ord b, Num k) => LinFun k a b -> Vect k a -> Vect k b +linfun :: (Eq k, Num k, Eq a, Ord b) => LinFun k a b -> Vect k a -> Vect k b linfun avbs = linear f where f a = case lookup a avbs of Just vb -> vb @@ -165,11 +166,11 @@ where types = (a,u1,u2,v1,v2) :: (Q, Vect Q EBasis, Vect Q EBasis, Vect Q EBasis, Vect Q EBasis) -} -tensor :: (Num k, Ord a, Ord b) => Vect k (Either a b) -> Vect k (a, b) +tensor :: (Eq k, Num k, Ord a, Ord b) => Vect k (Either a b) -> Vect k (a, b) tensor uv = nf $ V [( (a,b), x*y) | (a,x) <- u, (b,y) <- v] where V u = p1 uv; V v = p2 uv -bilinear :: (Num k, Ord a, Ord b, Ord c) => +bilinear :: (Eq k, Num k, Ord a, Ord b, Ord c) => ((a, b) -> Vect k c) -> Vect k (Either a b) -> Vect k c bilinear f = linear f . tensor @@ -177,7 +178,7 @@ polymult = bilinear (\(E i, E j) -> return (E (i+j))) -prop_Bilinear :: (Num k, Ord a, Ord b, Ord t) => +prop_Bilinear :: (Eq k, Num k, Ord a, Ord b, Ord t) => (Vect k (Either a b) -> Vect k t) -> (k, Vect k a, Vect k a, Vect k b, Vect k b) -> Bool prop_Bilinear f (a,u1,u2,v1,v2) = prop_Linear (\v -> f (u1 `dsume` v)) (a,v1,v2) && diff --git a/Math/Test/TCombinatorics/TCombinatorialHopfAlgebra.hs b/Math/Test/TCombinatorics/TCombinatorialHopfAlgebra.hs new file mode 100644 --- /dev/null +++ b/Math/Test/TCombinatorics/TCombinatorialHopfAlgebra.hs @@ -0,0 +1,178 @@ +-- Copyright (c) 2012, David Amos. All rights reserved. + +{-# LANGUAGE FlexibleInstances #-} + +module Math.Test.TCombinatorics.TCombinatorialHopfAlgebra where + +import Data.List as L + +import Math.Core.Field + +import Math.Algebras.VectorSpace hiding (E) +import Math.Algebras.Structures + +import Math.Combinatorics.CombinatorialHopfAlgebra + +import Math.Test.TAlgebras.TVectorSpace hiding (T, f) +import Math.Test.TAlgebras.TTensorProduct +import Math.Test.TAlgebras.TStructures + +import Test.QuickCheck +import Test.HUnit + +quickCheckCombinatorialHopfAlgebra = do + quickCheckShuffleAlgebra + quickCheckSSymF + quickCheckSSymM + quickCheckYSymF + quickCheckYSymM + quickCheckQSymM + quickCheckQSymF + quickCheckCHAIsomorphism + quickCheckCHAMorphism + + +instance Arbitrary a => Arbitrary (Shuffle a) where + arbitrary = fmap (Sh . take 3) arbitrary + +quickCheckShuffleAlgebra = do + putStrLn "Checking shuffle algebra" + -- quickCheck (prop_Algebra :: (Q, Vect Q (Shuffle Int), Vect Q (Shuffle Int), Vect Q (Shuffle Int)) -> Bool) -- too slow + quickCheck (prop_Coalgebra :: Vect Q (Shuffle Int) -> Bool) + quickCheck (prop_Bialgebra :: (Q, Vect Q (Shuffle Int), Vect Q (Shuffle Int)) -> Bool) -- slow + quickCheck (prop_HopfAlgebra :: Vect Q (Shuffle Int) -> Bool) + + +instance Arbitrary SSymF where + arbitrary = do xs <- elements permsTo3 + return (SSymF xs) + where permsTo3 = concatMap (\n -> L.permutations [1..n]) [0..3] + +instance Arbitrary SSymM where + arbitrary = do xs <- elements permsTo3 + return (SSymM xs) + where permsTo3 = concatMap (\n -> L.permutations [1..n]) [0..3] + +quickCheckSSymF = do + putStrLn "Checking SSymF" + -- quickCheck (prop_Algebra :: (Q, Vect Q SSymF, Vect Q SSymF, Vect Q SSymF) -> Bool) -- too slow + quickCheck (prop_Coalgebra :: Vect Q SSymF -> Bool) + quickCheck (prop_Bialgebra :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool) + quickCheck (prop_HopfAlgebra :: Vect Q SSymF -> Bool) + +quickCheckSSymM = do + putStrLn "Checking SSymM" + -- quickCheck (prop_Algebra :: (Q, Vect Q SSymM, Vect Q SSymM, Vect Q SSymM) -> Bool) -- too slow + quickCheck (prop_Coalgebra :: Vect Q SSymM -> Bool) + -- quickCheck (prop_Bialgebra :: (Q, Vect Q SSymM, Vect Q SSymM) -> Bool) -- too slow + quickCheck (prop_HopfAlgebra :: Vect Q SSymM -> Bool) + + +instance Arbitrary (YSymF ()) where + arbitrary = fmap (YSymF . shape . descendingTree . take 3) (arbitrary :: Gen [Int]) +-- We use descendingTree because it can make trees of interesting shapes from a given list +-- but we could equally have used other tree construction methods such as binary search tree + +instance Arbitrary (YSymF Int) where + arbitrary = fmap (YSymF . descendingTree . take 3) (arbitrary :: Gen [Int]) +-- It seems to all work even if we leave the labels on. Perhaps we should really put random labels on though, +-- rather than leaving the descendingTree labels + +instance Arbitrary (YSymM) where + arbitrary = fmap (YSymM . shape . descendingTree . take 3) (arbitrary :: Gen [Int]) + +quickCheckYSymF = do + putStrLn "Checking YSymF" + -- quickCheck (prop_Algebra :: (Q, Vect Q (YSymF ()), Vect Q (YSymF ()), Vect Q (YSymF ())) -> Bool) -- too slow + quickCheck (prop_Coalgebra :: Vect Q (YSymF ()) -> Bool) + quickCheck (prop_Bialgebra :: (Q, Vect Q (YSymF ()), Vect Q (YSymF ())) -> Bool) + quickCheck (prop_HopfAlgebra :: Vect Q (YSymF ()) -> Bool) + +quickCheckYSymM = do + putStrLn "Checking YSymM" + -- quickCheck (prop_Algebra :: (Q, Vect Q YSymM, Vect Q YSymM, Vect Q YSymM) -> Bool) -- too slow + quickCheck (prop_Coalgebra :: Vect Q YSymM -> Bool) + -- quickCheck (prop_Bialgebra :: (Q, Vect Q YSymM, Vect Q YSymM) -> Bool) + quickCheck (prop_HopfAlgebra :: Vect Q YSymM -> Bool) + + +instance Arbitrary QSymM where + arbitrary = do xs <- elements compositionsTo3 + return (QSymM xs) + where compositionsTo3 = concatMap compositions [0..3] + +instance Arbitrary QSymF where + arbitrary = do xs <- elements compositionsTo3 + return (QSymF xs) + where compositionsTo3 = concatMap compositions [0..3] + +quickCheckQSymM = do + putStrLn "Checking QSymM" + quickCheck (prop_Algebra :: (Q, Vect Q QSymM, Vect Q QSymM, Vect Q QSymM) -> Bool) -- too slow + quickCheck (prop_Coalgebra :: Vect Q QSymM -> Bool) + quickCheck (prop_Bialgebra :: (Q, Vect Q QSymM, Vect Q QSymM) -> Bool) + quickCheck (prop_HopfAlgebra :: (Vect Q QSymM) -> Bool) + +quickCheckQSymF = do + putStrLn "Checking QSymF" + quickCheck (prop_Algebra :: (Q, Vect Q QSymF, Vect Q QSymF, Vect Q QSymF) -> Bool) -- too slow + quickCheck (prop_Coalgebra :: Vect Q QSymF -> Bool) + quickCheck (prop_Bialgebra :: (Q, Vect Q QSymF, Vect Q QSymF) -> Bool) + quickCheck (prop_HopfAlgebra :: (Vect Q QSymF) -> Bool) + +quickCheckCHAIsomorphism = do + putStrLn "Checking CHA isomorphism (change of basis)" + putStrLn "Checking bijections" + quickCheck (prop_Id (toSSymF . toSSymM) :: Vect Q SSymF -> Bool) + quickCheck (prop_Id (toSSymM . toSSymF) :: Vect Q SSymM -> Bool) + quickCheck (prop_Id (toYSymF . toYSymM) :: Vect Q (YSymF ()) -> Bool) + quickCheck (prop_Id (toYSymM . toYSymF) :: Vect Q YSymM -> Bool) + quickCheck (prop_Id (toQSymF . toQSymM) :: Vect Q QSymF -> Bool) + quickCheck (prop_Id (toQSymM . toQSymF) :: Vect Q QSymM -> Bool) + putStrLn "Checking morphisms" + putStrLn "SSym" + -- quickCheck (prop_AlgebraMorphism toSSymF :: (Q, Vect Q SSymM, Vect Q SSymM) -> Bool) -- too slow + -- quickCheck (prop_AlgebraMorphism toSSymM :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool) -- too slow + quickCheck (prop_CoalgebraMorphism toSSymF :: Vect Q SSymM -> Bool) + quickCheck (prop_CoalgebraMorphism toSSymM :: Vect Q SSymF -> Bool) + quickCheck (prop_HopfAlgebraMorphism toSSymM :: Vect Q SSymF -> Bool) + quickCheck (prop_HopfAlgebraMorphism toSSymF :: Vect Q SSymM -> Bool) + putStrLn "YSym" + -- quickCheck (prop_AlgebraMorphism toYSymF :: (Q, Vect Q YSymM, Vect Q YSymM) -> Bool) -- too slow + quickCheck (prop_AlgebraMorphism toYSymM :: (Q, Vect Q (YSymF ()), Vect Q (YSymF ())) -> Bool) + quickCheck (prop_CoalgebraMorphism toYSymF :: Vect Q YSymM -> Bool) + quickCheck (prop_CoalgebraMorphism toYSymM :: Vect Q (YSymF ()) -> Bool) + quickCheck (prop_HopfAlgebraMorphism toYSymF :: Vect Q YSymM -> Bool) + quickCheck (prop_HopfAlgebraMorphism toYSymM :: Vect Q (YSymF ()) -> Bool) + putStrLn "QSym" + quickCheck (prop_AlgebraMorphism toQSymF :: (Q, Vect Q QSymM, Vect Q QSymM) -> Bool) + quickCheck (prop_AlgebraMorphism toQSymM :: (Q, Vect Q QSymF, Vect Q QSymF) -> Bool) + quickCheck (prop_CoalgebraMorphism toQSymF :: Vect Q QSymM -> Bool) + quickCheck (prop_CoalgebraMorphism toQSymM :: Vect Q QSymF -> Bool) + quickCheck (prop_HopfAlgebraMorphism toQSymM :: Vect Q QSymF -> Bool) + quickCheck (prop_HopfAlgebraMorphism toQSymF :: Vect Q QSymM -> Bool) + where prop_Id f x = f x == x + +quickCheckCHAMorphism = do + putStrLn "Checking morphisms between CHAs" + quickCheck (prop_AlgebraMorphism descendingTreeMap :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool) + quickCheck (prop_CoalgebraMorphism descendingTreeMap :: Vect Q SSymF -> Bool) + quickCheck (prop_HopfAlgebraMorphism descendingTreeMap :: Vect Q SSymF -> Bool) + quickCheck (prop_AlgebraMorphism descentMap :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool) + quickCheck (prop_CoalgebraMorphism descentMap :: Vect Q SSymF -> Bool) + quickCheck (prop_HopfAlgebraMorphism descentMap :: Vect Q SSymF -> Bool) + quickCheck (prop_AlgebraMorphism leftLeafCompositionMap :: (Q, Vect Q (YSymF ()), Vect Q (YSymF ())) -> Bool) + quickCheck (prop_CoalgebraMorphism leftLeafCompositionMap :: Vect Q (YSymF ()) -> Bool) + quickCheck (prop_HopfAlgebraMorphism leftLeafCompositionMap :: Vect Q (YSymF ()) -> Bool) + quickCheck (\x -> descentMap x == (leftLeafCompositionMap . descendingTreeMap) (x :: Vect Q SSymF)) + -- Coalgebra morphisms showing that various Hopf algebras are cofree + quickCheck (prop_CoalgebraMorphism ysymmToSh :: Vect Q YSymM -> Bool) + + +testlistCHA = TestList [ + TestCase $ assertEqual "toYSymF" (toYSymF $ ysymM $ T (T E () E) () (T (T E () E) () E)) + ( ysymF (T (T E () E) () (T (T E () E) () E)) - ysymF (T (T E () E) () (T E () (T E () E))) + - ysymF (T E () (T E () (T (T E () E) () E))) + ysymF (T E () (T E () (T E () (T E () E)))) ), -- Loday.pdf, p10 + TestCase $ assertEqual "leftLeafComposition" [2,3,2,1] + (leftLeafComposition $ T (T (T E 1 E) 2 (T (T E 3 E) 4 E)) 5 (T (T E 6 E) 7 (T E 8 E))) -- Loday.pdf, p6 + ] diff --git a/Math/Test/TCombinatorics/TDigraph.hs b/Math/Test/TCombinatorics/TDigraph.hs --- a/Math/Test/TCombinatorics/TDigraph.hs +++ b/Math/Test/TCombinatorics/TDigraph.hs @@ -5,6 +5,7 @@ import Test.HUnit import Control.Monad (when, unless) +import Math.Core.Utils (pairs) import Math.Combinatorics.Digraph import Math.Combinatorics.Poset diff --git a/Math/Test/TCore/TUtils.hs b/Math/Test/TCore/TUtils.hs new file mode 100644 --- /dev/null +++ b/Math/Test/TCore/TUtils.hs @@ -0,0 +1,50 @@ +-- Copyright (c) 2012, David Amos. All rights reserved. + +module Math.Test.TCore.TUtils where + +import Data.List as L + +import Test.QuickCheck + +import Math.Core.Utils + +quickCheckUtils = do + putStrLn "Testing Math.Core.Utils" + quickCheck prop_setUnionAsc + quickCheck prop_multisetSumAsc + quickCheck prop_multisetSumDesc + quickCheck prop_diffAsc + quickCheck prop_diffDesc + +prop_setUnionAsc xs ys = setUnionAsc xs' ys' == zs' + where xs' = toSet xs :: [Int] + ys' = toSet ys + zs' = toSet (xs++ys) + +prop_multisetSumAsc xs ys = multisetSumAsc xs' ys' == zs' + where xs' = L.sort xs :: [Int] + ys' = L.sort ys + zs' = L.sort (xs ++ ys) + +prop_multisetSumDesc xs ys = multisetSumDesc xs' ys' == zs' + where xs' = reverse (L.sort xs) :: [Int] + ys' = reverse (L.sort ys) + zs' = reverse (L.sort (xs ++ ys)) + +prop_diffAsc xs ys = diffAsc xs' ys' == xs' \\ ys' + where xs' = L.sort xs :: [Int] + ys' = L.sort ys + +prop_diffDesc xs ys = diffDesc xs' ys' == xs' \\ ys' + where xs' = reverse (L.sort xs) :: [Int] + ys' = reverse (L.sort ys) + +-- !! Feels like we need a better negative test +-- xs is never submultiset of symmetric difference xs ys, unless null ys +prop_isSubMultisetAsc xs ys = isSubMultisetAsc xs' zs' + && (isSubMultisetAsc zs' xs' `implies` null ys) + && (isSubMultisetAsc xs' ys' `implies` (length xs <= length ys)) + where xs' = L.sort xs :: [Int] + ys' = L.sort ys + zs' = multisetSumAsc xs' ys' + implies p q = not p || q diff --git a/Math/Test/TNumberTheory/TQuadraticField.hs b/Math/Test/TNumberTheory/TQuadraticField.hs new file mode 100644 --- /dev/null +++ b/Math/Test/TNumberTheory/TQuadraticField.hs @@ -0,0 +1,47 @@ +-- Copyright (c) 2012, David Amos. All rights reserved. + +-- {-# LANGUAGE #-} + + +module Math.Test.TNumberTheory.TQuadraticField where + +import Prelude hiding (sqrt) + +import Math.Core.Field +import Math.NumberTheory.QuadraticField + +import Test.HUnit + + +testlistQuadraticField = TestList [ + testlistMult, + testlistRecip + ] + + +testcaseMult x y z = TestCase $ assertEqual (show x ++ "*" ++ show y ++ "==" ++ show z) z (x*y) + +testlistMult = TestList [ + testcaseMult (sqrt 2) (sqrt 2) 2, + testcaseMult (sqrt 2) (sqrt 3) (sqrt 6), + testcaseMult (sqrt 2) (sqrt 6) (2 * sqrt 3), + testcaseMult i i (-1), + testcaseMult i (i * sqrt 3) (-1 * sqrt 3), + testcaseMult (i * sqrt 2) (i * sqrt 3) (-1 * sqrt 6) + ] +-- We don't bother to test multiplication of sums, because it's obvious by definition that it will work + + +testcaseRecip x = TestCase $ assertBool ("recip " ++ show x) (x * recip x == 1) + +testlistRecip = TestList [ + testcaseRecip (sqrt 2), + testcaseRecip i, + testcaseRecip (sqrt 2 + sqrt 3), + testcaseRecip (sqrt 2 + 2 * sqrt 3), + testcaseRecip (sqrt 2 + sqrt 6), + testcaseRecip (sqrt 2 + sqrt 3 + sqrt 5), + testcaseRecip (i + 3*sqrt 2 + 2*sqrt 3 - sqrt 5 + 5*sqrt 11) + ] +-- These tests could be replaced with QuickCheck equivalents, provided we limited the Arbitrary instance +-- to avoid having to solve too large a linear system diff --git a/Math/Test/TPermutationGroup.hs b/Math/Test/TPermutationGroup.hs --- a/Math/Test/TPermutationGroup.hs +++ b/Math/Test/TPermutationGroup.hs @@ -116,8 +116,8 @@ ccTest = and ccTests ccTests = - [conjClassReps (graphAuts2 (c 5)) == [(p [],1),(p [[1,2],[3,5]],5),(p [[1,2,3,4,5]],2),(p [[1,3,5,2,4]],2)] - ,conjClassReps (graphAuts2 (q 3)) == + [conjClassReps (graphAuts (c 5)) == [(p [],1),(p [[1,2],[3,5]],5),(p [[1,2,3,4,5]],2),(p [[1,3,5,2,4]],2)] + ,conjClassReps (graphAuts (q 3)) == [(p [],1) ,(p [[0,1],[2,3],[4,5],[6,7]],3) ,(p [[0,1],[2,5],[3,4],[6,7]],6) diff --git a/Math/Test/TestAll.hs b/Math/Test/TestAll.hs --- a/Math/Test/TestAll.hs +++ b/Math/Test/TestAll.hs @@ -10,11 +10,13 @@ import Math.Test.TRootSystem import Math.Test.TCore.TField +import Math.Test.TCore.TUtils import Math.Test.TAlgebras.TGroupAlgebra import Math.Test.TAlgebras.TOctonions import Math.Test.TAlgebras.TTensorAlgebra import Math.Test.TAlgebras.TTensorProduct +import Math.Test.TCombinatorics.TCombinatorialHopfAlgebra import Math.Test.TCombinatorics.TDigraph import Math.Test.TCombinatorics.TFiniteGeometry import Math.Test.TCombinatorics.TGraphAuts @@ -24,12 +26,14 @@ import Math.Test.TCommutativeAlgebra.TPolynomial import Math.Test.TCommutativeAlgebra.TGroebnerBasis import Math.Test.TNumberTheory.TPrimeFactor +import Math.Test.TNumberTheory.TQuadraticField import Math.Test.TProjects.TMiniquaternionGeometry import Test.QuickCheck import Test.HUnit +-- legacy tests - should really be converted to HUnit testall = and [Math.Test.TGraph.test ,Math.Test.TDesign.test @@ -43,6 +47,7 @@ quickCheckAll = do -- quickCheck prop_NonCommRingNPoly + quickCheckUtils quickCheck prop_GroupPerm quickCheckField quickCheckTensorProduct @@ -54,9 +59,11 @@ putStrLn "Testing miniquaternion geometries..." quickCheck prop_NearFieldF9 quickCheck prop_NearFieldJ9 + quickCheckCombinatorialHopfAlgebra hunitAll = runTestTT $ TestList [ testlistGroupAlgebra, + testlistCHA, testlistDigraph, testlistFiniteGeometry, testlistGraphAuts, @@ -65,5 +72,6 @@ testlistPoset, testlistPolynomial, testlistGroebnerBasis, - testlistPrimeFactor + testlistPrimeFactor, + testlistQuadraticField ]