HaskellForMaths-0.4.8/0000755000000000000000000000000012514742102012736 5ustar0000000000000000HaskellForMaths-0.4.8/HaskellForMaths.cabal0000644000000000000000000001036612514742102016757 0ustar0000000000000000 Name: HaskellForMaths Version: 0.4.8 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 License: BSD3 License-file: license.txt Author: David Amos Maintainer: haskellformaths-at-gmail-dot-com Homepage: http://haskellformaths.blogspot.com/ Stability: experimental Build-Type: Simple Cabal-Version: >=1.2 Extra-source-files: Math/Test/TDesign.hs, Math/Test/TField.hs, Math/Test/TFiniteGeometry.hs, Math/Test/TGraph.hs, Math/Test/TNonCommutativeAlgebra.hs, Math/Test/TPermutationGroup.hs, Math/Test/TRootSystem.hs, Math/Test/TSubquotients.hs, Math/Test/TestAll.hs Math/Test/TAlgebras/TVectorSpace.hs Math/Test/TAlgebras/TTensorProduct.hs Math/Test/TAlgebras/TStructures.hs Math/Test/TAlgebras/TQuaternions.hs Math/Test/TAlgebras/TOctonions.hs Math/Test/TAlgebras/TMatrix.hs Math/Test/TAlgebras/TGroupAlgebra.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 Build-Depends: base >= 2 && < 5, containers, array, random Exposed-modules: Math.Algebra.LinearAlgebra, Math.Algebra.Field.Base, Math.Algebra.Field.Extension, Math.Algebra.Group.PermutationGroup, Math.Algebra.Group.SchreierSims, Math.Algebra.Group.RandomSchreierSims, Math.Algebra.Group.Subquotients, Math.Algebra.Group.StringRewriting, Math.Algebra.Group.CayleyGraph, Math.Algebra.NonCommutative.NCPoly, Math.Algebra.NonCommutative.GSBasis, Math.Algebra.NonCommutative.TensorAlgebra, Math.Algebras.AffinePlane, Math.Algebras.Commutative, Math.Algebras.GroupAlgebra, Math.Algebras.LaurentPoly, Math.Algebras.Matrix, Math.Algebras.NonCommutative, 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, Math.Combinatorics.Digraph, Math.Combinatorics.Matroid, 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.QuadraticField, Math.Projects.RootSystem, Math.Projects.Rubik, Math.Projects.MiniquaternionGeometry, Math.Projects.ChevalleyGroup.Classical, Math.Projects.ChevalleyGroup.Exceptional, Math.Projects.KnotTheory.Braid, Math.Projects.KnotTheory.LaurentMPoly, Math.Projects.KnotTheory.TemperleyLieb, Math.Projects.KnotTheory.IwahoriHecke, Math.QuantumAlgebra.OrientedTangle, Math.QuantumAlgebra.QuantumPlane, Math.QuantumAlgebra.Tangle, Math.QuantumAlgebra.TensorCategory ghc-options: -w HaskellForMaths-0.4.8/license.txt0000644000000000000000000000271012514742102015121 0ustar0000000000000000Copyright (c) 2009, David Amos All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of Haskell for Maths nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. HaskellForMaths-0.4.8/Setup.hs0000644000000000000000000000005612514742102014373 0ustar0000000000000000import Distribution.Simple main = defaultMainHaskellForMaths-0.4.8/Math/0000755000000000000000000000000012514742102013627 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Algebra/0000755000000000000000000000000012514742102015164 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Algebra/LinearAlgebra.hs0000644000000000000000000002141412514742102020212 0ustar0000000000000000-- Copyright (c) 2008-2015, David Amos. All rights reserved. -- |A module providing elementary operations involving scalars, vectors, and matrices -- over a ring or field. Vectors are represented as [a], matrices as [[a]]. -- (No distinction is made between row and column vectors.) -- It is the caller's responsibility to ensure that the lists have the correct number of elements. -- -- The mnemonic for many of the arithmetic operations is that the number of angle brackets -- on each side indicates the dimension of the argument on that side. For example, -- v \<*\>\> m is multiplication of a vector on the left by a matrix on the right. module Math.Algebra.LinearAlgebra where import Prelude hiding ( (*>), (<*>) ) import qualified Data.List as L import Math.Core.Field -- not actually used in this module infixr 8 *>, *>> infixr 7 <<*> infixl 7 <.>, <*>, <<*>>, <*>> infixl 6 <+>, <->, <<+>>, <<->> -- The mnemonic for these operations is that the number of angle brackets on each side indicates the dimension of the argument on that side -- vector operations -- |u \<+\> v returns the sum u+v of vectors (<+>) :: (Num a) => [a] -> [a] -> [a] u <+> v = zipWith (+) u v -- |u \<-\> v returns the difference u-v of vectors (<->) :: (Num a) => [a] -> [a] -> [a] u <-> v = zipWith (-) u v -- |k *\> v returns the product k*v of the scalar k and the vector v (*>) :: (Num a) => a -> [a] -> [a] k *> v = map (k*) v -- |u \<.\> v returns the dot product of vectors (also called inner or scalar product) (<.>) :: (Num a) => [a] -> [a] -> a u <.> v = sum (zipWith (*) u v) -- |u \<*\> v returns the tensor product of vectors (also called outer or matrix product) (<*>) :: (Num a) => [a] -> [a] -> [[a]] u <*> v = [ [a*b | b <- v] | a <- u] -- matrix operations -- |a \<\<+\>\> b returns the sum a+b of matrices (<<+>>) :: (Num a) => [[a]] -> [[a]] -> [[a]] a <<+>> b = (zipWith . zipWith) (+) a b -- |a \<\<-\>\> b returns the difference a-b of matrices (<<->>) :: (Num a) => [[a]] -> [[a]] -> [[a]] a <<->> b = (zipWith . zipWith) (-) a b -- |a \<\<*\>\> b returns the product a*b of matrices (<<*>>) :: (Num a) => [[a]] -> [[a]] -> [[a]] a <<*>> b = [ [u <.> v | v <- L.transpose b] | u <- a] -- |k *\>\> m returns the product k*m of the scalar k and the matrix m (*>>) :: (Num a) => a -> [[a]] -> [[a]] k *>> m = (map . map) (k*) m -- |m \<\<*\> v is multiplication of a vector by a matrix on the left (<<*>) :: (Num a) => [[a]] -> [a] -> [a] m <<*> v = map (<.> v) m -- |v \<*\>\> m is multiplication of a vector by a matrix on the right (<*>>) :: (Num a) => [a] -> [[a]] -> [a] v <*>> m = map (v <.>) (L.transpose m) fMatrix n f = [[f i j | j <- [1..n]] | i <- [1..n]] -- version with indices from zero fMatrix' n f = [[f i j | j <- [0..n-1]] | i <- [0..n-1]] -- idMx n = fMatrix n (\i j -> if i == j then 1 else 0) idMx n = idMxs !! n where idMxs = map snd $ iterate next (0,[]) next (j,m) = (j+1, (1 : replicate j 0) : map (0:) m) -- |iMx n is the n*n identity matrix iMx :: (Num t) => Int -> [[t]] iMx n = idMx n -- |jMx n is the n*n matrix of all 1s jMx :: (Num t) => Int -> [[t]] jMx n = replicate n (replicate n 1) -- |zMx n is the n*n matrix of all 0s zMx :: (Num t) => Int -> [[t]] zMx n = replicate n (replicate n 0) {- -- VECTORS data Vector d k = V [k] deriving (Eq,Ord,Show) instance (IntegerAsType d, Num k) => Num (Vector d k) where V a + V b = V $ a <+> b V a - V b = V $ a <-> b negate (V a) = V $ map negate a fromInteger 0 = V $ replicate d' 0 where d' = fromInteger $ value (undefined :: d) V v <>> M m = V $ v <*>> m M m <<> V v = V $ m <<*> v k |> V v = V $ k *> v -} -- MATRICES {- -- Square matrices of dimension d over field k data Matrix d k = M [[k]] deriving (Eq,Ord,Show) instance (IntegerAsType d, Num k) => Num (Matrix d k) where M a + M b = M $ a <<+>> b M a - M b = M $ a <<->> b negate (M a) = M $ (map . map) negate a M a * M b = M $ a <<*>> b fromInteger 0 = M $ zMx d' where d' = fromInteger $ value (undefined :: d) fromInteger 1 = M $ idMx d' where d' = fromInteger $ value (undefined :: d) instance (IntegerAsType d, Fractional a) => Fractional (Matrix d a) where recip (M a) = case inverse a of Nothing -> error "Matrix.recip: matrix is singular" Just a' -> M a' -} -- |The inverse of a matrix (over a field), if it exists inverse :: (Eq a, Fractional a) => [[a]] -> Maybe [[a]] inverse m = let d = length m -- the dimension i = idMx d m' = zipWith (++) m i i1 = inverse1 m' i2 = inverse2 i1 in if length i1 == d then Just i2 else Nothing -- given (M|I), use row operations to get to (U|A), where U is upper triangular with 1s on diagonal inverse1 [] = [] inverse1 ((x:xs):rs) = if x /= 0 then let r' = (1/x) *> xs in (1:r') : inverse1 [ys <-> y *> r' | (y:ys) <- rs] else case filter (\r' -> head r' /= 0) rs of [] -> [] -- early termination, which will be detected in calling function r:_ -> inverse1 (((x:xs) <+> r) : rs) -- This is basically row echelon form -- given (U|A), use row operations to get to M^-1 inverse2 [] = [] inverse2 ((1:r):rs) = inverse2' r rs : inverse2 rs where inverse2' xs [] = xs inverse2' (x:xs) ((1:r):rs) = inverse2' (xs <-> x *> r) rs xs ! i = xs !! (i-1) -- ie, a 1-based list lookup instead of 0-based rowEchelonForm [] = [] rowEchelonForm ((x:xs):rs) = if x /= 0 then let r' = (1/x) *> xs in (1:r') : map (0:) (rowEchelonForm [ys <-> y *> r' | (y:ys) <- rs]) else case filter (\r' -> head r' /= 0) rs of [] -> map (0:) (rowEchelonForm $ xs : map tail rs) r:_ -> rowEchelonForm (((x:xs) <+> r) : rs) rowEchelonForm zs@([]:_) = zs reducedRowEchelonForm :: (Eq a, Fractional a) => [[a]] -> [[a]] reducedRowEchelonForm m = reverse $ reduce $ reverse $ rowEchelonForm m where reduce (r:rs) = let r':rs' = reduceStep (r:rs) in r' : reduce rs' -- is this scanl or similar? reduce [] = [] reduceStep ((1:xs):rs) = (1:xs) : [ 0: (ys <-> y *> xs) | y:ys <- rs] reduceStep rs@((0:_):_) = zipWith (:) (map head rs) (reduceStep $ map tail rs) reduceStep rs = rs -- Given a matrix m and (column) vector b, either find (column vector) x such that m x == b, -- or indicate that there is none solveLinearSystem m b = let augmented = zipWith (\r x -> r ++ [x]) m b -- augmented matrix trisystem = inverse1 augmented -- upper triangular form solution = reverse $ solveTriSystem $ reverse $ map reverse trisystem in if length solution == length b then Just solution else Nothing where solveTriSystem ([v,c]:rs) = let x = v/c -- the first row tells us that cx == v rs' = map (\(v':c':r) -> (v'-c'*x):r) rs in x : solveTriSystem rs' solveTriSystem [] = [] solveTriSystem _ = [] -- abnormal termination - m wasn't invertible isZero v = all (==0) v -- 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 ((1:xs):bs) (y:ys) = inSpanRE (map tail bs) (if y == 0 then ys else ys <-> y *> xs) inSpanRE ((0:xs):bs) (y:ys) = if y == 0 then inSpanRE (xs : map tail bs) ys else False inSpanRE _ ys = isZero ys rank m = length $ filter (not . isZero) $ rowEchelonForm m -- kernel of a matrix -- returns basis for vectors v s.t m <<*> v == 0 kernel m = kernelRRE $ reducedRowEchelonForm m kernelRRE m = let nc = length $ head m -- the number of columns is = findLeadingCols 1 (L.transpose m) -- these are the indices of the columns which have a leading 1 js = [1..nc] L.\\ is freeCols = let m' = take (length is) m -- discard zero rows in zip is $ L.transpose [map (negate . (!j)) m' | j <- js] boundCols = zip js (idMx $ length js) in L.transpose $ map snd $ L.sort $ freeCols ++ boundCols where findLeadingCols i (c@(1:_):cs) = i : findLeadingCols (i+1) (map tail cs) findLeadingCols i (c@(0:_):cs) = findLeadingCols (i+1) cs findLeadingCols _ _ = [] -- m ^- n = recip m ^ n -- t (M m) = M (L.transpose m) -- |The determinant of a matrix (over a field) det :: (Eq a, Fractional a) => [[a]] -> a det [[x]] = x det ((x:xs):rs) = if x /= 0 then let r' = (1/x) *> xs in x * det [ys <-> y *> r' | (y:ys) <- rs] else case filter (\r' -> head r' /= 0) rs of [] -> 0 r:_ -> det (((x:xs) <+> r) : rs) {- class IntegerAsType a where value :: a -> Integer data Z instance IntegerAsType Z where value _ = 0 data S a instance IntegerAsType a => IntegerAsType (S a) where value _ = value (undefined :: a) + 1 -}HaskellForMaths-0.4.8/Math/Algebra/Field/0000755000000000000000000000000012514742102016207 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Algebra/Field/Base.hs0000644000000000000000000001120712514742102017416 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-} module Math.Algebra.Field.Base where import Data.Ratio import Math.Common.IntegerAsType import Math.Core.Utils -- RATIONALS -- |Q is just the rationals, but with a better show function than the Prelude version newtype Q = Q Rational deriving (Eq,Ord,Num,Fractional) instance Show Q where show (Q x) | b == 1 = show a | otherwise = show a ++ "/" ++ show b where a = numerator x b = denominator x numeratorQ (Q x) = Data.Ratio.numerator x denominatorQ (Q x) = Data.Ratio.denominator x -- PRIME FIELDS -- extendedEuclid a b returns (u,v,d) such that u*a + v*b = d extendedEuclid a b | a >= 0 && b >= 0 = extendedEuclid' a b [] where extendedEuclid' d 0 qs = let (u,v) = unwind 1 0 qs in (u,v,d) extendedEuclid' a b qs = let (q,r) = quotRem a b in extendedEuclid' b r (q:qs) unwind u v [] = (u,v) unwind u v (q:qs) = unwind v (u-v*q) qs newtype Fp n = Fp Integer deriving (Eq,Ord) instance Show (Fp n) where show (Fp x) = show x instance IntegerAsType n => Num (Fp n) where Fp x + Fp y = Fp $ (x+y) `mod` p where p = value (undefined :: n) negate (Fp 0) = Fp 0 negate (Fp x) = Fp $ p - x where p = value (undefined :: n) Fp x * Fp y = Fp $ (x*y) `mod` p where p = value (undefined :: n) fromInteger m = Fp $ m `mod` p where p = value (undefined :: n) abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" -- n must be prime - could perhaps use a type to guarantee this instance IntegerAsType n => Fractional (Fp n) where recip 0 = error "Fp.recip 0" recip (Fp x) = let (u,v,1) = extendedEuclid x p -- so ux+vp = 1. (We know the gcd is 1 as p prime) in Fp $ u `mod` p where p = value (undefined :: n) -- Not sure if Eq fq is required, need to try with ghc >= 7.4.1 class (Eq fq, Fractional fq) => FiniteField fq where eltsFq :: fq -> [fq] -- return all elts of the field basisFq :: fq -> [fq] -- return an additive basis for the field (as Z-module) instance IntegerAsType p => FiniteField (Fp p) where eltsFq _ = map fromInteger [0..p'-1] where p' = value (undefined :: p) basisFq _ = [fromInteger 1] instance IntegerAsType p => FinSet (Fp p) where elts = map fromInteger [0..p'-1] where p' = value (undefined :: p) primitiveElt fq = head [x | x <- tail fq, length (powers x) == q-1] where q = length fq powers x | x /= 0 = 1 : takeWhile (/=1) (iterate (*x) x) -- characteristic of a finite field char fq = head [p | p <- [2..], length fq `mod` p == 0] -- |F2 is a type for the finite field with 2 elements type F2 = Fp T2 -- |f2 lists the elements of F2 f2 :: [F2] f2 = map fromInteger [0..1] -- :: [F2] -- |F3 is a type for the finite field with 3 elements type F3 = Fp T3 -- |f3 lists the elements of F3 f3 :: [F3] f3 = map fromInteger [0..2] -- :: [F3] -- |F5 is a type for the finite field with 5 elements type F5 = Fp T5 -- |f5 lists the elements of F5 f5 :: [F5] f5 = map fromInteger [0..4] -- :: [F5] -- |F7 is a type for the finite field with 7 elements type F7 = Fp T7 -- |f7 lists the elements of F7 f7 :: [F7] f7 = map fromInteger [0..6] -- :: [F7] type F11 = Fp T11 f11 = map fromInteger [0..10] :: [F11] type F13 = Fp T13 f13 = map fromInteger [0..12] :: [F13] type F17 = Fp T17 f17 = map fromInteger [0..16] :: [F17] type F19 = Fp T19 f19 = map fromInteger [0..18] :: [F19] type F23 = Fp T23 f23 = map fromInteger [0..22] :: [F23] type F29 = Fp T29 f29 = map fromInteger [0..28] :: [F29] type F31 = Fp T31 f31 = map fromInteger [0..30] :: [F31] type F37 = Fp T37 f37 = map fromInteger [0..36] :: [F37] type F41 = Fp T41 f41 = map fromInteger [0..40] :: [F41] type F43 = Fp T43 f43 = map fromInteger [0..42] :: [F43] type F47 = Fp T47 f47 = map fromInteger [0..46] :: [F47] type F53 = Fp T53 f53 = map fromInteger [0..52] :: [F53] type F59 = Fp T59 f59 = map fromInteger [0..58] :: [F59] type F61 = Fp T61 f61 = map fromInteger [0..60] :: [F61] type F67 = Fp T67 f67 = map fromInteger [0..66] :: [F67] type F71 = Fp T71 f71 = map fromInteger [0..70] :: [F71] type F73 = Fp T73 f73 = map fromInteger [0..72] :: [F73] type F79 = Fp T79 f79 = map fromInteger [0..78] :: [F79] type F83 = Fp T83 f83 = map fromInteger [0..82] :: [F83] type F89 = Fp T89 f89 = map fromInteger [0..88] :: [F89] type F97 = Fp T97 f97 = map fromInteger [0..96] :: [F97] HaskellForMaths-0.4.8/Math/Algebra/Field/Extension.hs0000644000000000000000000002210512514742102020517 0ustar0000000000000000-- Copyright (c) David Amos, 2008-2015. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, ScopedTypeVariables, EmptyDataDecls, FlexibleInstances #-} module Math.Algebra.Field.Extension where import Prelude hiding ( (<*>) ) import Data.Ratio import Data.List as L (elemIndex) import Math.Common.IntegerAsType import Math.Core.Utils import Math.Algebra.Field.Base -- UNIVARIATE POLYNOMIALS newtype UPoly a = UP [a] deriving (Eq,Ord) -- the list [a_0, a_1, ..., a_n] represents the polynomial a_0 + a_1 x + ... + a_n x^n x = UP [0,1] :: UPoly Integer instance (Eq a, Show a, Num a) => Show (UPoly a) where -- show (UP []) = "0" show (UP as) = showUP "x" as showUP _ [] = "0" showUP v as = let powers = filter ( (/=0) . fst ) $ zip as [0..] c:cs = concatMap showTerm powers in if c == '+' then cs else c:cs where showTerm (a,i) = showCoeff a ++ showPower a i showCoeff a = case show a of "1" -> "+" "-1" -> "-" '-':cs -> '-':cs cs -> '+':cs showPower a i | i == 0 = case show a of "1" -> "1" "-1" -> "1" otherwise -> "" | i == 1 = v -- "x" | i > 1 = v ++ "^" ++ show i -- "x^" ++ show i instance (Eq a, Num a) => Num (UPoly a) where UP as + UP bs = UP $ as <+> bs negate (UP as) = UP $ map negate as UP as * UP bs = UP $ as <*> bs fromInteger 0 = UP [] fromInteger a = UP [fromInteger a] abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" toUPoly as = UP (reverse (dropWhile (== 0) (reverse as))) -- The fussiness of the code is to avoid adding trailing zeroes, eg [3] <+> [-3] -- Otherwise we would have to normalise after every addition as <+> [] = as [] <+> bs = bs -- (a:as) <+> (b:bs) = (a+b) : (as <+> bs) (a:as) <+> (b:bs) = let c = a+b cs = as <+> bs in if c == 0 && null cs then [] else c:cs -- The fussiness of the code is to avoid adding trailing zeroes. -- Note that since we call <+>, we rely on it having similar properties. [] <*> _ = [] _ <*> [] = [] -- to avoid [0,1] <*> [] -> [0] (a:as) <*> bs = if null as then map (a*) bs else map (a*) bs <+> (0 : as <*> bs) -- > let valid xs = null xs || last xs /= 0 -- > quickCheck (\as bs -> not (valid as) || not (valid bs) || valid (as <*> bs)) {- -- The following definition introduces unnecessary trailing zeroes, eg [3] <*> [2] -> [6,0] [] <*> _ = [] _ <*> [] = [] (a:as) <*> (b:bs) = [a*b] <+> (0 : map (a*) bs) <+> (0 : map (*b) as) <+> (0 : 0 : as <*> bs) -} convert (UP as) = toUPoly $ map fromInteger as -- Can be used with type annotations to construct polynomials over other types, eg -- > convert (x^2+3*x+2) :: UPoly F2 -- x^2+x -- > convert (x^2+3*x+2) :: UPoly F3 -- x^2+2 -- DIVISION ALGORITHM -- degree deg (UP as) = length as -- leading term lt (UP as) = last as monomial a i = UP $ replicate i 0 ++ [a] -- quotRem for UPolys over a field quotRemUP :: (Eq k, Fractional k) => UPoly k -> UPoly k -> (UPoly k, UPoly k) quotRemUP f g = qr 0 f where qr q r = if deg r < deg_g then (q,r) else let s = monomial (lt r / lt_g) (deg r - deg_g) in qr (q+s) (r-s*g) deg_g = deg g lt_g = lt g modUP f g = snd $ quotRemUP f g -- extendedEuclidUP f g returns (u,v,d) such that u*f + v*g = d extendedEuclidUP f g = extendedEuclidUP' f g [] where extendedEuclidUP' d 0 qs = let (u,v) = unwind 1 0 qs in (u,v,d) extendedEuclidUP' f g qs = let (q,r) = quotRemUP f g in extendedEuclidUP' g r (q:qs) unwind u v [] = (u,v) unwind u v (q:qs) = unwind v (u-v*q) qs -- EXTENSION FIELDS class PolynomialAsType k poly where pvalue :: (k,poly) -> UPoly k data ExtensionField k poly = Ext (UPoly k) deriving (Eq,Ord) instance (Eq k, Show k, Num k) => Show (ExtensionField k poly) where -- show (Ext f) = show f -- show (Ext (UP [])) = "0" show (Ext (UP as)) = showUP "a" as instance (Eq k, Fractional k, PolynomialAsType k poly) => Num (ExtensionField k poly) where Ext x + Ext y = Ext $ (x+y) -- `modUP` pvalue (undefined :: (k,poly)) Ext x * Ext y = Ext $ (x*y) `modUP` pvalue (undefined :: (k,poly)) negate (Ext x) = Ext $ negate x fromInteger x = Ext $ fromInteger x abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance (Eq k, Fractional k, PolynomialAsType k poly) => Fractional (ExtensionField k poly) where recip 0 = error "ExtensionField.recip 0" recip (Ext f) = let g = pvalue (undefined :: (k,poly)) (u,v,d@(UP [c])) = extendedEuclidUP f g -- so u*f + v*g == d. We know the d is a unit, ie field element, since g is irreducible in Ext $ (c /> u) `modUP` g fromRational q = fromInteger a / fromInteger b where a = numerator q; b = denominator q -- divide through c /> f@(UP as) | c == 1 = f | c /= 0 = UP (map (c' *) as) where c' = recip c instance (FiniteField k, PolynomialAsType k poly) => FiniteField (ExtensionField k poly) where eltsFq _ = map Ext (polys (d-1) fp) where fp = eltsFq (undefined :: k) d = deg $ pvalue (undefined :: (k,poly)) basisFq _ = map embed $ take (d-1) $ iterate (*x) 1 where d = deg $ pvalue (undefined :: (k,poly)) -- Not sure if Eq fp is required, need to check with ghc >= 7.4.1 instance (FinSet fp, Eq fp, Num fp, PolynomialAsType fp poly) => FinSet (ExtensionField fp poly) where elts = map Ext (polys (d-1) fp') where fp' = elts d = deg $ pvalue (undefined :: (fp,poly)) embed f = Ext (convert f) -- PRIME POWER FINITE FIELDS polys d fp = map toUPoly $ polys' d where polys' 0 = [[]] polys' d = [x:xs | x <- fp, xs <- polys' (d-1)] -- return in ascending order -- polys' d = [x:xs | xs <- polys' (d-1), x <- fp] -- return with elts of fp first -- Conway polynomials from Holt, Handbook of Computational Group Theory, p60 data ConwayF4 instance PolynomialAsType F2 ConwayF4 where pvalue _ = convert $ x^2+x+1 type F4 = ExtensionField F2 ConwayF4 f4 = map Ext (polys 2 f2) :: [F4] a4 = embed x :: F4 data ConwayF8 instance PolynomialAsType F2 ConwayF8 where pvalue _ = convert $ x^3+x+1 type F8 = ExtensionField F2 ConwayF8 f8 = map Ext (polys 3 f2) :: [F8] a8 = embed x :: F8 data ConwayF9 instance PolynomialAsType F3 ConwayF9 where pvalue _ = convert $ x^2+2*x+2 type F9 = ExtensionField F3 ConwayF9 f9 = map Ext (polys 2 f3) :: [F9] a9 = embed x :: F9 data ConwayF16 instance PolynomialAsType F2 ConwayF16 where pvalue _ = convert $ x^4+x+1 type F16 = ExtensionField F2 ConwayF16 f16 = map Ext (polys 4 f2) :: [F16] a16 = embed x :: F16 data ConwayF25 instance PolynomialAsType F5 ConwayF25 where pvalue _ = convert $ x^2+4*x+2 type F25 = ExtensionField F5 ConwayF25 f25 = map Ext (polys 2 f5) :: [F25] a25 = embed x :: F25 data ConwayF27 instance PolynomialAsType F3 ConwayF27 where pvalue _ = convert $ x^3+2*x+1 type F27 = ExtensionField F3 ConwayF27 f27 = map Ext (polys 3 f3) :: [F27] a27 = embed x :: F27 data ConwayF32 instance PolynomialAsType F2 ConwayF32 where pvalue _ = convert $ x^5+x^2+1 type F32 = ExtensionField F2 ConwayF32 f32 = map Ext (polys 5 f2) :: [F32] a32 = embed x :: F32 -- generator for the automorphism group of fq, as applied to an element of fq frobeniusAut x = x ^ p where p = char $ eltsFq x -- the degree of fq as an extension over fp -- (hence also, the order of the automorphism group of fq) degree fq = n where q = length fq p = char fq Just n = L.elemIndex q $ iterate (*p) 1 -- QUADRATIC EXTENSIONS OF Q data Sqrt a = Sqrt a -- n should be square-free instance IntegerAsType n => PolynomialAsType Q (Sqrt n) where pvalue _ = convert $ x^2 - fromInteger (value (undefined :: n)) type QSqrt2 = ExtensionField Q (Sqrt T2) sqrt2 = embed x :: QSqrt2 type QSqrt3 = ExtensionField Q (Sqrt T3) sqrt3 = embed x :: QSqrt3 type QSqrt5 = ExtensionField Q (Sqrt T5) sqrt5 = embed x :: QSqrt5 type QSqrt7 = ExtensionField Q (Sqrt T7) sqrt7 = embed x :: QSqrt7 type QSqrtMinus1 = ExtensionField Q (Sqrt TMinus1) i = embed x :: QSqrtMinus1 type QSqrtMinus2 = ExtensionField Q (Sqrt (M TMinus1 T2)) sqrtminus2 = embed x :: QSqrtMinus2 type QSqrtMinus3 = ExtensionField Q (Sqrt (M TMinus1 T3)) sqrtminus3 = embed x :: QSqrtMinus3 type QSqrtMinus5 = ExtensionField Q (Sqrt (M TMinus1 T5)) sqrtminus5 = embed x :: QSqrtMinus5 -- conjugation automorphism of quadratic field -- conjugate of a + b sqrt d is a - b sqrt d conjugate :: ExtensionField Q (Sqrt d) -> ExtensionField Q (Sqrt d) conjugate (Ext (UP [a,b])) = Ext (UP [a,-b]) conjugate x = x -- the zero or constant casesHaskellForMaths-0.4.8/Math/Algebra/Group/0000755000000000000000000000000012514742102016260 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Algebra/Group/CayleyGraph.hs0000644000000000000000000001006512514742102021026 0ustar0000000000000000-- Copyright (c) David Amos, 2010. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction #-} module Math.Algebra.Group.CayleyGraph where import Math.Core.Utils hiding (elts) import Math.Algebra.Group.StringRewriting as SR import Math.Combinatorics.Graph -- import Math.Combinatorics.GraphAuts import Math.Algebra.Group.PermutationGroup as P import qualified Data.List as L data Digraph a = DG [a] [(a,a)] deriving (Eq,Ord,Show) cayleyDigraphP gs = DG vs es where vs = P.elts gs es = [(v,v') | v <- vs, v' <- nbrs v ] nbrs v = L.sort [v * g | g <- gs] -- |The Cayley graph (undirected) on the generators (and their inverses), -- for a group given as permutations cayleyGraphP :: (Ord a, Show a) => [Permutation a] -> Graph (Permutation a) cayleyGraphP gs = graph (vs,es) where -- G vs es where vs = P.elts gs es = toSet [ L.sort [v,v'] | v <- vs, v' <- nbrs v ] -- toSet orders and removes duplicates nbrs v = [v * g | g <- gs] cayleyDigraphS (gs,rs) = DG vs es where rs' = knuthBendix rs vs = L.sort $ nfs (gs,rs') -- calling elts would mean we invoked knuthBendix twice es = [(v,v') | v <- vs, v' <- nbrs v ] nbrs v = L.sort [rewrite rs' (v ++ [g]) | g <- gs] -- |The Cayley graph (undirected) on the generators (and their inverses), -- for a group given as generators and relations cayleyGraphS :: (Ord a) => ([a], [([a], [a])]) -> Graph [a] cayleyGraphS (gs,rs) = graph (vs,es) where -- G vs es where rs' = knuthBendix rs vs = L.sort $ nfs (gs,rs') -- calling elts would mean we invoked knuthBendix twice es = toSet [ L.sort [v,v'] | v <- vs, v' <- nbrs v ] -- toSet orders and removes duplicates nbrs v = [rewrite rs' (v ++ [g]) | g <- gs] -- it would be better if we could use shortlex ordering, but as it stands Graph will use lex ordering -- for example, can check -- isIso (cayleyGraphP [p [[1,2]], p [[2,3]], p [[3,4]]]) (cayleyGraphS (SR._S 4)) -- given sequence of transpositions, return group elt it represents fromTranspositions ts = product $ map (\(S i) -> p [[i,i+1]]) ts -- given sequence of transpositions, return the permutation of [1..n] that it causes fromTrans ts = [i .^ (g^-1) | i <- [1..n] ] where g = fromTranspositions ts n = maximum $ supp g bubblesort [] = [] bubblesort xs = bubblesort' [] xs where bubblesort' ls (r1:r2:rs) = if r1 <= r2 then bubblesort' (r1:ls) (r2:rs) else bubblesort' (r2:ls) (r1:rs) bubblesort' ls [r] = bubblesort (reverse ls) ++ [r] -- given a permutation of [1..n] (as a list), return the transpositions which led to it toTrans [] = [] toTrans xs = toTrans' 1 [] [] xs where toTrans' i ts ls (r1:r2:rs) = if r1 <= r2 then toTrans' (i+1) ts (r1:ls) (r2:rs) -- no swap needed else toTrans' (i+1) (S i : ts) (r2:ls) (r1:rs) -- swap needed toTrans' i ts ls [r] = toTrans (reverse ls) ++ ts -- note that the ts are returned in reverse to the order that they were used -- this is because we used them to *undo* the permutation - so we performed the *inverse* -- to get the permutation that led to xs, we have to take the inverse again, which we do by reversing -- given a permutation of [1..n] (as a group elt), factor it into transpositions toTranspositions 1 = [] toTranspositions g = toTrans [i .^ (g^-1) | i <- [1..n] ] where n = maximum $ supp g -- The reason we have g^-1 rather than g is that -- i .^ g == j tells us that i ends up in the j position whereas -- i .^ (g^-1) == j tells us that j is what ends up in the i position -- Clearly it's the latter we want -- For example, if g = s1 s2 = p [[1,3,2]], then the effect of applying g to [1,2,3] is [2,3,1] -- toTranspositions . fromList == toTrans -- fromTranspositions . toTranspositions == id -- toTransposition . fromTranspositions == id (for reduced expressions only) inversions g = [(i,j) | i <- [1..n], j <- [i+1..n], i .^ g > j .^ g] where n = maximum $ supp g -- it's clear that the word length == number of inversions, -- since both are equal to bubblesort distance -- (well actually, need proof that expression returned by bubblesort is shortest, but it's fairly obvious HaskellForMaths-0.4.8/Math/Algebra/Group/PermutationGroup.hs0000644000000000000000000004722012514742102022145 0ustar0000000000000000-- Copyright (c) David Amos, 2008-2012. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction #-} -- |A module for doing arithmetic in permutation groups. -- -- Group elements are represented as permutations of underlying sets, and are entered and displayed -- using a Haskell-friendly version of cycle notation. For example, the permutation (1 2 3)(4 5) -- would be entered as @p [[1,2,3],[4,5]]@, and displayed as [[1,2,3],[4,5]]. Permutations can be defined -- over arbitrary underlying sets (types), not just the integers. -- -- If @g@ and @h@ are group elements, then the expressions @g*h@ and @g^-1@ calculate product and inverse respectively. module Math.Algebra.Group.PermutationGroup where import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S import Math.Common.ListSet (toListSet, union, (\\) ) -- a version of union which assumes the arguments are ascending sets (no repeated elements) import Math.Core.Utils hiding (elts) import Math.Algebra.LinearAlgebra hiding (inverse) -- only needed for use in ghci infix 8 ~^ rotateL (x:xs) = xs ++ [x] -- PERMUTATIONS -- |A type for permutations, considered as functions or actions which can be performed on an underlying set. newtype Permutation a = P (M.Map a a) deriving (Eq,Ord) -- Can't make a Functor instance because we need an Ord instance fmapP f = fromPairs . map (\(x,y) -> (f x, f y)) . toPairs -- |Construct a permutation from a list of cycles. -- For example, @p [[1,2,3],[4,5]]@ returns the permutation that sends 1 to 2, 2 to 3, 3 to 1, 4 to 5, 5 to 4. p :: (Ord a) => [[a]] -> Permutation a p = fromCycles fromPairs xys | isValid = fromPairs' xys | otherwise = error "Not a permutation" where (xs,ys) = unzip xys (xs',ys') = (L.sort xs, L.sort ys) isValid = xs' == ys' && all ((==1) . length) (L.group xs') -- ie the domain and range are the same, and are *sets* fromPairs' xys = P $ M.fromList $ filter (uncurry (/=)) xys -- we remove fixed points, so that the derived Eq instance works as expected toPairs (P g) = M.toList g fromList xs = fromPairs $ zip xs (L.sort xs) -- for example, fromList [2,3,1] is [[1,3,2]] - because the 1 moved to the 3 position -- the support of a permutation is the points it moves (returned in ascending order) supp (P g) = M.keys g -- (This is guaranteed not to contain fixed points provided the permutations have been constructed using the supplied constructors) -- |x .^ g returns the image of a vertex or point x under the action of the permutation g. -- For example, @1 .^ p [[1,2,3]]@ returns 2. -- The dot is meant to be a mnemonic for point or vertex. (.^) :: (Ord a) => a -> Permutation a -> a x .^ P g = case M.lookup x g of Just y -> y Nothing -> x -- if x `notElem` supp (P g), then x is not moved -- |b -^ g returns the image of an edge or block b under the action of the permutation g. -- For example, @[1,2] -^ p [[1,4],[2,3]]@ returns [3,4]. -- The dash is meant to be a mnemonic for edge or line or block. (-^) :: (Ord a) => [a] -> Permutation a -> [a] xs -^ g = L.sort [x .^ g | x <- xs] -- construct a permutation from cycles -- fromCycles cs = fromPairs $ concatMap fromCycle cs fromCycles cs = product $ map (fromPairs . fromCycle) cs where fromCycle xs = zip xs (rotateL xs) -- convert a permutation to cycles toCycles g = toCycles' $ supp g where toCycles' ys@(y:_) = let c = cycleOf g y in c : toCycles' (ys L.\\ c) toCycles' [] = [] cycleOf g x = cycleOf' x [] where 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 | 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 sign g = (-1)^(parity g) orderElt g = foldl lcm 1 $ map length $ toCycles g -- == order [g] -- |The Num instance is what enables us to write @g*h@ for the product of group elements and @1@ for the group identity. -- Unfortunately we can't of course give sensible definitions for the other functions declared in the Num typeclass. instance Ord a => Num (Permutation a) where g * h = fromPairs' [(x, x .^ g .^ h) | x <- supp g `union` supp h] -- signum = sign -- doesn't work, complains about no (+) instance fromInteger 1 = P $ M.empty _ + _ = error "(Permutation a).+: not applicable" negate _ = error "(Permutation a).negate: not applicable" abs _ = error "(Permutation a).abs: not applicable" signum _ = error "(Permutation a).signum: not applicable" -- |The HasInverses instance is what enables us to write @g^-1@ for the inverse of a group element. instance Ord a => HasInverses (Permutation a) where inverse (P g) = P $ M.fromList $ map (\(x,y)->(y,x)) $ M.toList g -- |g ~^ h returns the conjugate of g by h, that is, h^-1*g*h. -- The tilde is meant to a mnemonic, because conjugacy is an equivalence relation. (~^) :: Ord a => Permutation a -> Permutation a -> Permutation a g ~^ h = h^-1 * g * h -- commutator comm g h = g^-1 * h^-1 * g * h -- ORBITS {- closureS xs fs = closure' S.empty (S.fromList xs) where closure' interior boundary | S.null boundary = interior | otherwise = let interior' = S.union interior boundary boundary' = S.fromList [f x | x <- S.toList boundary, f <- fs] S.\\ interior' in closure' interior' boundary' -} closureS xs fs = closure' S.empty xs where closure' interior (x:xs) | S.member x interior = closure' interior xs | otherwise = closure' (S.insert x interior) ([f x | f <- fs] ++ xs) closure' interior [] = interior closure xs fs = S.toList $ closureS xs fs orbit action x gs = closure [x] [ (`action` g) | g <- gs] -- |x .^^ gs returns the orbit of the point or vertex x under the action of the gs (.^^) :: (Ord a) => a -> [Permutation a] -> [a] x .^^ gs = orbit (.^) x gs orbitP gs x = orbit (.^) x gs orbitV gs x = orbit (.^) x gs -- |b -^^ gs returns the orbit of the block or edge b under the action of the gs (-^^) :: (Ord a) => [a] -> [Permutation a] -> [[a]] b -^^ gs = orbit (-^) b gs orbitB gs b = orbit (-^) b gs orbitE gs b = orbit (-^) b gs action xs f = fromPairs [(x, f x) | x <- xs] -- find all the orbits of a group -- (as we typically work with transitive groups, this is more useful for studying induced actions) -- (Note that of course this won't find orbits of points which are fixed by all elts of G) orbits gs = let xs = foldl union [] $ map supp gs in orbits' xs where orbits' [] = [] orbits' (x:xs) = let o = x .^^ gs in o : orbits' (xs L.\\ o) -- GROUPS -- Some standard sequences of groups, and constructions of new groups from old -- |_C n returns generators for Cn, the cyclic group of order n _C :: (Integral a) => a -> [Permutation a] _C n | n >= 2 = [p [[1..n]]] -- D2n, dihedral group of order 2n, symmetry group of n-gon -- For example, _D 8 == _D2 4 == symmetry group of square _D n | r == 0 = _D2 q where (q,r) = n `quotRem` 2 _D2 n | n >= 3 = [a,b] where a = p [[1..n]] -- rotation b = p [[i,n+1-i] | i <- [1..n `div` 2]] -- reflection -- b = fromPairs $ [(i,n+1-i) | i <- [1..n]] -- reflection -- |_S n returns generators for Sn, the symmetric group on [1..n] _S :: (Integral a) => a -> [Permutation a] _S n | n >= 3 = [s,t] | n == 2 = [t] | n == 1 = [] where s = p [[1..n]] t = p [[1,2]] -- |_A n returns generators for An, the alternating group on [1..n] _A :: (Integral a) => a -> [Permutation a] _A n | n > 3 = [s,t] | n == 3 = [t] | n == 2 = [] where s | odd n = p [[3..n]] | even n = p [[1,2], [3..n]] t = p [[1,2,3]] -- |Given generators for groups H and K, acting on sets A and B respectively, -- return generators for the direct product H*K, acting on the disjoint union A+B (= Either A B) dp :: (Ord a, Ord b) => [Permutation a] -> [Permutation b] -> [Permutation (Either a b)] dp hs ks = [P $ M.fromList $ map (\(x,x') -> (Left x,Left x')) $ M.toList h' | P h' <- hs] ++ [P $ M.fromList $ map (\(y,y') -> (Right y,Right y')) $ M.toList k' | P k' <- ks] -- Wreath product of groups -- Given generators for H and K, acting on sets X and Y respectively, -- return generators for H wr K, acting on X*Y (== (X,Y)) -- (Cameron, Combinatorics, p229-230; Cameron, Permutation Groups, p11-12) wr hs ks = let _X = S.toList $ foldl S.union S.empty [M.keysSet h' | P h' <- hs] -- set on which H acts _Y = S.toList $ foldl S.union S.empty [M.keysSet k' | P k' <- ks] -- set on which K acts -- Then the wreath product acts on cartesian product X * Y, -- regarded as a fibre bundle over Y of isomorphic copies of X _B = [P $ M.fromList $ map (\(x,x') -> ((x,y),(x',y))) $ M.toList h' | P h' <- hs, y <- _Y] -- bottom group B applies the action of H within each fibre _T = [P $ M.fromList [((x,y),(x,y')) | x <- _X, (y,y') <- M.toList k'] | P k' <- ks] -- top group T uses the action of K to permute the fibres in _B ++ _T -- semi-direct product of B and T -- !! Why using M.keysSet rather than supp? -- embed group elts into Sn - ie, convert so that the set acted on is [1..n] toSn gs = [toSn' g | g <- gs] where _X = L.sort $ foldl union [] $ map supp gs -- the set on which G acts mapping = M.fromList $ zip _X [1..] -- the mapping from _X to [1..n] toSn' g = fromPairs' $ map (\(x,x') -> (mapping M.! x, mapping M.! x')) $ toPairs g -- Given a permutation over lists of small positive integers, such as [1,2,3], -- return a permutation over the integers obtained by interpreting the lists as digits. -- For example, [1,2,3] -> 123. fromDigits g = fromPairs [(fromDigits' x, fromDigits' y) | (x,y) <- toPairs g] fromDigits' xs = f (reverse xs) where f (x:xs) = x + 10 * f xs f [] = 0 -- Given a permutation over lists of 0s and 1s, -- return the permutation obtained by interpreting these as binary digits. -- For example, [1,1,0] -> 6. fromBinary g = fromPairs [(fromBinary' x, fromBinary' y) | (x,y) <- toPairs g] fromBinary' xs = f (reverse xs) where f (x:xs) = x + 2 * f xs f [] = 0 -- INVESTIGATING GROUPS -- Functions to investigate groups in various ways -- Most of these functions will only be efficient for small groups (say |G| < 10000) -- For larger groups we will need to use Schreier-Sims and associated algorithms -- |Given generators for a group, return a (sorted) list of all elements of the group. -- Implemented using a naive closure algorithm, so only suitable for small groups (|G| < 10000) elts :: (Num a, Ord a) => [a] -> [a] elts gs = closure [1] [ (*g) | g <- gs] eltsS gs = closureS [1] [ (*g) | g <- gs] -- |Given generators for a group, return the order of the group (the number of elements). -- Implemented using a naive closure algorithm, so only suitable for small groups (|G| < 10000) order :: (Num a, Ord a) => [a] -> Int order gs = S.size $ eltsS gs -- length $ elts gs isMember gs h = h `S.member` eltsS gs -- h `elem` elts gs -- TRANSVERSAL GENERATING SETS -- The functions graphAuts2 and graphAuts3 return generating sets consisting of successive transversals -- In this case, we don't need to run Schreier-Sims to list elements or calculate order minsupp = head . supp -- calculate the order of the group, given a "transversal generating set" orderTGS tgs = let transversals = map (1:) $ L.groupBy (\g h -> minsupp g == minsupp h) tgs in product $ map L.genericLength transversals -- list the elts of the group, given a "transversal generating set" eltsTGS tgs = let transversals = map (1:) $ L.groupBy (\g h -> minsupp g == minsupp h) tgs in map product $ sequence transversals -- recover a transversal generating set from a strong generating set -- A strong generating set is a generating set gs such that = si -- ie, its intersection with each successive stabiliser in the chain generates the stabiliser tgsFromSgs sgs = concatMap transversal bs where bs = toListSet $ map minsupp sgs transversal b = closure b $ filter ( (b <=) . minsupp ) sgs closure b gs = closure' M.empty (M.fromList [(b, 1)]) where closure' interior boundary | M.null boundary = filter (/=1) $ M.elems interior | otherwise = let interior' = M.union interior boundary boundary' = M.fromList [(x .^ g, h*g) | (x,h) <- M.toList boundary, g <- gs] M.\\ interior' in closure' interior' boundary' -- For example, sgs (_A 5) == [[[1,2,3]],[[2,4,5]],[[3,4,5]]] -- So we need all three to generate the first transversal, then the last two to generate the second transversal, etc -- |Given a strong generating set, return the order of the group it generates. -- Note that the SGS is assumed to be relative to the natural order of the points on which the group acts. orderSGS :: (Ord a) => [Permutation a] -> Integer orderSGS sgs = product $ map (L.genericLength . fundamentalOrbit) bs where bs = toListSet $ map minsupp sgs fundamentalOrbit b = b .^^ filter ( (b <=) . minsupp ) sgs -- !! Needs more testing -- |Given a base and strong generating set, return the order of the group it generates. orderBSGS :: (Ord a) => ([a],[Permutation a]) -> Integer orderBSGS (bs,sgs) = go 1 bs sgs where go n [] _ = n go n (b:bs) gs = go (n * L.genericLength (b .^^ gs)) bs (filter (\g -> b .^ g == b) gs) -- MORE INVESTIGATIONS -- given the elts of a group, find generators gens hs = gens' [] (S.singleton 1) hs where gens' gs eltsG (h:hs) = if h `S.member` eltsG then gens' gs eltsG hs else gens' (h:gs) (eltsS $ h:gs) hs gens' gs _ [] = reverse gs -- conjClass gs h = orbit (~^) gs h -- Conjugacy class - should only be used for small groups h ~^^ gs = conjClass gs h conjClass gs h = closure [h] [ (~^ g) | g <- gs] -- conjClass gs h = h ~^^ gs -- |conjClassReps gs returns conjugacy class representatives and sizes for the group generated by gs. -- This implementation is only suitable for use with small groups (|G| < 10000). conjClassReps :: (Ord a, Show a) => [Permutation a] -> [(Permutation a, Int)] conjClassReps gs = conjClassReps' (elts gs) where conjClassReps' (h:hs) = let cc = conjClass gs h in (h, length cc) : conjClassReps' (hs \\ cc) conjClassReps' [] = [] -- using the ListSet implementation of \\, since we know both lists are sorted {- -- This is just the orbits under conjugation. Can we generalise "orbits" to help us here? conjClasses gs = conjClasses' (elts gs) where conjClasses' [] = [] conjClasses' (h:hs) = let c = conjClass gs h in c : conjClasses' (hs L.\\ c) -} -- given list of generators, try to find a shorter list reduceGens (1:gs) = reduceGens gs reduceGens (g:gs) = reduceGens' ([g], eltsS [g]) gs where reduceGens' (gs,eltsgs) (h:hs) = if h `S.member` eltsgs then reduceGens' (gs,eltsgs) hs else reduceGens' (h:gs, eltsS $ h:gs) hs reduceGens' (gs,_) [] = reverse gs -- SUBGROUPS isSubgp hs gs = all (`S.member` gs') hs where gs' = eltsS gs -- The following is similar to the "cyclic extension" method - Holt p385 -- However, Holt only looks at normal cyclic extensions (ie, by an elt of prime order), and so only finds solvable subgps -- |Return the subgroups of a group. Only suitable for use on small groups (eg < 100 elts) subgps :: (Ord a, Show a) => [Permutation a] -> [[Permutation a]] subgps gs = [] : subgps' S.empty [] (map (:[]) hs) where hs = filter isMinimal $ elts gs subgps' found ls (r:rs) = let ks = elts r in if ks `S.member` found then subgps' found ls rs else r : subgps' (S.insert ks found) (r:ls) rs subgps' found [] [] = [] subgps' found ls [] = subgps' found [] [l ++ [h] | l <- reverse ls, h <- hs, last l < h] -- g is the minimal elt in the cyclic subgp it generates isMinimal 1 = False isMinimal g = all (g <=) primitives -- g == minimum primitives where powers = takeWhile (/=1) $ tail $ iterate (*g) 1 n = orderElt g -- == length powers + 1 primitives = filter (\h -> orderElt h == n) powers -- centralizer of a subgroup or a set of elts -- the centralizer of H in G is the set of elts of G which commute with all elts of H centralizer gs hs = [k | k <- elts gs, all (\h -> h*k == k*h) hs] -- the centre of G is the set of elts of G which commute with all other elts centre gs = centralizer gs gs -- normaliser of a subgroup -- the normaliser of H in G is {g <- G | g^-1Hg == H} -- it is a subgroup of G, and H is a normal subgroup of it: H <|= N_G(H) <= G normalizer gs hs = [g | g <- elts gs, all (\h -> h~^g `elem` elts hs) hs] -- stabilizer of a point stabilizer gs x = [g | g <- elts gs, x .^ g == x] -- pointwise stabiliser of a set ptStab gs xs = [g | g <- elts gs, and [x .^ g == x | x <- xs] ] -- setwise stabiliser of a set setStab gs xs = [g | g <- elts gs, xs -^ g == xs] -- normal closure of H in G normalClosure gs hs = reduceGens $ hs ++ [h ~^ g | h <- hs, g <- gs ++ map inverse gs] -- commutator gp of H and K commutatorGp hs ks = normalClosure (hsks) [h^-1 * k^-1 * h * k | h <- hs', k <- ks'] where hs' = reduceGens hs ks' = reduceGens ks hsks = reduceGens (hs' ++ ks') -- no point processing more potential generators than we have to -- derived subgroup derivedSubgp gs = commutatorGp gs gs -- ACTION ON COSETS, QUOTIENT GROUPS xs -*- ys = toListSet [x*y | x <- xs, y <- ys] xs -* y = L.sort [x*y | x <- xs] -- == xs -*- [y] x *- ys = L.sort [x*y | y <- ys] -- == [x] -*- ys -- |isNormal gs ks returns True if \ is normal in \. -- Note, it is caller's responsibility to ensure that \ is a subgroup of \ (ie that each k is in \). isNormal :: (Ord a, Show a) => [Permutation a] -> [Permutation a] -> Bool isNormal gs ks = all (== ks') [ (g^-1) *- ks' -* g | g <- gs] where ks' = elts ks -- |Return the normal subgroups of a group. Only suitable for use on small groups (eg < 100 elts) normalSubgps :: (Ord a, Show a) => [Permutation a] -> [[Permutation a]] normalSubgps gs = filter (isNormal gs) (subgps gs) isSimple gs = length (normalSubgps gs) == 2 -- Note: caller must ensure that hs is a subgp of gs cosets gs hs = orbit (-*) hs' gs where hs' = elts hs -- |quotientGp gs ks returns \ / \ quotientGp :: (Ord a, Show a) => [Permutation a] -> [Permutation a] -> [Permutation Int] quotientGp gs ks | ks `isNormal` gs = gens $ toSn [action cosetsK (-* g) | g <- gs] | otherwise = error "quotientGp: not well defined unless ks normal in gs" where cosetsK = cosets gs ks -- |Synonym for quotientGp (//) :: (Ord a, Show a) => [Permutation a] -> [Permutation a] -> [Permutation Int] gs // ks = quotientGp gs ks -- action of group element on a subset by conjugation xs ~~^ g = L.sort [x ~^ g | x <- xs] conjugateSubgps gs hs = orbit (~~^) hs' gs where hs' = elts hs -- not necessarily transitive on isomorphic subgps - eg a gp with an outer aut subgpAction gs hs = let conjugatesH = conjugateSubgps gs hs in toSn [action conjugatesH (~~^ g) | g <- gs] -- in cube gp, the subgps all appear to correspond to stabilisers of subsets, or of blocks -- right regular permutation representation rrpr gs h = rrpr' (elts gs) h rrpr' gs h = fromPairs [(g, g*h) | g <- gs] permutationMatrix xs g = [ [if x .^ g == y then 1 else 0 | y <- xs] | x <- xs ] HaskellForMaths-0.4.8/Math/Algebra/Group/RandomSchreierSims.hs0000644000000000000000000001146312514742102022362 0ustar0000000000000000-- Copyright (c) David Amos, 2009. All rights reserved. module Math.Algebra.Group.RandomSchreierSims where import System.Random import Data.List as L import qualified Data.Map as M import Data.Maybe import Control.Monad import Data.Array.MArray import Data.Array.IO import System.IO.Unsafe import Math.Common.ListSet (toListSet) import Math.Core.Utils hiding (elts) import Math.Algebra.Group.PermutationGroup import Math.Algebra.Group.SchreierSims (sift, cosetRepsGx, ss') testProdRepl = do (r,xs) <- initProdRepl $ _D 10 hs <- replicateM 20 $ nextProdRepl (r,xs) mapM_ print hs -- Holt p69-71 -- Product replacement algorithm for generating uniformly distributed random elts of a black box group initProdRepl :: (Ord a, Show a) => [Permutation a] -> IO (Int, IOArray Int (Permutation a)) initProdRepl gs = let n = length gs r = max 10 n xs = (1:) $ take r $ concat $ repeat gs in do xs' <- newListArray (0,r) xs replicateM_ 60 $ nextProdRepl (r,xs') -- perform initial mixing return (r,xs') nextProdRepl :: (Ord a, Show a) => (Int, IOArray Int (Permutation a)) -> IO (Maybe (Permutation a)) nextProdRepl (r,xs) = do s <- randomRIO (1,r) t <- randomRIO (1,r) u <- randomRIO (0,3 :: Int) out <- updateArray xs s t u return out updateArray xs s t u = let (swap,invert) = quotRem u 2 in if s == t then return Nothing else do x_0 <- readArray xs 0 x_s <- readArray xs s x_t <- readArray xs t let x_s' = mult (swap,invert) x_s x_t x_0' = mult (swap,0) x_0 x_s' writeArray xs 0 x_0' writeArray xs s x_s' return (Just x_0') where mult (swap,invert) a b = case (swap,invert) of (0,0) -> a * b (0,1) -> a * b^-1 (1,0) -> b * a (1,1) -> b^-1 * a -- Holt p97-8 -- Random Schreier-Sims algorithm, for finding strong generating set of permutation group -- It's possible that the following code can be improved by introducing levels only as we need them? -- |Given generators for a permutation group, return a strong generating set. -- The result is calculated using random Schreier-Sims algorithm, so has a small (\<10^-6) chance of being incomplete. -- The sgs is relative to the base implied by the Ord instance. sgs :: (Ord a, Show a) => [Permutation a] -> [Permutation a] sgs gs = toListSet $ concatMap snd $ rss gs rss gs = unsafePerformIO $ do (r,xs) <- initProdRepl gs rss' (r,xs) (initLevels gs) 0 rss' (r,xs) levels i | i == 25 = return levels -- stop if we've had 25 successful sifts in a row | otherwise = do g <- nextProdRepl (r,xs) let (changed,levels') = updateLevels levels g rss' (r,xs) levels' (if changed then 0 else i+1) -- if we currently have an sgs for a subgroup of the group, then it must have index >= 2 -- so the chance of a random elt sifting to identity is <= 1/2 initLevels gs = [((b,M.singleton b 1),[]) | b <- bs] where bs = toListSet $ concatMap supp gs updateLevels levels Nothing = (False,levels) -- not strictly correct to increment count on a Nothing updateLevels levels (Just g) = case sift (map fst levels) g of Nothing -> (False, levels) -- Just 1 -> error "Just 1" Just g' -> (True, updateLevels' [] levels g' (minsupp g')) updateLevels' ls (r@((b,t),s):rs) h b' = if b == b' then reverse ls ++ ((b, cosetRepsGx (h:s) b), h:s) : rs else updateLevels' (r:ls) rs h b' -- updateLevels' ls [] h b' = error $ "updateLevels: " ++ show (ls,[],h,b') -- used the following in debugging -- orderLevels levels = product $ [if M.null t then 1 else toInteger (M.size t) | ((b,t),s) <- levels] -- recover the base tranversals from the sgs. gs must be an sgs -- baseTransversalsSGS gs = [let hs = [h | h <- gs, b <= minsupp h] in (b, cosetRepsGx hs b) | b <- bs] baseTransversalsSGS gs = [let hs = filter ( (b <=) . minsupp ) gs in (b, cosetRepsGx hs b) | b <- bs] where bs = toListSet $ map minsupp gs -- where bs = toListSet $ concatMap supp gs -- |Given a strong generating set gs, isMemberSGS gs is a membership test for the group isMemberSGS :: (Ord a, Show a) => [Permutation a] -> Permutation a -> Bool isMemberSGS gs h = let bts = baseTransversalsSGS gs in isNothing $ sift bts h {- -- Alternative where we carry on with Schreier-Sims when we finish Random Schreier-Sims, just to make sure -- !! Unfortunately, doesn't appear to work - perhaps ss' doesn't like finding empty levels sgs2 gs = toListSet $ concatMap snd $ rss2 gs rss2 gs = unsafePerformIO $ do (r,xs) <- initProdRepl gs levels <- rss' (r,xs) (initLevels gs) 0 return $ ss' bs (reverse levels) [] where bs = toListSet $ concatMap supp gs -} HaskellForMaths-0.4.8/Math/Algebra/Group/SchreierSims.hs0000644000000000000000000002144312514742102021220 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. module Math.Algebra.Group.SchreierSims where import qualified Data.List as L import Data.Maybe (isNothing, isJust) import qualified Data.Set as S import qualified Data.Map as M import Math.Algebra.Group.PermutationGroup hiding (elts, order, orderBSGS, gens, isMember, isSubgp, isNormal, reduceGens, normalClosure, commutatorGp, derivedSubgp) import Math.Common.ListSet (toListSet) import Math.Core.Utils hiding (elts) -- COSET REPRESENTATIVES FOR STABILISER OF A POINT -- Given a group G = , and a point x, find (right) coset representatives for Gx (stabiliser of x) in G -- In other words, for each x' in the orbit of x under G, we find a g <- G taking x to x' -- The code is similar to the code for calculating orbits, but modified to keep track of the group elements that we used to get there cosetRepsGx gs x = cosetRepsGx' gs M.empty (M.singleton x 1) where cosetRepsGx' gs interior boundary | M.null boundary = interior | otherwise = let interior' = M.union interior boundary boundary' = M.fromList [(p .^ g, h*g) | g <- gs, (p,h) <- M.toList boundary] M.\\ interior' in cosetRepsGx' gs interior' boundary' -- SCHREIER GENERATORS -- toSet xs = (map head . group . sort) xs -- Generators for Gx, the stabiliser of x, given that G is generated by gs, and rs is a set of coset representatives for Gx in G. -- Schreier's Lemma states that if H < G = , and R is a set of coset reps for H in G -- then H is generated by { rs(rs)*^-1 | r <- R, s <- S } (where * means "the coset representative of") -- In particular, with H = Gx, this gives us a way of finding a set of generators for Gx schreierGeneratorsGx (x,rs) gs = L.nub $ filter (/= 1) [schreierGenerator r g | r <- M.elems rs, g <- gs] where schreierGenerator r g = let h = r * g h' = rs M.! (x .^ h) in h * inverse h' -- SCHREIER-SIMS ALGORITHM -- Given a list of right transversals for a stabiliser chain, sift a group element through it -- Note, this version assumes the base is non-redundant sift _ 1 = Nothing sift ((b,t):bts) g = case M.lookup (b .^ g) t of Nothing -> Just g -- Nothing -> sift bts g -- if we allow redundant levels Just h -> sift bts (g * inverse h) sift [] g = Just g -- g == 1 case already caught above -- findBase gs = minimum $ concatMap supp gs findBase gs = minimum $ map minsupp gs {- -- Find base and strong generating set using Schreier-Sims algorithm bsgs gs | all (/= 1) gs = map fst $ ss [newLevel gs] [] newLevel s = let b = findBase s t = cosetRepsGx s b in ((b,t),s) ss (bad@((b,t),s):bads) goods = let bts = map fst goods sgs = schreierGeneratorsGx (b,t) s siftees = filter isJust $ map (sift bts) sgs in if null siftees then ss bads (bad:goods) else let Just h = head siftees in if null goods then ss (newLevel [h] : bad : bads) [] else let ((b_,t_),s_) = head goods s' = h:s_ t' = cosetRepsGx s' b_ in ss (((b_,t'),s') : bad : bads) (tail goods) ss [] goods = goods -} -- |Given generators for a permutation group, return a strong generating set. -- The result is calculated using Schreier-Sims algorithm, and is relative to the base implied by the Ord instance sgs :: (Ord a, Show a) => [Permutation a] -> [Permutation a] sgs gs = toListSet $ concatMap snd $ ss bs gs where bs = toListSet $ concatMap supp gs -- Find base and strong generating set using Schreier-Sims algorithm -- !! This function is poorly named - it actually finds you a base and sets of transversals -- This version guarantees to use bases in order bsgs gs = bsgs' bs gs where bs = toListSet $ concatMap supp gs -- This version lets you pass in bases in the order you want them (or [], and it will find its own) bsgs' bs gs = map fst $ ss bs gs -- For example, bsgs (_A 5) uses [1,2,3] as the bases, but bsgs' [] (_A 5) uses [1,3,2] newLevel (b:bs) s = (bs, newLevel' b s) newLevel [] s = ([], newLevel' b s) where b = findBase s newLevel' b s = ((b,t),s) where t = cosetRepsGx s b ss bs gs = ss' bs' [level] [] where (bs',level) = newLevel bs $ filter (/=1) gs ss' bs (bad@((b,t),s):bads) goods = let bts = map fst goods sgs = schreierGeneratorsGx (b,t) s siftees = filter isJust $ map (sift bts) sgs in if null siftees then ss' bs bads (bad:goods) else let Just h = head siftees in if null goods then let (bs', level) = newLevel bs [h] in ss' bs' (level : bad : bads) [] else let ((b_,t_),s_) = head goods s' = h:s_ t' = cosetRepsGx s' b_ in ss' bs (((b_,t'),s') : bad : bads) (tail goods) ss' _ [] goods = goods {- extendbsgs [] g = bsgs [g] extendbsgs (((b,t),s):bts) g = ss (((b,t),g:s):bts) [] bsgs' gs = map fst $ foldl extendbsgs [] gs -} -- The above is written for simplicity. -- Its efficiency could be improved by incrementally updating the transversals, -- and keeping track of Schreier generators we have already tried. -- (Remember to add new Schreier generators every time the generating set or transversal is augmented.) -- USING THE SCHREIER-SIMS TRANSVERSALS isMemberBSGS bts g = isNothing $ sift bts g -- By Lagrange's thm, every g <- G can be written uniquely as g = r_m ... r_1 (Seress p56) -- Note that we have to reverse the list of coset representatives eltsBSGS bts = map (product . reverse) (cartProd ts) where ts = map (M.elems . snd) bts cartProd (set:sets) = [x:xs | x <- set, xs <- cartProd sets] cartProd [] = [[]] orderBSGS bts = product (map (toInteger . M.size . snd) bts) -- |Given generators for a group, determine whether a permutation is a member of the group, using Schreier-Sims algorithm isMember :: (Ord t, Show t) => [Permutation t] -> Permutation t -> Bool isMember gs h = isMemberBSGS (bsgs gs) h -- |Given generators for a group, return a (sorted) list of all elements of the group, using Schreier-Sims algorithm elts :: (Ord t, Show t) => [Permutation t] -> [Permutation t] elts [] = [1] elts gs = eltsBSGS $ bsgs gs -- |Given generators for a group, return the order of the group (the number of elements), using Schreier-Sims algorithm order :: (Ord t, Show t) => [Permutation t] -> Integer order [] = 1 order gs = orderBSGS $ bsgs gs isSubgp hs gs = all (isMemberBSGS gs') hs where gs' = bsgs gs isNormal hs gs = hs `isSubgp` gs && all (isMemberBSGS hs') [h~^g | h <- hs, g <- gs] where hs' = bsgs hs index gs hs = order gs `div` order hs -- given list of generators, try to find a shorter list reduceGens gs = fst $ reduceGensBSGS (filter (/=1) gs) reduceGensBSGS (g:gs) = reduceGens' ([g],bsgs [g]) gs where reduceGens' (gs,bsgsgs) (h:hs) = if isMemberBSGS bsgsgs h then reduceGens' (gs,bsgsgs) hs else reduceGens' (h:gs, bsgs $ h:gs) hs reduceGens' (gs,bsgsgs) [] = (reverse gs,bsgsgs) reduceGensBSGS [] = ([],[]) -- normal closure of H in G -- for efficiency, should be called with gs and hs already reduced sets of generators normalClosure gs hs = reduceGens $ hs ++ [h ~^ g | h <- hs, g <- gs'] where gs' = gs ++ map inverse gs -- commutator gp of H and K commutatorGp hs ks = normalClosure (hsks) [h^-1 * k^-1 * h * k | h <- hs', k <- ks'] where hs' = reduceGens hs ks' = reduceGens ks hsks = reduceGens (hs' ++ ks') -- no point processing more potential generators than we have to -- derived subgroup (or commutator subgroup) derivedSubgp gs = normalClosure gs' [g^-1 * h^-1 * g * h | g <- gs', h <- gs'] where gs' = reduceGens gs -- == commutatorGp gs gs {- isPerfect gs = order gs == order (derivedSubgp gs) -- We compare orders rather than the generators themselves, because derivedSubgp will usually find different generators derivedSeries gs = derivedSeries' (gs, order gs) where derivedSeries' ([],1) = [[]] derivedSeries' (hs, orderhs) = let hs' = derivedSubgp hs orderhs' = order hs' in if orderhs' == orderhs then [hs] else hs : derivedSeries' (hs',orderhs') lowerCentralSeries gs = lowerCentralSeries' (gs, order gs) where lowerCentralSeries' ([],1) = [[]] lowerCentralSeries' (hs, orderhs) = let hs' = commutatorGp gs hs orderhs' = order hs' in if orderhs' == orderhs then [hs] else hs : lowerCentralSeries' (hs',orderhs') -} HaskellForMaths-0.4.8/Math/Algebra/Group/StringRewriting.hs0000644000000000000000000002253312514742102021762 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. module Math.Algebra.Group.StringRewriting where import Data.List as L import Data.Maybe (catMaybes) -- REWRITING -- |Given a list of rewrite rules of the form (left,right), and a word, -- rewrite it by repeatedly replacing any left substring in the word by the corresponding right rewrite :: (Eq a) => [([a], [a])] -> [a] -> [a] rewrite rules word = rewrite' rules word where rewrite' (r:rs) xs = case rewrite1 r xs of Nothing -> rewrite' rs xs Just ys -> rewrite' rules ys rewrite' [] xs = xs rewrite1 (l,r) xs = case xs `splitSubstring` l of Nothing -> Nothing Just (a,b) -> Just (a++r++b) -- given a string x and a substring b, find if possible (a,c) such that xs = abc splitSubstring xs ys = splitSubstring' [] xs where splitSubstring' ls [] = Nothing splitSubstring' ls (r:rs) = if ys `L.isPrefixOf` (r:rs) then Just (reverse ls, drop (length ys) (r:rs)) else splitSubstring' (r:ls) rs -- there might be a more efficient way to do this -- KNUTH-BENDIX -- given two strings x,y, find if possible a,b,c with x=ab y=bc findOverlap xs ys = findOverlap' [] xs ys where findOverlap' as [] cs = Nothing -- (reverse as, [], cs) findOverlap' as (b:bs) cs = if (b:bs) `L.isPrefixOf` cs then Just (reverse as, b:bs, drop (length (b:bs)) cs) else findOverlap' (b:as) bs cs -- there might be a more efficient way to do this -- note that findOverlap "abab" "abab" won't find the partial overlap ("ab","ab","ab") -- Knuth-Bendix algorithm -- http://en.wikipedia.org/wiki/Knuth-Bendix_algorithm -- Given a set of rules (assumed already reduced with respect to each other) -- return a confluent rewrite system knuthBendix1 rules = knuthBendix' rules pairs where pairs = [(lri,lrj) | lri <- rules, lrj <- rules, lri /= lrj] knuthBendix' rules [] = rules -- should reduce in some way knuthBendix' rules ( ((li,ri),(lj,rj)) : ps) = case findOverlap li lj of Nothing -> knuthBendix' rules ps Just (a,b,c) -> case ordpair (rewrite rules (ri++c)) (rewrite rules (a++rj)) of Nothing -> knuthBendix' rules ps -- they both reduce to the same thing Just rule' -> let rules' = reduce rule' rules ps' = ps ++ [(rule',rule) | rule <- rules'] ++ [(rule,rule') | rule <- rules'] in knuthBendix' (rule':rules') ps' -- the new rule comes from seeing that -- a ++ b ++ c == l1 ++ c -> r1 ++ c (by rule 1) -- a ++ b ++ c == a ++ l2 -> a ++ r2 (by rule 2) reduce rule@(l,r) rules = filter (\(l',r') -> not (L.isInfixOf l l')) rules -- [rule' | rule'@(l',r') <- rules, not (l `L.isInfixOf` l')] ordpair x y = case shortlex x y of LT -> Just (y,x) EQ -> Nothing GT -> Just (x,y) shortlex x y = compare (length x, x) (length y, y) -- for groups, where "letters" will take the form Either a a, we will want a different order, because we will want x^-1 -> x^3 to be the right way round -- An optimisation - keep the rules ordered smallest first, and process the pairs smallest first -- Appears to be significantly faster on average knuthBendix2 rules = map snd $ knuthBendix' rules' pairs where rules' = L.sort $ map sizedRule rules pairs = L.sort [sizedPair sri srj | sri <- rules', srj <- rules', sri /= srj] knuthBendix' rules [] = rules knuthBendix' rules ( (s,(li,ri),(lj,rj)) : ps) = case findOverlap li lj of Nothing -> knuthBendix' rules ps Just (a,b,c) -> case ordpair (rewrite (map snd rules) (ri++c)) (rewrite (map snd rules) (a++rj)) of Nothing -> knuthBendix' rules ps -- they both reduce to the same thing Just rule' -> let rules' = reduce (snd rule') rules -- ps' = L.sort $ ps ++ [sizedPair rule' rule | rule <- rules'] ++ [sizedPair rule rule' | rule <- rules'] ps' = merge ps $ merge [sizedPair rule' rule | rule <- rules'] [sizedPair rule rule' | rule <- rules'] in knuthBendix' (L.insert rule' rules') ps' reduce rule@(l,r) rules = filter (\(s',(l',r')) -> not (L.isInfixOf l l')) rules -- reduce rule@(l,r) rules = [rule' | rule'@(s',(l',r')) <- rules, not (l `L.isInfixOf` l')] ordpair x y = let lx = length x; ly = length y in case compare (lx,x) (ly,y) of LT -> Just (ly,(y,x)); EQ -> Nothing; GT -> Just (lx,(x,y)) sizedRule (rule@(l,r)) = (length l, rule) sizedPair (s1,r1) (s2,r2) = (s1+s2,r1,r2) -- merge two ordered lists merge (x:xs) (y:ys) = case compare x y of LT -> x : merge xs (y:ys) GT -> y : merge (x:xs) ys EQ -> error "" -- shouldn't happen in our case merge xs ys = xs++ys -- Another optimisation - at the stage where we remove some rules, we remove corresponding pairs too -- Seems to perform about 25% faster on large problems (eg Coxeter groups A4-12, B4-12) knuthBendix3 rules = knuthBendix' rules' pairs (length rules' + 1) where rules' = L.sort $ zipWith (\i (l,r) -> (length l,i,(l,r)) ) [1..] rules pairs = L.sort [sizedPair ri rj | ri <- rules', rj <- rules', ri /= rj] knuthBendix' rules [] k = map (\(s,i,r) -> r) rules knuthBendix' rules ( (s,(i,j),((li,ri),(lj,rj))) : ps) k = case findOverlap li lj of Nothing -> knuthBendix' rules ps k Just (a,b,c) -> case ordpair k (rewrite (map third rules) (ri++c)) (rewrite (map third rules) (a++rj)) of Nothing -> knuthBendix' rules ps k -- they both reduce to the same thing Just rule'@(_,_,(l,r)) -> let (outrules,inrules) = L.partition (\(s',i',(l',r')) -> L.isInfixOf l l') rules removedIndices = map second outrules ps' = [p | p@(s,(i,j),(ri,rj)) <- ps, i `notElem` removedIndices, j `notElem` removedIndices] ps'' = merge ps' $ merge [sizedPair rule' rule | rule <- inrules] [sizedPair rule rule' | rule <- inrules] in knuthBendix' (L.insert rule' inrules) ps'' (k+1) ordpair k x y = let lx = length x; ly = length y in case compare (lx,x) (ly,y) of LT -> Just (ly,k,(y,x)); EQ -> Nothing; GT -> Just (lx,k,(x,y)) second (s,i,r) = i third (s,i,r) = r sizedPair (si,i,ri) (sj,j,rj) = (si+sj,(i,j),(ri,rj)) -- |Implementation of the Knuth-Bendix algorithm. Given a list of relations, return a confluent rewrite system. -- The algorithm is not guaranteed to terminate. knuthBendix :: (Ord a) => [([a], [a])] -> [([a], [a])] knuthBendix relations = knuthBendix3 (reduce [] rules) where rules = catMaybes [ordpair x y | (x,y) <- relations] reduce ls (r:rs) = reduce (r: reduce' r ls) (reduce' r rs) reduce ls [] = ls reduce' r rules = catMaybes [ordpair (rewrite [r] lhs) (rewrite [r] rhs) | (lhs,rhs) <- rules] -- |Given generators and a confluent rewrite system, return (normal forms of) all elements nfs :: (Ord a) => ([a], [([a], [a])]) -> [[a]] nfs (gs,rs) = nfs' [[]] where nfs' [] = [] -- we have run out of words - this monoid is finite nfs' ws = let ws' = [g:w | g <- gs, w <- ws, not (any (`L.isPrefixOf` (g:w)) (map fst rs))] in ws ++ nfs' ws' -- |Given generators and relations, return (normal forms of) all elements elts :: (Ord a) => ([a], [([a], [a])]) -> [[a]] elts (gs,rs) = nfs (gs, knuthBendix rs) -- PRESENTATIONS FOR SOME STANDARD GROUPS -- Would like to add a few more to this list newtype SGen = S Int deriving (Eq,Ord) instance Show SGen where show (S i) = "s" ++ show i s_ i = S i s1 = s_ 1 s2 = s_ 2 s3 = s_ 3 -- D L Johnson, Presentations of Groups, p62 -- symmetric group, generated by adjacent transpositions _S n = (gs, r ++ s ++ t) where gs = map s_ [1..n-1] r = [([s_ i, s_ i],[]) | i <- [1..n-1]] s = [(concat $ replicate 3 [s_ i, s_ (i+1)],[]) | i <- [1..n-2]] t = [([s_ i, s_ j, s_ i, s_ j],[]) | i <- [1..n-1], j <- [i+2..n-1]] -- braid presentation for Sn _S' n = (gs, r ++ s ++ t) where gs = map s_ [1..n-1] r = [([s_ i, s_ i], []) | i <- [1..n-1]] s = [([s_ (i+1), s_ i, s_ (i+1)], [s_ i, s_ (i+1), s_ i] ) | i <- [1..n-2]] t = [([s_ i, s_ j, s_ i, s_ j], []) | i <- [1..n-1], j <- [i+2..n-1]] -- http://en.wikipedia.org/wiki/Triangle_group -- triangle groups - Johnson p127ff tri l m n = ("abc", [("aa",""),("bb",""),("cc",""),("ab" ^ l,""),("bc" ^ n,""),("ca" ^ m,"" )]) where xs ^ i = concat $ replicate i xs -- von Dyck groups - Johnson p121ff -- The subgroup of index 2 in the triangle group consisting of elts that preserve the orientation of the triangle _D l m n = ("xy", [("x" ^ l,""), ("y" ^ m,""), ("xy" ^ n,"")]) where xs ^ i = concat $ replicate i xs -- Degenerate cases: n == 1 => cyclic group -- l,2,2, l>=2 -> n-gon bipyramid - dihedral group -- Spherical case: 1/l+1/m+1/n > 1 -- 3,3,2 -> tetrahedron; 4,3,2 -> octahedron; 5,3,2 -> icosahedron -- Euclidean case: 1/l+1/m+1/n == 1 -- 3,3,3 4,4,2 6,3,2 -- Hyperbolic case: 1/l+1/m+1/n < 1 HaskellForMaths-0.4.8/Math/Algebra/Group/Subquotients.hs0000644000000000000000000002157612514742102021334 0ustar0000000000000000-- Copyright (c) David Amos, 2009. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction #-} -- Because unRight defined point-free module Math.Algebra.Group.Subquotients where import qualified Data.List as L import qualified Data.Map as M import Math.Common.ListSet import Math.Algebra.Group.PermutationGroup hiding (ptStab, normalClosure) import Math.Algebra.Group.SchreierSims (cosetRepsGx) import Math.Algebra.Group.RandomSchreierSims -- Source: Seress, Permutation Group Algorithms isLeft (Left _) = True isLeft (Right _) = False isRight (Right _) = True isRight (Left _) = False unRight = fromPairs . map (\(Right a, Right b) -> (a,b)) . toPairs restrictLeft g = fromPairs [(a,b) | (Left a, Left b) <- toPairs g] -- note that this is doing a filter - taking only the left part of the action - and a map, unLefting -- pointwise stabiliser of xs ptStab gs delta = map unRight $ dropWhile (isLeft . minsupp) $ sgs gs' where gs' = [ (fromPairs . map (\(a,b) -> (lr a, lr b)) . toPairs) g | g <- gs] lr x = if x `elem` delta then Left x else Right x {- -- !! NEXT TWO FUNCTIONS NOT TESTED -- Need some meaningful examples of homomorphisms -- eg Sn -> Sym(k-subsets of n) -- restrict to a transitive constituent -- blocks -- Given generators gs for a group G, and f : G -> H a homomorphism, -- return the "semi-diagonal" subgroup [(f g, g) | g <- gs] of f(G) * G homomorphismConstruction :: (Ord a, Ord b) => [Permutation a] -> (Permutation a -> Permutation b) -> [Permutation (Either b a)] homomorphismConstruction gs f = [lift g | g <- gs] where lift g = fromPairs $ [(Right x, Right y) | (x,y) <- toPairs g] ++ [(Left x', Left y') | (x',y') <- toPairs (f g)] ker gs f = ks where gbar = homomorphismConstruction gs f gs' = sgs gbar ks' = dropWhile (\h -> isLeft $ minsupp h) gs' -- !! should filter isRight - sgs might not be in order ks = map unRight ks' unRight = fromPairs . map (\(Right a, Right b) -> (a,b)) . toPairs -} isTransitive :: (Ord t) => [Permutation t] -> Bool isTransitive gs = length (orbits gs) == 1 -- TRANSITIVE CONSTITUENTS {- -- find largest composition factor of a group which is not transitive -- we do this by taking the smallest orbit delta, -- then constructing the homomorphism G -> Sym(delta) -- and returning the kernel and the image factorNotTransitive gs = transitiveConstituentHomomorphism' gs delta where delta = smallest $ orbits gs sizeSorted lists = map snd $ L.sort $ [(length l, l) | l <- lists] smallest = head . sizeSorted -} -- Seress p81 -- |Given a group gs and a transitive constituent ys, return the kernel and image of the transitive constituent homomorphism. -- That is, suppose that gs acts on a set xs, and ys is a subset of xs on which gs acts transitively. -- Then the transitive constituent homomorphism is the restriction of the action of gs to an action on the ys. transitiveConstituentHomomorphism :: (Ord a, Show a) => [Permutation a] -> [a] -> ([Permutation a], [Permutation a]) transitiveConstituentHomomorphism gs delta | delta == closure delta [(.^ g) | g <- gs] -- delta is closed under action of gs, hence a union of orbits = transitiveConstituentHomomorphism' gs delta transitiveConstituentHomomorphism' gs delta = (ker, im) where gs' = sgs $ map (fromPairs . map (\(a,b) -> (lr a, lr b)) . toPairs) gs -- as delta is a transitive constituent, we will always have a and b either both Left or both Right lr x = if x `elem` delta then Left x else Right x ker = map unRight $ dropWhile (isLeft . minsupp) gs' -- pointwise stabiliser of delta im = map restrictLeft $ takeWhile (isLeft . minsupp) gs' -- restriction of the action to delta -- BLOCKS OF IMPRIMITIVITY -- Holt p83ff (and also Seress p107ff) -- Find a minimal block containing ys. ys are assumed to be sorted. minimalBlock gs ys@(y1:yt) = minimalBlock' p yt gs where xs = foldl union [] $ map supp gs p = M.fromList $ [(yi,y1) | yi <- ys] ++ [(x,x) | x <- xs \\ ys] minimalBlock' p (q:qs) (h:hs) = let r = p M.! q -- representative of class containing q k = p M.! (q .^ h) -- rep of class (q^h) l = p M.! (r .^ h) -- rep of class (r^h) in if k /= l -- then we need to merge the classes then let p' = M.map (\x -> if x == l then k else x) p qs' = qs ++ [l] in minimalBlock' p' (q:qs') hs else minimalBlock' p (q:qs) hs minimalBlock' p (q:qs) [] = minimalBlock' p qs gs minimalBlock' p [] _ = let reps = toListSet $ M.elems p in L.sort [ filter (\x -> p M.! x == r) xs | r <- reps ] -- Because the support of the permutations is not constrained to be [1..n], we have to use a map instead of an array -- This probably affects the complexity, but isn't a problem in practice -- |Given a transitive group gs, find all non-trivial block systems. That is, if gs act on xs, -- find all the ways that the xs can be divided into blocks, such that the gs also have a permutation action on the blocks blockSystems :: (Ord t) => [Permutation t] -> [[[t]]] blockSystems gs | isTransitive gs = toListSet $ filter (/= [x:xs]) $ map (minimalBlock gs) [ [x,x'] | x' <- xs ] | otherwise = error "blockSystems: not transitive" where x:xs = foldl union [] $ map supp gs -- |A more efficient version of blockSystems, if we have an sgs blockSystemsSGS :: (Ord a) => [Permutation a] -> [[[a]]] blockSystemsSGS gs = toListSet $ filter (/= [x:xs]) $ map (minimalBlock gs) [ [x,x'] | x' <- rs ] where x:xs = foldl union [] $ map supp gs hs = filter (\g -> x < minsupp g) gs -- sgs for stabiliser Gx os = orbits hs rs = map head os ++ (xs \\ L.sort (concat os)) -- orbit representatives, including singleton cycles -- Perhaps we could have a function which just returns orbit reps for stabiliser -- eg for D 10, the stabiliser of 1 is [[2,6],[3,5]] - we need to make sure we don't forget 4 -- If we didn't have an SGS, we could try to randomly generate a few elts of stabiliser Gx, as that would still be better than nothing -- see Holt RandomStab function -- |A permutation group is primitive if it has no non-trivial block systems isPrimitive :: (Ord t) => [Permutation t] -> Bool isPrimitive gs = null (blockSystems gs) isPrimitiveSGS :: (Ord a) => [Permutation a] -> Bool isPrimitiveSGS gs = null (blockSystemsSGS gs) -- There are other optimisations we haven't done -- see Holt p86 -- |Given a transitive group gs, and a block system for gs, return the kernel and image of the block homomorphism -- (the homomorphism onto the action of gs on the blocks) blockHomomorphism :: (Ord t, Show t) => [Permutation t] -> [[t]] -> ([Permutation t], [Permutation [t]]) blockHomomorphism gs bs | bs == closure bs [(-^ g) | g <- gs] -- bs is closed under action of gs = blockHomomorphism' gs bs blockHomomorphism' gs bs = (ker,im) where gs' = sgs $ map lr gs lr g = fromPairs $ [(Left b, Left $ b -^ g) | b <- bs] ++ [(Right x, Right y) | (x,y) <- toPairs g] ker = map unRight $ dropWhile (isLeft . minsupp) gs' -- stabiliser of the blocks im = map restrictLeft $ takeWhile (isLeft . minsupp) gs' -- restriction to the action on blocks -- Note that there is a slightly more efficient way to calculate block homomorphism, -- but requires change of base algorithm which we haven't implemented yet -- NORMAL CLOSURE -- Seress 115 -- Given G, H < Sym(Omega) return (the normal closure) normalClosure gs hs = map unRight $ dropWhile (isLeft . minsupp) $ sgs ks where xs = foldl union [] $ map supp $ gs ++ hs ds = map diag gs -- {(g,g) | g <- G} diag g = fromPairs $ concat [ [(Left x, Left y) , (Right x, Right y)] | (x,y) <- toPairs g] hsR = map inR hs -- {(1,h) | h <- H} inR h = fromPairs [(Right x, Right y) | (x,y) <- toPairs h] ks = ds ++ hsR -- Seress 116 -- Given G, H < Sym(Omega) return `intersection` G intersectionNormalClosure gs hs = map unRight $ dropWhile (isLeft . minsupp) $ sgs ks where xs = foldl union [] $ map supp $ gs ++ hs ds = map diag gs -- {(g,g) | g <- G} diag g = fromPairs $ concat [ [(Left x, Left y) , (Right x, Right y)] | (x,y) <- toPairs g] hsL = map inL hs -- {(h,1) | h <- H} inL h = fromPairs [(Left x, Left y) | (x,y) <- toPairs h] ks = ds ++ hsL -- CENTRALISER IN THE SYMMETRIC GROUP -- Centralizer of G in Sym(X) - transitive case centralizerSymTrans gs = filter (/= 1) $ centralizerSymTrans' [] fix_g_a where xs@(a:_) = foldl union [] $ map supp gs ss = sgs gs g_a = dropWhile ( (==a) . minsupp ) ss -- pt stabiliser of a fix_g_a = xs \\ (foldl union [] $ map supp g_a) -- the pts fixed by stabiliser of a reps_a = cosetRepsGx gs a -- xs = M.keys reps_a centralizingElt b = fromPairs [ let g = reps_a M.! x in (x, b .^ g) | x <- xs ] centralizerSymTrans' ls (r:rs) = let c = centralizingElt r in c : centralizerSymTrans' (c:ls) (rs \\ orbitP (c:ls) a) centralizerSymTrans' _ [] = [] HaskellForMaths-0.4.8/Math/Algebra/NonCommutative/0000755000000000000000000000000012514742102020134 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Algebra/NonCommutative/GSBasis.hs0000644000000000000000000000517312514742102021771 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. module Math.Algebra.NonCommutative.GSBasis where import Data.List as L import Math.Algebra.NonCommutative.NCPoly -- given two monomials f g, find if possible a,b,c with f=ab g=bc findOverlap (M xs) (M ys) = findOverlap' [] xs ys where findOverlap' as [] cs = Nothing -- (reverse as, [], cs) findOverlap' as (b:bs) cs = if (b:bs) `L.isPrefixOf` cs then Just (M $ reverse as, M $ b:bs, M $ drop (length (b:bs)) cs) else findOverlap' (b:as) bs cs -- given two monomials f g, find if possible l,r with g = lfr -- findInclusion (M xs) (M ys) = findInclusion' sPoly f@(NP ((xs,c):_)) g@(NP ((ys,d):_)) = case findOverlap xs ys of Just (l,m,r) -> f * NP [(r,d)] - NP [(l,c)] * g Nothing -> 0 sPoly _ _ = 0 -- !! shouldn't reach this -- The point about the s-poly is that it cancels out the leading terms of the two polys, exposing their second terms gb1 fs = gb' fs [sPoly fi fj | fi <- fs, fj <- fs, fi /= fj] where -- unlike the commutative case, we take sPolys both ways round gb' gs (h:hs) = let h' = h %% gs in if h' == 0 then gb' gs hs else gb' (h':gs) (hs ++ [sPoly h' g | g <- gs] ++ [sPoly g h' | g <- gs]) gb' gs [] = gs reduce gs = reduce' [] gs where reduce' gs' (g:gs) | g' == 0 = reduce' gs' gs | otherwise = reduce' (g':gs') gs where g' = g %% (gs'++gs) reduce' gs' [] = reverse $ sort $ gs' gb fs = map toMonic $ reduce $ gb1 fs gb' fs = reduce $ gb1 fs gb2 fs = gb' fs [(fi,fj) | fi <- fs, fj <- fs, fi /= fj] where -- unlike the commutative case, we take sPolys both ways round gb' gs ((fi,fj):pairs) = let h = sPoly fi fj %% gs in if h == 0 then gb' gs pairs else gb' (h:gs) (pairs ++ [(h,g) | g <- gs] ++ [(g,h) | g <- gs]) gb' gs [] = gs gb2' fs = gb' fs [(fi,fj) | fi <- fs, fj <- fs, fi /= fj] where -- unlike the commutative case, we take sPolys both ways round gb' gs ((fi,fj):pairs) = let h = sPoly fi fj %% gs in if h == 0 then gb' gs pairs else (fi,fj,sPoly fi fj,h) : gb' (h:gs) (pairs ++ [(h,g) | g <- gs] ++ [(g,h) | g <- gs]) gb' gs [] = [] -- gs -- Monomial basis for the quotient algebra, where gs are the generators, rs the relations mbasisQA gs rs = mbasisQA' [1] where mbasisQA' [] = [] -- the quotient ring has a finite monomial basis mbasisQA' ms = let ms' = [g*m | g <- gs, m <- ms, g*m %% rs == g*m] -- ie, not reducible in ms ++ mbasisQA' ms' {- isGB fs = all (\h -> h %% fs == 0) (pairWith sPoly fs) -} HaskellForMaths-0.4.8/Math/Algebra/NonCommutative/NCPoly.hs0000644000000000000000000001751512514742102021645 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. -- |A module providing a type for non-commutative polynomials. module Math.Algebra.NonCommutative.NCPoly where import Data.List as L import Math.Algebra.Field.Base -- (NON-COMMUTATIVE) MONOMIALS newtype Monomial v = M [v] deriving (Eq) instance Ord v => Ord (Monomial v) where compare (M xs) (M ys) = compare (length xs,xs) (length ys,ys) -- Glex ordering instance (Eq v, Show v) => Show (Monomial v) where show (M xs) | null xs = "1" | otherwise = concatMap showPower (L.group xs) where showPower [v] = showVar v showPower vs@(v:_) = showVar v ++ "^" ++ show (length vs) showVar v = filter (/= '"') (show v) -- Taken from NonComMonomial - why don't we just use it directly instance (Eq v, Show v) => Num (Monomial v) where M xs * M ys = M (xs ++ ys) fromInteger 1 = M [] -- try to find l, r such that a = lbr divM (M a) (M b) = divM' [] a where divM' ls (r:rs) = if b `L.isPrefixOf` (r:rs) then Just (M $ reverse ls, M $ drop (length b) (r:rs)) else divM' (r:ls) rs divM' _ [] = Nothing -- (NON-COMMUTATIVE) POLYNOMIALS newtype NPoly r v = NP [(Monomial v,r)] deriving (Eq) instance (Ord r, Ord v) => Ord (NPoly r v) where compare (NP ts) (NP us) = compare ts us instance (Show r, Eq v, Show v) => Show (NPoly r v) where show (NP []) = "0" show (NP ts) = let (c:cs) = concatMap showTerm ts in if c == '+' then cs else c:cs where showTerm (m,a) = case show a of "1" -> "+" ++ show m "-1" -> "-" ++ show m -- cs@(x:_) -> (if x == '-' then cs else '+':cs) ++ (if m == 1 then "" else show m) cs -> showCoeff cs ++ (if m == 1 then "" else show m) showCoeff (c:cs) = if any (`elem` ['+','-']) cs then "+(" ++ c:cs ++ ")" else if c == '-' then c:cs else '+':c:cs instance (Eq r, Num r, Ord v, Show v) => Num (NPoly r v) where NP ts + NP us = NP (mergeTerms ts us) negate (NP ts) = NP $ map (\(m,c) -> (m,-c)) ts NP ts * NP us = NP $ collect $ L.sortBy cmpTerm $ [(g*h,c*d) | (g,c) <- ts, (h,d) <- us] fromInteger 0 = NP [] fromInteger n = NP [(fromInteger 1, fromInteger n)] cmpTerm (a,c) (b,d) = case compare a b of EQ -> EQ; GT -> LT; LT -> GT -- in mpolys we put "larger" terms first -- inputs in descending order mergeTerms (t@(g,c):ts) (u@(h,d):us) = case cmpTerm t u of LT -> t : mergeTerms ts (u:us) GT -> u : mergeTerms (t:ts) us EQ -> if e == 0 then mergeTerms ts us else (g,e) : mergeTerms ts us where e = c + d mergeTerms ts us = ts ++ us -- one of them is null collect (t1@(g,c):t2@(h,d):ts) | g == h = collect $ (g,c+d):ts | c == 0 = collect $ t2:ts | otherwise = t1 : collect (t2:ts) collect ts = ts -- Fractional instance so that we can enter fractional coefficients -- Only lets us divide by field elements (with unit monomial), not any other polynomials instance (Eq k, Fractional k, Ord v, Show v) => Fractional (NPoly k v) where recip (NP [(1,c)]) = NP [(1, recip c)] recip _ = error "NPoly.recip: only supported for (non-zero) constants" -- SOME VARIABLES (INDETERMINATES) -- The idea is that you define your own type of indeterminates as required, along the same lines as this data Var = X | Y | Z deriving (Eq,Ord) instance Show Var where show X = "x" show Y = "y" show Z = "z" -- |Create a non-commutative variable for use in forming non-commutative polynomials. -- For example, we could define x = var "x", y = var "y". Then x*y /= y*x. var :: (Num k) => v -> NPoly k v var v = NP [(M [v], 1)] x = var X :: NPoly Q Var y = var Y :: NPoly Q Var z = var Z :: NPoly Q Var -- DIVISION ALGORITHM lm (NP ((m,c):ts)) = m lc (NP ((m,c):ts)) = c lt (NP (t:ts)) = NP [t] -- given f, gs, find ls, rs, f' such that f = sum (zipWith3 (*) ls gs rs) + f', with f' not divisible by any g quotRemNP f gs | all (/=0) gs = quotRemNP' f (replicate n (0,0), 0) | otherwise = error "quotRemNP: division by zero" where n = length gs quotRemNP' 0 (lrs,f') = (lrs,f') quotRemNP' h (lrs,f') = divisionStep h (gs,[],lrs,f') divisionStep h (g:gs, lrs', (l,r):lrs, f') = case lm h `divM` lm g of Just (l',r') -> let l'' = NP [(l',lc h / lc g)] r'' = NP [(r',1)] h' = h - l'' * g * r'' in quotRemNP' h' (reverse lrs' ++ (l+l'',r+r''):lrs, f') Nothing -> divisionStep h (gs,(l,r):lrs',lrs,f') divisionStep h ([],lrs',[],f') = let lth = lt h -- can't reduce lt h, so add it to the remainder and try to reduce the remaining terms in quotRemNP' (h-lth) (reverse lrs', f'+lth) -- It is only marginally (5-10%) more space/time efficient not to track the (lazily unevaluated) factors remNP f gs | all (/=0) gs = remNP' f 0 -- let result = remNP' f 0 in if result == remNP2 f gs then result else error ("remNP2 " ++ show f ++ " " ++ show gs) | otherwise = error "remNP: division by zero" where n = length gs remNP' 0 f' = f' remNP' h f' = divisionStep h gs f' divisionStep h (g:gs) f' = case lm h `divM` lm g of Just (l',r') -> let l'' = NP [(l',lc h / lc g)] r'' = NP [(r',1)] h' = h - l'' * g * r'' in remNP' h' f' Nothing -> divisionStep h gs f' divisionStep h [] f' = let lth = lt h -- can't reduce lt h, so add it to the remainder and try to reduce the remaining terms in remNP' (h-lth) (f'+lth) infixl 7 %% -- f %% gs = r where (_,r) = quotRemNP f gs f %% gs = remNP f gs -- !! Not sure if the following is valid -- The idea is to avoid dividing by lc g, because sometimes our coefficient ring is not a field -- Passes all the knot theory tests -- However, it may be that if we ever get a non-invertible element at the front, we are in trouble anyway remNP2 f gs | all (/=0) gs = remNP' f 0 | otherwise = error "remNP: division by zero" where n = length gs remNP' 0 f' = f' remNP' h f' = divisionStep h gs f' divisionStep h (g:gs) f' = case lm h `divM` lm g of Just (l',r') -> let l'' = NP [(l',1)] -- NP [(l',lc h / lc g)] r'' = NP [(r',1)] lcg = inject (lc g) lch = inject (lc h) -- h' = h - l'' * g * r'' h' = lcg * h - lch * l'' * g * r'' in remNP' h' (lcg * f') -- must multiply f' by lcg too (otherwise get incorrect results, eg tlBasis 4) Nothing -> divisionStep h gs f' divisionStep h [] f' = let lth = lt h -- can't reduce lt h, so add it to the remainder and try to reduce the remaining terms in remNP' (h-lth) (f'+lth) -- OTHER STUFF toMonic 0 = 0 toMonic (NP ts@((_,c):_)) | c == 1 = NP ts | otherwise = NP $ map (\(m,d)->(m,d/c)) ts -- injection of field elements into polynomial ring inject 0 = NP [] inject c = NP [(fromInteger 1, c)] -- substitute terms for variables in an NPoly -- eg subst [(x,a),(y,a+b),(z,c^2)] (x*y+z) -> a*(a+b)+c^2 subst vts (NP us) = sum [inject c * substM m | (m,c) <- us] where substM (M xs) = product [substV x | x <- xs] substV v = let v' = NP [(M [v], 1)] in case L.lookup v' vts of Just t -> t Nothing -> error ("subst: no substitute supplied for " ++ show v') -- INVERTIBLE -- To support algebras which have invertible elements class Invertible a where inv :: a -> a x ^- k = inv x ^ kHaskellForMaths-0.4.8/Math/Algebra/NonCommutative/TensorAlgebra.hs0000644000000000000000000001050312514742102023217 0ustar0000000000000000-- Copyright (c) 2008, David Amos. All rights reserved. -- |A module defining the tensor, symmetric, and exterior algebras. -- This module has been partially superceded by Math.Algebras.TensorAlgebra, which should be used in preference. -- This module is likely to be removed at some point. module Math.Algebra.NonCommutative.TensorAlgebra where import Math.Algebra.Field.Base import Math.Algebra.NonCommutative.NCPoly hiding (X) import Math.Algebra.NonCommutative.GSBasis -- TENSOR ALGEBRA -- Tensor product satisfies the universal property that any multilinear map from the cartesian product can be factored through the tensor product -- The tensor algebra is the free algebra on the basis elts of the vector space data Basis = E Int deriving (Eq,Ord) instance Show Basis where show (E i) = 'e': show i e_ i = NP [(M [E i], 1)] :: NPoly Q Basis e1 = e_ 1 e2 = e_ 2 e3 = e_ 3 e4 = e_ 4 -- given an elt of the tensor algebra, return the dimension of the vector space it's defined over dim (NP ts) = maximum $ 0 : [i | (M bs,c) <- ts, E i <- bs] -- Monomial basis for tensor algebra over k^n - infinite tensorBasis n = mbasisQA [e_ i | i <- [1..n]] [] -- EXTERIOR ALGEBRA -- Exterior product satisfies the universal property that any alternating multilinear map from the cartesian product can be factored through the exterior product -- Exterior algebra over k^n is tensor algebra over k^n quotiented by these relations extRelations n = [e_ i * e_ i | i <- [1..n] ] ++ [e_ i * e_ j + e_ j * e_ i | i <- [1..n], j <- [i+1..n] ] extnf t = t %% (extRelations $ dim t) -- Monomial basis for exterior algebra over k^n - finite exteriorBasis n = mbasisQA [e_ i | i <- [1..n]] $ extRelations n -- SYMMETRIC ALGEBRA -- Symmetric product satisfies the universal property that any symmetric multilinear map from the cartesian product can be factored through the symmetric product -- Symmetric algebra over k^n is tensor algebra over k^n quotiented by these relations symRelations n = [e_ i * e_ j - e_ j * e_ i | i <- [1..n], j <- [i+1..n] ] symnf t = t %% (symRelations $ dim t) -- Monomial basis for symmetric algebra over k^n - infinite symmetricBasis n = mbasisQA [e_ i | i <- [1..n]] $ symRelations n -- WEYL ALGEBRAS -- http://en.wikipedia.org/wiki/Weyl_algebra -- Coutinho, A Primer of Algebraic D-modules, ch1 -- Given a symplectic form w, represented by -- [0 I] -- [-I 0] -- on R^2n -- The Weyl algebra is the tensor algebra quotiented by < u*v-v*u-w(u,v) > -- It has a natural interpretation as an operator algebra in which -- e_1 .. e_i .. e_n correspond to x_i (the "multiply by x_i" operator), -- e_n+1 .. e_n+i .. e_2*n correspond to d_x_i (the "differentiate wrt x_i" operator) -- Weyl algebra W(V) is a "quantization" of the Symmetric algebra Sym(V) weylRelations n = [e_ j * e_ i - e_ i * e_ j | i <- [1..2*n], j <- [i+1..2*n], j /= i+n ] ++ [e_ (i+n) * e_ i - e_ i * e_ (i+n) - 1 | i <- [1..n] ] weylnf n t = t %% (weylRelations n) weylBasis n = mbasisQA [e_ i | i <- [1..2*n]] $ weylRelations n -- Explicit construction of Weyl algebra in terms of d_x_i and x_i operators data WeylGens = X Int | D Int deriving (Eq,Ord) instance Show WeylGens where show (D i) = 'd': show i show (X i) = 'x': show i d_ i = NP [(M [D i], 1)] :: NPoly Q WeylGens x_ i = NP [(M [X i], 1)] :: NPoly Q WeylGens d1 = d_ 1 d2 = d_ 2 d3 = d_ 3 x1 = x_ 1 x2 = x_ 2 x3 = x_ 3 comm p q = p*q - q*p delta i j = if i == j then 1 else 0 weylRelations' n = [comm (x_ i) (x_ j) | i <- [1..n], j <- [i+1..n] ] ++ [comm (d_ i) (d_ j) | i <- [1..n], j <- [i+1..n] ] ++ [comm (d_ i) (x_ j) - delta i j | i <- [1..n], j <- [1..n] ] weylnf' f@(NP ts) = f %% weylRelations' n where n = maximum $ 0 : [i | (M bs,c) <- ts, X i <- bs] ++ [i | (M bs,c) <- ts, D i <- bs] weylBasis' n = mbasisQA (map x_ [1..n] ++ map d_ [1..n]) (weylRelations' n) {- -- HEISENBERG ALGEBRA data Heisenberg = D | U deriving (Eq,Ord) instance Show Heisenberg where show D = "d" show U = "u" d = NP [(M [D], 1)] :: NPoly Q Heisenberg u = NP [(M [U], 1)] :: NPoly Q Heisenberg heisenberg = [u*d-d*u-1] -- Monomial basis for Heisenberg algebra - infinite hBasis = mbasisQA [d,u] (gb heisenberg) -}HaskellForMaths-0.4.8/Math/Algebras/0000755000000000000000000000000012514742102015347 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Algebras/AffinePlane.hs0000644000000000000000000000500112514742102020047 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} -- |A module defining the affine plane and its symmetries module Math.Algebras.AffinePlane where import Math.Algebra.Field.Base hiding (powers) import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures import Math.Algebras.Commutative data XY = X | Y deriving (Eq, Ord) instance Show XY where show X = "x"; show Y = "y" x = glexVar X :: GlexPoly Q XY y = glexVar Y :: GlexPoly Q XY data ABCD = A | B | C | D deriving (Eq, Ord) instance Show ABCD where show A = "a"; show B = "b"; show C = "c"; show D = "d" a,b,c,d :: Monomial m => Vect Q (m ABCD) a = var A b = var B c = var C d = var D -- SL2 newtype SL2 v = SL2 (GlexMonomial v) deriving (Eq,Ord) instance Show v => Show (SL2 v) where show (SL2 m) = show m instance Algebra Q (SL2 ABCD) where -- to do this for Num k instead of Q we would need a,b,c,d defined for Num k unit 0 = zerov -- V [] unit x = V [(munit,x)] where munit = SL2 (Glex 0 []) mult x = x''' where x' = mult $ fmap ( \(SL2 a, SL2 b) -> (a,b) ) x -- perform the multiplication in GlexPoly x'' = x' %% [a*d-b*c-1] -- :: GlexPoly Q ABCD] -- quotient by ad-bc=1 in GlexPoly Q ABCD x''' = fmap SL2 x'' -- ie wrap the monomials up as SL2 again -- mmult (Glex si xis) (Glex sj yjs) = Glex (si+sj) $ addmerge xis yjs sl2Var v = V [(SL2 (Glex 1 [(v,1)]), 1)] -- :: Vect Q (SL2 ABCD) -- For example: -- > a*d :: Vect Q (SL2 ABCD) -- bc+1 instance Monomial SL2 where var = sl2Var powers (SL2 (Glex _ xis)) = xis instance Coalgebra Q (SL2 ABCD) where counit x = case x `bind` cu of V [] -> 0 V [(SL2 (Glex 0 []), c)] -> c where cu A = 1 :: Vect Q (SL2 ABCD) cu B = 0 cu C = 0 cu D = 1 comult x = x `bind` cm where cm A = a `te` a + b `te` c cm B = a `te` b + b `te` d cm C = c `te` a + d `te` c cm D = c `te` b + d `te` d -- In other words -- counit (a b) = (1 0) -- (c d) (0 1) -- comult (a b) = (a1 b1) `te` (a2 b2) -- (c d) (c1 d1) (c2 d2) instance Bialgebra Q (SL2 ABCD) where {} instance HopfAlgebra Q (SL2 ABCD) where antipode x = x `bind` antipode' where antipode' A = d antipode' B = b antipode' C = c antipode' D = a -- in the GL2 case we would need 1/det factor as well HaskellForMaths-0.4.8/Math/Algebras/Commutative.hs0000644000000000000000000001523412514742102020205 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -- |A module defining the algebra of commutative polynomials over a field k. -- -- Most users should probably use Math.CommutativeAlgebra.Polynomial instead, which is basically the same thing -- but more fully-featured. This module will probably be deprecated at some point, but remains for now because -- it has a simpler implementation which may be more helpful for people wanting to understand the code. module Math.Algebras.Commutative where import Prelude hiding ( (*>) ) import Math.Algebra.Field.Base hiding (powers) import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures -- GLEX MONOMIALS data GlexMonomial v = Glex Int [(v,Int)] deriving (Eq) -- The initial Int is the degree of the monomial. Storing it speeds up equality tests and comparisons -- type GlexMonomialS = GlexMonomial String instance Ord v => Ord (GlexMonomial v) where compare (Glex si xis) (Glex sj yjs) = compare (-si, [(x,-i) | (x,i) <- xis]) (-sj, [(y,-j) | (y,j) <- yjs]) instance Show v => Show (GlexMonomial v) where show (Glex _ []) = "1" show (Glex _ xis) = concatMap (\(x,i) -> if i==1 then showVar x else showVar x ++ "^" ++ show i) xis where showVar x = filter ( /= '"' ) (show x) -- in case v == String {- -- GlexMonomial is a functor and a monad -- However, this isn't all that much use, and to make proper use of it we'd need a "nf" function -- So leaving this commented out -- map one basis to another instance Functor GlexMonomial where fmap f (Glex si xis) = Glex si [(f x, i) | (x,i) <- xis] -- Note that as we can't assume the Ord instance, we would need to call "nf" afterwards instance Applicative GlexMonomial where pure = return (<*>) = ap -- GlexMonomial is the free commutative monoid, and hence a monad instance Monad GlexMonomial where return x = Glex 1 [(x,1)] (Glex _ xis) >>= f = let parts = [(i, sj, yjs) | (x,i) <- xis, let Glex sj yjs = f x] in Glex (sum [i*sj | (i,sj,_) <- parts]) (concatMap (\(i,_,yjs)->map (\(y,j)->(y,i*j)) yjs) parts) -- this isn't really much use - it's variable substitution, but we're only allowed to substitute monomials for each var -- Note that as we can't assume the Ord instance, we would need to call "nf" afterwards -} -- This is the monoid algebra for commutative monomials (which are the free commutative monoid) instance (Eq k, Num k, Ord v) => Algebra k (GlexMonomial v) where unit x = x *> return munit where munit = Glex 0 [] mult xy = nf $ fmap (\(a,b) -> a `mmult` b) xy where mmult (Glex si xis) (Glex sj yjs) = Glex (si+sj) $ addmerge xis yjs -- GlexPoly can be given the set coalgebra structure, which is compatible with the monoid algebra structure instance (Eq k, Num k) => Coalgebra k (GlexMonomial v) where counit = unwrap . nf . fmap (\m -> () ) -- trace -- counit (V ts) = sum [x | (m,x) <- ts] -- trace comult = fmap (\m -> (m,m) ) -- diagonal type GlexPoly k v = Vect k (GlexMonomial v) -- |glexVar creates a variable in the algebra of commutative polynomials with Glex term ordering. -- For example, the following code creates variables called x, y and z: -- -- > [x,y,z] = map glexVar ["x","y","z"] :: GlexPoly Q String glexVar :: (Num k) => v -> GlexPoly k v glexVar v = V [(Glex 1 [(v,1)], 1)] class Monomial m where var :: v -> Vect Q (m v) powers :: m v -> [(v,Int)] -- |In effect, we have (Num k, Monomial m) => Monad (\v -> Vect k (m v)), with return = var, and (>>=) = bind. -- However, we can't express this directly in Haskell, firstly because of the Ord b constraint, -- secondly because Haskell doesn't support type functions. bind :: (Monomial m, Eq k, Num k, Ord b, Show b, Algebra k b) => Vect k (m v) -> (v -> Vect k b) -> Vect k b V ts `bind` f = sum [c *> product [f x ^ i | (x,i) <- powers m] | (m, c) <- ts] -- flipbind f = linear (\m -> product [f x ^ i | (x,i) <- powers m]) instance Monomial GlexMonomial where var = glexVar powers (Glex _ xis) = xis -- DIVISION lt (V (t:ts)) = t class DivisionBasis b where dividesB :: b -> b -> Bool divB :: b -> b -> b dividesT (b1,x1) (b2,x2) = dividesB b1 b2 divT (b1,x1) (b2,x2) = (divB b1 b2, x1/x2) -- given f, gs, find as, r such that f = sum (zipWith (*) as gs) + r, with r not divisible by any g quotRemMP f gs = quotRemMP' f (replicate n 0, 0) where n = length gs quotRemMP' 0 (us,r) = (us,r) quotRemMP' h (us,r) = divisionStep h (gs,[],us,r) divisionStep h (g:gs,us',u:us,r) = if lt g `dividesT` lt h then let t = V [lt h `divT` lt g] h' = h - t*g u' = u+t in quotRemMP' h' (reverse us' ++ u':us, r) else divisionStep h (gs,u:us',us,r) divisionStep h ([],us',[],r) = let (lth,h') = splitlt h in quotRemMP' h' (reverse us', r+lth) splitlt (V (t:ts)) = (V [t], V ts) infixl 7 %% -- |(%%) reduces a polynomial with respect to a list of polynomials. (%%) :: (Eq k, Fractional k, Ord b, Show b, Algebra k b, DivisionBasis b) => Vect k b -> [Vect k b] -> Vect k b f %% gs = r where (_,r) = quotRemMP f gs instance Ord v => DivisionBasis (GlexMonomial v) where dividesB (Glex si xis) (Glex sj yjs) = si <= sj && dividesB' xis yjs where dividesB' ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> False GT -> dividesB' ((x,i):xis) yjs EQ -> if i<=j then dividesB' xis yjs else False dividesB' [] _ = True dividesB' _ [] = False divB (Glex si xis) (Glex sj yjs) = Glex (si-sj) $ divB' xis yjs where divB' ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> (x,i) : divB' xis ((y,j):yjs) EQ -> if i == j then divB' xis yjs else (x,i-j) : divB' xis yjs -- we don't bother to check i > j GT -> error "divB'" -- (y,-j) : divB' ((x,i):xis) yjs divB' xis [] = xis divB' [] yjs = error "divB'" {- -- Need to thread this through Maybe properly, so perhaps use do notation divB2 (Glex si xis) (Glex sj yjs) | si < sj = Nothing | otherwise = case divB' xis yjs of Nothing -> Nothing Just zks -> Glex (si-sj) zks where divB' ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> (x,i) : divB' xis ((y,j):yjs) EQ -> case compare i j of LT -> Nothing EQ -> divB' xis yjs GT -> (x,i-j) : divB' xis yjs GT -> Nothing -} -- !! could change divB to return Maybe, and avoid need for dividesB HaskellForMaths-0.4.8/Math/Algebras/GroupAlgebra.hs0000644000000000000000000001253512514742102020263 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances #-} -- ScopedTypeVariables -- |A module for doing arithmetic in the group algebra. -- -- Group elements are represented as permutations of the integers, and are entered and displayed -- using a Haskell-friendly version of cycle notation. For example, the permutation (1 2 3)(4 5) -- 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 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 (GroupAlgebra, p) where import Prelude hiding ( (*>) ) import Math.Core.Field 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 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 = (*) -- Monoid Algebra instance instance (Eq k, Num k) => Algebra k (Permutation Int) where 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 | (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 = 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 = 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) newtype X a = X a deriving (Eq,Ord,Show) -- 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 = 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) oneEquations = (coeff 1 one - 1) : [coeff g one - 0 | g <- tail gs] zeroEquations = [coeff g one - 0 | g <- gs] solution = gb oneEquations in if solution == [1] then Left (gb zeroEquations) -- it's a zero divisor else Right solution -- 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 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 -- |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 = 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 = 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) m = [ [coeff (mvar (X j)) c | j <- gs] | i <- gs, let c = coeff i one] b = 1 : replicate (length gs - 1) 0 in fmap (\v -> nf $ V $ zip gs v) (solveLinearSystem m b) {- in case solveLinearSystem m b of Just v -> Just $ nf $ V $ zip gs v Nothing -> Nothing -} HaskellForMaths-0.4.8/Math/Algebras/LaurentPoly.hs0000644000000000000000000000533312514742102020165 0ustar0000000000000000-- Copyright (c) 2010, David Amos. All rights reserved. {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} module Math.Algebras.LaurentPoly where import Math.Algebra.Field.Base hiding (powers) import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures import qualified Data.List as L import Math.Algebras.Commutative -- for DivisionBasis and quotRemMP -- LAURENT MONOMIALS data LaurentMonomial = LM Int [(String,Int)] deriving (Eq,Ord) {- instance Ord LaurentMonomial where compare (LM si xis) (LM sj yjs) = compare (-si, xis) (-sj, yjs) -} instance Show LaurentMonomial where show (LM 0 []) = "1" show (LM _ xis) = concatMap (\(x,i) -> if i==1 then x else x ++ "^" ++ show i) xis instance Mon LaurentMonomial where munit = LM 0 [] mmult (LM si xis) (LM sj yjs) = LM (si+sj) $ addmerge xis yjs instance (Eq k, Num k) => Algebra k LaurentMonomial where unit 0 = zerov -- V [] unit x = V [(munit,x)] mult (V ts) = nf $ fmap (\(a,b) -> a `mmult` b) (V ts) -- mult (V ts) = nf $ V [(a `mmult` b, x) | (T a b, x) <- ts] {- -- This is just the Set Coalgebra, so better to use a generic instance -- Also, not used anywhere. Hence commented out instance Num k => Coalgebra k LaurentMonomial where counit (V ts) = sum [x | (m,x) <- ts] -- trace comult = fmap (\m -> T m m) -} type LaurentPoly k = Vect k LaurentMonomial lvar v = V [(LM 1 [(v,1)], 1)] :: LaurentPoly Q instance (Eq k, Fractional k) => Fractional (LaurentPoly k) where recip (V [(LM si xis,c)]) = V [(LM (-si) $ map (\(x,i)->(x,-i)) xis, recip c)] recip _ = error "LaurentPoly.recip: only defined for single terms" q = lvar "q" q' = 1/q {- -- division doesn't terminate with the derived Ord instance -- if we use the graded Ord instance instead, division doesn't continue into negative powers -- so we get the negative powers as remained, even if they're divisible instance DivisionBasis LaurentMonomial where dividesB (LM si xis) (LM sj yjs) = si <= sj && dividesB' xis yjs where dividesB' ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> False GT -> dividesB' ((x,i):xis) yjs EQ -> if i<=j then dividesB' xis yjs else False dividesB' [] _ = True dividesB' _ [] = False divB (LM si xis) (LM sj yjs) = LM (si-sj) $ divB' xis yjs where divB' ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> (x,i) : divB' xis ((y,j):yjs) EQ -> if i == j then divB' xis yjs else (x,i-j) : divB' xis yjs -- we don't bother to check i > j GT -> error "divB'" -- (y,-j) : divB' ((x,i):xis) yjs divB' xis [] = xis divB' [] yjs = error "divB'" -} HaskellForMaths-0.4.8/Math/Algebras/Matrix.hs0000644000000000000000000000571612514742102017160 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} module Math.Algebras.Matrix where import Prelude hiding ( (*>) ) import Math.Algebra.Field.Base import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures -- Mat2 {- -- defined in Math.Algebras.TensorProduct delta i j | i == j = 1 | otherwise = 0 -} data Mat2 = E2 Int Int deriving (Eq,Ord,Show) -- E i j represents the elementary matrix with a 1 at the (i,j) position, and 0s elsewhere instance (Eq k, Num k) => Algebra k Mat2 where unit x = x *> V [(E2 i i, 1) | i <- [1..2] ] mult = linear mult' where mult' (E2 i j, E2 k l) = delta j k *> return (E2 i l) -- In other words -- unit x = x (1 0) -- (0 1) -- mult (a1 b1) `te` (a2 b2) = (a1 b1) * (a2 b2) = (a b) -- (c1 d1) (c2 d2) (c1 d1) (c2 d2) (c d) instance (Eq k, Num k) => Module k Mat2 EBasis where -- action ax = nf $ ax >>= action' where action = linear action' where action' (E2 i j, E k) = delta j k `smultL` return (E i) -- In other words -- action (a b) `te` (x) = (ax+by) -- (c d) (y) (cx+dy) toMat2 [[a,b],[c,d]] = sum $ zipWith (\x e -> unit x * return e) [a,b,c,d] [E2 1 1, E2 1 2, E2 2 1, E2 2 2] -- fromMat2 toEB2 [x,y] = foldl add zerov $ zipWith (\x e -> x `smultL` return e) [x,y] [E 1, E 2] toEB xs = foldl add zerov $ zipWith (\x e -> x `smultL` return e) xs (map E [1..]) data Mat2' = E2' Int Int deriving (Eq,Ord,Show) -- E2' i j represents the dual basis element corresponding to E i j -- Kassel p42 instance (Eq k, Num k) => Coalgebra k Mat2' where counit (V ts) = sum [xij * delta i j | (E2' i j, xij) <- ts] -- comult (V ts) = V $ concatMap (\(E2' i j,xij) -> [(T (E2' i k) (E2' k j), xij) | k <- [1..2]]) ts comult = linear (\(E2' i j) -> foldl (<+>) zerov [return (E2' i k, E2' k j) | k <- [1..2]]) -- In other words -- counit (a b) = (1 0) -- (c d) (0 1) -- comult (a b) = (a1 b1) `te` (a2 b2) -- (c d) (c1 d1) (c2 d2) -- ?? -- ?? How does this act on Mat2? -- ?? What is the relationship between this and SL2 ABCD, which it seems to resemble data M3 = E3 Int Int deriving (Eq,Ord,Show) -- E i j represents the elementary matrix with a 1 at the (i,j) position, and 0s elsewhere instance (Eq k, Num k) => Algebra k M3 where unit 0 = zerov -- V [] unit x = V [(E3 i i, x) | i <- [1..3] ] -- mult (V ts) = nf $ V $ map (\((E3 i j, E3 k l), x) -> (E3 i l, delta j k * x)) ts mult = linear mult' where mult' (E3 i j, E3 k l) = delta j k *> return (E3 i l) {- -- Kassel p42 -- In this coalgebra instance, the E3 i j are to be interpreted as the dual basis, not the original basis instance Num k => Coalgebra k M3 where counit (V ts) = sum [xij * delta i j | (E3 i j, xij) <- ts] comult (V ts) = V $ concatMap (\(E3 i j,xij) -> [((E3 i k, E3 k j), xij) | k <- [1..3]]) ts -- (is this order preserving?) -} HaskellForMaths-0.4.8/Math/Algebras/NonCommutative.hs0000644000000000000000000001214412514742102020655 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -- |A module defining the algebra of non-commutative polynomials over a field k module Math.Algebras.NonCommutative where import Prelude hiding ( (*>) ) import Math.Algebra.Field.Base hiding (powers) import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures import qualified Data.List as L data NonComMonomial v = NCM Int [v] deriving (Eq) instance Ord v => Ord (NonComMonomial v) where compare (NCM lx xs) (NCM ly ys) = compare (-lx, xs) (-ly, ys) -- ie Glex ordering instance (Eq v, Show v) => Show (NonComMonomial v) where show (NCM _ []) = "1" show (NCM _ vs) = concatMap showPower (L.group vs) where showPower [v] = showVar v showPower vs@(v:_) = showVar v ++ "^" ++ show (length vs) showVar v = filter (/= '"') (show v) instance Mon (NonComMonomial v) where munit = NCM 0 [] mmult (NCM i xs) (NCM j ys) = NCM (i+j) (xs++ys) instance (Eq k, Num k, Ord v) => Algebra k (NonComMonomial v) where unit 0 = zerov -- V [] unit x = V [(munit,x)] mult = nf . fmap (\(a,b) -> a `mmult` b) {- -- This is the monoid algebra for non-commutative monomials (which is the free monoid) instance (Num k, Ord v) => Algebra k (NonComMonomial v) where unit 0 = zero -- V [] unit x = V [(munit,x)] where munit = NCM 0 [] mult (V ts) = nf $ fmap (\(a,b) -> a `mmult` b) (V ts) where mmult (NCM lu us) (NCM lv vs) = NCM (lu+lv) (us++vs) -- mult (V ts) = nf $ V [(a `mmult` b, x) | (T a b, x) <- ts] -} {- -- This is just the Set Coalgebra, so better to use a generic instance -- Also, not used anywhere. Hence commented out instance Num k => Coalgebra k (NonComMonomial v) where counit (V ts) = sum [x | (m,x) <- ts] -- trace comult = fmap (\m -> (m,m)) -} class Monomial m where var :: v -> Vect Q (m v) powers :: Eq v => m v -> [(v,Int)] -- why do we need "powers"?? V ts `bind` f = sum [c *> product [f x ^ i | (x,i) <- powers m] | (m, c) <- ts] -- flipbind f = linear (\m -> product [f x ^ i | (x,i) <- powers m]) instance Monomial NonComMonomial where var v = V [(NCM 1 [v],1)] powers (NCM _ vs) = map power (L.group vs) where power vs@(v:_) = (v,length vs) type NCPoly v = Vect Q (NonComMonomial v) {- x,y,z :: NCPoly String x = var "x" y = var "y" z = var "z" -} -- DIVISION class DivisionBasis m where divM :: m -> m -> Maybe (m,m) -- divM a b tries to find l, r such that a = lbr {- findOverlap :: m -> m -> Maybe (m,m,m) -- given two monomials f g, find if possible a,b,c with f=ab g=bc -} instance Eq v => DivisionBasis (NonComMonomial v) where divM (NCM _ a) (NCM _ b) = divM' [] a where divM' ls (r:rs) = if b `L.isPrefixOf` (r:rs) then Just (ncm $ reverse ls, ncm $ drop (length b) (r:rs)) else divM' (r:ls) rs divM' _ [] = Nothing {- findOverlap (NCM _ xs) (NCM _ ys) = findOverlap' [] xs ys where findOverlap' as [] cs = Nothing -- (reverse as, [], cs) findOverlap' as (b:bs) cs = if (b:bs) `L.isPrefixOf` cs then Just (ncm $ reverse as, ncm $ b:bs, ncm $ drop (length (b:bs)) cs) else findOverlap' (b:as) bs cs -} ncm xs = NCM (length xs) xs lm (V ((m,c):ts)) = m lc (V ((m,c):ts)) = c lt (V (t:ts)) = V [t] -- given f, gs, find ls, rs, f' such that f = sum (zipWith3 (*) ls gs rs) + f', with f' not divisible by any g quotRemNP f gs | all (/=0) gs = quotRemNP' f (replicate n (0,0), 0) | otherwise = error "quotRemNP: division by zero" where n = length gs quotRemNP' 0 (lrs,f') = (lrs,f') quotRemNP' h (lrs,f') = divisionStep h (gs,[],lrs,f') divisionStep h (g:gs, lrs', (l,r):lrs, f') = case lm h `divM` lm g of Just (l',r') -> let l'' = V [(l',lc h / lc g)] r'' = V [(r',1)] h' = h - l'' * g * r'' in quotRemNP' h' (reverse lrs' ++ (l+l'',r+r''):lrs, f') Nothing -> divisionStep h (gs,(l,r):lrs',lrs,f') divisionStep h ([],lrs',[],f') = let lth = lt h -- can't reduce lt h, so add it to the remainder and try to reduce the remaining terms in quotRemNP' (h-lth) (reverse lrs', f'+lth) -- It is only marginally (5-10%) more space/time efficient not to track the (lazily unevaluated) factors remNP f gs | all (/=0) gs = remNP' f 0 | otherwise = error "remNP: division by zero" where n = length gs remNP' 0 f' = f' remNP' h f' = divisionStep h gs f' divisionStep h (g:gs) f' = case lm h `divM` lm g of Just (l',r') -> let l'' = V [(l',lc h / lc g)] r'' = V [(r',1)] h' = h - l'' * g * r'' in remNP' h' f' Nothing -> divisionStep h gs f' divisionStep h [] f' = let lth = lt h -- can't reduce lt h, so add it to the remainder and try to reduce the remaining terms in remNP' (h-lth) (f'+lth) infixl 7 %% -- f %% gs = r where (_,r) = quotRemNP f gs f %% gs = remNP f gs HaskellForMaths-0.4.8/Math/Algebras/Octonions.hs0000644000000000000000000000472312514742102017664 0ustar0000000000000000-- Copyright (c) 2011-2015, David Amos. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, NoMonomorphismRestriction #-} -- |A module defining the (non-associative) algebra of octonions over an arbitrary field. -- -- The octonions are the algebra defined by the basis {1,i0,i1,i2,i3,i4,i5,i6}, -- where each i_n * i_n = -1, and i_n+1 * i_n+2 = i_n+4 (where the indices are modulo 7). module Math.Algebras.Octonions where import Prelude hiding ( (*>) ) import Math.Core.Field import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct hiding (i1,i2) import Math.Algebras.Structures import Math.Algebras.Quaternions import Math.Combinatorics.FiniteGeometry (ptsAG) -- Conway & Smith, On Quaternions and Octonions -- OCTONIONS data OBasis = O Int deriving (Eq,Ord) -- map (return . O) [-1..6] -> [1,i0,i1,i2,i3,i4,i5,i6] type Octonion k = Vect k OBasis instance Show OBasis where show (O n) | n == -1 = "1" | 0 <= n && n <= 6 = "i" ++ show n | otherwise = error "Octonion: invalid basis element" i0, i1, i2, i3, i4, i5, i6 :: Octonion Q i0 = return (O 0) i1 = return (O 1) i2 = return (O 2) i3 = return (O 3) i4 = return (O 4) i5 = return (O 5) i6 = return (O 6) i_ :: Num k => Int -> Octonion k i_ n = return (O n) instance (Eq k, Num k) => Algebra k OBasis where unit x = x *> return (O (-1)) mult = linear m where m (O (-1), O n) = return (O n) m (O n, O (-1)) = return (O n) m (O a, O b) = case (b-a) `mod` 7 of 0 -> -1 1 -> i_ ((a+3) `mod` 7) -- i_n+1 * i_n+2 == i_n+4 2 -> i_ ((a+6) `mod` 7) -- i_n+2 * i_n+4 == i_n+1 3 -> -1 *> i_ ((a+1) `mod` 7) -- i_n+1 * i_n+4 == -i_n+2 4 -> i_ ((a+5) `mod` 7) -- i_n+4 * i_n+1 == i_n+2 5 -> -1 *> i_ ((a+4) `mod` 7) -- i_n+4 * i_n+2 == -i_n+1 6 -> -1 *> i_ ((a+2) `mod` 7) -- i_n+2 * i_n+1 == -i_n+4 instance (Eq k, Num k) => HasConjugation k OBasis where conj = (>>= conj') where conj' (O n) = (if n == -1 then 1 else -1) *> return (O n) -- ie conj = linear conj', but avoiding unnecessary nf call sqnorm x = sum $ map ((^2) . snd) $ terms x -- sqnorm x = scalarPart (x * conj x) -- Hence, the octonions inherit a Fractional instance -- octonions fq = [sum $ zipWith (\x n -> x *> i_ n) xs [-1..6] | xs <- ptsAG 8 fq] HaskellForMaths-0.4.8/Math/Algebras/Quaternions.hs0000644000000000000000000002026312514742102020216 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, NoMonomorphismRestriction #-} -- |A module defining the algebra of quaternions over an arbitrary field. -- -- The quaternions are the algebra defined by the basis {1,i,j,k}, where i^2 = j^2 = k^2 = ijk = -1 module Math.Algebras.Quaternions where import Prelude hiding ( (*>) ) import Math.Core.Field import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures -- Conway & Smith, On Quaternions and Octonions -- QUATERNIONS data HBasis = One | I | J | K deriving (Eq,Ord) type Quaternion k = Vect k HBasis instance Show HBasis where show One = "1" show I = "i" show J = "j" show K = "k" instance (Eq k, Num k) => Algebra k HBasis where unit x = x *> return One mult = linear mult' where mult' (One,b) = return b mult' (b,One) = return b mult' (I,I) = unit (-1) mult' (J,J) = unit (-1) mult' (K,K) = unit (-1) mult' (I,J) = return K mult' (J,I) = -1 *> return K mult' (J,K) = return I mult' (K,J) = -1 *> return I mult' (K,I) = return J mult' (I,K) = -1 *> return J -- |The quaternions have {1,i,j,k} as basis, where i^2 = j^2 = k^2 = ijk = -1. i,j,k :: Num k => Quaternion k i = return I j = return J k = return K class Algebra k a => HasConjugation k a where -- |A conjugation operation is required to satisfy the following laws: -- -- * conj (x+y) = conj x + conj y -- -- * conj (x*y) = conj y * conj x (note the order-reversal) -- -- * conj (conj x) = x -- -- * conj x = x if and only if x in k conj :: Vect k a -> Vect k a -- |The squared norm is defined as sqnorm x = x * conj x. It satisfies: -- -- * sqnorm (x*y) = sqnorm x * sqnorm y -- -- * sqnorm (unit k) = k^2, for k a scalar sqnorm :: Vect k a -> k -- |If an algebra has a conjugation operation, then it has multiplicative inverses, -- via 1\/x = conj x \/ sqnorm x instance (Eq k, Fractional k, Ord a, Show a, HasConjugation k a) => Fractional (Vect k a) where recip 0 = error "recip 0" recip x = (1 / sqnorm x) *> conj x fromRational q = fromRational q *> 1 -- |The scalar part of the quaternion w+xi+yj+zk is w. Also called the real part. scalarPart :: (Num k) => Quaternion k -> k scalarPart = coeff One -- |The vector part of the quaternion w+xi+yj+zk is xi+yj+zk. Also called the pure part. vectorPart :: (Eq k, Num k) => Quaternion k -> Quaternion k vectorPart q = q - scalarPart q *> 1 instance (Eq k, Num k) => HasConjugation k HBasis where conj = (>>= conj') where conj' One = return One conj' imag = -1 *> return imag -- ie conj = linear conj', but avoiding unnecessary nf call sqnorm x = sum $ map ((^2) . snd) $ terms x -- sqnorm x = scalarPart (conj x * x) -- the vector part will be zero anyway -- sqnorm x = x <.> x {- instance Fractional k => Fractional (Quaternion k) where recip 0 = error "Quaternion.recip 0" recip x = (1 / sqnorm x) *> conj x fromRational q = fromRational q *> 1 -} x <.> y = scalarPart (conj x * y) -- x <..> y = 1/2 * (sqnorm x + sqnorm y - sqnorm (x-y)) x^-1 = recip x -- Conway p40 refl q = \x -> -q * conj x * q -- Given a linear function f on the quaternions, return the matrix representing it, -- relative to a given basis. The matrix is considered as acting on the right. asMatrix f bs = [ let fi = f ei in [ej <.> fi | ej <- bs] | ei <- bs ] -- It is possible to write this function using coeff, instead of <.>, -- but then you have to pass in I,J,K, instead of i,j,k, which is uglier. -- Conway p24 -- A homomorphism from H\0 to SO3 -- if q is restricted to unit quaternions, this is a double cover of SO3 (since q, -q induce same rotation) -- The unit quaternions form the group Spin3 reprSO3' q = \x -> q^-1 * x * q -- |Given a non-zero quaternion q in H, the map x -> q^-1 * x * q defines an action on the 3-dimensional vector space -- of pure quaternions X (ie linear combinations of i,j,k). It turns out that this action is a rotation of X, -- and this is a surjective group homomorphism from H* onto SO3. If we restrict q to the group of unit quaternions -- (those of norm 1), then this homomorphism is 2-to-1 (since q and -q give the same rotation). -- This shows that the multiplicative group of unit quaternions is isomorphic to Spin3, the double cover of SO3. -- -- @reprSO3 q@ returns the 3*3 matrix representing this map. reprSO3 :: (Eq k, Fractional k) => Quaternion k -> [[k]] reprSO3 q = reprSO3' q `asMatrix` [i,j,k] -- It's clear from the definition that repr3' q leaves scalars invariant -- for achiral elts, ie GO3\SO3, we compose the above with conj -- For unit quaternions, this is a double cover of SO4 (since (l,r), (-l,-r) induce same rotation) -- Ordered pairs of unit quaternions form the group Spin4 reprSO4' (l,r) = \x -> l^-1 * x * r -- then (l1,r1) * (l2,r2) -> (l1*l2,r1*r2) -- having l^-1 is required for this to work -- |Given a pair of unit quaternions (l,r), the map x -> l^-1 * x * r defines an action on the 4-dimensional space -- of quaternions. It turns out that this action is a rotation, and this is a surjective group homomorphism -- onto SO4. The homomorphism is 2-to-1 (since (l,r) and (-l,-r) give the same map). -- This shows that the multiplicative group of pairs of unit quaternions (with pointwise multiplication) -- is isomorphic to Spin4, the double cover of SO4. -- -- @reprSO4 (l,r)@ returns the 4*4 matrix representing this map. reprSO4 :: (Eq k, Fractional k) => (Quaternion k, Quaternion k) -> [[k]] reprSO4 (l,r) = reprSO4' (l,r) `asMatrix` [1,i,j,k] -- could consider checking that l,r are unit length - except that this is hard to achieve working over Q reprSO4d lr = reprSO4 (p1 lr, p2 lr) -- for achiral elts, GO4\SO4, we compose the above with conj -- DUAL SPACE OF QUATERNIONS AS COALGEBRA one',i',j',k' :: Num k => Vect k (Dual HBasis) one' = return (Dual One) i' = return (Dual I) j' = return (Dual J) k' = return (Dual K) -- Coalgebra structure on the dual vector space to the quaternions -- The comult is the transpose of mult instance (Eq k, Num k) => Coalgebra k (Dual HBasis) where counit = unwrap . linear counit' where counit' (Dual One) = return () counit' _ = zerov comult = linear comult' where comult' (Dual One) = return (Dual One, Dual One) <+> (-1) *> ( return (Dual I, Dual I) <+> return (Dual J, Dual J) <+> return (Dual K, Dual K) ) comult' (Dual I) = return (Dual One, Dual I) <+> return (Dual I, Dual One) <+> return (Dual J, Dual K) <+> (-1) *> return (Dual K, Dual J) comult' (Dual J) = return (Dual One, Dual J) <+> return (Dual J, Dual One) <+> return (Dual K, Dual I) <+> (-1) *> return (Dual I, Dual K) comult' (Dual K) = return (Dual One, Dual K) <+> return (Dual K, Dual One) <+> return (Dual I, Dual J) <+> (-1) *> return (Dual J, Dual I) {- -- Of course, we can define this coalgebra structure on the quaternions themselves -- However, it is not compatible with the algebra structure: we don't get a bialgebra instance Num k => Coalgebra k HBasis where counit = unwrap . linear counit' where counit' One = return () counit' _ = zero comult = linear comult' where comult' One = return (One,One) <+> (-1) *> ( return (I,I) <+> return (J,J) <+> return (K,K) ) comult' I = return (One,I) <+> return (I,One) <+> return (J,K) <+> (-1) *> return (K,J) comult' J = return (One,J) <+> return (J,One) <+> return (K,I) <+> (-1) *> return (I,K) comult' K = return (One,K) <+> return (K,One) <+> return (I,J) <+> (-1) *> return (J,I) -} {- -- Set coalgebra instance instance Num k => Coalgebra k HBasis where counit (V ts) = sum [x | (m,x) <- ts] -- trace comult = fmap (\m -> T m m) -- diagonal -} {- instance Num k => Coalgebra k HBasis where counit (V ts) = sum [x | (One,x) <- ts] comult = linear cm where cm m = if m == One then return (m,m) else return (m,One) <+> return (One,m) -} HaskellForMaths-0.4.8/Math/Algebras/Structures.hs0000644000000000000000000002314312514742102020071 0ustar0000000000000000-- Copyright (c) David Amos, 2010-2015. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, NoMonomorphismRestriction #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE IncoherentInstances #-} -- |A module defining various algebraic structures that can be defined on vector spaces -- - specifically algebra, coalgebra, bialgebra, Hopf algebra, module, comodule module Math.Algebras.Structures where import Prelude hiding ( (*>) ) import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct -- MONOID -- |Monoid class Mon m where munit :: m mmult :: m -> m -> m -- ALGEBRAS, COALGEBRAS, BIALGEBRAS, HOPF ALGEBRAS -- |Caution: If we declare an instance Algebra k b, then we are saying that the vector space Vect k b is a k-algebra. -- In other words, we are saying that b is the basis for a k-algebra. So a more accurate name for this class -- would have been AlgebraBasis. class Algebra k b where unit :: k -> Vect k b mult :: Vect k (Tensor b b) -> Vect k b -- |Sometimes it is more convenient to work with this version of unit. unit' :: (Eq k, Num k, Algebra k b) => Vect k () -> Vect k b unit' = unit . unwrap -- where unwrap = counit :: Num k => Trivial k -> k -- |An instance declaration for Coalgebra k b is saying that the vector space Vect k b is a k-coalgebra. class Coalgebra k b where counit :: Vect k b -> k comult :: Vect k b -> Vect k (Tensor b b) -- |Sometimes it is more convenient to work with this version of counit. counit' :: (Eq k, Num k, Coalgebra k b) => Vect k b -> Vect k () counit' = wrap . counit -- where wrap = unit :: Num k => k -> Trivial k -- unit' and counit' enable us to form tensors of these functions -- |A bialgebra is an algebra which is also a coalgebra, subject to the compatibility conditions -- that counit and comult must be algebra morphisms (or equivalently, that unit and mult must be coalgebra morphisms) class (Algebra k b, Coalgebra k b) => Bialgebra k b where {} class Bialgebra k b => HopfAlgebra k b where antipode :: Vect k b -> Vect k b 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 = negatev x -- negate (V ts) = V $ map (\(b,x) -> (b, negate x)) ts x*y = mult (x `te` y) fromInteger n = unit (fromInteger n) abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" -- This is the Frobenius form, provided some conditions are met -- pairing = counit . mult {- -- A class to be used to declare that a type b should be given the set coalgebra structure class SetCoalgebra b where {} instance (Num k, SetCoalgebra b) => Coalgebra k b where counit (V ts) = sum [x | (m,x) <- ts] -- trace comult = fmap (\m -> T m m) -- diagonal -} instance (Eq k, Num k) => Algebra k () where unit = wrap -- unit 0 = zero -- V [] -- unit x = V [( (),x)] mult = fmap (\((),())->()) -- mult = linear mult' where mult' ((),()) = return () -- mult (V [( ((),()), x)]) = V [( (),x)] -- mult (V []) = zerov instance (Eq k, Num k) => Coalgebra k () where counit = unwrap -- counit (V []) = 0 -- counit (V [( (),x)]) = x comult = fmap (\()->((),())) -- comult = linear comult' where comult' () = return ((),()) -- comult (V [( (),x)]) = V [( ((),()), x)] -- comult (V []) = zerov -- Kassel p4 -- |The direct sum of k-algebras can itself be given the structure of a k-algebra. -- This is the product object in the category of k-algebras. instance (Eq k, Num k, Ord a, Ord b, Algebra k a, Algebra k b) => Algebra k (DSum a b) where unit k = i1 (unit k) <+> i2 (unit k) -- unit == (i1 . unit) <<+>> (i2 . unit) mult = linear mult' where mult' (Left a1, Left a2) = i1 $ mult $ return (a1,a2) mult' (Right b1, Right b2) = i2 $ mult $ return (b1,b2) mult' _ = zerov -- This is the product algebra, which is the product in the category of algebras -- 1 = (1,1) -- (a1,b1) * (a2,b2) = (a1*a2, b1*b2) -- It's not a coproduct, because i1, i2 aren't algebra morphisms (they violate Unit axiom) -- |The direct sum of k-coalgebras can itself be given the structure of a k-coalgebra. -- This is the coproduct object in the category of k-coalgebras. instance (Eq k, Num k, Ord a, Ord b, Coalgebra k a, Coalgebra k b) => Coalgebra k (DSum a b) where counit = unwrap . linear counit' where counit' (Left a) = (wrap . counit) (return a) counit' (Right b) = (wrap . counit) (return b) -- counit = counit . p1 <<+>> counit . p2 comult = linear comult' where comult' (Left a) = fmap (\(a1,a2) -> (Left a1, Left a2)) $ comult $ return a comult' (Right b) = fmap (\(b1,b2) -> (Right b1, Right b2)) $ comult $ return b -- comult = ( (i1 `tf` i1) . comult . p1 ) <<+>> ( (i2 `tf` i2) . comult . p2 ) -- Kassel p32 -- |The tensor product of k-algebras can itself be given the structure of a k-algebra instance (Eq k, Num k, Ord a, Ord b, Algebra k a, Algebra k b) => Algebra k (Tensor a b) where -- unit 0 = V [] unit x = x *> (unit 1 `te` unit 1) mult = (mult `tf` mult) . fmap (\((a,b),(a',b')) -> ((a,a'),(b,b')) ) -- mult = linear m where -- m ((a,b),(a',b')) = (mult $ return (a,a')) `te` (mult $ return (b,b')) -- Kassel p42 -- |The tensor product of k-coalgebras can itself be given the structure of a k-coalgebra instance (Eq k, Num k, Ord a, Ord b, Coalgebra k a, Coalgebra k b) => Coalgebra k (Tensor a b) where counit = unwrap . linear counit' where counit' (a,b) = (wrap . counit . return) a * (wrap . counit . return) b -- (*) taking place in Vect k () -- what this really says is that counit (a `tensor` b) = counit a * counit b -- counit = counit . linear (\(x,y) -> counit' (return x) * counit' (return y)) comult = nf . fmap (\((a,a'),(b,b')) -> ((a,b),(a',b')) ) . (comult `tf` comult) -- comult = assocL . (id `tf` assocR) . (id `tf` (twist `tf` id)) -- . (id `tf` assocL) . assocR . (comult `tf` comult) -- The set coalgebra - can be defined on any set instance (Eq k, Num k) => Coalgebra k EBasis where counit (V ts) = sum [x | (ei,x) <- ts] -- trace comult = fmap ( \ei -> (ei,ei) ) -- diagonal newtype SetCoalgebra b = SC b deriving (Eq,Ord,Show) instance (Eq k, Num k) => Coalgebra k (SetCoalgebra b) where counit (V ts) = sum [x | (m,x) <- ts] -- trace comult = fmap ( \m -> (m,m) ) -- diagonal newtype MonoidCoalgebra m = MC m deriving (Eq,Ord,Show) instance (Eq k, Num k, Ord m, Mon m) => Coalgebra k (MonoidCoalgebra m) where counit (V ts) = sum [if m == MC munit then x else 0 | (m,x) <- ts] comult = linear cm where cm m = if m == MC munit then return (m,m) else return (m, MC munit) <+> return (MC munit, m) -- Brzezinski and Wisbauer, Corings and Comodules, p5 -- Both of the above can be used to define coalgebra structure on polynomial algebras -- by using the definitions above on the generators (ie the indeterminates) and then extending multiplicatively -- They are then guaranteed to be algebra morphisms? -- MODULES AND COMODULES class Algebra k a => Module k a m where action :: Vect k (Tensor a m) -> Vect k m r *. m = action (r `te` m) class Coalgebra k c => Comodule k c n where coaction :: Vect k n -> Vect k (Tensor c n) instance Algebra k a => Module k a a where action = mult instance Coalgebra k c => Comodule k c c where coaction = comult -- module and comodule instances for tensor products -- Kassel p57-8 instance (Eq k, Num k, Ord a, Ord u, Ord v, Algebra k a, Module k a u, Module k a v) => Module k (Tensor a a) (Tensor u v) where -- action x = nf $ x >>= action' action = linear action' where action' ((a,a'), (u,v)) = (action $ return (a,u)) `te` (action $ return (a',v)) instance (Eq k, Num k, Ord a, Ord u, Ord v, Bialgebra k a, Module k a u, Module k a v) => Module k a (Tensor u v) where -- action x = nf $ x >>= action' action = linear action' where action' (a,(u,v)) = action $ (comult $ return a) `te` (return (u,v)) -- !! Overlapping instances -- If a == Tensor b b, then we have overlapping instance with the previous definition -- On the other hand, if a == Tensor u v, then we have overlapping instance with the earlier instance -- Kassel p63 instance (Eq k, Num k, Ord a, Ord m, Ord n, Bialgebra k a, Comodule k a m, Comodule k a n) => Comodule k a (Tensor m n) where coaction = (mult `tf` id) . twistm . (coaction `tf` coaction) where twistm x = nf $ fmap ( \((h,m), (h',n)) -> ((h,h'), (m,n)) ) x -- PAIRINGS -- |A pairing is a non-degenerate bilinear form U x V -> k. -- We are typically interested in pairings having additional properties. For example: -- -- * A bialgebra pairing is a pairing between bialgebras A and B such that the mult in A is adjoint to the comult in B, and vice versa, and the unit in A is adjoint to the counit in B, and vice versa. -- -- * A Hopf pairing is a bialgebra pairing between Hopf algebras A and B such that the antipodes in A and B are adjoint. class HasPairing k u v where pairing :: Vect k (Tensor u v) -> Vect k () -- |The pairing function with a more Haskellish type signature pairing' :: (Num k, HasPairing k u v) => Vect k u -> Vect k v -> k pairing' u v = unwrap (pairing (u `te` v)) instance (Eq k, Num k) => HasPairing k () () where pairing = mult instance (Eq k, Num k, HasPairing k u v, HasPairing k u' v') => HasPairing k (Tensor u u') (Tensor v v') where pairing = mult . (pairing `tf` pairing) . fmap (\((u,u'),(v,v')) -> ((u,v),(u',v'))) -- pairing = fmap (\((),()) -> ()) . (pairing `tf` pairing) . fmap (\((u,u'),(v,v')) -> ((u,v),(u',v'))) HaskellForMaths-0.4.8/Math/Algebras/TensorAlgebra.hs0000644000000000000000000003411012514742102020432 0ustar0000000000000000-- Copyright (c) 2010-2011, David Amos. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, NoMonomorphismRestriction #-} -- |A module defining the tensor algebra, symmetric algebra, exterior (or alternating) algebra, and tensor coalgebra module Math.Algebras.TensorAlgebra where import Prelude hiding ( (*>) ) import qualified Data.List as L import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures import Math.Algebra.Field.Base -- TENSOR ALGEBRA -- |A data type representing basis elements of the tensor algebra over a set\/type. -- Elements of the tensor algebra are linear combinations of iterated tensor products of elements of the set\/type. -- If V = Vect k a is the free vector space over a, then the tensor algebra T(V) = Vect k (TensorAlgebra a) is isomorphic -- to the infinite direct sum: -- -- T(V) = k ⊕ V ⊕ V⊗V ⊕ V⊗V⊗V ⊕ ... data TensorAlgebra a = TA Int [a] deriving (Eq,Ord) instance Show a => Show (TensorAlgebra a) where show (TA _ []) = "1" show (TA _ xs) = filter (/= '"') $ concat $ L.intersperse "*" $ map show xs -- show (TA _ xs) = filter (/= '"') $ concat $ L.intersperse "\x2297" $ map show xs instance Mon (TensorAlgebra a) where munit = TA 0 [] mmult (TA i xs) (TA j ys) = TA (i+j) (xs++ys) instance (Eq k, Num k, Ord a) => Algebra k (TensorAlgebra a) where unit x = x *> return munit mult = nf . fmap (\(a,b) -> a `mmult` b) -- The tensor algebra is the free algebra. It has the following universal property: -- Given f :: a -> Vect k b, where Vect k b is an algebra -- (which induces a vector space morphism, linear f :: Vect k a -> Vect k b) -- then we can lift to an algebra morphism, (liftTA f) :: Vect k (TensorAlgebra a) -> Vect k b -- with (liftTA f) . linear injectTA = linear f -- |Inject an element of the free vector space V = Vect k a into the tensor algebra T(V) = Vect k (TensorAlgebra a) injectTA :: Num k => Vect k a -> Vect k (TensorAlgebra a) injectTA = fmap (\a -> TA 1 [a]) -- The Num k context is not strictly necessary -- |Inject an element of the set\/type A\/a into the tensor algebra T(A) = Vect k (TensorAlgebra a). injectTA' :: (Eq k, Num k) => a -> Vect k (TensorAlgebra a) injectTA' = injectTA . return -- injectTA' a = return (TA 1 [a]) -- |Given vector spaces A = Vect k a, B = Vect k b, where B is also an algebra, -- lift a linear map f: A -> B to an algebra morphism f': T(A) -> B, -- where T(A) is the tensor algebra Vect k (TensorAlgebra a). -- f' will agree with f on A itself (considered as a subspace of T(A)). -- In other words, f = f' . injectTA liftTA :: (Eq k, Num k, Ord b, Show b, Algebra k b) => (Vect k a -> Vect k b) -> Vect k (TensorAlgebra a) -> Vect k b liftTA f = linear (\(TA _ xs) -> product [f (return x) | x <- xs]) -- The Show b constraint is required because we use product (and Num requires Show)!! -- |Given a set\/type A\/a, and a vector space B = Vect k b, where B is also an algebra, -- lift a function f: A -> B to an algebra morphism f': T(A) -> B. -- f' will agree with f on A itself. In other words, f = f' . injectTA' liftTA' :: (Eq k, Num k, Ord b, Show b, Algebra k b) => (a -> Vect k b) -> Vect k (TensorAlgebra a) -> Vect k b liftTA' = liftTA . linear -- liftTA' f = linear (\(TA _ xs) -> product [f x | x <- xs]) -- The second version might be more efficient -- |Tensor algebra is a functor from k-Vect to k-Alg. -- The action on objects is Vect k a -> Vect k (TensorAlgebra a). -- The action on arrows is f -> fmapTA f. fmapTA :: (Eq k, Num k, Ord b, Show b) => (Vect k a -> Vect k b) -> Vect k (TensorAlgebra a) -> Vect k (TensorAlgebra b) fmapTA f = liftTA (injectTA . f) -- fmapTA f = linear (\(TA _ xs) -> product [injectTA (f (return x)) | x <- xs]) -- |If we compose the free vector space functor Set -> k-Vect with the tensor algebra functor k-Vect -> k-Alg, -- we obtain a functor Set -> k-Alg, the free algebra functor. -- The action on objects is a -> Vect k (TensorAlgebra a). -- The action on arrows is f -> fmapTA' f. fmapTA' :: (Eq k, Num k, Ord b, Show b) => (a -> b) -> Vect k (TensorAlgebra a) -> Vect k (TensorAlgebra b) fmapTA' = fmapTA . fmap -- fmapTA' f = liftTA' (injectTA' . f) -- fmapTA' f = linear (\(TA _ xs) -> product [injectTA' (f x) | x <- xs]) bindTA :: (Eq k, Num k, Ord b, Show b) => Vect k (TensorAlgebra a) -> (Vect k a -> Vect k (TensorAlgebra b)) -> Vect k (TensorAlgebra b) bindTA = flip liftTA bindTA' :: (Eq k, Num k, Ord b, Show b) => Vect k (TensorAlgebra a) -> (a -> Vect k (TensorAlgebra b)) -> Vect k (TensorAlgebra b) bindTA' = flip liftTA' -- Another way to think about this is variable substitution -- "The algebra is free until we bind it" -- SYMMETRIC ALGEBRA -- |A data type representing basis elements of the symmetric algebra over a set\/type. -- The symmetric algebra is the quotient of the tensor algebra by -- the ideal generated by all -- differences of products u⊗v - v⊗u. data SymmetricAlgebra a = Sym Int [a] deriving (Eq,Ord) instance Show a => Show (SymmetricAlgebra a) where show (Sym _ []) = "1" show (Sym _ xs) = filter (/= '"') $ concat $ L.intersperse "." $ map show xs instance Ord a => Mon (SymmetricAlgebra a) where munit = Sym 0 [] mmult (Sym i xs) (Sym j ys) = Sym (i+j) $ L.sort (xs++ys) instance (Eq k, Num k, Ord a) => Algebra k (SymmetricAlgebra a) where unit x = x *> return munit mult = nf . fmap (\(a,b) -> a `mmult` b) -- |Algebra morphism from tensor algebra to symmetric algebra. -- The kernel of the morphism is the ideal generated by all -- differences of products u⊗v - v⊗u. toSym :: (Eq k, Num k, Ord a) => Vect k (TensorAlgebra a) -> Vect k (SymmetricAlgebra a) toSym = linear toSym' where toSym' (TA i xs) = return $ Sym i (L.sort xs) -- The symmetric algebra is the free commutative algebra. It has the following universal property: -- Given f :: a -> Vect k b, where Vect k b is a commutative algebra -- (which induces a vector space morphism, linear f :: Vect k a -> Vect k b) -- then we can lift to a commutative algebra morphism, (liftSym f) :: Vect k (SymmetricAlgebra a) -> Vect k b -- with (liftSym f) . injectSym = f injectSym :: Num k => Vect k a -> Vect k (SymmetricAlgebra a) injectSym = fmap (\a -> Sym 1 [a]) injectSym' :: Num k => a -> Vect k (SymmetricAlgebra a) injectSym' = injectSym . return -- injectSym' a = return (Sym 1 [a]) liftSym :: (Eq k, Num k, Ord b, Show b, Algebra k b) => (Vect k a -> Vect k b) -> Vect k (SymmetricAlgebra a) -> Vect k b liftSym f = linear (\(Sym _ xs) -> product [f (return x) | x <- xs]) liftSym' :: (Eq k, Num k, Ord b, Show b, Algebra k b) => (a -> Vect k b) -> Vect k (SymmetricAlgebra a) -> Vect k b liftSym' = liftSym . linear -- liftSym' f = linear (\(Sym _ xs) -> product [f x | x <- xs]) fmapSym :: (Eq k, Num k, Ord b, Show b) => (Vect k a -> Vect k b) -> Vect k (SymmetricAlgebra a) -> Vect k (SymmetricAlgebra b) fmapSym f = liftSym (injectSym . f) -- fmapSym f = linear (\(Sym _ xs) -> product [injectSym (f (return x)) | x <- xs]) fmapSym' :: (Eq k, Num k, Ord b, Show b) => (a -> b) -> Vect k (SymmetricAlgebra a) -> Vect k (SymmetricAlgebra b) fmapSym' = fmapSym . fmap -- fmapSym' f = liftSym' (injectSym' . f) -- fmapSym' f = linear (\(Sym _ xs) -> product [injectSym' (f x) | x <- xs]) bindSym :: (Eq k, Num k, Ord b, Show b) => Vect k (SymmetricAlgebra a) -> (Vect k a -> Vect k (SymmetricAlgebra b)) -> Vect k (SymmetricAlgebra b) bindSym = flip liftSym bindSym' :: (Eq k, Num k, Ord b, Show b) => Vect k (SymmetricAlgebra a) -> (a -> Vect k (SymmetricAlgebra b)) -> Vect k (SymmetricAlgebra b) bindSym' = flip liftSym' -- Another way to think about this is variable substitution -- EXTERIOR ALGEBRA -- |A data type representing basis elements of the exterior algebra over a set\/type. -- The exterior algebra is the quotient of the tensor algebra by -- the ideal generated by all -- self-products u⊗u and sums of products u⊗v + v⊗u data ExteriorAlgebra a = Ext Int [a] deriving (Eq,Ord) instance Show a => Show (ExteriorAlgebra a) where show (Ext _ []) = "1" show (Ext _ xs) = filter (/= '"') $ concat $ L.intersperse "^" $ map show xs instance (Eq k, Num k, Ord a) => Algebra k (ExteriorAlgebra a) where unit x = x *> return (Ext 0 []) mult xy = nf $ xy >>= (\(Ext i xs, Ext j ys) -> signedMerge 1 (0,[]) (i,xs) (j,ys)) where signedMerge s (k,zs) (i,x:xs) (j,y:ys) = case compare x y of EQ -> zerov LT -> signedMerge s (k+1,x:zs) (i-1,xs) (j,y:ys) GT -> let s' = if even i then s else -s -- we had to commute y past x:xs, with i sign changes in signedMerge s' (k+1,y:zs) (i,x:xs) (j-1,ys) signedMerge s (k,zs) (i,xs) (0,[]) = s *> (return $ Ext (k+i) $ reverse zs ++ xs) signedMerge s (k,zs) (0,[]) (j,ys) = s *> (return $ Ext (k+j) $ reverse zs ++ ys) -- |Algebra morphism from tensor algebra to exterior algebra. -- The kernel of the morphism is the ideal generated by all -- self-products u⊗u and sums of products u⊗v + v⊗u toExt :: (Eq k, Num k, Ord a) => Vect k (TensorAlgebra a) -> Vect k (ExteriorAlgebra a) toExt = linear toExt' where toExt' (TA i xs) = let (sign,xs') = signedSort 1 True [] xs in fromInteger sign *> return (Ext i xs') signedSort sign done ls (r1:r2:rs) = case compare r1 r2 of EQ -> (0,[]) LT -> signedSort sign done (r1:ls) (r2:rs) GT -> signedSort (-sign) False (r2:ls) (r1:rs) signedSort sign done ls rs = if done then (sign,reverse ls ++ rs) else signedSort sign True [] (reverse ls ++ rs) -- !! The above code seems a bit clumsy - can we do better injectExt :: Num k => Vect k a -> Vect k (ExteriorAlgebra a) injectExt = fmap (\a -> Ext 1 [a]) injectExt' :: Num k => a -> Vect k (ExteriorAlgebra a) injectExt' = injectExt . return -- injectExt' a = return (Ext 1 [a]) liftExt :: (Eq k, Num k, Ord b, Show b, Algebra k b) => (Vect k a -> Vect k b) -> Vect k (ExteriorAlgebra a) -> Vect k b liftExt f = linear (\(Ext _ xs) -> product [f (return x) | x <- xs]) liftExt' :: (Eq k, Num k, Ord b, Show b, Algebra k b) => (a -> Vect k b) -> Vect k (ExteriorAlgebra a) -> Vect k b liftExt' = liftExt . linear -- liftExt' f = linear (\(Ext _ xs) -> product [f x | x <- xs]) fmapExt :: (Eq k, Num k, Ord b, Show b) => (Vect k a -> Vect k b) -> Vect k (ExteriorAlgebra a) -> Vect k (ExteriorAlgebra b) fmapExt f = liftExt (injectExt . f) -- fmapExt f = linear (\(Ext _ xs) -> product [injectExt (f (return x)) | x <- xs]) fmapExt' :: (Eq k, Num k, Ord b, Show b) => (a -> b) -> Vect k (ExteriorAlgebra a) -> Vect k (ExteriorAlgebra b) fmapExt' = fmapExt . fmap -- fmapExt' f = liftExt' (injectExt' . f) -- fmapExt' f = linear (\(Ext _ xs) -> product [injectExt' (f x) | x <- xs]) bindExt :: (Eq k, Num k, Ord b, Show b) => Vect k (ExteriorAlgebra a) -> (Vect k a -> Vect k (ExteriorAlgebra b)) -> Vect k (ExteriorAlgebra b) bindExt = flip liftExt bindExt' :: (Eq k, Num k, Ord b, Show b) => Vect k (ExteriorAlgebra a) -> (a -> Vect k (ExteriorAlgebra b)) -> Vect k (ExteriorAlgebra b) bindExt' = flip liftExt' -- Another way to think about this is variable substitution -- TENSOR COALGEBRA -- Kassel p67 data TensorCoalgebra c = TC Int [c] deriving (Eq,Ord,Show) instance (Eq k, Num k, Ord c) => Coalgebra k (TensorCoalgebra c) where counit = unwrap . linear counit' where counit' (TC 0 []) = return () -- 1 counit' _ = zerov comult = linear comult' where comult' (TC d xs) = sumv [return (TC i ls, TC (d-i) rs) | (i,ls,rs) <- L.zip3 [0..] (L.inits xs) (L.tails xs)] -- Now show that the tensor coalgebra is the cofree coalgebra -- ie that it has the required universal property: -- coliftTC f is a coalgebra morphism, and f == projectTC . coliftTC f -- projection onto the underlying vector space projectTC :: (Eq k, Num k, Ord b) => Vect k (TensorCoalgebra b) -> Vect k b projectTC = linear projectTC' where projectTC' (TC 1 [b]) = return b; projectTC' _ = zerov -- projectTC t = V [(b,c) | (TC 1 [b], c) <- terms t] -- lift a vector space morphism C -> D to a coalgebra morphism C -> T'(D) -- this function returns an approximation, valid only up to second order terms coliftTC :: (Eq k, Num k, Coalgebra k c, Ord d) => (Vect k c -> Vect k d) -> Vect k c -> Vect k (TensorCoalgebra d) coliftTC f = sumf [coliftTC' i f | i <- [0..2] ] coliftTC' 0 f = linear f0' where f0' c = counit (return c) *> return (TC 0 []) coliftTC' 1 f = linear f1' where f1' c = fmap (\d -> TC 1 [d]) (f $ return c) coliftTC' n f = linear fn' where f1' = coliftTC' 1 f fn1' = coliftTC' (n-1) f fn' c = fmap (\(TC 1 [x], TC _ xs) -> TC n (x:xs)) $ ( (f1' `tf` fn1') . comult) (return c) cobindTC :: (Eq k, Num k, Ord c, Ord d) => (Vect k (TensorCoalgebra c) -> Vect k d) -> Vect k (TensorCoalgebra c) -> Vect k (TensorCoalgebra d) cobindTC = coliftTC -- So we have a comonad: -- projectTC is extract :: w a -> a -- cobindTC is extend :: (w a -> b) -> w a -> w b {- Derivation of coliftTC: Write f' = f0' + f1' + f2' + ..., where fn' is the part of f' whose range is the nth iterated tensor product in TC. Then we can deduce f0' from counit . f' == counit If f': c -> sum ai*di + terms of other order then counit c = sum ai*counit di We can deduce f1' from f == projectTC . f' We can deduce the rest recursively from comult Write comult (on TC) = comult00 + (comult01+comult10) + (comult02+comult11+comult20) + ..., where comultij is that part that operates on the i+j'th tensor product to produce i'th `te` jth Then comult . f' = (f' `tf` f') . comult can be expanded as (comult00 + comult01+comult10 + ...) . (f0' + f1' + ...) = (f0' `tf` f0' + f0' `tf` f1' + f1' `tf` f0' + ...) . comult Looking at the 1,n-1 term, we see that comult1,n-1 . fn' = (f1' `tf` fn-1') . comult -} -- For example {- > let f = linear (\x -> case x of Dual One -> e1; Dual I -> e2; Dual J -> e3; Dual K -> e 4) > let f' = sumf [coliftTC' i f | i <- [0..3] ] -- then the following agree up to level three (inclusive) > (comult . f') one' > ((f' `tf` f') . comult) one' -} HaskellForMaths-0.4.8/Math/Algebras/TensorProduct.hs0000644000000000000000000001242212514742102020517 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction #-} -- |A module defining direct sum and tensor product of vector spaces module Math.Algebras.TensorProduct where import Prelude hiding ( (*>) ) import Math.Algebras.VectorSpace infix 7 `te`, `tf` infix 6 `dsume`, `dsumf` -- DIRECT SUM -- |A type for constructing a basis for the direct sum of vector spaces. -- The direct sum of Vect k a and Vect k b is Vect k (DSum a b) type DSum a b = Either a b -- |Injection of left summand into direct sum i1 :: Vect k a -> Vect k (DSum a b) i1 = fmap Left -- |Injection of right summand into direct sum i2 :: Vect k b -> Vect k (DSum a b) i2 = fmap Right -- |The coproduct of two linear functions (with the same target). -- Satisfies the universal property that f == coprodf f g . i1 and g == coprodf f g . i2 coprodf :: (Eq k, Num k, Ord t) => (Vect k a -> Vect k t) -> (Vect k b -> Vect k t) -> Vect k (DSum a b) -> Vect k t coprodf f g = linear fg' where fg' (Left a) = f (return a) fg' (Right b) = g (return b) -- |Projection onto left summand from direct sum p1 :: (Eq k, Num k, Ord a) => Vect k (DSum a b) -> Vect k a p1 = linear p1' where p1' (Left a) = return a p1' (Right b) = zerov -- |Projection onto right summand from direct sum p2 :: (Eq k, Num k, Ord b) => Vect k (DSum a b) -> Vect k b p2 = linear p2' where p2' (Left a) = zerov p2' (Right b) = return b -- |The product of two linear functions (with the same source). -- Satisfies the universal property that f == p1 . prodf f g and g == p2 . prodf f g prodf :: (Eq k, Num k, Ord a, Ord b) => (Vect k s -> Vect k a) -> (Vect k s -> Vect k b) -> Vect k s -> Vect k (DSum a b) prodf f g = linear fg' where fg' b = fmap Left (f $ return b) <+> fmap Right (g $ return b) -- |The direct sum of two vector space elements dsume :: (Eq k, Num k, Ord a, Ord b) => Vect k a -> Vect k b -> Vect k (DSum a b) -- dsume x y = fmap Left x <+> fmap Right y dsume x y = i1 x <+> i2 y -- |The direct sum of two linear functions. -- Satisfies the universal property that f == p1 . dsumf f g . i1 and g == p2 . dsumf f g . i2 dsumf :: (Eq k, Num k, Ord a, Ord b, Ord a', Ord b') => (Vect k a -> Vect k a') -> (Vect k b -> Vect k b') -> Vect k (DSum a b) -> Vect k (DSum a' b') dsumf f g ab = (i1 . f . p1) ab <+> (i2 . g . p2) ab -- TENSOR PRODUCT -- |A type for constructing a basis for the tensor product of vector spaces. -- The tensor product of Vect k a and Vect k b is Vect k (Tensor a b) type Tensor a b = (a,b) -- |The tensor product of two vector space elements te :: Num k => Vect k a -> Vect k b -> Vect k (Tensor a b) te (V us) (V vs) = V [((a,b), x*y) | (a,x) <- us, (b,y) <- vs] -- te (V us) (V vs) = V [((ei,ej), xi*xj) | (ei,xi) <- us, (ej,xj) <- vs] -- preserves order - that is, if the inputs are correctly ordered, so is the output -- Implicit assumption - f and g are linear -- |The tensor product of two linear functions tf :: (Eq k, Num k, Ord a', Ord b') => (Vect k a -> Vect k a') -> (Vect k b -> Vect k b') -> Vect k (Tensor a b) -> Vect k (Tensor a' b') tf f g (V ts) = sum [x *> te (f $ return a) (g $ return b) | ((a,b), x) <- ts] where sum = foldl add zerov -- tensor isomorphisms -- in fact, this definition works for any Functor f, not just (Vect k) assocL :: Vect k (Tensor a (Tensor b c)) -> Vect k (Tensor (Tensor a b) c) assocL = fmap ( \(a,(b,c)) -> ((a,b),c) ) assocR :: Vect k (Tensor (Tensor a b) c) -> Vect k (Tensor a (Tensor b c)) assocR = fmap ( \((a,b),c) -> (a,(b,c)) ) unitInL :: Vect k a -> Vect k (Tensor () a) unitInL = fmap ( \a -> ((),a) ) unitOutL :: Vect k (Tensor () a) -> Vect k a unitOutL = fmap ( \((),a) -> a ) unitInR :: Vect k a -> Vect k (Tensor a ()) unitInR = fmap ( \a -> (a,()) ) unitOutR :: Vect k (Tensor a ()) -> Vect k a unitOutR = fmap ( \(a,()) -> a ) twist :: (Eq k, Num k, Ord a, Ord b) => Vect k (Tensor a b) -> Vect k (Tensor b a) twist v = nf $ fmap ( \(a,b) -> (b,a) ) v -- note the nf call, as f is not order-preserving distrL :: (Eq k, Num k, Ord a, Ord b, Ord c) => Vect k (Tensor a (DSum b c)) -> Vect k (DSum (Tensor a b) (Tensor a c)) distrL v = nf $ fmap (\(a,bc) -> case bc of Left b -> Left (a,b); Right c -> Right (a,c)) v undistrL :: (Eq k, Num k, Ord a, Ord b, Ord c) => Vect k (DSum (Tensor a b) (Tensor a c)) -> Vect k (Tensor a (DSum b c)) undistrL v = nf $ fmap ( \abc -> case abc of Left (a,b) -> (a,Left b); Right (a,c) -> (a,Right c) ) v distrR :: Vect k (Tensor (DSum a b) c) -> Vect k (DSum (Tensor a c) (Tensor b c)) distrR v = fmap ( \(ab,c) -> case ab of Left a -> Left (a,c); Right b -> Right (b,c) ) v -- order-preserving, so no nf call needed undistrR :: Vect k (DSum (Tensor a c) (Tensor b c)) -> Vect k (Tensor (DSum a b) c) undistrR v = fmap ( \abc -> case abc of Left (a,c) -> (Left a, c); Right (b,c) -> (Right b, c) ) v -- For example: -- > distrL (e1 `te` i1 e2) :: Vect Q (DSum (Tensor EBasis EBasis) (Tensor EBasis EBasis)) -- Left (e1,e2) ev :: (Eq k, Num k, Ord b) => Vect k (Tensor (Dual b) b) -> k ev = unwrap . linear (\(Dual bi, bj) -> delta bi bj *> return ()) -- slightly cheating, as delta i j is meant to compare indices, not the basis elements themselves delta i j = if i == j then 1 else 0 reify :: (Eq k, Num k, Ord b) => Vect k (Dual b) -> (Vect k b -> k) reify f x = ev (f `te` x) HaskellForMaths-0.4.8/Math/Algebras/VectorSpace.hs0000644000000000000000000002407112514742102020125 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_HADDOCK prune #-} -- |A module defining the type and operations of free k-vector spaces over a basis b (for a field k) module Math.Algebras.VectorSpace where import Prelude hiding ( (<*), (*>) ) import Control.Applicative hiding ( (<*), (*>) ) import Control.Monad (ap) import qualified Data.List as L import qualified Data.Set as S -- only needed for toSet infixr 7 *> infixl 7 <* infixl 6 <+>, <->, <<+>>, <<->> -- |Given a field type k and a basis type b, Vect k b is the type of the free k-vector space over b. -- Elements (values) of Vect k b consist of k-linear combinations of elements (values) of b. -- -- In order for Vect k b to be a vector space, it is necessary that k is a field (that is, an instance of Fractional). -- In practice, we often relax this condition, and require that k is a ring (that is, an instance of Num). In that case, -- Vect k b should more correctly be called (the type of) the free k-module over b. -- -- Most of the code requires that b is an instance of Ord. This is primarily to enable us to simplify to a normal form. newtype Vect k b = V [(b,k)] deriving (Eq,Ord) instance (Show k, Eq k, Num k, Show b) => Show (Vect k b) where show (V []) = "0" show (V ts) = concatWithPlus $ map showTerm ts where showTerm (b,x) | show b == "1" = show x | show x == "1" = show b | show x == "-1" = "-" ++ show b | otherwise = (if isAtomic (show x) then show x else "(" ++ show x ++ ")") ++ show b -- (if ' ' `notElem` show b then show b else "(" ++ show b ++ ")") -- if we put this here we miss the two cases above concatWithPlus (t1:t2:ts) = if head t2 == '-' then t1 ++ concatWithPlus (t2:ts) else t1 ++ '+' : concatWithPlus (t2:ts) concatWithPlus [t] = t isAtomic (c:cs) = isAtomic' cs isAtomic' ('^':'-':cs) = isAtomic' cs isAtomic' ('+':cs) = False isAtomic' ('-':cs) = False isAtomic' (c:cs) = isAtomic' cs isAtomic' [] = True terms (V ts) = ts -- |Return the coefficient of the specified basis element in a vector coeff :: (Num k, Eq b) => b -> Vect k b -> k coeff b v = sum [k | (b',k) <- terms v, b' == b] -- |Remove the term for a specified basis element from a vector removeTerm :: (Eq k, Num k, Ord b) => b -> Vect k b -> Vect k b removeTerm b (V ts) = V $ filter ((/=b) . fst) ts -- v <-> coeff b v *> return b -- |The zero vector zerov :: Vect k b zerov = V [] -- |Addition of vectors add :: (Eq k, Num k, Ord b) => Vect k b -> Vect k b -> Vect k b add (V ts) (V us) = V $ addmerge ts us -- |Addition of vectors (same as add) (<+>) :: (Eq k, Num k, Ord b) => Vect k b -> Vect k b -> Vect k b (<+>) = add addmerge ((a,x):ts) ((b,y):us) = case compare a b of LT -> (a,x) : addmerge ts ((b,y):us) EQ -> if x+y == 0 then addmerge ts us else (a,x+y) : addmerge ts us GT -> (b,y) : addmerge ((a,x):ts) us addmerge ts [] = ts addmerge [] us = us -- |Sum of a list of vectors sumv :: (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b sumv = foldl (<+>) zerov -- |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 (<->) :: (Eq k, Num k, Ord b) => Vect k b -> Vect k b -> Vect k b (<->) u v = u <+> negatev v -- |Scalar multiplication (on the left) smultL :: (Eq k, Num k) => k -> Vect k b -> Vect k b smultL 0 _ = zerov -- V [] smultL k (V ts) = V [(ei,k*xi) | (ei,xi) <- ts] -- |Same as smultL. Mnemonic is \"multiply through (from the left)\" (*>) :: (Eq k, Num k) => k -> Vect k b -> Vect k b (*>) = smultL -- |Scalar multiplication on the right smultR :: (Eq k, Num k) => Vect k b -> k -> Vect k b smultR _ 0 = zerov -- V [] smultR (V ts) k = V [(ei,xi*k) | (ei,xi) <- ts] -- |Same as smultR. Mnemonic is \"multiply through (from the right)\" (<*) :: (Eq k, Num k) => Vect k b -> k -> Vect k b (<*) = smultR -- same as return -- injection of basis elt into vector space -- inject b = V [(b,1)] -- same as fmap -- liftFromBasis f (V ts) = V [(f b, x) | (b, x) <- ts] -- if f is not order-preserving, then you need to call nf afterwards -- |Convert an element of Vect k b into normal form. Normal form consists in having the basis elements in ascending order, -- with no duplicates, and all coefficients non-zero nf :: (Eq k, Num k, Ord b) => Vect k b -> Vect k b nf (V ts) = V $ nf' $ L.sortBy compareFst ts where nf' ((b1,x1):(b2,x2):ts) = case compare b1 b2 of LT -> if x1 == 0 then nf' ((b2,x2):ts) else (b1,x1) : nf' ((b2,x2):ts) EQ -> if x1+x2 == 0 then nf' ts else nf' ((b1,x1+x2):ts) GT -> error "nf': not pre-sorted" nf' [(b,x)] = if x == 0 then [] else [(b,x)] nf' [] = [] compareFst (b1,x1) (b2,x2) = compare b1 b2 -- compareFst = curry ( uncurry compare . (fst *** fst) ) -- |Given a field k, (Vect k) is a functor, the \"free k-vector space\" functor. -- -- In the mathematical sense, this can be regarded as a functor from the category Set (of sets) to the category k-Vect -- (of k-vector spaces). In Haskell, instead of Set we have Hask, the category of Haskell types. However, for our purposes -- it is helpful to identify Hask with Set, by identifying a Haskell type with its set of inhabitants. -- -- The type constructor (Vect k) gives the action of the functor on objects in the category, -- taking a set (type) to a free k-vector space. fmap gives the action of the functor on arrows in the category, -- taking a function between sets (types) to a linear map between vector spaces. -- -- Note that if f is not order-preserving, then (fmap f) is not guaranteed to return results in normal form, -- so it may be preferable to use (nf . fmap f). instance Functor (Vect k) where -- lift a function on the basis to a function on the vector space fmap f (V ts) = V [(f b, x) | (b,x) <- ts] -- Note that if f is not order-preserving, then we need to call "nf" afterwards -- From GHC 7.10, Monad has Applicative as a superclass, so we must define an instance. -- It doesn't particularly make sense for Vect k. -- (Although given Vect k b, we could represent the dual space as Vect k (b -> ()), -- and then have a use for <*>.) instance Num k => Applicative (Vect k) where pure = return -- pure b = V [(b,1)] (<*>) = ap -- V fs <*> V xs = V [(f x, a*b) | (f,a) <- fs, (x,b) <- xs] -- |Given a field k, the type constructor (Vect k) is a monad, the \"free k-vector space monad\". -- -- In order to understand this, it is probably easiest to think of a free k-vector space as a kind of container, -- a bit like a list, except that order doesn't matter, and you're allowed arbitrary (even negative or fractional) -- quantities of the basis elements in the container. -- -- According to this way of thinking, return is the function that puts a basis element into the vector space (container). -- -- Given a function f from the basis of one vector space to another vector space (a -> Vect k b), -- bind (>>=) lifts it to a function (>>= f) from the first vector space to the second (Vect k a -> Vect k b). -- -- Note that in general (>>= f) applied to a vector will not return a result in normal form, -- so it is usually preferable to use (linear f) instead. instance Num k => Monad (Vect k) where return a = V [(a,1)] V ts >>= f = V $ concat [ [(b,y*x) | let V us = f a, (b,y) <- us] | (a,x) <- ts] -- Note that as we can't assume Ord a in the Monad instance, we need to call "nf" afterwards -- |A linear map between vector spaces A and B can be defined by giving its action on the basis elements of A. -- The action on all elements of A then follows by linearity. -- -- If we have A = Vect k a, B = Vect k b, and f :: a -> Vect k b is a function from the basis elements of A into B, -- then @linear f@ is the linear map that this defines by linearity. linear :: (Eq k, Num k, Ord b) => (a -> Vect k b) -> Vect k a -> Vect k b linear f v = nf $ v >>= f newtype EBasis = E Int deriving (Eq,Ord) instance Show EBasis where show (E i) = "e" ++ show i e i = return $ E i e1 = e 1 e2 = e 2 e3 = e 3 -- dual (E i) = E (-i) -- |Trivial k is the field k considered as a k-vector space. In maths, we would not normally make a distinction here, -- but in the code, we need this if we want to be able to put k as one side of a tensor product. type Trivial k = Vect k () -- |Wrap an element of the field k to an element of the trivial k-vector space wrap :: (Eq k, Num k) => k -> Vect k () wrap 0 = zerov wrap x = V [( (),x)] -- |Unwrap an element of the trivial k-vector space to an element of the field k unwrap :: Num k => Vect k () -> k unwrap (V []) = 0 unwrap (V [( (),x)]) = x -- |Given a finite vector space basis b, Dual b can be used to represent a basis for the dual vector space. -- The intention is that for a given individual basis element b_i, (Dual b_i) represents the indicator function for b_i, -- which takes b_i to 1 and all other basis elements to 0. -- -- (Note that if the basis b is infinite, then Dual b may only represent a sub-basis of the dual vector space.) newtype Dual b = Dual b deriving (Eq,Ord) instance Show basis => Show (Dual basis) where show (Dual b) = show b ++ "'" e' i = return $ Dual $ E i e1' = e' 1 e2' = e' 2 e3' = e' 3 dual :: Vect k b -> Vect k (Dual b) dual = fmap Dual (f <<+>> g) v = f v <+> g v (f <<->> g) v = f v <-> g v zerof v = zerov sumf fs = foldl (<<+>>) zerof fs -- Lens coeffLens :: (Ord b, Eq k, Num k, Functor f) => b -> (k -> f k) -> (Vect k b -> f (Vect k b)) coeffLens b = lens (coeff b) (setter b) where setter b = \(V ts) k -> (k *> return b) <+> (V $ filter ((/=b) . fst) ts) lens getter setter f a = fmap (setter a) (f (getter a)) -- Can be used with lens-family, for example -- e1 ^. coeffLens (E 2) --> 0 -- e1 & coeffLens (E 2) .~ 2 --> e1+2e2 -- e1 & coeffLens (E 1) %~ (+2) --> 3e1 HaskellForMaths-0.4.8/Math/Combinatorics/0000755000000000000000000000000012514742102016423 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Combinatorics/CombinatorialHopfAlgebra.hs0000644000000000000000000011740112514742102023641 0ustar0000000000000000-- Copyright (c) 2012-2015, 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: -- -- * Sh, the Shuffle Hopf algebra -- -- * 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) -- -- * Sym, the Hopf algebra of symmetric functions (having a basis indexed by integer partitions) -- -- * NSym, the Hopf algebra of non-commutative symmetric functions 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 -- Lie Algebras and Hopf Algebras -- Michiel Hazewinkel, Nadiya Gubareni, V.V.Kirichenko import Prelude hiding ( (*>) ) 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 and flattened deconcatenation coproduct -- 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] -} instance HasInverses SSymF where inverse (SSymF xs) = SSymF $ map snd $ L.sort $ map (\(s,t)->(t,s)) $ zip [1..] xs -- Hazewinkel p267 -- |A pairing showing that SSym is self-adjoint instance (Eq k, Num k) => HasPairing k SSymF SSymF where pairing = linear pairing' where pairing' (x,y) = delta x (inverse y) -- Not entirely clear to me why this works -- The pairing is *not* positive definite (Hazewinkel p267) -- eg (\x -> pairing' x x >= 0) (ssymF [1,3,2] + ssymF [2,3,1] - ssymF [3,1,2]) == False -- |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] -- should really check that xs and ys have the same length, and perhaps insist also on same type 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 ssymMtoF :: (Eq k, Num k) => Vect k SSymM -> Vect k SSymF ssymMtoF = linear ssymMtoF' where ssymMtoF' (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 ssymFtoM :: (Eq k, Num k) => Vect k SSymF -> Vect k SSymM ssymFtoM = linear ssymFtoM' where ssymFtoM' (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 = ssymFtoM . mult . (ssymMtoF `tf` ssymMtoF) {- 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 = (ssymFtoM `tf` ssymFtoM) . comult . ssymMtoF 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 = ssymFtoM . antipode . ssymMtoF -- Hazewinkel p265 instance (Eq k, Num k) => Algebra k (Dual SSymF) where unit x = x *> return (Dual (SSymF [])) mult = linear mult' where mult' (Dual (SSymF xs), Dual (SSymF ys)) = sumv [(return . Dual . SSymF) (xs'' ++ ys'') | xs' <- combinationsOf r [1..r+s], let ys' = diffAsc [1..r+s] xs', xs'' <- L.permutations xs', flatten xs'' == xs, ys'' <- L.permutations ys', flatten ys'' == ys ] where r = length xs; s = length ys -- In other words, mult x y is the sum of those z whose comult (in SSymF) has an (x,y) term -- So the matrix for mult is the transpose of the matrix for comult in SSymF instance (Eq k, Num k) => Coalgebra k (Dual SSymF) where counit = unwrap . linear counit' where counit' (Dual (SSymF xs)) = if null xs then 1 else 0 comult = linear comult' where comult' (Dual (SSymF xs)) = sumv [return (Dual (SSymF ys), Dual (SSymF (flatten zs))) | i <- [0..n], let (ys,zs) = L.partition (<=i) xs ] where n = length xs -- In other words, comult x is the sum of those (y,z) whose mult (in SSymF) has a z term -- So the matrix for comult is the transpose of the matrix for mult in SSymF instance (Eq k, Num k) => Bialgebra k (Dual SSymF) where {} instance (Eq k, Num k) => HopfAlgebra k (Dual SSymF) where antipode = linear antipode' where antipode' (Dual (SSymF [])) = return (Dual (SSymF [])) antipode' x@(Dual (SSymF xs)) = (negatev . mult . (id `tf` antipode) . removeTerm (Dual (SSymF []),x) . comult . return) x -- This pairing is positive definite (Hazewinkel p267) instance (Eq k, Num k) => HasPairing k SSymF (Dual SSymF) where pairing = linear pairing' where pairing' (x, Dual y) = delta x y -- |The isomorphism from SSym to its dual that takes a permutation in the fundamental basis to its inverse in the dual basis ssymFtoDual :: (Eq k, Num k) => Vect k SSymF -> Vect k (Dual SSymF) ssymFtoDual = nf . fmap (Dual . inverse) -- This is theta on Hazewinkel p266 (though later he also uses theta for the inverse of this map) -- 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) -- |List all trees with the given number of nodes trees :: Int -> [PBT ()] 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 tamariCovers :: PBT a -> [PBT a] tamariCovers E = [] tamariCovers (T t@(T u x v) y w) = [T t' y w | t' <- tamariCovers t] ++ [T t y w' | w' <- tamariCovers 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) tamariCovers (T E x u) = [T E x u' | u' <- tamariCovers u] -- |The up-set of a binary tree in the Tamari partial order tamariUpSet :: Ord a => PBT a -> [PBT a] tamariUpSet t = upSet' [] [t] where upSet' interior boundary = if null boundary then interior else let interior' = setUnionAsc interior boundary boundary' = toSet $ concatMap tamariCovers boundary in upSet' interior' boundary' -- tamariOrder1 u v = v `elem` upSet u -- |The Tamari partial order on binary trees. -- This is only defined between trees of the same size (number of nodes). -- The result between trees of different sizes is undefined (we don't check). tamariOrder :: PBT a -> PBT a -> Bool 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 it -- |Convert an element of YSym represented in the monomial basis to the fundamental basis ysymMtoF :: (Eq k, Num k) => Vect k YSymM -> Vect k (YSymF ()) ysymMtoF = linear ysymMtoF' where ysymMtoF' (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 ysymFtoM :: (Eq k, Num k) => Vect k (YSymF ()) -> Vect k YSymM ysymFtoM = linear ysymFtoM' where ysymFtoM' (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 = ysymFtoM . mult . (ysymMtoF `tf` ysymMtoF) instance (Eq k, Num k) => Coalgebra k YSymM where counit = unwrap . linear counit' where counit' (YSymM E) = 1; counit' (YSymM (T _ _ _)) = 0 -- comult = (ysymFtoM `tf` ysymFtoM) . comult . ysymMtoF 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 = ysymFtoM . antipode . ysymMtoF -- QSYM: QUASI-SYMMETRIC FUNCTIONS -- The following is the Hopf algebra QSym of quasi-symmetric functions -- using the monomial and fundamental bases (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 ((x+y):) (quasiShuffles xs ys) ++ map (y:) (quasiShuffles (x: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 (sum xs, xs) (sum 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 xs | all (>0) xs = return (QSymM xs) | otherwise = error "qsymM: not a composition" instance (Eq k, Num k) => Algebra k QSymM where unit x = x *> return (QSymM []) mult = linear mult' where mult' (QSymM alpha, QSymM beta) = sumv [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) = sumv [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 * sumv [return (QSymM beta) | beta <- coarsenings (reverse alpha)] -- antipode' (QSymM alpha) = (-1)^length alpha * sumv [return (QSymM (reverse beta)) | beta <- coarsenings alpha] coarsenings (x1:x2:xs) = map (x1:) (coarsenings (x2:xs)) ++ coarsenings ((x1+x2):xs) coarsenings xs = [xs] -- for xs a singleton or null refinements (x:xs) = [y++ys | y <- compositions x, ys <- refinements xs] refinements [] = [[]] -- |A type for the fundamental basis for the quasi-symmetric functions, indexed by compositions. newtype QSymF = QSymF [Int] deriving (Eq) instance Ord QSymF where compare (QSymF xs) (QSymF ys) = compare (sum xs, xs) (sum 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 xs | all (>0) xs = return (QSymF xs) | otherwise = error "qsymF: not a composition" -- |Convert an element of QSym represented in the monomial basis to the fundamental basis qsymMtoF :: (Eq k, Num k) => Vect k QSymM -> Vect k QSymF qsymMtoF = linear qsymMtoF' where qsymMtoF' (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 qsymFtoM :: (Eq k, Num k) => Vect k QSymF -> Vect k QSymM qsymFtoM = linear qsymFtoM' where qsymFtoM' (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 = qsymMtoF . mult . (qsymFtoM `tf` qsymFtoM) 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 = (qsymMtoF `tf` qsymMtoF) . comult . qsymFtoM instance (Eq k, Num k) => Bialgebra k QSymF where {} instance (Eq k, Num k) => HopfAlgebra k QSymF where antipode = qsymMtoF . antipode . qsymFtoM -- 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] ] -- |@qsymPoly n is@ is the quasi-symmetric polynomial in n variables for the indices is. (This corresponds to the -- monomial basis for QSym.) For example, qsymPoly 3 [2,1] == x1^2*x2+x1^2*x3+x2^2*x3. qsymPoly :: Int -> [Int] -> GlexPoly Q String qsymPoly n is = sum [product (zipWith (^) xs' is) | xs' <- combinationsOf r xs] where xs = [glexvar ("x" ++ show i) | i <- [1..n] ] r = length is -- SYM, THE HOPF ALGEBRA OF SYMMETRIC FUNCTIONS -- |A type for the monomial basis for Sym, the Hopf algebra of symmetric functions, indexed by integer partitions newtype SymM = SymM [Int] deriving (Eq,Show) instance Ord SymM where compare (SymM xs) (SymM ys) = compare (sum xs, ys) (sum ys, xs) -- note the order reversal in snd -- |Construct the element of Sym in the monomial basis indexed by the given integer partition symM :: [Int] -> Vect Q SymM symM xs | all (>0) xs = return (SymM $ sortDesc xs) | otherwise = error "symM: not a partition" instance (Eq k, Num k) => Algebra k SymM where unit x = x *> return (SymM []) mult = linear mult' where mult' (SymM lambda, SymM mu) = sumv [return (SymM nu) | nu <- symMult lambda mu] -- multisetPermutations = toSet . L.permutations -- compositionsFromPartition2 = foldl (\xss ys -> concatMap (shuffles ys) xss) [[]] . L.group -- compositionsFromPartition2 = foldl (\ls r -> concat [shuffles l r | l <- ls]) [[]] . L.group -- The partition must be in either ascending or descending order (so that L.group does as expected) compositionsFromPartition = foldr (\l rs -> concatMap (shuffles l) rs) [[]] . L.group -- In effect, we multiply in Sym by converting to QSym, multiplying there, and converting back. -- It would be nice to find a more direct method. symMult xs ys = filter isWeaklyDecreasing $ concat [quasiShuffles xs' ys' | xs' <- compositionsFromPartition xs, ys' <- compositionsFromPartition ys] instance (Eq k, Num k) => Coalgebra k SymM where counit = unwrap . linear counit' where counit' (SymM lambda) = if null lambda then 1 else 0 comult = linear comult' where comult' (SymM lambda) = sumv [return (SymM mu, SymM nu) | mu <- toSet (powersetdfs lambda), let nu = diffDesc lambda mu] instance (Eq k, Num k) => Bialgebra k SymM where {} instance (Eq k, Num k) => HopfAlgebra k SymM where antipode = linear antipode' where antipode' (SymM []) = return (SymM []) antipode' x = (negatev . mult . (id `tf` antipode) . removeTerm (SymM [],x) . comult . return) x -- |The elementary basis for Sym, the Hopf algebra of symmetric functions. Defined informally as -- > symE [n] = symM (replicate n 1) -- > symE lambda = product [symE [p] | p <- lambda] newtype SymE = SymE [Int] deriving (Eq,Ord,Show) symE :: [Int] -> Vect Q SymE symE xs | all (>0) xs = return (SymE $ sortDesc xs) | otherwise = error "symE: not a partition" instance (Eq k, Num k) => Algebra k SymE where unit x = x *> return (SymE []) mult = linear (\(SymE lambda, SymE mu) -> return $ SymE $ multisetSumDesc lambda mu) instance (Eq k, Num k) => Coalgebra k SymE where counit = unwrap . linear counit' where counit' (SymE lambda) = if null lambda then 1 else 0 comult = linear comult' where comult' (SymE [n]) = sumv [return (e i, e (n-i)) | i <- [0..n] ] comult' (SymE lambda) = product [comult' (SymE [n]) | n <- lambda] e 0 = SymE [] e i = SymE [i] instance (Eq k, Num k) => Bialgebra k SymE where {} -- |Convert from the elementary to the monomial basis of Sym symEtoM :: (Eq k, Num k) => Vect k SymE -> Vect k SymM symEtoM = linear symEtoM' where symEtoM' (SymE [n]) = return (SymM (replicate n 1)) symEtoM' (SymE lambda) = product [symEtoM' (SymE [p]) | p <- lambda] -- |The complete basis for Sym, the Hopf algebra of symmetric functions. Defined informally as -- > symH [n] = sum [symM lambda | lambda <- integerPartitions n] -- == all monomials of weight n -- > symH lambda = product [symH [p] | p <- lambda] newtype SymH = SymH [Int] deriving (Eq,Ord,Show) symH :: [Int] -> Vect Q SymH symH xs | all (>0) xs = return (SymH $ sortDesc xs) | otherwise = error "symH: not a partition" instance (Eq k, Num k) => Algebra k SymH where unit x = x *> return (SymH []) mult = linear (\(SymH lambda, SymH mu) -> return $ SymH $ multisetSumDesc lambda mu) instance (Eq k, Num k) => Coalgebra k SymH where counit = unwrap . linear counit' where counit' (SymH lambda) = if null lambda then 1 else 0 comult = linear comult' where comult' (SymH [n]) = sumv [return (h i, h (n-i)) | i <- [0..n] ] comult' (SymH lambda) = product [comult' (SymH [n]) | n <- lambda] h 0 = SymH [] h i = SymH [i] instance (Eq k, Num k) => Bialgebra k SymH where {} -- |Convert from the complete to the monomial basis of Sym symHtoM :: (Eq k, Num k) => Vect k SymH -> Vect k SymM symHtoM = linear symHtoM' where symHtoM' (SymH [n]) = sumv [return (SymM mu) | mu <- integerPartitions n] symHtoM' (SymH lambda) = product [symHtoM' (SymH [p]) | p <- lambda] -- NSYM, THE HOPF ALGEBRA OF NON-COMMUTATIVE SYMMETRIC FUNCTIONS -- |A basis for NSym, the Hopf algebra of non-commutative symmetric functions, indexed by compositions newtype NSym = NSym [Int] deriving (Eq,Ord,Show) nsym :: [Int] -> Vect Q NSym nsym xs = return (NSym xs) nsym xs | all (>0) xs = return (NSym xs) | otherwise = error "nsym: not a composition" instance (Eq k, Num k) => Algebra k NSym where unit x = x *> return (NSym []) mult = linear mult' where mult' (NSym xs, NSym ys) = return $ NSym $ xs ++ ys instance (Eq k, Num k) => Coalgebra k NSym where counit = unwrap . linear counit' where counit' (NSym zs) = if null zs then 1 else 0 comult = linear comult' where comult' (NSym [n]) = sumv [return (z i, z (n-i)) | i <- [0..n] ] comult' (NSym zs) = product [comult' (NSym [n]) | n <- zs] z 0 = NSym [] z i = NSym [i] instance (Eq k, Num k) => Bialgebra k NSym where {} -- Hazewinkel et al p233 instance (Eq k, Num k) => HopfAlgebra k NSym where antipode = linear antipode' where antipode' (NSym alpha) = sumv [(-1)^length beta *> return (NSym beta) | beta <- refinements (reverse alpha)] -- 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 -- |Given a permutation p of [1..n], we can construct a tree (the descending tree of p) as follows: -- -- * Split the permutation as p = ls ++ [n] ++ rs -- -- * Place n at the root of the tree, and recursively place the descending trees of ls and rs as the left and right children of the root -- -- * To bottom out the recursion, the descending tree of the empty permutation is of course the empty tree -- -- This map between bases SSymF -> YSymF turns out to induce a morphism of Hopf algebras. 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 -- or are they? - these give the min and max inverse images in the lexicographic order, rather than the weak order? 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 = descComp 0 xs where descComp c (x1:x2:xs) = if x1 < x2 then descComp (c+1) (x2:xs) else (c+1) : descComp 0 (x2:xs) descComp c [x] = [c+1] -- |Given a permutation of [1..n], its descents are those positions where the next number is less than the previous number. -- For example, the permutation [2,3,5,1,6,4] has descents from 5 to 1 and from 6 to 4. The descents can be regarded as cutting -- the permutation sequence into segments - 235-16-4 - and by counting the lengths of the segments, we get a composition 3+2+1. -- This map between bases SSymF -> QSymF turns out to induce a morphism of Hopf algebras. 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 -} -- |The injection of Sym into QSym (defined over the monomial basis) symToQSymM :: (Eq k, Num k) => Vect k SymM -> Vect k QSymM symToQSymM = linear symToQSymM' where symToQSymM' (SymM ps) = sumv [return (QSymM c) | c <- compositionsFromPartition ps] -- We could equally well send NSym -> SymE, since the algebra and coalgebra definitions for SymE and SymH are exactly analogous. -- However, NSym -> SymH is more natural, since it is consistent with the duality pairings below. -- eg Hazewinkel 238ff -- (Why do SymE and SymH have the same definitions? They're not dual bases. It's because of the Wronski relations.) -- |A surjection of NSym onto Sym (defined over the complete basis) nsymToSymH :: (Eq k, Num k) => Vect k NSym -> Vect k SymH nsymToSymH = linear nsymToSym' where nsymToSym' (NSym zs) = return (SymH $ sortDesc zs) -- The Hopf algebra morphism NSym -> Sym factors through NSym -> SSym -> YSym -> Sym (contained in QSym) -- (?? This map NSym -> SSym is the dual of the descent map SSym -> QSym ??) -- (Loday.pdf, p30) -- (See also Hazewinkel p267-9) nsymToSSym = linear nsymToSSym' where nsymToSSym' (NSym xs) = product [return (SSymF [1..n]) | n <- xs] -- |A duality pairing between the complete and monomial bases of Sym, showing that Sym is self-dual. instance (Eq k, Num k) => HasPairing k SymH SymM where pairing = linear pairing' where pairing' (SymH alpha, SymM beta) = delta alpha beta -- Kronecker delta -- Hazewinkel p178 -- Actually to show duality you would need to show that the map SymH -> SymM*, v -> is onto -- |A duality pairing between NSym and QSymM (monomial basis), showing that NSym and QSym are dual. instance (Eq k, Num k) => HasPairing k NSym QSymM where pairing = linear pairing' where pairing' (NSym alpha, QSymM beta) = delta alpha beta -- Kronecker delta -- Hazewinkel p236-7 -- Actually to show duality you would need to show that the map NSym -> QSymM*, v -> is onto HaskellForMaths-0.4.8/Math/Combinatorics/Design.hs0000644000000000000000000004106112514742102020172 0ustar0000000000000000-- Copyright (c) 2008, David Amos. All rights reserved. -- |A module for constructing and working with combinatorial designs. -- -- Given integers t \< k \< v and lambda > 0, a t-design or t-(v,k,lambda) design is an incidence structure of points X and blocks B, -- where X is a set of v points, B is a collection of k-subsets of X, with the property that any t points are contained -- in exactly lambda blocks. If lambda = 1 and t >= 2, then a t-design is also called a Steiner system S(t,k,v). -- -- Many designs are highly symmetric structures, having large automorphism groups. In particular, the Mathieu groups, -- which were the first discovered sporadic finite simple groups, turn up as the automorphism groups of the Witt designs. module Math.Combinatorics.Design where import Data.Maybe (fromJust, isJust) import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S import Math.Common.ListSet (intersect, symDiff) import Math.Core.Utils (combinationsOf) import Math.Algebra.Field.Base import Math.Algebra.Field.Extension 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 (graphAuts, incidenceAuts) -- , removeGens) import Math.Combinatorics.FiniteGeometry -- Cameron & van Lint, Designs, Graphs, Codes and their Links {- set xs = map head $ group $ sort xs -} isSubset xs ys = all (`elem` ys) xs -- DESIGNS data Design a = D [a] [[a]] deriving (Eq,Ord,Show) -- Do we or should we insist on ordering of the xs or bs? design (xs,bs) | isValid d = d where d = D xs bs toDesign (xs,bs) = D xs' bs' where xs' = L.sort xs bs' = L.sort $ map L.sort bs -- in fact don't require that the blocks are in order isValid (D xs bs) = (xs == L.sort xs || error "design: points are not in order") && (all (\b -> b == L.sort b) bs || error "design: blocks do not have points in order") -- could also check that each block is a subset of xs, etc points (D xs bs) = xs blocks (D xs bs) = bs -- FINDING DESIGN PARAMETERS noRepeatedBlocks (D xs bs) = all ( (==1) . length ) $ L.group $ L.sort bs -- Note that the design parameters functions don't check no repeated blocks, so they're also valid for t-structures -- given t and a t-(v,k,lambda) design, return (v,k,lambda) tDesignParams t d = case findvk d of Nothing -> Nothing Just (v,k) -> case findlambda t d of Nothing -> Nothing Just lambda -> Just (v,k,lambda) findvk (D xs bs) = let k:ls = map length bs in if all (==k) ls then Just (v,k) else Nothing where v = length xs findlambda t (D xs bs) = let lambda:ls = [length [b | b <- bs, ts `isSubset` b] | ts <- combinationsOf t xs] in if all (==lambda) ls then Just lambda else Nothing -- given (xs,bs), return design parameters t-(v,k,lambda) with t maximal designParams d = case findvk d of Nothing -> Nothing Just (v,k) -> case reverse (takeWhile (isJust . snd) [(t, findlambda t d) | t <- [0..k] ]) of [] -> Nothing (t,Just lambda):_ -> Just (t,(v,k,lambda)) -- Note that a 0-(v,k,lambda) design just means that there are lambda blocks, all of size k, with no other regularity isStructure t d = isJust $ tDesignParams t d isDesign t d = noRepeatedBlocks d && isStructure t d is2Design d = isDesign 2 d -- square 2-design (more often called "symmetric" in the literature) isSquare d@(D xs bs) = is2Design d && length xs == length bs -- (We follow Cameron & van Lint.) -- |The incidence matrix of a design, with rows indexed by blocks and columns by points. -- (Note that in the literature, the opposite convention is sometimes used instead.) incidenceMatrix :: (Eq t) => Design t -> [[Int]] incidenceMatrix (D xs bs) = [ [if x `elem` b then 1 else 0 | x <- xs] | b <- bs] -- SOME FAMILIES OF DESIGNS -- the following is trivially a k-(v,k,lambda) design subsetDesign v k = design (xs,bs) where xs = [1..v] bs = combinationsOf k xs -- Cameron & van Lint, p30 -- the pair design on n points is the complete graph on n points considered as a 2-(n,2,1) design pairDesign n = D vs es where graph = G.k n vs = vertices graph es = edges graph -- |The affine plane AG(2,Fq), a 2-(q^2,q,1) design or Steiner system S(2,q,q^2). ag2 :: (FiniteField k, Ord k) => [k] -> Design [k] ag2 fq = design (points, lines) where points = ptsAG 2 fq lines = map line $ tail $ ptsPG 2 fq line [a,b,c] = [ [x,y] | [x,y] <- points, a*x+b*y+c==0 ] -- |The projective plane PG(2,Fq), a square 2-(q^2+q+1,q+1,1) design or Steiner system S(2,q+1,q^2+q+1). -- For example, @pg2 f2@ is the Fano plane, a Steiner triple system S(2,3,7). pg2 :: (FiniteField k, Ord k) => [k] -> Design [k] pg2 fq = design (points, lines) where points = ptsPG 2 fq lines = L.sort $ map line points line u = [v | v <- points, u <.> v == 0] u <.> v = sum (zipWith (*) u v) -- Remember that the points and lines of PG(2,Fp) are really the lines and planes of AG(3,Fp). -- A line in AG(3,Fp) defines a plane orthogonal to it. -- The points and i-flats of PG(n,fq), 1<=i<=n-1, form a 2-design -- For i==1, this is a 2-((q^(n+1)-1)/(q-1),q+1,1) design -- For i==n-1, this is a 2-((q^(n+1)-1)/(q-1),(q^n-1)/(q-1),(q^(n-1)-1)/(q-1)) design -- Cameron & van Lint, p8 flatsDesignPG n fq k = design (points, blocks) where points = ptsPG n fq blocks = map closurePG $ flatsPG n fq k -- the closurePG replaces the generators of the flat by the list of points of the flat -- The projective point-hyperplane design is also denoted PG(n,q) pg n fq = flatsDesignPG n fq (n-1) -- (Cameron & van Lint don't actually state that this is a design except when k == n-1) flatsDesignAG n fq k = design (points, blocks) where points = ptsAG n fq blocks = map closureAG $ flatsAG n fq k -- the closureAG replaces the generators of the flat by the list of points of the flat -- The affine point-hyperplane design is also denoted AG(n,q) -- It a 2-(q^n,q^(n-1),(q^(n-1)-1)/(q-1)) design -- Cameron & van Lint, p17 ag n fq = flatsDesignAG n fq (n-1) -- convert a design to be defined over the set [1..n] to1n (D xs bs) = (D xs' bs') where mapping = M.fromList $ zip xs [1..] -- the mapping from vs to [1..n] xs' = M.elems mapping bs' = [map (mapping M.!) b | b <- bs] -- the blocks will already be sorted correctly by construction -- Cameron & van Lint p10 paleyDesign fq | length fq `mod` 4 == 3 = design (xs,bs) where xs = fq qs = set [x^2 | x <- xs] L.\\ [0] -- the non-zero squares in Fq bs = [L.sort (map (x+) qs) | x <- xs] fanoPlane = paleyDesign f7 -- isomorphic to PG(2,F2) -- NEW DESIGNS FROM OLD -- Dual of a design. Cameron & van Lint p11 -- |The dual of a design dual :: (Ord t) => Design t -> Design [t] dual (D xs bs) = design (bs, map beta xs) where beta x = filter (x `elem`) bs -- Derived design relative to a point. Cameron & van Lint p11 -- Derived design of a t-(v,k,lambda) is a t-1-(v-1,k-1,lambda) design. derivedDesign :: (Ord t) => Design t -> t -> Design t derivedDesign (D xs bs) p = design (xs L.\\ [p], [b L.\\ [p] | b <- bs, p `elem` b]) -- Residual design relative to a point. Cameron & van Lint p13 -- Point-residual of a t-(v,k,lambda) is a t-1-(v-1,k,mu). pointResidual :: (Ord t) => Design t -> t -> Design t pointResidual (D xs bs) p = design (xs L.\\ [p], [b | b <- bs, p `notElem` b]) -- Complementary design. Cameron & van Lint p13 -- Complement of a t-(v,k,lambda) is a t-(v,v-k,mu). complementaryDesign (D xs bs) = design (xs, [xs L.\\ b | b <- bs]) -- Residual design relative to a block. Cameron & van Lint p13 -- This is only a design if (xs,bs) is a square design -- It may have repeated blocks - but if so, residuals of the complement will not -- Block-residual of a 2-(v,k,lambda) is a 2-(v-k,k-lambda,lambda). blockResidual :: (Ord t) => Design t -> [t] -> Design t blockResidual d@(D xs bs) b | isSquare d = design (xs L.\\ b, [b' L.\\ b | b' <- bs, b' /= b]) -- DESIGN AUTOMORPHISMS isDesignAut (D xs bs) g | supp g `isSubset` xs = all (`S.member` bs') [b -^ g | b <- bs] where bs' = S.fromList bs -- |The incidence graph of a design incidenceGraph :: (Ord a) => Design a -> Graph (Either a [a]) incidenceGraph (D xs bs) = G vs es where -- graph (vs,es) where vs = L.sort $ map Left xs ++ map Right bs es = L.sort [ [Left x, Right b] | x <- xs, b <- bs, x `elem` b ] -- |Find a strong generating set for the automorphism group of a design designAuts :: (Ord t) => Design t -> [Permutation t] designAuts d = incidenceAuts $ incidenceGraph d -- We find design auts by finding graph auts of the incidence graph of the design -- In a square design, we need to watch out for graph auts which are mapping points <-> blocks designAuts1 d = filter (/=1) $ map points $ graphAuts $ incidenceGraph d where points h = fromPairs [(x,y) | (Left x, Left y) <- toPairs h] -- This implicitly filters out (Right x, Right y) action on blocks, -- and also (Left x, Right y) auts taking points to blocks. -- The filter (/=1) is to remove points <-> blocks auts -- The incidence graph is a bipartite graph, so the distance function naturally partitions points from blocks -- MATHIEU GROUPS AND WITT DESIGNS alphaL2_23 = p [[-1],[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22]] -- t -> t+1 betaL2_23 = p [[-1],[0],[1,2,4,8,16,9,18,13,3,6,12],[5,10,20,17,11,22,21,19,15,7,14]] -- t -> 2*t gammaL2_23 = p [[-1,0],[1,22],[2,11],[3,15],[4,17],[5,9],[6,19],[7,13],[8,20],[10,16],[12,21],[14,18]] -- t -> -1/t l2_23 = [alphaL2_23, betaL2_23, gammaL2_23] -- Mathieu group M24 -- Conway and Sloane p274ff -- This is the automorphism group of the extended binary Golay code G24 -- or alternatively of the unique Steiner system S(5,8,24) (which consists of the weight 8 codewords of the above) deltaM24 = p [[-1],[0],[1,18,4,2,6],[3],[5,21,20,10,7],[8,16,13,9,12],[11,19,22,14,17],[15]] -- this is t -> t^3 / 9 (for t a quadratic residue), t -> 9 t^3 (t a non-residue) -- |Generators for the Mathieu group M24, a finite simple group of order 244823040 m24 :: [Permutation Integer] m24 = [alphaL2_23, betaL2_23, gammaL2_23, deltaM24] -- |A strong generating set for the Mathieu group M24, a finite simple group of order 244823040 m24sgs :: [Permutation Integer] m24sgs = sgs m24 -- |A strong generating set for the Mathieu group M23, a finite simple group of order 10200960 m23sgs :: [Permutation Integer] m23sgs = filter (\g -> (-1).^g == -1) m24sgs -- |A strong generating set for the Mathieu group M22, a finite simple group of order 443520 m22sgs :: [Permutation Integer] m22sgs = filter (\g -> 0.^g == 0) m23sgs -- sgs uses the base implied by the Ord instance, which will be [-1,0,..] -- Steiner system S(5,8,24) octad = [0,1,2,3,4,7,10,12] -- Conway&Sloane p276 - this is a weight 8 codeword from Golay code G24 -- |The Steiner system S(5,8,24), with 759 blocks, whose automorphism group is M24 s_5_8_24 :: Design Integer s_5_8_24 = design ([-1..22], octad -^^ l2_23) -- S(5,8,24) constructed as the image of a single octad under the action of PSL(2,23) -- 759 blocks ( (24 `choose` 5) `div` (8 `choose` 5) ) -- Automorphism group is M24 -- |The Steiner system S(4,7,23), with 253 blocks, whose automorphism group is M23 s_4_7_23 :: Design Integer s_4_7_23 = derivedDesign s_5_8_24 (-1) -- 253 blocks ( (23 `choose` 4) `div` (7 `choose` 4) ) -- Automorphism group is M23 -- |The Steiner system S(3,6,22), with 77 blocks, whose automorphism group is M22 s_3_6_22 :: Design Integer s_3_6_22 = derivedDesign s_4_7_23 0 -- 77 blocks -- Automorphism group is M22 -- Derived design of s_3_6_22 is PG(2,F4) -- An alternative construction s_5_8_24' = D xs bs where xs = [1..24] bs = sift [] (combinationsOf 8 xs) sift ls (r:rs) = if all ((<=4) . length) [r `intersect` l | l <- ls] then r : sift (r:ls) rs else sift ls rs sift ls [] = [] -- Could test that m22sgs are all designAuts of s_3_6_22 -- S(5,6,12) and M12 alphaL2_11 = p [[-1],[0,1,2,3,4,5,6,7,8,9,10]] -- t -> t+1 betaL2_11 = p [[-1],[0],[1,3,9,5,4],[2,6,7,10,8]] -- t -> 3*t gammaL2_11 = p [[-1,0],[1,10],[2,5],[3,7],[4,8],[6,9]] -- t -> -1/t l2_11 = [alphaL2_11, betaL2_11, gammaL2_11] deltaM12 = p [[-1],[0],[1],[2,10],[3,4],[5,9],[6,7],[8]] -- Conway&Sloane p271, 327 hexad = [0,1,3,4,5,9] -- the squares (quadratic residues) in F11 -- http://en.wikipedia.org/wiki/Steiner_system -- |The Steiner system S(5,6,12), with 132 blocks, whose automorphism group is M12 s_5_6_12 :: Design Integer s_5_6_12 = design ([-1..10], hexad -^^ l2_11) -- S(5,6,12) constructed as the image of a single hexad under the action of PSL(2,11) -- 132 blocks ( (12 `choose` 5) `div` (6 `choose` 5) ) -- Automorphism group is M12 -- |The Steiner system S(4,5,11), with 66 blocks, whose automorphism group is M11 s_4_5_11 :: Design Integer s_4_5_11 = derivedDesign s_5_6_12 (-1) -- 66 blocks -- Automorphism group is M11 -- |Generators for the Mathieu group M12, a finite simple group of order 95040 m12 :: [Permutation Integer] m12 = [alphaL2_11, betaL2_11, gammaL2_11, deltaM12] -- |A strong generating set for the Mathieu group M12, a finite simple group of order 95040 m12sgs :: [Permutation Integer] m12sgs = sgs m12 -- order 95040 -- |A strong generating set for the Mathieu group M11, a finite simple group of order 7920 m11sgs :: [Permutation Integer] m11sgs = filter (\g -> (-1).^g == -1) m12sgs -- order 7920 {- -- WITT DESIGNS -- S(5,8,24) AND S(5,6,12) -- Let D be a square 2-design. -- An n-arc is a set of n points of D, no three of which are contained in a block arcs n (D xs bs) = map reverse $ dfs n [] xs where dfs 0 ys _ = [ys] dfs i ys xs = concat [dfs (i-1) (x:ys) (dropWhile (<=x) xs) | x <- xs, isCompatible (x:ys)] isCompatible ys = all ((<=2) . length) [ys `L.intersect` b | b <- bs] tangents (D xs bs) arc = [b | b <- bs, length (arc `L.intersect` b) == 1] -- !! NOT QUITE AS EXPECTED -- Cameron van Lint implies that ovals should have n = 1+(k-1)/lambda, whereas I'm finding that they're one bigger than that -- eg length $ ovals $ ag2 f3 should be 54 -- But ag2 f3 isn't a *square* design ovals d = let Just (_,k,lambda) = tDesignParams 2 d (q,r) = (k-1) `quotRem` lambda n = 2+q -- == 1+(k-1)/lambda in if r == 0 then [arc | arc <- arcs n d, arc == L.sort (concat $ map (L.intersect arc) $ tangents d arc)] -- each point has a unique tangent else [] hyperovals d = let Just (_,k,lambda) = tDesignParams 2 d (q,r) = k `quotRem` lambda n = 1+q -- == 1+k/lambda in if r == 0 then filter (null . tangents d) $ arcs n d else [] -- Cameron & van Lint, p22 -- s_5_8_24 = [length (intersect (head h) (head s)) | h <- [h1,h2,h3], s <- [s1,s2,s3]] where s_5_8_24 = design (points,lines) where points = map Left xs ++ map Right [1,2,3] lines = [map Left b ++ map Right [1,2,3] | b <- bs] ++ -- line plus three points at infinity [map Left h ++ map Right [2,3] | h <- h1] ++ -- hyperoval plus two points at infinity [map Left h ++ map Right [1,3] | h <- h2] ++ [map Left h ++ map Right [1,2] | h <- h3] ++ [map Left s ++ map Right [1] | s <- s1] ++ -- Baer subplanes plus one point at infinity [map Left s ++ map Right [2] | s <- s2] ++ [map Left s ++ map Right [3] | s <- s3] ++ [map Left (l1 `symDiff` l2) | l1 <- bs, l2 <- bs, l1 < l2] d@(D xs bs) = pg2 f4 hs = hyperovals d [h1,h2,h3] = evenClasses hs [s2,s1,s3] = oddClasses baerSubplanes -- we have to number the ss so that if h <- hi, s <- sj, then |h intersect s| is even <=> i == j evenClasses (h:hs) = let (ys,ns) = partition (even . length . L.intersect h) hs in (h:ys) : evenClasses ns evenClasses [] = [] oddClasses (h:hs) = let (ys,ns) = partition (odd . length . L.intersect h) hs in (h:ys) : oddClasses ns oddClasses [] = [] baerSubplanes = [s | s <- baerSubplanes', and [length (L.intersect s b) `elem` [1,3] | b <- bs] ] baerSubplanes' = map reverse $ dfs 7 [] xs where dfs 0 ys _ = [ys] dfs i ys xs = concat [dfs (i-1) (x:ys) (dropWhile (<=x) xs) | x <- xs, isCompatible (x:ys)] isCompatible ys = all ((<=3) . length) [ys `L.intersect` b | b <- bs] -}HaskellForMaths-0.4.8/Math/Combinatorics/Digraph.hs0000644000000000000000000003562512514742102020350 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction #-} -- |A module for working with directed graphs (digraphs). -- Some of the functions are specifically for working with directed acyclic graphs (DAGs), -- that is, directed graphs containing no cycles. module Math.Combinatorics.Digraph where import Data.List as L import qualified Data.Map as M import qualified Data.Set as S import Math.Core.Utils (picks, toSet) -- |A digraph is represented as DG vs es, where vs is the list of vertices, and es is the list of edges. -- Edges are directed: an edge (u,v) means an edge from u to v. -- A digraph is considered to be in normal form if both es and vs are in ascending order. -- This is the preferred form, and some functions will only work for digraphs in normal form. data Digraph v = DG [v] [(v,v)] deriving (Eq,Ord,Show) instance Functor Digraph where -- |If f is not order-preserving, then you should call nf afterwards fmap f (DG vs es) = DG (map f vs) (map (\(u,v)->(f u, f v)) es) nf (DG vs es) = DG (L.sort vs) (L.sort es) vertices (DG vs _) = vs edges (DG _ es) = es -- Is it valid to call them predecessors / successors in the case when the digraph contains cycles? predecessors (DG _ es) v = [u | (u,v') <- es, v' == v] successors (DG _ es) u = [v | (u',v) <- es, u' == u] -- Calculate maps of predecessor and successor lists for each vertex in a digraph. -- If a vertex has no predecessors (respectively successors), then it is left out of the relevant map adjLists (DG vs es) = adjLists' (M.empty, M.empty) es where adjLists' (preds,succs) ((u,v):es) = adjLists' (M.insertWith' (flip (++)) v [u] preds, M.insertWith' (flip (++)) u [v] succs) es adjLists' (preds,succs) [] = (preds, succs) digraphIsos1 (DG vsa esa) (DG vsb esb) | length vsa /= length vsb = [] | length esa /= length esb = [] | otherwise = digraphIsos' [] vsa vsb where digraphIsos' xys [] [] = [xys] digraphIsos' xys (x:xs) ys = concat [ digraphIsos' ((x,y):xys) xs ys' | (y,ys') <- picks ys, isCompatible (x,y) xys] isCompatible (x,y) xys = and [ ((x,x') `elem` esa) == ((y,y') `elem` esb) && ((x',x) `elem` esa) == ((y',y) `elem` esb) | (x',y') <- xys ] digraphIsos2 a b | length (vertices a) /= length (vertices b) = [] | L.sort (M.elems indega) /= L.sort (M.elems indegb) = [] | L.sort (M.elems outdega) /= L.sort (M.elems outdegb) = [] | otherwise = dfs [] (vertices a) (vertices b) where (preda,succa) = adjLists a (predb,succb) = adjLists b indega = M.map length preda indegb = M.map length predb outdega = M.map length succa outdegb = M.map length succb isCompatible (x,y) xys = (M.findWithDefault 0 x indega) == (M.findWithDefault 0 y indegb) && (M.findWithDefault 0 x outdega) == (M.findWithDefault 0 y outdegb) && and [ (x' `elem` predx) == (y' `elem` predy) && (x' `elem` succx) == (y' `elem` succy) | let predx = M.findWithDefault [] x preda, let predy = M.findWithDefault [] y predb, let succx = M.findWithDefault [] x succa, let succy = M.findWithDefault [] y succb, (x',y') <- xys] dfs xys [] [] = [xys] dfs xys (x:xs) ys = concat [ dfs ((x,y):xys) xs ys' | (y,ys') <- picks ys, isCompatible (x,y) xys] -- For DAGs, can almost certainly do better than the above by using the height partition -- However see remarks in Poset on orderIsos: -- What is most efficient will depend on whether you want to list all of them, or just find out whether there are any or not -- Could also try refining the height partition by (indegree,outdegree) -- doesn't check whether input is a dag -- if not, then the output will not contain all the vs heightPartitionDAG dag@(DG vs es) = heightPartition' S.empty [v | v <- vs, v `M.notMember` preds] -- ie vertices with no predecessors where (preds,succs) = adjLists dag heightPartition' interior boundary | null boundary = [] | otherwise = let interior' = S.union interior $ S.fromList boundary boundary' = toSet [v | u <- boundary, v <- M.findWithDefault [] u succs, all (`S.member` interior') (preds M.! v) ] in boundary : heightPartition' interior' boundary' isDAG dag@(DG vs _) = length vs == length (concat (heightPartitionDAG dag)) -- Only valid for DAGs, not for digraphs in general dagIsos dagA@(DG vsA esA) dagB@(DG vsB esB) | length vsA /= length (concat heightPartA) = error "dagIsos: dagA is not a DAG" | length vsB /= length (concat heightPartB) = error "dagIsos: dagB is not a DAG" | map length heightPartA /= map length heightPartB = [] | otherwise = dfs [] heightPartA heightPartB where heightPartA = heightPartitionDAG dagA heightPartB = heightPartitionDAG dagB (predsA,_) = adjLists dagA (predsB,_) = adjLists dagB dfs xys [] [] = [xys] dfs xys ([]:las) ([]:lbs) = dfs xys las lbs dfs xys ((x:xs):las) (ys:lbs) = concat [ dfs ((x,y):xys) (xs:las) (ys' : lbs) | (y,ys') <- picks ys, isCompatible (x,y) xys] isCompatible (x,y) xys = let preds_x = M.findWithDefault [] x predsA preds_y = M.findWithDefault [] y predsB in and [ (x' `elem` preds_x) == (y' `elem` preds_y) | (x',y') <- xys] -- and [ ((x',x) `elem` esA) == ((y',y) `elem` esB) -- | (x',y') <- xys ] -- we only need to check predecessors, not successors, because we proceeding by height ordering -- can probably do better by intersecting the height partition with the (indegree,outdegree) partition -- (although on very symmetrical posets such as B n, this won't help at all) -- |Are the two DAGs isomorphic? isDagIso :: (Ord a, Ord b) => Digraph a -> Digraph b -> Bool isDagIso dagA dagB = (not . null) (dagIsos dagA dagB) perms [] = [[]] perms (x:xs) = [ls ++ [x] ++ rs | ps <- perms xs, (ls,rs) <- zip (inits ps) (tails ps)] -- or use L.permutations {- -- orderings compatible with the height partition heightOrderingsDAG dag@(DG vs es) = heightOrderings' [[]] (heightPartitionDAG dag) where heightOrderings' initsegs (level:levels) = let addsegs = perms level initsegs' = [init ++ add | init <- initsegs, add <- addsegs] in heightOrderings' initsegs' levels heightOrderings' segs [] = segs -} isoRepDAG1 dag@(DG vs es) = isoRepDAG' [M.empty] 1 (heightPartitionDAG dag) where isoRepDAG' initmaps j (level:levels) = let j' = j + length level addmaps = [M.fromList (zip ps [j..]) | ps <- perms level] initmaps' = [init +++ add | init <- initmaps, add <- addmaps] in isoRepDAG' initmaps' j' levels isoRepDAG' maps _ [] = DG [1..length vs] (minimum [L.sort (map (\(u,v) -> (m M.! u, m M.! v)) es) | m <- maps]) initmap +++ addmap = M.union initmap addmap -- For example -- > isoRepDAG1 (DG ['a'..'e'] [('a','c'),('a','d'),('b','d'),('b','e'),('d','e')]) -- ([1,2,3,4,5],[(1,3),(1,4),(2,3),(2,5),(3,5)]) -- > isoRepDAG1 (DG ['a'..'e'] [('a','d'),('a','e'),('b','c'),('b','d'),('d','e')]) -- ([1,2,3,4,5],[(1,3),(1,4),(2,3),(2,5),(3,5)]) -- Find the minimum height-preserving numberings of the vertices, using dfs isoRepDAG2 dag@(DG vs es) = minimum $ dfs [] srclevels trglevels where -- (preds,succs) = adjLists dag srclevels = heightPartitionDAG dag trglevels = reverse $ fst $ foldl (\(tls,is) sl -> let (js,ks) = splitAt (length sl) is in (js:tls,ks)) ([],[1..]) srclevels dfs xys [] [] = [xys] dfs xys ([]:sls) ([]:tls) = dfs xys sls tls dfs xys ((x:xs):sls) (ys:tls) = concat [ dfs ((x,y):xys) (xs:sls) (ys' : tls) | (y,ys') <- picks ys] -- not applying any compatibility condition yet -- Find the height-respecting numbering of the vertices which leads to the minimal numbering of the edges -- So this is calculating the same function as isoRepDAG1, but more efficiently -- Uses dfs with pruning, rather than exhaustive search isoRepDAG3 dag@(DG vs es) = dfs root [root] where n = length vs root = ([],(1,0),M.empty,(srclevels,trglevels)) -- root of the search tree (preds,succs) = adjLists dag srclevels = heightPartitionDAG dag trglevels = reverse $ fst $ foldl (\(tls,is) sl -> let (js,ks) = splitAt (length sl) is in (js:tls,ks)) ([],[1..]) srclevels dfs best (node:stack) = -- node : -- for debugging case cmpPartial best node of LT -> dfs best stack -- ie prune the search tree at this node GT -> dfs node (successors node ++ stack) -- ie replace best with this node EQ -> dfs best (successors node ++ stack) -- dfs best [] = [best] -- !! for debugging dfs best@(es',_,_,_) [] = DG [1..n] es' successors (es,_,_,([],[])) = [] successors (es,(i,j),m,([]:sls,[]:tls)) = successors (es,(i,j),m,(sls,tls)) successors (es,(i,j),m,(xs:sls,(y:ys):tls)) = [ (es', (i',y), m', (L.delete x xs : sls, ys : tls)) | x <- xs, let m' = M.insert x y m, let es' = L.sort $ es ++ [(m M.! u, y) | u <- M.findWithDefault [] x preds], let i' = nextunfinished m' i ] -- a vertex is considered finished when all its successors have assignments in the map nextunfinished m i = case [v | (v,i') <- M.assocs m, i' == i] of [] -> i [u] -> if all (`M.member` m) (M.findWithDefault [] u succs) then nextunfinished m (i+1) -- i is finished: all successors already have assignments in the map else i cmpPartial (es,_,_,_) (es',(i',j'),_,_) = cmpPartial' (i',j') es es' -- where j' = maximum $ 0 : map snd es' cmpPartial' (i',j') ((u,v):es) ((u',v'):es') = -- Any new e' that can be added to es' must be greater than (i',j') -- (we don't care about possible extensions of es, because we're not extending them) case compare (u,v) (u',v') of EQ -> cmpPartial' (i',j') es es' LT -> if (u,v) <= (i',j') then LT else EQ GT -> GT -- always replace best if you beat it -- (even if it could improve, it's not going to as we're not progressing it) cmpPartial' (i',j') ((u,v):es) [] = if (u,v) <= (i',j') then LT else EQ cmpPartial' _ [] ((u',v'):es') = GT -- always extend an existing partial best cmpPartial' _ [] [] = EQ -- Now we seek a numbering of the vertices which respects height-ordering, -- and within each height level respects (indegree,outdegree) ordering. -- We seek the numbering which minimises the resulting edge list. -- |Given a directed acyclic graph (DAG), return a canonical representative for its isomorphism class. -- @isoRepDAG dag@ is isomorphic to @dag@. It follows that if @isoRepDAG dagA == isoRepDAG dagB@ then @dagA@ is isomorphic to @dagB@. -- Conversely, @isoRepDAG dag@ is the minimal element in the isomorphism class, subject to some constraints. -- It follows that if @dagA@ is isomorphic to @dagB@, then @isoRepDAG dagA == isoRepDAG dagB@. -- -- The algorithm of course is faster on some DAGs than others: roughly speaking, -- it prefers \"tall\" DAGs (long chains) to \"wide\" DAGs (long antichains), -- and it prefers asymmetric DAGs (ie those with smaller automorphism groups). isoRepDAG :: (Ord a) => Digraph a -> Digraph Int isoRepDAG dag@(DG vs es) = dfs root [root] where n = length vs root = ([],(1,0),M.empty,(srclevels,trglevels)) -- root of the search tree (preds,succs) = adjLists dag indegs = M.map length preds outdegs = M.map length succs byDegree vs = (map . map) snd $ L.groupBy (\(du,u) (dv,v) -> du == dv) $ L.sort [( (M.findWithDefault 0 v indegs, M.findWithDefault 0 v outdegs), v) | v <- vs] srclevels = concatMap byDegree $ heightPartitionDAG dag trglevels = reverse $ fst $ foldl (\(tls,is) sl -> let (js,ks) = splitAt (length sl) is in (js:tls,ks)) ([],[1..]) srclevels dfs best (node:stack) = -- node : -- for debugging case cmpPartial best node of LT -> dfs best stack -- ie prune the search tree at this node GT -> dfs node (successors node ++ stack) -- ie replace best with this node EQ -> dfs best (successors node ++ stack) -- dfs best [] = [best] -- !! for debugging dfs best@(es',_,_,_) [] = DG [1..n] es' successors (es,_,_,([],[])) = [] successors (es,(i,j),m,([]:sls,[]:tls)) = successors (es,(i,j),m,(sls,tls)) successors (es,(i,j),m,(xs:sls,(y:ys):tls)) = [ (es', (i',y), m', (L.delete x xs : sls, ys : tls)) | x <- xs, let m' = M.insert x y m, let es' = L.sort $ es ++ [(m M.! u, y) | u <- M.findWithDefault [] x preds], let i' = nextunfinished m' i ] -- a vertex is considered finished when all its successors have assignments in the map nextunfinished m i = case [v | (v,i') <- M.assocs m, i' == i] of [] -> i [u] -> if all (`M.member` m) (M.findWithDefault [] u succs) then nextunfinished m (i+1) -- i is finished: all successors already have assignments in the map else i cmpPartial (es,_,_,_) (es',(i',j'),_,_) = cmpPartial' (i',j') es es' -- where j' = maximum $ 0 : map snd es' cmpPartial' (i',j') ((u,v):es) ((u',v'):es') = -- Any new e' that can be added to es' must be greater than (i',j') -- (we don't care about possible extensions of es, because we're not extending them) case compare (u,v) (u',v') of EQ -> cmpPartial' (i',j') es es' LT -> if (u,v) <= (i',j') then LT else EQ GT -> GT -- always replace best if you beat it -- (even if it could improve, it's not going to as we're not progressing it) cmpPartial' (i',j') ((u,v):es) [] = if (u,v) <= (i',j') then LT else EQ cmpPartial' _ [] ((u',v'):es') = GT -- always extend an existing partial best cmpPartial' _ [] [] = EQ HaskellForMaths-0.4.8/Math/Combinatorics/FiniteGeometry.hs0000644000000000000000000002255612514742102021723 0ustar0000000000000000-- Copyright (c) David Amos, 2008-2015. All rights reserved. -- |Constructions of the finite geometries AG(n,Fq) and PG(n,Fq), their points, lines and flats, -- together with the incidence graphs between points and lines. module Math.Combinatorics.FiniteGeometry where import Prelude hiding ( (*>) ) import Data.List as L import qualified Data.Set as S import Math.Common.ListSet (toListSet) import Math.Core.Utils import Math.Core.Field import Math.Algebra.LinearAlgebra -- hiding ( det ) import Math.Combinatorics.Graph import Math.Combinatorics.GraphAuts -- for use in GHCi import Math.Algebra.Group.PermutationGroup hiding (elts) -- for use in GHCi import Math.Algebra.Group.SchreierSims as SS hiding (elts) -- for use in GHCi -- !! The following two functions previously required (FiniteField a) as context -- but this has been temporarily removed to enable them to work with Math.Core.Field -- |ptsAG n fq returns the points of the affine geometry AG(n,Fq), where fq are the elements of Fq ptsAG :: Int -> [a] -> [[a]] ptsAG 0 fq = [[]] ptsAG n fq = [x:xs | x <- fq, xs <- ptsAG (n-1) fq] -- |ptsPG n fq returns the points of the projective geometry PG(n,Fq), where fq are the elements of Fq ptsPG :: Num a => Int -> [a] -> [[a]] ptsPG 0 _ = [[1]] ptsPG n fq = map (0:) (ptsPG (n-1) fq) ++ map (1:) (ptsAG n fq) -- "projective normal form" pnf (0:xs) = 0 : pnf xs pnf (1:xs) = 1 : xs pnf (x:xs) = 1 : map (* x') xs where x' = recip x ispnf (0:xs) = ispnf xs ispnf (1:xs) = True ispnf _ = False -- closure of points in AG(n,Fq) -- given p1, .., pk, we're looking for all a1 p1 + ... + ak pk, s.t. a1 + ... + ak = 1 -- if m is the matrix with p1, .., pk as rows, and vs are the vectors [a1, .., ak] -- then this is the same as [v <*>> m | v <- vs] == [m' <<*> v | v <- vs] -- |Given a list of points in AG(n,Fq), return their closure, the smallest flat containing them closureAG :: (Num a, Ord a, FinSet a) => [[a]] -> [[a]] closureAG ps = let vs = [ (1 - sum xs) : xs | xs <- ptsAG (k-1) fq ] -- k-vectors over fq whose sum is 1 in toListSet [m' <<*> v | v <- vs] where k = length ps -- the dimension of the flat (assuming ps are independent) m' = L.transpose ps fq = elts -- toListSet call sorts the result, and also removes duplicates in case the points weren't independent {- closureAG ps = let vs = [ (1 - sum xs) : xs | xs <- ptsAG (k-1) fq ] -- k-vectors over fq whose sum is 1 in toListSet [foldl1 (<+>) $ zipWith (*>) v ps | v <- vs] where k = length ps -- the dimension of the flat fq = eltsFq undefined -} lineAG [p1,p2] = L.sort [ p1 <+> (c *> dp) | c <- fq ] where dp = p2 <-> p1 fq = elts -- closure of points in PG(n,Fq) -- take all linear combinations of the points (ie the subspace generated by the points, considered as points in Fq ^(n+1) ) -- then discard all which aren't in PNF (thus dropping back into PG(n,Fq)) -- |Given a set of points in PG(n,Fq), return their closure, the smallest flat containing them closurePG :: (Num a, Ord a, FinSet a) => [[a]] -> [[a]] closurePG ps = toListSet $ filter ispnf $ map (<*>> ps) $ ptsAG k fq where k = length ps fq = elts -- toListSet call sorts the result, and also removes duplicates in case the points weren't independent linePG [p1,p2] = toListSet $ filter ispnf [(a *> p1) <+> (b *> p2) | a <- fq, b <- fq] where fq = elts -- van Lint & Wilson, p325, 332 qtorial n q | n >= 0 = product [(q^i - 1) `div` (q-1) | i <- [1..n]] -- van Lint & Wilson, p326 qnomial n k q = (n `qtorial` q) `div` ( (k `qtorial` q) * ((n-k) `qtorial` q) ) -- Cameron, p129 numFlatsPG n q k = qnomial (n+1) (k+1) q -- because it's the number of subspaces in AG n+1 -- Cameron, p137 numFlatsAG n q k = q^(n-k) * qnomial n k q qtorials q = scanl (*) 1 [(q^i - 1) `div` (q-1) | i <- [1..]] qnomials q = iterate succ [1] where succ xs = L.zipWith3 (\l r c -> l+c*r) (0:xs) (xs++[0]) (iterate (*q) 1) -- succ xs = zipWith (+) (0:xs) $ zipWith (*) (xs++[0]) $ iterate (*q) 1 -- This amounts to saying -- [n+1,k]_q = [n,k-1]_q + q^k [n,k]_q -- Cameron, Combinatorics, p126 -- FLATS VIA REDUCED ROW ECHELON FORMS -- Suggested by Cameron p125 data ZeroOneStar = Zero | One | Star deriving (Eq) instance Show ZeroOneStar where show Zero = "0" show One = "1" show Star = "*" -- reduced row echelon forms rrefs n k = map (rref 1 1) (combinationsOf k [1..n]) where rref r c (x:xs) = if c == x then zipWith (:) (oneColumn r) (rref (r+1) (c+1) xs) else zipWith (:) (starColumn r) (rref r (c+1) (x:xs)) rref _ c [] = replicate k (replicate (n+1-c) Star) oneColumn r = replicate (r-1) Zero ++ One : replicate (k-r) Zero starColumn r = replicate (r-1) Star ++ replicate (k+1-r) Zero -- flatsPG :: (FiniteField a) => Int -> [a] -> Int -> [[[a]]] -- |@flatsPG n fq k@ returns the k-flats in PG(n,Fq), where fq are the elements of Fq. -- The returned flats are represented as matrices in reduced row echelon form, -- the rows of which are the points that generate the flat. -- The full set of points in the flat can be recovered by calling 'closurePG' flatsPG :: (Eq a, Num a) => Int -> [a] -> Int -> [[[a]]] flatsPG n fq k = concatMap substStars $ rrefs (n+1) (k+1) where substStars (r:rs) = [r':rs' | r' <- substStars' r, rs' <- substStars rs] substStars [] = [[]] substStars' (Star:xs) = [x':xs' | x' <- fq, xs' <- substStars' xs] substStars' (Zero:xs) = map (0:) $ substStars' xs substStars' (One:xs) = map (1:) $ substStars' xs substStars' [] = [[]] -- Flats in AG(n,Fq) are just the flats in PG(n,Fq) which are not "at infinity" -- flatsAG :: (FiniteField a) => Int -> [a] -> Int -> [[[a]]] -- |flatsAG n fq k returns the k-flats in AG(n,Fq), where fq are the elements of Fq. flatsAG :: (Eq a, Num a) => Int -> [a] -> Int -> [[[a]]] flatsAG n fq k = [map tail (r : map (r <+>) rs) | r:rs <- flatsPG n fq k, head r == 1] -- The head r == 1 condition is saying that we want points which are in the "finite" part of PG(n,Fq), not points at infinity -- The reason we add r to each of the rs is to bring them into the "finite" part -- (If you don't do this, it can lead to incorrect results, for example some of the flats having the same closure) -- linesPG :: (FiniteField a) => Int -> [a] -> [[[a]]] -- |The lines (1-flats) in PG(n,fq) linesPG :: (Eq a, Num a) => Int -> [a] -> [[[a]]] linesPG n fq = flatsPG n fq 1 -- linesAG :: (FiniteField a) => Int -> [a] -> [[[a]]] -- |The lines (1-flats) in AG(n,fq) linesAG :: (Eq a, Num a) => Int -> [a] -> [[[a]]] linesAG n fq = flatsAG n fq 1 -- almost certainly not as efficient as linesAG, because requires lineAG/closureAG call -- among all pairs of distinct points, select those which are the first two in the line they generate linesAG1 n fq = [ [x,y] | [x,y] <- combinationsOf 2 (ptsAG n fq), [x,y] == take 2 (lineAG [x,y]) ] -- the point of the condition at the end is to avoid listing the same line more than once -- almost certainly not as efficient as linesAG, because requires lineAG/closureAG call -- a line in AG(n,fq) is a translation (x) of a line through the origin (y) linesAG2 n fq = [ [x,z] | x <- ptsAG n fq, y <- ptsPG (n-1) fq, z <- [x <+> y], [x,z] == take 2 (closureAG [x,z]) ] -- INCIDENCE GRAPH -- |Incidence graph of PG(n,fq), considered as an incidence structure between points and lines incidenceGraphPG :: (Num a, Ord a, FinSet a) => Int -> [a] -> Graph (Either [a] [[a]]) incidenceGraphPG n fq = G vs es where points = ptsPG n fq lines = linesPG n fq vs = L.sort $ map Left points ++ map Right lines es = L.sort [ [Left x, Right b] | b <- lines, x <- closurePG b] -- Could also consider incidence structure between points and planes, etc -- incidenceAuts (incidenceGraphPG n fq) == PGL(n+1,fq) * auts fq -- For example, incidenceAuts (incidenceGraphPG 2 f4) = -- PGL(3,f4) * auts f4 -- where PGL(3,f4)/PSL(3,f4) == f4* (multiplicative group of f4), -- and auts f4 == { 1, x -> x^2 } (the Frobenius aut) -- The full group is called PGammaL(3,f4) -- |Incidence graph of AG(n,fq), considered as an incidence structure between points and lines incidenceGraphAG :: (Num a, Ord a, FinSet a) => Int -> [a] -> Graph (Either [a] [[a]]) incidenceGraphAG n fq = G vs es where points = ptsAG n fq lines = linesAG n fq vs = L.sort $ map Left points ++ map Right lines es = L.sort [ [Left x, Right b] | b <- lines, x <- closureAG b] -- incidenceAuts (incidenceGraphAG n fq) == Aff(n,fq) * auts fq -- where Aff(n,fq), the affine group, is the semi-direct product GL(n,fq) * (fq^n)+ -- where (fq^n)+ is the additive group of translations -- Each elt of Aff(n,fq) is of the form x -> ax + b, where a <- GL(n,fq), b <- (fq^n)+ orderGL n q = product [q^n - q^i | i <- [0..n-1] ] -- for the first row, we can choose any vector except zero, hence q^n-1 -- for the second row, we can choose any vector except a multiple of the first, hence q^n-q -- etc orderAff n q = q^n * orderGL n q orderPGL n q = orderGL n q `div` (q-1) -- NOTE: -- AG(n,F2) is degenerate: -- Every pair of points is a line, so it is the complete graph on 2^n points -- And as such has aut group S(2^n) -- Heawood graph = incidence graph of Fano plane heawood = to1n $ incidenceGraphPG 2 f2HaskellForMaths-0.4.8/Math/Combinatorics/Graph.hs0000644000000000000000000003476712514742102020041 0ustar0000000000000000-- Copyright (c) 2008-2011, David Amos. All rights reserved. -- |A module defining a polymorphic data type for (simple, undirected) graphs, -- together with constructions of some common families of graphs, -- new from old constructions, and calculation of simple properties of graphs. module Math.Combinatorics.Graph where import qualified Data.List as L import Data.Maybe (isJust) import qualified Data.Map as M import qualified Data.Set as S import Control.Arrow ( (&&&) ) import Math.Common.ListSet as LS import Math.Core.Utils import Math.Algebra.Group.PermutationGroup hiding (fromDigits, fromBinary) import qualified Math.Algebra.Group.SchreierSims as SS -- Main source: Godsil & Royle, Algebraic Graph Theory -- COMBINATORICS -- Some functions we'll use set xs = map head $ L.group $ L.sort xs -- subsets of a set (returned in "binary" order) powerset [] = [[]] powerset (x:xs) = let p = powerset xs in p ++ map (x:) p -- GRAPH -- |Datatype for graphs, represented as a list of vertices and a list of edges. -- For most purposes, graphs are required to be in normal form. -- A graph G vs es is in normal form if (i) vs is in ascending order without duplicates, -- (ii) es is in ascending order without duplicates, (iii) each e in es is a 2-element list [x,y], x Graph a -> Graph a nf (G vs es) = G vs' es' where vs' = L.sort vs es' = L.sort (map L.sort es) -- we require that vs, es, and each individual e are sorted isSetSystem xs bs = isListSet xs && isListSet bs && all isListSet bs && all (`isSubset` xs) bs isGraph vs es = isSetSystem vs es && all ( (==2) . length) es -- |Safe constructor for graph from lists of vertices and edges. -- graph (vs,es) checks that vs and es are valid before returning the graph. graph :: (Ord t) => ([t], [[t]]) -> Graph t graph (vs,es) | isGraph vs es = G vs es -- | otherwise = error ( "graph " ++ show (vs,es) ) -- isValid g = g where g = G vs es toGraph (vs,es) | isGraph vs' es' = G vs' es' where vs' = L.sort vs es' = L.sort $ map L.sort es -- note that calling isListSet on a sorted list still checks that there are no duplicates vertices (G vs _) = vs edges (G _ es) = es -- OTHER REPRESENTATIONS -- incidence matrix of a graph -- (rows and columns indexed by edges and vertices respectively) -- (warning: in the literature it is often the other way round) incidenceMatrix (G vs es) = [ [if v `elem` e then 1 else 0 | v <- vs] | e <- es] fromIncidenceMatrix m = graph (vs,es) where n = L.genericLength $ head m vs = [1..n] es = L.sort $ map edge m edge row = [v | (1,v) <- zip row vs] adjacencyMatrix (G vs es) = [ [if L.sort [i,j] `S.member` es' then 1 else 0 | j <- vs] | i <- vs] where es' = S.fromList es fromAdjacencyMatrix m = graph (vs,es) where n = L.genericLength m vs = [1..n] es = es' 1 m es' i (r:rs) = [ [i,j] | (j,1) <- drop i (zip vs r)] ++ es' (i+1) rs es' _ [] = [] -- SOME SIMPLE FAMILIES OF GRAPHS -- |The null graph on n vertices is the graph with no edges nullGraph :: (Integral t) => t -> Graph t nullGraph n = G [1..n] [] -- |The null graph, with no vertices or edges nullGraph' :: Graph Int -- type signature needed nullGraph' = G [] [] -- |c n is the cyclic graph on n vertices c :: (Integral t) => t -> Graph t c n | n >= 3 = graph (vs,es) where vs = [1..n] es = L.insert [1,n] [[i,i+1] | i <- [1..n-1]] -- automorphism group is D2n -- |k n is the complete graph on n vertices k :: (Integral t) => t -> Graph t k n = graph (vs,es) where vs = [1..n] es = [[i,j] | i <- [1..n-1], j <- [i+1..n]] -- == combinationsOf 2 [1..n] -- automorphism group is Sn -- |kb m n is the complete bipartite graph on m and n vertices kb :: (Integral t) => t -> t -> Graph t kb m n = to1n $ kb' m n -- |kb' m n is the complete bipartite graph on m left and n right vertices kb' :: (Integral t) => t -> t -> Graph (Either t t) kb' m n = graph (vs,es) where vs = map Left [1..m] ++ map Right [1..n] es = [ [Left i, Right j] | i <- [1..m], j <- [1..n] ] -- automorphism group is Sm*Sn (plus a flip if m==n) -- |q k is the graph of the k-cube q :: (Integral t) => Int -> Graph t q k = fromBinary $ q' k q' :: (Integral t) => Int -> Graph [t] q' k = graph (vs,es) where vs = sequence $ replicate k [0,1] -- ptsAn k f2 es = [ [u,v] | [u,v] <- combinationsOf 2 vs, hammingDistance u v == 1 ] hammingDistance as bs = length $ filter id $ zipWith (/=) as bs -- can probably type-coerce this to be Graph [F2] if required tetrahedron = k 4 cube = q 3 octahedron = graph (vs,es) where vs = [1..6] es = combinationsOf 2 vs L.\\ [[1,6],[2,5],[3,4]] dodecahedron = toGraph (vs,es) where vs = [1..20] es = [ [1,2],[2,3],[3,4],[4,5],[5,1], [6,7],[7,8],[8,9],[9,10],[10,11],[11,12],[12,13],[13,14],[14,15],[15,6], [16,17],[17,18],[18,19],[19,20],[20,16], [1,6],[2,8],[3,10],[4,12],[5,14], [7,16],[9,17],[11,18],[13,19],[15,20] ] icosahedron = toGraph (vs,es) where vs = [1..12] es = [ [1,2],[1,3],[1,4],[1,5],[1,6], [2,3],[3,4],[4,5],[5,6],[6,2], [7,12],[8,12],[9,12],[10,12],[11,12], [7,8],[8,9],[9,10],[10,11],[11,7], [2,7],[7,3],[3,8],[8,4],[4,9],[9,5],[5,10],[10,6],[6,11],[11,2] ] -- Prisms are regular, vertex-transitive, but not edge-transitive unless n == 1, 2, 4. -- (prism 2 ~= q 2, prism 4 ~= q 3) prism :: Int -> Graph (Int,Int) prism n = k 2 `cartProd` c n -- convert a graph to have [1..n] as vertices to1n (G vs es) = graph (vs',es') where mapping = M.fromList $ zip vs [1..] -- the mapping from vs to [1..n] vs' = M.elems mapping es' = [map (mapping M.!) e | e <- es] -- the edges will already be sorted correctly by construction -- |Given a graph with vertices which are lists of small integers, eg [1,2,3], -- return a graph with vertices which are the numbers obtained by interpreting these as digits, eg 123. -- The caller is responsible for ensuring that this makes sense (eg that the small integers are all < 10) fromDigits :: Integral a => Graph [a] -> Graph a fromDigits = fmap fromDigits' {- fromDigits (G vs es) = graph (vs',es') where vs' = map fromDigits' vs es' = (map . map) fromDigits' es -} -- |Given a graph with vertices which are lists of 0s and 1s, -- return a graph with vertices which are the numbers obtained by interpreting these as binary digits. -- For example, [1,1,0] -> 6. fromBinary :: Integral a => Graph [a] -> Graph a fromBinary = fmap fromBinary' {- fromBinary (G vs es) = graph (vs',es') where vs' = map fromBinary' vs es' = (map . map) fromBinary' es -} petersen :: Graph [Integer] petersen = graph (vs,es) where vs = combinationsOf 2 [1..5] es = [ [v1,v2] | [v1,v2] <- combinationsOf 2 vs, disjoint v1 v2] -- == kneser 5 2 == j 5 2 0 -- == complement $ lineGraph' $ k 5 -- == complement $ t' 5 -- NEW GRAPHS FROM OLD complement :: (Ord t) => Graph t -> Graph t complement (G vs es) = graph (vs,es') where es' = combinationsOf 2 vs LS.\\ es -- es' = [e | e <- combinationsOf 2 vs, e `notElem` es] -- |The restriction of a graph to a subset of the vertices restriction :: (Eq a) => Graph a -> [a] -> Graph a restriction g@(G vs es) us = G us (es `restrict` us) where es `restrict` us = [e | e@[i,j] <- es, i `elem` us, j `elem` us] inducedSubgraph :: (Eq a) => Graph a -> [a] -> Graph a inducedSubgraph g@(G vs es) us = G us (es `restrict` us) where es `restrict` us = [e | e@[i,j] <- es, i `elem` us, j `elem` us] lineGraph g = to1n $ lineGraph' g lineGraph' (G vs es) = graph (es, [ [ei,ej] | ei <- es, ej <- dropWhile (<= ei) es, ei `intersect` ej /= [] ]) -- For example cartProd (c m) (c n) is a wireframe for a torus -- cartProd (q m) (q n) `isGraphIso` q (m+n) -- Godsil and Royle p154 cartProd (G vs es) (G vs' es') = G us [e | e@[u,u'] <- combinationsOf 2 us, u `adj` u' ] where us = [(v,v') | v <- vs, v' <- vs'] eset = S.fromList es eset' = S.fromList es' adj (x1,y1) (x2,y2) = x1 == x2 && L.sort [y1,y2] `S.member` eset' || y1 == y2 && L.sort [x1,x2] `S.member` eset -- SIMPLE PROPERTIES OF GRAPHS order = length . vertices size = length . edges -- also called degree valency (G vs es) v = length $ filter (v `elem`) es valencies g@(G vs es) = map (head &&& length) $ L.group $ L.sort $ map (valency g) vs valencyPartition g@(G vs es) = map (map snd) $ L.groupBy (\x y -> fst x == fst y) [(valency g v, v) | v <- vs] regularParam g = case valencies g of [(v,_)] -> Just v _ -> Nothing -- |A graph is regular if all vertices have the same valency (degree) isRegular :: (Eq t) => Graph t -> Bool isRegular g = isJust $ regularParam g -- |A 3-regular graph is called a cubic graph isCubic :: (Eq t) => Graph t -> Bool isCubic g = regularParam g == Just 3 nbrs (G vs es) v = [u | [u,v'] <- es, v == v'] ++ [w | [v',w] <- es, v == v'] -- if the graph is valid, then the neighbours will be returned in ascending order -- find paths from x to y using bfs -- by definition, a path is a subgraph isomorphic to a "line" - it can't have self-crossings -- (a walk allows self-crossings, a trail allows self-crossings but no edge reuse) findPaths g@(G vs es) x y = map reverse $ bfs [ [x] ] where bfs ((z:zs) : nodes) | z == y = (z:zs) : bfs nodes | otherwise = bfs (nodes ++ [(w:z:zs) | w <- nbrs g z, w `notElem` zs]) bfs [] = [] -- |Within a graph G, the distance d(u,v) between vertices u, v is length of the shortest path from u to v distance :: (Eq a) => Graph a -> a -> a -> Int distance g x y = case findPaths g x y of [] -> -1 -- infinite p:ps -> length p - 1 -- |The diameter of a graph is maximum distance between two distinct vertices diameter :: (Ord t) => Graph t -> Int diameter g@(G vs es) | isConnected g = maximum $ map maxDistance vs | otherwise = -1 where maxDistance v = length (distancePartition g v) - 1 -- find cycles starting at x -- by definition, a cycle is a subgraph isomorphic to a cyclic graph - it can't have self-crossings -- (a circuit allows self-crossings but not edge reuse) findCycles g@(G vs es) x = [reverse (x:z:zs) | z:zs <- bfs [ [x] ], z `elem` nbrsx, length zs > 1] where nbrsx = nbrs g x bfs ((z:zs) : nodes) = (z:zs) : bfs (nodes ++ [ w:z:zs | w <- nbrs g z, w `notElem` zs]) bfs [] = [] -- |The girth of a graph is the size of the smallest cycle that it contains. -- Note: If the graph contains no cycles, we return -1, representing infinity. girth :: (Eq t) => Graph t -> Int girth g@(G vs es) = minimum' $ map minCycle vs where minimum' xs = let (zs,nzs) = L.partition (==0) xs in if null nzs then -1 else minimum nzs minCycle v = case findCycles g v of [] -> 0 c:cs -> length c - 1 -- because v occurs twice in c, as startpoint and endpoint -- circumference = max cycle - Bollobas p104 -- Vertices that are not in the same component as the start vertex all go into a final cell distancePartition g@(G vs es) v = distancePartitionS vs (S.fromList es) v distancePartitionS vs eset v = distancePartition' (S.singleton v) (S.delete v (S.fromList vs)) where distancePartition' boundary exterior | S.null boundary = if S.null exterior then [] else [S.toList exterior] -- graph may not have been connected | otherwise = let (boundary', exterior') = S.partition (\v -> any (`S.member` eset) [L.sort [u,v] | u <- S.toList boundary]) exterior in S.toList boundary : distancePartition' boundary' exterior' -- the connected component to which v belongs component g v = component' S.empty (S.singleton v) where component' interior boundary | S.null boundary = S.toList interior | otherwise = let interior' = S.union interior boundary boundary' = foldl S.union S.empty [S.fromList (nbrs g x) | x <- S.toList boundary] S.\\ interior' in component' interior' boundary' -- TODO: This can almost certainly be made more efficient. -- nbrs is O(n), and this calls it for each vertex in the component, so it is O(n^2) -- |Is the graph connected? isConnected :: (Ord t) => Graph t -> Bool isConnected g@(G (v:vs) es) = length (component g v) == length (v:vs) isConnected (G [] []) = True components g = components' (vertices g) where components' [] = [] components' (v:vs) = let c = component g v in c : components' (vs LS.\\ c) -- MORE GRAPHS -- Generalized Johnson graph, Godsil & Royle p9 -- Also called generalised Kneser graph, http://en.wikipedia.org/wiki/Kneser_graph j v k i | v >= k && k >= i = graph (vs,es) where vs = combinationsOf k [1..v] es = [ [v1,v2] | [v1,v2] <- combinationsOf 2 vs, length (v1 `intersect` v2) == i ] -- j v k i is isomorphic to j v (v-k) (v-2k+i), so may as well have v >= 2k -- kneser v k | v >= 2*k = j v k 0 -- |kneser n k returns the kneser graph KG n,k - -- whose vertices are the k-element subsets of [1..n], with edges between disjoint subsets kneser :: Int -> Int -> Graph [Int] kneser n k | 2*k <= n = graph (vs,es) where vs = combinationsOf k [1..n] es = [ [v1,v2] | [v1,v2] <- combinationsOf 2 vs, disjoint v1 v2] johnson v k | v >= 2*k = j v k (k-1) bipartiteKneser n k | 2*k < n = graph (vs,es) where vs = map Left (combinationsOf k [1..n]) ++ map Right (combinationsOf (n-k) [1..n]) es = [ [Left u, Right v] | u <- combinationsOf k [1..n], v <- combinationsOf (n-k) [1..n], u `isSubset` v] desargues1 = bipartiteKneser 5 2 -- Generalised Petersen graphs -- http://en.wikipedia.org/wiki/Petersen_graph gp n k | 2*k < n = toGraph (vs,es) where vs = map Left [0..n-1] ++ map Right [0..n-1] es = (map . map) Left [ [i, (i+1) `mod` n] | i <- [0..n-1] ] ++ [ [Left i, Right i] | i <- [0..n-1] ] ++ (map . map) Right [ [i, (i+k) `mod` n] | i <- [0..n-1] ] petersen2 = gp 5 2 prism' n = gp n 1 durer = gp 6 2 mobiusKantor = gp 8 3 dodecahedron2 = gp 10 2 desargues2 = gp 10 3HaskellForMaths-0.4.8/Math/Combinatorics/GraphAuts.hs0000644000000000000000000012242012514742102020656 0ustar0000000000000000-- Copyright (c) David Amos, 2009-2014. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction, TupleSections, DeriveFunctor #-} module Math.Combinatorics.GraphAuts (isVertexTransitive, isEdgeTransitive, isArcTransitive, is2ArcTransitive, is3ArcTransitive, is4ArcTransitive, isnArcTransitive, isDistanceTransitive, graphAuts, incidenceAuts, graphAuts7, graphAuts8, incidenceAuts2, isGraphAut, isIncidenceAut, graphIsos, incidenceIsos, isGraphIso, isIncidenceIso) where import Data.Either (lefts, rights, partitionEithers) import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S import Data.Maybe import Data.Ord (comparing) import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import Math.Common.ListSet import Math.Core.Utils (combinationsOf, intersectAsc, pairs, picks, (^-)) import Math.Combinatorics.Graph -- import Math.Combinatorics.StronglyRegularGraph -- import Math.Combinatorics.Hypergraph -- can't import this, creates circular dependency import Math.Algebra.Group.PermutationGroup import Math.Algebra.Group.SchreierSims as SS -- The code for finding automorphisms - "graphAuts" - follows later on in file -- TRANSITIVITY PROPERTIES OF GRAPHS -- |A graph is vertex-transitive if its automorphism group acts transitively on the vertices. Thus, given any two distinct vertices, there is an automorphism mapping one to the other. isVertexTransitive :: (Ord t) => Graph t -> Bool isVertexTransitive (G [] []) = True -- null graph is trivially vertex transitive isVertexTransitive g@(G (v:vs) es) = orbitV auts v == v:vs where auts = graphAuts g -- |A graph is edge-transitive if its automorphism group acts transitively on the edges. Thus, given any two distinct edges, there is an automorphism mapping one to the other. isEdgeTransitive :: (Ord t) => Graph t -> Bool isEdgeTransitive (G _ []) = True isEdgeTransitive g@(G vs (e:es)) = orbitE auts e == e:es where auts = graphAuts g arc ->^ g = map (.^ g) arc -- unlike edges/blocks, arcs are directed, so the action on them does not sort -- Godsil & Royle 59-60 -- |A graph is arc-transitive (or flag-transitive) if its automorphism group acts transitively on arcs. (An arc is an ordered pair of adjacent vertices.) isArcTransitive :: (Ord t) => Graph t -> Bool isArcTransitive (G _ []) = True -- empty graphs are trivially arc transitive isArcTransitive g@(G vs es) = orbit (->^) a auts == a:as where -- isArcTransitive g@(G vs es) = closure [a] [ ->^ h | h <- auts] == a:as where a:as = L.sort $ es ++ map reverse es auts = graphAuts g isArcTransitive' g@(G (v:vs) es) = orbitP auts v == v:vs && -- isVertexTransitive g orbitP stab n == n:ns where auts = graphAuts g stab = filter (\p -> v .^ p == v) auts -- relies on v being the first base for the SGS returned by graphAuts -- stab = dropWhile (\p -> v .^ p /= v) auts -- we know that graphAuts are returned in this order n:ns = nbrs g v -- execution time of both of the above is dominated by the time to calculate the graph auts, so their performance is similar -- then k n, kb n n, q n, other platonic solids, petersen graph, heawood graph, pappus graph, desargues graph are all arc-transitive -- find arcs of length l from x using dfs - results returned in order -- an arc is a sequence of vertices connected by edges, no doubling back, but self-crossings allowed findArcs g@(G vs es) x l = map reverse $ dfs [ ([x],0) ] where dfs ( (z1:z2:zs,l') : nodes) | l == l' = (z1:z2:zs) : dfs nodes | otherwise = dfs $ [(w:z1:z2:zs,l'+1) | w <- nbrs g z1, w /= z2] ++ nodes dfs ( ([z],l') : nodes) | l == l' = [z] : dfs nodes | otherwise = dfs $ [([w,z],l'+1) | w <- nbrs g z] ++ nodes dfs [] = [] -- note that a graph with triangles can't be 3-arc transitive, etc, because an aut can't map a self-crossing arc to a non-self-crossing arc -- |A graph is n-arc-transitive if its automorphism group is transitive on n-arcs. (An n-arc is an ordered sequence (v0,...,vn) of adjacent vertices, with crossings allowed but not doubling back.) isnArcTransitive :: (Ord t) => Int -> Graph t -> Bool isnArcTransitive _ (G [] []) = True isnArcTransitive n g@(G (v:vs) es) = orbitP auts v == v:vs && -- isVertexTransitive g orbit (->^) a stab == a:as -- closure [a] [ ->^ h | h <- stab] == a:as where auts = graphAuts g stab = filter (\p -> v .^ p == v) auts -- relies on v being the first base for the SGS returned by graphAuts -- stab = dropWhile (\p -> v .^ p /= v) auts -- we know that graphAuts are returned in this order a:as = findArcs g v n is2ArcTransitive :: (Ord t) => Graph t -> Bool is2ArcTransitive g = isnArcTransitive 2 g is3ArcTransitive :: (Ord t) => Graph t -> Bool is3ArcTransitive g = isnArcTransitive 3 g -- The incidence graphs of the projective planes PG(2,Fq) are 4-arc-transitive is4ArcTransitive :: (Ord t) => Graph t -> Bool is4ArcTransitive g = isnArcTransitive 4 g -- Godsil & Royle 66-7 -- |A graph is distance transitive if given any two ordered pairs of vertices (u,u') and (v,v') with d(u,u') == d(v,v'), -- there is an automorphism of the graph that takes (u,u') to (v,v') isDistanceTransitive :: (Ord t) => Graph t -> Bool isDistanceTransitive (G [] []) = True isDistanceTransitive g@(G (v:vs) es) | isConnected g = orbitP auts v == v:vs && -- isVertexTransitive g length stabOrbits == diameter g + 1 -- the orbits under the stabiliser of v coincide with the distance partition from v | otherwise = error "isDistanceTransitive: only implemented for connected graphs" where auts = graphAuts g stab = filter (\p -> v .^ p == v) auts -- relies on v being the first base for the SGS returned by graphAuts -- stab = dropWhile (\p -> v .^ p /= v) auts -- we know that graphAuts are returned in this order stabOrbits = let os = orbits stab in os ++ map (:[]) ((v:vs) L.\\ concat os) -- include fixed point orbits -- GRAPH AUTOMORPHISMS -- |Is the permutation an automorphism of the graph? isGraphAut :: Ord t => Graph t -> Permutation t -> Bool isGraphAut (G vs es) h = all (`S.member` es') [e -^ h | e <- es] where es' = S.fromList es -- this works best on sparse graphs, where p(edge) < 1/2 -- if p(edge) > 1/2, it would be better to test on the complement of the graph -- |Is the permutation an automorphism of the incidence structure represented by the graph? -- (Note that an incidence graph colours points as Left, blocks as Right, and a permutation -- that swaps points and blocks, even if it is an automorphism of the graph, does not represent -- an automorphism of the incidence structure. Instead, a point-block crossover is called a duality.) isIncidenceAut :: (Ord p, Ord b) => Graph (Either p b) -> Permutation (Either p b) -> Bool isIncidenceAut (G vs es) h = all (`S.member` es') [e ->^ h | e <- es] -- using ->^ instead of -^ excludes dualities, since each edge is of the form [Left p, Right b] where es' = S.fromList es -- Calculate a map consisting of neighbour lists for each vertex in the graph -- If a vertex has no neighbours then it is left out of the map adjLists (G vs es) = adjLists' M.empty es where adjLists' nbrs ([u,v]:es) = adjLists' (M.insertWith' (flip (++)) v [u] $ M.insertWith' (flip (++)) u [v] nbrs) es adjLists' nbrs [] = nbrs -- ALTERNATIVE VERSIONS OF GRAPH AUTS -- (showing how we got to the final version) data SearchTree a = T Bool a [SearchTree a] deriving (Eq, Ord, Show, Functor) -- The boolean indicates whether or not this is a terminal / solution node leftDepth (T _ _ []) = 1 leftDepth (T _ _ (t:ts)) = 1 + leftDepth t leftWidths (T _ _ []) = [] leftWidths (T _ _ ts@(t:_)) = length ts : leftWidths t graphAutsEdgeSearchTree (G vs es) = dfs [] vs vs where dfs xys (x:xs) yys = T False xys [dfs ((x,y):xys) xs ys | (y,ys) <- picks yys, isCompatible xys (x,y)] dfs xys [] [] = T True xys [] isCompatible xys (x',y') = and [([x,x'] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x,y) <- xys] es' = S.fromList es graphAuts1 = map fromPairs . terminals . graphAutsEdgeSearchTree terminals (T False _ ts) = concatMap terminals ts terminals (T True xys _) = [xys] -- Using Lemma 9.1.1 from Seress p203 to prune the search tree -- Because auts form a group, it is sufficient to expand only each leftmost branch of the tree in full. -- For every other branch, it is sufficient to find a single representative, since the other elements -- can then be obtained by multiplication in the group (using the leftmost elements). -- In effect, we are finding a transversal generating set. -- Note however, that this transversal generating set is relative to whatever base order the tree uses, -- so for clarity, the tree should use natural vertex order. transversalTerminals (T False _ (t:ts)) = concatMap (take 1 . transversalTerminals) ts ++ transversalTerminals t -- transversalTerminals (T False _ (t:ts)) = transversalTerminals t ++ concatMap (take 1 . transversalTerminals) ts transversalTerminals (T True xys _) = [xys] transversalTerminals _ = [] graphAuts2 = filter (/=1) . map fromPairs . transversalTerminals . graphAutsEdgeSearchTree -- init because last is identity isSingleton [_] = True isSingleton _ = False intersectCells p1 p2 = concat [ [c1 `intersectAsc` c2 | c2 <- p2] | c1 <- p1] -- Intersection preserves ordering within cells but not between cells -- eg the cell [1,2,3,4] could be refined to [2,4],[1,3] graphAutsDistancePartitionSearchTree g@(G vs es) = dfs [] ([vs],[vs]) where dfs xys (srcPart,trgPart) | all isSingleton srcPart = let xys' = zip (concat srcPart) (concat trgPart) in T (isCompatible xys') (xys++xys') [] -- Since the xys' are distance-compatible with the xys, they are certainly edge-compatible. -- However, we do need to check that the xys' are edge-compatible with each other. | otherwise = let (x:xs):srcCells = srcPart yys :trgCells = trgPart srcPart' = intersectCells (xs : srcCells) (dps M.! x) in T False xys -- the L.sort in the following line is so that we traverse vertices in natural order [dfs ((x,y):xys) ((unzip . L.sort) (zip (filter (not . null) srcPart') (filter (not . null) trgPart'))) | (y,ys) <- picks yys, let trgPart' = intersectCells (ys : trgCells) (dps M.! y), map length srcPart' == map length trgPart'] isCompatible xys = and [([x,x'] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x,y) <- xys, (x',y') <- xys, x < x'] es' = S.fromList es dps = M.fromAscList [(v, distancePartitionS vs es' v) | v <- vs] graphAuts3 = filter (/=1) . map fromPairs . transversalTerminals . graphAutsDistancePartitionSearchTree -- Whereas transversalTerminals produced a transversal generating set, here we produce a strong generating set. -- In particular, if we have already found (3 4), and then we find (1 2 3), -- then there is no need to look for (1 3 ...) or (1 4 ...), since it is clear that such elements exist -- as products of those we have already found. strongTerminals = strongTerminals' [] where strongTerminals' gs (T False xys ts) = case listToMaybe $ reverse $ filter (\(x,y) -> x /= y) xys of -- the first vertex that isn't fixed Nothing -> L.foldl' (\hs t -> strongTerminals' hs t) gs ts Just (x,y) -> if y `elem` (x .^^ gs) then gs -- Since we're not on the leftmost spine, we can stop as soon as we find one new element else find1New gs ts -- else L.foldl' (\hs t -> if hs /= gs then hs else strongTerminals' hs t) gs ts strongTerminals' gs (T True xys []) = fromPairs xys : gs find1New gs (t:ts) = let hs = strongTerminals' gs t in if take 1 gs /= take 1 hs -- we know a new element would be placed at the front then hs else find1New gs ts find1New gs [] = gs -- |Given a graph g, @graphAuts g@ returns a strong generating set for the automorphism group of g. graphAuts :: (Ord a) => Graph a -> [Permutation a] graphAuts = filter (/=1) . strongTerminals . graphAutsDistancePartitionSearchTree -- Using colourings (M.Map vertex colour, M.Map colour [vertex]), in place of partitions ([[vertex]]) -- This turns out to be slower than using partitions. -- Updating the colour partition incrementally seems to be much less efficient than just recalculating it each time -- (Recalculating each time is O(n), incrementally updating is O(n^2)?) graphAutsDistanceColouringSearchTree g@(G vs es) = dfs [] unitCol unitCol where unitCol = (M.fromList $ map (,[]) vs, M.singleton [] vs) -- "unit colouring" dfs xys srcColouring@(srcVmap,srcCmap) trgColouring@(trgVmap,trgCmap) -- ( | M.map length srcCmap /= M.map length trgCmap = T False xys [] ) | all isSingleton (M.elems srcCmap) = -- discrete colouring let xys' = zip (concat $ M.elems srcCmap) (concat $ M.elems trgCmap) in T (isCompatible xys') (reverse xys'++xys) [] -- Since the xys' are distance-compatible with the xys, they are certainly edge-compatible. -- However, we do need to check that the xys' are edge-compatible with each other. | otherwise = let (x,c) = M.findMin srcVmap (xVmap,xCmap) = dcs M.! x ys = trgCmap M.! c srcVmap' = M.delete x (intersectColouring srcVmap xVmap) srcCmap' = colourPartition srcVmap' -- srcCmap' = M.fromAscList [(c1++c2, cell) | (c1,srcCell) <- M.assocs srcCmap, (c2,xCell) <- M.assocs xCmap, -- let cell = L.delete x (intersectAsc srcCell xCell), -- (not . null) cell] in T False xys [dfs ((x,y):xys) (srcVmap',srcCmap') (trgVmap',trgCmap') | y <- ys, let (yVmap,yCmap) = dcs M.! y, let trgVmap' = M.delete y (intersectColouring trgVmap yVmap), let trgCmap' = colourPartition trgVmap', -- let trgCmap' = M.fromAscList [(c1++c2, cell) | (c1,trgCell) <- M.assocs trgCmap, (c2,yCell) <- M.assocs yCmap, -- let cell = L.delete y (intersectAsc trgCell yCell), -- (not . null) cell], M.map length srcCmap' == M.map length trgCmap' ] isCompatible xys = and [([x,x'] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x,y) <- xys, (x',y') <- xys, x < x'] es' = S.fromList es dcs = M.fromAscList [(v, distanceColouring v) | v <- vs] distanceColouring u = let dp = distancePartitionS vs es' u vmap = M.fromList [(v,[c]) | (cell,c) <- zip dp [0..], v <- cell] cmap = M.fromList $ zip (map (:[]) [0..]) dp in (vmap, cmap) {- -- If we are going to recalculate the colour partition each time anyway, -- then we don't need to carry it around, and can simplify the code graphAutsDistanceColouringSearchTree g@(G vs es) = dfs [] initCol initCol where initCol = M.fromList $ map (,[]) vs dfs xys srcCol trgCol | M.map length srcPart /= M.map length trgPart = T False xys [] | all isSingleton (M.elems srcPart) = let xys' = zip (concat $ M.elems srcPart) (concat $ M.elems trgPart) in T (isCompatible xys') (reverse xys'++xys) [] -- Since the xys' are distance-compatible with the xys, they are certainly edge-compatible. -- However, we do need to check that the xys' are edge-compatible with each other. | otherwise = let (x,c) = M.findMin srcCol ys = trgPart M.! c srcCol' = M.delete x $ intersectColouring srcCol (dcs M.! x) in T False xys [dfs ((x,y):xys) srcCol' trgCol' | y <- ys, let trgCol' = M.delete y (intersectColouring trgCol (dcs M.! y))] where srcPart = colourPartition srcCol trgPart = colourPartition trgCol isCompatible xys = and [([x,x'] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x,y) <- xys, (x',y') <- xys, x < x'] es' = S.fromList es dcs = M.fromAscList [(v, distanceColouring v) | v <- vs] distanceColouring u = M.fromList [(v,[c]) | (cell,c) <- zip (distancePartitionS vs es' u) [0..], v <- cell] -} distanceColouring (G vs es) u = M.fromList [(v,[c]) | (cell,c) <- zip (distancePartitionS vs es' u) [0..], v <- cell] where es' = S.fromList es intersectColouring c1 c2 = M.intersectionWith (++) c1 c2 colourPartition c = L.foldr (\(k,v) m -> M.insertWith (++) v [k] m) M.empty (M.assocs c) -- Based on McKay’s Canonical Graph Labeling Algorithm, by Stephen G. Hartke and A. J. Radcliffe -- (http://www.math.unl.edu/~aradcliffe1/Papers/Canonical.pdf) equitableRefinement g@(G vs es) p = equitableRefinement' (S.fromList es) p equitableRefinement' edgeset partition = go partition where go cells = let splits = L.zip (L.inits cells) (L.tails cells) shatterPairs = [(L.zip ci counts,ls,rs) | (ls,ci:rs) <- splits, cj <- cells, let counts = map (nbrCount cj) ci, isShatter counts] in case shatterPairs of -- by construction, the lexicographic least (i,j) comes first [] -> cells (vcs,ls,rs):_ -> let fragments = shatter vcs in go (ls ++ fragments ++ rs) isShatter (c:cs) = any (/= c) cs shatter vcs = map (map fst) $ L.groupBy (\x y -> snd x == snd y) $ L.sortBy (comparing snd) $ vcs -- Memoizing here results in about 10% speed improvement. Not worth it for loss of generality (ie requiring HasTrie instances) -- nbrCount = memo2 nbrCount' -- How many neighbours in cell does vertex have nbrCount cell vertex = length (filter (isEdge vertex) cell) isEdge u v = L.sort [u,v] `S.member` edgeset equitablePartitionSearchTree g@(G vs es) p = dfs [] p where dfs bs p = let p' = equitableRefinement' es' p in if all isSingleton p' then T True (p',bs) [] else T False (p',bs) [dfs (b:bs) p'' | (b,p'') <- splits [] p'] -- For now, we just split the first non-singleton cell we find splits ls (r:rs) | isSingleton r = splits (r:ls) rs | otherwise = let ls' = reverse ls in [(x, ls' ++ [x]:xs:rs) | (x,xs) <- picks r] es' = S.fromList es {- -- Using Data.Sequence instead of list for the partitions -- Makes no difference to speed (in fact slightly slower) equitableRefinementSeq' edgeset partition = go partition where go cells = let splits = Seq.zip (Seq.inits cells) (Seq.tails cells) shatterPairs = [(L.zip ci counts,ls,rs') | (ls,rs) <- Foldable.toList splits, (not . Seq.null) rs, let ci Seq.:< rs' = Seq.viewl rs, cj <- Foldable.toList cells, let counts = map (nbrCount cj) ci, isShatter counts] in case shatterPairs of -- by construction, the lexicographic least (i,j) comes first [] -> cells (vcs,ls,rs):_ -> let fragments = Seq.fromList (shatter vcs) in go (ls Seq.>< fragments Seq.>< rs) isShatter (c:cs) = any (/= c) cs shatter vcs = map (map fst) $ L.groupBy (\x y -> snd x == snd y) $ L.sortBy (comparing snd) $ vcs -- How many neighbours in cell does vertex have nbrCount cell vertex = length (filter (isEdge vertex) cell) isEdge u v = L.sort [u,v] `S.member` edgeset equitablePartitionSeqSearchTree g@(G vs es) p = dfs [] (Seq.fromList p) where dfs bs p = let p' = equitableRefinementSeq' es' p in if Foldable.all isSingleton p' then T True (Foldable.toList p',bs) [] else T False (Foldable.toList p',bs) [dfs (b:bs) p'' | (b,p'') <- splits p'] -- For now, we just split the first non-singleton cell we find splits cells = case Seq.findIndexL (not . isSingleton) cells of Just i -> let (ls,rs) = Seq.splitAt i cells r Seq.:< rs' = Seq.viewl rs in [(x, ls Seq.>< ([x] Seq.<| xs Seq.<| rs')) | (x,xs) <- picks r] Nothing -> error "Not possible, as we know there are non-singleton cells" es' = S.fromList es -} -- In this version, whenever we have an equitable partition, we separate out all the singleton cells and put them to one side. -- (Since the partition is equitable, singleton cells have already done any work they are going to do in shattering other cells, -- so they will no longer play any part.) -- This seems to result in about 20% speedup. equitablePartitionSearchTree2 g@(G vs es) p = dfs [] ([],p) where dfs bs (ss,cs) = let (ss',cs') = L.partition isSingleton $ equitableRefinement' es' cs ss'' = ss++ss' in case cs' of [] -> T True (ss'',bs) [] -- We just split the first non-singleton cell -- c:cs'' -> T False (ss''++cs',bs) [dfs (x:bs) (ss'',[x]:xs:cs'') | (x,xs) <- picks c] c:cs'' -> T False (cs'++ss'',bs) [dfs (x:bs) (ss'',[x]:xs:cs'') | (x,xs) <- picks c] es' = S.fromList es -- TODO: On the first level, we can use a stronger partitioning function (eg distance partitions, + see nauty manual, vertex invariants) equitableDistancePartitionSearchTree g@(G vs es) p = dfs [] p where dfs bs p = let p' = equitableRefinement' es' p in if all isSingleton p' then T True (p',bs) [] else T False (p',bs) [dfs (b:bs) p'' | (b,p'') <- splits [] p'] -- For now, we just split the first non-singleton cell we find splits ls (r:rs) | isSingleton r = splits (r:ls) rs | otherwise = [(x, p'') | let ls' = reverse ls, (x,xs) <- picks r, let p' = ls' ++ [x]:xs:rs, let p'' = filter (not . null) (intersectCells p' (dps M.! x))] es' = S.fromList es dps = M.fromAscList [(v, distancePartitionS vs es' v) | v <- vs] {- -- This is just fmap (\(p,bs) -> (p,bs,trace p)) t equitablePartitionTracedSearchTree g@(G vs es) trace p = dfs [] p where dfs bs p = let p' = equitableRefinement' es' p in if all isSingleton p' then T True (p',bs,trace p') [] else T False (p',bs,trace p') [dfs (b:bs) p'' | (b,p'') <- splits [] p'] -- For now, we just split the first non-singleton cell we find splits ls (r:rs) | isSingleton r = splits (r:ls) rs | otherwise = let ls' = reverse ls in [(x, ls' ++ [x]:xs:rs) | (x,xs) <- picks r] es' = S.fromList es -} -- Intended as a node invariant trace1 p = map (\xs@(x:_) -> (x, length xs)) $ L.group $ L.sort $ map length p equitablePartitionGraphSearchTree g@(G vs es) = equitablePartitionSearchTree g unitPartition where unitPartition = [vs] -- The incidence graph has vertices that are coloured left (points) or right (blocks). -- We are not interested in dualities (automorphisms that swap points and blocks), so we look for colour-preserving automorphisms equitablePartitionIncidenceSearchTree g@(G vs es) = equitablePartitionSearchTree g lrPartition where (lefts, rights) = partitionEithers vs lrPartition = [map Left lefts, map Right rights] leftLeaf (T False _ (t:ts)) = leftLeaf t leftLeaf (T True (p,bs) []) = (concat p, reverse bs) {- leftSpine (T False x (t:ts)) = x : leftSpine t leftSpine (T True x []) = [x] -} allLeaves (T False _ ts) = concatMap allLeaves ts allLeaves (T True (p,bs) []) = [(concat p, reverse bs)] {- partitionTransversals tree = [fromPairs (zip canonical partition) | partition <- findTransversals tree] where (_,canonical) = leftLeaf tree findTransversals (T False _ (t:ts)) = concatMap (take 1 . findTransversals) ts ++ findTransversals t findTransversals (T True (_,partition) []) = [concat partition] graphAuts5 = partitionTransversals . equitablePartitionGraphSearchTree -} -- NOT WORKING partitionBSGS0 g@(G vs es) t = (bs, findLevels t) where (p1,bs) = leftLeaf t g1 = fromPairs $ zip p1 vs g1' = g1^-1 es1 = S.fromList $ edges $ fmap (.^ g1) g -- the edges of the isomorph corresponding to p1. (S.fromList makes it unnecessary to call nf.) findLevels (T True (partition,_) []) = [] findLevels (T False (partition,_) (t:ts)) = let hs = findLevels t -- TODO: It might be better to use the b that is added in t to find the cell that splits cell@(v:vs) = head $ filter (not . isSingleton) partition -- the cell that is going to split in findLevel v hs (zip vs ts) findLevel v hs ((v',t'):vts) = if v' `elem` v .^^ hs then findLevel v hs vts else let h = find1New t' in findLevel v (h++hs) vts findLevel _ hs [] = hs find1New (T False _ ts) = take 1 $ concatMap find1New ts -- There is a leaf for every aut, but not necessarily an aut for every leaf, so we must check we have an aut -- (For example, incidenceGraphPG 2 f8 has leaf nodes which do not correspond to auts.) find1New (T True (partition,_) []) = let h = fromPairs $ zip (concat partition) vs g' = fmap (.^ h) g in if all (`S.member` es1) (edges g') then [h*g1'] else [] -- isAut h = all (`S.member` es') [e -^ h | e <- es] -- es' = S.fromList es -- Given a partition search tree, return a base and strong generating set for graph automorphism group. partitionBSGS g@(G vs es) t = (bs, findLevels t) where (canonical,bs) = leftLeaf t findLevels (T True (partition,_) []) = [] findLevels (T False (partition,_) (t:ts)) = let hs = findLevels t -- TODO: It might be better to use the b that is added in t to find the cell that splits cell@(v:vs) = head $ filter (not . isSingleton) partition -- the cell that is going to split in findLevel v hs (zip vs ts) findLevel v hs ((v',t'):vts) = if v' `elem` v .^^ hs -- TODO: Memoize this orbit then findLevel v hs vts else let h = find1New t' in findLevel v (h++hs) vts findLevel _ hs [] = hs find1New (T False _ ts) = take 1 $ concatMap find1New ts -- Some leaf nodes correspond to different isomorphs of the graph, and hence don't yield automorphisms find1New (T True (partition,_) []) = let h = fromPairs $ zip canonical (concat partition) in filter isAut [h] isAut h = all (`S.member` es') [e -^ h | e <- es] es' = S.fromList es -- The tree for g1 has leaf nodes of two different isomorphs, as does the tree for incidenceGraphPG 2 f8 -- Returns auts as Right, different isomorphs as Left -- (Must be used with the tree which doesn't put singletons to end) partitionBSGS3 g@(G vs es) t = (bs, findLevels t) where (p1,bs) = leftLeaf t findLevels (T True (partition,_) []) = [] findLevels (T False (partition,_) (t:ts)) = let hs = findLevels t -- TODO: It might be better to use the b that is added in t to find the cell that splits cell@(v:vs) = head $ filter (not . isSingleton) partition -- the cell that is going to split in findLevel v hs (zip vs ts) findLevel v hs ((v',t'):vts) = if v' `elem` v .^^ rights hs then findLevel v hs vts else let h = find1New t' in findLevel v (h++hs) vts findLevel _ hs [] = hs find1New (T False _ ts) = take 1 $ concatMap find1New ts -- There is a leaf for every aut, but not necessarily an aut for every leaf, so we must check we have an aut -- (For example, incidenceGraphPG 2 f8 has leaf nodes which do not correspond to auts.) find1New (T True (partition,_) []) = let h = fromPairs $ zip p1 (concat partition) in if isAut h then [Right h] else [Left h] isAut h = all (`S.member` es') [e -^ h | e <- es] es' = S.fromList es -- TODO: I think we are only justified in doing find1New (ie only finding 1) if we *do* find an aut. -- If we don't, we should potentially keep looking in that subtree -- (See section 6 of paper. If we find isomorphic leaves, then the two subtrees of their common parent are isomorphic, -- so no need to continue searching the second.) -- This is using a node invariant to do more pruning. -- However, seems to be much slower on very regular graphs (where perhaps there is no pruning to be done) -- (This suggests that perhaps using fmap is not good - perhaps a space leak?) -- (Or perhaps it's just that calculating and comparing the node invariants is expensive) -- TODO: Perhaps use something simpler, like just the number of cells in the partition partitionBSGS2 g@(G vs es) t = (bs, findLevels t') where t' = fmap (\(p,bs) -> (p,bs,trace1 p)) t trace1 = length -- the number of cells in the partition (canonical,bs) = leftLeaf t findLevels (T True (partition,_,_) []) = [] findLevels (T False (partition,_,_) (t:ts)) = let (T _ (_,_,trace) _) = t hs = findLevels t -- TODO: It might be better to use the b that is added in t to find the cell that splits cell@(v:vs) = head $ filter (not . isSingleton) partition -- the cell that is going to split vts = filter (\(_,T _ (_,_,trace') _) -> trace == trace') $ zip vs ts in findLevel v hs vts findLevel v hs ((v',t'):vts) = if v' `elem` v .^^ hs then findLevel v hs vts else let h = find1New t' in findLevel v (h++hs) vts findLevel _ hs [] = hs find1New (T False _ ts) = take 1 $ concatMap find1New ts -- There is a leaf for every aut, but not necessarily an aut for every leaf, so we must check we have an aut -- (For example, incidenceGraphPG 2 f8 has leaf nodes which do not correspond to auts.) -- (The graph g1, below, shows a simple example where this will happen.) find1New (T True (partition,_,_) []) = let h = fromPairs $ zip canonical (concat partition) in filter isAut [h] isAut h = all (`S.member` es') [e -^ h | e <- es] es' = S.fromList es graphAuts7 g = (partitionBSGS g) (equitablePartitionGraphSearchTree g) -- This is faster on kneser graphs, but slower on incidenceGraphPG graphAuts8 g = (partitionBSGS g) (equitableDistancePartitionSearchTree g [vertices g]) -- This is a graph where the node invariant should cause pruning. -- The initial equitable partition will be [[1..8],[9,10]], because it can do no better than distinguish by degree -- However, vertices 1..4 and vertices 5..8 are in fact different (there is no aut that takes one set to the other), -- so the subtrees starting 1..4 have a different invariant to those starting 5..8 g1 = G [1..10] [[1,2],[1,3],[1,9],[2,4],[2,10],[3,4],[3,9],[4,10],[5,6],[5,8],[5,9],[6,7],[6,10],[7,8],[7,9],[8,10]] g1' = nf $ fmap (\x -> if x <= 4 then x+4 else if x <= 8 then x-4 else x) g1 -- G [1..10] [[1,2],[1,4],[1,9],[2,3],[2,10],[3,4],[3,9],[4,10],[5,6],[5,7],[5,9],[6,8],[6,10],[7,8],[7,9],[8,10]] g2 = G [1..12] [[1,2],[1,4],[1,11],[2,3],[2,12],[3,4],[3,11],[4,12],[5,6],[5,8],[5,11],[6,9],[6,12],[7,8],[7,10],[7,11],[8,12],[9,10],[9,11],[10,12]] -- NOT WORKING: This fails to find the isomorphism between g1 and g1' above. -- Instead of using left leaf, we need to find the canonical isomorph, as described in the paper. -- (In a graph where not all leaves lead to automorphisms, we might happen to end up with non-isomorphic left leaves) maybeGraphIso g1 g2 = let (vs1,_) = (leftLeaf . equitablePartitionGraphSearchTree) g1 (vs2,_) = (leftLeaf . equitablePartitionGraphSearchTree) g2 f = M.fromList (zip vs1 vs2) in if length vs1 == length vs2 && (nf . fmap (f M.!)) g1 == g2 then Just f else Nothing -- AUTS OF INCIDENCE STRUCTURE VIA INCIDENCE GRAPH -- This code is nearly identical to the corresponding graphAuts code, with two exceptions: -- 1. We start by partitioning into lefts and rights. -- This avoids left-right crossover auts, which while they are auts of the graph, -- are not auts of the incidence structure -- 2. When labelling the nodes, we filter out Right blocks, and unLeft the Left points incidenceAutsDistancePartitionSearchTree g@(G vs es) = dfs [] (lrPart, lrPart) where dfs xys (srcPart,trgPart) | all isSingleton srcPart = let xys' = zip (concat srcPart) (concat trgPart) in T (isCompatible xys') (unLeft $ xys++xys') [] -- Since the xys' are distance-compatible with the xys, they are certainly edge-compatible. -- However, we do need to check that the xys' are edge-compatible with each other. | otherwise = let (x:xs):srcCells = srcPart yys :trgCells = trgPart srcPart' = intersectCells (xs : srcCells) (dps M.! x) in T False (unLeft xys) -- the L.sort in the following line is so that we traverse vertices in natural order [dfs ((x,y):xys) ((unzip . L.sort) (zip (filter (not . null) srcPart') (filter (not . null) trgPart'))) | (y,ys) <- picks yys, let trgPart' = intersectCells (ys : trgCells) (dps M.! y), map length srcPart' == map length trgPart'] isCompatible xys = and [([x,x'] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x,y) <- xys, (x',y') <- xys, x < x'] (lefts, rights) = partitionEithers vs lrPart = [map Left lefts, map Right rights] -- Partition the vertices into left and right, to exclude crossover auts unLeft xys = [(x,y) | (Left x, Left y) <- xys] -- also filters out Rights es' = S.fromList es dps = M.fromList [(v, distancePartitionS vs es' v) | v <- vs] -- |Given the incidence graph of an incidence structure between points and blocks -- (for example, a set system), -- @incidenceAuts g@ returns a strong generating set for the automorphism group of the incidence structure. -- The generators are represented as permutations of the points. -- The incidence graph should be represented with the points on the left and the blocks on the right. incidenceAuts :: (Ord p, Ord b) => Graph (Either p b) -> [Permutation p] incidenceAuts = filter (/= p []) . strongTerminals . incidenceAutsDistancePartitionSearchTree -- TODO: Filter out rights, map unLeft - to bs and gs incidenceAuts2 g = (partitionBSGS g) (equitablePartitionIncidenceSearchTree g) where unLeft (Left x) = x -- map (\g -> fromPairs . map (\(Left x, Left y) -> (x,y)) . filter (\(x,y) -> isLeft x) . toPairs) gs -- GRAPH ISOMORPHISMS -- !! not yet using equitable partitions, so could probably be more efficient -- graphIsos :: (Ord a, Ord b) => Graph a -> Graph b -> [[(a,b)]] graphIsos g1 g2 | length cs1 /= length cs2 = [] | otherwise = graphIsos' cs1 cs2 where cs1 = map (inducedSubgraph g1) (components g1) cs2 = map (inducedSubgraph g2) (components g2) graphIsos' (ci:cis) cjs = [iso ++ iso' | (cj,cjs') <- picks cjs, iso <- graphIsosCon ci cj, iso' <- graphIsos' cis cjs'] graphIsos' [] [] = [[]] -- isos between connected graphs graphIsosCon g1 g2 | isConnected g1 && isConnected g2 = concat [dfs [] (distancePartition g1 v1) (distancePartition g2 v2) | v1 <- take 1 (vertices g1), v2 <- vertices g2] -- the take 1 handles the case where g1 is the null graph | otherwise = error "graphIsosCon: either or both graphs are not connected" where dfs xys p1 p2 | map length p1 /= map length p2 = [] | otherwise = let p1' = filter (not . null) p1 p2' = filter (not . null) p2 in if all isSingleton p1' then let xys' = xys ++ zip (concat p1') (concat p2') in if isCompatible xys' then [xys'] else [] else let (x:xs):p1'' = p1' ys:p2'' = p2' in concat [dfs ((x,y):xys) (intersectCells (xs : p1'') (dps1 M.! x)) (intersectCells (ys': p2'') (dps2 M.! y)) | (y,ys') <- picks ys] isCompatible xys = and [([x,x'] `S.member` es1) == (L.sort [y,y'] `S.member` es2) | (x,y) <- xys, (x',y') <- xys, x < x'] dps1 = M.fromAscList [(v, distancePartitionS vs1 es1 v) | v <- vs1] dps2 = M.fromAscList [(v, distancePartitionS vs2 es2 v) | v <- vs2] -- dps1 = M.fromList [(v, distancePartition g1 v) | v <- vertices g1] -- dps2 = M.fromList [(v, distancePartition g2 v) | v <- vertices g2] vs1 = vertices g1 vs2 = vertices g2 es1 = S.fromList $ edges g1 es2 = S.fromList $ edges g2 -- |Are the two graphs isomorphic? isGraphIso :: (Ord a, Ord b) => Graph a -> Graph b -> Bool isGraphIso g1 g2 = (not . null) (graphIsos g1 g2) -- !! If we're only interested in seeing whether or not two graphs are iso, -- !! then the cost of calculating distancePartitions may not be warranted -- !! (see Math.Combinatorics.Poset: orderIsos01 versus orderIsos) -- the following differs from graphIsos in only two ways -- we avoid Left, Right crossover isos, by insisting that a Left is taken to a Left (first two lines) -- we return only the action on the Lefts, and unLeft it -- incidenceIsos :: (Ord p1, Ord b1, Ord p2, Ord b2) => -- Graph (Either p1 b1) -> Graph (Either p2 b2) -> [[(p1,p2)]] incidenceIsos g1 g2 | length cs1 /= length cs2 = [] | otherwise = incidenceIsos' cs1 cs2 where cs1 = map (inducedSubgraph g1) (filter (not . null . lefts) $ components g1) cs2 = map (inducedSubgraph g2) (filter (not . null . lefts) $ components g2) incidenceIsos' (ci:cis) cjs = [iso ++ iso' | (cj,cjs') <- picks cjs, iso <- incidenceIsosCon ci cj, iso' <- incidenceIsos' cis cjs'] incidenceIsos' [] [] = [[]] incidenceIsosCon g1 g2 | isConnected g1 && isConnected g2 = concat [dfs [] (distancePartition g1 v1) (distancePartition g2 v2) | v1@(Left _) <- take 1 (vertices g1), v2@(Left _) <- vertices g2] -- g1 may have no vertices | otherwise = error "incidenceIsos: one or both graphs not connected" where dfs xys p1 p2 | map length p1 /= map length p2 = [] | otherwise = let p1' = filter (not . null) p1 p2' = filter (not . null) p2 in if all isSingleton p1' then let xys' = xys ++ zip (concat p1') (concat p2') in if isCompatible xys' then [[(x,y) | (Left x, Left y) <- xys']] else [] else let (x:xs):p1'' = p1' ys:p2'' = p2' in concat [dfs ((x,y):xys) (intersectCells (xs : p1'') (dps1 M.! x)) (intersectCells (ys': p2'') (dps2 M.! y)) | (y,ys') <- picks ys] isCompatible xys = and [([x,x'] `S.member` es1) == (L.sort [y,y'] `S.member` es2) | (x,y) <- xys, (x',y') <- xys, x < x'] dps1 = M.fromList [(v, distancePartition g1 v) | v <- vertices g1] dps2 = M.fromList [(v, distancePartition g2 v) | v <- vertices g2] es1 = S.fromList $ edges g1 es2 = S.fromList $ edges g2 -- |Are the two incidence structures represented by these incidence graphs isomorphic? isIncidenceIso :: (Ord p1, Ord b1, Ord p2, Ord b2) => Graph (Either p1 b1) -> Graph (Either p2 b2) -> Bool isIncidenceIso g1 g2 = (not . null) (incidenceIsos g1 g2) HaskellForMaths-0.4.8/Math/Combinatorics/Hypergraph.hs0000644000000000000000000002144612514742102021077 0ustar0000000000000000-- Copyright (c) 2009, David Amos. All rights reserved. -- |A module defining a type for hypergraphs. module Math.Combinatorics.Hypergraph where import qualified Data.List as L import Math.Common.ListSet import Math.Core.Utils (combinationsOf) import Math.Combinatorics.Graph hiding (incidenceMatrix) import Math.Algebra.Group.PermutationGroup (orbitB, p) -- needed for construction of Coxeter group -- not used in this module, only in GHCi import Math.Algebra.Field.Base import Math.Algebra.Field.Extension import Math.Combinatorics.Design hiding (incidenceMatrix, incidenceGraph, dual, isSubset, fanoPlane) -- set system or hypergraph data Hypergraph a = H [a] [[a]] deriving (Eq,Ord,Show) hypergraph xs bs | isSetSystem xs bs = H xs bs toHypergraph xs bs = H xs' bs' where xs' = L.sort xs bs' = L.sort $ map L.sort bs -- this still doesn't guarantee that all bs are subset of xs -- |Is this hypergraph uniform - meaning that all blocks are of the same size isUniform :: (Ord a) => Hypergraph a -> Bool isUniform h@(H xs bs) = isSetSystem xs bs && same (map length bs) same (x:xs) = all (==x) xs same [] = True fromGraph (G vs es) = H vs es fromDesign (D xs bs) = H xs (L.sort bs) -- !! should insist that designs have blocks in order -- !! dual probably doesn't guarantee this at present {- dual (H xs bs) = toHypergraph (bs, map beta xs) where beta x = filter (x `elem`) bs -} -- INCIDENCE GRAPH -- data Incidence a = P a | B [a] deriving (Eq, Ord, Show) -- compare Design, where we just use Left, Right -- Also called the Levi graph incidenceGraph :: (Ord a) => Hypergraph a -> Graph (Either a [a]) incidenceGraph (H xs bs) = G vs es where vs = map Left xs ++ map Right bs es = L.sort [ [Left x, Right b] | b <- bs, x <- b] -- INCIDENCE MATRIX -- !! why are we doing this the other way round to the literature ?? -- incidence matrix of a hypergraph -- (rows and columns indexed by edges and vertices respectively) -- (warning: in the literature it is often the other way round) incidenceMatrix (H vs es) = [ [if v `elem` e then 1 else 0 | v <- vs] | e <- es] fromIncidenceMatrix m = H vs es where n = L.genericLength $ head m vs = [1..n] es = L.sort $ map edge m edge row = [v | (1,v) <- zip row vs] -- isTwoGraph -- We can represent various incidence structures as hypergraphs, -- by identifying the lines with the sets of points that they contain isPartialLinearSpace :: (Ord a) => Hypergraph a -> Bool isPartialLinearSpace h@(H ps ls) = isSetSystem ps ls && all ( (<=1) . length ) [filter (pair `isSubset`) ls | pair <- combinationsOf 2 ps] -- any two points are incident with at most one line -- Godsil & Royle, p79 -- |Is this hypergraph a projective plane - meaning that any two lines meet in a unique point, -- and any two points lie on a unique line isProjectivePlane :: (Ord a) => Hypergraph a -> Bool isProjectivePlane h@(H ps ls) = isSetSystem ps ls && all ( (==1) . length) [intersect l1 l2 | [l1,l2] <- combinationsOf 2 ls] && -- any two lines meet in a unique point all ( (==1) . length) [ filter ([p1,p2] `isSubset`) ls | [p1,p2] <- combinationsOf 2 ps] -- any two points lie in a unique line -- |Is this hypergraph a projective plane with a triangle. -- This is a weak non-degeneracy condition, which eliminates all points on the same line, or all lines through the same point. isProjectivePlaneTri :: (Ord a) => Hypergraph a -> Bool isProjectivePlaneTri h@(H ps ls) = isProjectivePlane h && any triangle (combinationsOf 3 ps) where triangle t@[p1,p2,p3] = (not . null) [l | l <- ls, [p1,p2] `isSubset` l, p3 `notElem` l] && -- there is a line containing p1,p2 but not p3 (not . null) [l | l <- ls, [p1,p3] `isSubset` l, p2 `notElem` l] && (not . null) [l | l <- ls, [p2,p3] `isSubset` l, p1 `notElem` l] -- |Is this hypergraph a projective plane with a quadrangle. -- This is a stronger non-degeneracy condition. isProjectivePlaneQuad :: (Ord a) => Hypergraph a -> Bool isProjectivePlaneQuad h@(H ps ls) = isProjectivePlane h && any quadrangle (combinationsOf 4 ps) where quadrangle q = all (not . collinear) (combinationsOf 3 q) -- no three points collinear collinear ps = any (ps `isSubset`) ls -- > isProjectivePlaneQuad $ fromDesign $ pg2 f2 -- True -- GENERALIZED QUADRANGLES -- Godsil & Royle p81 isGeneralizedQuadrangle :: (Ord a) => Hypergraph a -> Bool isGeneralizedQuadrangle h@(H ps ls) = isPartialLinearSpace h && all (\(l,p) -> unique [p' | p' <- l, collinear (pair p p')]) [(l,p) | l <- ls, p <- ps, p `notElem` l] && -- given any line l and point p not on l, there is a unique point p' on l with p and p' collinear any (not . collinear) (powerset ps) && -- there are non collinear points any (not . concurrent) (powerset ls) -- there are non concurrent lines where unique xs = length xs == 1 pair x y = if x < y then [x,y] else [y,x] collinear ps = any (ps `isSubset`) ls concurrent ls = any (\p -> all (p `elem`) ls) ps grid m n = H ps ls where ps = [(i,j) | i <- [1..m], j <- [1..n] ] ls = L.sort $ [ [(i,j) | i <- [1..m] ] | j <- [1..n] ] -- horizontal lines ++ [ [(i,j) | j <- [1..n] ] | i <- [1..m] ] -- vertical lines dualGrid m n = fromGraph $ kb m n -- the lines of the grid are the points of the dual, and the points of the grid are the lines of the dual isGenQuadrangle' h = diameter g == 4 && girth g == 8 -- !! plus non-degeneracy conditions where g = incidenceGraph h -- CONFIGURATIONS -- http://en.wikipedia.org/wiki/Projective_configuration -- |Is this hypergraph a (projective) configuration. isConfiguration :: (Ord a) => Hypergraph a -> Bool isConfiguration h@(H ps ls) = isUniform h && -- a set system, with each line incident with the same number of points same [length (filter (p `elem`) ls) | p <- ps] -- each point is incident with the same number of lines fanoPlane :: Hypergraph Integer fanoPlane = toHypergraph [1..7] [[1,2,4],[2,3,5],[3,4,6],[4,5,7],[5,6,1],[6,7,2],[7,1,3]] -- |The Heawood graph is the incidence graph of the Fano plane heawoodGraph :: Graph (Either Integer [Integer]) heawoodGraph = incidenceGraph fanoPlane desarguesConfiguration :: Hypergraph [Integer] desarguesConfiguration = H xs bs where xs = combinationsOf 2 [1..5] bs = [ [x | x <- xs, x `isSubset` b] | b <- combinationsOf 3 [1..5] ] desarguesGraph :: Graph (Either [Integer] [[Integer]]) desarguesGraph = incidenceGraph desarguesConfiguration pappusConfiguration :: Hypergraph Integer pappusConfiguration = H xs bs where xs = [1..9] bs = L.sort [ [1,2,3], [4,5,6], [7,8,9], [1,5,9], [1,6,8], [2,4,9], [3,4,8], [2,6,7], [3,5,7] ] pappusGraph :: Graph (Either Integer [Integer]) pappusGraph = incidenceGraph pappusConfiguration -- !! no particular reason why the following is here rather than elsewhere {- triples = combinationsOf 3 [1..7] heptads = [ [a,b,c,d,e,f,g] | a <- triples, b <- triples, a < b, meetOne b a, c <- triples, b < c, all (meetOne c) [a,b], d <- triples, c < d, all (meetOne d) [a,b,c], e <- triples, d < e, all (meetOne e) [a,b,c,d], f <- triples, e < f, all (meetOne f) [a,b,c,d,e], g <- triples, f < g, all (meetOne g) [a,b,c,d,e,f], foldl intersect [1..7] [a,b,c,d,e,f,g] == [] ] where meetOne x y = length (intersect x y) == 1 -- each pair of triples meet in exactly one point, and there is no point in all of them - Godsil & Royle p69 -- (so these are the projective planes over 7 points) -} -- Godsil & Royle p69 coxeterGraph :: Graph [Integer] coxeterGraph = G vs es where g = p [[1..7]] vs = L.sort $ concatMap (orbitB [g]) [[1,2,4],[3,5,7],[3,6,7],[5,6,7]] es = [ e | e@[v1,v2] <- combinationsOf 2 vs, disjoint v1 v2] -- is this the incidence graph of a hypergraph involving heptads over triples? -- edges of K6 duads = combinationsOf 2 [1..6] -- 1-factors of K6 -- 15 different ways to pick three disjoint duads from [1..6] synthemes = [ [d1,d2,d3] | d1 <- duads, d2 <- duads, d2 > d1, disjoint d1 d2, d3 <- duads, d3 > d2, disjoint d1 d3, disjoint d2 d3 ] -- |The Tutte-Coxeter graph, also called the Tutte 8-cage tutteCoxeterGraph :: Graph (Either [Integer] [[Integer]]) tutteCoxeterGraph = incidenceGraph $ H duads synthemes -- Also known as line graph intersectionGraph (H xs bs) = G vs es where vs = bs es = [pair | pair@[b1,b2] <- combinationsOf 2 bs, not (disjoint b1 b2)]HaskellForMaths-0.4.8/Math/Combinatorics/IncidenceAlgebra.hs0000644000000000000000000003404412514742102022123 0ustar0000000000000000-- Copyright (c) 2011-2015, David Amos. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, NoMonomorphismRestriction #-} module Math.Combinatorics.IncidenceAlgebra where import Prelude hiding ( (*>) ) import Math.Core.Utils import Math.Combinatorics.Digraph import Math.Combinatorics.Poset import Math.Algebra.Field.Base import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures import Data.List as L import qualified Data.Map as M import qualified Data.Set as S -- INTERVALS IN A POSET -- |A type to represent an interval in a poset. The (closed) interval [x,y] is the set {z | x <= z <= y} within the poset. -- Note that the \"empty interval\" is not an interval - that is, the interval [x,y] is only defined for x <= y. -- The (closed) intervals within a poset form a basis for the incidence algebra as a k-vector space. data Interval a = Iv (Poset a) (a,a) instance Eq a => Eq (Interval a) where Iv _ (a,b) == Iv _ (a',b') = (a,b) == (a',b') -- we don't bother to check that they are from the same poset instance Ord a => Ord (Interval a) where compare (Iv _ (a,b)) (Iv _ (a',b')) = compare (a,b) (a',b') instance Show a => Show (Interval a) where show (Iv _ (a,b)) = "Iv (" ++ show a ++ "," ++ show b ++ ")" {- -- !! This should probably be called heightPartition not rank -- rank is only well-defined if we don't have cover edges jumping levels rankPartition (Iv poset@(Poset (set,po)) (a,b)) = rankPartition' S.empty [a] (L.delete a iv) where rankPartition' _ level [] = [level] rankPartition' interior boundary exterior = let interior' = S.union interior (S.fromList boundary) boundary' = toSet [v | (u,v) <- es, u `elem` boundary, all (`S.member` interior') (predecessors es v)] exterior' = exterior \\ boundary' in boundary : rankPartition' interior' boundary' exterior' iv = interval poset (a,b) (_,es) = coverGraph (Poset (iv,po)) predecessors es v = [u | (u,v') <- es, v' == v] -- !! Can be written more efficiently, eg by memoising predecessors and successors, culling covers as we use them, etc. -- The point of rankPartition function is to enable a slightly faster isomorphism test -- Could do even better by refining with (indegree, outdegree) -} -- The sub-poset defined by an interval ivPoset (Iv poset@(Poset (_,po)) (x,y)) = Poset (interval poset (x,y), po) intervalIsos iv1 iv2 = orderIsos (ivPoset iv1) (ivPoset iv2) isIntervalIso iv1 iv2 = isOrderIso (ivPoset iv1) (ivPoset iv2) -- we're only really interested in comparing intervals in the same poset {- intervalIsoMap1 poset = intervalIsoMap' M.empty [Iv poset xy | xy <- L.sort (intervals poset)] where intervalIsoMap' m (iv:ivs) = let reps = [iv' | iv' <- M.keys m, m M.! iv' == Nothing, iv `isIntervalIso` iv'] in if null reps then intervalIsoMap' (M.insert iv Nothing m) ivs else let [iv'] = reps in intervalIsoMap' (M.insert iv (Just iv') m) ivs intervalIsoMap' m [] = m -} -- A poset on n vertices has at most n(n+1)/2 intervals -- In the worst case, we might have to compare each interval to all earlier intervals -- Hence this is O(n^4) intervalIsoMap poset = isoMap where ivs = [Iv poset xy | xy <- intervals poset] isoMap = M.fromList [(iv, isoMap' iv) | iv <- ivs] isoMap' iv = let reps = [iv' | iv' <- ivs, iv' < iv, isoMap M.! iv' == Nothing, iv `isIntervalIso` iv'] in if null reps then Nothing else let [rep] = reps in Just rep -- Once an interval is identified as a representative, it is likely to take part in many isomorphism tests -- Whereas most intervals take part in only one -- So perhaps we could make this more efficient by having an isomorphism test which uses a height partition -- for the LHS but not for the RHS? -- |List representatives of the order isomorphism classes of intervals in a poset intervalIsoClasses :: (Ord a) => Poset a -> [Interval a] intervalIsoClasses poset = [iv | iv <- M.keys isoMap, isoMap M.! iv == Nothing] where isoMap = intervalIsoMap poset -- INCIDENCE ALGEBRA -- |The incidence algebra of a poset is the free k-vector space having as its basis the set of intervals in the poset, -- with multiplication defined by concatenation of intervals. -- The incidence algebra can also be thought of as the vector space of functions from intervals to k, with multiplication -- defined by the convolution (f*g)(x,y) = sum [ f(x,z) g(z,y) | x <= z <= y ]. instance (Eq k, Num k, Ord a) => Algebra k (Interval a) where -- |Note that we are not able to give a generic definition of unit for the incidence algebra, -- because it depends on which poset we are working in, -- and that information is encoded at the value level rather than the type level. See unitIA. unit 0 = zerov -- so that sum works -- unit x = x *> sumv [return (Iv (a,a)) | a <- poset] -- the delta function -- but we can't know from the types alone which poset we are working in mult = linear mult' where mult' (Iv poset (a,b), Iv _ (c,d)) = if b == c then return (Iv poset (a,d)) else zerov -- So multiplication in the incidence algebra is about composition of intervals -- |The unit of the incidence algebra of a poset 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 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 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 -- See Stanley, Enumerative Combinatorics I, p115ff, for more similar -- calculate the mobius function of a poset: naive implementation muIA1 poset@(Poset (set,po)) = sum [mu (x,y) *> return (Iv poset (x,y)) | x <- set, y <- set] 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 -- calculate the mobius function of a poset, with memoization -- |The Mobius function of a poset 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] | otherwise = 0 mus = M.fromList [((x,y), mu (x,y)) | x <- set, y <- set] -- calculate the inverse of a function in the incidence algebra: naive implementation invIA1 f | f == zerov = error "invIA 0" | any (==0) [f' (x,x) | x <- set] = error "invIA: not invertible" | otherwise = g where (Iv poset@(Poset (set,po)) _,_) = head $ terms f f' (x,y) = coeff (Iv poset (x,y)) f g = sumv [g' xy *> return (Iv poset xy) | xy <- intervals poset] g' (x,y) | x == y = 1 / f' (x,x) | otherwise = (-1 / f' (x,x)) * sum [f' (x,z) * g' (z,y) | z <- interval poset (x,y), x /= z] -- 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 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 where (Iv poset@(Poset (set,po)) _,_) = head $ terms f f' (x,y) = coeff (Iv poset (x,y)) f g = sumv [g' xy *> return (Iv poset xy) | xy <- intervals poset] g' (x,y) | x == y = 1 / f' (x,x) | 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] 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, 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, Show a) => Poset a -> Vect Q (Interval a) numMaximalChainsIA poset = (unitIA poset <-> etaIA poset)^-1 -- In order to quickCheck this, we would need -- (i) Custom Arbitrary instance - which uses only valid intervals for the poset (ie elts of the basis) -- (ii) Custom quickCheck property, which uses the correct unit -- SOME KNOWN MOBIUS FUNCTIONS muC n = sum [mu' (a,b) *> return (Iv poset (a,b)) | (a,b) <- intervals poset] where mu' (a,b) | a == b = 1 | a+1 == b = -1 | otherwise = 0 poset = chainN n muB n = sumv [(-1)^(length b - length a) *> return (Iv poset (a,b)) | (a,b) <- intervals poset] where poset = posetB n -- van Lint & Wilson p335 muL n fq = sumv [ ( (-1)^k * q^(k*(k-1) `div` 2) ) *> return (Iv poset (a,b)) | (a,b) <- intervals poset, let k = length b - length a ] -- the difference in dimensions where q = length fq poset = posetL n fq -- van Lint & Wilson p335 -- INCIDENCE COALGEBRA -- Schmitt, Incidence Hopf Algebras instance (Eq k, Num k, Ord a) => Coalgebra k (Interval a) where counit = unwrap . linear counit' where counit' (Iv _ (x,y)) = (if x == y then 1 else 0) *> return () comult = linear comult' where comult' (Iv poset (x,z)) = sumv [return (Iv poset (x,y), Iv poset (y,z)) | y <- interval poset (x,z)] -- So comultiplication in the incidence coalgebra is about decomposition of intervals into subintervals -- But for incidence Hopf algebras, Schmitt wants the basis elts to be isomorphism classes of intervals, not intervals themselves -- (ie unlabelled intervals) -- |@toIsoClasses@ is the linear map from the incidence Hopf algebra of a poset to itself, -- in which each interval is mapped to (the minimal representative of) its isomorphism class. -- Thus the result can be considered as a linear combination of isomorphism classes of intervals, -- rather than of intervals themselves. -- Note that if this operation is to be performed repeatedly for the same poset, -- then it is more efficient to use @toIsoClasses' poset@, which memoizes the isomorphism class lookup table. toIsoClasses :: (Eq k, Num k, Ord a) => Vect k (Interval a) -> Vect k (Interval a) toIsoClasses v | v == zerov = zerov | otherwise = toIsoClasses' poset v where (Iv poset _, _) = head $ terms v -- |Given a poset, @toIsoClasses' poset@ is the linear map from the incidence Hopf algebra of the poset to itself, -- in which each interval is mapped to (the minimal representative of) its isomorphism class. toIsoClasses' :: (Eq k, Num k, Ord a) => Poset a -> Vect k (Interval a) -> Vect k (Interval a) toIsoClasses' poset = linear isoRep where isoRep iv = case isoMap M.! iv of Nothing -> return iv Just iv' -> return iv' isoMap = intervalIsoMap poset {- -- for example: > toIsoClasses $ zetaIA $ posetP 4 15Iv ([[1],[2],[3],[4]],[[1],[2],[3],[4]])+31Iv ([[1],[2],[3],[4]],[[1],[2],[3,4]])+10Iv ([[1],[2],[3],[4]],[[1],[2,3,4]])+3Iv ([[1],[2],[3],[4]],[[1,2],[3,4]])+Iv ([[1],[2],[3],[4]],[[1,2,3,4]]) -- Can we use this to solve "counting squares" problems > let b3 = comult $ return $ Iv (posetB 3) ([],[1,2,3]) > let isoB3 = toIsoClasses' $ posetB 3 > (isoB3 `tf` isoB3) b3 (Iv ([],[]),Iv ([],[1,2,3]))+3(Iv ([],[1]),Iv ([],[1,2]))+3(Iv ([],[1,2]),Iv ([],[1]))+(Iv ([],[1,2,3]),Iv ([],[])) -- The incidence coalgebra of the binomial poset is isomorphic to the binomial coalgebra -- if we just want to get the coefficients, we don't need to use comult: > let poset@(Poset (set,po)) = posetB 3 in toIsoClasses $ sumv [return (Iv poset ([],x)) | x <- set] Iv ([],[])+3Iv ([],[1])+3Iv ([],[1,2])+Iv ([],[1,2,3]) > let n = 4; p = comult $ return $ Iv (posetP n) ([[i] | i<- [1..n]],[[1..n]]); iso = toIsoClasses' (posetP n) in (iso `tf` iso) p (Iv ([[1],[2],[3],[4]],[[1],[2],[3],[4]]),Iv ([[1],[2],[3],[4]],[[1,2,3,4]]))+ 6(Iv ([[1],[2],[3],[4]],[[1],[2],[3,4]]),Iv ([[1],[2],[3],[4]],[[1],[2,3,4]]))+ 4(Iv ([[1],[2],[3],[4]],[[1],[2,3,4]]),Iv ([[1],[2],[3],[4]],[[1],[2],[3,4]]))+ 3(Iv ([[1],[2],[3],[4]],[[1,2],[3,4]]),Iv ([[1],[2],[3],[4]],[[1],[2],[3,4]]))+ (Iv ([[1],[2],[3],[4]],[[1,2,3,4]]),Iv ([[1],[2],[3],[4]],[[1],[2],[3],[4]])) -- These are multinomial coefficients, OEIS A178867: 1; 1,1; 1,3,1; 1,6,4,3,1; 1,10,10,15,5,10,1; ... -- Although A036040, which is the same up to ordering, seems a better match. (Our order is fairly arbitrary) > let n = 4; p = comult $ return $ Iv (posetL n f2) ([],[[1 :: F2,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]); iso = toIsoClasses' (posetL n f2) in (iso `tf` iso) p (Iv ([],[]),Iv ([],[[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]))+ 15(Iv ([],[[0,0,0,1]]),Iv ([],[[0,1,0,0],[0,0,1,0],[0,0,0,1]]))+ 35(Iv ([],[[0,0,1,0],[0,0,0,1]]),Iv ([],[[0,0,1,0],[0,0,0,1]]))+ 15(Iv ([],[[0,1,0,0],[0,0,1,0],[0,0,0,1]]),Iv ([],[[0,0,0,1]]))+ (Iv ([],[[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]),Iv ([],[])) -- With L n fq, we get the q-binomial coefficients, eg OEIS A022166: 1; 1, 1; 1, 3, 1; 1, 7, 7, 1; 1, 15, 35, 15, 1 -} -- This still isn't quite what Schmitt wants -- Schmitt, IHA, p6 -- The incidence Hopf algebra should have as its basis isomorphism classes of intervals, not intervals -- The mult is defined as direct product of posets HaskellForMaths-0.4.8/Math/Combinatorics/LatinSquares.hs0000644000000000000000000001200012514742102021363 0ustar0000000000000000-- Copyright (c) David Amos, 2009. All rights reserved. module Math.Combinatorics.LatinSquares where import qualified Data.List as L import qualified Data.Set as S import qualified Data.Map as M -- import Math.Combinatorics.FiniteGeometry import Math.Combinatorics.Design import Math.Algebra.Field.Base import Math.Algebra.Field.Extension import Math.Algebra.LinearAlgebra (fMatrix') import Math.Combinatorics.Graph import Math.Combinatorics.GraphAuts import Math.Combinatorics.StronglyRegularGraph import Math.Core.Utils (combinationsOf) -- LATIN SQUARES findLatinSqs :: (Eq a) => [a] -> [[[a]]] findLatinSqs xs = findLatinSqs' 1 [xs] where n = length xs findLatinSqs' i rows | i == n = [reverse rows] | otherwise = concat [findLatinSqs' (i+1) (row:rows) | row <- findRows (L.transpose rows) [] xs] findRows (col:cols) ls rs = concat [findRows cols (r:ls) (L.delete r rs) | r <- rs, r `notElem` col] findRows [] ls _ = [reverse ls] isLatinSq :: (Ord a) => [[a]] -> Bool isLatinSq rows = all isOneOfEach rows && all isOneOfEach cols where cols = L.transpose rows isOneOfEach xs = length xs == S.size (S.fromList xs) -- The incidence graph of a latin square -- It is distance-regular -- Godsil & Royle p69 incidenceGraphLS l = graph (vs,es) where n = length l -- the order of the latin square vs = [ (i, j, l ! (i,j)) | i <- [1..n], j <- [1..n] ] es = [ [v1,v2] | [v1@(i,j,lij), v2@(i',j',lij')] <- combinationsOf 2 vs, i == i' || j == j' || lij == lij' ] m ! (i,j) = m !! (i-1) !! (j-1) incidenceGraphLS' l = graph (vs,es) where n = length l -- the order of the latin square vs = [ (i, j) | i <- [1..n], j <- [1..n] ] es = [ [v1,v2] | [v1@(i,j), v2@(i',j')] <- combinationsOf 2 vs, i == i' || j == j' || l' M.! (i,j) == l' M.! (i',j') ] l' = M.fromList [ ( (i,j), l !! (i-1) !! (j-1) ) | i <- [1..n], j <- [1..n] ] -- vertices are grid positions -- adjacent if they're in the same row, same column, or have the same entry -- ORTHOGONAL AND MUTUALLY ORTHOGONAL LATINS SQUARES -- |Are the two latin squares orthogonal? isOrthogonal :: (Ord a, Ord b) => [[a]] -> [[b]] -> Bool isOrthogonal greeks latins = isOneOfEach pairs where pairs = zip (concat greeks) (concat latins) findMOLS k lsqs = findMOLS' k [] lsqs where findMOLS' 0 ls _ = [reverse ls] findMOLS' i ls (r:rs) = if all (isOrthogonal r) ls then findMOLS' (i-1) (r:ls) rs ++ findMOLS' i ls rs else findMOLS' i ls rs findMOLS' _ _ [] = [] -- |Are the latin squares mutually orthogonal (ie each pair is orthogonal)? isMOLS :: (Ord a) => [[[a]]] -> Bool isMOLS (greek:latins) = all (isOrthogonal greek) latins && isMOLS latins isMOLS [] = True -- |MOLS from a projective plane fromProjectivePlane :: (Ord k, Num k) => Design [k] -> [[[Int]]] fromProjectivePlane (D xs bs) = map toLS parallelClasses where k = [x | [0,1,x] <- xs] -- the field we're working over n = length k -- the order of the projective plane parallelClasses = drop 2 $ L.groupBy (\l1 l2 -> head l1 == head l2) bs -- The classes of parallel lines -- Each line has its ideal point at its head -- The first two classes have [0,0,1] and [0,1,0] as ideal points, and hence consist of horizontal and vertical lines toLS ls = let grid = M.fromList [ ((x,y),i) | (i, [0,1,mu]:ps) <- zip [1..] ls, [1,x,y] <- ps] in fMatrix' n (\i j -> grid M.! (k !! i, k !! j)) -- ORTHOGONAL ARRAYS -- Godsil & Royle p224 isOA (k,n) rows = length rows == k && all ( (== n^2) . length ) rows && all isOneOfEach [zip ri rj | [ri,rj] <- combinationsOf 2 rows ] -- An OA(3,n) from a latin square fromLS l = [ concat [replicate n i | i <- [1..n] ] -- row numbers , concat (replicate n [1..n]) -- column numbers , concat l -- entries ] where n = length l -- the order of the latin square fromMOLS mols = (concat [replicate n i | i <- [1..n] ]) : -- row numbers (concat (replicate n [1..n]) ) : -- column numbers map concat mols -- entries for each lsq where n = length $ head mols -- the order of the latin squares -- The graph defined by an OA(k,n) -- It is strongly regular with parameters ( n^2, (n-1)k, n-2+(k-1)(k-2), k(k-1) ) -- Godsil & Royle p225 graphOA rows = graph (vs,es) where vs = L.transpose rows -- the vertices are the columns of the OA es = [ [v1,v2] | [v1,v2] <- combinationsOf 2 vs, or (zipWith (==) v1 v2) ] -- two vertices are adjacent if they agree in any position -- Expected SRG parameters srgParamsOA (k,n) = Just ( n^2, (n-1)*k, n-2+(k-1)*(k-2), k*(k-1) ) -- eg srgParams (4,4) == srgParams $ graphOA $ init $ fromMOLS $ fromProjectivePlane $ pg2 f4 -- Todo: -- Would like a way to find out to what extent two sets of MOLS are really the same, -- eg can one be obtained from the other by row or column reordering (with renumbering) -- This might provide a proof of the distinctness of phi, omega, omegaD, psi HaskellForMaths-0.4.8/Math/Combinatorics/Matroid.hs0000644000000000000000000014615112514742102020366 0ustar0000000000000000-- Copyright (c) 2011-2015, David Amos. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction, DeriveFunctor #-} -- |A module providing functions to construct and investigate (small, finite) matroids. module Math.Combinatorics.Matroid where -- Source: Oxley, Matroid Theory (second edition) import Math.Core.Utils import Math.Core.Field hiding (f7) import Math.Common.ListSet as LS -- set operations on strictly ascending lists -- import Math.Algebra.Field.Base hiding (Q, F2, F3, F5, F7, F11, f2, f3, f5, f7, f11) import Math.Algebra.LinearAlgebra hiding (rank) import qualified Math.Combinatorics.Graph as G -- hiding (combinationsOf, restriction, component, isConnected) import Math.Combinatorics.FiniteGeometry import Math.Combinatorics.GraphAuts import Math.Algebra.Group.PermutationGroup hiding (closure) import Math.Algebras.VectorSpace hiding (dual) import Math.Algebras.Structures import Math.Algebras.Commutative import Data.List as L import qualified Data.Map as M import qualified Data.Set as S implies p q = q || not p exists = not . null unique [x] = x shortlex xs ys = case compare (length xs) (length ys) of LT -> LT EQ -> compare xs ys GT -> GT isShortlex xs = foldcmpl (\x1 x2 -> shortlex x1 x2 /= GT) xs toShortlex xs = map snd $ L.sort [(length x, x) | x <- xs] isClutter ss = and [ (s1 `LS.isSubset` s2) `implies` (s1 == s2) | s1 <- ss, s2 <- ss ] -- note that this definition would allow duplicates -- single-element deletions of xs -- if xs is sorted, then so is reverse (deletions xs) deletions xs = zipWith (++) (inits xs) (tail $ tails xs) closedUnderSubsets xss = and [xs' `S.member` xss' | xs <- xss, xs' <- deletions xs] where xss' = S.fromList xss -- |The data structure that we use to store the bases of the matroid data TrieSet a = TS [(a, TrieSet a)] deriving (Eq,Ord,Functor) -- Note that in a trie we would normally have a Bool at each node saying whether or not the node is terminal -- (ie corresponds to a member and not just a prefix of a member). -- However, since we intend to use the trie to store the bases, and they are all the same length, -- we can use lack of children to detect that a node is terminal. -- We could try storing the children in a map rather than a list -- for debugging tsshow (TS xts) = "TS [" ++ concatMap (\(x,t) -> "(" ++ show x ++ "," ++ tsshow t ++ ")") xts ++ "]" instance Show a => Show (TrieSet a) where show = show . tstolist tsempty = TS [] tsinsert (x:xs) (TS ts) = case L.lookup x ts of Nothing -> let t = tsinsert xs (TS []) in TS $ L.insert (x,t) ts Just t -> let t' = tsinsert xs t in TS $ L.insert (x,t') $ L.delete (x,t) ts tsinsert [] t = t tsmember (x:xs) (TS ts) = case lookup x ts of Nothing -> False Just t -> tsmember xs t tsmember [] (TS []) = True -- the node has no children, and hence is terminal tsmember [] _ = False -- xs is a subset of a member of t tssubmember (x:xs) (TS ts) = or [ case compare x y of LT -> False EQ -> tssubmember xs t GT -> tssubmember (x:xs) t | (y,t) <- ts ] tssubmember [] _ = True tstolist (TS []) = [[]] tstolist (TS xts) = concatMap (\(x,t) -> map (x:) (tstolist t)) xts tsfromlist = foldl' (flip tsinsert) tsempty -- |A datatype to represent a matroid. @M es bs@ is the matroid whose elements are @es@, and whose bases are @bs@. -- The normal form is for the @es@ to be in order, for each of the @bs@ individually to be in order. -- (So the TrieSet should have the property that any path from the root to a leaf is strictly increasing). data Matroid a = M [a] (TrieSet a) deriving (Eq,Show,Functor) -- |Return the elements over which the matroid is defined. elements :: Matroid t -> [t] elements (M es bs) = es -- |Return all the independent sets of a matroid, in shortlex order. indeps :: (Ord a) => Matroid a -> [[a]] indeps m = bfs [ ([],es) ] where es = elements m bfs ( (ls,rs) : nodes ) = let ls' = reverse ls in if isIndependent m ls' then ls' : bfs ( nodes ++ successors (ls,rs) ) else bfs nodes bfs [] = [] successors (ls,rs) = [ (r:ls, rs') | r:rs' <- L.tails rs ] isIndependent :: (Ord a) => Matroid a -> [a] -> Bool isIndependent (M es bs) xs = xs `tssubmember` bs isDependent :: (Ord a) => Matroid a -> [a] -> Bool isDependent m = not . isIndependent m -- |Are these the independent sets of a matroid? (The sets must individually be ordered.) isMatroidIndeps :: (Ord a) => [[a]] -> Bool isMatroidIndeps is = [] `elem` is && closedUnderSubsets is && and [ (l1 < l2) `implies` exists [e | e <- i2 LS.\\ i1, L.insert e i1 `elem` is] | i1 <- is, let l1 = length i1, i2 <- is, let l2 = length i2 ] -- |Construct a matroid from its elements and its independent sets. fromIndeps :: (Ord a) => [a] -> [[a]] -> Matroid a fromIndeps es is = fromBases es bs where bs = dfs [] [([],es)] dfs bs ( node@(ls,rs) : nodes ) = let succs = successors node in if null succs then dfs (ls:bs) nodes else dfs bs (succs ++ nodes) dfs ls [] = let r = length $ last ls -- we know that the first one we found is a true base in map reverse $ filter (\b -> length b == r) ls -- we might have had null succs simply because we ran out of vectors to add successors (ls,rs) = [ (r:ls, rs') | r:rs' <- L.tails rs, (r:ls) `S.member` is' ] is' = S.fromList $ map reverse is -- this seems to be just slightly slower fromIndeps1 es is = fromBases es bs where b = greedy [] es -- first find any basis greedy ls (r:rs) = if (r:ls) `S.member` ris' then greedy (r:ls) rs else greedy ls rs greedy ls [] = reverse ls ris' = S.fromList $ map reverse is bs = closure S.empty (S.singleton b) -- now find all other bases by passing to "neighbouring" bases closure interior boundary = if S.null boundary then S.toList interior else let interior' = interior `S.union` boundary boundary' = S.fromList [ b' | b <- S.toList boundary, x <- b, y <- es LS.\\ b, let b' = L.insert y (L.delete x b), b' `S.notMember` interior', b' `S.member` is' ] in closure interior' boundary' is' = S.fromList is -- The basis properties imply that the set of all bases is connected under the "neighbour" relation -- |Given a matrix, represented as a list of rows, number the columns [1..], -- and construct the matroid whose independent sets correspond to those sets of columns which are linearly independent -- (or in case there are repetitions, those multisets of columns which are sets, and which are linearly independent). vectorMatroid :: (Eq k, Fractional k) => [[k]] -> Matroid Int vectorMatroid = vectorMatroid' . L.transpose -- |Given a list of vectors (or rows of a matrix), number the vectors (rows) [1..], and construct the matroid whose independent sets -- correspond to those sets of vectors (rows) which are linearly independent -- (or in case there are repetitions, those multisets which are sets, and which are linearly independent). vectorMatroid' :: (Eq k, Fractional k) => [[k]] -> Matroid Int vectorMatroid' vs = fromBases (map fst vs') bs where vs' = zip [1..] vs bs = dfs [] [([],[],vs')] dfs ls (r@(i,ref,es) : rs) = let succs = successors r in if null succs then dfs (i:ls) (succs ++ rs) else dfs ls (succs ++ rs) dfs ls [] = let r = length $ last ls -- we know that the first one we found is a true base in map reverse $ filter (\b -> length b == r) ls -- we might have had null succs simply because we ran out of vectors to add successors (i,ref,es) = [(i',ref',es') | (j,e):es' <- L.tails es, not (inSpanRE ref e), let ref' = rowEchelonForm (ref ++ [e]), -- is this really better than e:ref? let i' = j : i ] -- |Given the edges of an undirected graph, number the edges [1..], and construct the matroid whose independent sets -- correspond to those sets of edges which contain no cycle. The bases therefore correspond to maximal forests within the graph. -- The edge set is allowed to contain loops or parallel edges. cycleMatroid :: (Ord a) => [[a]] -> Matroid Int cycleMatroid es = fromBases (map fst es') bs where es' = zip [1..] es bs = dfs [] [([], M.empty, es')] dfs ls (r@(i,ref,es) : rs) = let succs = successors r in if null succs then dfs (i:ls) (succs ++ rs) else dfs ls (succs ++ rs) dfs ls [] = let r = length $ last ls -- we know that the first one we found is a true base in map reverse $ filter (\b -> length b == r) ls -- we might have had null succs simply because we ran out of edges to add successors (i, reps, (j,[u,v]):es' ) = if u == v then successors (i, reps, es') else case (M.lookup u reps, M.lookup v reps) of (Nothing, Nothing) -> (j:i, M.insert u u $ M.insert v u reps, es') : successors (i, reps, es') -- neither of these vertices has been seen before, so add this edge as a new tree in the forest (Just u', Nothing) -> (j:i, M.insert v u' reps, es') : successors (i, reps, es') -- we have seen u before but not v, so add v to the u-tree (Nothing, Just v') -> (j:i, M.insert u v' reps, es') : successors (i, reps, es') -- we have seen v before but not u, so add u to the v-tree (Just u', Just v') -> if u' == v' then successors (i,reps,es') -- u and v are already in the same tree, so adding this edge would make a cycle else (j:i, M.map (\w -> if w == v' then u' else w) reps, es') : successors (i, reps, es') -- u and v are in different trees, so join the trees together successors (_, _, []) = [] -- A version of cycle matroid that retains the original edges rather than relabeling with integers. -- Not really valid if there are parallel edges (because they can't be distinguished in the output). -- Required for "markedfcim" below. cycleMatroid' es = fmap lookupEdge $ cycleMatroid es where table = M.fromList $ zip [1..] es lookupEdge = (M.!) table -- |Given a matroid over an arbitrary type, relabel to obtain a matroid over the integers. to1n :: (Ord a) => Matroid a -> Matroid Int to1n m = fmap to1n' m where es = elements m table = M.fromList $ zip es [1..] to1n' = (M.!) table -- ISOMORPHISMS AND AUTOMORPHISMS incidenceGraphB m = G.G vs' es' where es = elements m bs = bases m vs' = map Left es ++ map Right bs es' = L.sort [ [Left e, Right b] | b <- bs, e <- b ] -- incidence graph for the matroid considered as an incidence structure between elements and bases incidenceGraphC m = G.G vs' es' where es = elements m cs = L.sort $ circuits m vs' = map Left es ++ map Right cs es' = L.sort [ [Left e, Right c] | c <- cs, e <- c ] -- incidence graph for the matroid considered as an incidence structure between elements and circuits incidenceGraphH m = G.G vs' es' where es = elements m hs = L.sort $ hyperplanes m vs' = map Left es ++ map Right hs es' = L.sort [ [Left e, Right h] | h <- hs, e <- h ] -- incidence graph for the matroid considered as an incidence structure between elements and hyperplanes -- for "sparse" matroids, there are likely to be fewer hyperplanes than bases (why?) -- incidenceGraphH may not be connected - eg u 2 4 -- (So a rank 3 or higher matroid, provided it has more than one hyperplane, certainly has a connected incidenceGraphH) matroidIsos m1 m2 = incidenceIsos (incidenceGraphH m1) (incidenceGraphH m2) -- |Are the two matroids isomorphic? isMatroidIso :: (Ord a, Ord b) => Matroid a -> Matroid b -> Bool isMatroidIso m1 m2 = isIncidenceIso (incidenceGraphH m1) (incidenceGraphH m2) -- |Return the automorphisms of the matroid. matroidAuts :: (Ord a) => Matroid a -> [Permutation a] matroidAuts m = incidenceAuts $ incidenceGraphH m -- Note that the results aren't always what one intuitively expects from the geometric representation. -- This is because geometric representations suggest additional structure beyond matroid structure. -- For example, for the Vamos matroid v8, -- it returns auts which are not "geometric" auts of the geometric representation. -- Matroids are really combinatorial objects, not geometric. -- In the case of v8, the key is that the only thing the auts have to preserve are the planes, not the lines -- CIRCUITS -- |A circuit in a matroid is a minimal dependent set. isCircuit :: (Ord a) => Matroid a -> [a] -> Bool isCircuit m c = isDependent m c && all (isIndependent m) (deletions c) -- |Return all circuits for the given matroid, in shortlex order. circuits :: (Ord a) => Matroid a -> [[a]] circuits m = toShortlex $ dfs S.empty [L.insert e b | b <- bs, e <- es LS.\\ b] where es = elements m bs = bases m dfs vs (c:cs) | c `S.member` vs = dfs vs cs | otherwise = let cs' = successors c vs' = S.insert c vs in if null cs' then c : dfs vs' cs else dfs vs' (cs' ++ cs) dfs _ [] = [] successors c = [c' | c' <- deletions c, isDependent m c' ] -- Oxley p10 -- |Are the given sets the circuits of some matroid? isMatroidCircuits :: (Ord a) => [[a]] -> Bool isMatroidCircuits cs = [] `notElem` cs && and [(c1 `LS.isSubset` c2) `implies` (c1 == c2) | c1 <- cs, c2 <- cs] && and [ exists [c3 | c3 <- cs, c3 `LS.isSubset` c12'] | c1 <- cs, c2 <- cs, c1 /= c2, e <- c1 `LS.intersect` c2, let c12' = L.delete e (c1 `LS.union` c2)] -- |Reconstruct a matroid from its elements and circuits. fromCircuits :: (Ord a) => [a] -> [[a]] -> Matroid a fromCircuits es cs = fromBases es bs where b = greedy [] es -- first find any basis greedy ls (r:rs) = let ls' = ls ++ [r] in if isIndep ls' then greedy ls' rs else greedy ls rs greedy ls [] = ls bs = closure S.empty (S.singleton b) -- now find all other bases by passing to "neighbouring" bases closure interior boundary = if S.null boundary then S.toList interior else let interior' = interior `S.union` boundary boundary' = S.fromList [ b' | b <- S.toList boundary, x <- b, y <- es LS.\\ b, let b' = L.insert y (L.delete x b), b' `S.notMember` interior', isIndep b' ] in closure interior' boundary' isIndep xs = not (any (`LS.isSubset` xs) cs) -- |An element e in a matroid M is a loop if {e} is a circuit of M. isLoop :: (Ord a) => Matroid a -> a -> Bool isLoop m e = isCircuit m [e] -- isLoop (M es is) e = [e] `notElem` is -- |Elements f and g in a matroid M are parallel if {f,g} is a circuit of M. isParallel :: (Ord a) => Matroid a -> a -> a -> Bool isParallel m f g = isCircuit m [f,g] -- |A matroid is simple if it has no loops or parallel elements isSimple :: (Ord a) => Matroid a -> Bool isSimple m = all ( (>2) . length ) (circuits m) -- BASES -- |A base or basis in a matroid is a maximal independent set. isBase :: (Ord a) => Matroid a -> [a] -> Bool isBase (M es bs) b = b `tsmember` bs -- |Return all bases for the given matroid bases :: (Ord a) => Matroid a -> [[a]] bases (M es bs) = tstolist bs -- |Are the given sets the bases of some matroid? isMatroidBases :: (Ord a) => [[a]] -> Bool isMatroidBases bs = (not . null) bs && and [ exists [y | y <- b2 LS.\\ b1, L.insert y (L.delete x b1) `elem` bs] | b1 <- bs, b2 <- bs, x <- b1 LS.\\ b2 ] -- |Reconstruct a matroid from its elements and bases. fromBases :: (Ord a) => [a] -> [[a]] -> Matroid a fromBases es bs = M es (tsfromlist bs) -- The elements are required because a loop does not appear in any basis. -- Oxley p17 -- |Given a matroid m, a basis b, and an element e, @fundamentalCircuit m b e@ returns the unique circuit contained in b union {e}, -- which is called the fundamental circuit of e with respect to b. fundamentalCircuit :: (Ord a) => Matroid a -> [a] -> a -> [a] fundamentalCircuit m b e = unique [c | c <- circuits m, c `LS.isSubset` be] where be = L.insert e b uniformMatroid m n | m <= n = fromBases es bs where es = [1..n] bs = combinationsOf m es -- |The uniform matroid U m n is the matroid whose independent sets are all subsets of [1..n] with m or fewer elements. u :: Int -> Int -> Matroid Int u = uniformMatroid -- RANK FUNCTION -- Oxley p103, 3.1.14 restriction1 m xs = fromBases xs bs' where bs = bases m is' = toShortlex [b `LS.intersect` xs | b <- bs] r = length $ last is' bs' = dropWhile ( (< r) . length ) is' -- |The restriction of a matroid to a subset of its elements restriction :: (Ord a) => Matroid a -> [a] -> Matroid a restriction m@(M es bs) xs = M xs bs' where (_,bs') = balance $ prune bs prune (TS yts) = let (ins, outs) = L.partition (\(y,t) -> y `elem` xs) yts ins' = [(y, prune t) | (y,t) <- ins] outs' = concat [ zts | (y,t) <- outs, let TS zts = prune t ] in TS $ ins' ++ outs' balance (TS yts) = let dyt's = [(d',(y,t')) | (y,t) <- yts, let (d',t') = balance t] d = maximum $ 0 : map fst dyt's in (d+1, TS $ toSet [(y,t') | (d',(y,t')) <- dyt's, d' == d]) -- we have to make the toSet call *after* we balance, otherwise two trees may appear unequal because of undergrowth that is going to be removed -- !! Need thorough testing to prove that restriction == restriction1 -- |Given a matroid m, @rankfun m@ is the rank function on subsets of its element set rankfun :: (Ord a) => Matroid a -> [a] -> Int rankfun m xs = (length . head . bases) (restriction m xs) -- no danger of head [], because bases must be non-null -- |The rank of a matroid is the cardinality of a basis rank :: (Ord a) => Matroid a -> Int rank m = length $ head $ bases m -- rank m@(M es bs) = rankfun m es -- Oxley p23 -- |Reconstruct a matroid from its elements and rank function fromRankfun :: (Ord a) => [a] -> ([a] -> Int) -> Matroid a fromRankfun es rkf = fromBases es bs where b = greedy 0 [] es -- first find any basis greedy rk ls (r:rs) = let ls' = ls ++ [r] in if rkf ls' == rk+1 then greedy (rk+1) ls' rs else greedy rk ls rs greedy _ ls [] = ls rk = rkf b isBasis b' = rkf b' == rk bs = closure S.empty (S.singleton b) S.empty -- now find all other bases by passing to "neighbouring" bases closure interior boundary exterior = if S.null boundary then S.toList interior else let interior' = interior `S.union` boundary candidates = S.fromList [ b' | b <- S.toList boundary, x <- b, y <- es LS.\\ b, let b' = L.insert y (L.delete x b), b' `S.notMember` interior', b' `S.notMember` exterior ] (boundary', exterior') = S.partition isBasis candidates in closure interior' boundary' (S.union exterior exterior') -- The purpose of keeping track of exterior points we have encountered -- is to avoid making repeat calls to the rank function rkf -- CLOSURE OPERATOR AND FLATS -- |Given a matroid m, @closure m@ is the closure operator on subsets of its element set closure :: (Ord a) => Matroid a -> [a] -> [a] closure m xs = [x | x <- es, x `elem` xs || rankfun m (L.insert x xs) == rankxs] where es = elements m rankxs = rankfun m xs -- The intuition is that closure xs is all elements within the span of xs -- |Reconstruct a matroid from its elements and closure operator fromClosure :: (Ord a) => [a] -> ([a] -> [a]) -> Matroid a fromClosure es cl = fromBases es bs where b = greedy (cl []) [] es -- first find any basis greedy span ls (r:rs) = let ls' = ls ++ [r] in if r `notElem` span -- r is independent relative to ls then greedy (cl ls') ls' rs else greedy span ls rs greedy _ ls [] = ls rk = length b isBasis b' = cl b' == es bs = closure S.empty (S.singleton b) S.empty -- now find all other bases by passing to "neighbouring" bases closure interior boundary exterior = if S.null boundary then S.toList interior else let interior' = interior `S.union` boundary candidates = S.fromList [ b' | b <- S.toList boundary, x <- b, y <- es LS.\\ b, let b' = L.insert y (L.delete x b), b' `S.notMember` interior', b' `S.notMember` exterior ] (boundary', exterior') = S.partition isBasis candidates in closure interior' boundary' (S.union exterior exterior') -- The purpose of keeping track of exterior points we have encountered -- is to avoid making repeat calls to the closure operator cl {- -- Not quite sure why the following is so much slower than the above -- May just be because Data.Set is compiled, and this would be comparable if also compiled fromClosure2 es cl = M es bs where b = greedy (cl []) [] es -- first find any basis greedy span ls (r:rs) = let ls' = ls ++ [r] in if r `notElem` span -- r is independent relative to ls then greedy (cl ls') ls' rs else greedy span ls rs greedy _ ls [] = ls rk = length b isBasis b' = cl b' == es bs = closure tsempty [b] tsempty -- now find all other bases by passing to "neighbouring" bases closure interior boundary exterior = if null boundary then interior else let interior' = foldl' (flip tsinsert) interior boundary candidates = [ b' | b <- boundary, x <- b, y <- es LS.\\ b, let b' = L.insert y (L.delete x b), not (b' `tsmember` interior'), not (b' `tsmember` exterior) ] (boundary', exterior') = L.partition isBasis candidates in closure interior' boundary' (foldl' (flip tsinsert) exterior exterior') -} -- |A flat in a matroid is a closed set, that is a set which is equal to its own closure isFlat :: (Ord a) => Matroid a -> [a] -> Bool isFlat m xs = closure m xs == xs flats1 m = [xs | xs <- powersetbfs es, isFlat m xs] where es = elements m -- first, inefficient, implementation -- given xs, a flat in m, return the flats which cover xs -- these have the property that they partition es \\ xs coveringFlats m xs = coveringFlats' (es LS.\\ xs) where es = elements m coveringFlats' (y:ys) = let zs = closure m (L.insert y xs) in zs : coveringFlats' (ys LS.\\ zs) coveringFlats' [] = [] -- since we are dealing with finite matroids, the lattice of flats is finite, so it has a minimal element minimalFlat m = head $ filter (isFlat m) $ powersetbfs $ elements m -- |The flats of a matroid are its closed sets. They form a lattice under inclusion. flats :: (Ord a) => Matroid a -> [[a]] flats m = flats' S.empty [minimalFlat m] where flats' ls (r:rs) = if r `S.member` ls then flats' ls rs else flats' (S.insert r ls) (rs ++ coveringFlats m r) flats' ls [] = toShortlex $ S.toList ls -- this is just breadth-first search -- isMatroidFlats -- Oxley p31-32 {- isMatroidFlats es fs = es `elem` fs && [ (f1 `LS.intersect` f2) `elem` fs | f1 <- fs, f2 <- fs ] && -- for all flats f, the minimal flats containing f partition es-f -} -- |Reconstruct a matroid from its flats. (The flats must be given in shortlex order.) fromFlats :: (Ord a) => [[a]] -> Matroid a fromFlats fs | isShortlex fs = fromFlats' fs | otherwise = error "fromFlats: flats must be in shortlex order" fromFlats' fs = fromClosure es cl where es = last fs -- es is a flat, and last in shortlex order cl xs = head [f | f <- fs, xs `LS.isSubset` f] -- the first flat is minimal, because of shortlex order -- !! we can probably do better (efficiency-wise) -- eg by constructing the lattice as a DAG, and climbing up it -- |A subset of the elements in a matroid is spanning if its closure is all the elements isSpanning :: (Ord a) => Matroid a -> [a] -> Bool isSpanning m xs = closure m xs == es where es = elements m -- |A hyperplane is a flat whose rank is one less than that of the matroid isHyperplane :: (Ord a) => Matroid a -> [a] -> Bool isHyperplane m xs = isFlat m xs && rankfun m xs == rank m - 1 hyperplanes1 m = [h | h <- flats m, rankfun m h == rk - 1] where rk = rank m -- Oxley p65: h is a hyperplane iff its complement is a cocircuit hyperplanes :: (Ord a) => Matroid a -> [[a]] hyperplanes m = toShortlex $ map complement $ cocircuits m where es = elements m complement cc = es LS.\\ cc -- This appears to be faster than hyperplanes1 -- Oxley p70 isMatroidHyperplanes :: (Ord a) => [a] -> [[a]] -> Bool isMatroidHyperplanes es hs = es `notElem` hs && isClutter hs && and [ exists [h3 | h3 <- hs, h12e `LS.isSubset` h3] | (h1,h2) <- pairs hs, e <- es LS.\\ (LS.union h1 h2), let h12e = L.insert e (LS.intersect h1 h2) ] -- Note that contrary to what one might initially think -- it does *not* follow from the third condition that every element is in some hyperplane -- since there might be only one hyperplane, eg fromBases [1,2] [[2]] has [1] as it's only hyperplane -- Haven't actually proven that the following is always correct -- but it seems to work fromHyperplanes1 es hs = fromFlats $ closure S.empty (S.fromList hs) where closure interior boundary = if S.null boundary then (toShortlex $ S.toList interior) ++ [es] else let interior' = S.union interior boundary boundary' = S.fromList [ f1 `LS.intersect` f2 | (f1,f2) <- pairs (S.toList boundary) ] S.\\ interior' in closure interior' boundary' -- |Reconstruct a matroid from its elements and hyperplanes fromHyperplanes :: (Ord a) => [a] -> [[a]] -> Matroid a fromHyperplanes es hs = fromCocircuits es $ map complement hs where fromCocircuits es = dual . fromCircuits es complement xs = es LS.\\ xs -- GEOMETRIC REPRESENTATION -- |Given a list of points in k^n, number the points [1..], and construct the matroid whose independent sets -- correspond to those sets of points which are affinely independent. -- -- A multiset of points in k^n is said to be affinely dependent if it contains two identical points, -- or three collinear points, or four coplanar points, or ... - and affinely independent otherwise. affineMatroid :: (Eq k, Fractional k) => [[k]] -> Matroid Int affineMatroid vs = vectorMatroid' $ map (1:) vs -- |fromGeoRep returns a matroid from a geometric representation consisting of dependent flats of various ranks. -- Given lists of dependent rank 0 flats (loops), rank 1 flats (points), rank 2 flats (lines) and rank 3 flats (planes), -- @fromGeoRep loops points lines planes@ returns the matroid having these as dependent flats. -- Note that if all the elements lie in the same plane, then this should still be listed as an argument. fromGeoRep :: (Ord a) => [[a]] -> [[a]] -> [[a]] -> [[a]] -> Matroid a fromGeoRep loops points lines planes = fromCircuits es $ minimal $ loops ++ concatMap (combinationsOf 2) points ++ concatMap (combinationsOf 3) lines ++ concatMap (combinationsOf 4) planes ++ combinationsOf 5 es where es = toSet $ concat loops ++ concat points ++ concat lines ++ concat planes -- Note that we don't check that the inputs are valid -- xss assumed to be in shortlex order minimal xss = minimal' [] xss where minimal' ls (r:rs) = if any (`LS.isSubset` r) ls then minimal' ls rs else minimal' (r:ls) rs minimal' ls [] = reverse ls -- |A simple matroid has no loops or parallel elements, hence its geometric representation has no loops or dependent points. -- @simpleFromGeoRep lines planes@ returns the simple matroid having these dependent flats. simpleFromGeoRep :: (Ord a) => [[a]] -> [[a]] -> Matroid a simpleFromGeoRep lines planes = fromGeoRep [] [] lines planes -- Oxley p37-8 isSimpleGeoRep lines planes = all ( (<= 1) . length ) [ l1 `LS.intersect` l2 | (l1,l2) <- pairs lines ] && all ( \i -> length i <= 2 || i `elem` lines ) [ p1 `LS.intersect` p2 | (p1,p2) <- pairs planes ] && and [ any (u `LS.isSubset`) planes | (l1,l2) <- pairs lines, length (l1 `LS.intersect` l2) == 1, let u = l1 `LS.union` l2 ] && and [ length i == 1 || i == l | l <- lines, p <- planes, let i = l `LS.intersect` p ] isCircuitHyperplane m xs = isCircuit m xs && isHyperplane m xs -- |List the circuit-hyperplanes of a matroid. circuitHyperplanes :: (Ord a) => Matroid a -> [[a]] circuitHyperplanes m = [ h | h <- hyperplanes m, isCircuit m h ] -- Oxley p39 -- |Given a matroid m, and a set of elements b which is both a circuit and a hyperplane in m, -- then @relaxation m b@ is the matroid which is obtained by adding b as a new basis. -- This corresponds to removing b from the geometric representation of m. relaxation :: (Ord a) => Matroid a -> [a] -> Matroid a relaxation m b | isCircuitHyperplane m b = fromBases es bs | otherwise = error "relaxation: not a circuit-hyperplane" where es = elements m bs = b : bases m -- TRANSVERSAL MATROIDS ex161 = [ [1,2,6], [3,4,5,6], [2,3], [2,4,6] ] -- the edges of the bipartite graph transversalGraph as = [(Left x, Right i) | (a,i) <- zip as [1..], x <- a] partialMatchings es = dfs [(S.empty, [], es)] where dfs (node@(vs,ls,rs): nodes) = ls : dfs (successors node ++ nodes) dfs [] = [] successors (vs,ls,rs) = [ (S.insert u $ S.insert v vs, L.insert r ls, rs') | r@(u,v):rs' <- L.tails rs, u `S.notMember` vs, v `S.notMember` vs ] -- |Given a set of elements es, and a sequence as = [a1,...,am] of subsets of es, -- return the matroid whose independent sets are the partial transversals of the as. transversalMatroid :: (Ord a) => [a] -> [[a]] -> Matroid a transversalMatroid es as = fromBases es bs where is@(i:_) = reverse $ toShortlex $ toSet $ (map . map) (unLeft . fst) $ partialMatchings (transversalGraph as) unLeft (Left x) = x l = length i bs = reverse $ takeWhile ( (== l) . length ) is -- In this case, as is called a presentation of the matroid -- Note that there may be partial transversals even if there are no transversals -- Not obvious how to efficiently find the bases without finding the independent sets, -- since neighbouring partial transversals might arise in different ways -- (Although Oxley p93 seems to be saying that they don't) {- transversalMatroid2 es as = fromBases es bs where es' = transversalGraph as b = greedy [] es' -- first find any basis greedy ls (r@(u,v):rs) = if u `notElem` map fst ls && v `notElem` map snd ls then greedy (r:ls) rs else greedy ls rs greedy ls [] = ls -- now choose the subset of the as indicated by the Right part of b -- and seek all full transversals bs = closure S.empty (S.singleton b) -- now find all other bases by passing to "neighbouring" bases closure interior boundary = if S.null boundary then S.toList interior else let interior' = interior `S.union` boundary boundary' = S.fromList [ b' | b <- S.toList boundary, x <- b, y <- es LS.\\ b, let b' = L.insert y (L.delete x b), b' `S.notMember` interior', cl b' == es ] -- b' is spanning, and same size as b, hence must be basis -- S.\\ interior' in closure interior' boundary' -} -- DUALITY -- |The dual matroid dual :: (Ord a) => Matroid a -> Matroid a dual m = fromBases es bs' where es = elements m bs = bases m bs' = L.sort $ map (es LS.\\) bs isCoindependent m xs = isIndependent (dual m) xs isCobase m xs = isBase (dual m) xs -- quicker but less clear to calculate this directly isCocircuit m xs = isCircuit (dual m) xs cocircuits :: (Ord a) => Matroid a -> [[a]] cocircuits m = circuits (dual m) isColoop m e = isLoop (dual m) e isCoparallel m f g = isParallel (dual m) f g -- MINORS deletion :: (Ord a) => Matroid a -> [a] -> Matroid a deletion m xs = restriction m (es LS.\\ xs) where es = elements m (\\\) = deletion contraction :: (Ord a) => Matroid a -> [a] -> Matroid a contraction m xs = dual (deletion (dual m) xs) (///) = contraction -- CONNECTIVITY -- Oxley p120 -- |A matroid is (2-)connected if, for every pair of distinct elements, there is a circuit containing both isConnected :: (Ord a) => Matroid a -> Bool isConnected m = and [any (pair `LS.isSubset`) cs | pair <- combinationsOf 2 es] where es = elements m cs = circuits m component m x = closure S.empty (S.singleton x) where cs = circuits m closure interior boundary = if S.null boundary then S.toList interior else let interior' = S.union interior boundary boundary' = S.fromList (concat [c | c <- cs, (not . null) (LS.intersect c (S.toList boundary)) ]) S.\\ interior' in closure interior' boundary' -- |The direct sum of two matroids dsum :: (Ord a, Ord b) => Matroid a -> Matroid b -> Matroid (Either a b) dsum m1 m2 = fromBases es bs where es = map Left (elements m1) ++ map Right (elements m2) bs = [map Left b1 ++ map Right b2 | b1 <- bases m1, b2 <- bases m2] -- REPRESENTABILITY -- |@matroidPG n fq@ returns the projective geometry PG(n,Fq), where fq is a list of the elements of Fq matroidPG :: (Eq a, Fractional a) => Int -> [a] -> Matroid Int matroidPG n fq = vectorMatroid' $ ptsPG n fq -- |@matroidAG n fq@ returns the affine geometry AG(n,Fq), where fq is a list of the elements of Fq matroidAG :: (Eq a, Fractional a) => Int -> [a] -> Matroid Int matroidAG n fq = vectorMatroid' $ ptsAG n fq -- Oxley p182 -- |Given a matroid m, the fundamental-circuit incidence matrix relative to a base b -- has rows indexed by the elements of b, and columns indexed by the elements not in b. -- The bi, ej entry is 1 if bi is in the fundamental circuit of ej relative to b, and 0 otherwise. fundamentalCircuitIncidenceMatrix :: (Ord a, Num k) => Matroid a -> [a] -> [[k]] fundamentalCircuitIncidenceMatrix m b = L.transpose $ fundamentalCircuitIncidenceMatrix' m b fundamentalCircuitIncidenceMatrix' m b = [ [if e `elem` fundamentalCircuit m b e' then 1 else 0 | e <- b] | e' <- elements m LS.\\ b ] fcim = fundamentalCircuitIncidenceMatrix fcim' = fundamentalCircuitIncidenceMatrix' -- Then fcim w4 [1..4] == L.transpose (fcim (dual w4) [5..8]) -- Given a matrix of 0s and 1s, return a matrix of 0s, 1s and *s -- where 0 -> 0, and 1 -> 1 if it is the first 1 in either a row or column, 1 -> * otherwise markNonInitialRCs mx = mark (replicate w False) mx where w = length $ head mx -- the width mark cms (r:rs) = let (cms', r') = mark' False [] cms [] r in r' : mark cms' rs mark _ [] = [] mark' rm cms' (cm:cms) ys (x:xs) | x == 0 = mark' rm (cm:cms') cms (Zero:ys) xs | x == 1 = if rm && cm then mark' True (True:cms') cms (Star:ys) xs else mark' True (True:cms') cms (One:ys) xs mark' _ cms' [] ys [] = (reverse cms', reverse ys) -- Given a matrix of 0s, 1s and *s, return all distinct matrices that can be obtained -- by substituting non-zero elements of Fq for the *s substStars mx fq = substStars' mx where fq' = tail fq -- non-zero elts of fq substStars' (r:rs) = [r':rs' | r' <- substStars'' r, rs' <- substStars' rs] substStars' [] = [[]] substStars'' (Zero:xs) = map (0:) $ substStars'' xs substStars'' (One:xs) = map (1:) $ substStars'' xs substStars'' (Star:xs) = [x':xs' | x' <- fq', xs' <- substStars'' xs] substStars'' [] = [[]] starSubstitutionsV fq' (Zero:xs) = map (0:) $ starSubstitutionsV fq' xs starSubstitutionsV fq' (One:xs) = map (1:) $ starSubstitutionsV fq' xs starSubstitutionsV fq' (Star:xs) = [x':xs' | x' <- fq', xs' <- starSubstitutionsV fq' xs] starSubstitutionsV _ [] = [[]] -- Oxley p184-5 -- Note that the particular representations you get depend on which basis is used -- (Perhaps we should let you pass in the basis to use) representations1 fq m = [ L.transpose d | d <- substStars dhash fq, let mx = ir ++ d, to1n m == (vectorMatroid' $ map snd $ L.sort $ zip (b ++ b') mx) ] where b = head $ bases m b' = elements m LS.\\ b r = length b -- rank of the matroid ir = idMx r -- identity matrix dhash = markNonInitialRCs $ fcim' m b -- edges of the fundamental circuit incidence graph fcig m b = [ [e,e'] | e <- b, e' <- elements m LS.\\ b, e `elem` fundamentalCircuit m b e' ] -- the fcim of m relative to b, with 1s and *s marked markedfcim m b = mark b b' (fcim m b) where b' = elements m LS.\\ b -- the elements of b are the row labels, those of b' are the column labels entries = fcig m b -- the [row,column] coordinates of the non-zero entries in the fcim ones = head $ bases $ cycleMatroid' entries -- a set of entries which we can take to be 1 stars = entries LS.\\ ones -- the set of entries which we are then still free to assign mark (i:is) js (r:rs) = (mark' i js r) : mark is js rs mark [] _ [] = [] mark' i (j:js) (x:xs) | x == 0 = Zero : mark' i js xs | x == 1 = (if [i,j] `elem` stars then Star else One) : mark' i js xs mark' _ [] [] = [] -- The markedfcim will sometimes do better than markNonInitialRCs, and is best possible -- Oxley p184-5 representations2 fq m = [ L.transpose mx | d <- substStars dhash' fq, let mx = ir ++ d, m' == (vectorMatroid' $ map snd $ L.sort $ zip (b ++ b') mx) ] where m' = to1n m es = elements m b = head $ bases m b' = es LS.\\ b r = length b -- rank of the matroid ir = idMx r -- identity matrix dhash' = L.transpose $ markedfcim m b -- In the following, we check the representations of the restrictions as we add a column at a time -- This enables us to early out if a potential representation doesn't work on a restriction -- |Find representations of the matroid m over fq. Specifically, this function will find one representative -- of each projective equivalence class of representation. representations :: (Eq fq, Fractional fq, Ord a) => [fq] -> Matroid a -> [[[fq]]] representations fq m = map L.transpose $ representations' (reverse $ zip b ir) (zip b' dhash') where fq' = tail fq -- fq \ {0} b = head $ bases m b' = elements m LS.\\ b r = length b -- rank of the matroid ir = idMx r -- identity matrix dhash' = L.transpose $ markedfcim m b representations' ls ((i,r):rs) = concat [ representations' ((i,r'):ls) rs | r' <- starSubstitutionsV fq' r, let (is,vs) = unzip $ L.sortBy cmpfst ((i,r'):ls), to1n (restriction m is) == (vectorMatroid' vs) ] representations' ls [] = [map snd $ reverse ls] -- |Is the matroid representable over Fq? For example, to find out whether a matroid m is binary, evaluate @isRepresentable f2 m@. isRepresentable :: (Eq fq, Fractional fq, Ord a) => [fq] -> Matroid a -> Bool isRepresentable fq m = (not . null) (representations fq m) -- |A binary matroid is a matroid which is representable over F2 isBinary :: (Ord a) => Matroid a -> Bool isBinary = isRepresentable f2 -- |A ternary matroid is a matroid which is representable over F3 isTernary :: (Ord a) => Matroid a -> Bool isTernary = isRepresentable f3 -- CONSTRUCTIONS -- The next three functions not very thoroughly tested data LMR a b = L a | Mid | R b deriving (Eq, Ord, Show) -- Oxley p252 seriesConnection (m1,p1) (m2,p2) | not (isLoop m1 p1) && not (isColoop m1 p1) && not (isLoop m2 p2) && not (isColoop m2 p2) = fromCircuits es cs | otherwise = error "not yet implemented" where es = map L (elements m1 LS.\\ [p1]) ++ [Mid] ++ map R (elements m2 LS.\\ [p2]) cs = (map . map) L (circuits $ m1 \\\ [p1]) ++ (map . map) R (circuits $ m2 \\\ [p2]) ++ [ map L (L.delete p1 c1) ++ [Mid] ++ map R (L.delete p2 c2) | c1 <- circuits m1, p1 `elem` c1, c2 <- circuits m2, p2 `elem` c2] parallelConnection (m1,p1) (m2,p2) | not (isLoop m1 p1) && not (isColoop m1 p1) && not (isLoop m2 p2) && not (isColoop m2 p2) = fromCircuits es cs | otherwise = error "not yet implemented" where es = map L (elements m1 LS.\\ [p1]) ++ [Mid] ++ map R (elements m2 LS.\\ [p2]) cs = (map . map) L (circuits $ m1 \\\ [p1]) ++ [ map L (L.delete p1 c1) ++ [Mid] | c1 <- circuits m1, p1 `elem` c1 ] ++ (map . map) R (circuits $ m2 \\\ [p2]) ++ [ [Mid] ++ map R (L.delete p2 c2) | c2 <- circuits m2, p2 `elem` c2 ] ++ [ map L (L.delete p1 c1) ++ map R (L.delete p2 c2) | c1 <- circuits m1, p1 `elem` c1, c2 <- circuits m2, p2 `elem` c2 ] twoSum (m1,p1) (m2,p2) | not (isLoop m1 p1) && not (isColoop m1 p1) && not (isLoop m2 p2) && not (isColoop m2 p2) = fromCircuits es cs | otherwise = error "not yet implemented" where es = map L (elements m1 LS.\\ [p1]) ++ [Mid] ++ map R (elements m2 LS.\\ [p2]) cs = (map . map) L (circuits $ m1 \\\ [p1]) ++ (map . map) R (circuits $ m2 \\\ [p2]) ++ [ map L (L.delete p1 c1) ++ map R (L.delete p2 c2) | c1 <- circuits m1, p1 `elem` c1, c2 <- circuits m2, p2 `elem` c2] -- Note: The only different from seriesConnection is that we don't have Mid in the last set -- Oxley p427 matroidUnion m1 m2 = fromBases es bs where es = LS.union (elements m1) (elements m2) is = toShortlex $ toSet [ LS.union b1 b2 | b1 <- bases m1, b2 <- bases m2 ] r = length $ last is bs = dropWhile ( (< r) . length ) is -- SOME INTERESTING MATROIDS -- |The Fano plane F7 = PG(2,F2) f7 :: Matroid Int f7 = fromGeoRep [] [] [[1,2,3],[1,4,7],[1,5,6],[2,4,6],[2,5,7],[3,4,5],[3,6,7]] [[1..7]] -- Oxley p36, fig 1.12: -- cycleMatroid [[1,2],[1,3],[2,3],[3,4],[2,4],[1,4]] == restriction fanoPlane [1..6] -- |F7-, the relaxation of the Fano plane by removal of a line f7m :: Matroid Int f7m = relaxation f7 [2,4,6] -- Oxley p39 -- |The Pappus configuration from projective geometry pappus :: Matroid Int pappus = fromGeoRep [] [] [[1,2,3],[1,5,7],[1,6,8],[2,4,7],[2,6,9],[3,4,8],[3,5,9],[4,5,6],[7,8,9]] [[1..9]] -- more logical relabeling -- pappus' = fromGeoRep [] [] [[1,2,3],[1,5,9],[1,6,8],[2,4,9],[2,6,7],[3,4,8],[3,5,7],[4,5,6],[7,8,9]] [[1..9]] -- |Relaxation of the Pappus configuration by removal of a line nonPappus :: Matroid Int nonPappus = relaxation pappus [7,8,9] -- fromGeoRep [] [] [[1,2,3],[1,5,7],[1,6,8],[2,4,7],[2,6,9],[3,4,8],[3,5,9],[4,5,6]] [[1..9]] -- |The Desargues configuration desargues :: Matroid Int desargues = fromGeoRep [] [] [[1,2,5],[1,3,6],[1,4,7],[2,3,8],[2,4,9],[3,4,10],[5,6,8],[5,7,9],[6,7,10],[8,9,10]] [[1,2,3,5,6,8],[1,2,4,5,7,9],[1,3,4,6,7,10],[2,3,4,8,9,10],[5,6,7,8,9,10]] -- desargues == cycleMatroid (combinationsOf 2 [1..5]) -- (ie Desargues = M(K5) ) -- interestingly, although these are all the dependent flats that are evident from the diagram, -- there are also some rank 3 flats consisting of a line and an "antipodal" point -- eg, in terms of K5, [1,8,9,10] corresponds to [[1,2],[3,4],[3,5],[4,5]] -- Oxley p71 vamosMatroid1 = fromHyperplanes [1..8] (hs4 ++ hs3) where hs4 = [ [1,2,3,4], [1,4,5,6], [2,3,5,6], [1,4,7,8], [2,3,7,8] ] hs3 = [ h3 | h3 <- combinationsOf 3 [1..8], null [h4 | h4 <- hs4, h3 `LS.isSubset` h4] ] vamosMatroid = fromGeoRep [] [] [] [[1,2,3,4],[1,4,5,6],[2,3,5,6],[1,4,7,8],[2,3,7,8]] -- |The Vamos matroid V8. It is not representable over any field. v8 :: Matroid Int v8 = vamosMatroid -- v8 is self-dual (isomorphic to its own dual) -- Oxley p188 -- |P8 is a minor-minimal matroid that is not representable over F4, F8, F16, ... . -- It is Fq-representable if and only if q is not a power of 2. p8 :: Matroid Int p8 = vectorMatroid $ ( [ [1,0,0,0, 0, 1, 1,-1], [0,1,0,0, 1, 0, 1, 1], [0,0,1,0, 1, 1, 0, 1], [0,0,0,1, -1, 1, 1, 0] ] :: [[F3]] ) p8' = fromGeoRep [] [] [] [ [1,2,3,8], [1,2,4,7], [1,3,4,6], [1,4,5,8], [1,5,6,7], [2,3,4,5], [2,3,6,7], [2,5,6,8], [3,5,7,8], [4,6,7,8] ] -- |P8- is a relaxation of P8. It is Fq-representable if and only if q >= 4. p8m :: Matroid Int p8m = relaxation p8 [2,3,6,7] -- |P8-- is a relaxation of P8-. It is a minor-minimal matroid that is not representable over F4. -- It is Fq-representable if and only if q >= 5. p8mm :: Matroid Int p8mm = relaxation p8m [1,4,5,8] -- Oxley p317 -- r-spoked wheel graph wheelGraph r = G.G vs es where vs = [0..r] es = [ [0,i] | i <- [1..r] ] ++ [ [i,i+1] | i <- [1..r-1] ] ++ [ [1,r] ] -- for normal form, should L.sort es mw4 = cycleMatroid $ G.edges $ wheelGraph 4 -- has [5,6,7,8] as unique circuit-hyperplane w4' = relaxation mw4 $ unique $ circuitHyperplanes mw4 -- [5,6,7,8] -- Oxley p183 w4 = fromGeoRep [] [] [[1,2,5],[1,4,8],[2,3,6],[3,4,7]] [[1,2,3,5,6],[1,2,4,5,8],[1,3,4,7,8],[2,3,4,6,7]] -- BINARY MATROIDS -- Oxley p344 isBinary2 m = all (even . length) [ c `LS.intersect` cc | c <- circuits m, cc <- cocircuits m ] -- RANK POLYNOMIAL -- Godsil & Royle p356 [x,y] = map glexVar ["x","y"] :: [GlexPoly Integer String] -- first naive version rankPoly1 m = sum [ x^(rm - r a) * y^(rm' - r' a') | a <- powersetdfs es, let a' = es LS.\\ a ] where es = elements m rm = rank m r = rankfun m m' = dual m rm' = rank m' r' = rankfun m' -- |Given a matroid m over elements es, the rank polynomial is a polynomial r(x,y), -- which is essentially a generating function for the subsets of es, enumerated by size and rank. -- It is efficiently calculated using deletion and contraction. -- -- It has the property that r(0,0) is the number of bases in m, r(1,0) is the number of independent sets, -- r(0,1) is the number of spanning sets. It can also be used to derive the chromatic polynomial of a graph, -- the weight enumerator of a linear code, and more. rankPoly :: (Ord a) => Matroid a -> GlexPoly Integer String rankPoly m | null es = 1 | isLoop m e = (1+y) * rankPoly (m \\\ [e]) -- deletion | isColoop m e = (1+x) * rankPoly (m /// [e]) -- contraction | otherwise = rankPoly (m \\\ [e]) + rankPoly (m /// [e]) where es = elements m e = head es numBases m = unwrap $ rankPoly m `bind` (\v -> case v of "x" -> 0; "y" -> 0) numIndeps m = unwrap $ rankPoly m `bind` (\v -> case v of "x" -> 1; "y" -> 0) numSpanning m = unwrap $ rankPoly m `bind` (\v -> case v of "x" -> 0; "y" -> 1) -- It is then possible to derive the chromatic poly of a graph from the rankPoly of its cycle matroid, etc -- Oxley p586 -- How many independent sets are there of each size indepCounts m = map length $ L.groupBy eqfst $ [(length i, i) | i <- indeps m] -- relying on shortlex order {- -- The following tries to calculate the indep counts -- as the Hilbert series of the Stanley-Reisner ring. -- However, it's not giving the right answer. indepCounts2 m = take r $ indepCounts' (circuits m) where n = length (elements m) -- the number of "variables" r = rank m n' = toInteger n indepCounts' [] = map (\k -> (k+n'-1) `choose` (n'-1)) [0..] -- the number of ways of choosing n-1 separators, so as to leave a product of k powers indepCounts' (c:cs) = let d = length c -- the "degree" of c cs' = reduce [] $ toShortlex $ toSet $ map (LS.\\ c) cs -- the quotient of cs by c in indepCounts' cs <-> (replicate d 0 ++ indepCounts' cs') reduce ls (r:rs) = if any (`LS.isSubset` r) ls then reduce ls rs else reduce (r:ls) rs reduce ls [] = reverse ls (x:xs) <+> (y:ys) = (x+y) : (xs <+> ys) xs <+> ys = xs ++ ys -- one of them is null xs <-> ys = xs <+> map negate ys -} -- Whitney numbers of the second kind -- The number of flats of each rank whitney2nd m = map length $ L.groupBy eqfst $ L.sort [(rankfun m f, f) | f <- flats m] -- Whitney numbers of the first kind -- The number of subsets (of the element set) of each rank whitney1st m = alternatingSign $ map length $ L.groupBy eqfst $ L.sort [(rankfun m x, x) | x <- powersetdfs (elements m)] where alternatingSign (x:xs) = x : alternatingSign (map negate xs) alternatingSign [] = [] -- TODO -- 1. Sort out the isomorphism code in the case where the incidence graph isn't connected -- 2. We could generate the geometric representation from a matroid (provided its rank <= 4) -- geoRep m = filter (isDependent m) (flats m) -- 3. isMatroidFlats HaskellForMaths-0.4.8/Math/Combinatorics/Poset.hs0000644000000000000000000003017312514742102020055 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. {-# 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.Core.Field import Math.Combinatorics.FiniteGeometry import Math.Algebra.LinearAlgebra import Math.Combinatorics.Digraph import Data.List as L import qualified Data.Map as M -- import qualified Data.Set as S -- |A poset is represented as a pair (set,po), where set is the underlying set of the poset, and po is the partial order relation newtype Poset t = Poset ([t], t -> t -> Bool) instance Eq t => Eq (Poset t) where Poset (set,po) == Poset (set',po') = set == set' && and [po x y == po' x y | x <- set, y <- set] -- There may be ways to avoid comparing every pair -- If we could calculate the coverGraph without comparing every pair, -- then it would be sufficient to test whether their cover graphs are equal instance Show t => Show (Poset t) where show (Poset (set,po)) = "Poset " ++ show set implies p q = q || not p isReflexive (set,po) = and [x `po` x | x <- set] isAntisymmetric (set,po) = and [((x `po` y) && (y `po` x)) `implies` (x == y) | x <- set, y <- set] isTransitive (set,po) = and [((x `po` y) && (y `po` z)) `implies` (x `po` z) | x <- set, y <- set, z <- set] isPoset poset = isReflexive poset && isAntisymmetric poset && isTransitive poset poset (set,po) | isPoset (set,po) = Poset (set,po) | otherwise = error "poset: Not a partial order" -- Most of the posets we will deal with are in fact lattices, meaning that any two elements -- have a meet (greatest lower bound) and join (least upper bound) intervals (Poset (set,po)) = [(a,b) | a <- set, b <- set, a `po` b] interval (Poset (set,po)) (x,z) = [y | y <- set, x `po` y, y `po` z] -- LINEAR ORDER POSET -- This is of course a lattice, with meet = min, join = max -- |A chain is a poset in which every pair of elements is comparable (ie either x <= y or y <= x). -- It is therefore a linear or total order. -- chainN n is the poset consisting of the numbers [1..n] ordered by (<=) chainN :: Int -> Poset Int chainN n = Poset ( [1..n], (<=) ) -- hasseN n = DG [1..n] [(i,i+1) | i <- [1..n-1]] -- |An antichain is a poset in which distinct elements are incomparable. -- antichainN n is the poset consisting of [1..n], with x <= y only when x == y. antichainN :: Int -> Poset Int antichainN n = Poset ( [1..n], (==) ) -- LATTICE OF (POSITIVE) DIVISORS OF N divides a b = b `rem` a == 0 divisors n = toSet [ d' | d <- takeWhile (\d -> d*d <= n) [1..], let (q,r) = n `quotRem` d, r == 0, d' <- [d,q] ] -- The toSet call sorts, and deduplicates if n is a square -- divisors n | n >= 1 = [a | a <- [1..n], a `divides` n] -- |posetD n is the lattice of (positive) divisors of n posetD :: Int -> Poset Int posetD n | n >= 1 = Poset ( divisors n, divides ) -- LATTICE OF SUBSETS OF [1..N] ORDERED BY INCLUSION -- (Boolean lattice) powerset [] = [[]] powerset (x:xs) = let p = powerset xs in p ++ map (x:) p {- -- subset test for sorted lists isSubset (x:xs) (y:ys) = case compare x y of LT -> False EQ -> isSubset xs ys GT -> isSubset (x:xs) ys isSubset [] _ = True isSubset _ [] = False -} -- |posetB n is the lattice of subsets of [1..n] ordered by inclusion posetB :: Int -> Poset [Int] posetB n = Poset ( powerset [1..n], LS.isSubset ) -- LATTICE OF SET PARTITIONS OF [1..N] ORDERED BY REFINEMENT partitions [] = [[]] partitions [x] = [[[x]]] partitions (x:xs) = let ps = partitions xs in map ([x]:) ps ++ [ (x:cell):p' | p <- ps, (cell,p') <- picks p] -- if the input is sorted, then so is the output 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 set partitions of [1..n], ordered by refinement posetP :: Int -> Poset [[Int]] posetP n = Poset ( partitions [1..n], isRefinement ) -- muP n = ... -- see van Lint and Wilson p336 -- LATTICE OF INTERVAL PARTITIONS OF [1..N] ORDERED BY REFINEMENT -- Interval partitions of [1..n] correspond to compositions of n intervalPartitions xs = filter (all isInterval) (partitions xs) isInterval (x1:x2:xs) = x1+1 == x2 && isInterval (x2:xs) isInterval _ = True intervalPartitions2 [] = [[]] intervalPartitions2 [x] = [[[x]]] 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 -- 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 | n >= 0 = ips n n where ips 0 _ = [[]] ips _ 0 = [] ips n m | m <= n = map (m:) (ips (n-m) m) ++ ips n (m-1) | otherwise = ips n n 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 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) -- |posetL n fq is the lattice of subspaces of the vector space Fq^n, ordered by inclusion. -- Subspaces are represented by their reduced row echelon form. -- Example usage: posetL 2 f3 posetL :: (Eq fq, Num fq) => Int -> [fq] -> Poset [[fq]] posetL n fq = Poset ( subspaces fq n, isSubspace ) -- choose n k = product [n-k+1..n] `div` product [1..k] -- NEW FROM OLD CONSTRUCTIONS -- |The subposet of a poset satisfying a predicate subposet :: Poset a -> (a -> Bool) -> Poset a subposet (Poset (set,po)) p = Poset (filter p set, po) -- |The direct sum of two posets dsum :: Poset a -> Poset b -> Poset (Either a b) dsum (Poset (setA,poA)) (Poset (setB,poB)) = Poset (set,po) where set = map Left setA ++ map Right setB po (Left a1) (Left a2) = poA a1 a2 po (Right b1) (Right b2) = poB b1 b2 po _ _ = False -- |The direct product of two posets dprod :: Poset a -> Poset b -> Poset (a,b) dprod (Poset (setA,poA)) (Poset (setB,poB)) = Poset ( [(a,b) | a <- setA, b <- setB], \(a1,b1) (a2,b2) -> (a1 `poA` a2) && (b1 `poB` b2) ) -- |The dual of a poset dual :: Poset a -> Poset a dual (Poset (set, po)) = Poset (set, po') where po' x y = po y x -- ANALYSIS OF POSETS -- |Given a poset (X,<=), we say that y covers x, written x -< y, if x < y and there is no z in X with x < z < y. -- The Hasse digraph of a poset is the digraph whose vertices are the elements of the poset, -- with an edge between every pair (x,y) with x -< y. -- The Hasse digraph can be represented diagrammatically as a Hasse diagram, by drawing x below y whenever x -< y. hasseDigraph :: (Eq a) => Poset a -> Digraph a hasseDigraph (Poset (set,po)) = DG set [(x,y) | x <- set, y <- set, x -< y] where x -< y = x /= y && x `po` y && null [z | z <- set, x `po` z, x /= z, z `po` y, z /= y] -- The partial order can be recovered as the transitive closure of the covers relation -- !! Can we construct the cover graph without having to compare every pair ?? -- If we know in advance the poset we're interested in, -- then we're probably better off constructing the Hasse digraph directly -- (In effect, the transitive closure of the edge relation) -- |Given a DAG (directed acyclic graph), return the poset consisting of the vertices of the DAG, ordered by reachability. -- This can be used to recover a poset from its Hasse digraph. reachabilityPoset :: (Ord a) => Digraph a -> Poset a reachabilityPoset (DG vs es) = Poset (vs,tc') -- \u v -> tc M.! (u,v) where tc = M.fromList [ ((u,v), tc' u v) | u <- vs, v <- vs] tc' u v | u == v = True | otherwise = or [tc M.! (w,v) | w <- successors u] successors u = [v | (u',v) <- es, u' == u] -- !! looks like we could memoise more than we are doing {- -- For example: > let poset = posetB 3 in poset == reachabilityPoset (hasseDigraph poset) True -} isOrderPreserving :: (a -> b) -> Poset a -> Poset b -> Bool isOrderPreserving f (Poset (seta,poa)) (Poset (setb,pob)) = and [ x `poa` y == f x `pob` f y | x <- seta, y <- seta ] -- Find all order isomorphisms between two posets -- This is the most naive algorithm, and should not be used on larger posets -- For example, already on the following, this takes forever compared to almost instant for orderIsos: -- > head $ orderIsos01 (posetD $ 8*9*25*49) (posetD $ 4*27*25*121) orderIsos01 (Poset (seta,poa)) (Poset (setb,pob)) | length seta /= length setb = [] | otherwise = orderIsos' [] seta setb where orderIsos' xys [] [] = [xys] orderIsos' xys (x:xs) ys = concat [ orderIsos' ((x,y):xys) xs ys' | (y,ys') <- picks ys, and [ (x `poa` x', x' `poa` x) == (y `pob` y', y' `pob` y) | (x',y') <- xys ] ] -- |Are the two posets order-isomorphic? isOrderIso :: (Ord a, Ord b) => Poset a -> Poset b -> Bool isOrderIso poseta posetb = (not . null) (orderIsos poseta posetb) -- For small posets, it may be that the up-front cost of calculating the hasseDigraph and heightPartitionDAG -- are not justified. -- |Find all order isomorphisms between two posets orderIsos :: (Ord a, Ord b) => Poset a -> Poset b -> [[(a,b)]] orderIsos posetA@(Poset (_,poa)) posetB@(Poset (_,pob)) | map length heightPartA /= map length heightPartB = [] | otherwise = dfs [] heightPartA heightPartB where heightPartA = heightPartitionDAG (hasseDigraph posetA) heightPartB = heightPartitionDAG (hasseDigraph posetB) dfs xys [] [] = [xys] dfs xys ([]:las) ([]:lbs) = dfs xys las lbs dfs xys ((x:xs):las) (ys:lbs) = concat [ dfs ((x,y):xys) (xs:las) (ys' : lbs) | (y,ys') <- picks ys, and [ (x `poa` x', x' `poa` x) == (y `pob` y', y' `pob` y) | (x',y') <- xys ] ] -- A variant on this algorithm would use the Hasse digraph rather than the partial order in the test on the last line -- This might be faster, depending how expensive the partial order comparison function is -- In effect though, it would then be a DAG isomorphism function -- The order automorphisms of a poset orderAuts1 poset = orderIsos poset poset -- This returns all automorphisms -- What we really want is to return generators of the permutation group -- |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. isLinext (Poset (set,po)) set' = all (\(x,y) -> not (y `po` x)) (pairs set') -- |Linear extensions of a poset linexts (Poset (set,po)) = linexts' [[]] set where linexts' lss (r:rs) = let lss' = [ lts ++ [r] ++ gts | ls <- lss, let ls' = takeWhile (not . (r `po`)) ls, (lts,gts) <- zip (inits ls') (tails ls), all (not . (`po` r)) gts ] in linexts' lss' rs linexts' lss [] = lss HaskellForMaths-0.4.8/Math/Combinatorics/StronglyRegularGraph.hs0000644000000000000000000002521512514742102023111 0ustar0000000000000000-- Copyright (c) 2008-2015, David Amos. All rights reserved. -- |A module defining various strongly regular graphs, including the Clebsch, Hoffman-Singleton, Higman-Sims, and McLaughlin graphs. -- -- A strongly regular graph with parameters (n,k,lambda,mu) is a (simple) graph with n vertices, -- in which the number of common neighbours of x and y is k, lambda or mu according as whether -- x and y are equal, adjacent, or non-adjacent. (In particular, it is a k-regular graph.) -- -- Strongly regular graphs are highly symmetric, and have large automorphism groups. module Math.Combinatorics.StronglyRegularGraph where import qualified Data.List as L import Data.Maybe (isJust) import qualified Data.Map as M import qualified Data.Set as S import Math.Common.ListSet import Math.Core.Utils (combinationsOf) import Math.Algebra.Group.PermutationGroup hiding (P) import Math.Algebra.Group.SchreierSims as SS import Math.Combinatorics.Graph as G hiding (G) import Math.Combinatorics.GraphAuts import Math.Combinatorics.Design as D import Math.Algebra.LinearAlgebra -- hiding (t) import Math.Algebra.Field.Base -- for F2 import Math.Combinatorics.FiniteGeometry -- Sources -- Godsil & Royle, Algebraic Graph Theory -- Cameron & van Lint, Designs, Graphs, Codes and their Links -- van Lint & Wilson, A Course in Combinatorics, 2nd ed -- STRONGLY REGULAR GRAPHS -- strongly regular graphs srgParams g | null es = error "srgParams: not defined for null graph" | null es' = error "srgParams: not defined for complete graph" | otherwise = if all (==k) ks && all (==lambda) ls && all (==mu) ms then Just (n,k,lambda,mu) else Nothing where vs = vertices g n = length vs es = edges g es' = combinationsOf 2 vs \\ es -- the non-edges k:ks = map (valency g) vs lambda:ls = map (length . commonNbrs) es -- common neighbours of adjacent vertices mu:ms = map (length . commonNbrs) es' -- common neighbours of non-adjacent vertices commonNbrs [v1,v2] = (nbrs_g M.! v1) `intersect` (nbrs_g M.! v2) nbrs_g = M.fromList [ (v, nbrs g v) | v <- vs ] isSRG g = isJust $ srgParams g -- SIMPLE EXAMPLES -- Triangular graph - van Lint & Wilson p262 -- http://mathworld.wolfram.com/TriangularGraph.html t' m = G.to1n $ t m t m | m >= 4 = graph (vs,es) where vs = combinationsOf 2 [1..m] es = [ [v,v'] | v <- vs, v' <- dropWhile (<= v) vs, not (disjoint v v')] -- This is just lineGraph (k m), by another name -- Lattice graph - van Lint & Wilson p262 -- http://mathworld.wolfram.com/LatticeGraph.html l2' m = G.to1n $ l2 m l2 m | m >= 2 = graph (vs,es) where vs = [ (i,j) | i <- [1..m], j <- [1..m] ] es = [ [v,v'] | v@(i,j) <- vs, v'@(i',j') <- dropWhile (<= v) vs, i == i' || j == j'] -- This is lineGraph (kb m m) -- Automorphism group is Sm * Sm * C2 -- via i -> ig, j -> jg, i <-> j paleyGraph fq | length fq `mod` 4 == 1 = graph (vs,es) where vs = fq qs = set [x^2 | x <- vs] \\ [0] -- the non-zero squares in Fq es = [ [x,y] | x <- vs, y <- vs, x < y, (x-y) `elem` qs] -- CLEBSCH GRAPH -- van Lint & Wilson, p263 clebsch' = G.to1n clebsch clebsch = graph (vs,es) where vs = L.sort $ filter (even . length) $ powerset [1..5] es = [ [v,v'] | v <- vs, v' <- dropWhile (<= v) vs, length (symDiff v v') == 4] -- Alternative construction from Cameron & van Lint p106 clebsch2 = graph (vs,es) where D xs bs = pairDesign 5 vs = [C] ++ [P x | x <- xs] ++ [B b | b <- bs] es = L.sort $ [ [B a, B b] | a <- bs, b <- dropWhile (<=a) bs, disjoint a b] ++ [ [P p, B b] | b <- bs, p <- b] ++ [ [C, P p] | p <- xs ] -- HOFFMAN-SINGLETON GRAPH -- Cameron, Permutation Groups, p79ff -- Godsil & Royle, p92ff -- Aut group is U3(5).2 (Atlas p34) triples = combinationsOf 3 [1..7] heptads = [ [a,b,c,d,e,f,g] | a <- triples, b <- triples, a < b, meetOne b a, c <- triples, b < c, all (meetOne c) [a,b], d <- triples, c < d, all (meetOne d) [a,b,c], e <- triples, d < e, all (meetOne e) [a,b,c,d], f <- triples, e < f, all (meetOne f) [a,b,c,d,e], g <- triples, f < g, all (meetOne g) [a,b,c,d,e,f], foldl intersect [1..7] [a,b,c,d,e,f,g] == [] ] where meetOne x y = length (intersect x y) == 1 -- each pair of triples meet in exactly one point, and there is no point in all of them - Godsil & Royle p69 -- (so these are the projective planes over 7 points) plane +^ g = L.sort [line -^ g | line <- plane] plane +^^ gs = orbit (+^) plane gs -- plane +^^ gs = closure [plane] [ +^ g | g <- gs ] hoffmanSingleton' = G.to1n hoffmanSingleton hoffmanSingleton = graph (vs,es) where h = head heptads hs = h +^^ _A 7 -- an A7 orbit of a heptad vs = map Left hs ++ map Right triples es = [ [Left h, Right t] | h <- hs, t <- triples, t `elem` h] ++ [ [Right t, Right t'] | t <- triples, t' <- dropWhile (<= t) triples, t `disjoint` t'] -- induced action of A7 on Hoffman-Singleton graph inducedA7 g = fromPairs [(v, v ~^ g) | v <- vs] where vs = vertices hoffmanSingleton (Left h) ~^ g = Left (h +^ g) (Right t) ~^ g = Right (t -^ g) hsA7 = toSn $ map inducedA7 $ _A 7 -- GEWIRTZ GRAPH -- van Lint & Wilson p266-7 -- (also called Sims-Gewirtz graph) gewirtz' = G.to1n gewirtz gewirtz = graph (vs,es) where vs = [xs | xs <- blocks s_3_6_22, 22 `notElem` xs] -- The 21 blocks of S(3,6,22) which contain 22 are the lines of PG(2,4) (projective plane over F4) -- The 56 blocks which don't are hyperovals in this plane. They form a 2-(21,6,4) design. es = [ [v,v'] | v <- vs, v' <- dropWhile (<= v) vs, length (v `intersect` v') == 0] -- HIGMAN-SIMS GRAPH -- Aut group is HS.2, where HS is the Higman-Sims sporadic simple group data DesignVertex = C | P Integer | B [Integer] deriving (Eq,Ord,Show) higmanSimsGraph' = G.to1n higmanSimsGraph -- Cameron & van Lint, p107 higmanSimsGraph = graph (vs,es) where D xs bs = s_3_6_22 vs = [C] ++ [P x | x <- xs] ++ [B b | b <- bs] es = L.sort $ [ [B a, B b] | a <- bs, b <- dropWhile (<=a) bs, disjoint a b] ++ [ [P p, B b] | b <- bs, p <- b] ++ [ [C, P p] | p <- xs ] -- s_3_6_22' = blocks s_3_6_22 -- There is an induced action of M22 on Higman Sims graph -- induced action of M22 on Higman-Sims graph inducedM22 g = fromPairs [(v, v ~^ g) | v <- vs] where -- G vs _ = higmanSimsGraph' vs = vertices higmanSimsGraph (B b) ~^ g = B (b -^ g) (P p) ~^ g = P (p .^ g) C ~^ _ = C higmanSimsM22 = toSn $ map inducedM22 $ m22sgs -- all (isGraphAut higmanSimsGraph) higmanSimsM22 -- M22 is one point stabilizer (of C) -- HS.2, where HS is Higman-Sims sporadic group _HS2 = SS.reduceGens $ graphAuts higmanSimsGraph -- (It will actually find 11 strong generators, but the first 4 are sufficient to generate the group) _HS = SS.derivedSubgp _HS2 -- SYMPLECTIC GRAPHS -- Godsil & Royle p242 sp2 r = graph (vs,es) where vs = tail $ ptsAG (2*r) f2 -- all non-zero pts in F2^2r es = [ [u,v] | [u,v] <- combinationsOf 2 vs, u <*>> n <.> v == 1] -- uT N v == 1, ie vectors adjacent if non-orthogonal n = fMatrix (2*r) (\i j -> if abs (i-j) == 1 && even (max i j) then 1 else 0) -- matrix defining a symplectic form sp n | even n = sp2 (n `div` 2) -- TWO GRAPHS AND SWITCHING -- SCHLAFLI GRAPH -- An srg(27,16,10,8) -- Has geometric interpretation in terms of 27 lines on general cubic surface in projective 3-space -- Aut group is G.2 where G = U4(2) = S4(3) (Atlas p26) -- (G.2 is also the Weyl group of E6 - don't know if there's any connection) -- Godsil & Royle p254ff switch g us | us `D.isSubset` vs = graph (vs, L.sort switchedes) where vs = vertices g us' = vs L.\\ us -- complement of us in vs es = edges g es' = S.fromList es switchedes = [e | e@[v1,v2] <- es, (v1 `elem` us) == (v2 `elem` us)] -- edges within us or its complement are unchanged ++ [ L.sort [v1,v2] | v1 <- us, v2 <- us', L.sort [v1,v2] `S.notMember` es'] -- edges between us and its complement are switched -- Godsil & Royle p259 schlafli' = G.to1n schlafli schlafli = graph (vs,es') where g = lineGraph $ k 8 v:vs = vertices g es = edges g gswitched = switch g (nbrs g v) -- switch off the vertex v es' = edges gswitched -- MCLAUGHLIN GRAPH -- Aut group is McL.2, where McL is the McLaughlin sporadic simple group -- http://people.csse.uwa.edu.au/gordon/constructions/mclaughlin/ -- http://mathworld.wolfram.com/McLaughlinGraph.html mcLaughlin' = G.to1n mcLaughlin mcLaughlin = graph (vs',es') where D xs bs = s_4_7_23 vs = map P xs ++ map B bs es = [ [P x, B b] | x <- xs, b <- bs, x `notElem` b] ++ [ [B b1, B b2] | b1 <- bs, b2 <- bs, b1 < b2, length (b1 `intersect` b2) == 1] g276 = graph (vs,es) g276switched = switch g276 (nbrs g276 (P 0)) P 0 : vs' = vs -- drop P 0 as it's now not connected es' = edges g276switched _McL2 = SS.reduceGens $ graphAuts mcLaughlin -- finds 14 auts - but takes half an hour (interpreted) to do so -- in fact just the first 2 are sufficient to generate the group _McL = SS.derivedSubgp $ _McL2 {- -- TWO GRAPH ON 276 VERTICES -- Has Conway's .3 as automorphism group -- Godsil & Royle p260ff twoGraph276 = let nt = D.incidenceMatrix s_4_7_23 n = L.transpose nt -- Godsil & Royle do incidence matrix the other way round to us s = L.transpose $ (j 23 23 <<->> i 23) +|+ (j 23 253 <<->> 2 *>> n) ++ (j 253 23 <<->> 2 *>> nt) +|+ (nt <<*>> n <<->> 5 *>> i 253 <<->> 2 *>> j 253 253) a = (map . map) (`div` 2) (j 276 276 <<->> i 276 <<->> s) in fromAdjacencyMatrix a where j r c = replicate r (replicate c 1) i = idMx (+|+) = zipWith (++) -- Its automorphism group *as a two-graph* is .3 (Co3) -- But its aut group as a graph is only M23 twoGraph276' = graph (vs,es) where D xs bs = s_4_7_23 vs = map P xs ++ map B bs es = [ [P x, B b] | x <- xs, b <- bs, x `notElem` b] ++ [ [B b1, B b2] | b1 <- bs, b2 <- bs, b1 < b2, length (b1 `intersect` b2) == 1] -- !! This isn't isomorphic to twoGraph276 -- (Perhaps it is in the same switching class though) -- We can obtain McLaughlin graph from this by switching in neighbourhood of P 0 -}HaskellForMaths-0.4.8/Math/Common/0000755000000000000000000000000012514742102015057 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Common/IntegerAsType.hs0000644000000000000000000000402012514742102020132 0ustar0000000000000000-- Copyright (c) David Amos, 2009. All rights reserved. {-# LANGUAGE EmptyDataDecls, ScopedTypeVariables #-} module Math.Common.IntegerAsType where class IntegerAsType a where value :: a -> Integer -- multiplication of IntegerAsType data M a b = M a b instance (IntegerAsType a, IntegerAsType b) => IntegerAsType (M a b) where value _ = value (undefined :: a) * value (undefined :: b) data TMinus1 instance IntegerAsType TMinus1 where value _ = -1 data TZero instance IntegerAsType TZero where value _ = 0 data TOne instance IntegerAsType TOne where value _ = 1 data T2 instance IntegerAsType T2 where value _ = 2 data T3 instance IntegerAsType T3 where value _ = 3 data T5 instance IntegerAsType T5 where value _ = 5 data T7 instance IntegerAsType T7 where value _ = 7 data T11 instance IntegerAsType T11 where value _ = 11 data T13 instance IntegerAsType T13 where value _ = 13 data T17 instance IntegerAsType T17 where value _ = 17 data T19 instance IntegerAsType T19 where value _ = 19 data T23 instance IntegerAsType T23 where value _ = 23 data T29 instance IntegerAsType T29 where value _ = 29 data T31 instance IntegerAsType T31 where value _ = 31 data T37 instance IntegerAsType T37 where value _ = 37 data T41 instance IntegerAsType T41 where value _ = 41 data T43 instance IntegerAsType T43 where value _ = 43 data T47 instance IntegerAsType T47 where value _ = 47 data T53 instance IntegerAsType T53 where value _ = 53 data T59 instance IntegerAsType T59 where value _ = 59 data T61 instance IntegerAsType T61 where value _ = 61 data T67 instance IntegerAsType T67 where value _ = 67 data T71 instance IntegerAsType T71 where value _ = 71 data T73 instance IntegerAsType T73 where value _ = 73 data T79 instance IntegerAsType T79 where value _ = 79 data T83 instance IntegerAsType T83 where value _ = 83 data T89 instance IntegerAsType T89 where value _ = 89 data T97 instance IntegerAsType T97 where value _ = 97 HaskellForMaths-0.4.8/Math/Common/ListSet.hs0000644000000000000000000000244612514742102017010 0ustar0000000000000000 module Math.Common.ListSet where import Data.List (group,sort) -- versions of Data.List functions which assume that the lists are ascending sets (no repeated elements) toListSet xs = map head $ group $ sort xs isListSet (x1:x2:xs) = x1 < x2 && isListSet (x2:xs) isListSet _ = True union (x:xs) (y:ys) = case compare x y of LT -> x : union xs (y:ys) EQ -> x : union xs ys GT -> y : union (x:xs) ys union [] ys = ys union xs [] = xs intersect (x:xs) (y:ys) = case compare x y of LT -> intersect xs (y:ys) EQ -> x : intersect xs ys GT -> intersect (x:xs) ys intersect _ _ = [] (x:xs) \\ (y:ys) = case compare x y of LT -> x : (xs \\ (y:ys)) EQ -> xs \\ ys GT -> (x:xs) \\ ys [] \\ _ = [] xs \\ [] = xs symDiff (x:xs) (y:ys) = case compare x y of LT -> x : symDiff xs (y:ys) EQ -> symDiff xs ys GT -> y : symDiff (x:xs) ys symDiff [] ys = ys symDiff xs [] = xs disjoint xs ys = null (intersect xs ys) isSubset (x:xs) (y:ys) = case compare x y of LT -> False EQ -> isSubset xs ys GT -> isSubset (x:xs) ys isSubset [] _ = True isSubset _ [] = False -- Note that an ListSet.elem turned out to be slower than Data.List.elem -- (Perhaps because it's slower when x `notElem` xs) HaskellForMaths-0.4.8/Math/CommutativeAlgebra/0000755000000000000000000000000012514742102017402 5ustar0000000000000000HaskellForMaths-0.4.8/Math/CommutativeAlgebra/GroebnerBasis.hs0000644000000000000000000004407012514742102022470 0ustar0000000000000000-- Copyright (c) David Amos, 2011. All rights reserved. {-# LANGUAGE TupleSections, NoMonomorphismRestriction #-} -- |A module providing an efficient implementation of the Buchberger algorithm for calculating the (reduced) Groebner basis for an ideal, -- together with some straightforward applications. module Math.CommutativeAlgebra.GroebnerBasis where import Data.List as L import qualified Data.IntMap as IM import qualified Data.Set as S import Math.Core.Utils import Math.Core.Field import Math.Algebras.VectorSpace import Math.Algebras.Structures import Math.CommutativeAlgebra.Polynomial -- Sources: -- Cox, Little, O'Shea: Ideals, Varieties and Algorithms -- Giovini, Mora, Niesi, Robbiano, Traverso, "One sugar cube please, or Selection strategies in the Buchberger algorithm" sPoly f g = let d = tgcd (lt f) (lt g) in (lt g `tdiv` d) *-> f - (lt f `tdiv` d) *-> g -- The point about the s-poly is that it cancels out the leading terms of the two polys, exposing their second terms isGB fs = all (\h -> h %% fs == 0) (pairWith sPoly fs) -- Initial, naive version -- Cox p87 gb1 fs = gb' fs (pairWith sPoly fs) where gb' gs (h:hs) = let h' = h %% gs in if h' == 0 then gb' gs hs else gb' (h':gs) (hs ++ map (sPoly h') gs) gb' gs [] = gs -- [f xi xj | xi <- xs, xj <- xs, i < j] pairWith f (x:xs) = map (f x) xs ++ pairWith f xs pairWith _ [] = [] -- Cox p89-90 reduce gs = reduce' gs [] where reduce' (l:ls) rs = let l' = l %% (rs ++ ls) in if l' == 0 then reduce' ls rs else reduce' ls (toMonic l':rs) reduce' [] rs = L.sort rs -- when using an elimination order, the elimination ideal will be at the end -- Cox et al p106-7 -- No need to calculate an spoly fi fj if -- 1. the lm fi and lm fj are coprime, or -- 2. there exists some fk, with (i,k) (j,k) already considered, and lm fk divides lcm (lm fi) (lm fj) -- some slight inefficiencies from looking up fi, fj repeatedly gb2 fs = reduce $ gb' fs (pairs [1..s]) s where s = length fs gb' gs ((i,j):ps) t = let fi = gs!i; fj = gs!j in if mcoprime (lm fi) (lm fj) || criterion fi fj then gb' gs ps t else let h = sPoly fi fj %% gs in if h == 0 then gb' gs ps t else gb' (gs++[h]) (ps ++ [ (i,t+1) | i <- [1..t] ]) (t+1) where criterion fi fj = let l = mlcm (lm fi) (lm fj) in any (test l) [1..t] test l k = k `notElem` [i,j] && ordpair i k `notElem` ps && ordpair j k `notElem` ps && lm (gs!k) `mdivides` l gb' gs [] _ = gs xs ! i = xs !! (i-1) -- in other words, index the list from 1 not 0 -- Doesn't result in any speedup gb2a fs = reduce $ gb' fs' (pairs [1..s]) s where fs' = IM.fromList $ zip [1..] $ filter (/= 0) fs s = IM.size fs' gb' gs ((i,j):ps) t = let fi = gs IM.! i; fj = gs IM.! j in if mcoprime (lm fi) (lm fj) || criterion fi fj then gb' gs ps t else let h = sPoly fi fj %% IM.elems gs in if h == 0 then gb' gs ps t else let t' = t+1 gs' = IM.insert t' h gs ps' = ps ++ map (,t') [1..t] in gb' gs' ps' t' where criterion fi fj = let l = mlcm (lm fi) (lm fj) in any (test l) [1..t] test l k = k `notElem` [i,j] && ordpair i k `notElem` ps && ordpair j k `notElem` ps && lm (gs IM.! k) `mdivides` l gb' gs [] _ = IM.elems gs -- version of gb2 where we eliminate pairs as they're created, rather than as they're processed gb3 fs = reduce $ gb1' [] fs [] 0 where gb1' gs (f:fs) ps t = let ps' = updatePairs gs ps f t in gb1' (gs ++ [f]) fs ps' (t+1) gb1' ls [] ps t = gb2' ls ps t gb2' gs ((i,j):ps) t = let h = sPoly (gs!i) (gs!j) %% gs in if h == 0 then gb2' gs ps t else let ps' = updatePairs gs ((i,j):ps) h t in gb2' (gs++[h]) ps' (t+1) gb2' gs [] _ = gs updatePairs gs ps f t = [p | p@(i,j) <- ps, not (lm f `mdivides` mlcm (lm (gs!i)) (lm (gs!j)))] ++ [ (i,t+1) | (gi,i) <- zip gs [1..t], not (mcoprime (lm gi) (lm f)), not (criterion (mlcm (lm gi) (lm f)) i) ] where criterion l i = any (`mdivides` l) [lm gk | (gk,k) <- zip gs [1..t], k /= i, ordpair i k `notElem` ps] -- Cox et al 108 -- 1. list smallest fs first, as more likely to reduce -- 2. order the pairs with smallest lcm fi fj first ("normal selection strategy") gb4 fs = reduce $ gb1' [] fs' [] 0 where fs' = reverse $ L.sort $ filter (/=0) fs gb1' gs (f:fs) ps t = gb1' (gs ++ [f]) fs ps' (t+1) where ps' = updatePairs gs ps f t gb1' ls [] ps t = gb2' ls ps t gb2' gs ((l,(i,j)):ps) t = let h = sPoly (gs!i) (gs!j) %% gs in if h == 0 then gb2' gs ps t else let ps' = updatePairs gs ((l,(i,j)):ps) h t in gb2' (gs++[h]) ps' (t+1) gb2' gs [] _ = gs updatePairs gs ps f t = let oldps = [p | p@(l,(i,j)) <- ps, not (lm f `mdivides` l)] newps = sortBy (flip cmpfst) [ (l,(i,t+1)) | (gi,i) <- zip gs [1..t], let l = mlcm (lm gi) (lm f), not (mcoprime (lm gi) (lm f)), not (criterion l i) ] in mergeBy (flip cmpfst) oldps newps where criterion l i = any (`mdivides` l) [lm gk | (gk,k) <- zip gs [1..t], k /= i, ordpair i k `notElem` map snd ps] mergeBy cmp (t:ts) (u:us) = case cmp t u of LT -> t : mergeBy cmp ts (u:us) EQ -> t : mergeBy cmp ts (u:us) GT -> u : mergeBy cmp (t:ts) us mergeBy _ ts us = ts ++ us -- one of them is null -- Giovini et al -- The point of sugar is, given fi, fj, to give an upper bound on the degree of sPoly fi fj without having to calculate it -- We can then select by preference pairs with lower sugar, expecting therefore that the s-polys will have lower degree -- It is only for Lex ordering that sugar seems to give a substantial improvement -- gb4 is fine for Grevlex -- !! can probably get rid of the Ord k requirement in the following -- |Given a list of polynomials over a field, return a Groebner basis for the ideal generated by the polynomials. gb :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => [Vect k m] -> [Vect k m] gb fs = let fs' = reverse $ sort $ map toMonic $ filter (/=0) fs in reduce $ gb1' [] fs' [] 0 where gb1' gs (f:fs) ps t = gb1' (gs ++ [f]) fs ps' (t+1) where ps' = updatePairs gs ps f (t+1) gb1' ls [] ps t = gb2' ls ps t gb2' gs (p@(_,(i,j)):ps) t = if h == 0 then gb2' gs ps t else gb2' (gs++[h]) ps' (t+1) where h = toMonic $ sPoly (gs!i) (gs!j) %% gs ps' = updatePairs gs (p:ps) h (t+1) gb2' gs [] _ = gs updatePairs gs ps gk k = let newps = [let l = mlcm (lm gi) (lm gk) in ((sugar gi gk l, l), (i,k)) | (gi,i) <- zip gs [1..k-1] ] ps' = [p | p@((sij,tij),(i,j)) <- ps, let ((sik,tik),_) = newps ! i, let ((sjk,tjk),_) = newps ! j, not ( (tik `mproperlydivides` tij) && (tjk `mproperlydivides` tij) ) ] -- sloppy variant newps' = discard1 [] newps newps'' = sortBy (flip cmpSug) $ discard2 [] $ sortBy (flip cmpNormal) newps' in mergeBy (flip cmpSug) ps' newps'' where discard1 ls (r@((_sik,tik),(i,_k)):rs) = if lm (gs!i) `mcoprime` lm gk -- then discard [l | l@((_,tjk),_) <- ls, tjk /= tik] [r | r@((_,tjk),_) <- ls, tjk /= tik] then discard1 (filter (\((_,tjk),_) -> tjk /= tik) ls) (filter (\((_,tjk),_) -> tjk /= tik) rs) else discard1 (r:ls) rs discard1 ls [] = ls discard2 ls (r@((_sik,tik),(i,k)):rs) = discard2 (r:ls) $ filter (\((_sjk,tjk),(j,k')) -> not (k == k' && tik `mdivides` tjk)) rs discard2 ls [] = ls -- The two calls to toMonic are designed to prevent coefficient explosion, but it is unproven that they are effective -- sugar of sPoly f g, where h = lcm (lt f) (lt g) -- this is an upper bound on deg (sPoly f g) sugar f g h = mdeg h + max (deg f - mdeg (lm f)) (deg g - mdeg (lm g)) cmpNormal ((s1,t1),(i1,j1)) ((s2,t2),(i2,j2)) = compare (t1,j1) (t2,j2) cmpSug ((s1,t1),(i1,j1)) ((s2,t2),(i2,j2)) = compare (-s1,t1,j1) (-s2,t2,j2) {- merge (t:ts) (u:us) = if t <= u then t : merge ts (u:us) else u : merge (t:ts) us merge ts us = ts ++ us -- one of them is null -} -- OPERATIONS ON IDEALS memberGB f gs = f %% gs == 0 -- |@memberI f gs@ returns whether f is in the ideal generated by gs memberI :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => Vect k m -> [Vect k m] -> Bool memberI f gs = memberGB f (gb gs) -- Cox et al, p181 -- |Given ideals I and J, their sum is defined as I+J = {f+g | f \<- I, g \<- J}. -- -- If fs and gs are generators for I and J, then @sumI fs gs@ returns generators for I+J. -- -- The geometric interpretation is that the variety of the sum is the intersection of the varieties, -- ie V(I+J) = V(I) intersect V(J) sumI :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => [Vect k m] -> [Vect k m] -> [Vect k m] sumI fs gs = gb (fs ++ gs) -- Cox et al, p183 -- |Given ideals I and J, their product I.J is the ideal generated by all products {f.g | f \<- I, g \<- J}. -- -- If fs and gs are generators for I and J, then @productI fs gs@ returns generators for I.J. -- -- The geometric interpretation is that the variety of the product is the union of the varieties, -- ie V(I.J) = V(I) union V(J) productI :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => [Vect k m] -> [Vect k m] -> [Vect k m] productI fs gs = gb [f * g | f <- fs, g <- gs] -- Cox et al, p185-6 -- |The intersection of ideals I and J is the set of all polynomials which belong to both I and J. -- -- If fs and gs are generators for I and J, then @intersectI fs gs@ returns generators for the intersection of I and J -- -- The geometric interpretation is that the variety of the intersection is the union of the varieties, -- ie V(I intersect J) = V(I) union V(J). -- -- The reason for prefering the intersection over the product is that the intersection of radical ideals is radical, -- whereas the product need not be. intersectI :: (Fractional k, Ord k, Monomial m, Ord m) => [Vect k m] -> [Vect k m] -> [Vect k m] intersectI fs gs = let t = toElimFst $ return $ (mvar "t" :: Glex String) hs = map ((t *) . toElimSnd) fs ++ map (((1-t) *) . toElimSnd) gs in eliminateFst hs toElimFst = fmap (\m -> Elim2 m munit) toElimSnd = fmap (\m -> Elim2 munit m) isElimFst = (/= munit) . (\(Elim2 m _) -> m) . lm fromElimSnd = fmap (\(Elim2 _ m) -> m) eliminateFst = map fromElimSnd . dropWhile isElimFst . gb -- Cox et al, p193-4 -- |Given ideals I and J, their quotient is defined as I:J = {f | f \<- R, f.g is in I for all g in J}. -- -- If fs and gs are generators for I and J, then @quotientI fs gs@ returns generators for I:J. -- -- The ideal quotient is the algebraic analogue of the Zariski closure of a difference of varieties. -- V(I:J) contains the Zariski closure of V(I)-V(J), with equality if k is algebraically closed and I is a radical ideal. quotientI :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => [Vect k m] -> [Vect k m] -> [Vect k m] quotientI _ [] = [1] quotientI fs gs = foldl1 intersectI $ map (quotientP fs) gs -- quotientI fs gs = foldl intersectI [1] $ map (quotientP fs) gs quotientP fs g = map ( // g ) $ intersectI fs [g] where h // g = let ([u],_) = quotRemMP h [g] in u -- |@eliminate vs gs@ returns the elimination ideal obtained from the ideal generated by gs by eliminating the variables vs. eliminate :: (Eq k, Fractional k, Ord k, MonomialConstructor m, Monomial (m v), Ord (m v)) => [Vect k (m v)] -> [Vect k (m v)] -> [Vect k (m v)] eliminate vs gs = let subs = subFst vs in eliminateFst [g `bind` subs | g <- gs] where subFst :: (Eq k, Num k, MonomialConstructor m, Eq (m v), Mon (m v)) => [Vect k (m v)] -> v -> Vect k (Elim2 (m v) (m v)) subFst vs = (\v -> let v' = var v in if v' `elem` vs then toElimFst v' else toElimSnd v') {- -- !! NOT WORKING -- |@elimExcept vs gs@ returns the elimination ideal obtained from the ideal generated by gs by eliminating all variables except vs. elimExcept :: (Fractional k, Ord k, MonomialConstructor m, Monomial (m v), Ord (m v)) => [Vect k (m v)] -> [Vect k (m v)] -> [Vect k (m v)] elimExcept vs gs = let subs = subSnd vs in eliminateFst [g `bind` subs | g <- gs] where subSnd :: (Num k, MonomialConstructor m, Eq (m v), Mon (m v)) => [Vect k (m v)] -> v -> Vect k (Elim2 (m v) (m v)) subSnd vs = (\v -> let v' = var v in if v' `elem` vs then toElimSnd v' else toElimFst v') -} -- MONOMIAL BASES FOR QUOTIENT ALGEBRAS -- basis for the polynomial ring in variables vs mbasis vs = mbasis' [1] where mbasis' ms = ms ++ mbasis' (toSet [v*m | v <- vs, m <- ms]) -- |Given variables vs, and a Groebner basis gs, @mbasisQA vs gs@ returns a monomial basis for the quotient algebra k[vs]/\. -- For example, @mbasisQA [x,y] [x^2+y^2-1]@ returns a monomial basis for k[x,y]/\. -- In general, the monomial basis is likely to be infinite. mbasisQA :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => [Vect k m] -> [Vect k m] -> [Vect k m] mbasisQA vs gs = mbasisQA' [1] where mbasisQA' [] = [] -- the quotient algebra is finite-dimensional mbasisQA' ms = ms ++ mbasisQA' (toSet [f | v <- vs, m <- ms, let f = v*m, f %% gs == f]) -- |Given an ideal I, the leading term ideal lt(I) consists of the leading terms of all elements of I. -- If I is generated by gs, then @ltIdeal gs@ returns generators for lt(I). ltIdeal :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => [Vect k m] -> [Vect k m] ltIdeal gs = map (return . lm) $ gb gs -- number of monomials of degree i in n variables numMonomials n i = toInteger (i+n-1) `choose` toInteger (n-1) -- |Given variables vs, and a homogeneous ideal gs, @hilbertFunQA vs gs@ returns the Hilbert function for the quotient algebra k[vs]/\. -- Given an integer i, the Hilbert function returns the number of degree i monomials in a basis for k[vs]/\. -- For a homogeneous ideal, this number is independent of the monomial ordering used -- (even though the elements of the monomial basis themselves are dependent on the ordering). -- -- If the ideal I is not homogeneous, then R/I is not graded, and the Hilbert function is not well-defined. -- Specifically, the number of degree i monomials in a basis is likely to depend on which monomial ordering you use. hilbertFunQA :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => [Vect k m] -> [Vect k m] -> Int -> Integer hilbertFunQA vs gs i = hilbertFunQA' (ltIdeal gs) i where n = length vs hilbertFunQA' _ i | i < 0 = 0 hilbertFunQA' (m:ms) i = hilbertFunQA' ms i - hilbertFunQA' (ms `quotientP` m) (i - deg m) hilbertFunQA' [] i = numMonomials n i -- For example, consider k[x,y]/ -- Under Lex ordering, the monomial basis is 1,y,y^2,y^3,... -- Under Glex ordering, the monomial basis is 1,x,y,x^2,xy,x^3,x^2y,... -- So the Hilbert function is not well-defined. -- Note though that this function does still correctly return the number of degree i monomials for the given monomial ordering -- naive implementation which simply counts monomials hilbertSeriesQA1 vs gs = hilbertSeriesQA1' [1] where hilbertSeriesQA1' [] = [] -- repeat 0 hilbertSeriesQA1' ms = length ms : hilbertSeriesQA1' (toSet [f | v <- vs, m <- ms, let f = v*m, f %% gs == f]) -- Eisenbud p325, p357 / Schenck p56 -- This can be made more efficient by choosing which m to recurse on -- |Given variables vs, and a homogeneous ideal gs, @hilbertSeriesQA vs gs@ returns the Hilbert series for the quotient algebra k[vs]/\. -- The Hilbert series should be interpreted as a formal power series where the coefficient of t^i is the Hilbert function evaluated at i. -- That is, the i'th element in the series is the number of degree i monomials in a basis for k[vs]/\. hilbertSeriesQA :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => [Vect k m] -> [Vect k m] -> [Integer] hilbertSeriesQA vs gs = hilbertSeriesQA' $ ltIdeal gs where hilbertSeriesQA' (m:ms) = hilbertSeriesQA' ms <-> (replicate (deg m) 0 ++ hilbertSeriesQA' (ms `quotientI` [m])) hilbertSeriesQA' [] = [numMonomials n i | i <- [0..] ] n = length vs (a:as) <-> (b:bs) = (a-b) : (as <-> bs) as <-> [] = as [] <-> bs = map negate bs -- |In the case where every variable v occurs in some generator g of the homogeneous ideal (the usual case), -- then the vs can be inferred from the gs. -- @hilbertSeriesQA' gs@ returns the Hilbert series for the quotient algebra k[vs]/\. hilbertSeriesQA' :: (Fractional k, Ord k, MonomialConstructor m, Ord (m v), Monomial (m v), Algebra k (m v)) => [Vect k (m v)] -> [Integer] hilbertSeriesQA' gs = hilbertSeriesQA vs gs where vs = toSet (concatMap vars gs) -- |For i \>\> 0, the Hilbert function becomes a polynomial in i, called the Hilbert polynomial. hilbertPolyQA :: (Fractional k, Ord k, Monomial m, Ord m, Algebra k m) => [Vect k m] -> [Vect k m] -> GlexPoly Q String hilbertPolyQA vs gs = hilbertPolyQA' (ltIdeal gs) i where n = toInteger $ length vs i = glexvar "i" hilbertPolyQA' [] x = product [ x + fromInteger j | j <- [1..n-1] ] / (fromInteger $ product [1..n-1]) hilbertPolyQA' (m:ms) x = hilbertPolyQA' ms x - hilbertPolyQA' (ms `quotientP` m) (x - fromIntegral (deg m)) hilbertPolyQA' :: (Fractional k, Ord k, MonomialConstructor m, Ord (m v), Monomial (m v), Algebra k (m v)) => [Vect k (m v)] -> GlexPoly Q String hilbertPolyQA' gs = hilbertPolyQA vs gs where vs = toSet (concatMap vars gs) -- The dimension of a variety dim vs gs = 1 + deg (hilbertPolyQA vs gs) dim' gs = 1 + deg (hilbertPolyQA' gs) HaskellForMaths-0.4.8/Math/CommutativeAlgebra/Polynomial.hs0000644000000000000000000004137112514742102022067 0ustar0000000000000000-- Copyright (c) 2011-2015, David Amos. All rights reserved. {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, DeriveFunctor #-} -- |A module defining the algebra of commutative polynomials over a field k. -- Polynomials are represented as the free k-vector space with the monomials as basis. -- -- A monomial ordering is required to specify how monomials are to be ordered. -- The Lex, Glex, and Grevlex monomial orders are defined, with the possibility to add others. -- -- In order to make use of this module, some variables must be defined, for example: -- -- > [t,u,v,x,y,z] = map glexvar ["t","u","v","x","y","z"] module Math.CommutativeAlgebra.Polynomial where import Prelude hiding ( (*>) ) import Math.Core.Field import Math.Core.Utils (toSet) import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures -- |In order to work with monomials, we need to be able to multiply them and divide them. -- Multiplication is defined by the Mon (monoid) class. Division is defined in this class. -- The functions here are primarily intended for internal use only. class (Eq m, Show m, Mon m) => Monomial m where mdivides :: m -> m -> Bool mdiv :: m -> m -> m mgcd :: m -> m -> m mlcm :: m -> m -> m mcoprime :: m -> m -> Bool mdeg :: m -> Int -- mlcm m1 m2 = let m = mgcd m1 m2 in mmult m1 (mdiv m2 m) mproperlydivides m1 m2 = m1 /= m2 && mdivides m1 m2 -- |We want to be able to construct monomials over any set of variables that we choose. -- Although we will often use String as the type of our variables, -- it is useful to define polymorphic types for monomials. class MonomialConstructor m where mvar :: v -> m v mindices :: m v -> [(v,Int)] -- |@var v@ creates a variable in the vector space of polynomials. -- For example, if we want to work in Q[x,y,z], we might define: -- -- > [x,y,z] = map var ["x","y","z"] :: [GlexPoly Q String] -- -- Notice that, in general, it is necessary to provide a type annotation so that -- the compiler knows which field and which term order to use. var :: (Num k, MonomialConstructor m) => v -> Vect k (m v) var = return . mvar -- class MonomialOrder m where -- isGraded :: m -> Bool -- MONOMIALS -- |The underlying implementation of monomials in variables of type v. Most often, we will be interested in MonImpl String, -- with the variable \"x\" represented by M 1 [(\"x\",1)]. However, other types can be used instead. -- -- No Ord instance is defined for MonImpl v, so it cannot be used as the basis for a free vector space of polynomials. -- Instead, several different newtype wrappers are provided, corresponding to different monomial orderings. data MonImpl v = M Int [(v,Int)] deriving (Eq, Functor) -- The initial Int is the degree of the monomial. Storing it speeds up equality tests and comparisons instance Show v => Show (MonImpl v) where show (M _ []) = "1" show (M _ xis) = concatMap (\(x,i) -> if i==1 then showVar x else showVar x ++ "^" ++ show i) xis where showVar x = filter ( /= '"' ) (show x) -- in case v == String instance (Ord v) => Mon (MonImpl v) where munit = M 0 [] mmult (M si xis) (M sj yjs) = M (si+sj) $ addmerge xis yjs instance (Ord v, Show v) => Monomial (MonImpl v) where mdivides (M si xis) (M sj yjs) = si <= sj && mdivides' xis yjs where mdivides' ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> False GT -> mdivides' ((x,i):xis) yjs EQ -> if i<=j then mdivides' xis yjs else False mdivides' [] _ = True mdivides' _ [] = False mdiv (M si xis) (M sj yjs) = M (si-sj) $ addmerge xis $ map (\(y,j) -> (y,-j)) yjs -- we don't check that the result has no negative indices mgcd (M _ xis) (M _ yjs) = mgcd' 0 [] xis yjs where mgcd' s zks ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> mgcd' s zks xis ((y,j):yjs) GT -> mgcd' s zks ((x,i):xis) yjs EQ -> let k = min i j in mgcd' (s+k) ((x,k):zks) xis yjs mgcd' s zks _ _ = M s (reverse zks) mlcm (M si xis) (M sj yjs) = mlcm' 0 [] xis yjs where mlcm' s zks ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> mlcm' (s+i) ((x,i):zks) xis ((y,j):yjs) GT -> mlcm' (s+j) ((y,j):zks) ((x,i):xis) yjs EQ -> let k = max i j in mlcm' (s+k) ((x,k):zks) xis yjs mlcm' s zks xis yjs = let zks' = xis ++ yjs; s' = sum (map snd zks') -- either xis or yjs is null in M (s+s') (reverse zks ++ zks') mcoprime (M _ xis) (M _ yjs) = mcoprime' xis yjs where mcoprime' ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> mcoprime' xis ((y,j):yjs) GT -> mcoprime' ((x,i):xis) yjs EQ -> False mcoprime' _ _ = True -- mcoprime m1 m2 = mgcd m1 m2 == munit mdeg (M s _) = s instance MonomialConstructor MonImpl where mvar v = M 1 [(v,1)] mindices (M si xis) = xis -- LEX ORDER -- |A type representing monomials with Lex ordering. -- -- Lex stands for lexicographic ordering. -- For example, in Lex ordering, monomials up to degree two would be ordered as follows: x^2+xy+xz+x+y^2+yz+y+z^2+z+1. newtype Lex v = Lex (MonImpl v) deriving (Eq, Functor, Mon, Monomial, MonomialConstructor) -- GeneralizedNewtypeDeriving instance Show v => Show (Lex v) where show (Lex m) = show m instance Ord v => Ord (Lex v) where compare (Lex (M si xis)) (Lex (M sj yjs)) = compare' xis yjs where compare' ((x,i):xis) ((y,j):yjs) = case compare x y of LT -> LT GT -> GT EQ -> case compare i j of LT -> GT GT -> LT EQ -> compare' xis yjs compare' [] [] = EQ compare' _ [] = LT compare' [] _ = GT -- unfortunately we can't use the following, because we want [] sorted after everything, not before -- compare [(x,-i) | (x,i) <- xis] [(y,-j) | (y,j) <- yjs] -- instance MonomialOrder Lex where isGraded _ = False -- |A type representing polynomials with Lex term ordering. type LexPoly k v = Vect k (Lex v) -- |@lexvar v@ creates a variable in the algebra of commutative polynomials over Q with Lex term ordering. -- It is provided as a shortcut, to avoid having to provide a type annotation, as with @var@. -- For example, the following code creates variables called x, y and z: -- -- > [x,y,z] = map lexvar ["x","y","z"] lexvar :: v -> LexPoly Q v lexvar v = return $ Lex $ M 1 [(v,1)] -- lexvar = var instance (Eq k, Num k, Ord v, Show v) => Algebra k (Lex v) where unit x = x *> return munit mult xy = nf $ fmap (\(a,b) -> a `mmult` b) xy -- GLEX ORDER -- |A type representing monomials with Glex ordering. -- -- Glex stands for graded lexicographic. Thus monomials are ordered first by degree, then by lexicographic order. -- For example, in Glex ordering, monomials up to degree two would be ordered as follows: x^2+xy+xz+y^2+yz+z^2+x+y+z+1. newtype Glex v = Glex (MonImpl v) deriving (Eq, Functor, Mon, Monomial, MonomialConstructor) -- GeneralizedNewtypeDeriving instance Show v => Show (Glex v) where show (Glex m) = show m instance Ord v => Ord (Glex v) where compare (Glex (M si xis)) (Glex (M sj yjs)) = compare (-si, [(x,-i) | (x,i) <- xis]) (-sj, [(y,-j) | (y,j) <- yjs]) -- instance MonomialOrder Glex where isGraded _ = True -- |A type representing polynomials with Glex term ordering. type GlexPoly k v = Vect k (Glex v) -- |@glexvar v@ creates a variable in the algebra of commutative polynomials over Q with Glex term ordering. -- It is provided as a shortcut, to avoid having to provide a type annotation, as with @var@. -- For example, the following code creates variables called x, y and z: -- -- > [x,y,z] = map glexvar ["x","y","z"] glexvar :: v -> GlexPoly Q v glexvar v = return $ Glex $ M 1 [(v,1)] -- glexvar = var instance (Eq k, Num k, Ord v, Show v) => Algebra k (Glex v) where unit x = x *> return munit mult xy = nf $ fmap (\(a,b) -> a `mmult` b) xy -- GREVLEX ORDER -- |A type representing monomials with Grevlex ordering. -- -- Grevlex stands for graded reverse lexicographic. Thus monomials are ordered first by degree, then by reverse lexicographic order. -- For example, in Grevlex ordering, monomials up to degree two would be ordered as follows: x^2+xy+y^2+xz+yz+z^2+x+y+z+1. -- -- In general, Grevlex leads to the smallest Groebner bases. newtype Grevlex v = Grevlex (MonImpl v) deriving (Eq, Functor, Mon, Monomial, MonomialConstructor) -- GeneralizedNewtypeDeriving instance Show v => Show (Grevlex v) where show (Grevlex m) = show m instance Ord v => Ord (Grevlex v) where compare (Grevlex (M si xis)) (Grevlex (M sj yjs)) = compare (-si, reverse xis) (-sj, reverse yjs) -- instance MonomialOrder Grevlex where isGraded _ = True -- |A type representing polynomials with Grevlex term ordering. type GrevlexPoly k v = Vect k (Grevlex v) -- |@grevlexvar v@ creates a variable in the algebra of commutative polynomials over Q with Grevlex term ordering. -- It is provided as a shortcut, to avoid having to provide a type annotation, as with @var@. -- For example, the following code creates variables called x, y and z: -- -- > [x,y,z] = map grevlexvar ["x","y","z"] grevlexvar :: v -> GrevlexPoly Q v grevlexvar v = return $ Grevlex $ M 1 [(v,1)] -- grevlexvar = var instance (Eq k, Num k, Ord v, Show v) => Algebra k (Grevlex v) where unit x = x *> return munit mult xy = nf $ fmap (\(a,b) -> a `mmult` b) xy -- ELIMINATION ORDER data Elim2 a b = Elim2 !a !b deriving (Eq, Functor) instance (Ord a, Ord b) => Ord (Elim2 a b) where compare (Elim2 a1 b1) (Elim2 a2 b2) = compare (a1,b1) (a2,b2) instance (Show a, Show b) => Show (Elim2 a b) where show (Elim2 ma mb) = case (show ma, show mb) of ("1","1") -> "1" (ma',"1") -> ma' ("1",mb') -> mb' (ma',mb') -> ma' ++ mb' instance (Mon a, Mon b) => Mon (Elim2 a b) where munit = Elim2 munit munit mmult (Elim2 a1 b1) (Elim2 a2 b2) = Elim2 (mmult a1 a2) (mmult b1 b2) instance (Monomial a, Monomial b) => Monomial (Elim2 a b) where mdivides (Elim2 a1 b1) (Elim2 a2 b2) = mdivides a1 a2 && mdivides b1 b2 mdiv (Elim2 a1 b1) (Elim2 a2 b2) = Elim2 (mdiv a1 a2) (mdiv b1 b2) mgcd (Elim2 a1 b1) (Elim2 a2 b2) = Elim2 (mgcd a1 a2) (mgcd b1 b2) mlcm (Elim2 a1 b1) (Elim2 a2 b2) = Elim2 (mlcm a1 a2) (mlcm b1 b2) mcoprime (Elim2 a1 b1) (Elim2 a2 b2) = mcoprime a1 a2 && mcoprime b1 b2 mdeg (Elim2 a b) = mdeg a + mdeg b instance (Eq k, Num k, Ord a, Mon a, Ord b, Mon b) => Algebra k (Elim2 a b) where unit x = x *> return munit mult xy = nf $ fmap (\(a,b) -> a `mmult` b) xy -- VARIABLE SUBSTITUTION -- |Given (Num k, MonomialConstructor m), then Vect k (m v) is the free commutative algebra over v. -- As such, it is a monad (in the mathematical sense). The following pseudo-code (not legal Haskell) -- shows how this would work: -- -- > instance (Num k, Monomial m) => Monad (\v -> Vect k (m v)) where -- > return = var -- > (>>=) = bind -- -- bind corresponds to variable substitution, so @v \`bind\` f@ returns the result of making the substitutions -- encoded in f into v. -- -- Note that the type signature is slightly more general than that required by (>>=). -- For a monad, we would only require: -- -- > bind :: (MonomialConstructor m, Num k, Ord (m v), Show (m v), Algebra k (m v)) => -- > Vect k (m u) -> (u -> Vect k (m v)) -> Vect k (m v) -- -- Instead, the given type signature allows us to substitute in elements of any algebra. -- This is occasionally useful. -- |bind performs variable substitution bind :: (Eq k, Num k, MonomialConstructor m, Ord a, Show a, Algebra k a) => Vect k (m v) -> (v -> Vect k a) -> Vect k a v `bind` f = linear (\m -> product [f x ^ i | (x,i) <- mindices m]) v -- V ts `bind` f = sum [c *> product [f x ^ i | (x,i) <- mindices m] | (m, c) <- ts] -- We can't express the Monad instance directly in Haskell, firstly because of the Ord v constraint (? - not used), -- secondly because Haskell doesn't support type functions. flipbind f = linear (\m -> product [f x ^ i | (x,i) <- mindices m]) -- |Evaluate a polynomial at a point. -- For example @eval (x^2+y^2) [(x,1),(y,2)]@ evaluates x^2+y^2 at the point (x,y)=(1,2). eval :: (Eq k, Num k, MonomialConstructor m, Eq (m v), Show v) => Vect k (m v) -> [(Vect k (m v), k)] -> k eval f vs = unwrap $ f `bind` sub where sub x = case lookup (var x) vs of Just xval -> xval *> return () Nothing -> error ("eval: no binding given for " ++ show x) -- |Perform variable substitution on a polynomial. -- For example @subst (x*z-y^2) [(x,u^2),(y,u*v),(z,v^2)]@ performs the substitution x -> u^2, y -> u*v, z -> v^2. subst :: (Eq k, Num k, MonomialConstructor m, Eq (m u), Show u, Ord (m v), Show (m v), Algebra k (m v)) => Vect k (m u) -> [(Vect k (m u), Vect k (m v))] -> Vect k (m v) subst f vs = f `bind` sub where sub x = case lookup (var x) vs of Just xsub -> xsub Nothing -> error ("eval: no binding given for " ++ show x) -- The type could be more general than this, but haven't so far found a use case -- |List the variables used in a polynomial vars :: (Num k, Ord k, MonomialConstructor m, Ord (m v)) => Vect k (m v) -> [Vect k (m v)] vars f = toSet [ var v | (m,_) <- terms f, v <- map fst (mindices m) ] -- DIVISION ALGORITHM FOR POLYNOMIALS lt (V (t:ts)) = t -- leading term lm = fst . lt -- leading monomial lc = snd . lt -- leading coefficient -- deg :: (Num k, Monomial m, MonomialOrder m) => Vect k m -> Int deg (V []) = -1 deg f = maximum $ [mdeg m | (m,c) <- terms f] {- deg f | isGraded (lm f) = mdeg (lm f) | otherwise = maximum $ [mdeg m | (m,c) <- terms f] -} -- the true degree of the polynomial, not the degree of the leading term -- required for sugar strategy when computing Groebner basis toMonic 0 = 0 toMonic f = (1 / lc f) *> f -- tdivmaybe (m1,x1) (m2,x2) = fmap (\m -> (m,x1/x2)) $ mdivmaybe m1 m2 tdivides (m1,x1) (m2,x2) = mdivides m1 m2 tdiv (m1,x1) (m2,x2) = (mdiv m1 m2, x1/x2) tgcd (m1,_) (m2,_) = (mgcd m1 m2, 1) -- tlcm (m1,_) (m2,_) = (mlcm m1 m2, 1) tmult (m,c) (m',c') = (mmult m m',c*c') infixl 7 *-> t *-> V ts = V $ map (tmult t) ts -- preserves term order -- given f, gs, find as, r such that f = sum (zipWith (*) as gs) + r, with r not divisible by any g quotRemMP f gs = quotRemMP' f (replicate n 0, 0) where n = length gs quotRemMP' 0 (us,r) = (us,r) quotRemMP' h (us,r) = divisionStep h (gs,[],us,r) divisionStep h (g:gs,us',u:us,r) = if lt g `tdivides` lt h then let t = V [lt h `tdiv` lt g] h' = h - t*g u' = u+t in quotRemMP' h' (reverse us' ++ u':us, r) else divisionStep h (gs,u:us',us,r) divisionStep h ([],us',[],r) = let (lth,h') = splitlt h in quotRemMP' h' (reverse us', r+lth) splitlt (V (t:ts)) = (V [t], V ts) rewrite f gs = rewrite' (f,0) gs where rewrite' (0,r) _ = r rewrite' (l,r) (h:hs) = if lt h `tdivides` lt l -- if lhs of "rewrite rule" h matches then let l' = l - V [lt l `tdiv` lt h] * h -- apply rewrite rule to eliminate leading term in rewrite' (l',r) gs -- then start again and try to eliminate the new lt. else rewrite' (l,r) hs -- else try the next potential divisor rewrite' (l,r) [] = -- none of the rewrite rules matches lt l let (h,t) = split l in rewrite' (t, r + h) gs -- so move it into the remainder r, and try to rewrite the other terms split (V (t:ts)) = (V [t], V ts) infixl 7 %% -- |@f %% gs@ is the reduction of a polynomial f with respect to a list of polynomials gs. -- In the case where the gs are a Groebner basis for an ideal I, -- then @f %% gs@ is the equivalence class representative of f in R/I, -- and is zero if and only if f is in I. (%%) :: (Eq k, Fractional k, Monomial m, Ord m, Algebra k m) => Vect k m -> [Vect k m] -> Vect k m f %% gs = rewrite f gs -- f %% gs = r where (_,r) = quotRemMP f gs -- |As a convenience, a partial instance of Fractional is defined for polynomials. -- The instance is well-defined only for scalars, and gives an error if used on other values. -- The purpose of this is to allow entry of fractional scalars, in expressions such as @x/2@. -- On the other hand, an expression such as @2/x@ will return an error. instance (Eq k, Fractional k, Monomial m, Ord m, Algebra k m) => Fractional (Vect k m) where recip (V [(m,c)]) | m == munit = V [(m,1/c)] | otherwise = error "Polynomial recip: only defined for scalars" fromRational x = V [(munit, fromRational x)] HaskellForMaths-0.4.8/Math/Core/0000755000000000000000000000000012514742102014517 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Core/Field.hs0000644000000000000000000003745212514742102016111 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- |A module defining the field Q of rationals and the small finite fields (Galois fields) -- F2, F3, F4, F5, F7, F8, F9, F11, F13, F16, F17, F19, F23, F25. -- -- Given a prime power q, Fq is the type representing elements of the field (eg @F4@), -- fq is a list of the elements of the field, beginning 0,1,... (eg @f4@), -- and for prime power fields, aq is a primitive element, which generates the multiplicative group (eg @a4@). -- -- The design philosophy is that fq, the list of elements, represents the field. -- Thus, many functions elsewhere in the library expect to take fq as an argument, -- telling them which field to work over. module Math.Core.Field where import Data.Ratio import Data.Bits import Data.List as L import Math.Core.Utils (FinSet, elts) -- |Q is just the rationals, but with a better show function than the Prelude version newtype Q = Q Rational deriving (Eq,Ord,Num,Fractional) instance Show Q where show (Q x) | b == 1 = show a | otherwise = show a ++ "/" ++ show b where a = numerator x b = denominator x numeratorQ (Q x) = Data.Ratio.numerator x denominatorQ (Q x) = Data.Ratio.denominator x -- The following implementations of the prime fields are only slightly faster than the versions in Math.Algebra.Field.Base -- |F2 is a type for the finite field with 2 elements newtype F2 = F2 Int deriving (Eq,Ord) instance Show F2 where show (F2 x) = show x instance Num F2 where F2 x + F2 y = F2 $ (x+y) .&. 1 -- `mod` 2 negate x = x F2 x * F2 y = F2 $ x*y fromInteger n = F2 $ fromInteger n `mod` 2 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F2 where recip (F2 0) = error "F2.recip 0" recip (F2 1) = F2 1 fromRational _ = error "F2.fromRational: not well defined" instance FinSet F2 where elts = f2 -- |f2 is a list of the elements of F2 f2 :: [F2] f2 = map fromInteger [0..1] -- :: [F2] -- |F3 is a type for the finite field with 3 elements newtype F3 = F3 Int deriving (Eq,Ord) instance Show F3 where show (F3 x) = show x instance Num F3 where F3 x + F3 y = F3 $ (x+y) `mod` 3 negate (F3 0) = F3 0 negate (F3 x) = F3 $ 3 - x F3 x * F3 y = F3 $ (x*y) `mod` 3 fromInteger n = F3 $ fromInteger n `mod` 3 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F3 where recip (F3 0) = error "F3.recip 0" recip (F3 x) = F3 x fromRational _ = error "F3.fromRational: not well defined" instance FinSet F3 where elts = f3 -- |f3 is a list of the elements of F3 f3 :: [F3] f3 = map fromInteger [0..2] -- :: [F3] -- |F5 is a type for the finite field with 5 elements newtype F5 = F5 Int deriving (Eq,Ord) instance Show F5 where show (F5 x) = show x instance Num F5 where F5 x + F5 y = F5 $ (x+y) `mod` 5 negate (F5 0) = F5 0 negate (F5 x) = F5 $ 5 - x F5 x * F5 y = F5 $ (x*y) `mod` 5 fromInteger n = F5 $ fromInteger n `mod` 5 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F5 where recip (F5 0) = error "F5.recip 0" recip (F5 x) = F5 $ (x^3) `mod` 5 fromRational _ = error "F5.fromRational: not well defined" instance FinSet F5 where elts = f5 -- |f5 is a list of the elements of F5 f5 :: [F5] f5 = map fromInteger [0..4] -- |F7 is a type for the finite field with 7 elements newtype F7 = F7 Int deriving (Eq,Ord) instance Show F7 where show (F7 x) = show x instance Num F7 where F7 x + F7 y = F7 $ (x+y) `mod` 7 negate (F7 0) = F7 0 negate (F7 x) = F7 $ 7 - x F7 x * F7 y = F7 $ (x*y) `mod` 7 fromInteger n = F7 $ fromInteger n `mod` 7 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F7 where recip (F7 0) = error "F7.recip 0" recip (F7 x) = F7 $ (x^5) `mod` 7 fromRational _ = error "F7.fromRational: not well defined" instance FinSet F7 where elts = f7 -- |f7 is a list of the elements of F7 f7 :: [F7] f7 = map fromInteger [0..6] -- |F11 is a type for the finite field with 11 elements newtype F11 = F11 Int deriving (Eq,Ord) instance Show F11 where show (F11 x) = show x instance Num F11 where F11 x + F11 y = F11 $ (x+y) `mod` 11 negate (F11 0) = F11 0 negate (F11 x) = F11 $ 11 - x F11 x * F11 y = F11 $ (x*y) `mod` 11 fromInteger n = F11 $ fromInteger n `mod` 11 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F11 where recip (F11 0) = error "F11.recip 0" recip (F11 x) = F11 $ (x^9) `mod` 11 fromRational _ = error "F11.fromRational: not well defined" instance FinSet F11 where elts = f11 -- |f11 is a list of the elements of F11 f11 :: [F11] f11 = map fromInteger [0..10] -- |F13 is a type for the finite field with 13 elements newtype F13 = F13 Int deriving (Eq,Ord) instance Show F13 where show (F13 x) = show x instance Num F13 where F13 x + F13 y = F13 $ (x+y) `mod` 13 negate (F13 0) = F13 0 negate (F13 x) = F13 $ 13 - x F13 x * F13 y = F13 $ (x*y) `mod` 13 fromInteger n = F13 $ fromInteger n `mod` 13 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F13 where recip (F13 0) = error "F13.recip 0" recip (F13 x) = F13 $ (x5*x5*x) `mod` 13 where x5 = x^5 `mod` 13 -- 12^11 would overflow Int fromRational _ = error "F13.fromRational: not well defined" instance FinSet F13 where elts = f13 -- |f13 is a list of the elements of F13 f13 :: [F13] f13 = map fromInteger [0..12] -- |F17 is a type for the finite field with 17 elements newtype F17 = F17 Int deriving (Eq,Ord) instance Show F17 where show (F17 x) = show x instance Num F17 where F17 x + F17 y = F17 $ (x+y) `mod` 17 negate (F17 0) = F17 0 negate (F17 x) = F17 $ 17 - x F17 x * F17 y = F17 $ (x*y) `mod` 17 fromInteger n = F17 $ fromInteger n `mod` 17 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F17 where recip (F17 0) = error "F17.recip 0" recip (F17 x) = F17 $ (x5^3) `mod` 17 where x5 = x^5 `mod` 17 -- 16^15 would overflow Int fromRational _ = error "F17.fromRational: not well defined" instance FinSet F17 where elts = f17 -- |f17 is a list of the elements of F17 f17 :: [F17] f17 = map fromInteger [0..16] -- |F19 is a type for the finite field with 19 elements newtype F19 = F19 Int deriving (Eq,Ord) instance Show F19 where show (F19 x) = show x instance Num F19 where F19 x + F19 y = F19 $ (x+y) `mod` 19 negate (F19 0) = F19 0 negate (F19 x) = F19 $ 19 - x F19 x * F19 y = F19 $ (x*y) `mod` 19 fromInteger n = F19 $ fromInteger n `mod` 19 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F19 where recip (F19 0) = error "F17.recip 0" recip (F19 x) = F19 $ (x4^4*x) `mod` 19 where x4 = x^4 `mod` 19 -- 18^17 would overflow Int fromRational _ = error "F19.fromRational: not well defined" instance FinSet F19 where elts = f19 -- |f19 is a list of the elements of F19 f19 :: [F19] f19 = map fromInteger [0..18] -- |F23 is a type for the finite field with 23 elements newtype F23 = F23 Int deriving (Eq,Ord) instance Show F23 where show (F23 x) = show x instance Num F23 where F23 x + F23 y = F23 $ (x+y) `mod` 23 negate (F23 0) = F23 0 negate (F23 x) = F23 $ 23 - x F23 x * F23 y = F23 $ (x*y) `mod` 23 fromInteger n = F23 $ fromInteger n `mod` 23 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F23 where recip (F23 0) = error "F23.recip 0" recip (F23 x) = F23 $ (x5^4*x) `mod` 23 where x5 = x^5 `mod` 23 -- 22^21 would overflow Int fromRational _ = error "F23.fromRational: not well defined" instance FinSet F23 where elts = f23 -- |f23 is a list of the elements of F23 f23 :: [F23] f23 = map fromInteger [0..22] -- The following implementations of the prime power fields are significantly faster than the versions in Math.Algebra.Field.Extension -- |F4 is a type for the finite field with 4 elements. -- F4 is represented as the extension of F2 by an element a4 satisfying x^2+x+1 = 0 newtype F4 = F4 Int deriving (Eq,Ord) instance Show F4 where show (F4 0x00) = "0" show (F4 0x01) = "1" show (F4 0x10) = "a4" show (F4 0x11) = "a4+1" -- == a4^2 -- |a4 is a primitive element for F4 as an extension over F2. a4 satisfies x^2+x+1 = 0. a4 :: F4 a4 = F4 0x10 instance Num F4 where F4 x + F4 y = F4 $ (x+y) .&. 0x11 negate x = x F4 x * F4 y = let z = x*y in if z `testBit` 8 then F4 ((z + 0x11) .&. 0x11) -- this is replacing x^2 by x+1 else F4 z fromInteger n = F4 $ fromInteger n .&. 1 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F4 where recip (F4 0) = error "F4.recip 0" recip (F4 1) = F4 1 recip (F4 x) = F4 (x `xor` 1) fromRational _ = error "F4.fromRational: not well defined" instance FinSet F4 where elts = f4 -- |f4 is a list of the elements of F4 f4 :: [F4] f4 = L.sort $ 0 : powers a4 powers x | x /= 0 = 1 : takeWhile (/=1) (iterate (*x) x) -- |F8 is a type for the finite field with 8 elements. -- F8 is represented as the extension of F2 by an element a8 satisfying x^3+x+1 = 0 newtype F8 = F8 Int deriving (Eq,Ord) instance Show F8 where show (F8 0x0) = "0" show (F8 0x1) = "1" show (F8 0x10) = "a8" show (F8 0x11) = "a8+1" show (F8 0x100) = "a8^2" show (F8 0x101) = "a8^2+1" show (F8 0x110) = "a8^2+a8" show (F8 0x111) = "a8^2+a8+1" -- |a8 is a primitive element for F8 as an extension over F2. a8 satisfies x^3+x+1 = 0. a8 :: F8 a8 = F8 0x10 instance Num F8 where F8 x + F8 y = F8 $ (x+y) .&. 0x111 negate x = x F8 x * F8 y = F8 $ ((z43 `shiftR` 8) + (z43 `shiftR` 12) + z) .&. 0x111 where z = x*y; z43 = z .&. 0xff000; -- z210 = z .&. 0xfff -- Explanation: We are making the substitution x^3 = x+1, x^4 = x^2+x fromInteger n = F8 $ fromInteger n .&. 0x1 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F8 where recip (F8 0) = error "F8.recip 0" recip x = x^6 fromRational _ = error "F8.fromRational: not well defined" instance FinSet F8 where elts = f8 -- |f8 is a list of the elements of F8 f8 :: [F8] f8 = L.sort $ 0 : powers a8 -- |F9 is a type for the finite field with 9 elements. -- F9 is represented as the extension of F3 by an element a9 satisfying x^2+2x+2 = 0 newtype F9 = F9 Int deriving (Eq,Ord) instance Show F9 where show (F9 0x00) = "0" show (F9 0x01) = "1" show (F9 0x02) = "2" show (F9 0x100) = "a9" show (F9 0x101) = "a9+1" show (F9 0x102) = "a9+2" show (F9 0x200) = "2a9" show (F9 0x201) = "2a9+1" show (F9 0x202) = "2a9+2" -- |a9 is a primitive element for F9 as an extension over F3. a9 satisfies x^2+2x+2 = 0. a9 :: F9 a9 = F9 0x100 instance Num F9 where F9 x + F9 y = F9 $ z1 + z0 where z = x+y; z1 = (z .&. 0xff00) `rem` 0x300; z0 = (z .&. 0xff) `rem` 3 negate (F9 x) = F9 $ z1 + z0 where z = 0x303 - x; z1 = (z .&. 0xff00) `rem` 0x300; z0 = (z .&. 0xff) `rem` 3 F9 x * F9 y = F9 $ ((z2 + z1) `rem` 0x300) + ((z2 + z0) `rem` 3) where z = x*y; z2 = z .&. 0xff0000; z1 = z .&. 0xff00; z0 = z .&. 0xff -- Explanation: We are substituting x^2 = x+1. -- We could do z2 `shiftR` 8 and z2 `shiftR` 16 -- However, because 0x100 `mod` 3 == 1, we don't need to fromInteger n = F9 $ fromInteger n `mod` 3 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F9 where recip (F9 0) = error "F9.recip 0" recip x = x^7 fromRational _ = error "F9.fromRational: not well defined" instance FinSet F9 where elts = f9 -- |f9 is a list of the elements of F9 f9 :: [F9] f9 = L.sort $ 0 : powers a9 -- |F16 is a type for the finite field with 16 elements. -- F16 is represented as the extension of F2 by an element a16 satisfying x^4+x+1 = 0 newtype F16 = F16 Int deriving (Eq,Ord) instance Show F16 where show (F16 0x0) = "0" show (F16 0x1) = "1" show (F16 0x10) = "a16" show (F16 0x11) = "a16+1" show (F16 0x100) = "a16^2" show (F16 0x101) = "a16^2+1" show (F16 0x110) = "a16^2+a16" show (F16 0x111) = "a16^2+a16+1" show (F16 0x1000) = "a16^3" show (F16 0x1001) = "a16^3+1" show (F16 0x1010) = "a16^3+a16" show (F16 0x1011) = "a16^3+a16+1" show (F16 0x1100) = "a16^3+a16^2" show (F16 0x1101) = "a16^3+a16^2+1" show (F16 0x1110) = "a16^3+a16^2+a16" show (F16 0x1111) = "a16^3+a16^2+a16+1" -- |a16 is a primitive element for F16 as an extension over F2. a16 satisfies x^4+x+1 = 0. a16 :: F16 a16 = F16 0x10 instance Num F16 where F16 x + F16 y = F16 $ (x+y) .&. 0x1111 negate x = x F16 x * F16 y = F16 $ ((z654 `shiftR` 12) + (z654 `shiftR` 16) + z) .&. 0x1111 where z = x*y; z654 = z .&. 0xfff0000; -- z3210 = z .&. 0xffff -- Explanation: We are making the substitution x^4 = x+1 (and also for x^5, x^6) fromInteger n = F16 $ fromInteger n .&. 0x1 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F16 where recip (F16 0) = error "F16.recip 0" recip x = x^14 fromRational _ = error "F16.fromRational: not well defined" instance FinSet F16 where elts = f16 -- |f16 is a list of the elements of F16 f16 :: [F16] f16 = L.sort $ 0 : powers a16 -- |F25 is a type for the finite field with 25 elements. -- F25 is represented as the extension of F5 by an element a25 satisfying x^2+4x+2 = 0 newtype F25 = F25 Int deriving (Eq,Ord) instance Show F25 where show (F25 x) = case ( (x .&. 0xff00) `shiftR` 8, x .&. 0xff ) of (0,x0) -> show x0 (1,0) -> "a25" (1,x0) -> "a25+" ++ show x0 (x1,0) -> show x1 ++ "a25" (x1,x0) -> show x1 ++ "a25+" ++ show x0 -- |a25 is a primitive element for F25 as an extension over F5. a25 satisfies x^2+4x+2 = 0. a25 :: F25 a25 = F25 0x100 instance Num F25 where F25 x + F25 y = F25 $ z1 + z0 where z = x+y; z1 = (z .&. 0xff00) `rem` 0x500; z0 = (z .&. 0xff) `rem` 5 negate (F25 x) = F25 $ z1 + z0 where z = 0x505 - x; z1 = (z .&. 0xff00) `rem` 0x500; z0 = (z .&. 0xff) `rem` 5 F25 x * F25 y = F25 $ ((z2 + z1) `rem` 0x500) + ((3*z2 + z0) `rem` 5) where z = x*y; z2 = z .&. 0xff0000; z1 = z .&. 0xff00; z0 = z .&. 0xff -- Explanation: We are substituting x^2 = x+3. -- We could do z2 `shiftR` 8 and z2 `shiftR` 16 -- However, because 0x100 `mod` 5 == 1, we don't need to fromInteger n = F25 $ fromInteger n `mod` 5 abs _ = error "Prelude.Num.abs: inappropriate abstraction" signum _ = error "Prelude.Num.signum: inappropriate abstraction" instance Fractional F25 where recip (F25 0) = error "F25.recip 0" recip x = x^23 fromRational _ = error "F25.fromRational: not well defined" instance FinSet F25 where elts = f25 -- |f25 is a list of the elements of F25 f25 :: [F25] f25 = L.sort $ 0 : powers a25 HaskellForMaths-0.4.8/Math/Core/Utils.hs0000644000000000000000000001643512514742102016164 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction, TupleSections #-} -- |A module of simple utility functions which are used throughout the rest of the library module Math.Core.Utils where import Data.List as L import qualified Data.Set as S toSet = S.toList . S.fromList sortDesc = L.sortBy (flip compare) insertDesc = L.insertBy (flip compare) -- |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 setUnionDesc :: Ord a => [a] -> [a] -> [a] setUnionDesc (x:xs) (y:ys) = case compare x y of GT -> x : setUnionDesc xs (y:ys) EQ -> x : setUnionDesc xs ys LT -> y : setUnionDesc (x:xs) ys setUnionDesc xs ys = xs ++ ys -- |The (multi-)set intersection of two ascending lists. If both inputs are strictly increasing, -- then the output is the set intersection and is strictly increasing. If both inputs are weakly increasing, -- then the output is the multiset intersection (with multiplicity), and is weakly increasing. intersectAsc :: Ord a => [a] -> [a] -> [a] intersectAsc (x:xs) (y:ys) = case compare x y of LT -> intersectAsc xs (y:ys) EQ -> x : intersectAsc xs ys GT -> intersectAsc (x:xs) ys intersectAsc _ _ = [] -- |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 == sortDesc (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 -- |Is the element in the ascending list? -- -- With infinite lists, this can fail to terminate. -- For example, elemAsc 1 [1/2,3/4,7/8..] would fail to terminate. -- However, with a list of Integer, this will always terminate. elemAsc :: Ord a => a -> [a] -> Bool elemAsc x (y:ys) = case compare x y of LT -> False EQ -> True GT -> elemAsc x ys -- or x `elemAsc` ys = x `elem` takeWhile (<= x) ys -- |Is the element not in the ascending list? (With infinite lists, this can fail to terminate.) notElemAsc :: Ord a => a -> [a] -> Bool notElemAsc x (y:ys) = case compare x y of LT -> True EQ -> False GT -> notElemAsc x ys -- From Conor McBride -- http://stackoverflow.com/questions/12869097/splitting-list-into-a-list-of-possible-tuples/12872133#12872133 -- |Return all the ways to \"pick one and leave the others\" from a list picks :: [a] -> [(a,[a])] picks [] = [] picks (x:xs) = (x,xs) : [(y,x:ys) | (y,ys) <- picks xs] pairs (x:xs) = map (x,) xs ++ pairs xs pairs [] = [] ordpair x y | x < y = (x,y) | otherwise = (y,x) -- fold a comparison operator through a list foldcmpl p xs = and $ zipWith p xs (tail xs) -- foldcmpl p (x1:x2:xs) = p x1 x2 && foldcmpl p (x2:xs) -- foldcmpl _ _ = True -- foldcmpl _ [] = True -- foldcmpl p xs = and $ zipWith p xs (tail xs) isWeaklyIncreasing :: Ord t => [t] -> Bool isWeaklyIncreasing = foldcmpl (<=) isStrictlyIncreasing :: Ord t => [t] -> Bool isStrictlyIncreasing = foldcmpl (<) isWeaklyDecreasing :: Ord t => [t] -> Bool isWeaklyDecreasing = foldcmpl (>=) isStrictlyDecreasing :: Ord t => [t] -> Bool isStrictlyDecreasing = foldcmpl (>) -- for use with L.sortBy cmpfst x y = compare (fst x) (fst y) -- for use with L.groupBy eqfst x y = (==) (fst x) (fst y) fromBase b xs = foldl' (\n x -> n * b + x) 0 xs -- |Given a set @xs@, represented as an ordered list, @powersetdfs xs@ returns the list of all subsets of xs, in lex order powersetdfs :: [a] -> [[a]] powersetdfs xs = map reverse $ dfs [ ([],xs) ] where dfs ( (ls,rs) : nodes ) = ls : dfs (successors (ls,rs) ++ nodes) dfs [] = [] successors (ls,rs) = [ (r:ls, rs') | r:rs' <- L.tails rs ] -- |Given a set @xs@, represented as an ordered list, @powersetbfs xs@ returns the list of all subsets of xs, in shortlex order powersetbfs :: [a] -> [[a]] powersetbfs xs = map reverse $ bfs [ ([],xs) ] where bfs ( (ls,rs) : nodes ) = ls : bfs ( nodes ++ successors (ls,rs) ) bfs [] = [] successors (ls,rs) = [ (r:ls, rs') | r:rs' <- L.tails rs ] -- |Given a positive integer @k@, and a set @xs@, represented as a list, -- @combinationsOf k xs@ returns all k-element subsets of xs. -- The result will be in lex order, relative to the order of the xs. combinationsOf :: Int -> [a] -> [[a]] combinationsOf 0 _ = [[]] combinationsOf _ [] = [] combinationsOf k (x:xs) | k > 0 = map (x:) (combinationsOf (k-1) xs) ++ combinationsOf k xs -- |@choose n k@ is the number of ways of choosing k distinct elements from an n-set choose :: (Integral a) => a -> a -> a choose n k = product [n-k+1..n] `div` product [1..k] -- |The class of finite sets class FinSet x where elts :: [x] -- |A class representing algebraic structures having an inverse operation. -- Note that in some cases not every element has an inverse. class HasInverses a where inverse :: a -> a infix 8 ^- -- |A trick: x^-1 returns the inverse of x (^-) :: (Num a, HasInverses a, Integral b) => a -> b -> a x ^- n = inverse x ^ nHaskellForMaths-0.4.8/Math/NumberTheory/0000755000000000000000000000000012514742102016252 5ustar0000000000000000HaskellForMaths-0.4.8/Math/NumberTheory/Factor.hs0000644000000000000000000002404212514742102020026 0ustar0000000000000000-- Copyright (c) 2006-2011, David Amos. All rights reserved. {-# LANGUAGE BangPatterns #-} -- |A module for finding prime factors. module Math.NumberTheory.Factor (module Math.NumberTheory.Prime, pfactors, ppfactors, pfactorsTo, ppfactorsTo) where import Control.Arrow (second, (&&&)) import Data.Either (lefts) import Data.List as L import Math.Core.Utils (multisetSumAsc) import Math.NumberTheory.Prime -- |List the prime factors of n (with multiplicity). For example: -- >>> pfactors 60 -- [2,2,3,5] -- -- This says that 60 = 2 * 2 * 3 * 5 -- -- The algorithm uses trial division to find small factors, -- followed if necessary by the elliptic curve method to find larger factors. -- The running time increases with the size of the second largest prime factor of n. -- It can find 10-digit prime factors in seconds, but can struggle with 20-digit prime factors. pfactors :: Integer -> [Integer] pfactors n | n > 0 = pfactors' n $ takeWhile (< 10000) primes | n < 0 = -1 : pfactors' (-n) (takeWhile (< 10000) primes) where pfactors' n (d:ds) | n == 1 = [] | n < d*d = [n] | r == 0 = d : pfactors' q (d:ds) | otherwise = pfactors' n ds where (q,r) = quotRem n d pfactors' n [] = pfactors'' n pfactors'' n = if isMillerRabinPrime n then [n] else let d = findFactorParallelECM n -- findFactorECM n in multisetSumAsc (pfactors'' d) (pfactors'' (n `div` d)) -- |List the prime power factors of n. For example: -- >>> ppfactors 60 -- [(2,2),(3,1),(5,1)] -- -- This says that 60 = 2^2 * 3^1 * 5^1 ppfactors :: Integer -> [(Integer,Int)] ppfactors = map (head &&& length) . L.group . pfactors -- ppfactors = map (\xs -> (head xs, length xs)) . L.group . pfactors -- |Find the prime factors of all numbers up to n. Thus @pfactorsTo n@ is equivalent to @[(m, pfactors m) | m <- [1..n]]@, -- except that the results are not returned in order. For example: -- >>> pfactorsTo 10 -- [(8,[2,2,2]),(4,[2,2]),(6,[3,2]),(10,[5,2]),(2,[2]),(9,[3,3]),(3,[3]),(5,[5]),(7,[7]),(1,[])] -- -- @pfactorsTo n@ is significantly faster than @map pfactors [1..n]@ for larger n. pfactorsTo n = pfactorsTo' (1,[]) primes where pfactorsTo' (!m,!qs) ps@(ph:pt) | m' > n = [(m,qs)] | otherwise = pfactorsTo' (m',ph:qs) ps ++ pfactorsTo' (m,qs) pt where m' = m*ph -- We avoid a reverse call, because it does make a noticeable difference to the speed. -- |Find the prime power factors of all numbers up to n. Thus @ppfactorsTo n@ is equivalent to @[(m, ppfactors m) | m <- [1..n]]@, -- except that the results are not returned in order. For example: -- >>> ppfactorsTo 10 -- [(8,[(2,3)]),(4,[(2,2)]),(6,[(3,1),(2,1)]),(10,[(5,1),(2,1)]),(2,[(2,1)]),(9,[(3,2)]),(3,[(3,1)]),(5,[(5,1)]),(7,[(7,1)]),(1,[])] -- -- @ppfactorsTo n@ is significantly faster than @map ppfactors [1..n]@ for larger n. ppfactorsTo = map (second (map (head &&& length) . L.group)) . pfactorsTo -- Cohen, A Course in Computational Algebraic Number Theory, p488 -- return (u,v,d) s.t ua+vb = d, with d = gcd a b extendedEuclid a b | b == 0 = (1,0,a) | otherwise = let (q,r) = a `quotRem` b -- a == qb + r (s,t,d) = extendedEuclid b r -- s*b+t*r == d in (t,s-q*t,d) -- s*b+t*(a-q*b) == d -- ELLIPTIC CURVE ARITHMETIC data EllipticCurve = EC Integer Integer Integer deriving (Eq, Show) -- EC p a b represents the curve y^2 == x^3+ax+b over Fp data EllipticCurvePt = Inf | P Integer Integer deriving (Eq, Show) -- P x y isEltEC _ Inf = True isEltEC (EC n a b) (P x y) = (y*y - x*x*x - a*x - b) `mod` n == 0 -- Koblitz p34 -- Addition in an elliptic curve, with bailout if the arithmetic fails (giving a potential factor of n) ecAdd _ Inf pt = Right pt ecAdd _ pt Inf = Right pt ecAdd (EC n a b) (P x1 y1) (P x2 y2) | x1 /= x2 = let (_,v,d) = extendedEuclid n ((x1-x2) `mod` n) -- we're expecting d == 1, v == 1/(x1-x2) (mod n) m = (y1-y2) * v `mod` n x3 = (m*m - x1 - x2) `mod` n y3 = (-y1 + m*(x1 - x3)) `mod` n in if d == 1 then Right (P x3 y3) else Left d | x1 == x2 = if (y1 + y2) `mod` n == 0 -- includes the case y1 == y2 == 0 then Right Inf else let (_,v,d) = extendedEuclid n ((2*y1) `mod` n) -- we're expecting d == 1, v == 1/(2*y1) (mod n) m = (3*x1*x1 + a) * v `mod` n x3 = (m*m - 2*x1) `mod` n y3 = (-y1 + m*(x1 - x3)) `mod` n in if d == 1 then Right (P x3 y3) else Left d -- Note that b isn't actually used anywhere -- Note, only the final `mod` n calls when calculating x3, y3 are necessary -- and the code is faster if the others are removed -- Scalar multiplication in an elliptic curve ecSmult _ 0 _ = Right Inf ecSmult ec k pt | k > 0 = ecSmult' k pt Inf where -- ecSmult' k q p = k * q + p ecSmult' 0 _ p = Right p ecSmult' i q p = let p' = if odd i then ecAdd ec p q else Right p q' = ecAdd ec q q in case (p',q') of (Right p'', Right q'') -> ecSmult' (i `div` 2) q'' p'' (Left _, _) -> p' (_, Left _) -> q' -- ELLIPTIC CURVE FACTORISATION -- We choose an elliptic curve E over Zn, and a point P on the curve -- We then try to calculate kP, for suitably chosen k -- What we are hoping is that at some stage we will fail because we can't invert an element in Zn -- This will lead to finding a non-trivial factor of n discriminantEC a b = 4 * a * a * a + 27 * b * b -- perform a sequence of scalar multiplications in the elliptic curve, hoping for a bailout ecTrial ec@(EC n a b) ms pt | d == 1 = ecTrial' ms pt | otherwise = Left d where d = gcd n (discriminantEC a b) ecTrial' [] pt = Right pt ecTrial' (m:ms) pt = case ecSmult ec m pt of Right pt' -> ecTrial' ms pt' Left d -> Left d -- In effect, we're calculating ecSmult ec (product ms) pt, but an m at a time l n = exp (sqrt (log n * log (log n))) -- L(n) is some sort of measure of the average smoothness of numbers up to n -- # [x <= n | x is L(n)^a-smooth] = n L(n)^(-1/2a+o(1)) -- Cohen p 482 -- q is the largest prime we're looking for - normally sqrt n -- the b figure here is from Cohen p488 multipliers q = [p' | p <- takeWhile (<= b) primes, let p' = last (takeWhile (<= b) (powers p))] where b = round ((l q) ** (1/sqrt 2)) powers x = iterate (*x) x findFactorECM n | gcd n 6 == 1 = let ms = multipliers (sqrt $ fromInteger n) in head $ filter ( (/= 0) . (`mod` n) ) $ lefts [ecTrial (EC n a 1) ms (P 0 1) | a <- [1..] ] -- the filter is because d might be a multiple of n, -- for example if the problem was that the discriminant was divisible by n -- TESTING MULTIPLE CURVES IN PARALLEL -- Cohen p489 -- find inverse of as mod n in parallel, or a non-trivial factor of n parallelInverse n as = if d == 1 then Right bs else Left $ head [d' | a <- as, let d' = gcd a n, d' /= 1] where c:cs = reverse $ scanl (\x y -> x*y `mod` n) 1 as ds = scanl (\x y -> x*y `mod` n) 1 (reverse as) (u,_,d) = extendedEuclid c n bs = reverse [ u*nota `mod` n | nota <- zipWith (*) cs ds] -- let m = length as -- then the above code requires O(m) mod calls - in fact 3m-3 calls (?) parallelEcAdd n ecs ps1 ps2 = case parallelInverse n (zipWith f ps1 ps2) of Right invs -> Right [g ec p1 p2 inv | (ec,p1,p2,inv) <- L.zip4 ecs ps1 ps2 invs] Left d -> Left d where f Inf pt = 1 f pt Inf = 1 f (P x1 y1) (P x2 y2) | x1 /= x2 = x1-x2 -- slightly faster not to `mod` n here | x1 == x2 = 2*y1 -- slightly faster not to `mod` n here -- inverses = parallelInverse n $ zipWith f ps1 ps2 g _ Inf pt _ = pt g _ pt Inf _ = pt g (EC n a b) (P x1 y1) (P x2 y2) inv | x1 /= x2 = let m = (y1-y2) * inv -- slightly faster not to `mod` n here x3 = (m*m - x1 - x2) `mod` n y3 = (-y1 + m*(x1 - x3)) `mod` n in P x3 y3 | x1 == x2 = if (y1 + y2) `elem` [0,n] -- `mod` n == 0 -- includes the case y1 == y2 == 0 then Inf else let m = (3*x1*x1 + a) * inv -- slightly faster not to `mod` n here x3 = (m*m - 2*x1) `mod` n y3 = (-y1 + m*(x1 - x3)) `mod` n in P x3 y3 parallelEcSmult _ _ 0 pts = Right $ map (const Inf) pts parallelEcSmult n ecs k pts | k > 0 = ecSmult' k pts (map (const Inf) pts) where -- ecSmult' k qs ps = k * qs + ps ecSmult' 0 _ ps = Right ps ecSmult' k qs ps = let ps' = if odd k then parallelEcAdd n ecs ps qs else Right ps qs' = parallelEcAdd n ecs qs qs in case (ps',qs') of (Right ps'', Right qs'') -> ecSmult' (k `div` 2) qs'' ps'' (Left _, _) -> ps' (_, Left _) -> qs' parallelEcTrial n ecs ms pts | all (==1) ds = ecTrial' ms pts | otherwise = Left $ head $ filter (/=1) ds where ds = [gcd n (discriminantEC a b) | EC n a b <- ecs] ecTrial' [] pts = Right pts ecTrial' (m:ms) pts = case parallelEcSmult n ecs m pts of Right pts' -> ecTrial' ms pts' Left d -> Left d findFactorParallelECM n | gcd n 6 == 1 = let ms = multipliers (sqrt $ fromInteger n) in head $ filter ( (/= 0) . (`mod` n) ) $ lefts [parallelEcTrial n [EC n (a+i) 1 | i <- [1..100]] ms (replicate 100 (P 0 1)) | a <- [0,100..] ] -- 100 at a time is chosen heuristically. HaskellForMaths-0.4.8/Math/NumberTheory/Prime.hs0000644000000000000000000001232712514742102017667 0ustar0000000000000000-- Copyright (c) 2006-2011, David Amos. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction #-} -- |A module providing functions to test for primality, and find next and previous primes. module Math.NumberTheory.Prime (primes, isTrialDivisionPrime, isMillerRabinPrime, isPrime, notPrime, prevPrime, nextPrime) where import System.Random import System.IO.Unsafe isTrialDivisionPrime n | n > 1 = not $ any (\p -> n `rem` p == 0) (takeWhile (\p -> p*p <= n) primes) | otherwise = False -- |A (lazy) list of the primes primes :: [Integer] primes = 2 : filter isPrime [3,5..] where isPrime n = not $ any (\p -> n `rem` p == 0) (takeWhile (\p -> p*p <= n) primes) {- -- This is just marginally faster, but less elegant primes2 :: [Integer] primes2 = 2 : 3 : 5 : 7 : filter isPrime (concat [ [m30+11,m30+13,m30+17,m30+19,m30+23,m30+29,m30+31,m30+37] | m30 <- [0,30..] ]) where isPrime n = not $ any (\p -> n `rem` p == 0) (takeWhile (\p -> p*p <= n) primes2') primes2' = drop 3 primes2 -} {- -- initial version. This isn't going to be very good if n has any "large" prime factors (eg > 10000) pfactors1 n | n > 0 = pfactors' n primes | n < 0 = -1 : pfactors' (-n) primes where pfactors' n (d:ds) | n == 1 = [] | n < d*d = [n] | r == 0 = d : pfactors' q (d:ds) | otherwise = pfactors' n ds where (q,r) = quotRem n d -} -- MILLER-RABIN TEST -- Cohen, A Course in Computational Algebraic Number Theory, p422 -- Koblitz, A Course in Number Theory and Cryptography -- Let n-1 = 2^s * q, q odd -- Then n is a strong pseudoprime to base b if -- either b^q == 1 (mod n) -- or b^(2^r * q) == -1 (mod n) for some 0 <= r < s -- (For we know that if n is prime, then b^(n-1) == 1 (mod n) isStrongPseudoPrime n b = let (s,q) = split2s 0 (n-1) -- n-1 == 2^s * q, with q odd in isStrongPseudoPrime' n (s,q) b isStrongPseudoPrime' n (s,q) b | b' == 1 = True | otherwise = n-1 `elem` squarings where b' = power_mod b q n -- b' = b^q `mod` n squarings = take s $ iterate (\x -> x*x `mod` n) b' -- b^(2^r *q) for 0 <= r < s -- split2s 0 m returns (s,t) such that 2^s * t == m, t odd split2s s t = let (q,r) = t `quotRem` 2 in if r == 0 then split2s (s+1) q else (s,t) -- power_mod b t n == b^t mod n power_mod b t n = powerMod' b 1 t where powerMod' x y 0 = y powerMod' x y t = let (q,r) = t `quotRem` 2 in powerMod' (x*x `rem` n) (if r == 0 then y else x*y `rem` n) q isMillerRabinPrime' n | n >= 4 = let (s,q) = split2s 0 (n-1) -- n-1 == 2^s * q, with q odd in do g <- getStdGen let rs = randomRs (2,n-1) g return $ all (isStrongPseudoPrime' n (s,q)) (take 25 rs) | n >= 2 = return True | otherwise = return False -- Cohen states that if we restrict our rs to single word numbers, we can use a more efficient powering algorithm -- isMillerRabinPrime :: Integer -> Bool isMillerRabinPrime n = unsafePerformIO (isMillerRabinPrime' n) -- |Is this number prime? The algorithm consists of using trial division to test for very small factors, -- followed if necessary by the Miller-Rabin probabilistic test. isPrime :: Integer -> Bool isPrime n | n > 1 = isPrime' $ takeWhile (< 100) primes | otherwise = False where isPrime' (d:ds) | n < d*d = True | otherwise = let (q,r) = quotRem n d in if r == 0 then False else isPrime' ds isPrime' [] = isMillerRabinPrime n -- the < 100 is found heuristically to be about the point at which trial division stops being worthwhile notPrime :: Integer -> Bool notPrime = not . isPrime -- |Given n, @prevPrime n@ returns the greatest p, p < n, such that p is prime prevPrime :: Integer -> Integer prevPrime n | n > 5 = head $ filter isPrime $ candidates | n < 3 = error "prevPrime: no previous primes" | n == 3 = 2 | otherwise = 3 where n6 = (n `div` 6) * 6 candidates = dropWhile (>= n) $ concat [ [m6+5,m6+1] | m6 <- [n6, n6-6..] ] -- |Given n, @nextPrime n@ returns the least p, p > n, such that p is prime nextPrime :: Integer -> Integer nextPrime n | n < 2 = 2 | n < 3 = 3 | otherwise = head $ filter isPrime $ candidates where n6 = (n `div` 6) * 6 candidates = dropWhile (<= n) $ concat [ [m6+1,m6+5] | m6 <- [n6, n6+6..] ] {- -- slightly better version. This is okay so long as n has at most one "large" prime factor (> 10000) -- if it has more, it does at least tell you, via an error message, that it has run into difficulties pfactors2 n | n > 0 = pfactors' n $ takeWhile (< 10000) primes | n < 0 = -1 : pfactors' (-n) (takeWhile (< 10000) primes) where pfactors' n (d:ds) | n == 1 = [] | n < d*d = [n] | r == 0 = d : pfactors' q (d:ds) | otherwise = pfactors' n ds where (q,r) = quotRem n d pfactors' n [] = if isMillerRabinPrime n then [n] else error ("pfactors2: can't factor " ++ show n) -} HaskellForMaths-0.4.8/Math/NumberTheory/QuadraticField.hs0000644000000000000000000001121412514742102021466 0ustar0000000000000000-- Copyright (c) 2011-2015, 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 HaskellForMaths-0.4.8/Math/Projects/0000755000000000000000000000000012514742102015420 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Projects/MiniquaternionGeometry.hs0000644000000000000000000002733612514742102022505 0ustar0000000000000000-- Copyright (c) David Amos, 2009-2015. All rights reserved. module Math.Projects.MiniquaternionGeometry where import Prelude hiding ( (<*), (*>) ) import qualified Data.List as L import Math.Common.ListSet as LS import Math.Core.Utils (combinationsOf) import Math.Algebra.Field.Base import Math.Combinatorics.FiniteGeometry (pnf, ispnf, orderPGL) -- import Math.Combinatorics.Graph import Math.Combinatorics.GraphAuts import Math.Algebra.Group.PermutationGroup hiding (order) import qualified Math.Algebra.Group.SchreierSims as SS import Math.Algebra.Group.RandomSchreierSims import Math.Combinatorics.Design as D import Math.Algebra.LinearAlgebra -- ( (<.>), (<+>) ) import Math.Projects.ChevalleyGroup.Classical -- Sources: -- Miniquaternion Geometry, Room & Kirkpatrick -- Survey of Non-Desarguesian Planes, Charles Weibel -- F9, defined by adding sqrt of -1 to F3. (The Conway poly for F9 is not so convenient for us here) data F9 = F9 F3 F3 deriving (Eq,Ord) instance Show F9 where show (F9 0 0) = "0" show (F9 0 1) = "e" show (F9 0 2) = "-e" show (F9 1 0) = "1" show (F9 1 1) = "1+e" show (F9 1 2) = "1-e" show (F9 2 0) = "-1" show (F9 2 1) = "-1+e" show (F9 2 2) = "-1-e" e = F9 0 1 -- sqrt of -1 instance Num F9 where F9 a1 b1 + F9 a2 b2 = F9 (a1+a2) (b1+b2) F9 a1 b1 * F9 a2 b2 = F9 (a1*a2-b1*b2) (a1*b2+a2*b1) negate (F9 a b) = F9 (negate a) (negate b) fromInteger n = F9 (fromInteger n) 0 f9 = [F9 a b | a <- f3, b <- f3] w = 1-e -- a primitive element - generates the multiplicative group conj (F9 a b) = F9 a (-b) -- This is just the Frobenius aut x -> x^3 norm (F9 a b) = a^2 + b^2 -- == x * conj x instance Fractional F9 where recip x@(F9 a b) = F9 (a/n) (-b/n) where n = norm x instance FiniteField F9 where basisFq _ = [1,e] -- J9, or Q, defined by modifying the multiplication in F9 data J9 = J9 F9 deriving (Eq,Ord) instance Show J9 where show (J9 (F9 0 0)) = "0" show (J9 (F9 0 1)) = "-j" show (J9 (F9 0 2)) = "j" show (J9 (F9 1 0)) = "1" show (J9 (F9 1 1)) = "-k" show (J9 (F9 1 2)) = "i" show (J9 (F9 2 0)) = "-1" show (J9 (F9 2 1)) = "-i" show (J9 (F9 2 2)) = "k" squaresF9 = [1,w^2,w^4,w^6] -- and 0, but not needed here instance Num J9 where J9 x + J9 y = J9 (x+y) 0 * _ = 0 _ * 0 = 0 J9 x * J9 y = if y `elem` squaresF9 then J9 (x*y) else J9 (conj x * y) negate (J9 x) = J9 (negate x) fromInteger n = J9 (fromInteger n) i = J9 w j = J9 (w^6) -- == i-1 k = J9 (w^7) -- == i+1 j9 = [J9 x | x <- f9] -- the aut of J9 that sends i to x autJ9 x = fromPairs [ (a+b*i, a+b*x) | a <- [0,1,-1], b <- [1,-1] ] autA = autJ9 (-i) -- sends i -> -i autB = autJ9 (-k) -- sends j -> -j autC = autJ9 (-j) -- sends k -> -k autsJ9 = [autA, autC] -- these two auts generate the group, which is isomorphic to S3 -- indeed, the auts permute the pairs {i,-i}, {j,-j}, {k,-k} conj' (J9 x) = J9 (conj x) -- Note that conj' x == x .^ autB isAut k sigma = and [sigma x + sigma y == sigma (x+y) | x <- k, y <- k] && and [sigma x * sigma y == sigma (x*y) | x <- k, y <- k] isReal x = x `elem` [0,1,-1] isComplex = not . isReal instance Fractional J9 where recip 0 = error "J9.recip: 0" recip x | isReal x = x | otherwise = -x instance FiniteField J9 where basisFq _ = [1,i,j,k] eltsFq _ = j9 -- PROJECTIVE PLANES ptsPG2 r = [ [0,0,1] ] ++ [ [0,1,x] | x <- r ] ++ [ [1,x,y] | x <- r, y <- r ] -- if r is sorted, then so is the result orthogonalLinesPG2 xs = L.sort [ [x | x <- xs, u <.> x == 0] | u <- xs ] rightLinesPG2 r = [ [0,0,1] : [ [0,1,x] | x <- r] ] ++ -- line at infinity [ [0,0,1] : [ [1,x,y] | y <- r] | x <- r ] ++ -- vertical lines [ [0,1,a] : [ [1,x,y] | x <- r, y <- [x*a+b] ] | a <- r, b <- r ] -- slope multiplies on the right -- if r is sorted, then so is the result, and each line in the result leftLinesPG2 r = [ [0,0,1] : [ [0,1,x] | x <- r] ] ++ -- line at infinity [ [0,0,1] : [ [1,x,y] | y <- r] | x <- r ] ++ -- vertical lines [ [0,1,a] : [ [1,x,y] | x <- r, y <- [a*x+b] ] | a <- r, b <- r ] -- slope multiplies on the left -- Projective plane PG2(F9) phi = design (xs,bs) where xs = ptsPG2 f9 bs = orthogonalLinesPG2 xs -- L.sort [ [x | x <- xs, u <.> x == 0] | u <- xs ] -- Then the collineations of phi consist of projective transformations, -- together with a conjugacy collineation induced by the Frobenius aut -- alternative construction of PG2(F9) - gives same result phi' = design (xs,bs) where xs = ptsPG2 f9 bs = rightLinesPG2 f9 collineationsPhi = l 3 f9 ++ [fieldAut] where D xs bs = phi fieldAut = fromPairs [ (x , map conj x) | x <- xs ] -- in general, this would be PSigmaL(n,Fq), whereas we want PGammaL(n,Fq). However, for F9 they coincide. -- order 84913920 liftToGraph (D xs bs) g = fromPairs $ [(Left x, Left (x .^ g)) | x <- xs] ++ [(Right b, Right (b -^ g)) | b <- bs] -- This construction appears to produce a projective plane -- (However, Room & Kirkpatrick point out that it's not really well-defined -- - if we had chosen different quasi-homogeneous coords, we would have got different results) -- However, it's not the same as either omega or omegaD below omega0 = design (xs,bs) where xs = ptsPG2 j9 bs = orthogonalLinesPG2 xs -- L.sort [ [x | x <- xs, u <.> x == 0] | u <- xs ] -- Room & Kirkpatrick, p103 omega = design (xs,bs) where xs = ptsPG2 j9 bs = rightLinesPG2 j9 -- another construction that produces same result (but slower) omega2 = design (xs,bs) where xs = ptsPG2 j9 bs = [ l | [p,q] <- combinationsOf 2 xs, l <- [line p q], [p,q] == take 2 l] line p q = toListSet $ filter ispnf [(a *> p) <+> (b *> q) | a <- j9, b <- j9] -- Room & Kirkpatrick, p107, p114 collineationsOmega = [r] ++ [s rho sigma | rho <- j9 \\ [0], sigma <- j9 \\ [0], rho == 1 || sigma == 1] ++ [t delta epsilon | delta <- j9, epsilon <- j9, delta * epsilon == 0] -- for generators sufficient to have only one non-zero ++ [u] ++ [a lambda | lambda <- autsJ9] where D xs bs = omega fromMatrix m = fromPairs [ (x, pnf (x <*>> m)) | x <- xs] r = fromMatrix [[1,0,0],[0,0,1],[0,1,0]] -- reflect in the line x = y in the affine subplane s rho sigma = fromPairs $ [([1,x,y], [1,x*rho,y*sigma]) | x <- j9, y <- j9] ++ [([0,1,mu],[0,1,(recip rho)*mu*sigma]) | mu <- j9] ++ [([0,0,1],[0,0,1])] -- leaves "Y" fixed -- fromMatrix [[1,0,0],[0,rho,0],[0,0,sigma]] -- scale x,y -> rho x, sigma y t delta epsilon = fromMatrix [[1,delta,epsilon],[0,1,0],[0,0,1]] -- translation x,y -> x+delta, y+epsilon u = fromPairs $ [([1,x,y], [1,x+y,x-y]) | x <- j9, y <- j9] ++ [([0,1,mu],[0,1,-mu]) | mu <- filter isComplex j9] ++ [([0,1,0],[0,1,1]), ([0,1,1],[0,1,0]), ([0,1,-1],[0,0,1]), ([0,0,1],[0,1,-1])] -- fromMatrix [[1,0,0],[0,1,-1],[0,1,1]] a lambda = fromPairs [ (x, map (.^ lambda) x) | x <- xs] -- order 311040 -- (which means this is also the plane constructed in Weibel?) -- dual plane of omega omegaD = design (xs,bs) where xs = ptsPG2 j9 bs = leftLinesPG2 j9 omegaD1 = D.to1n $ dual omega -- need proof omega /~= omegaD omegaD2 = design (xs,bs) where xs = ptsPG2 j9 bs = [ l | [p,q] <- combinationsOf 2 xs, l <- [line p q], [p,q] == take 2 l] line p q = toListSet $ filter ispnf [(p <* a) <+> (q <* b) | a <- j9, b <- j9] us <* x = map (*x) us -- Room and Kirkpatrick p130 psi = design (xs,bs) where xs = ptsPG2 j9 isReal x = all (`elem` [0,1,-1]) x xrs = ptsPG2 [0,1,-1] -- the thirteen real points, a copy of PG2(F3) within psi bs = toListSet [line p q | p <- xrs, q <- xs, q /= p] line p q = L.sort $ p : [pnf ( (p <* a) <+> q) | a <- j9] -- Room & Kirkpatrick p137 psi2 = design (xs,bs) where xs = ptsPG2 j9 bs = L.sort $ [ [0,0,1] : [ [0,1,x] | x <- j9] ] ++ -- line at infinity, z=0 [ [0,0,1] : [ [1,kappa,y] | y <- j9] | kappa <- j9 ] ++ -- vertical lines x = kappa [ [0,1,m] : [ [1,x,m*x+kappa] | x <- j9 ] | m <- [0,1,-1], kappa <- j9 ] ++ -- lines with real slope [ [0,1,kappa] : [ [1,x,kappa*(x-r)+s] | x <- j9 ] | r <- [0,1,-1], s <- [0,1,-1], kappa <- j9 \\ [0,1,-1] ] -- lines with complex slope -- Room & Kirkpatrick p134-6 collineationsPsi = realProjectivities -- real transvections, generating real projectivities ++ [a lambda | lambda <- autsJ9] where D xs bs = psi n = 3 realTransvections = [elemTransvection n (r,c) l | r <- [1..n], c <- [1..n], r /= c, l <- [1]] realProjectivities = [fromPairs $ [(x, pnf (x <*>> m)) | x <- xs] | m <- realTransvections] a lambda = fromPairs [ (x, map (.^ lambda) x) | x <- xs] -- order 33696 -- The order of a projective plane order (D xs bs) = length (head bs) - 1 isProjectivePlane pi = designParams pi == Just (2,(q^2+q+1,q,1)) where q = order pi collinear (D xs bs) ys = (not . null) [b | b <- bs, all (`elem` b) ys] -- assume p1..4 are distinct isQuadrangle plane ps@[p1,p2,p3,p4] = all (not . collinear plane) (combinationsOf 3 ps) concurrent (D xs bs) ls = (not . null) [x | x <- xs, all (x `elem`) ls] isQuadrilateral plane ls@[l1,l2,l3,l4] = all (not . concurrent plane) (combinationsOf 3 ls) isOval pi ps = length ps == order pi+1 && all (not . collinear pi) (combinationsOf 3 ps) findOvals1 pi = findOvals' 0 ([], points pi) where n = order pi findOvals' i (ls,rs) | i == n+1 = [reverse ls] | otherwise = concatMap (findOvals' (i+1)) [ (r:ls, rs') | r:rs' <- L.tails rs, all (not . collinear pi) (map (r:) (combinationsOf 2 ls)) ] -- if we have a function to quickly generate the line through two points, -- then we just need to see whether the third point is on it, which is much faster than testing collinearity findQuadrangles pi = findQuadrangles' 0 ([], points pi) where findQuadrangles' i (ls,rs) | i == 4 = [reverse ls] | otherwise = concatMap (findQuadrangles' (i+1)) [ (r:ls, rs') | r:rs' <- L.tails rs, all (not . collinear pi) (map (r:) (combinationsOf 2 ls)) ] findOvals pi@(D xs bs) = findOvals' 0 ([],xs) bs where n = order pi findOvals' i (ls,rs) bs | i == n+1 = [reverse ls] | otherwise = concat [let rls = reverse (r:ls) (notchords, chords) = L.partition (\b -> length (rls `LS.intersect` b) < 2) bs rs'' = foldl (\\) rs' chords -- if any line is already a chord, remove remaining points on it from further consideration in findOvals' (i+1) (r:ls, rs'') notchords | r:rs' <- L.tails rs] -- Todo: -- Code that shows that phi is Desarguesian, and omega, omegaD and psi are not {- -- !! NOT WORKING -- finds apparent counterexamples in phi too findNonDesarguesian pi@(D xs bs) = [ [p,x,y,z,x',y',z',k,l,m] | p <- xs, x <- xs \\ [p], y <- xs \\ [p,x], z <- xs \\ [p,x,y], (not . collinear pi) [x,y,z], x' <- line p x \\ L.sort [p,x], y' <- line p y \\ L.sort [p,y], z' <- line p z \\ L.sort [p,z], (not . collinear pi) [x',y',z'], k <- line x y `intersect` line x' y', -- will only have one element l <- line x z `intersect` line x' z', m <- line y z `intersect` line y' z', (not . collinear pi) [k,l,m] ] where line p q = head [b | b <- bs, p `elem` b, q `elem` b] -}HaskellForMaths-0.4.8/Math/Projects/RootSystem.hs0000644000000000000000000002274712514742102020120 0ustar0000000000000000-- Copyright (c) David Amos, 2008-2015. All rights reserved. module Math.Projects.RootSystem where import Prelude hiding ( (*>) ) import Data.Ratio import qualified Data.List as L import qualified Data.Set as S import Math.Algebra.LinearAlgebra import Math.Algebra.Group.PermutationGroup hiding (elts, order, closure) import Math.Algebra.Group.SchreierSims as SS import Math.Algebra.Group.StringRewriting as SG import Math.Algebra.Field.Base -- for Q data Type = A | B | C | D | E | F | G -- Humphreys, Reflection Groups and Coxeter Groups -- SIMPLE SYSTEMS -- sometimes called fundamental systems -- The ith basis vector in K^n basisElt :: Int -> Int -> [Q] -- this type signature determines all the rest basisElt n i = replicate (i-1) 0 ++ 1 : replicate (n-i) 0 -- We need to work over the rationals to ensure that arithmetic is exact -- So long as our simple systems are rational, then reflection matrices are rational -- A simple system is like a basis for the root system (see Humphreys p8 for full definition) -- simpleSystem :: Type -> Int -> [[Q]] simpleSystem A n | n >= 1 = [e i <-> e (i+1) | i <- [1..n]] where e = basisElt (n+1) simpleSystem B n | n >= 2 = [e i <-> e (i+1) | i <- [1..n-1]] ++ [e n] where e = basisElt n simpleSystem C n | n >= 2 = [e i <-> e (i+1) | i <- [1..n-1]] ++ [2 *> e n] where e = basisElt n simpleSystem D n | n >= 4 = [e i <-> e (i+1) | i <- [1..n-1]] ++ [e (n-1) <+> e n] where e = basisElt n simpleSystem E n | n `elem` [6,7,8] = take n simpleroots where e = basisElt 8 simpleroots = ((1/2) *> (e 1 <-> e 2 <-> e 3 <-> e 4 <-> e 5 <-> e 6 <-> e 7 <+> e 8)) : (e 1 <+> e 2) : [e (i-1) <-> e (i-2) | i <- [3..8]] simpleSystem F 4 = [e 2 <-> e 3, e 3 <-> e 4, e 4, (1/2) *> (e 1 <-> e 2 <-> e 3 <-> e 4)] where e = basisElt 4 simpleSystem G 2 = [e 1 <-> e 2, ((-2) *> e 1) <+> e 2 <+> e 3] where e = basisElt 3 -- ROOT SYSTEMS -- Calculating the full root system from the fundamental roots -- Humphreys p3 -- Weyl group element corresponding to a root -- w r is the reflection in the hyperplane orthogonal to r w r s = s <-> (2 * (s <.> r) / (r <.> r)) *> r -- Given a simple system, return the full root system -- The closure of a set of roots under reflection closure rs = S.toList $ closure' S.empty (S.fromList rs) where closure' interior boundary | S.null boundary = interior | otherwise = let interior' = S.union interior boundary boundary' = S.fromList [w r s | r <- rs, s <- S.toList boundary] S.\\ interior' in closure' interior' boundary' -- WEYL GROUP -- The finite reflection group generated by the root system -- Generators of the Weyl group as permutation group on the roots weylPerms t n = let rs = simpleSystem t n xs = closure rs toPerm r = fromPairs [(x, w r x) | x <- xs] in map toPerm rs -- Generators of the Weyl group as a matrix group weylMatrices t n = map wMx (simpleSystem t n) -- The Weyl group element corresponding to a root, represented as a matrix wMx r = map (w r) [e i | i <- [1..d]] -- matrix for reflection in hyperplane orthogonal to r where d = length r -- dimension of the space e = basisElt d -- the images of the basis elts form the columns of the matrix -- however, reflection matrices are symmetric, so they also form the rows -- CARTAN MATRIX, DYNKIN DIAGRAM, COXETER SYSTEM cartanMatrix t n = [[2 * (ai <.> aj) / (ai <.> ai) | aj <- roots] | ai <- roots] where roots = simpleSystem t n -- Note: The Cartan matrices for A, D, E systems are symmetric. -- Those of B, C, F, G are not -- Carter, Simple Groups of Lie Type, p44-5 gives the expected answers -- They agree with our answers except for G2, which is the transpose -- (So probably Carter defines the roots of G2 the other way round to Humphreys) -- set the diagonal entries of (square) matrix mx to constant c setDiag c mx@((x:xs):rs) = (c:xs) : zipWith (:) (map head rs) (setDiag c $ map tail rs) setDiag _ [[]] = [[]] -- Carter, Segal, Macdonald p17-18 -- given a Cartan matrix, derive the corresponding matrix describing the Dynkin diagram -- nij = Aij * Aji, nii = 0 dynkinFromCartan aij = setDiag 0 $ (zipWith . zipWith) (*) aij (L.transpose aij) dynkinDiagram t n = dynkinFromCartan $ cartanMatrix t n -- given the Dynkin diagram nij, derive the coefficients mij of the Coxeter group (so mii == 1) -- using nij = 4 cos^2 theta_ij -- nij == 0 <=> theta = pi/2 -- nij == 1 <=> theta = pi/3 -- nij == 2 <=> theta = pi/4 -- nij == 3 <=> theta = pi/6 coxeterFromDynkin nij = setDiag 1 $ (map . map) f nij where f 0 = 2; f 1 = 3; f 2 = 4; f 3 = 6 -- The mij coefficients of the Coxeter group , as a matrix coxeterMatrix t n = coxeterFromDynkin $ dynkinDiagram t n -- Given the matrix of coefficients mij, return the Coxeter group -- We assume but don't check that mii == 1 and mij == mji fromCoxeterMatrix mx = (gs,rs) where n = length mx gs = map s_ [1..n] rs = rules mx 1 rules [] _ = [] rules ((1:xs):rs) i = ([s_ i, s_ i],[]) : [powerRelation i j m | (j,m) <- zip [i+1..] xs] ++ rules (map tail rs) (i+1) powerRelation i j m = (concat $ replicate m [s_ i, s_ j],[]) -- Another presentation for the Coxeter group, using braid relations fromCoxeterMatrix2 mx = (gs,rs) where n = length mx gs = map s_ [1..n] rs = rules mx 1 rules [] _ = [] rules ((1:xs):rs) i = ([s_ i, s_ i],[]) : [braidRelation i j m | (j,m) <- zip [i+1..] xs] ++ rules (map tail rs) (i+1) braidRelation i j m = (take m $ cycle [s_ j, s_ i], take m $ cycle [s_ i, s_ j]) coxeterPresentation t n = fromCoxeterMatrix $ coxeterMatrix t n eltsCoxeter t n = SG.elts $ fromCoxeterMatrix2 $ coxeterMatrix t n -- it's just slightly faster to use the braid presentation poincarePoly t n = map length $ L.group $ map length $ eltsCoxeter t n -- LIE ALGEBRAS elemMx n i j = replicate (i-1) z ++ e j : replicate (n-i) z where z = replicate n 0 e = basisElt n lieMult x y = x*y - y*x -- for gluing matrices together (+|+) = zipWith (++) -- glue two matrices together side by side (+-+) = (++) -- glue two matrices together above and below form D n = (zMx n +|+ idMx n) +-+ (idMx n +|+ zMx n) form C n = (2 : replicate (2*n) 0) : (map (0:) (form D n)) form B n = let id' = (-1) *>> idMx n in (zMx n +|+ idMx n) +-+ (id' +|+ zMx n) -- TESTING -- The expected values of the root system, number of roots, order of Weyl group -- for comparison against the calculated values -- !! Not yet got root systems for E6,7,8, F4 -- Humphreys p41ff -- The full root system -- L.sort (rootSystem t n) == closure (simpleSystem t n) -- rootSystem :: Type -> Int -> [[QQ]] rootSystem A n | n >= 1 = [e i <-> e j | i <- [1..n+1], j <- [1..n+1], i /= j] where e = basisElt (n+1) rootSystem B n | n >= 2 = shortRoots ++ longRoots where e = basisElt n shortRoots = [e i | i <- [1..n]] ++ [[] <-> e i | i <- [1..n]] longRoots = [e i <+> e j | i <- [1..n], j <- [i+1..n]] ++ [e i <-> e j | i <- [1..n], j <- [i+1..n]] ++ [[] <-> e i <+> e j | i <- [1..n], j <- [i+1..n]] ++ [[] <-> e i <-> e j | i <- [1..n], j <- [i+1..n]] rootSystem C n | n >= 2 = longRoots ++ shortRoots where e = basisElt n longRoots = [2 *> e i | i <- [1..n]] ++ [[] <-> (2 *> e i) | i <- [1..n]] shortRoots = [e i <+> e j | i <- [1..n], j <- [i+1..n]] ++ [e i <-> e j | i <- [1..n], j <- [i+1..n]] ++ [[] <-> e i <+> e j | i <- [1..n], j <- [i+1..n]] ++ [[] <-> e i <-> e j | i <- [1..n], j <- [i+1..n]] rootSystem D n | n >= 4 = [e i <+> e j | i <- [1..n], j <- [i+1..n]] ++ [e i <-> e j | i <- [1..n], j <- [i+1..n]] ++ [[] <-> e i <+> e j | i <- [1..n], j <- [i+1..n]] ++ [[] <-> e i <-> e j | i <- [1..n], j <- [i+1..n]] where e = basisElt n rootSystem G 2 = shortRoots ++ longRoots where e = basisElt 3 shortRoots = [e i <-> e j | i <- [1..3], j <- [1..3], i /= j] longRoots = concatMap (\r-> [r,[] <-> r]) [2 *> e i <-> e j <-> e k | i <- [1..3], [j,k] <- [[1..3] L.\\ [i]] ] -- numRoots t n == length (closure $ simpleSystem t n) numRoots A n = n*(n+1) numRoots B n = 2*n*n numRoots C n = 2*n*n numRoots D n = 2*n*(n-1) numRoots E 6 = 72 numRoots E 7 = 126 numRoots E 8 = 240 numRoots F 4 = 48 numRoots G 2 = 12 -- The order of the Weyl group -- orderWeyl t n == S.order (weylPerms t n) orderWeyl A n = factorial (n+1) orderWeyl B n = 2^n * factorial n orderWeyl C n = 2^n * factorial n orderWeyl D n = 2^(n-1) * factorial n orderWeyl E 6 = 2^7 * 3^4 * 5 orderWeyl E 7 = 2^10 * 3^4 * 5 * 7 orderWeyl E 8 = 2^14 * 3^5 * 5^2 * 7 orderWeyl F 4 = 2^7 * 3^2 orderWeyl G 2 = 12 factorial n = product [1..toInteger n] {- -- now moved to TRootSystem test1 = all (\(t,n) -> orderWeyl t n == L.genericLength (eltsCoxeter t n)) [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(F,4),(G,2)] test2 = all (\(t,n) -> orderWeyl t n == SS.order (weylPerms t n)) [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(E,6),(F,4),(G,2)] -}HaskellForMaths-0.4.8/Math/Projects/Rubik.hs0000644000000000000000000001165212514742102017035 0ustar0000000000000000-- Copyright (c) David Amos, 2009. All rights reserved. module Math.Projects.Rubik where import Math.Algebra.Group.PermutationGroup hiding (_D) import Math.Algebra.Group.SchreierSims as SS import Math.Algebra.Group.RandomSchreierSims as RSS import Math.Algebra.Group.Subquotients -- Rubik's cube -- 11 12 13 -- 14 U 16 -- 17 18 19 -- 21 22 23 1 2 3 41 42 43 51 52 53 -- 24 L 26 4 F 6 44 R 46 54 B 56 -- 27 28 29 7 8 9 47 48 49 57 58 59 -- 31 32 33 -- 34 D 36 -- 37 38 39 f = p [[ 1, 3, 9, 7],[ 2, 6, 8, 4],[17,41,33,29],[18,44,32,26],[19,47,31,23]] b = p [[51,53,59,57],[52,56,58,54],[11,27,39,43],[12,24,38,46],[13,21,37,49]] l = p [[21,23,29,27],[22,26,28,24],[ 1,31,59,11],[ 4,34,56,14],[ 7,37,53,17]] r = p [[41,43,49,47],[42,46,48,44],[ 3,13,57,33],[ 6,16,54,36],[ 9,19,51,39]] u = p [[11,13,19,17],[12,16,18,14],[ 1,21,51,41],[ 2,22,52,42],[ 3,23,53,43]] d = p [[31,33,39,37],[32,36,38,34],[ 7,47,57,27],[ 8,48,58,28],[ 9,49,59,29]] rubikCube = [f,b,l,r,u,d] -- In Singmaster notation these would be capital letters. [cornerFaces,edgeFaces] = orbits rubikCube (kerCornerFaces,imCornerFaces) = transitiveConstituentHomomorphism rubikCube cornerFaces -- kernel is the elts which fix all corner faces -- image is the action restricted to the corner faces (kerEdgeFaces,imEdgeFaces) = transitiveConstituentHomomorphism rubikCube edgeFaces -- kernel is the elts which fix all edge faces -- image is the action restricted to the edge faces [cornerBlocks] = blockSystems imCornerFaces [edgeBlocks] = blockSystems imEdgeFaces (kerCornerBlocks,imCornerBlocks) = blockHomomorphism imCornerFaces cornerBlocks -- kernel is elts which fix all the corners as blocks, with order 3^7 -- (Whenever you twist one corner you must untwist another -- - so the action on 7 corners determines the 8th) -- image is the action on the corners as blocks, which is S8 of order 20160 (kerEdgeBlocks,imEdgeBlocks) = blockHomomorphism imEdgeFaces edgeBlocks -- kernel is elts which fix all the edges as blocks, with order 2^11 -- (Whenever you flip one edge, you must flip another edge -- - so the action on 11 edges determines the 12th) -- image is the action on the edges as blocks, which is S12 of order 479001600 -- Note that orderSGS imCornerFaces * orderSGS imEdgeFaces == 2 * orderSGS (sgs rubikCube) -- This is because you can't operate on corners and edges totally independently -- If you swap two corners, you must also swap two edges -- See also -- http://www.gap-system.org/Doc/Examples/rubik.html -- (Note that the kernel of the corner constituent homomorphism /= image of edge constituent homomorphism -- For example, [[36,38],[48,58]] is in the latter, but not the former because it's not in the Rubik group -- ie there is an elt in the Rubik group which does just that to the edges, but may do some things to the corners) -- Rubik's revenge (4*4*4 cube) -- 1 2 3 4 -- 5 6 7 8 -- 9 10 11 12 -- 13 14 15 16 -- 101 102 103 104 201 202 203 204 301 302 303 304 401 402 403 404 -- 105 106 107 108 205 206 207 208 305 306 307 308 405 406 407 408 -- 109 110 111 112 209 210 211 212 309 310 311 312 409 410 411 412 -- 113 114 115 116 213 214 215 216 313 314 315 316 413 414 415 416 -- 501 502 503 504 -- 505 506 507 508 -- 509 510 511 512 -- 513 514 515 516 _U = p [[1,13,16,4],[2,9,15,8],[3,5,14,12],[6,10,11,7], [101,201,301,401],[102,202,302,402],[103,203,303,403],[104,204,304,404]] _u = p [[105,205,305,405],[106,206,306,406],[107,207,307,407],[108,208,308,408]] _d = p [[109,209,309,409],[110,210,310,410],[111,211,311,411],[112,212,312,412]] _D = p [[113,213,313,413],[114,214,314,414],[115,215,315,415],[116,216,316,416], [501,504,516,513],[502,508,515,509],[503,512,514,505],[506,507,511,510]] bf = p [[1,304,516,113],[2,308,515,109],[3,312,514,105],[4,316,513,101], [5,303,512,114],[6,307,511,110],[7,311,510,106],[8,315,509,102], [9,302,508,115],[10,306,507,111],[11,310,506,107],[12,314,505,103], [13,301,504,116],[14,305,503,112],[15,309,502,108],[16,313,501,104], [201,204,216,213],[202,208,215,209],[203,212,214,205],[206,207,211,210], [401,413,416,404],[402,409,415,408],[403,405,414,412],[406,410,411,407]] _R = _U ~^ bf _r = _u ~^ bf _l = _d ~^ bf _L = _D ~^ bf ud = _U * _u * _d * _D _B = _R ~^ ud _b = _r ~^ ud _f = _l ~^ ud _F = _L ~^ ud -- Note that orderSGS $ sgs [_U,_u,_d,_D,bf] comes out much too large, -- because it includes rotations of the whole cube (24) -- and exchanges of indistinguishable centre faces (24 for each of 6 colours) -- So we have to divide by 24^7 / 2. -- (The /2 is because we can only have even permutations when exchanging indistinguishable centres)HaskellForMaths-0.4.8/Math/Projects/ChevalleyGroup/0000755000000000000000000000000012514742102020351 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Projects/ChevalleyGroup/Classical.hs0000644000000000000000000001365712514742102022617 0ustar0000000000000000-- Copyright (c) 2008-2015, David Amos. All rights reserved. module Math.Projects.ChevalleyGroup.Classical where import Prelude hiding ( (*>) ) import Math.Algebra.Field.Base import Math.Algebra.Field.Extension hiding ( (<+>), (<*>) ) import Math.Algebra.LinearAlgebra import Math.Algebra.Group.PermutationGroup import Math.Algebra.Group.SchreierSims as SS import Math.Combinatorics.FiniteGeometry numPtsAG n q = q^n numPtsPG n q = (q^(n+1)-1) `div` (q-1) -- LINEAR GROUPS -- |The special linear group SL(n,Fq), generated by elementary transvections, returned as matrices sl :: FiniteField k => Int -> [k] -> [[[k]]] sl n fq = [elemTransvection n (r,c) l | r <- [1..n], c <- [1..n], r /= c, l <- fq'] where fq' = basisFq undefined -- tail fq -- Carter p68 - x_r(t1) x_r(t2) == x_r(t1+t2) - this is true in general, not just in this case elemTransvection n (r,c) l = fMatrix n (\i j -> if i == j then 1 else if (i,j) == (r,c) then l else 0) -- |The projective special linear group PSL(n,Fq) == A(n,Fq) == SL(n,Fq)/Z, -- returned as permutations of the points of PG(n-1,Fq). -- This is a finite simple group provided n>2 or q>3. l :: (FiniteField k, Ord k) => Int -> [k] -> [Permutation [k]] l n fq = [fromPairs $ [(p, pnf (p <*>> m)) | p <- ps] | m <- sl n fq] where ps = ptsPG (n-1) fq orderL n q = ( q^(n*(n-1) `div` 2) * product [ q^i-1 | i <- [n,n-1..2] ] ) `div` gcd (q-1) n -- SYMPLECTIC GROUPS -- Carter p186 and 181-3 -- |The symplectic group Sp(2n,Fq), returned as matrices sp2 :: FiniteField k => Int -> [k] -> [[[k]]] sp2 n fq = [_I <<+>> t *>> (e i j <<->> e (-j) (-i)) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<->> t *>> (e (-i) (-j) <<->> e j i) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<+>> t *>> (e i (-j) <<+>> e j (-i)) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<+>> t *>> (e (-i) j <<+>> e (-j) i) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ -- Carter expresses this slightly differently [_I <<+>> t *>> e i (-i) | i <- [1..n], t <- fq' ] ++ [_I <<+>> t *>> e (-i) i | i <- [1..n], t <- fq' ] where fq' = basisFq undefined -- tail fq -- multiplicative group _I = idMx (2*n) e i j = e' (if i > 0 then i else n-i) (if j > 0 then j else n-j) e' i j = fMatrix (2*n) (\k l -> if (k,l) == (i,j) then 1 else 0) -- |The projective symplectic group PSp(2n,Fq) == Cn(Fq) == Sp(2n,Fq)/Z, -- returned as permutations of the points of PG(2n-1,Fq). -- This is a finite simple group for n>1, except for PSp(4,F2). s2 :: (FiniteField k, Ord k) => Int -> [k] -> [Permutation [k]] s2 n fq = [fromPairs $ [(p, pnf (p <*>> m)) | p <- ps] | m <- sp2 n fq] where ps = ptsPG (2*n-1) fq s n fq | even n = s2 (n `div` 2) fq orderS2 n q = (q^n^2 * product [ q^i-1 | i <- [2*n,2*n-2..2] ]) `div` gcd (q-1) 2 orderS n q | even n = orderS2 (n `div` 2) q -- ORTHOGONAL GROUPS -- Carter p185 and 178-9 -- Omega2n(q) - commutator subgroup of O2n(q) omegaeven n fq = [_I <<+>> t *>> (e i j <<->> e (-j) (-i)) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<->> t *>> (e (-i) (-j) <<->> e j i) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<+>> t *>> (e i (-j) <<->> e j (-i)) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<->> t *>> (e (-i) j <<->> e (-j) i) | i <- [1..n], j <- [i+1..n], t <- fq' ] where fq' = basisFq undefined -- tail fq -- multiplicative group _I = idMx (2*n) e i j = e' (if i > 0 then i else n-i) (if j > 0 then j else n-j) e' i j = fMatrix (2*n) (\k l -> if (k,l) == (i,j) then 1 else 0) -- O+2n(Fq) Artin/Conway notation (Atlas, pxii) -- Dn(Fq) Chevalley group d n fq = [fromPairs $ [(p, pnf (p <*>> m)) | p <- ps] | m <- omegaeven n fq] where ps = ptsPG (2*n-1) fq -- Carter p186-8 -- Omega2n+1(q) omegaodd n fq | char fq /= 2 = [_I <<+>> t *>> (e i j <<->> e (-j) (-i)) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<->> t *>> (e (-i) (-j) <<->> e j i) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<+>> t *>> (e i (-j) <<->> e j (-i)) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<->> t *>> (e (-i) j <<->> e (-j) i) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<+>> t *>> (2 *>> e i 0 <<->> e 0 (-i)) <<->> (t^2) *>> e i (-i) | i <- [1..n], t <- fq' ] ++ [_I <<->> t *>> (2 *>> e (-i) 0 <<->> e 0 i) <<->> (t^2) *>> e (-i) i | i <- [1..n], t <- fq' ] | char fq == 2 = [_I <<+>> t *>> (e i j <<->> e (-j) (-i)) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<->> t *>> (e (-i) (-j) <<->> e j i) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<+>> t *>> (e i (-j) <<->> e j (-i)) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ -- !! Carter has a + in place of a - here [_I <<->> t *>> (e (-i) j <<->> e (-j) i) | i <- [1..n], j <- [i+1..n], t <- fq' ] ++ [_I <<+>> (t^2) *>> e i (-i) | i <- [1..n], t <- fq' ] ++ [_I <<+>> (t^2) *>> e (-i) i | i <- [1..n], t <- fq' ] where fq' = basisFq undefined -- tail fq -- multiplicative group _I = idMx (2*n+1) e i j = e' (if i >= 0 then i else n-i) (if j >= 0 then j else n-j) e' i j = fMatrix' (2*n+1) (\k l -> if (k,l) == (i,j) then 1 else 0) -- O2n+1(Fq) Artin/Conway notation -- Bn(Fq) Chevalley group b n fq = [fromPairs $ [(p, pnf (p <*>> m)) | p <- ps] | m <- omegaodd n fq] where ps = ptsPG (2*n) fq o n fq | even n = d (n `div` 2) fq | odd n = b (n `div` 2) fq -- The orthogonal groups aren't transitive on PG(n-1,Fq), -- so the above permutation representation actually splits into smaller representations on the orbits -- eg map length $ orbits $ o 7 f3 -> [364,378,351] -- which is the first three permutation representations listed at http://brauer.maths.qmul.ac.uk/Atlas/v3/clas/O73/ -- UNITARY GROUPS -- The unitary group U(n+1,q) is the twisted Chevalley group 2An(q) HaskellForMaths-0.4.8/Math/Projects/ChevalleyGroup/Exceptional.hs0000644000000000000000000001460112514742102023162 0ustar0000000000000000-- Copyright (c) 2008-2015, David Amos. All rights reserved. module Math.Projects.ChevalleyGroup.Exceptional where import Prelude hiding ( (*>) ) import Data.List as L -- import Math.Algebra.Field.Base -- import Math.Algebra.Field.Extension hiding ( (<+>), (<*>) ) import Math.Core.Field import Math.Algebra.LinearAlgebra import Math.Algebra.Group.PermutationGroup hiding (fromList) -- import Math.Algebra.Group.SchreierSims as SS import Math.Algebra.Group.RandomSchreierSims as RSS import Math.Combinatorics.FiniteGeometry (ptsAG) -- Follows Conway's notation -- The octonion xinf + x0 i0 + x1 i1 + ... + x6 i6 -- is represented as O [(-1,xinf),(0,x0),(1,x1),...,(6,x6)] -- where a list element may be omitted if the coefficient is zero newtype Octonion k = O [(Int,k)] deriving (Eq, Ord) i0, i1, i2, i3, i4, i5, i6 :: Octonion Q i0 = O [(0,1)] i1 = O [(1,1)] i2 = O [(2,1)] i3 = O [(3,1)] i4 = O [(4,1)] i5 = O [(5,1)] i6 = O [(6,1)] fromList as = O $ filter ((/=0) . snd) $ zip [-1..6] as toList (O xs) = toList' xs [-1..6] where toList' ((i,a):xs) (j:js) = if i == j then a : toList' xs js else 0 : toList' ((i,a):xs) js toList' [] (j:js) = 0 : toList' [] js toList' _ [] = [] expose (O ts) = ts instance Show k => Show (Octonion k) where show (O []) = "0" show (O ts) = let c:cs = concatMap showTerm ts in if c == '+' then cs else c:cs where showTerm (i,a) = showCoeff a ++ showImag a i showCoeff a = case show a of "1" -> "+" "-1" -> "-" '-':cs -> '-':cs cs -> '+':cs showImag a i | i == -1 = case show a of "1" -> "1" "-1" -> "1" otherwise -> "" | otherwise = "i" ++ show i instance (Ord k, Num k) => Num (Octonion k) where -- Ord k not strictly required, but keeps nf simpler O ts + O us = O $ nf $ ts ++ us negate (O ts) = O $ map (\(i,a) -> (i,-a)) ts O ts * O us = O $ nf [m t u | t <- ts, u <- us] fromInteger 0 = O [] fromInteger n = O [(-1, fromInteger n)] nf ts = nf' $ L.sort ts where nf' ((i1,a1):(i2,a2):ts) = if i1 == i2 then if a1+a2 == 0 then nf' ts else nf' ((i1,a1+a2):ts) else (i1,a1) : nf' ((i2,a2):ts) nf' ts = ts m (-1,a) (i,b) = (i,a*b) m (i,a) (-1,b) = (i,a*b) m (i,a) (j,b) = case (j-i) `mod` 7 of 0 -> (-1,-a*b) 1 -> ( (i+3) `mod` 7, a*b) -- i_n+1 * i_n+2 == i_n+4 2 -> ( (i+6) `mod` 7, a*b) -- i_n+2 * i_n+4 == i_n+1 3 -> ( (i+1) `mod` 7, -a*b) -- i_n+1 * i_n+4 == -i_n+2 4 -> ( (i+5) `mod` 7, a*b) -- i_n+4 * i_n+1 == i_n+2 5 -> ( (i+4) `mod` 7, -a*b) -- i_n+4 * i_n+2 == -i_n+1 6 -> ( (i+2) `mod` 7, -a*b) -- i_n+2 * i_n+1 == -i_n+4 conj (O ts) = O $ map (\(i,a) -> if i == -1 then (i,a) else (i,-a)) ts sqnorm (O ts) = sum [a^2 | (i,a) <- ts] instance (Ord k, Num k, Fractional k) => Fractional (Octonion k) where recip x = let O x' = conj x xx' = sqnorm x in O $ map (\(i,a) -> (i,a/xx')) x' isOrthogonal (O ts) (O us) = dot ts us == 0 where dot ((i,a):ts) ((j,b):us) = case compare i j of EQ -> a*b + dot ts us LT -> dot ts ((j,b):us) GT -> dot ((i,a):ts) us dot _ _ = 0 antiCommutes x y = x*y + y*x == 0 -- anti-commuting and being orthogonal appear to be equivalent for unit imaginary octonions, -- provided we're not in characteristic 2 -- OCTONIONS OVER FINITE FIELDS {- octonions fq = map O $ octonions' [-1..6] where octonions' (i:is) = [if a == 0 then ts else (i,a):ts | a <- fq, ts <- octonions' is] octonions' [] = [[]] -} octonions fq = map fromList $ ptsAG 8 fq isUnit x = sqnorm x == 1 unitImagOctonions fq = filter isUnit $ map (fromList . (0:)) $ ptsAG 7 fq -- given the images of i0, i1, i2, return the automorphism -- the inputs must be pure imaginary unit octonions -- and we must have isOrthogonal i0 i1, isOrthogonal i0 i2, isOrthogonal i1 i2, and isOrthogonal (i0*i1) i2 autFrom i0' i1' i2' = let 0:r0 = toList i0' 0:r1 = toList i1' 0:r2 = toList i2' 0:r3 = toList $ i0'*i1' 0:r4 = toList $ i1'*i2' 0:r5 = toList $ i0'*(i1'*i2') 0:r6 = toList $ i0'*i2' in [r0,r1,r2,r3,r4,r5,r6] x %^ g = let a:as = toList x in fromList $ a : (as <*>> g) -- G2(3) alpha3 = autFrom (O [(1,1::F3)]) (O [(2,1)]) (O [(3,1)]) beta3 = autFrom (O [(0,1::F3)]) (O [(2,1)]) (O [(4,1)]) gamma3s = [x | x <- unitImagOctonions f3, isOrthogonal (O [(0,1)]) x, isOrthogonal (O [(1,1)]) x, isOrthogonal (O [(3,1)]) x] gamma3 = autFrom (O [(0,1::F3)]) (O [(1,1)]) (O [(2,1),(4,1),(5,1),(6,1)]) alpha3' = fromPairs [(x, x %^ alpha3) | x <- unitImagOctonions f3] beta3' = fromPairs [(x, x %^ beta3) | x <- unitImagOctonions f3] gamma3' = fromPairs [(x, x %^ gamma3) | x <- unitImagOctonions f3] -- |Generators for G2(3), a finite simple group of order 4245696, -- as a permutation group on the 702 unit imaginary octonions over F3 g2_3 :: [Permutation (Octonion F3)] g2_3 = [alpha3', beta3', gamma3'] -- These three together generate a group of order 4245696, which is therefore the whole of G2(3) -- Unit imaginary octonions form one orbit under the action of G2 -- [alpha', beta', gamma'] generate G2(3) as a permutation group on 702 points (the number of unit imaginary octonions over F3) -- Interestingly, http://brauer.maths.qmul.ac.uk/Atlas/v3/exc/G23/ doesn't seem to have this permutation representation -- G2(4) alpha4 = autFrom (O [(1,1::F4)]) (O [(2,1)]) (O [(3,1)]) beta4 = autFrom (O [(0,1::F4)]) (O [(2,1)]) (O [(4,1)]) gamma4s = [x | x <- unitImagOctonions f4, isOrthogonal (O [(0,1)]) x, isOrthogonal (O [(1,1)]) x, isOrthogonal (O [(3,1)]) x] -- gamma4 = autFrom (O [(0,1::F4)]) (O [(1,1)]) (O [(5,embed x),(6,embed $ 1+x)]) gamma4 = autFrom (O [(0,1::F4)]) (O [(1,1)]) (O [(5,a4),(6,1+a4)]) alpha4' = fromPairs [(x, x %^ alpha4) | x <- unitImagOctonions f4] beta4' = fromPairs [(x, x %^ beta4) | x <- unitImagOctonions f4] gamma4' = fromPairs [(x, x %^ gamma4) | x <- unitImagOctonions f4] -- Haven't checked whether these generate whole group - can be expected to run a long timeHaskellForMaths-0.4.8/Math/Projects/KnotTheory/0000755000000000000000000000000012514742102017526 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Projects/KnotTheory/Braid.hs0000644000000000000000000000307012514742102021103 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} module Math.Projects.KnotTheory.Braid where import Data.List ( (\\) ) import Math.Algebra.Field.Base import Math.Algebra.NonCommutative.NCPoly import Math.Projects.KnotTheory.LaurentMPoly type LPQ = LaurentMPoly Q instance Invertible LPQ where inv = recip -- BRAID ALGEBRA data BraidGens = S Int deriving (Eq,Ord) -- Inverse of S n is S (-n) instance Show BraidGens where show (S i) | i > 0 = 's': show i | i < 0 = 's': show (-i) ++ "'" s_ i = NP [(M [S i], 1)] :: NPoly LPQ BraidGens s1 = s_ 1 s2 = s_ 2 s3 = s_ 3 s4 = s_ 4 instance Invertible (NPoly LPQ BraidGens) where inv (NP [(M [S i], 1)]) = s_ (-i) {- braidRelations n = [s_ j * s_ i - s_ i * s_ j | i <- [1..n-1], j <- [i+2..n-1] ] ++ [s_ (i+1) * s_ i * s_ (i+1) - s_ i * s_ (i+1) * s_ i | i <- [1..n-2] ] -- !! need relations for the inverses too !! -- (but we're not intending to work in the braid algebra - we're intending to map into Temperley-Lieb or Iwahori-Hecke) -} -- The writhe of a braid == the sum of the signs of the crossings writhe (NP [(M xs,c)]) = sum [signum i | S i <- xs] -- Some knots - Lickorish p5, p27 -- (Note: These knots/braids give the correct Homfly/Jones polynomials compared to Lickorish) -- (In general, that's not sufficient to prove that they are the claimed knots, although in these cases, they are.) k3_1 = s1^-3 k4_1 = s2^-1 * s1 * s2^-1 * s1 k5_1 = s1^-5 k7_1 = s1^-7 HaskellForMaths-0.4.8/Math/Projects/KnotTheory/IwahoriHecke.hs0000644000000000000000000001074512514742102022433 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. {-# LANGUAGE FlexibleInstances #-} module Math.Projects.KnotTheory.IwahoriHecke where -- import qualified Data.Map as M import Math.Algebra.Field.Base import Math.Algebra.NonCommutative.NCPoly as NP hiding (x,y,z) import Math.Algebra.NonCommutative.GSBasis import Math.Projects.KnotTheory.LaurentMPoly as LP hiding (z) import Math.Projects.KnotTheory.Braid -- IWAHORI-HECKE ALGEBRAS data IwahoriHeckeGens = T Int deriving (Eq,Ord) instance Show IwahoriHeckeGens where show (T i) = 't': show i t_ i = NP [(M [T i], 1)] :: NPoly LPQ IwahoriHeckeGens t1 = t_ 1 t2 = t_ 2 t3 = t_ 3 t4 = t_ 4 q = LP.var "q" -- :: LPQ z = LP.var "z" -- :: LPQ q' = NP.inject q :: NPoly LPQ IwahoriHeckeGens z' = NP.inject z :: NPoly LPQ IwahoriHeckeGens -- inverses instance Invertible (NPoly LPQ IwahoriHeckeGens) where inv (NP [(M [T i], 1)]) = (t_ i - z') / q' -- x ^- n = inv x ^ n -- Iwahori-Hecke algebra Hn(q,z), generated by n-1 elts t1..t_n-1, together with relations ihRelations n = [t_ i * t_ j - t_ j * t_ i | i <- [1..n-1], j <- [i+2..n-1] ] ++ [t_ i * t_ j * t_ i - t_ j * t_ i * t_ j | i <- [1..n-1], j <- [1..n-1], abs (i-j) == 1 ] ++ [(t_ i)^2 - z' * t_ i - q' | i <- [1..n-1] ] -- given an elt of the Temperley-Lieb algebra, return the dimension it's defined over (ie the number of points) dimIH (NP ts) = 1 + maximum (0 : [i | (M bs,c) <- ts, T i <- bs]) -- Reduce to normal form ihnf f = f %% (gb $ ihRelations $ dimIH f) -- Monomial basis for Iwahori-Hecke algebra (as quotient of free algebra by Iwahori-Hecke relations) ihBasis n = mbasisQA [t_ i | i <- [1..n-1]] (gb $ ihRelations n) -- OCNEANU TRACE -- Trace function on single terms tau' 1 (1,c) = c tau' 2 (1,c) = c * (1-q)/z tau' 2 (m,c) = c tau' n (m,c) = case m `divM` M [T (n-1)] of Just (l,r) -> tau (n-1) $ NP [(l*r,c)] -- have to call tau not tau', because l*r might be reducible Nothing -> tau' (n-1) (m,c*(1-q)/z) -- Trace function on polynomials, by linearity -- Given an elt of Iwahori-Hecke algebra, returns an elt of Q[q,z] tau n f | dimIH f <= n = let NP ts = ihnf f in sum [tau' n t | t <- ts] fromBraid f = ihnf (NP.subst skeinRelations f) where skeinRelations = concat [ [(s_ i, t_ i), (s_ (-i), (t_ i - z') / q')] | i <- [1..] ] -- HOMFLY polynomial, also called Jones-Conway polynomial -- Kassel, Turaev version, as poly in x,y -- Satisfies skein relation x P_L_+(x,y) - x^-1 P_L_-(x,y) == y P_L_0(x,y) -- n is the index of the Iwahori-Hecke algebra we're working in (ie the number of strings in the braid) -- f is the braid expressed in the Iwahori-Hecke generators ti homfly n f = LP.subst [(q,1/x^2),(z,y/x)] $ tau n $ fromBraid f i = LP.var "i" :: LPQ l = LP.var "l" :: LPQ m = LP.var "m" :: LPQ -- HOMFLY polynomial (for braid f over n strings) -- Lickorish version, as poly in l,m -- Satisfies skein relation l P_L_+(l,m) + l^-1 P_L_-(l,m) + m P_L_0(l,m) == 0 homfly' n f = let f' = LP.subst [(x,i^3*l),(y,i*m)] (homfly n f) in reduceLP f' (i^2+1) -- Closer to Thistlethwaite notation homfly'' n f = sum $ zipWith (*) (map LP.inject $ coeffs (m^2) (homfly' n f)) (iterate (*(m'^2)) 1) where m' = LP.var "m" :: LaurentMPoly LPQ -- where m' = LP [(LM $ M.singleton "m" 1, 1)] :: LaurentMPoly LPQ -- express an lpoly as a upoly over one of its variables coeffs v 0 = [] coeffs v f = let (f',c) = quotRemLP f v in c : coeffs v f' -- Jones polynomial (for braid f over m strings) -- from the HOMFLY polynomial via the substitution x -> 1/t, y -> t^1/2 - t^-1/2 -- The reason the code is so complicated is that y == t^1/2 - t^-1/2 can appear in the denominator, -- and we have to cancel it out with the numerator by hand because our code can't do it for us jones' m f = let f' = homfly m f n = d*f' d = denominatorLP f' subs = [(x,1/t),(y,t^^^(1/2)-1/t^^^(1/2))] -- subs = [(x,1/t^2),(y,t-1/t)] n' = LP.subst subs n d' = LP.subst subs d nn = nd*n' nd = denominatorLP n' dn = dd*d' dd = denominatorLP d' (q,r) = quotRemLP nn dn -- in if r == 0 then halfExponents' (dd/nd * q) else error "" in if r == 0 then (dd/nd * q) else error "" -- Alexander polynomial is the substitution x -> 1, y -> t^1/2 - t^-1/2 HaskellForMaths-0.4.8/Math/Projects/KnotTheory/LaurentMPoly.hs0000644000000000000000000001571112514742102022462 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. module Math.Projects.KnotTheory.LaurentMPoly where import qualified Data.Map as M import Data.List as L import Math.Algebra.Field.Base -- It would be possible to refactor this and other code into common code for semigroup rings -- But there are enough small fiddly differences that it's easier not to -- LAURENT MONOMIALS newtype LaurentMonomial = LM (M.Map String Q) deriving (Eq) -- We allow exponents to be rationals, because we want to support rings such as Z[q^1/2,q^-1/2] in connection with Hecke algebras -- the multidegree - not sure how meaningful this is if we have negative indices too degLM (LM m) = sum $ M.elems m -- Glex ordering instance Ord LaurentMonomial where compare a b = let ds = M.elems m where LM m = a/b in case compare (sum ds) 0 of GT -> GT LT -> LT EQ -> if null ds then EQ else if head ds > 0 then GT else LT instance Show LaurentMonomial where show (LM a) | M.null a = "1" | otherwise = concatMap showVar $ M.toList a where showVar (v,1) = v showVar (v,i) = v ++ "^" ++ show i instance Num LaurentMonomial where LM a * LM b = LM $ M.filter (/=0) $ M.unionWith (+) a b fromInteger 1 = LM M.empty instance Fractional (LaurentMonomial) where recip (LM m) = LM $ M.map negate m -- untested -- numeratorLM (LM a) = LM $ M.filter (>0) a denominatorLM (LM a) = recip $ LM $ M.filter (<0) a -- not valid for arguments with negative exponents (because 0 won't trump -i) lcmLM (LM a) (LM b) = LM $ M.unionWith max a b -- not tested -- for arguments with non-zero denominators -- gcdLM (LM a) (LM b) = LM $ M.intersectionWith min a b divLM a b = let LM c = a/b in if all (>=0) (M.elems c) then Just (LM c) else Nothing -- LAURENT POLYNOMIALS newtype LaurentMPoly r = LP [(LaurentMonomial,r)] deriving (Eq,Ord) instance Show r => Show (LaurentMPoly r) where show (LP []) = "0" show (LP ts) = let (c:cs) = concatMap showTerm (reverse ts) -- we show Laurent polys with smallest terms first in if c == '+' then cs else c:cs where showTerm (m,c) = case show c of "1" -> "+" ++ show m "-1" -> "-" ++ show m -- cs@(x:_) -> (if x == '-' then cs else '+':cs) ++ (if m == 1 then "" else show m) cs -> showCoeff cs ++ (if m == 1 then "" else show m) showCoeff (c:cs) = if any (`elem` ['+','-']) cs then "+(" ++ c:cs ++ ")" else if c == '-' then c:cs else '+':c:cs -- we don't attempt sign reversal within brackets in case we have expressions like t^-1 inside the brackets instance (Eq r, Num r) => Num (LaurentMPoly r) where LP ts + LP us = LP (mergeTerms ts us) negate (LP ts) = LP $ map (\(m,c)->(m,-c)) ts LP ts * LP us = LP $ collect $ sortBy cmpTerm $ [(g*h,c*d) | (g,c) <- ts, (h,d) <- us] fromInteger 0 = LP [] fromInteger n = LP [(fromInteger 1, fromInteger n)] cmpTerm (a,c) (b,d) = case compare a b of EQ -> EQ; GT -> LT; LT -> GT -- we have to put largest terms first so that quotRem works -- inputs in descending order mergeTerms (t@(g,c):ts) (u@(h,d):us) = case cmpTerm t u of LT -> t : mergeTerms ts (u:us) GT -> u : mergeTerms (t:ts) us EQ -> if e == 0 then mergeTerms ts us else (g,e) : mergeTerms ts us where e = c + d mergeTerms ts us = ts ++ us -- one of them is null collect (t1@(g,c):t2@(h,d):ts) | g == h = collect $ (g,c+d):ts | c == 0 = collect $ t2:ts | otherwise = t1 : collect (t2:ts) collect ts = ts -- Fractional instance so that we can enter fractional coefficients -- Only lets us divide by single terms, not any other polynomials instance (Eq r, Fractional r) => Fractional (LaurentMPoly r) where recip (LP [(m,c)]) = LP [(recip m, recip c)] recip _ = error "LaurentMPoly.recip: only supported for (non-zero) constants or monomials" lm (LP ((m,c):ts)) = m lc (LP ((m,c):ts)) = c lt (LP ((m,c):ts)) = LP [(m,c)] quotRemLP f g | g == 0 = error "quotRemLP: division by zero" | denominatorLP f /= 1 || denominatorLP g /= 1 = error "quotRemLP: negative exponents" | otherwise = quotRemLP' f (0,0) where quotRemLP' 0 (q,r) = (q,r) quotRemLP' h (q,r) = case lm h `divLM` lm g of Just m -> let t = LP [(m, lc h / lc g)] in quotRemLP' (h-t*g) (q+t,r) Nothing -> let lth = lt h -- can't reduce lt h, so add it to the remainder and try to reduce the remaining terms in quotRemLP' (h-lth) (q, r+lth) -- g must be a binomial without negative exponents - eg i^2+1 reduceLP f g@(LP [_,_]) = let fn = f * fd fd = denominatorLP f (_,rn) = quotRemLP fn g (_,rd) = quotRemLP fd g in rn / rd var v = LP [(LM $ M.singleton v 1, 1)] t = var "t" :: LaurentMPoly Q x = var "x" :: LaurentMPoly Q y = var "y" :: LaurentMPoly Q z = var "z" :: LaurentMPoly Q denominatorLP (LP ts) = LP [(m',1)] where m' = foldl lcmLM 1 [denominatorLM m | (m,c) <- ts] {- -- not tested for terms with non-zero denominator gcdTermsLP (LP ts) = LP [(m',1)] where m' = foldl gcdLM 1 [m | (m,c) <- ts] -} -- injection of field elements into polynomial ring inject 0 = LP [] inject c = LP [(fromInteger 1, c)] sqrtvar v = LP [(LM $ M.singleton v (1/2), 1)] -- substitute terms for variables in an MPoly -- eg subst [(x,a),(y,a+b),(z,c^2)] (x*y+z) -> a*(a+b)+c^2 subst vts (LP us) = sum [inject c * substM m | (m,c) <- us] where substM (LM m) = product [substV v ^^^ i | (v,i) <- M.toList m] substV v = let v' = var v in case L.lookup v' vts of Just t -> t Nothing -> v' -- no substitute, so keep as is f ^^^ i | denominatorQ i == 1 = f ^^ numeratorQ i -- exponent is an integer | otherwise = case f of LP [(LM m,1)] -> LP [(LM $ M.map (*i) m ,1)]-- base is a monomial otherwise -> error ("(^^^): Cannot calculate " ++ show f ++ " ^^^ " ++ show i) {- -- halve all indices - useful when we really want to be working over k[t^1/2,t^-1/2] halfExponents (LP ts) = if any odd (concatMap (\(LM m,c) -> M.elems m) ts) then error ("halfExponents: " ++ show (LP ts)) else LP $ map (\(LM m, c) -> (LM $ M.filter (/=0) $ M.map (`div` 2) m, c)) ts halfExponents' f@(LP ts) = let f'@(LP us) = LP $ map (\(LM m, c) -> (LM $ M.map (`div` 2) m, c)) ts in if any (==0) (concatMap (\(LM m,c) -> M.elems m) us) then Left f else Right f' quarterExponents' f@(LP ts) = let f'@(LP us) = LP $ map (\(LM m, c) -> (LM $ M.map (`div` 4) m, c)) ts in if any (==0) (concatMap (\(LM m,c) -> M.elems m) us) then Left f else Right f' -}HaskellForMaths-0.4.8/Math/Projects/KnotTheory/TemperleyLieb.hs0000644000000000000000000000604212514742102022626 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. {-# LANGUAGE FlexibleInstances #-} module Math.Projects.KnotTheory.TemperleyLieb where import Data.List ( (\\) ) import Math.Algebra.Field.Base import Math.Algebra.NonCommutative.NCPoly as NP import Math.Algebra.NonCommutative.GSBasis import Math.Projects.KnotTheory.LaurentMPoly as LP import Math.Projects.KnotTheory.Braid -- TEMPERLEY-LIEB ALGEBRAS data TemperleyLiebGens = E Int deriving (Eq,Ord) instance Show TemperleyLiebGens where show (E i) = 'e': show i e_ i = NP [(M [E i], 1)] :: NPoly LPQ TemperleyLiebGens -- d is the value of a closed loop d = LP.var "d" d' = NP.inject d :: NPoly LPQ TemperleyLiebGens e1 = e_ 1 e2 = e_ 2 e3 = e_ 3 e4 = e_ 4 -- Temperley-Lieb algebra An(d), generated by n-1 elts e1..e_n-1, together with relations tlRelations n = [e_ i * e_ j - e_ j * e_ i | i <- [1..n-1], j <- [i+2..n-1] ] ++ [e_ i * e_ j * e_ i - e_ i | i <- [1..n-1], j <- [1..n-1], abs (i-j) == 1 ] ++ [(e_ i)^2 - d' * e_ i | i <- [1..n-1] ] -- given an elt of the Temperley-Lieb algebra, return the dimension it's defined over (ie the number of points) dimTL (NP ts) = 1 + maximum (0 : [i | (M bs,c) <- ts, E i <- bs]) -- Reduce to normal form tlnf f = f %% (gb $ tlRelations $ dimTL f) -- Monomial basis for Temperley-Lieb algebra (as quotient of free algebra by Temperley-Lieb relations) tlBasis n = mbasisQA [e_ i | i <- [1..n-1]] (gb $ tlRelations n) -- trace function -- the trace of an elt is d^k, where k is the number of loops in its closure (ie join the top and bottom of the diagram to make an annulus) -- this is clearly the same as the number of cycles of the elt when thought of as an elt of Sn, with ei mapped to the transposition (i i+1) tr' n (M g) = d ^ ( -1 + length (orbits g [1..n]) ) where image i [] = i image i (E j : es) | i == j = image (i+1) es | i == j+1 = image (i-1) es | otherwise = image i es orbits g [] = [] orbits g (i:is) = let i' = orbit i [] in i' : orbits g ((i:is) \\ i') orbit j js = let j' = image j g in if j' `elem` (j:js) then reverse (j:js) else orbit j' (j:js) -- Note, some authors define the trace so that tr 1 == 1. -- That is the same as this trace except for a factor of d^(n-1) tr n f@(NP ts) = sum [c * tr' n m | (m,c) <- ts] -- JONES POLYNOMIAL a = LP.var "a" a' = NP.inject a :: NPoly LPQ TemperleyLiebGens -- Convert a braid to Temperley-Lieb algebra using Skein relation fromBraid f = tlnf (NP.subst skeinRelations f) where skeinRelations = concat [ [(s_ i, 1/a' * e_ i + a'), (s_ (-i), a' * e_ i + 1/a')] | i <- [1..] ] -- Jones polynomial -- n the number of strings, f the braid jones n f = let kauffman = LP.subst [(d, - a^2 - 1/a^2)] $ tr n (fromBraid f) j = (-a)^^(-3 * writhe f) * kauffman -- in halfExponents $ halfExponents $ LP.subst [(a,1/t)] j -- in quarterExponents' $ LP.subst [(a,1/t)] j in LP.subst [(a,1/t^^^(1/4))] j HaskellForMaths-0.4.8/Math/QuantumAlgebra/0000755000000000000000000000000012514742102016537 5ustar0000000000000000HaskellForMaths-0.4.8/Math/QuantumAlgebra/OrientedTangle.hs0000644000000000000000000001251012514742102021776 0ustar0000000000000000-- Copyright (c) David Amos, 2010-2015. All rights reserved. {-# LANGUAGE TypeFamilies, EmptyDataDecls #-} module Math.QuantumAlgebra.OrientedTangle where import Prelude hiding ( (*>) ) import Math.Algebra.Field.Base import Math.Algebras.LaurentPoly -- hiding (lvar, q, q') import Math.QuantumAlgebra.TensorCategory import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures -- import MathExperiments.Algebra.TAlgebra -- ORIENTED TANGLE CATEGORY data Oriented = Plus | Minus deriving (Eq,Ord,Show) data HorizDir = ToL | ToR deriving (Eq,Ord,Show) data OrientedTangle -- In GHCi 6.12.1, we appear to be limited to 8 value constructors within an associated data family instance MCategory OrientedTangle where data Ob OrientedTangle = OT [Oriented] deriving (Eq,Ord,Show) data Ar OrientedTangle = IdT [Oriented] | CapT HorizDir | CupT HorizDir | XPlus | XMinus | SeqT [Ar OrientedTangle] | ParT [Ar OrientedTangle] deriving (Eq,Ord,Show) id_ (OT os) = IdT os source (IdT os) = OT os source (CapT _) = OT [] source (CupT toR) = OT [Plus,Minus] source (CupT toL) = OT [Minus,Plus] source XPlus = OT [Plus,Plus] source XMinus = OT [Plus,Plus] source (ParT as) = OT $ concatMap ((\(OT os) -> os) . source) as source (SeqT as) = source (head as) target (IdT os) = OT os target (CapT toR) = OT [Minus,Plus] target (CapT toL) = OT [Plus,Minus] target (CupT _) = OT [] target XPlus = OT [Plus,Plus] target XMinus = OT [Plus,Plus] target (ParT as) = OT $ concatMap ((\(OT os) -> os) . target) as target (SeqT as) = target (last as) a >>> b | target a == source b = SeqT [a,b] instance Monoidal OrientedTangle where tunit = OT [] tob (OT as) (OT bs) = OT (as++bs) tar a b = ParT [a,b] idV = id idV' = id evalV = \(E i, E j) -> if i + j == 0 then return () else zerov evalV' = \(E i, E j) -> if i + j == 0 then return () else zerov coevalV m = foldl (<+>) zerov [e i `te` e (-i) | i <- [1..m] ] coevalV' m = foldl (<+>) zerov [e (-i) `te` e i | i <- [1..m] ] lambda m = q' ^ m -- q^-m c m (E i, E j) = case compare i j of EQ -> (lambda m * q) *> return (E i, E i) LT -> lambda m *> return (E j, E i) GT -> lambda m *> (return (E j, E i) <+> (q - q') *> return (E i, E j)) -- inverse of c c' m (E i, E j) = case compare i j of EQ -> (1/(lambda m * q)) *> return (E i, E i) LT -> (1/lambda m) *> (return (E j, E i) <+> (q'-q) *> return (E i, E j)) GT -> (1/lambda m) *> return (E j, E i) testcc' m v = nf $ v >>= c m >>= c' m mu m (E i) = (1 / (lambda m * q ^ (2*i-1))) *> return (E i) mu' m (E i) = (lambda m * q ^ (2*i-1)) *> return (E i) -- The following are modified from Kassel. We compose diagrams downwards, whereas he composes them upwards. capRL m = coevalV m capLR m = do (i,j) <- coevalV' m k <- mu' m j return (i,k) cupRL m = evalV cupLR m (i,j) = do k <- mu m i evalV' (k,j) -- linear evalV' . (linear (mu' m) `tf` idV) xplus m = c m xminus m = c' m yplus m (p,q) = do (r,s) <- capRL m (t,u) <- xplus m (q,r) cupRL m (p,t) return (u,s) yminus m (p,q) = do (r,s) <- capRL m (t,u) <- xminus m (q,r) cupRL m (p,t) return (u,s) tplus m (p,q) = do (r,s) <- capLR m (t,u) <- xplus m (s,p) cupLR m (u,q) return (r,t) tminus m (p,q) = do (r,s) <- capLR m (t,u) <- xminus m (s,p) cupLR m (u,q) return (r,t) zplus m (p,q) = do (r,u) <- capLR m (s,t) <- capLR m (v,w) <- xplus m (t,u) cupLR m (v,q) cupLR m (w,p) return (r,s) zminus m (p,q) = do (r,u) <- capLR m (s,t) <- capLR m (v,w) <- xminus m (t,u) cupLR m (v,q) cupLR m (w,p) return (r,s) {- Then we have for example the following: > let v = e1 `te` e2 in nf $ v >>= xplus 2 >>= xminus 2 (e1,e2) > let v = e (-1) `te` e2 in nf $ v >>= yplus 2 >>= tminus 2 (e-1,e2) > let v = e (-1) `te` e (-2) in nf $ v >>= zplus 2 >>= zminus 2 (e-1,e-2) -} oloop m = nf $ do (a,b) <- capLR m cupRL m (a,b) -- oriented trefoil otrefoil m = nf $ do (p,q) <- capLR m (r,s) <- capLR m (t,u) <- tminus m (q,r) (v,w) <- zminus m (p,t) (x,y) <- xminus m (u,s) cupRL m (w,x) cupRL m (v,y) -- oriented the other way otrefoil' m = nf $ do (p,q) <- capRL m (r,s) <- capRL m (t,u) <- yminus m (q,r) (v,w) <- xminus m (p,t) (x,y) <- zminus m (u,s) cupLR m (w,x) cupLR m (v,y) {- -- REPRESENTATIONS OF THE TANGLE CATEGORY IN VECTOR SPACE CATEGORY -- But we need to convert the above code to use TensorAlgebra first kauffman :: Ar Tangle -> TangleRep [Oriented] -> TangleRep [Oriented] kauffman (IdT n) = id -- could be tf of n ids kauffman CapT = linear cap kauffman CupT = linear cup kauffman OverT = linear over kauffman UnderT = linear under kauffman (SeqT fs) = foldl (>>>) id $ map kauffman fs where g >>> h = h . g kauffman (ParT [f]) = kauffman f kauffman (ParT (f:fs)) = tf m (kauffman f) (kauffman (ParT fs)) where OT m = source f tf m f' fs' = linear (\xs -> let (ls,rs) = splitAt m xs in f' (return ls) * fs' (return rs) ) -}HaskellForMaths-0.4.8/Math/QuantumAlgebra/QuantumPlane.hs0000644000000000000000000001637412514742102021520 0ustar0000000000000000-- Copyright (c) 2010, David Amos. All rights reserved. {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, NoMonomorphismRestriction #-} -- |A module defining the quantum plane and its symmetries module Math.QuantumAlgebra.QuantumPlane where -- Refs: -- Kassel, Quantum Groups -- Street, Quantum Groups import Math.Algebra.Field.Base hiding (powers) import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures import Math.Algebras.LaurentPoly import Math.Algebras.NonCommutative import qualified Data.List as L qvar v = let V [(m,1)] = var v in V [(m,1 :: LaurentPoly Q)] a = qvar "a" b = qvar "b" c = qvar "c" d = qvar "d" detq = a*d-unit q'*b*c x = qvar "x" y = qvar "y" -- z = qvar "z" u = qvar "u" v = qvar "v" -- Quantum plane Aq20 aq20 = [y*x-unit q*x*y] -- Kassel p72, Street p10 newtype Aq20 v = Aq20 (NonComMonomial v) deriving (Eq,Ord) instance (Eq v, Show v) => Show (Aq20 v) where show (Aq20 m) = show m instance Monomial Aq20 where var v = V [(Aq20 (NCM 1 [v]),1)] powers (Aq20 m) = powers m instance Algebra (LaurentPoly Q) (Aq20 String) where unit 0 = zerov -- V [] unit x = V [(munit,x)] where munit = Aq20 (NCM 0 []) mult x = x''' where x' = mult $ fmap ( \(Aq20 a, Aq20 b) -> (a,b) ) x -- unwrap and multiply x'' = x' %% aq20 -- quotient by m2q relations while unwrapped x''' = fmap Aq20 x'' -- wrap the monomials up as Aq20 again -- Quantum superplane Aq02 aq02 = [u^2, v^2, u*v+unit q*v*u] -- Street p10 newtype Aq02 v = Aq02 (NonComMonomial v) deriving (Eq,Ord) instance (Eq v, Show v) => Show (Aq02 v) where show (Aq02 m) = show m instance Monomial Aq02 where var v = V [(Aq02 (NCM 1 [v]),1)] powers (Aq02 m) = powers m instance Algebra (LaurentPoly Q) (Aq02 String) where unit 0 = zerov -- V [] unit x = V [(munit,x)] where munit = Aq02 (NCM 0 []) mult x = x''' where x' = mult $ fmap ( \(Aq02 a, Aq02 b) -> (a,b) ) x -- unwrap and multiply x'' = x' %% aq02 -- quotient by m2q relations while unwrapped x''' = fmap Aq02 x'' -- wrap the monomials up as Aq02 again -- M2q m2q = [a*b-unit q'*b*a, a*c-unit q'*c*a, c*d-unit q'*d*c, b*d-unit q'*d*b, b*c-c*b, a*d-d*a-unit (q'-q)*b*c] -- Kassel p78, Street p9 -- I think this is already a Groebner basis newtype M2q v = M2q (NonComMonomial v) deriving (Eq,Ord) instance (Eq v, Show v) => Show (M2q v) where show (M2q m) = show m instance Monomial M2q where var v = V [(M2q (NCM 1 [v]),1)] powers (M2q m) = powers m instance Algebra (LaurentPoly Q) (M2q String) where unit 0 = zerov -- V [] unit x = V [(munit,x)] where munit = M2q (NCM 0 []) mult x = x''' where x' = mult $ fmap ( \(M2q a, M2q b) -> (a,b) ) x -- unwrap and multiply x'' = x' %% m2q -- quotient by m2q relations while unwrapped x''' = fmap M2q x'' -- wrap the monomials up as M2q again -- Kassel p82-3 instance Coalgebra (LaurentPoly Q) (M2q String) where counit x = case x `bind` cu of V [] -> 0 V [(M2q (NCM 0 []), c)] -> c where cu "a" = 1 :: Vect (LaurentPoly Q) (M2q String) cu "b" = 0 cu "c" = 0 cu "d" = 1 comult x = x `bind` cm where cm "a" = a `te` a + b `te` c cm "b" = a `te` b + b `te` d cm "c" = c `te` a + d `te` c cm "d" = c `te` b + d `te` d instance Bialgebra (LaurentPoly Q) (M2q String) where {} {- -- The following shows that the M2q relations are *sufficient* -- for M2q to be symmetries of Aq20 and Aq02 > let x' = a*x+b*y :: Vect (LaurentPoly Q) (NonComMonomial String) > let y' = c*x+d*y :: Vect (LaurentPoly Q) (NonComMonomial String) > (y'*x'-unit q*x'*y') %% (m2q ++ aq20 ++ [s*t-t*s | s <- [a,b,c,d], t <- [x,y]]) 0 > let u' = a*u+b*v :: Vect (LaurentPoly Q) (NonComMonomial String) > let v' = c*u+d*v :: Vect (LaurentPoly Q) (NonComMonomial String) > (u'^2) %% (m2q ++ aq02 ++ [s*t-t*s | s <- [a,b,c,d], t <- [u,v]]) 0 > (v'^2) %% (m2q ++ aq02 ++ [s*t-t*s | s <- [a,b,c,d], t <- [u,v]]) 0 > (u'*v'+unit q*v'*u') %% (m2q ++ aq02 ++ [s*t-t*s | s <- [a,b,c,d], t <- [u,v]]) 0 -- To show that the M2q relations are necessary, -- set the coefficients of x^2, yx, y^2, and vu == 0 in all of the following > (y'*x'-unit q*x'*y') %% (aq20 ++ [p*q-q*p | p <- [a,b,c,d], q <- [x,y]]) -qx^2ac+x^2ca-yxad-qyxbc+q^-1yxcb+yxda-qy^2bd+y^2db > (u'^2) %% (aq02 ++ [p*q-q*p | p <- [a,b,c,d], q <- [u,v]]) -qvuab+vuba > (v'^2) %% (aq02 ++ [p*q-q*p | p <- [a,b,c,d], q <- [u,v]]) -qvucd+vudc > (u'*v'+unit q*v'*u') %% (aq02 ++ [p*q-q*p | p <- [a,b,c,d], q <- [u,v]]) -qvuad+vubc-q^2vucb+qvuda -- yx => -ad-qbc+q^-1cb+da == 0 -- vu => -qad+bc-q^2cb+qda == 0 -- qyx-vu => -q^2bc+cb-bc+q^2cb == 0 => bc == cb -- Now substitute back into yx -- We could probably have got gb to do this for us -} -- Kassel p85 instance Comodule (LaurentPoly Q) (M2q String) (Aq20 String) where coaction xy = xy `bind` ca where ca "x" = (a `te` x) + (b `te` y) -- we can use (+) instead of add since Aq20 is an algebra ca "y" = (c `te` x) + (d `te` y) -- coaction (x) = (a b) `te` (x) -- (y) (c d) (y) -- SL2q sl2q = [a*b-unit q'*b*a, a*c-unit q'*c*a, c*d-unit q'*d*c, b*d-unit q'*d*b, b*c-c*b, a*d-d*a-unit (q'-q)*b*c, -unit q*c*b + d*a - 1] -- det q, but reduced -- a*d-unit q'*b*c-1] -- det_q -- We have to hand-reduce detq, or else call gb newtype SL2q v = SL2q (NonComMonomial v) deriving (Eq,Ord) instance (Eq v, Show v) => Show (SL2q v) where show (SL2q m) = show m instance Monomial SL2q where var v = V [(SL2q (NCM 1 [v]),1)] powers (SL2q m) = powers m instance Algebra (LaurentPoly Q) (SL2q String) where unit 0 = zerov -- V [] unit x = V [(munit,x)] where munit = SL2q (NCM 0 []) mult x = x''' where x' = mult $ fmap ( \(SL2q a, SL2q b) -> (a,b) ) x -- unwrap and multiply x'' = x' %% sl2q -- quotient by sl2q relations while unwrapped x''' = fmap SL2q x'' -- wrap the monomials up as SL2q again instance Coalgebra (LaurentPoly Q) (SL2q String) where counit x = case x `bind` cu of V [] -> 0 V [(SL2q (NCM 0 []), c)] -> c where cu "a" = 1 :: Vect (LaurentPoly Q) (SL2q String) cu "b" = 0 cu "c" = 0 cu "d" = 1 comult x = x `bind` cm where cm "a" = a `te` a + b `te` c cm "b" = a `te` b + b `te` d cm "c" = c `te` a + d `te` c cm "d" = c `te` b + d `te` d instance Bialgebra (LaurentPoly Q) (SL2q String) where {} -- Kassel p84 instance HopfAlgebra (LaurentPoly Q) (SL2q String) where antipode x = x `bind` antipode' where antipode' "a" = d antipode' "b" = - unit q * b antipode' "c" = - unit q' * c antipode' "d" = a -- in the GL2q case we would need 1/detq factor as well -- !! The following probably needs to be rehoused in separate module at some point -- YANG-BAXTER OPERATOR -- This is a Yang-Baxter operator, but not the only possible such -- Street, p93 yb x = nf $ x >>= yb' where yb' (a,b) = case compare a b of GT -> return (b,a) LT -> return (b,a) + unit (q-q') * return (a,b) EQ -> unit q * return (a,a) HaskellForMaths-0.4.8/Math/QuantumAlgebra/Tangle.hs0000644000000000000000000001315212514742102020307 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, EmptyDataDecls #-} -- |A module defining the category of tangles, and representations into the category of vector spaces -- (specifically, knot invariants). module Math.QuantumAlgebra.Tangle where import Prelude hiding ( (*>) ) -- import qualified Data.List as L import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures import Math.Algebra.Field.Base import Math.Algebras.LaurentPoly import Math.QuantumAlgebra.TensorCategory hiding (Vect) instance Mon [a] where munit = [] mmult = (++) -- type TensorAlgebra k a = Vect k [a] instance (Eq k, Num k, Ord a) => Algebra k [a] where unit 0 = zerov -- V [] unit x = V [(munit,x)] mult = nf . fmap (\(a,b) -> a `mmult` b) -- Could make TensorAlgebra k a into an instance of Category, TensorCategory -- TANGLE CATEGORY -- (Unoriented) data Tangle instance MCategory Tangle where data Ob Tangle = OT Int deriving (Eq,Ord,Show) data Ar Tangle = IdT Int | CapT | CupT | OverT | UnderT -- | SeqT (Ar Tangle) (Ar Tangle) | SeqT [Ar Tangle] -- | ParT (Ar Tangle) (Ar Tangle) | ParT [Ar Tangle] deriving (Eq,Ord,Show) id_ (OT n) = IdT n source (IdT n) = OT n source CapT = OT 0 source CupT = OT 2 source OverT = OT 2 source UnderT = OT 2 -- source (ParT a b) = OT (sa + sb) where OT sa = source a; OT sb = source b source (ParT as) = OT $ sum [sa | a <- as, let OT sa = source a] -- source (SeqT a b) = source a source (SeqT as) = source (head as) target (IdT n) = OT n target CapT = OT 2 target CupT = OT 0 target OverT = OT 2 target UnderT = OT 2 -- target (ParT a b) = OT (ta + tb) where OT ta = target a; OT tb = target b target (ParT as) = OT $ sum [ta | a <- as, let OT ta = target a] -- target (SeqT a b) = target b target (SeqT as) = target (last as) -- a >>> b | target a == source b = SeqT a b a >>> b | target a == source b = SeqT [a,b] instance Monoidal Tangle where tunit = OT 0 tob (OT a) (OT b) = OT (a+b) -- tar a b = ParT a b tar a b = ParT [a,b] -- KAUFFMAN BRACKET data Oriented = Plus | Minus deriving (Eq,Ord,Show) type TangleRep b = Vect (LaurentPoly Q) b -- adapted from http://blog.sigfpe.com/2008/10/untangling-with-continued-fractions.html cap :: [Oriented] -> TangleRep [Oriented] cap [] = return [Plus, Minus] <+> (-q^2) *> return [Minus, Plus] cup :: [Oriented] -> TangleRep [Oriented] cup [Plus, Minus] = (-q'^2) *> return [] cup [Minus, Plus] = return [] cup _ = zerov -- also called xminus over :: [Oriented] -> TangleRep [Oriented] over [u, v] = q *> do {[] <- cup [u, v]; cap []} <+> q' *> return [u, v] {- -- if you expand "over" into terms, you find that it equals the following, -- which strongly resembles c' below over' (T i j) = case compare i j of EQ -> q' *> return (T i i) -- ++ -> q' ++, -- -> q' -- LT -> q *> return (T j i) -- +- -> q -+ GT -> q *> (return (T j i) <+> (q'^2 - q^2) *> return (T i j)) -- -+ -> q +- + (q'-q^3) -+ -} -- also called xplus under :: [Oriented] -> TangleRep [Oriented] under [u, v] = q' *> do {[] <- cup [u, v]; cap []} <+> q *> return [u, v] {- -- if you expand "under" into terms, you find that it equals the following, -- which strongly resembles c below under' (T i j) = case compare i j of EQ -> q *> return (T i i) -- ++ -> q ++, -- -> q -- LT -> q' *> (return (T j i) <+> (q^2 - q'^2) *> return (T i j)) -- +- -> q' -+ + (q-q^-3) -+ GT -> q' *> return (T j i) -- -+ -> q' +- -} loop = nf $ do {[i, j] <- cap []; cup [i, j]} trefoil = nf $ do [i, j] <- cap [] [k, l] <- cap [] [m, n] <- under [j, k] [p, q] <- over [i, m] [r, s] <- over [n, l] cup [p, s] cup [q, r] -- KAUFFMAN BRACKET AS A REPRESENTATION FROM TANGLE TO VECT -- But this isn't quite the Kauffman bracket - we still need to divide by (-q^2-q^-2) kauffman :: Ar Tangle -> TangleRep [Oriented] -> TangleRep [Oriented] kauffman (IdT n) = id -- could be tf of n ids kauffman CapT = linear cap kauffman CupT = linear cup kauffman OverT = linear over kauffman UnderT = linear under kauffman (SeqT fs) = foldl (>>>) id $ map kauffman fs where g >>> h = h . g kauffman (ParT [f]) = kauffman f kauffman (ParT (f:fs)) = tf m (kauffman f) (kauffman (ParT fs)) where OT m = source f tf m f' fs' = linear (\xs -> let (ls,rs) = splitAt m xs in f' (return ls) * fs' (return rs) ) {- kauffman (ParT f g) = tf m n (kauffman f) (kauffman g) where OT m = source f OT n = source g tf m n f' g' = linear (\xs -> let (ls,rs) = splitAt m xs in f' (return ls) * g' (return rs) ) -} -- loopT = SeqT CapT CupT loopT = SeqT [CapT, CupT] {- trefoilT = (ParT CapT CapT) `SeqT` (ParT (IdT 1) (ParT UnderT (IdT 1))) `SeqT` (ParT OverT OverT) `SeqT` (ParT (IdT 1) (ParT CupT (IdT 1))) `SeqT` CupT trefoilT = ParT [CapT, CapT] `SeqT` ParT [IdT 1, UnderT, IdT 1] `SeqT` ParT [OverT, OverT] `SeqT` ParT [IdT 1, CupT, IdT 1] `SeqT` CupT -} trefoilT = SeqT [ ParT [CapT, CapT], ParT [IdT 1, UnderT, IdT 1], ParT [OverT, OverT], ParT [IdT 1, CupT, IdT 1], CupT] -- eg kauffman (trefoilT) (return []) HaskellForMaths-0.4.8/Math/QuantumAlgebra/TensorCategory.hs0000644000000000000000000002051512514742102022046 0ustar0000000000000000-- Copyright (c) 2010-2014, David Amos. All rights reserved. {-# LANGUAGE TypeFamilies, EmptyDataDecls, MultiParamTypeClasses #-} -- |A module defining classes and example instances of categories, monoidal categories and braided categories module Math.QuantumAlgebra.TensorCategory where import Data.List as L class MCategory c where data Ob c :: * data Ar c :: * id_ :: Ob c -> Ar c source, target :: Ar c -> Ob c (>>>) :: Ar c -> Ar c -> Ar c -- Note that the class Category defined in Control.Category is about categories whose objects are Haskell types, -- whereas we want the objects to be values of a single type. class (MCategory a, MCategory b) => MFunctor a b where fob :: Ob a -> Ob b -- functor on objects far :: Ar a -> Ar b -- functor on arrows -- We could also define tensor functors and braided functors, which are just functors which commute appropriately -- with tensor and braiding operations -- Kassel p282 -- The following is actually definition of a _strict_ monoidal category -- Also called tensor category class MCategory c => Monoidal c where tunit :: Ob c tob :: Ob c -> Ob c -> Ob c -- tensor product of objects tar :: Ar c -> Ar c -> Ar c -- tensor product of arrows class Monoidal c => StrictMonoidal c where {} -- we want to be able to declare some tensor categories as strict class Monoidal c => WeakMonoidal c where assoc :: Ob c -> Ob c -> Ob c -> Ar c -- assoc u v w is an arrow (natural transformation?): (u `tob` v) `tob` w -> u `tob` (v `tob` w) lunit :: Ob c -> Ar c -- lunit v is an arrow (isomorphism): tunit `tob` v -> v runit :: Ob c -> Ar c -- runit v is an arrow (isomorphism): v `tob` tunit -> v {- instance (Monoidal c, Eq (Ar c), Show (Ar c)) => Num (Ar c) where (*) = tar -} class Monoidal c => Braided c where twist :: Ob c -> Ob c -> Ar c -- twist v w is a map from v tensor w to w tensor v -- twist must be natural, and satisfy certain commutative diagrams - Kock 161, 169 class Braided c => Symmetric c where {} -- if twist satisfies twist v w >>> twist w v == id_ (v tensor w), then the category is symmetric -- SIMPLEX CATEGORIES -- Kock, Frobenius Algebras ..., p178-9 -- The skeleton of FinOrd (finite ordered sets) -- The objects are the finite ordinals n == [0..n-1] -- The arrows are the order-preserving maps data FinOrd instance MCategory FinOrd where data Ob FinOrd = FinOrdOb Int deriving (Eq,Ord,Show) -- FinOrdOb n represents the oriented simplex n == [0..n-1] data Ar FinOrd = FinOrdAr Int Int [Int] deriving (Eq,Ord,Show) -- FinOrdAr s t fs represents the order-preserving map, zip [0..s-1] fs. -- For example FinOrdAr 3 2 [0,0,1] represents the map 0 -> 0, 1 -> 0, 2 -> 1 id_ (FinOrdOb n) = FinOrdAr n n [0..n-1] source (FinOrdAr s _ _) = FinOrdOb s target (FinOrdAr _ t _) = FinOrdOb t FinOrdAr sf tf fs >>> FinOrdAr sg tg gs | tf == sg = FinOrdAr sf tg [let j = fs !! i in gs !! j | i <- [0..sf-1] ] instance Monoidal FinOrd where tunit = FinOrdOb 0 tob (FinOrdOb m) (FinOrdOb n) = FinOrdOb (m+n) tar (FinOrdAr sf tf fs) (FinOrdAr sg tg gs) = FinOrdAr (sf+sg) (tf+tg) (fs ++ map (+tf) gs) finOrdAr s t fs | s == length fs && minimum fs >= 0 && maximum fs < t && isOrderPreserving fs = FinOrdAr s t fs where isOrderPreserving (f1:f2:fs) = f1 <= f2 && isOrderPreserving (f2:fs) isOrderPreserving _ = True -- The skeleton of FinSet -- The objects are the finite cardinals n == {0..n-1} (with no order) -- The arrows are the maps data FinCard instance MCategory FinCard where data Ob FinCard = FinCardOb Int deriving (Eq,Ord,Show) -- FinCardOb n represents the unoriented simplex n == {0..n-1} data Ar FinCard = FinCardAr Int Int [Int] deriving (Eq,Ord,Show) -- FinCardAr s t fs represents the map, zip [0..s-1] fs. -- For example FinCardAr 3 2 [0,1,0] represents the map 0 -> 0, 1 -> 1, 2 -> 0 id_ (FinCardOb n) = FinCardAr n n [0..n-1] source (FinCardAr s _ _) = FinCardOb s target (FinCardAr _ t _) = FinCardOb t FinCardAr sf tf fs >>> FinCardAr sg tg gs | tf == sg = FinCardAr sf tg [let j = fs !! i in gs !! j | i <- [0..sf-1] ] instance Monoidal FinCard where tunit = FinCardOb 0 tob (FinCardOb m) (FinCardOb n) = FinCardOb (m+n) tar (FinCardAr sf tf fs) (FinCardAr sg tg gs) = FinCardAr (sf+sg) (tf+tg) (fs ++ map (+tf) gs) finCardAr s t fs | s == length fs && minimum fs >= 0 && maximum fs < t -- for finite cardinals, the map doesn't have to be order-preserving = FinCardAr s t fs -- Finite permutations form a subcategory of FinCard -- having as objects the finite cardinals n == {0..n-1} -- and as arrows the bijections (== permutations) finPerm fs | L.sort fs == [0..n-1] = FinCardAr n n fs where n = length fs -- (Note that these are permutations of [0..n-1], rather than [1..n]) -- This is the forgetful functor FinOrd -> FinCard (FinSet) instance MFunctor FinOrd FinCard where fob (FinOrdOb n) = FinCardOb n far (FinOrdAr s t fs) = FinCardAr s t fs -- BRAID CATEGORY data Braid instance MCategory Braid where data Ob Braid = BraidOb Int deriving (Eq,Ord,Show) data Ar Braid = BraidAr Int [Int] deriving (Eq,Ord,Show) id_ (BraidOb n) = BraidAr n [] source (BraidAr n _) = BraidOb n target (BraidAr n _) = BraidOb n BraidAr m is >>> BraidAr n js | m == n = BraidAr m (cancel (reverse is) js) where cancel (x:xs) (y:ys) = if x+y == 0 then cancel xs ys else reverse xs ++ x:y:ys cancel xs ys = reverse xs ++ ys t n 0 = BraidAr n [] -- the identity braid t n i | 0 < i && i < n = BraidAr n [i] | -n < i && i < 0 = BraidAr n [i] -- The generators of B_n are [t n i | i <- [1..n-1]] -- The inverses of the braid generators t' n i | 0 < i && i < n = BraidAr n [-i] instance Monoidal Braid where tunit = BraidOb 0 tob (BraidOb m) (BraidOb n) = BraidOb (m+n) tar (BraidAr m is) (BraidAr n js) = BraidAr (m+n) (is ++ map (+m) js) instance Braided Braid where twist (BraidOb m) (BraidOb n) = BraidAr (m+n) $ concat [[i..i+n-1] | i <- [m,m-1..1]] -- Note that in FinCard we consider the objects as [0..n-1], whereas in Braid we consider them as [1..n], so that s_i twists [i,i+1] instance MFunctor Braid FinCard where fob (BraidOb n) = FinCardOb n far (BraidAr n ss) = foldr (>>>) (id_ (FinCardOb n)) [finPerm ([0..ti-1] ++ [ti+1,ti] ++ [ti+2..n-1]) | si <- ss, let ti = abs si - 1] -- VECT data Vect k instance Num k => MCategory (Vect k) where data Ob (Vect k) = VectOb Int deriving (Eq,Ord,Show) data Ar (Vect k) = VectAr Int Int [[Int]] deriving (Eq,Ord,Show) id_ (VectOb n) = VectAr n n idMx where idMx = [[if i == j then 1 else 0 | j <- [1..n]] | i <- [1..n]] source (VectAr m _ _) = VectOb m target (VectAr _ n _) = VectOb n VectAr r c xss >>> VectAr r' c' yss | c == r' = undefined -- matrix multiplication -- functor from FinPerm to Vect k -- 2-COBORDISMS data Cob2 -- works very similar to Tangle category instance MCategory Cob2 where data Ob Cob2 = O Int deriving (Eq,Ord,Show) data Ar Cob2 = Id Int | Unit | Mult | Counit | Comult | Par (Ar Cob2) (Ar Cob2) | Seq (Ar Cob2) (Ar Cob2) deriving (Eq,Ord,Show) id_ (O n) = Id n source (Id n) = O n source Unit = O 0 source Mult = O 2 source Counit = O 1 source Comult = O 1 source (Par a b) = O (sa + sb) where O sa = source a; O sb = source b source (Seq a b) = source a target (Id n) = O n target Unit = O 1 target Mult = O 1 target Counit = O 0 target Comult = O 2 target (Par a b) = O (ta + tb) where O ta = target a; O tb = target b target (Seq a b) = target b a >>> b | target a == source b = Seq a b instance Monoidal Cob2 where tunit = O 0 tob (O a) (O b) = O (a+b) tar a b = Par a b -- rewrite a Cob2 so that it is a Seq of Pars -- (this isn't necessarily going to help us towards a normal form - there may not even be one rewrite (Par (Seq a1 a2) (Seq b1 b2)) = Seq (Par idSourceA b1') ( (Seq (Par idSourceA b2') (Seq (Par a1' idTargetB) (Par a2' idTargetB) ) ) ) where idSourceA = id_ (source a1) idTargetB = id_ (target b2) a1' = rewrite a1 a2' = rewrite a2 b1' = rewrite b1 b2' = rewrite b2 rewrite x = xHaskellForMaths-0.4.8/Math/Test/0000755000000000000000000000000012514742102014546 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Test/TDesign.hs0000644000000000000000000000262112514742102016440 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. {-# LANGUAGE FlexibleInstances #-} module Math.Test.TDesign where import qualified Data.List as L import Math.Algebra.Field.Base import Math.Algebra.Field.Extension import Math.Combinatorics.Design as D import Math.Algebra.Group.SchreierSims as SS factorial n = product [1..n] choose n m | m <= n = product [m+1..n] `div` product [1..n-m] test = and [designParamsTest, designAutTest] designParamsTest = and [designParams (ag2 f2) == Just (2,(4,2,1)) ,designParams (ag2 f3) == Just (2,(9,3,1)) ,designParams (ag2 f4) == Just (2,(16,4,1)) ,designParams (pg2 f2) == Just (2,(7,3,1)) ,designParams (pg2 f3) == Just (2,(13,4,1)) ,designParams (pg2 f4) == Just (2,(21,5,1)) ,designParams s_3_6_22 == Just (3,(22,6,1)) ,designParams (derivedDesign s_3_6_22 1) == Just (2,(21,5,1)) -- it is PG(2,F4) ,designParams s_4_5_11 == Just (4,(11,5,1)) ,designParams (derivedDesign (derivedDesign s_4_5_11 0) 1) == Just (2,(9,3,1)) -- it is AG(2,F3) ] designAutTest = all (uncurry (==)) designAutTests designAutTests = [(SS.order $ designAuts $ pg2 f2, 168) -- this is L3(2), see Atlas ,(SS.order $ designAuts $ pg2 f3, 5616) -- this is L3(3) ,(SS.order $ designAuts $ pg2 f4, 120960) -- this is S3.L3(4) -- ,(SS.order $ designAuts $ pg2 f5, 372000) -- this is L3(5) ]HaskellForMaths-0.4.8/Math/Test/TestAll.hs0000644000000000000000000000440512514742102016455 0ustar0000000000000000module Math.Test.TestAll where import Math.Test.TGraph import Math.Test.TDesign import Math.Test.TPermutationGroup import Math.Test.TSubquotients import Math.Test.TFiniteGeometry import Math.Test.TNonCommutativeAlgebra import Math.Test.TField 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 import Math.Test.TCombinatorics.TIncidenceAlgebra import Math.Test.TCombinatorics.TMatroid import Math.Test.TCombinatorics.TPoset 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 ,Math.Test.TPermutationGroup.test ,Math.Test.TSubquotients.test ,Math.Test.TFiniteGeometry.test ,Math.Test.TField.test ,Math.Test.TRootSystem.test ] quickCheckAll = do -- quickCheck prop_NonCommRingNPoly quickCheckUtils quickCheck prop_GroupPerm quickCheckField quickCheckTensorProduct quickCheckGroupAlgebra quickCheckTensorAlgebra putStrLn "Testing Octonions..." quickCheck prop_AlgebraNonAssociative_Octonions quickCheck prop_InverseLoop_Octonions putStrLn "Testing miniquaternion geometries..." quickCheck prop_NearFieldF9 quickCheck prop_NearFieldJ9 quickCheckCombinatorialHopfAlgebra hunitAll = runTestTT $ TestList [ testlistGroupAlgebra, testlistCHA, testlistDigraph, testlistFiniteGeometry, testlistGraphAuts, testlistIncidenceAlgebra, testlistMatroid, testlistPoset, testlistPolynomial, testlistGroebnerBasis, testlistPrimeFactor, testlistQuadraticField ] HaskellForMaths-0.4.8/Math/Test/TField.hs0000644000000000000000000000032412514742102016250 0ustar0000000000000000module Math.Test.TField where import Math.Algebra.Field.Base import Math.Algebra.Field.Extension test = and [ (1/5 :: QSqrt3) * 5 == 1 -- regression test for defect , (1/4 :: F25) * 4 == 1 ]HaskellForMaths-0.4.8/Math/Test/TFiniteGeometry.hs0000644000000000000000000000323612514742102020164 0ustar0000000000000000module Math.Test.TFiniteGeometry where import Math.Combinatorics.FiniteGeometry import Math.Core.Field -- import Math.Algebra.Field.Base -- import Math.Algebra.Field.Extension import Math.Combinatorics.GraphAuts import Math.Algebra.Group.PermutationGroup test = and [numFlatsAG 2 2 0 == length (flatsAG 2 f2 0) ,numFlatsAG 2 2 1 == length (flatsAG 2 f2 1) ,numFlatsAG 2 2 2 == length (flatsAG 2 f2 2) ,numFlatsAG 3 2 1 == length (flatsAG 3 f2 1) ,numFlatsAG 3 3 1 == length (flatsAG 3 f3 1) ,numFlatsAG 3 4 1 == length (flatsAG 3 f4 1) ,numFlatsAG 3 4 2 == length (flatsAG 3 f4 2) ,numFlatsAG 3 4 3 == length (flatsAG 3 f4 3) ,numFlatsPG 2 2 0 == length (flatsPG 2 f2 0) ,numFlatsPG 2 2 1 == length (flatsPG 2 f2 1) ,numFlatsPG 2 2 2 == length (flatsPG 2 f2 2) ,numFlatsPG 3 2 1 == length (flatsPG 3 f2 1) ,numFlatsPG 3 3 1 == length (flatsPG 3 f3 1) ,numFlatsPG 3 4 1 == length (flatsPG 3 f4 1) ,numFlatsPG 3 4 2 == length (flatsPG 3 f4 2) ,numFlatsPG 3 4 3 == length (flatsPG 3 f4 3) ,(orderSGS $ incidenceAuts $ incidenceGraphAG 2 f2) == orderAff 2 2 -- * toInteger (degree f2) ,(orderSGS $ incidenceAuts $ incidenceGraphAG 2 f3) == orderAff 2 3 -- * toInteger (degree f3) ,(orderSGS $ incidenceAuts $ incidenceGraphAG 2 f4) == orderAff 2 4 * 2 -- * toInteger (degree f4) ,(orderSGS $ incidenceAuts $ incidenceGraphPG 2 f2) == orderPGL 3 2 -- * toInteger (degree f2) ,(orderSGS $ incidenceAuts $ incidenceGraphPG 2 f3) == orderPGL 3 3 -- * toInteger (degree f3) ,(orderSGS $ incidenceAuts $ incidenceGraphPG 2 f4) == orderPGL 3 4 * 2 -- * toInteger (degree f4) ] HaskellForMaths-0.4.8/Math/Test/TGraph.hs0000644000000000000000000001061712514742102016274 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. {-# LANGUAGE FlexibleInstances #-} module Math.Test.TGraph where import qualified Data.List as L import Math.Combinatorics.Graph as G import Math.Combinatorics.StronglyRegularGraph as SRG import Math.Combinatorics.Hypergraph as H import Math.Combinatorics.GraphAuts import Math.Algebra.Group.PermutationGroup as P -- not used import Math.Algebra.Group.SchreierSims as SS -- import Math.Algebra.Group.StringRewriting import Math.Algebra.Group.CayleyGraph -- Sources -- [AGT] - Godsil and Royle, Algebraic Graph Theory factorial n = product [1..n] choose n m | m <= n = product [m+1..n] `div` product [1..n-m] test = and [graphPropsTest, graphTransitivityTest, srgParamTest, graphAutTest] graphPropsTest = all (uncurry (==)) graphPropsTestsBool && all (uncurry (==)) graphPropsTestsInt graphPropsTestsBool = -- [(isConnected nullGraph, True)] ++ [(isConnected (c n), True) | n <- [3..8] ] ++ [(isConnected $ complement $ k n, False) | n <- [3..6] ] graphPropsTestsInt = [(diameter (c n), n `div` 2) | n <- [3..8] ] ++ [(girth (c n), n) | n <- [3..8] ] ++ [(girth (kb m n), 4) | m <- [2..4], n <- [2..4] ] ++ [(girth petersen, 5), (girth heawoodGraph, 6), (girth coxeterGraph, 7), (girth tutteCoxeterGraph, 8)] graphTransitivityTest = and graphTransitivityTests graphTransitivityTests = [(not . isVertexTransitive) (kb m n) | n <- [1..3], m <- [1..3], m /= n] ++ [isEdgeTransitive (kb m n) | n <- [1..3], m <- [1..3]] ++ map isArcTransitive [k 4, kb 3 3, q 3, dodecahedron, G.to1n heawoodGraph, G.to1n coxeterGraph, G.to1n tutteCoxeterGraph] ++ map is2ArcTransitive [c 7, q 3, G.to1n coxeterGraph] ++ map is3ArcTransitive [c 7, G.to1n petersen] ++ map (not . is3ArcTransitive) [q 3] ++ -- [isArcTransitive (j v k i) | v <- [3..5], k <- [1..v `div` 2], i <- [0..k] ] ++ -- [AGT] p60 -- !! j 4 2 0 is not connected, so this test now gives error. Not sure how it passed before [is2ArcTransitive (j (2*k+1) k 0) | k <- [1..2] ] ++ [isDistanceTransitive (j v k (k-1)) | v <- [3..5], k <- [1..v `div` 2] ] ++ -- [AGT] p75 [isDistanceTransitive (j (2*k+1) k 0) | k <- [1..2] ] ++ [p doyleGraph | p <- [isVertexTransitive, isEdgeTransitive, not . isArcTransitive, not . isDistanceTransitive] ] -- Most of the graphs we construct are highly symmetric, and turn out to be arc- and distance-transitive -- On the other hand, those which aren't arc- or distance-transitive are often trivially not so, -- by virtue of not even being vertex- or edge-transitive -- It is actually rather hard to find graphs which are vertex- and edge-transitive but not arc-transitive, but here is one -- Doyle, "A 27-vertex graph that is vertex-transitive and edge-transitive but not 1-transitive" -- http://en.wikipedia.org/wiki/Holt_graph doyleGraph = cayleyGraphS (['a','c'], [("aaaaaaaaa",""), ("ccccccccc",""), ("aaaaaa","ccc"), ("cccccc","aaa"), ("ccccccccac","aaaa"), ("aaaaaaaaca","cccc")]) -- so the vertices are the elts g, and the edges join g to ga, gc, ga^-1, gc^-1 srgParamTest = all (uncurry (==)) srgParamTests -- van Lint & Wilson 262 srgParamTests = [(srgParams $ SRG.t m, Just (m `choose` 2, 2*(m-2), m-2, 4) ) | m <- [4..7] ] ++ [(srgParams $ l2 m, Just (m^2, 2*(m-1), m-2, 2) ) | m <- [2..6] ] -- ++ [(srgParams $ paleyGraph fq, Just (q, (q-1) `div` 2, (q-5) `div` 4, (q-1) `div` 4) ) | (q,fq) <- [(5,f5),(9,f9),(13,f13),(17,f17)] ] ++ [(srgParams $ G.petersen, Just (10,3,0,1) ) ] ++ [(srgParams $ clebsch, Just (16,5,0,2) ) ] ++ [(srgParams $ hoffmanSingleton, Just (50,7,0,1) ) ] ++ [(srgParams $ higmanSimsGraph, Just (100,22,0,6) ) ] ++ [(srgParams $ sp (2*r), Just (2^(2*r)-1,2^(2*r-1),2^(2*r-2),2^(2*r-2))) | r <- [2..3] ] graphAutTest = all (uncurry (==)) graphAutTests graphAutTests = [(SS.order $ graphAuts $ c n, 2*n) | n <- [3..6] ] -- Aut(C n) = _D2 n ++ [(SS.order $ graphAuts $ k n, factorial n) | n <- [3..6] ] -- Aut(K n) = S n ++ [(SS.order $ graphAuts $ kb m n, factorial m * factorial n) | m <- [1..4], n <- [m+1..5] ] -- Aut(K m n) = S m * S n (m /= n) ++ [(SS.order $ graphAuts $ kb n n, 2 * (factorial n)^2 ) | n <- [1..5] ] -- Aut(K n n) = S n * S n * C2 (m == n) ++ [(SS.order $ graphAuts $ l2 n, 2 * (factorial n)^2 ) | n <- [2..5] ] -- Aut(L2 n) = S m * S m * C2 HaskellForMaths-0.4.8/Math/Test/TNonCommutativeAlgebra.hs0000644000000000000000000000270512514742102021460 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. {-# LANGUAGE FlexibleInstances #-} module Math.Test.TNonCommutativeAlgebra where import Math.Algebra.Field.Base import Math.Algebra.NonCommutative.NCPoly import Math.Algebra.NonCommutative.TensorAlgebra import Test.QuickCheck -- > quickCheck prop_NonCommRingNPoly -- Non-Commutative Ring (with 1) prop_NonCommRing (a,b,c) = a+(b+c) == (a+b)+c && -- addition is associative a+b == b+a && -- addition is commutative a+0 == a && -- additive identity a+(-a) == 0 && -- additive inverse a*(b*c) == (a*b)*c && -- multiplication is associative a*1 == a && 1*a == a && -- multiplicative identity a*(b+c) == a*b + a*c && -- left distributivity (a+b)*c == a*c + b*c -- left distributivity monomial is = product $ map (e_ . abs) is -- npoly :: [(Integer,[Int])] -> NPoly Q Basis npoly ais = sum [fromInteger a * monomial is | (a,is) <- ais] instance Arbitrary (NPoly Q Basis) where -- arbitrary = do ais <- arbitrary :: Gen [(Integer,[Int])] arbitrary = do ais <- sized $ \n -> resize (n `div` 2) arbitrary :: Gen [(Integer,[Int])] return (npoly ais) -- coarbitrary = undefined -- !! only required if we want to test functions over the type prop_NonCommRingNPoly (f,g,h) = prop_NonCommRing (f,g,h) where types = (f,g,h) :: (NPoly Q Basis, NPoly Q Basis, NPoly Q Basis) HaskellForMaths-0.4.8/Math/Test/TPermutationGroup.hs0000644000000000000000000001141412514742102020553 0ustar0000000000000000-- Copyright (c) David Amos, 2008. All rights reserved. {-# LANGUAGE FlexibleInstances #-} module Math.Test.TPermutationGroup where import qualified Data.List as L import Math.Core.Utils hiding (elts) import Math.Algebra.Group.PermutationGroup as P import Math.Algebra.Group.SchreierSims as SS import Math.Algebra.Group.RandomSchreierSims as RSS import Math.Algebra.Group.CayleyGraph import Math.Combinatorics.Graph import Math.Combinatorics.GraphAuts import Math.Projects.Rubik import Test.QuickCheck hiding (choose) factorials = scanl (*) 1 [1..] :: [Integer] -- factorial representation -- express n as a sum [ai * i! | i <- [1..]] facRep n = facRep' [] facs n where facs = reverse $ takeWhile (<= n) $ tail factorials -- [i!, ..., 2!, 1!] where n >= i! facRep' as (f:fs) n = let (q,r) = n `quotRem` f in facRep' (q : as) fs r facRep' as [] 0 = as -- Unrank a permutation in Sn, using lexicographic order -- eg for S3, we have -- r facRep r unrankSn 3 r -- 0 0.1!+0.2! [1,2,3] -- 1 1.1!+0.2! [1,3,2] -- 2 0.1!+1.2! [2,1,3] -- 3 1.1!+1.2! [2,3,1] -- 4 0.1!+2.2! [3,1,2] -- 5 1.1!+2.2! [3,2,1] -- So the image of 1 is determined by the most significant digit of the facRep, and then recurse on the remaining unrankSn n r | r < factorial (toInteger n) = let ds = reverse $ take (n-1) $ facRep r ++ repeat 0 in unrank' ds [1..n] where unrank' (d:ds) xs = let x = xs !! fromIntegral d in x : unrank' ds (L.delete x xs) unrank' [] [x] = [x] -- unrank permutations of S(N) (where N is the natural numbers from 1) -- doesn't use lexicographic order any more, but still a 1-1 mapping from N to permutations unrankSN r | r >= 0 = let ds = reverse (facRep r) in reverse (unrank' ds [1..length ds + 1]) where unrank' (d:ds) xs = let x = if d==0 then last xs else xs !! (fromIntegral d-1) in x : unrank' ds (L.delete x xs) unrank' [] [x] = [x] -- perm r = fromPairs $ zip [1..] $ unrankSN r instance Arbitrary (Permutation Int) where arbitrary = do r <- arbitrary -- :: Gen Integer return (fromList $ unrankSN $ abs r) -- return (perm (abs r)) -- return (perm (r^2)) -- to get some larger perms -- coarbitrary = undefined prop_Group (g,h,k) = g*(h*k)==(g*h)*k && -- associativity 1*g == g && g*1 == g && -- identity g*(g^-1) == 1 && (g^-1)*g == 1 -- inverse prop_GroupPerm (g,h,k) = prop_Group (g,h,k) where types = (g,h,k) :: (Permutation Int, Permutation Int, Permutation Int) prop_Transpositions g = g == (fromTranspositions . toTranspositions) g where types = g :: Permutation Int -- Could do more, like taking arbitrary lists of perms as generators of a group, -- and checking that the centre has the required property, etc factorial n = product [1..n] choose n m | m <= n = product [m+1..n] `div` product [1..n-m] test = and [sgsTest, ssTest, ccTest, rubikTest] sgsTest = all (uncurry (==)) sgsTests sgsTests = [(sgsOrder $ _A n, SS.order $ _A n) | n <- [4..7] ] ++ [(sgsOrder $ _S n, SS.order $ _S n) | n <- [4..7] ] ++ [(sgsOrder $ _D2 n, SS.order $ _D2 n) | n <- [4..10] ] ++ [let _G = toSn (_S 3 `dp` _S 3) in (sgsOrder _G, SS.order _G) ] ++ [let _G = toSn (_C 3 `wr` _S 3) in (sgsOrder _G, SS.order _G) ] ++ [let _G = toSn (_S 3 `wr` _C 3) in (sgsOrder _G, SS.order _G) ] where sgsOrder = orderTGS . tgsFromSgs . SS.sgs rubikTest = orderSGS (RSS.sgs rubikCube) == 43252003274489856000 ssTest = all (uncurry (==)) ssTests ssTests = [(L.sort $ P.elts $ _C n, L.sort $ SS.elts $ _C n) | n <- [2..6] ] ++ [(L.sort $ P.elts $ _D2 n, L.sort $ SS.elts $ _D2 n) | n <- [3..6] ] ++ [(L.sort $ P.elts $ _S n, L.sort $ SS.elts $ _S n) | n <- [3..5] ] ++ [(L.sort $ P.elts $ _A n, L.sort $ SS.elts $ _A n) | n <- [3..5] ] ++ [let _G = toSn (_S 3 `dp` _S 3) in (L.sort $ P.elts _G, L.sort $ SS.elts _G) ] ++ [let _G = toSn (_C 3 `wr` _S 3) in (L.sort $ P.elts _G, L.sort $ SS.elts _G) ] ++ [let _G = toSn (_S 3 `wr` _C 3) in (L.sort $ P.elts _G, L.sort $ SS.elts _G) ] ccTest = and ccTests ccTests = [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) ,(p [[0,1,3,2],[4,5,7,6]],6) ,(p [[0,1,3,7,6,4],[2,5]],8) ,(p [[0,3],[1,2],[4,7],[5,6]],3) ,(p [[0,3,6,5],[1,2,7,4]],6) ,(p [[0,3,6],[1,7,4]],8) ,(p [[0,3],[4,7]],6) ,(p [[0,7],[1,6],[2,5],[3,4]],1) ] ]HaskellForMaths-0.4.8/Math/Test/TRootSystem.hs0000644000000000000000000000127412514742102017362 0ustar0000000000000000 module Math.Test.TRootSystem where import Math.Projects.RootSystem import qualified Math.Algebra.Group.StringRewriting as SG import qualified Math.Algebra.Group.SchreierSims as SS import qualified Data.List as L test = testStringRewriting && testPermutations -- tests orders of the groups via presentations testStringRewriting = all (\(t,n) -> orderWeyl t n == L.genericLength (eltsCoxeter t n)) [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(F,4),(G,2)] -- tests orders of the groups via permutations testPermutations = all (\(t,n) -> orderWeyl t n == SS.order (weylPerms t n)) [(A,3),(A,4),(A,5),(B,3),(B,4),(B,5),(C,3),(C,4),(C,5),(D,4),(D,5),(E,6),(F,4),(G,2)]HaskellForMaths-0.4.8/Math/Test/TSubquotients.hs0000644000000000000000000000462612514742102017743 0ustar0000000000000000-- Copyright (c) David Amos, 2009. All rights reserved. module Math.Test.TSubquotients where import Math.Algebra.Group.PermutationGroup hiding (ptStab, normalClosure) -- import Math.Algebra.Group.SchreierSims (cosetRepsGx) -- import Math.Algebra.Group.RandomSchreierSims import Math.Algebra.Group.Subquotients import qualified Math.Algebra.Group.PermutationGroup as P -- for testing test = and [testPtStab, testTransitiveConstituentHomomorphism, testBlockSystems, testBlockHomomorphism, testNormalClosure, testCentralizerSymTrans] -- TESTS testPtStab = let gs = [p [[1..5],[6,7]], p [[1,2],[6..10]] ] -- S 5 * S 5 gs16 = ptStab gs [1,6] in orderSGS gs16 == 24*24 && orbitP gs16 1 == [1] && orbitP gs16 6 == [6] testTransitiveConstituentHomomorphism = let gs1 = [p [[1..5],[6,7]], p [[1,2],[6..10]] ] -- S 5 * S 5 (ker1,im1) = transitiveConstituentHomomorphism gs1 [1..5] gs2 = [p [[1,2,3],[4,5,6]], p [[1,2],[4,5]]] -- note that the two halves don't move independently (ker2,im2) = transitiveConstituentHomomorphism gs2 [1,2,3] gs3 = [p [[1,2],[4,5]], p [[1,2,3]], p [[4,5,6]] ] -- so we can achieve odd permutations in each half, but we can't achieve an odd in one without achieving an odd in the other -- hence the order of the group is only half the order of the left image * the order of the right image (ker3,im3) = transitiveConstituentHomomorphism gs3 [1,2,3] in orderSGS ker1 == 120 && orderSGS im1 == 120 && null ker2 && orderSGS im2 == 6 && orderSGS im3 == 6 && orderSGS ker3 == 3 testBlockSystems = blockSystems [p [[1..3]], p [[4..6]], p [[1,4],[2,5],[3,6]]] == [ [[1,2,3],[4,5,6]] ] && blockSystems (_D 10) == [] && blockSystems (_D 12) == [ [[1,3,5],[2,4,6]], [[1,4],[2,5],[3,6]] ] testBlockHomomorphism = let (ker14,im14) = blockHomomorphism (_D 12) [[1,4],[2,5],[3,6]] (ker135,im135) = blockHomomorphism (_D 12) [[1,3,5],[2,4,6]] in (orderSGS ker14, orderSGS im14) == (2,6) && (orderSGS ker135, orderSGS im135) == (6,2) -- !! Need to improve this test testNormalClosure = let gs = [p [[1,4]]] hs = [p [[1,2,3]]] in elts (P.normalClosure gs hs) == elts (normalClosure gs hs) -- == _A 4 testCentralizerSymTrans = let gs = [ p [[1..5]] ] hs = [ p [[1,2],[3,4]], p [[1,3],[2,4]] ] in centralizerSymTrans gs == gs && centralizerSymTrans hs == hsHaskellForMaths-0.4.8/Math/Test/TAlgebras/0000755000000000000000000000000012514742102016412 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Test/TAlgebras/TGroupAlgebra.hs0000644000000000000000000000503412514742102021446 0ustar0000000000000000-- Copyright (c) 2010, David Amos. All rights reserved. {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} module Math.Test.TAlgebras.TGroupAlgebra where import Test.HUnit import Test.QuickCheck import Math.Algebra.Group.PermutationGroup hiding (p) import Math.Test.TPermutationGroup -- for instance Arbitrary (Permutation Int) import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures import Math.Algebras.GroupAlgebra import Math.Core.Field import Math.Core.Utils 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) :: (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) :: (Q, Q, Q, Q, GroupAlgebra Q, GroupAlgebra Q, GroupAlgebra Q, GroupAlgebra Q) prop_Coalgebra_GroupAlgebra x = prop_Coalgebra x 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) :: (Q, Q, GroupAlgebra Q, GroupAlgebra Q) prop_Bialgebra_GroupAlgebra (k,x,y) = prop_Bialgebra (k,x,y) where types = (k,x,y) :: (Q, GroupAlgebra Q, GroupAlgebra Q) prop_HopfAlgebra_GroupAlgebra x = prop_HopfAlgebra x where types = x :: GroupAlgebra Q quickCheckGroupAlgebra = do 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 [ testlistLeftInverse, testlistRightInverse ] groupAlgebraElts = [ 1+p[[1,2,3]], 1+p[[1,2,3]]+p[[1,2],[3,4]], 1+2*p[[1,2,3]]+p[[1,2],[3,4]] ] testcaseLeftInverse x = TestCase $ assertEqual ("inverse " ++ show x) 1 (x^-1 * x) testlistLeftInverse = TestList $ map testcaseLeftInverse groupAlgebraElts testcaseRightInverse x = TestCase $ assertEqual ("inverse " ++ show x) 1 (x * x^-1) testlistRightInverse = TestList $ map testcaseRightInverse groupAlgebraElts HaskellForMaths-0.4.8/Math/Test/TAlgebras/TMatrix.hs0000644000000000000000000000155112514742102020340 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Math.Test.TAlgebras.TMatrix where import Test.QuickCheck import Math.Algebra.Field.Base import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Matrix import Math.Test.TAlgebras.TVectorSpace import Math.Test.TAlgebras.TStructures import Math.Algebras.Structures -- not really needed instance Arbitrary Mat2 where arbitrary = elements [E2 1 1, E2 1 2, E2 2 1, E2 2 2] instance Arbitrary Mat2' where arbitrary = elements [E2' 1 1, E2' 1 2, E2' 2 1, E2' 2 2] prop_Algebra_Mat2 (k,x,y,z) = prop_Algebra (k,x,y,z) where types = (k,x,y,z) :: (Q, Vect Q Mat2, Vect Q Mat2, Vect Q Mat2) prop_Coalgebra_Mat2' x = prop_Coalgebra x where types = x :: Vect Q Mat2' HaskellForMaths-0.4.8/Math/Test/TAlgebras/TOctonions.hs0000644000000000000000000000245312514742102021051 0ustar0000000000000000-- Copyright (c) 2011-2015, David Amos. All rights reserved. module Math.Test.TAlgebras.TOctonions where import Prelude hiding ( (*>) ) import Test.QuickCheck import Math.Core.Field -- import Math.Algebra.Field.Base import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Quaternions import Math.Algebras.Octonions import Math.Test.TAlgebras.TVectorSpace import Math.Test.TAlgebras.TStructures import Math.Algebras.Structures -- not really needed instance Arbitrary OBasis where arbitrary = elements $ map O [-1..6] -- TVectorSpace defines an Arbitrary instance for Vect k b, given Arbitrary instances for k and b -- same as prop_Algebra, but missing associativity axiom prop_AlgebraNonAssociative (k,x) = unitOutL (k' `te` x) == (mult . (unit' `tf` id)) (k' `te` x) && -- left unit unitOutR (x `te` k') == (mult . (id `tf` unit')) (x `te` k') -- right unit where k' = k *> return () prop_AlgebraNonAssociative_Octonions (k,x) = prop_AlgebraNonAssociative (k,x) where types = (k,x) :: (Q, Octonion Q) prop_InverseLoop (x,y) = x*1 == x && x == 1*x && (x == 0 || (x^-1 * (x*y) == y && y == (y*x) * x^-1 && (x^-1)^-1 == x) ) prop_InverseLoop_Octonions (x,y) = prop_InverseLoop (x,y) where types = (x,y) :: (Octonion Q, Octonion Q) HaskellForMaths-0.4.8/Math/Test/TAlgebras/TQuaternions.hs0000644000000000000000000000436312514742102021410 0ustar0000000000000000-- Copyright (c) 2010, David Amos. All rights reserved. {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Math.Test.TAlgebras.TQuaternions where import Test.QuickCheck import Math.Algebra.Field.Base import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Quaternions import Math.Test.TAlgebras.TVectorSpace import Math.Test.TAlgebras.TStructures import Math.Algebras.Structures -- not really needed instance Arbitrary HBasis where arbitrary = elements [One,I,J,K] -- TVectorSpace defines an Arbitrary instance for Vect k b, given Arbitrary instances for k and b {- instance Arbitrary (Quaternion Integer) where arbitrary = do ts <- arbitrary :: Gen [(HBasis, Integer)] return $ nf $ V ts -} prop_Algebra_Quaternion (k,x,y,z) = prop_Algebra (k,x,y,z) where types = (k,x,y,z) :: (Q, Quaternion Q, Quaternion Q, Quaternion Q) -- (Integer, Quaternion Integer, Quaternion Integer, Quaternion Integer) prop_Coalgebra_DualQuaternion x = prop_Coalgebra x where types = x :: Vect Q (Dual HBasis) conjH = linear conjH' where conjH' One = 1 conjH' I = -i conjH' J = -j conjH' K = -k normH x = x * conjH x -- The following property fails: conjugation is not an algebra morphism -- It fails to commute with mult: conjH (i*j) /= conjH i * conjH j nonprop_AlgebraMorphism_ConjH = prop_AlgebraMorphism conjH -- The following property also fails: norm is not an algebra morphism -- It fails to commute with unit: conjH (unit (-1)) /= unit (-1) nonprop_AlgebraMorphism_NormH = prop_AlgebraMorphism normH {- prop_Coalgebra_Quaternion x = prop_Coalgebra x where types = x :: Quaternion Integer -- Fails - the algebra and coalgebra structures I've given are not compatible prop_Bialgebra_Quaternion (k,x,y) = prop_Bialgebra (k,x,y) where types = (k,x,y) :: (Integer, Quaternion Integer, Quaternion Integer) -} {- prop_FrobeniusRelation_Quaternion (x,y) = prop_FrobeniusRelation (x,y) where types = (x,y) :: (Quaternion Integer, Quaternion Integer) -- !! fails, because the counit we have given is not a Frobenius form -} instance Algebra2 Integer (Quaternion Integer) where unit2 k = unit k mult2 xy = mult xy HaskellForMaths-0.4.8/Math/Test/TAlgebras/TStructures.hs0000644000000000000000000002051612514742102021261 0ustar0000000000000000-- Copyright (c) 2010, David Amos. All rights reserved. {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TypeFamilies, RankNTypes, MultiParamTypeClasses #-} module Math.Test.TAlgebras.TStructures where import Prelude hiding ( (*>) ) -- import Test.QuickCheck -- don't actually need, as we don't define any Arbitrary instances here import Control.Arrow ( (>>>) ) -- actually you can get this from Category? import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Algebras.Structures -- what we're testing prop_Linear f (k,l,x,y) = f (add (smultL k x) (smultL l y)) == add (smultL k (f x)) (smultL l (f y)) -- now use this to show algebra and coalgebra ops are linear -- in this version we supply z of the intended return type of f, -- so that we can make sure we select the correct instance for f polymorphic in return type prop_Linear' f (k,l,x,y,z) = f (add (smultL k x) (smultL l y)) `add` z == add (smultL k (f x)) (smultL l (f y)) `add` z -- prop_Bilinear could be defined in terms of prop_Linear over tensor product -- if we had a way to convert a bilinear function to a tensor function prop_Algebra_Linear :: (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) && prop_Linear' unit' (k,l,wrap m, wrap n, x) && prop_Linear mult (k,l, x `te` y, z `te` w) where wrap = (\c -> V [((),c)]) :: k -> Trivial k prop_Coalgebra_Linear (k,l,x,y) = prop_Linear counit' (k,l,x,y) && prop_Linear comult (k,l,x,y) -- ALGEBRAS prop_Algebra (k,x,y,z) = (mult . (id `tf` mult)) (x `te` (y `te` z)) == (mult . (mult `tf` id)) ((x `te` y) `te` z) && -- associativity unitOutL (k' `te` x) == (mult . (unit' `tf` id)) (k' `te` x) && -- left unit unitOutR (x `te` k') == (mult . (id `tf` unit')) (x `te` k') -- right unit -- mult (x `te` mult (y `te` z)) == mult (mult (x `te` y) `te` z) && -- associativity -- smultL k x == mult (unit k `te` x) && -- left unit -- smultR x k == mult (x `te` unit k) -- && -- right unit where k' = k *> return () -- additionally, unit and mult must be linear prop_Commutative (x,y) = let xy = x `te` y in (mult . twist) xy == mult xy prop_Algebra_DSum (k,(a1,a2,a3),(b1,b2,b3)) = prop_Algebra (k, a1 `dsume` b1, a2 `dsume` b2, a3 `dsume` b3) prop_Algebra_TProd (k,(a1,a2,a3),(b1,b2,b3)) = prop_Algebra (k, a1 `te` b1, a2 `te` b2, a3 `te` b3) -- COALGEBRAS prop_Coalgebra x = ((comult `tf` id) . comult) x == (assocL . (id `tf` comult) . comult) x && -- coassociativity ((counit' `tf` id) . comult) x == unitInL x && -- left counit ((id `tf` counit') . comult) x == unitInR x -- right counit -- additionally, counit and comult must be linear prop_Cocommutative x = (twist . comult) x == comult x -- MORPHISMS prop_AlgebraMorphism f (k,x,y) = (f . unit) k == unit k && (f . mult) (x `te` y) == (mult . (f `tf` f)) (x `te` y) -- in this version we supply z of the intended return type of f, -- so that we can make sure we select the correct instance for f polymorphic in return type prop_AlgebraMorphism' f (k,l,x,y,z) = (f . unit) k + z == unit k + z && (f . mult) (x `te` y) == (mult . (f `tf` f)) (x `te` y) 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 {- prop_Bialgebra1 (x,y) = let xy = x `te` y in (comult . mult) xy == ( (mult `tf` mult) . assocL . (id `tf` assocR) . (id `tf` (twist `tf` id)) . (id `tf` assocL) . assocR . (comult `tf` comult) ) xy -} prop_Bialgebra1 (x,y) = let xy = x `te` y in (comult . mult) xy == ( (mult `tf` mult) . fmap (\((a,a'),(b,b')) -> ((a,b),(a',b')) ) . (comult `tf` comult) ) xy prop_Bialgebra2 (k,xy) = (comult . unit') k' + xy == ((unit' `tf` unit') . iso) k' + xy where iso = fmap (\ () -> ((),()) ) -- the isomorphism k ~= k tensor k k' = wrap k -- inject into the trivial algebra -- the +xy is just to force the other expression to be of the right type prop_Bialgebra3 (x,y) = (counit' . mult) xy == (iso . (counit' `tf` counit')) xy where xy = x `te` y iso = fmap ( \((),()) -> ()) prop_Bialgebra4 (k,x) = id k == (counit . (\a -> a+x-x) . unit) k -- so we are using the x just to force the intermediate value to be of the right type prop_Bialgebra (k,x,y) = prop_Bialgebra1 (x,y) && prop_Bialgebra2 (k,x `te` y) && prop_Bialgebra3 (x,y) && prop_Bialgebra4 (k,x) -- Claim that this is equivalent to the above, but much shorter because it piggy-backs on -- the coalgebra instance for tensor product, and the algebra morphism definition prop_BialgebraA (k,x,y) = prop_AlgebraMorphism (wrap . counit) (k,x,y) && prop_AlgebraMorphism comult (k,x,y) -- Need a way to force the result type of (unit . unwrap) to be the same as the type of x and y -- prop_BialgebraC (k,x,y) = prop_CoalgebraMorphism (unit . unwrap) (wrap k) && prop_CoalgebraMorphism mult (x `te` y) prop_HopfAlgebra x = (unit . counit) x == (mult . (antipode `tf` id) . comult) x && (unit . counit) x == (mult . (id `tf` antipode) . comult) x -- Street p87 -- we also require that f be invertible prop_YangBaxter f (x,y,z) = ( (f `tf` id) >>> assocR >>> (id `tf` f) >>> assocL >>> (f `tf` id) >>> assocR ) xyz == ( assocR >>> (id `tf` f) >>> assocL >>> (f `tf` id) >>> assocR >>> (id `tf` f) ) xyz where xyz = ( (x `te` y) `te` z) -- MODULES AND COMODULES prop_Module_Linear (k,l,x,y) = prop_Linear action (k,l,x,y) prop_Module_Assoc (r,s,m) = (action . (mult `tf` id)) ((r `te` s) `te` m) == (action . (id `tf` action)) (r `te` (s `te` m)) {- prop_Module_Unit (k,m) = (action . (unit' `tf` id)) k' == -} -- PAIRINGS -- http://mathoverflow.net/questions/20666/is-a-bialgebra-pairing-of-hopf-algebras-automatically-a-hopf-pairing -- Hazewinkel p155 -- Majid, Quantum Groups Primer, p12 prop_BialgebraPairing :: (Eq k, Num k, Ord a, Ord b, Show a, Show b, Bialgebra k a, Bialgebra k b, HasPairing k a b) => (Vect k a, Vect k a, Vect k b, Vect k b) -> Bool prop_BialgebraPairing (u,v,x,y) = pairing' (mult (u `te` v)) x == pairing' (u `te` v) (comult x) && -- mult in A is adjoint to comult in B pairing' (comult u) (x `te` y) == pairing' u (mult (x `te` y)) && -- comult in A is adjoint to mult in B pairing' (1+u-u) x == counit x && -- unit (ie 1) is adjoint to counit pairing' u (1+x-x) == counit u -- The +x-x is to coerce the type of unit k -- The same could probably be achieved with ScopedTypeVariables prop_HopfPairing (u,v,x,y) = prop_BialgebraPairing (u,v,x,y) && pairing' (antipode u) x == pairing' u (antipode x) -- ALTERNATIVE DEFINITION OF ALGEBRA type TensorProd k u v = (u ~ Vect k a, v ~ Vect k b) => Vect k (Tensor a b) class Algebra2 k a where unit2 :: k -> a mult2 :: TensorProd k a a -> a -- FROBENIUS ALGEBRAS frobeniusLeft1 = (id `tf` mult) . assocR . (comult `tf` id) frobeniusLeft2 x = nf $ x >>= fl where fl (i,j) = do (k,l) <- comultM i m <- idM j p <- idM k q <- multM (l,m) return (p,q) frobeniusMiddle1 = comult . mult frobeniusMiddle2 x = nf $ x >>= fm where fm (i,j) = do k <- multM (i,j) (l,m) <- comultM k return (l,m) prop_FrobeniusRelation (x,y) = let xy = x `te` y in frobeniusLeft1 xy == frobeniusMiddle1 xy -- (inject == return) multM = mult . return -- inject comultM = comult . return -- inject idM = id . return -- can we do the same with unit, counit? -- unit takes k as input, so isn't in the monad -- counit gives k as output - what would we do with it -- so perhaps we have to use unit' and counit' HaskellForMaths-0.4.8/Math/Test/TAlgebras/TTensorProduct.hs0000644000000000000000000000720312514742102021707 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE EmptyDataDecls, ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies, RankNTypes #-} module Math.Test.TAlgebras.TTensorProduct where import Prelude hiding ( (*>) ) import Test.QuickCheck import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Core.Field -- import Math.Algebra.Field.Base import Math.Test.TAlgebras.TVectorSpace import Prelude as P import Control.Category as C import Control.Arrow quickCheckTensorProduct = do putStrLn "Testing that tf is linear, and tensor product is a functor" quickCheck prop_Linear_tf quickCheck prop_TensorFunctor type DirectSum k u v = (u ~ Vect k a, v ~ Vect k b) => Vect k (DSum a b) type TensorProd k u v = (u ~ Vect k a, v ~ Vect k b) => Vect k (Tensor a b) type En = Vect Q EBasis {- -- But then you need to make sure that you run GHCi with -XTypeFamilies, otherwise: > e1 `te` e2 :: TensorProd Q En En :1:0: Illegal equational constraint En ~ Vect Q a (Use -XTypeFamilies to permit this) In an expression type signature: TensorProd Q En En In the expression: e1 `te` e2 :: TensorProd Q En En In the definition of `it': it = e1 `te` e2 :: TensorProd Q En En -} -- check that tf is linear prop_Linear_tf ((f,g),k,(a1,a2,b1,b2)) = prop_Linear (linfun f `tf` linfun g) (k, a1 `te` b1, a2 `te` b2) where types = (f,g,k,a1,a2,b1,b2) :: (LinFun Q ABasis SBasis, LinFun Q BBasis TBasis, Q, Vect Q ABasis, Vect Q ABasis, Vect Q BBasis, Vect Q BBasis) -- check that tensor product is a functor, as required prop_TensorFunctor ((f1,f2,g1,g2),(a,b)) = (P.id `tf` P.id) (a `te` b) == P.id (a `te` b) && ((f' P.. f) `tf` (g' P.. g)) (a `te` b) == ((f' `tf` g') P.. (f `tf` g)) (a `te` b) where f = linfun f1 f' = linfun f2 g = linfun g1 g' = linfun g2 types = (f1,f2,g1,g2,a,b) :: (LinFun Q ABasis ABasis, LinFun Q ABasis ABasis, LinFun Q BBasis BBasis, LinFun Q BBasis BBasis, Vect Q ABasis, Vect Q BBasis) -- Now test eg -- > quickCheck (\x -> (distrL . undistrL) x == id x) -- but need to make x be of interesting type (not just () ) data Zero -- a type with no inhabitants -- so the associated free vector space is the zero space -- instance Eq Zero where {} -- instance Ord Zero where {} instance Show Zero where {} -- > zero :: Vect Q Zero -- 0 -- ARROW INSTANCE -- This isn't currently used anywhere else -- It's intended to illustrate the point that tensor product is like doing things in parallel newtype Linear k a b = Linear (Vect k a -> Vect k b) instance Category (Linear k) where id = Linear P.id (Linear f) . (Linear g) = Linear (f P.. g) 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 Linear f *** Linear g = Linear (f `tf2` g) where tf2 f g (V ts) = V $ concat [let V us = x *> te (f $ return a) (g $ return b) in us | ((a,b), x) <- ts] -- can't use tf, as it uses add, which assumes Ord instance Linear f &&& Linear g = (Linear f *** Linear g) C.. Linear (\a -> a `te` a) {- -- The following are morally correct, but don't work because they require Ord instance instance Num k => ArrowChoice (Linear k) where left (Linear f) = Linear (f `dsume` id) right (Linear f) = Linear (id `dsume` f) Linear f +++ Linear g = Linear (f `dsumf` g) Linear f ||| Linear g = Linear (f `coprodf` g) -} HaskellForMaths-0.4.8/Math/Test/TAlgebras/TVectorSpace.hs0000644000000000000000000001535012514742102021314 0ustar0000000000000000-- Copyright (c) 2010-2015, David Amos. All rights reserved. {-# LANGUAGE FlexibleInstances, NoMonomorphismRestriction, ScopedTypeVariables, GeneralizedNewtypeDeriving #-} module Math.Test.TAlgebras.TVectorSpace where import Prelude hiding ( (*>) ) import Test.QuickCheck import Math.Algebras.VectorSpace import Math.Algebras.TensorProduct import Math.Core.Field -- import Math.Algebra.Field.Base -- import Control.Monad -- MonadPlus prop_AddGrp (x,y,z) = x <+> (y <+> z) == (x <+> y) <+> z && -- associativity x <+> y == y <+> x && -- commutativity x <+> zerov == x && -- identity x <+> negatev x == zerov -- inverse prop_VecSp (a,b,x,y,z) = prop_AddGrp (x,y,z) && a *> (x <+> y) == a *> x <+> a *> y && -- distributivity through vectors (a+b) *> x == a *> x <+> b *> x && -- distributivity through scalars (a*b) *> x == a *> (b *> x) && -- associativity 1 *> x == x -- unit instance Arbitrary EBasis where arbitrary = do n <- arbitrary :: Gen Int return (E $ abs n) instance Arbitrary b => Arbitrary (Dual b) where arbitrary = fmap Dual arbitrary -- arbitrary = do b <- arbitrary :: Gen b -- ScopedTypeVariables -- return (Dual b) instance Arbitrary Q where arbitrary = do n <- arbitrary :: Gen Integer d <- arbitrary :: Gen Integer return (if d == 0 then fromInteger n else fromInteger n / fromInteger d) 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 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) prop_Linear f (a,x,y) = f (x <+> y) == f x <+> f y && f zerov == zerov && f (negatev x) == negatev (f x) && f (a *> x) == a *> f x prop_LinearQn f (a,x,y) = prop_Linear f (a,x,y) where types = (a,x,y) :: (Q, Vect Q EBasis, Vect Q EBasis) newtype FBasis = F Int deriving (Eq,Ord,Arbitrary) instance Show FBasis where show (F i) = "f" ++ show i f i = return (F i) :: Vect Q FBasis f1 = f 1 f2 = f 2 f3 = f 3 -- DIRECT SUM {- instance Num k => Alternative (Vect k) where (<|>) = mplus empty = mzero instance Num k => MonadPlus (Vect k) where mzero = zerov mplus (V xs) (V ys) = V (xs++ys) -- need to call nf afterwards -} -- (Alternative versions of prodf and coprodf) f .*. g = linear fg' where fg' b = fmap Left (f (return b)) <+> fmap Right (g (return b)) f .+. g = linear fg' where fg' (Left a) = f (return a) fg' (Right b) = g (return b) type LinFun k a b = [(a, Vect k b)] -- a way of representing a linear function as data 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 Nothing -> zerov prop_Product (f',g',x) = f x == (p1 . fg) x && g x == (p2 . fg) x where f = linfun f' g = linfun g' fg = prodf f g prop_Coproduct (f',g',a,b) = f a == (fg . i1) a && g b == (fg . i2) b where f = linfun f' g = linfun g' fg = coprodf f g prop_dsumf (f',g',a,b) = f a == (p1 . fg . i1) a && g b == (p2 . fg . i2) b where f = linfun f' g = linfun g' fg = dsumf f g newtype ABasis = A Int deriving (Eq,Ord,Show,Arbitrary) -- GeneralizedNewtypeDeriving newtype BBasis = B Int deriving (Eq,Ord,Show,Arbitrary) newtype SBasis = S Int deriving (Eq,Ord,Show,Arbitrary) newtype TBasis = T Int deriving (Eq,Ord,Show,Arbitrary) prop_ProductQn (f,g,x) = prop_Product (f,g,x) where types = (f,g,x) :: (LinFun Q SBasis ABasis, LinFun Q SBasis BBasis, Vect Q SBasis) prop_CoproductQn (f,g,a,b) = prop_Coproduct (f,g,a,b) where types = (f,g,a,b) :: (LinFun Q ABasis TBasis, LinFun Q BBasis TBasis, Vect Q ABasis, Vect Q BBasis) prop_dsumfQn (f,g,a,b) = prop_dsumf (f,g,a,b) where types = (f,g,a,b) :: (LinFun Q ABasis SBasis, LinFun Q BBasis TBasis, Vect Q ABasis, Vect Q BBasis) -- TENSOR PRODUCT dot0 uv = sum [ if a == b then x*y else 0 | (a,x) <- u, (b,y) <- v] where V u = p1 uv V v = p2 uv dot1 uv = nf $ V [( (), if a == b then x*y else 0) | (a,x) <- u, (b,y) <- v] where V u = p1 uv V v = p2 uv polymult1 uv = nf $ V [(E (i+j) , x*y) | (E i,x) <- u, (E j,y) <- v] where V u = p1 uv V v = p2 uv {- tensor1 :: (Num k, Ord a, Ord b) => (Vect k a, Vect k b) -> Vect k (a, b) tensor1 (V axs, V bys) = nf $ V [((a,b),x*y) | (a,x) <- axs, (b,y) <- bys] bilinear1 :: (Num k, Ord a, Ord b, Ord c) => ((a, b) -> Vect k c) -> (Vect k a, Vect k b) -> Vect k c bilinear1 f = linear f . tensor1 prop_Bilinear1 f (a,u1,u2,v1,v2) = prop_Linear (\v -> f (u1,v)) (a,v1,v2) && prop_Linear (\u -> f (u,v1)) (a,u1,u2) prop_BilinearQn1 f (a,u1,u2,v1,v2) = prop_Bilinear1 f (a,u1,u2,v1,v2) where types = (a,u1,u2,v1,v2) :: (Q, Vect Q EBasis, Vect Q EBasis, Vect Q EBasis, Vect Q EBasis) -} 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 :: (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 dot = bilinear (\(a,b) -> if a == b then return () else zerov) polymult = bilinear (\(E i, E j) -> return (E (i+j))) 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) && prop_Linear (\u -> f (u `dsume` v1)) (a,u1,u2) prop_BilinearQn f (a,u1,u2,v1,v2) = prop_Bilinear f (a,u1,u2,v1,v2) where types = (a,u1,u2,v1,v2) :: (Q, Vect Q EBasis, Vect Q EBasis, Vect Q EBasis, Vect Q EBasis) {- > quickCheck (prop_BilinearQn dot1) +++ OK, passed 100 tests. > quickCheck (prop_BilinearQn polymult1) +++ OK, passed 100 tests. *Math.Test.TAlgebras.TVectorSpace> quickCheck (prop_BilinearQn tensor) +++ OK, passed 100 tests. > quickCheck (\x -> dot1 x == dot x) +++ OK, passed 100 tests. > quickCheck (\x -> polymult1 x == polymult x) +++ OK, passed 100 tests. > quickCheck (prop_BilinearQn id) *** Failed! Falsifiable (after 2 tests): (1,0,0,e1,0) -- fails basically because (0 <+> 0) `dsume` e0 /= (0 `dsume` e0) <+> (0 `dsume` e0) > (zero <+> zero) `dsume` e1 Right e1 > (zero `dsume` e1) <+> (zero `dsume` e1) 2Right e1 -} HaskellForMaths-0.4.8/Math/Test/TCombinatorics/0000755000000000000000000000000012514742102017466 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Test/TCombinatorics/TCombinatorialHopfAlgebra.hs0000644000000000000000000003577712514742102025047 0ustar0000000000000000-- 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.Combinatorics.Poset (integerPartitions) import Math.Algebras.VectorSpace hiding (E) import Math.Algebras.TensorProduct -- for ghci 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 quickCheckSymM quickCheckSymE quickCheckSymH quickCheckNSym 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) quickCheck (prop_Commutative :: (Vect Q (Shuffle Int), 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) quickCheckDualSSymF = do putStrLn "Checking Dual(SSymF)" -- quickCheck (prop_Algebra :: (Q, Vect Q (Dual SSymF), Vect Q (Dual SSymF), Vect Q (Dual SSymF)) -> Bool) -- too slow quickCheck (prop_Coalgebra :: Vect Q (Dual SSymF) -> Bool) quickCheck (prop_Bialgebra :: (Q, Vect Q (Dual SSymF), Vect Q (Dual SSymF)) -> Bool) quickCheck (prop_HopfAlgebra :: Vect Q (Dual SSymF) -> Bool) instance Arbitrary (YSymF ()) where arbitrary = fmap YSymF (elements (concatMap trees [0..3])) -- 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 (elements (concatMap trees [0..3])) -- 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) quickCheck (prop_Commutative :: (Vect Q QSymM, 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) quickCheck (prop_Commutative :: (Vect Q QSymF, Vect Q QSymF) -> Bool) instance Arbitrary SymM where arbitrary = do xs <- elements (concatMap integerPartitions [0..4]) return (SymM xs) quickCheckSymM = do putStrLn "Checking SymM" quickCheck (prop_Algebra :: (Q, Vect Q SymM, Vect Q SymM, Vect Q SymM) -> Bool) quickCheck (prop_Coalgebra :: Vect Q SymM -> Bool) quickCheck (prop_Bialgebra :: (Q, Vect Q SymM, Vect Q SymM) -> Bool) quickCheck (prop_HopfAlgebra :: Vect Q SymM -> Bool) quickCheck (prop_Commutative :: (Vect Q SymM, Vect Q SymM) -> Bool) quickCheck (prop_Cocommutative :: Vect Q SymM -> Bool) instance Arbitrary SymE where arbitrary = do xs <- elements (concatMap integerPartitions [0..4]) return (SymE xs) quickCheckSymE = do putStrLn "Checking SymE" quickCheck (prop_Algebra :: (Q, Vect Q SymE, Vect Q SymE, Vect Q SymE) -> Bool) quickCheck (prop_Coalgebra :: Vect Q SymE -> Bool) quickCheck (prop_Bialgebra :: (Q, Vect Q SymE, Vect Q SymE) -> Bool) -- quickCheck (prop_HopfAlgebra :: Vect Q SymE -> Bool) quickCheck (prop_Commutative :: (Vect Q SymE, Vect Q SymE) -> Bool) quickCheck (prop_Cocommutative :: Vect Q SymE -> Bool) instance Arbitrary SymH where arbitrary = do xs <- elements (concatMap integerPartitions [0..4]) return (SymH xs) quickCheckSymH = do putStrLn "Checking SymH" quickCheck (prop_Algebra :: (Q, Vect Q SymH, Vect Q SymH, Vect Q SymH) -> Bool) quickCheck (prop_Coalgebra :: Vect Q SymH -> Bool) quickCheck (prop_Bialgebra :: (Q, Vect Q SymH, Vect Q SymH) -> Bool) -- quickCheck (prop_HopfAlgebra :: (Vect Q SymH) -> Bool) quickCheck (prop_Commutative :: (Vect Q SymH, Vect Q SymH) -> Bool) quickCheck (prop_Cocommutative :: Vect Q SymH -> Bool) -- The basis isn't indexed by compositions, but using compositions is an easy way to ensure -- that we have positive ints and that they're bounded (to keep the comult manageable) instance Arbitrary NSym where arbitrary = do xs <- elements compositionsTo4 return (NSym xs) where compositionsTo4 = concatMap compositions [0..4] quickCheckNSym = do putStrLn "Checking NSym" quickCheck (prop_Algebra :: (Q, Vect Q NSym, Vect Q NSym, Vect Q NSym) -> Bool) quickCheck (prop_Coalgebra :: Vect Q NSym -> Bool) quickCheck (prop_Bialgebra :: (Q, Vect Q NSym, Vect Q NSym) -> Bool) quickCheck (prop_HopfAlgebra :: Vect Q NSym -> Bool) quickCheckCHAIsomorphism = do putStrLn "Checking CHA isomorphism (change of basis)" putStrLn "Checking bijections" quickCheck (prop_Id (ssymMtoF . ssymFtoM) :: Vect Q SSymF -> Bool) quickCheck (prop_Id (ssymFtoM . ssymMtoF) :: Vect Q SSymM -> Bool) quickCheck (prop_Id (ysymMtoF . ysymFtoM) :: Vect Q (YSymF ()) -> Bool) quickCheck (prop_Id (ysymFtoM . ysymMtoF) :: Vect Q YSymM -> Bool) quickCheck (prop_Id (qsymMtoF . qsymFtoM) :: Vect Q QSymF -> Bool) quickCheck (prop_Id (qsymFtoM . qsymMtoF) :: Vect Q QSymM -> Bool) putStrLn "Checking morphisms" putStrLn "SSym" -- quickCheck (prop_AlgebraMorphism ssymMtoF :: (Q, Vect Q SSymM, Vect Q SSymM) -> Bool) -- too slow -- quickCheck (prop_AlgebraMorphism ssymFtoM :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool) -- too slow quickCheck (prop_CoalgebraMorphism ssymMtoF :: Vect Q SSymM -> Bool) quickCheck (prop_CoalgebraMorphism ssymFtoM :: Vect Q SSymF -> Bool) quickCheck (prop_HopfAlgebraMorphism ssymFtoM :: Vect Q SSymF -> Bool) quickCheck (prop_HopfAlgebraMorphism ssymMtoF :: Vect Q SSymM -> Bool) quickCheck (prop_AlgebraMorphism ssymFtoDual :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool) quickCheck (prop_CoalgebraMorphism ssymFtoDual :: Vect Q SSymF -> Bool) quickCheck (prop_HopfAlgebraMorphism ssymFtoDual :: Vect Q SSymF -> Bool) putStrLn "YSym" -- quickCheck (prop_AlgebraMorphism ysymMtoF :: (Q, Vect Q YSymM, Vect Q YSymM) -> Bool) -- too slow quickCheck (prop_AlgebraMorphism ysymFtoM :: (Q, Vect Q (YSymF ()), Vect Q (YSymF ())) -> Bool) quickCheck (prop_CoalgebraMorphism ysymMtoF :: Vect Q YSymM -> Bool) quickCheck (prop_CoalgebraMorphism ysymFtoM :: Vect Q (YSymF ()) -> Bool) quickCheck (prop_HopfAlgebraMorphism ysymMtoF :: Vect Q YSymM -> Bool) quickCheck (prop_HopfAlgebraMorphism ysymFtoM :: Vect Q (YSymF ()) -> Bool) putStrLn "QSym" quickCheck (prop_AlgebraMorphism qsymMtoF :: (Q, Vect Q QSymM, Vect Q QSymM) -> Bool) quickCheck (prop_AlgebraMorphism qsymFtoM :: (Q, Vect Q QSymF, Vect Q QSymF) -> Bool) quickCheck (prop_CoalgebraMorphism qsymMtoF :: Vect Q QSymM -> Bool) quickCheck (prop_CoalgebraMorphism qsymFtoM :: Vect Q QSymF -> Bool) quickCheck (prop_HopfAlgebraMorphism qsymFtoM :: Vect Q QSymF -> Bool) quickCheck (prop_HopfAlgebraMorphism qsymMtoF :: Vect Q QSymM -> Bool) putStrLn "Sym" quickCheck (prop_AlgebraMorphism symEtoM :: (Q, Vect Q SymE, Vect Q SymE) -> Bool) quickCheck (prop_AlgebraMorphism symHtoM :: (Q, Vect Q SymH, Vect Q SymH) -> Bool) quickCheck (prop_CoalgebraMorphism symEtoM :: Vect Q SymE -> Bool) quickCheck (prop_CoalgebraMorphism symHtoM :: Vect Q SymH -> 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)) quickCheck (prop_AlgebraMorphism symToQSymM :: (Q, Vect Q SymM, Vect Q SymM) -> Bool) quickCheck (prop_CoalgebraMorphism symToQSymM :: Vect Q SymM -> Bool) quickCheck (prop_HopfAlgebraMorphism symToQSymM :: Vect Q SymM -> Bool) -- quickCheck (prop_AlgebraMorphism nsymToSSym :: (Q, Vect Q NSym, Vect Q NSym) -> Bool) -- too slow quickCheck (prop_CoalgebraMorphism nsymToSSym :: Vect Q NSym -> Bool) quickCheck (prop_HopfAlgebraMorphism nsymToSSym :: Vect Q NSym -> Bool) quickCheck (prop_AlgebraMorphism nsymToSymH :: (Q, Vect Q NSym, Vect Q NSym) -> Bool) quickCheck (prop_CoalgebraMorphism nsymToSymH :: Vect Q NSym -> Bool) -- The map NSym -> Sym factors through the descent map SSym -> (YSym ->) QSym quickCheck (\x -> (symToQSymM . symHtoM . nsymToSymH) x == (qsymFtoM . descentMap . nsymToSSym) (x :: Vect Q NSym)) -- Coalgebra morphisms showing that various Hopf algebras are cofree quickCheck (prop_CoalgebraMorphism ysymmToSh :: Vect Q YSymM -> Bool) -- Duality pairings quickCheck (prop_HopfPairing :: (Vect Q SSymF, Vect Q SSymF, Vect Q (Dual SSymF), Vect Q (Dual SSymF)) -> Bool) quickCheck (prop_HopfPairing :: (Vect Q SSymF, Vect Q SSymF, Vect Q SSymF, Vect Q SSymF) -> Bool) quickCheck (prop_BialgebraPairing :: (Vect Q SymH, Vect Q SymH, Vect Q SymM, Vect Q SymM) -> Bool) -- The above is in fact a Hopf pairing, but need to define a Hopf algebra instance for SymH quickCheck (prop_HopfPairing :: (Vect Q NSym, Vect Q NSym, Vect Q QSymM, Vect Q QSymM) -> Bool) -- A bialgebra pairing gives a map A -> B*, u -> -- However, require that the pairing is non-degenerate in order to be injective, and also need to prove surjective testlistCHA = TestList [ TestCase $ assertEqual "ysymMtoF" (ysymMtoF $ 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 TestCase $ assertEqual "mult QSymM" (qsymM [1,3] + qsymM [3,1] + qsymM [1,1,2] + qsymM [1,2,1] + qsymM [2,1,1]) (qsymM [2] * qsymM [1,1]), -- SSym.pdf, p5 TestCase $ assertEqual "mult QSymM" (qsymM [1,3] + qsymM [2,2] + 2*qsymM [1,1,2] + qsymM [1,2,1]) (qsymM [1] * qsymM [1,2]), -- SSym.pdf, p31 TestCase $ assertEqual "mult SSymF" (ssymM [1,2,4,3]+ssymM [1,3,4,2]+ssymM [1,4,2,3]+3*ssymM [1,4,3,2]+ssymM [2,3,4,1]+2*ssymM [2,4,3,1] +ssymM [3,4,2,1]+ssymM [4,1,2,3]+2*ssymM [4,1,3,2]+ssymM [4,2,3,1]+ssymM [4,3,1,2]) (ssymM [1,2] * ssymM [2,1]), -- SSym.pdf, p15 TestCase $ assertEqual "ssymMtoF" (ssymF [4,1,2,3] - ssymF [4,1,3,2] - ssymF [4,2,1,3] + ssymF [4,3,2,1]) (ssymMtoF (ssymM [4,1,2,3])), -- SSym.pdf, p7 TestCase $ assertEqual "antipode NSym" (- nsym [1,1,1] + nsym [1,2] + nsym [2,1] - nsym [3]) (antipode $ nsym [3]) -- Hazewinkel p142 ] HaskellForMaths-0.4.8/Math/Test/TCombinatorics/TDigraph.hs0000644000000000000000000001023312514742102021523 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. module Math.Test.TCombinatorics.TDigraph where import Test.HUnit import Control.Monad (when, unless) import Math.Core.Utils (pairs) import Math.Combinatorics.Digraph import Math.Combinatorics.Poset testlistDigraph = TestList [ testlistIsDagIsoPositive, testlistIsDagIsoNegative, testlistIsoRepDAGIsIso, testlistIsoRepDAGPositive, testlistIsoRepDAGNegative ] testcaseIsDagIsoPositive desc dag1 dag2 = TestCase $ assertBool desc $ isDagIso dag1 dag2 testlistIsDagIsoPositive = TestList [ testcaseIsDagIsoPositive "D 30 ~= D 42" (hasseDigraph $ posetD 30) (hasseDigraph $ posetD 42), testcaseIsDagIsoPositive "D 60 ~= D 90" (hasseDigraph $ posetD 30) (hasseDigraph $ posetD 42), testcaseIsDagIsoPositive "D 30 ~= B 3" (hasseDigraph $ posetD 30) (hasseDigraph $ posetB 3), testcaseIsDagIsoPositive "B 2 ~= 2 * 2" (hasseDigraph $ posetB 2) (hasseDigraph $ dprod (chainN 2) (chainN 2)) ] testcaseIsDagIsoNegative desc dag1 dag2 = TestCase $ assertBool desc $ not (isDagIso dag1 dag2) testlistIsDagIsoNegative = TestList [ testcaseIsDagIsoNegative "D 20 ~/= D 30" (hasseDigraph $ posetD 20) (hasseDigraph $ posetD 30), testcaseIsDagIsoNegative "Subposets B4 - 1" (hasseDigraph $ subposet (posetB 4) (/= [1])) (hasseDigraph $ subposet (posetB 4) (/= [1,2])), testcaseIsDagIsoNegative "Subposets B4 - 2" (hasseDigraph $ subposet (posetB 4) (`notElem` [[1],[1,2]])) (hasseDigraph $ subposet (posetB 4) (`notElem` [[1],[2,3]])) ] -- test that the isoRepDAG is isomorphic to the DAG testcaseIsoRepDAGIsIso desc dag = TestCase $ assertBool desc $ isDagIso dag (isoRepDAG dag) testlistIsoRepDAGIsIso = TestList [ testcaseIsoRepDAGIsIso "D 30" (hasseDigraph $ posetD 30), testcaseIsoRepDAGIsIso "B 4 - [1,2]" (hasseDigraph $ subposet (posetB 4) (/= [1,2])) ] testcaseIsoRepDAGPositive desc dag1 dag2 = TestCase (assertEqual desc (isoRepDAG dag1) (isoRepDAG dag2)) testlistIsoRepDAGPositive = TestList [ testcaseIsoRepDAGPositive "D 30 ~= D 42" (hasseDigraph $ posetD 30) (hasseDigraph $ posetD 42), testcaseIsoRepDAGPositive "D 60 ~= D 90" (hasseDigraph $ posetD 30) (hasseDigraph $ posetD 42), testcaseIsoRepDAGPositive "D 30 ~= B 3" (hasseDigraph $ posetD 30) (hasseDigraph $ posetB 3), testcaseIsoRepDAGPositive "B 2 ~= 2 * 2" (hasseDigraph $ posetB 2) (hasseDigraph $ dprod (chainN 2) (chainN 2)) ] assertNotEqual desc val1 val2 = when (val1 == val2) (assertFailure desc) -- unless (val1 /= val2) (assertFailure desc) testcaseIsoRepDAGNegative desc dag1 dag2 = TestCase (assertNotEqual desc (isoRepDAG dag1) (isoRepDAG dag2)) testlistIsoRepDAGNegative = TestList [ testcaseIsoRepDAGNegative "Subposets B4 - 1" (hasseDigraph $ subposet (posetB 4) (/= [1])) (hasseDigraph $ subposet (posetB 4) (/= [1,2])), testcaseIsoRepDAGNegative "Subposets B4 - 2" (hasseDigraph $ subposet (posetB 4) (`notElem` [[1],[1,2]])) (hasseDigraph $ subposet (posetB 4) (`notElem` [[1],[2,3]])) ] allDags n = [DG [1..n] es | es <- powerset (pairs [1..n])] -- > all (uncurry (==)) [(dag1 `isDagIso` dag2, isoRepDAG dag1 == isoRepDAG dag2) | (dag1,dag2) <- pairs (allDags 4)] {- -- Following tests no longer valid, as isoRepDAG doesn't produce same representative as isoRepDAG1 testcaseIsoRepDAG desc dag = TestCase (assertEqual desc (isoRepDAG1 dag) (isoRepDAG dag)) testlistIsoRepDAG = TestList [ testcaseIsoRepDAG "posetB 3" (hasseDigraph (posetB 3)), testcaseIsoRepDAG "posetP 3" (hasseDigraph (posetP 3)), testcaseIsoRepDAG "dual (chainN 5)" (hasseDigraph (dual (chainN 5))), testcaseIsoRepDAG "antiChainN 5" (hasseDigraph (antichainN 5)), testcaseIsoRepDAG "posetD 60" (hasseDigraph (posetD 60)), testcaseIsoRepDAG "dprod (posetB 2) (chainN 3)" (hasseDigraph (dprod (posetB 2) (chainN 3))), testcaseIsoRepDAG "DG ['a'..'e'] [('a','d'),('a','e'),('b','c'),('b','d'),('d','e')]" (DG ['a'..'e'] [('a','d'),('a','e'),('b','c'),('b','d'),('d','e')]) ] -} HaskellForMaths-0.4.8/Math/Test/TCombinatorics/TFiniteGeometry.hs0000644000000000000000000000447512514742102023112 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved module Math.Test.TCombinatorics.TFiniteGeometry where import Test.HUnit import Math.Combinatorics.FiniteGeometry import Math.Core.Field import Math.Combinatorics.GraphAuts (incidenceAuts) import Math.Algebra.Group.PermutationGroup (orderSGS) import Math.NumberTheory.Factor (pfactors) testlistFiniteGeometry = TestList [ testlistFlatsAG, testlistFlatsPG, testlistAutsAG, testlistAutsPG ] -- !! can't make list [f2,f3,f4], because they're different types testcaseFlatsAG n fq k = TestCase $ assertEqual (show "flatsAG " ++ show n ++ " " ++ show q ++ " " ++ show k) (numFlatsAG n q k) (length (flatsAG n fq k)) where q = length fq testlistFlatsAG = TestList $ [testcaseFlatsAG n f2 k | n <- [2,3], k <- [0..n]] ++ [testcaseFlatsAG n f3 k | n <- [2,3], k <- [0..n]] ++ [testcaseFlatsAG n f4 k | n <- [2,3], k <- [0..n]] testcaseFlatsPG n fq k = TestCase $ assertEqual (show "flatsPG " ++ show n ++ " " ++ show q ++ " " ++ show k) (numFlatsPG n q k) (length (flatsPG n fq k)) where q = length fq testlistFlatsPG = TestList $ [testcaseFlatsPG n f2 k | n <- [2,3], k <- [0..n]] ++ [testcaseFlatsPG n f3 k | n <- [2,3], k <- [0..n]] ++ [testcaseFlatsPG n f4 k | n <- [2,3], k <- [0..n]] testcaseAutsAG n fq = TestCase $ assertEqual ("autsAG " ++ show n ++ " " ++ show q) (orderAff n q * degree) (orderSGS $ incidenceAuts $ incidenceGraphAG n fq) where q = toInteger $ length fq degree = toInteger $ length $ pfactors $ toInteger q testlistAutsAG = TestList $ -- [testcaseAutsAG n f2 | n <- [2,3] ] ++ -- this is the complete graph, so has more auts than expected [testcaseAutsAG n f3 | n <- [2] ] -- ++ -- [testcaseAutsAG n f4 | n <- [2,3] ] -- these take too long testcaseAutsPG n fq = TestCase $ assertEqual ("autsPG " ++ show n ++ " " ++ show q) (orderPGL (n+1) q * degree) (orderSGS $ incidenceAuts $ incidenceGraphPG n fq) where q = toInteger $ length fq degree = toInteger $ length $ pfactors $ toInteger q testlistAutsPG = TestList $ [testcaseAutsPG n f2 | n <- [2,3] ] ++ [testcaseAutsPG n f3 | n <- [2] ] -- ++ -- [testcaseAutsPG n f4 | n <- [2,3] ] -- these take too long HaskellForMaths-0.4.8/Math/Test/TCombinatorics/TGraphAuts.hs0000644000000000000000000002344012514742102022047 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. module Math.Test.TCombinatorics.TGraphAuts where import Data.List as L import Math.Core.Field hiding (f7) import Math.Core.Utils (combinationsOf) import Math.Algebra.Group.PermutationGroup as P import Math.Algebra.Group.RandomSchreierSims as SS import Math.Combinatorics.Graph as G import Math.Combinatorics.GraphAuts import Math.Combinatorics.Matroid as M import Math.Combinatorics.FiniteGeometry import qualified Math.Algebra.Field.Extension as F import Test.HUnit testlistGraphAuts = TestList [ testlistGraphAutsOrder, testlistGraphAutsGroup, testlistGraphAutsComplement, testlistIncidenceAutsOrder, testlistGraphIsos, testlistIsGraphIso, testlistIncidenceIsos, testlistVertexTransitive, testlistNotVertexTransitive, testlistEdgeTransitive, testlistNotEdgeTransitive, testlistArcTransitive, testlistNotArcTransitive, testlist2ArcTransitive, testlistNot2ArcTransitive, testlist4ArcTransitive, testlistDistanceTransitive, testlistNotDistanceTransitive ] -- We know the expected order of the graph automorphism group testcaseGraphAutsOrder desc g n = TestCase $ assertEqual ("order " ++ desc) n (orderSGS $ graphAuts g) testlistGraphAutsOrder = TestList [ let g = G [1..6] [[1,2],[3,4],[5,6]] in testcaseGraphAutsOrder (show g) g 48, -- 2*2*2*3! testcaseGraphAutsOrder "cube" cube 48, testcaseGraphAutsOrder "dodecahedron" dodecahedron 120 ] induced bs g = fromPairs [(b, b -^ g) | b <- bs] -- We know the expected group of graph automorphisms testcaseGraphAutsGroup desc graph group = TestCase $ assertEqual ("group " ++ desc) (elts $ graphAuts graph) (elts $ group) testlistGraphAutsGroup = TestList [ testcaseGraphAutsGroup "nullGraph 0" (nullGraph 0) [], testcaseGraphAutsGroup "nullGraph 1" (nullGraph 1) (_S 1), testcaseGraphAutsGroup "nullGraph 2" (nullGraph 2) (_S 2), testcaseGraphAutsGroup "nullGraph 3" (nullGraph 3) (_S 3), testcaseGraphAutsGroup "k 3" (k 3) (_S 3), testcaseGraphAutsGroup "k 4" (k 4) (_S 4), testcaseGraphAutsGroup "k 5" (k 5) (_S 5), testcaseGraphAutsGroup "c 4" (c 4) (_D 8), testcaseGraphAutsGroup "c 5" (c 5) (_D 10), let graph = G [1..3] [[1,2],[2,3]] in testcaseGraphAutsGroup (show graph) graph [p [[1,3]]], -- regression test let graph = G [1..6] [[2,3],[4,5],[5,6]] in testcaseGraphAutsGroup (show graph) graph [p [[2,3]], p [[4,6]]], testcaseGraphAutsGroup "petersen" petersen (map (induced $ combinationsOf 2 [1..5]) $ _S 5) ] -- The automorphisms of the graph should be the same as the auts of its complement testcaseGraphAutsComplement desc g = TestCase $ assertEqual ("complement " ++ desc) (elts $ graphAuts g) (elts $ graphAuts $ complement g) -- the algorithm may not find the same set of generators, so we have to compare the elements testlistGraphAutsComplement = TestList [ testcaseGraphAutsComplement "k 3" (k 3), testcaseGraphAutsComplement "kb 2 3" (kb 2 3), -- complement is not connected testcaseGraphAutsComplement "kb 3 3" (kb 3 3), -- complement is not connected, but components can be swapped testcaseGraphAutsComplement "kt 2 3 3" (kt 2 3 3), testcaseGraphAutsComplement "kt 2 3 4" (kt 2 3 4), testcaseGraphAutsComplement "kt 3 3 3" (kt 3 3 3) ] kt a b c = graph (vs,es) where vs = [1..a+b+c] es = L.sort $ [[i,j] | i <- [1..a], j <- [a+1..a+b] ] ++ [[i,k] | i <- [1..a], k <- [a+b+1..a+b+c] ] ++ [[j,k] | j <- [a+1..a+b], k <- [a+b+1..a+b+c] ] -- We know the expected order of the incidence structure automorphism group testcaseIncidenceAutsOrder desc g n = TestCase $ assertEqual ("incidence order " ++ desc) n (P.order $ incidenceAuts g) -- We use matroids as our incidence structure just because we have a powerful library for constructing them testlistIncidenceAutsOrder = TestList [ testcaseIncidenceAutsOrder "pg2 f2 (B)" (incidenceGraphB $ matroidPG 2 f2) 168, testcaseIncidenceAutsOrder "pg2 f2 (C)" (incidenceGraphC $ matroidPG 2 f2) 168, testcaseIncidenceAutsOrder "pg2 f2 (H)" (incidenceGraphH $ matroidPG 2 f2) 168, testcaseIncidenceAutsOrder "u 1 3 (B)" (incidenceGraphB $ u 1 3) 6, -- not connected testcaseIncidenceAutsOrder "u 1 3 (C)" (incidenceGraphC $ u 1 3) 6, testcaseIncidenceAutsOrder "u 1 3 (H)" (incidenceGraphH $ u 1 3) 6, -- not connected testcaseIncidenceAutsOrder "u 2 3 `dsum` u 2 3 (H)" (incidenceGraphH $ u 2 3 `dsum` u 2 3) 72, -- 6*6*2 testcaseIncidenceAutsOrder "u 2 3 `dsum` u 2 3 (C)" (incidenceGraphC $ u 2 3 `dsum` u 2 3) 72, -- not connected testcaseIncidenceAutsOrder "u 2 3 `dsum` u 3 4 (H)" (incidenceGraphH $ u 2 3 `dsum` u 3 4) 144, -- 6*24 testcaseIncidenceAutsOrder "u 2 3 `dsum` u 3 4 (C)" (incidenceGraphC $ u 2 3 `dsum` u 3 4) 144 -- not connected ] testcaseGraphIsos g1 g2 isos = TestCase $ assertEqual (show (g1,g2)) isos (graphIsos g1 g2) testlistGraphIsos = TestList [ testcaseGraphIsos (G [1,2] []) (G [3,4] []) [[(1,3),(2,4)],[(1,4),(2,3)]], testcaseGraphIsos (G [1,2,3] [[1,2]]) (G [4,5,6] [[5,6]]) [[(1,5),(2,6),(3,4)],[(1,6),(2,5),(3,4)]] ] testcaseIsGraphIso g1 g2 = TestCase $ assertBool (show (g1,g2)) $ isGraphIso g1 g2 testlistIsGraphIso = TestList [ testcaseIsGraphIso (nullGraph') (nullGraph') ] testcaseIncidenceIsos g1 g2 isos = TestCase $ assertEqual (show (g1,g2)) isos (incidenceIsos g1 g2) testlistIncidenceIsos = TestList [ testcaseIncidenceIsos (G [Left 1, Right 2] []) (G [Left 3, Right 4] []) [[(1,3)]], testcaseIncidenceIsos (G [Left 1, Left 2, Right 1] [[Left 1, Right 1]]) (G [Left 3, Left 4, Right 4] [[Left 4, Right 4]]) [[(1,4),(2,3)]] ] testcaseVertexTransitive (desc, graph) = TestCase $ assertBool ("isVertexTransitive " ++ desc) $ isVertexTransitive graph testlistVertexTransitive = TestList $ map testcaseVertexTransitive [ -- because we're mapping, these all have to be of same type, hence Graph Int ("(q 3)", q 3), ("(q 4)", q 4), ("petersen", G.to1n petersen) ] testcaseNotVertexTransitive (desc, graph) = TestCase $ assertBool ("not isVertexTransitive " ++ desc) $ (not . isVertexTransitive) graph testlistNotVertexTransitive = TestList $ map testcaseNotVertexTransitive [ ("(kb 2 3)", G.to1n $ kb 2 3), ("(kb 3 4)", G.to1n $ kb 3 4), ("regular not vertex transitive" , G [(1::Int)..8] [[1,2],[1,3],[1,8],[2,3],[2,4],[3,5],[4,5],[4,6],[5,7],[6,7],[6,8],[7,8]]) ] testcaseEdgeTransitive (desc, graph) = TestCase $ assertBool ("isEdgeTransitive " ++ desc) $ isEdgeTransitive graph testlistEdgeTransitive = TestList $ map testcaseEdgeTransitive [ ("(kb 2 3)", kb 2 3), ("(kb 3 4)", kb 3 4) ] testcaseNotEdgeTransitive (desc, graph) = TestCase $ assertBool ("not isEdgeTransitive " ++ desc) $ (not . isEdgeTransitive) graph testlistNotEdgeTransitive = TestList $ map testcaseNotEdgeTransitive [ ("pyramid 4", pyramid 4), ("pyramid 5", pyramid 5), ("prism 3", G.to1n $ prism 3), ("prism 5", G.to1n $ prism 5) ] where pyramid n = let G vs es = c n in graph (0:vs, [[0,v] | v <- vs] ++ es) testcaseArcTransitive (desc, graph) = TestCase $ assertBool ("isArcTransitive " ++ desc) $ isArcTransitive graph testlistArcTransitive = TestList $ map testcaseArcTransitive [ -- Godsil and Royle, p60 - j v k i is arc-transitive ("(j 4 2 0)", j 4 2 0), ("(j 5 2 0)", j 5 2 0), ("(j 5 2 1)", j 5 2 1) ] testcaseNotArcTransitive (desc, graph) = TestCase $ assertBool ("not isArcTransitive " ++ desc) $ (not . isArcTransitive) graph testlistNotArcTransitive = TestList $ map testcaseNotArcTransitive [ ("kb 3 2", kb 3 2), ("kb 4 3", kb 4 3) ] testcase2ArcTransitive (desc, graph) = TestCase $ assertBool ("is2ArcTransitive " ++ desc) $ is2ArcTransitive graph testlist2ArcTransitive = TestList $ map testcase2ArcTransitive [ -- Godsil and Royle, p60 - j (2k+1) k 0 is 2-arc-transitive ("(j 3 1 0)", j 3 1 0), ("(j 5 2 0)", j 5 2 0), ("(j 7 3 0)", j 7 3 0) ] testcaseNot2ArcTransitive (desc, graph) = TestCase $ assertBool ("not is2ArcTransitive " ++ desc) $ (not . is2ArcTransitive) graph testlistNot2ArcTransitive = TestList $ map testcaseNot2ArcTransitive [ -- because a 2-arc can be two sides of a triangle, or not, so they are not all alike ("octahedron", octahedron), ("icosahedron", icosahedron) ] testcase4ArcTransitive (desc, graph) = TestCase $ assertBool ("is4ArcTransitive " ++ desc) $ is4ArcTransitive graph testlist4ArcTransitive = TestList $ map testcase4ArcTransitive [ -- Godsil and Royle, p80-1 ("PG(2,F2)", G.to1n $ incidenceGraphPG 2 f2), ("PG(2,F3)", G.to1n $ incidenceGraphPG 2 f3), ("PG(2,F4)", G.to1n $ incidenceGraphPG 2 f4) ] testcaseDistanceTransitive (desc, graph) = TestCase $ assertBool ("isDistanceTransitive " ++ desc) $ isDistanceTransitive graph testlistDistanceTransitive = TestList $ map testcaseDistanceTransitive [ ("(kb 3 3)", G.to1n $ kb 3 3), ("(kb 4 4)", G.to1n $ kb 4 4), ("(q 3)", G.to1n $ q 3), ("(q 4)", G.to1n $ q 4), ("petersen", G.to1n $ petersen), -- Godsil and Royle, p67 - j v k (k-1) and j (2k+1) (k+1) 0 are distance-transitive ("(j 3 2 1)", G.to1n $ j 3 2 1), ("(j 4 2 1)", G.to1n $ j 4 2 1), ("(j 5 3 2)", G.to1n $ j 5 3 2) -- ("(j 3 2 0)", G.to1n $ j 3 2 0), -- ("(j 5 3 0)", G.to1n $ j 5 3 0), -- ("(j 7 4 0)", G.to1n $ j 7 4 0) ] testcaseNotDistanceTransitive (desc, graph) = TestCase $ assertBool ("not isDistanceTransitive " ++ desc) $ (not . isDistanceTransitive) graph testlistNotDistanceTransitive = TestList $ map testcaseNotDistanceTransitive [ ("(prism 3)", prism 3), -- not prism 4, which is the cube ("(prism 5)", prism 5) ] HaskellForMaths-0.4.8/Math/Test/TCombinatorics/TIncidenceAlgebra.hs0000644000000000000000000000213112514742102023302 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. module Math.Test.TCombinatorics.TIncidenceAlgebra where import Test.HUnit import Math.Algebra.Field.Base import Math.Combinatorics.Digraph import Math.Combinatorics.Poset import Math.Combinatorics.IncidenceAlgebra testlistIncidenceAlgebra = TestList [ testlistMuReference, testlistMuInverse ] -- test that the calculated mu matches reference definition testcaseMuReference desc poset muref = TestCase $ assertEqual desc muref (muIA poset) testlistMuReference = TestList [ testcaseMuReference "chainN 3" (chainN 3) (muC 3), testcaseMuReference "posetB 3" (posetB 3) (muB 3), testcaseMuReference "posetL 3 f3" (posetL 3 f3) (muL 3 f3) ] -- test that muIA is multiplicative inverse of zetaIA testcaseMuInverse desc poset = TestCase (assertEqual desc (unitIA poset) (muIA poset * zetaIA poset)) testlistMuInverse = TestList [ testcaseMuInverse "chainN 3" (chainN 3), testcaseMuInverse "antichainN 3" (antichainN 3), testcaseMuInverse "posetB 3" (posetB 3), testcaseMuInverse "posetP 3" (posetP 3) ] HaskellForMaths-0.4.8/Math/Test/TCombinatorics/TMatroid.hs0000644000000000000000000001156012514742102021550 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. module Math.Test.TCombinatorics.TMatroid where import Test.HUnit import Math.Combinatorics.Matroid import Math.Core.Field hiding (f7) -- import Math.Algebra.Field.Base hiding (f7) import Math.Core.Utils (combinationsOf) testlistMatroid = TestList [ testlistKnownEquivalent, testlistFromCircuits, testlistFromBases, testlistFromRankfun, testlistFromClosure, testlistFromFlats, testlistFromHyperplanes, testlistRepresentable ] elts = elements -- Oxley p8 ex112 = vectorMatroid' [[1,0],[0,1],[0,0],[1,0],[1,1::Q]] -- Oxley p11 - leads to same matroid as ex112 ex118 = cycleMatroid [ [1,2],[1,3],[3,3],[1,2],[2,3]] -- Oxley p19 - two non-isomorphic graphs giving rise to the same matroid fig13a = cycleMatroid [ [1,1],[2,3],[2,4],[2,5],[6,7]] fig13b = cycleMatroid [ [1,1],[1,2],[2,3],[3,4],[4,5]] -- Oxley p34, fig 1.8 ex154 = fromGeoRep [[3]] [[1,4]] [[1,2,5],[2,4,5]] [[1..5]] -- Oxley p46 ex163a = cycleMatroid [ [1,2],[1,2],[2,3],[2,3],[3,4],[3,4],[1,4] ] ex163b = transversalMatroid [1..7] [ [1,2,7],[3,4,7],[5,6,7] ] {- -- not currently used ex16 = affineMatroid [ [0,0],[0,1],[0,2],[1,0],[1,1],[2,0::Q]] ex17 = affineMatroid [ [0,0,0],[0,0,1],[0,1,0],[0,1,1],[1,0,0],[1,1,0::Q]] -} testcaseEquivalent desc m1 m2 = TestCase (assertEqual desc m1 m2) testlistKnownEquivalent = TestList [ testcaseEquivalent "ex112=118" ex112 ex118, testcaseEquivalent "fig13a=fig13b" fig13a fig13b, testcaseEquivalent "ex112=ex154" ex112 ex154, testcaseEquivalent "desargues = M(K5)" desargues (cycleMatroid (combinationsOf 2 [1..5])), -- Oxley p39 testcaseEquivalent "ex163a=ex163b" ex163a ex163b ] exampleList = [ ("ex112", ex112), ("fig13a", fig13a), ("f7", f7), ("pappus",pappus), ("nonPappus",nonPappus), ("desargues",desargues), ("v8",v8) ] -- if we're really just going to use the same examples for each test, should use map testcaseFromCircuits (desc, m) = TestCase (assertEqual ("fromCircuits " ++ desc) m (fromCircuits (elts m) (circuits m))) testlistFromCircuits = TestList $ map testcaseFromCircuits exampleList testcaseFromBases (desc, m) = TestCase (assertEqual ("fromBases " ++ desc) m (fromBases (elts m) (bases m))) testlistFromBases = TestList $ map testcaseFromBases exampleList testcaseFromRankfun (desc, m) = TestCase (assertEqual ("fromRankfun " ++ desc) m (fromRankfun (elts m) (rankfun m))) testlistFromRankfun = TestList $ map testcaseFromRankfun exampleList testcaseFromClosure (desc, m) = TestCase (assertEqual ("fromClosure " ++ desc) m (fromClosure (elts m) (closure m))) testlistFromClosure = TestList $ map testcaseFromClosure exampleList testcaseFromFlats (desc, m) = TestCase (assertEqual ("fromFlats " ++ desc) m (fromFlats (flats m))) testlistFromFlats = TestList $ map testcaseFromFlats exampleList testcaseFromHyperplanes (desc, m) = TestCase (assertEqual ("fromHyperplanes " ++ desc) m (fromHyperplanes (elts m) (hyperplanes m))) testlistFromHyperplanes = TestList $ map testcaseFromHyperplanes exampleList testcaseIsRepresentable desc fq m = TestCase (assertBool ("isRepresentable " ++ desc) (isRepresentable fq m)) testcaseNotRepresentable desc fq m = TestCase (assertBool ("notRepresentable " ++ desc) (not (isRepresentable fq m))) testlistRepresentable = TestList [ testcaseNotRepresentable "f2 v8" f2 v8, -- Oxley p84 testcaseNotRepresentable "f3 v8" f3 v8, testcaseNotRepresentable "f4 v8" f4 v8, testcaseNotRepresentable "f5 v8" f5 v8, testcaseIsRepresentable "f2 f7" f2 f7, -- Oxley p187 testcaseNotRepresentable "f3 f7" f3 f7, testcaseIsRepresentable "f4 f7" f4 f7, testcaseNotRepresentable "f5 f7" f5 f7, testcaseNotRepresentable "f2 f7m" f2 f7m, testcaseIsRepresentable "f3 f7m" f3 f7m, testcaseNotRepresentable "f4 f7m" f4 f7m, testcaseIsRepresentable "f5 f7m" f5 f7m, testcaseNotRepresentable "f2 p8" f2 p8, -- Oxley p189-90 testcaseIsRepresentable "f3 p8" f3 p8, testcaseNotRepresentable "f4 p8" f4 p8, testcaseIsRepresentable "f5 p8" f5 p8, testcaseNotRepresentable "f2 p8m" f2 p8m, testcaseNotRepresentable "f3 p8m" f3 p8m, testcaseIsRepresentable "f4 p8m" f4 p8m, testcaseIsRepresentable "f5 p8m" f5 p8m, testcaseNotRepresentable "f2 p8mm" f2 p8mm, testcaseNotRepresentable "f3 p8mm" f3 p8mm, testcaseNotRepresentable "f4 p8mm" f4 p8mm, testcaseIsRepresentable "f5 p8mm" f5 p8mm, testcaseNotRepresentable "f2 u24" f2 (u 2 4), -- Oxley p193 testcaseNotRepresentable "f3 u25" f3 (u 2 5), testcaseNotRepresentable "f3 u35" f3 (u 3 5), testcaseNotRepresentable "f4 u26" f4 (u 2 6), testcaseNotRepresentable "f4 u46" f4 (u 4 6), testcaseNotRepresentable "f5 u27" f5 (u 2 7), testcaseNotRepresentable "f5 u57" f5 (u 5 7) -- Oxley does mention other excluded minors for other fields, but we have to stop somewhere ] HaskellForMaths-0.4.8/Math/Test/TCombinatorics/TPoset.hs0000644000000000000000000000243212514742102021241 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. module Math.Test.TCombinatorics.TPoset where import Test.HUnit import Math.Combinatorics.Digraph import Math.Combinatorics.Poset testlistPoset = TestList [ testlistIsOrderIsoPositive, testlistIsOrderIsoNegative, testlistHasseDigraph ] testcaseIsOrderIsoPositive desc p1 p2 = TestCase (assertBool desc (isOrderIso p1 p2)) testlistIsOrderIsoPositive = TestList [ testcaseIsOrderIsoPositive "D 30 ~= D 42" (posetD 30) (posetD 42), testcaseIsOrderIsoPositive "D 60 ~= D 90" (posetD 30) (posetD 42), testcaseIsOrderIsoPositive "D 30 ~= B 3" (posetD 30) (posetB 3), testcaseIsOrderIsoPositive "B 2 ~= 2 * 2" (posetB 2) (dprod (chainN 2) (chainN 2)) ] testcaseIsOrderIsoNegative desc p1 p2 = TestCase (assertBool desc (not (isOrderIso p1 p2))) testlistIsOrderIsoNegative = TestList [ testcaseIsOrderIsoNegative "D 20 ~/= D 30" (posetD 20) (posetD 30) ] testcaseHasseDigraph desc poset = TestCase $ assertEqual desc poset (reachabilityPoset $ hasseDigraph poset) testlistHasseDigraph = TestList [ testcaseHasseDigraph "chain 3" (chainN 3), testcaseHasseDigraph "antichain 3" (antichainN 3), testcaseHasseDigraph "posetB 3" (posetB 3), testcaseHasseDigraph "posetB 4" (posetB 4) ] HaskellForMaths-0.4.8/Math/Test/TCommutativeAlgebra/0000755000000000000000000000000012514742102020445 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Test/TCommutativeAlgebra/TGroebnerBasis.hs0000644000000000000000000000765212514742102023664 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. module Math.Test.TCommutativeAlgebra.TGroebnerBasis where import Test.HUnit import Math.Core.Field import Math.Algebras.VectorSpace import Math.CommutativeAlgebra.Polynomial import Math.CommutativeAlgebra.GroebnerBasis -- Sources: -- Eisenbud, Commutative Algebra with a View Toward Algebraic Geometry -- [IVA] - Cox, Little, O'Shea: Ideals, Varieties and Algorithms, 2nd ed -- (Note that I have the 5th printing, which is known to have some misprints) -- [UAG] - Cox, Little, O'Shea: Using Algebraic Geometry -- Schenck, Computational Algebraic Geometry testlistGroebnerBasis = TestList [ testlistLexGb, testlistGlexGb, testlistIntersectI, testlistQuotientI, testlistEliminate, -- testlistElimExcept, testlistHilbertPolyQA ] data Var = X | Y | Z | W deriving (Eq,Ord) instance Show Var where show X = "x" show Y = "y" show Z = "z" show W = "w" [x,y,z,w] = map grevlexvar [X,Y,Z,W] testcaseGb desc input output = TestCase (assertEqual desc output (gb input)) testlistLexGb = let [x,y,z] = map lexvar ["x","y","z"] in TestList [ testcaseGb "Lex " [x^2,x*y+y^2] [x^2,x*y+y^2,y^3], -- Eisenbud p339 testcaseGb "Lex " [x^2+y^2+z^2-1,x^2+z^2-y,x-z] [x-z,y-2*z^2,z^4+1/2*z^2-1/4], -- IVA p93-4 testcaseGb "Lex " [x^2+y^2+z^2-1,x*y*z-1] [x+y^3*z+y*z^3-y*z,y^4*z^2+y^2*z^4-y^2*z^2+1], -- IVA p116 testcaseGb "Lex " [x*y-4,y^2-(x^3-1)] [x-1/16*y^4-1/16*y^2,y^5+y^3-64] -- IVA p117, misprint corrected ] testlistGlexGb = let [x,y,z] = map glexvar ["x","y","z"] in TestList [ testcaseGb "Glex " [x*z-y^2,x^3-z^2] [y^6-z^5,x*y^4-z^4,x^2*y^2-z^3,x^3-z^2,x*z-y^2], -- IVA p93 testcaseGb "Glex " [x^2+y,x*y+x] [x^2+y,x*y+x,y^2+y] -- Schenck p54 ] testcaseIntersectI desc i1 i2 iout = TestCase (assertEqual ("intersectI " ++ desc) iout (intersectI i1 i2)) testlistIntersectI = let [x,y] = map grevlexvar ["x","y"] in TestList [ testcaseIntersectI "[x^2*y] [x*y^2]" [x^2*y] [x*y^2] [x^2*y^2], -- IVA p186 testcaseIntersectI "IVA 186/2" [(x+y)^4*(x^2+y)^2*(x-5*y)] [(x+y)*(x^2+y)^3*(x+3*y)] [(x+y)^4*(x^2+y)^3*(x-5*y)*(x+3*y)] -- IVA p186 ] testcaseQuotientI desc i j q = TestCase (assertEqual ("quotientI " ++ desc) q (i `quotientI` j)) testlistQuotientI = let [x,y,z] = map grevlexvar ["x","y","z"] in TestList [ testcaseQuotientI "[x*z, y*z] [z]" [x*z, y*z] [z] [x,y], -- IVA p192 testcaseQuotientI "[y^2, z^2] [y*z]" [y^2, z^2] [y*z] [y,z] -- Schenck p56 (in passing) ] testcaseEliminate vs gs gs' = TestCase $ assertEqual "Eliminate" gs' (eliminate vs gs) testlistEliminate = let [t,u,v,x,y,z,x',y',z'] = map glexvar ["t","u","v","x","y","z","x'","y'","z'"] in TestList [ testcaseEliminate [x,y,z] [x^2+y^2-z^2,x'-(x+z),y'-y,z'-(z-x)] [x'*z'-y'^2], -- Reid p15 testcaseEliminate [t] [(t^2+1)*x-2*t, (t^2+1)*y-(t^2-1)] [x^2+y^2-1], testcaseEliminate [u,v] [x'-u^2,y'-u*v,z'-v^2] [x'*z'-y'^2] -- Reid p16 ] {- testcaseElimExcept vs gs gs' = TestCase $ assertEqual "Eliminate" gs' (eliminate vs gs) testlistElimExcept = let [t,u,v,x,y,z,x',y',z'] = map glexvar ["t","u","v","x","y","z","x'","y'","z'"] in TestList [ testcaseElimExcept [x',y',z'] [x^2+y^2-z^2,x'-(x+z),y'-y,z'-(z-x)] [x'*z'-y'^2], -- Reid p15 testcaseElimExcept [x,y] [(t^2+1)*x-2*t, (t^2+1)*y-(t^2-1)] [x^2+y^2-1], testcaseElimExcept [x',y',z'] [x'-u^2,y'-u*v,z'-v^2] [x'*z'-y'^2] -- Reid p16 ] -} testcaseHilbertPolyQA desc hp vs gs = TestCase $ assertEqual desc hp (hilbertPolyQA vs gs) testlistHilbertPolyQA = let i = glexvar "i" in TestList [ testcaseHilbertPolyQA "hilbertPoly " (3*i+1) [x,y,z,w] [y*z-x*w,z^2-y*w,y^2-x*z] -- Schenck p56-7 ] HaskellForMaths-0.4.8/Math/Test/TCommutativeAlgebra/TPolynomial.hs0000644000000000000000000000534512514742102023257 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. module Math.Test.TCommutativeAlgebra.TPolynomial where import Test.HUnit import Data.List as L import Math.Core.Field -- import Math.Algebras.VectorSpace import Math.CommutativeAlgebra.Polynomial testlistPolynomial = TestList [ testlistMonomialOrders1, testlistMonomialOrders2, testlistOverFiniteField, testlistEval, testlistSubst ] testcaseMonomialOrder1 desc monomials expected = TestCase $ assertEqual desc expected (L.sort monomials) testlistMonomialOrders1 = TestList [ let [x,y,z] = map lexvar ["x","y","z"] in testcaseMonomialOrder1 "Lex" [1,x,y,z,x^2,x*y,x*z,y^2,y*z,z^2] [x^2,x*y,x*z,x,y^2,y*z,y,z^2,z,1], let [x,y,z] = map glexvar ["x","y","z"] in testcaseMonomialOrder1 "Glex" [1,x,y,z,x^2,x*y,x*z,y^2,y*z,z^2] [x^2,x*y,x*z,y^2,y*z,z^2,x,y,z,1], let [x,y,z] = map grevlexvar ["x","y","z"] in testcaseMonomialOrder1 "Grevlex" [1,x,y,z,x^2,x*y,x*z,y^2,y*z,z^2] [x^2,x*y,y^2,x*z,y*z,z^2,x,y,z,1] ] testcaseMonomialOrder2 desc poly string = TestCase $ assertEqual desc string (show poly) testlistMonomialOrders2 = TestList [ let [x,y,z] = map lexvar ["x","y","z"] in testcaseMonomialOrder2 "Lex" ((x+y+z+1)^3) "x^3+3x^2y+3x^2z+3x^2+3xy^2+6xyz+6xy+3xz^2+6xz+3x+y^3+3y^2z+3y^2+3yz^2+6yz+3y+z^3+3z^2+3z+1", let [x,y,z] = map glexvar ["x","y","z"] in testcaseMonomialOrder2 "Glex" ((x+y+z+1)^3) "x^3+3x^2y+3x^2z+3xy^2+6xyz+3xz^2+y^3+3y^2z+3yz^2+z^3+3x^2+6xy+6xz+3y^2+6yz+3z^2+3x+3y+3z+1", let [x,y,z] = map grevlexvar ["x","y","z"] in testcaseMonomialOrder2 "Grevlex" ((x+y+z+1)^3) "x^3+3x^2y+3xy^2+y^3+3x^2z+6xyz+3y^2z+3xz^2+3yz^2+z^3+3x^2+6xy+3y^2+6xz+6yz+3z^2+3x+3y+3z+1" ] testcaseOverFiniteField desc input expected = TestCase $ assertEqual desc expected input testlistOverFiniteField = TestList [ let [x,y,z] = map var ["x","y","z"] :: [GlexPoly F3 String] in testcaseOverFiniteField "F3" ((x+y+z)^3) (x^3+y^3+z^3), let [x,y,z] = map var ["x","y","z"] :: [GlexPoly F5 String] in testcaseOverFiniteField "F5" ((x+y+z)^5) (x^5+y^5+z^5) ] testcaseEval poly point value = TestCase $ assertEqual "Eval" value (eval poly point) testlistEval = let [x,y,z] = map glexvar ["x","y","z"] in TestList [ testcaseEval (x^2+y^2-z^2) [(x,3),(y,4),(z,5)] 0, testcaseEval (z-1) [(x,100),(y,-100),(z,1)] 0 ] testcaseSubst poly subs poly' = TestCase $ assertEqual "Subst" poly' (subst poly subs) testlistSubst = let [x,y,z,x',y',z'] = map glexvar ["x","y","z","x'","y'","z'"] in TestList [ testcaseSubst (x^2+y^2-z^2) [(x,(x'-z')/2),(y,y'),(z,(x'+z')/2)] (y'^2-x'*z') ] -- The division algorithm is adequately tested by the GroebnerBasis tests HaskellForMaths-0.4.8/Math/Test/TCore/0000755000000000000000000000000012514742102015562 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Test/TCore/TField.hs0000644000000000000000000000667312514742102017301 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. module Math.Test.TCore.TField where import Test.QuickCheck import Math.Core.Field prop_Field (x,y,z) = (x+y)+z == x+(y+z) && -- associativity of addition (x+0) == x && (0+x) == x && -- identity for addition x+(-x) == 0 && (-x)+x == 0 && -- additive inverse x+y == y+x && -- commutativity of addition (x*y)*z == x*(y*z) && -- associativity of multiplication (x*1) == x && (1*x) == x && -- identity for multiplication (x == 0 || (x*(1/x) == 1 && (1/x)*x == 1)) && -- multiplicative inverse x*y == y*x && -- commutativity of multiplication x*(y+z) == x*y + x*z && (x+y)*z == x*z + y*z -- distributivity of multiplication over addition instance Arbitrary F2 where arbitrary = do {n <- arbitrary; return (fromInteger n)} instance Arbitrary F3 where arbitrary = do {n <- arbitrary; return (fromInteger n)} instance Arbitrary F5 where arbitrary = do {n <- arbitrary; return (fromInteger n)} instance Arbitrary F7 where arbitrary = do {n <- arbitrary; return (fromInteger n)} instance Arbitrary F11 where arbitrary = do {n <- arbitrary; return (fromInteger n)} instance Arbitrary F13 where arbitrary = do {n <- arbitrary; return (fromInteger n)} instance Arbitrary F17 where arbitrary = do {n <- arbitrary; return (fromInteger n)} instance Arbitrary F19 where arbitrary = do {n <- arbitrary; return (fromInteger n)} instance Arbitrary F23 where arbitrary = do {n <- arbitrary; return (fromInteger n)} instance Arbitrary F4 where arbitrary = do {n <- arbitrary; return (f4 !! mod (fromInteger n) 4)} instance Arbitrary F8 where arbitrary = do {n <- arbitrary; return (f8 !! mod (fromInteger n) 8)} instance Arbitrary F9 where arbitrary = do {n <- arbitrary; return (f9 !! mod (fromInteger n) 9)} instance Arbitrary F16 where arbitrary = do {n <- arbitrary; return (f16 !! mod (fromInteger n) 16)} instance Arbitrary F25 where arbitrary = do {n <- arbitrary; return (f25 !! mod (fromInteger n) 25)} quickCheckField = do putStrLn "Testing finite fields" putStrLn "Testing F2..." quickCheck (prop_Field :: (F2,F2,F2) -> Bool) putStrLn "Testing F3..." quickCheck (prop_Field :: (F3,F3,F3) -> Bool) putStrLn "Testing F5..." quickCheck (prop_Field :: (F5,F5,F5) -> Bool) putStrLn "Testing F7..." quickCheck (prop_Field :: (F7,F7,F7) -> Bool) putStrLn "Testing F11..." quickCheck (prop_Field :: (F11,F11,F11) -> Bool) putStrLn "Testing F13..." quickCheck (prop_Field :: (F13,F13,F13) -> Bool) putStrLn "Testing F17..." quickCheck (prop_Field :: (F17,F17,F17) -> Bool) putStrLn "Testing F19..." quickCheck (prop_Field :: (F19,F19,F19) -> Bool) putStrLn "Testing F23..." quickCheck (prop_Field :: (F23,F23,F23) -> Bool) putStrLn "Testing F4..." quickCheck (prop_Field :: (F4,F4,F4) -> Bool) putStrLn "Testing F8..." quickCheck (prop_Field :: (F8,F8,F8) -> Bool) putStrLn "Testing F9..." quickCheck (prop_Field :: (F9,F9,F9) -> Bool) putStrLn "Testing F16..." quickCheck (prop_Field :: (F16,F16,F16) -> Bool) putStrLn "Testing F25..." quickCheck (prop_Field :: (F25,F25,F25) -> Bool) HaskellForMaths-0.4.8/Math/Test/TCore/TUtils.hs0000644000000000000000000000307312514742102017345 0ustar0000000000000000-- 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 || qHaskellForMaths-0.4.8/Math/Test/TNumberTheory/0000755000000000000000000000000012514742102017315 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Test/TNumberTheory/TPrimeFactor.hs0000644000000000000000000001111212514742102022204 0ustar0000000000000000-- Copyright (c) 2011, David Amos. All rights reserved. module Math.Test.TNumberTheory.TPrimeFactor where import Data.List ( (\\) ) import Math.NumberTheory.Prime import Math.NumberTheory.Factor import Test.HUnit testlistPrimeFactor = TestList [ testcasePrimesList, testlistSmallPrimes, testlistMillerRabin, testlistMersennePrimes, testlistMersenneNonPrimes, testlistFermatPrimes, testlistFermatNonPrimes, testlistCullenPrimes, testlistCullenNonPrimes, testlistWoodallPrimes, testlistWoodallNonPrimes, testlistWagstaffPrimes, testlistWagstaffNonPrimes, testlistFermatFactors, testlistNextPrime, testlistPrevPrime, testlistConsistentFactors, testlistFactorOrder ] primesTo100 = [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97] testcasePrimesList = TestCase $ assertEqual "primes list" primesTo100 (takeWhile (<100) primes) testlistSmallPrimes = TestList [ TestCase $ assertEqual "small primes" primesTo100 (filter isPrime [1..100]), TestCase $ assertBool "negative primes" (all notPrime [-10..0]) ] testcaseMillerRabin n = TestCase $ assertEqual ("MillerRabin " ++ show n) (isTrialDivisionPrime n) (isMillerRabinPrime n) testlistMillerRabin = TestList $ map testcaseMillerRabin $ [1 :: Integer ..1000] ++ [10^6..10^6+10^3] -- Source: http://en.wikipedia.org/wiki/Mersenne_prime testlistMersennePrimes = TestList [TestCase $ assertBool ("Mersenne " ++ show p) (isPrime (2^p-1)) | p <- [2,3,5,7,13,17,19,31,61,89,107,127,521] ] testlistMersenneNonPrimes = TestList [TestCase $ assertBool ("Mersenne " ++ show p) (notPrime (2^p-1)) | p <- [11,23,29,37,41,43,47,53,59,67,71,73,79,83,97,101,103,109,113] ] -- http://en.wikipedia.org/wiki/Fermat_prime testlistFermatPrimes = TestList [TestCase $ assertBool ("Fermat " ++ show n) (isPrime (2^2^n + 1)) | n <- [0..4] ] testlistFermatNonPrimes = TestList [TestCase $ assertBool ("Fermat " ++ show n) (notPrime (2^2^n + 1)) | n <- [5..10] ] -- http://en.wikipedia.org/wiki/Cullen_number testlistCullenPrimes = TestList [TestCase $ assertBool ("Cullen " ++ show n) (isPrime (n * 2^n + 1)) | n <- [141] ] testlistCullenNonPrimes = TestList [TestCase $ assertBool ("Cullen " ++ show n) (notPrime (n * 2^n + 1)) | n <- [2..100] ] -- http://en.wikipedia.org/wiki/Woodall_number testlistWoodallPrimes = TestList [TestCase $ assertBool ("Woodall " ++ show n) (isPrime (n * 2^n - 1)) | n <- [2,3,6,30,75,81,115,123,249,362,384] ] testlistWoodallNonPrimes = TestList [TestCase $ assertBool ("Woodall " ++ show n) (notPrime (n * 2^n - 1)) | n <- [2..100] \\ [2,3,6,30,75,81,115,123,249,362,384] ] -- http://en.wikipedia.org/wiki/Wagstaff_prime testlistWagstaffPrimes = TestList [TestCase $ assertBool ("Wagstaff " ++ show n) (isPrime ((2^n + 1) `div` 3)) | n <- [3,5,7,11,13,17,19,23,31,43,61,79,101,127,167,191,199] ] testlistWagstaffNonPrimes = TestList [TestCase $ assertBool ("Wagstaff " ++ show n) (notPrime ((2^n + 1) `div` 3)) | n <- takeWhile (<200) primes \\ [3,5,7,11,13,17,19,23,31,43,61,79,101,127,167,191,199] ] testcaseKnownFactors n ps = TestCase $ assertEqual (show n) ps (pfactors n) testlistFermatFactors = TestList [ testcaseKnownFactors (2^2^5+1) [641, 6700417], testcaseKnownFactors (2^2^6+1) [274177, 67280421310721] ] testlistNextPrime = TestList [TestCase $ assertEqual (show n) p (nextPrime n) | (n,p) <- [(0,2),(1,2),(2,3),(3,5),(4,5),(5,7),(6,7),(7,11),(8,11),(9,11), (10,11),(11,13),(12,13),(13,17),(14,17),(15,17),(16,17),(17,19),(18,19),(19,23), (20,23),(21,23),(22,23),(23,29),(24,29),(25,29),(26,29),(27,29),(28,29),(29,31),(30,31)] ] testlistPrevPrime = TestList [TestCase $ assertEqual (show n) p (prevPrime n) | (n,p) <- [(3,2),(4,3),(5,3),(6,5),(7,5),(8,7),(9,7), (10,7),(11,7),(12,11),(13,11),(14,13),(15,13),(16,13),(17,13),(18,17),(19,17), (20,19),(21,19),(22,19),(23,19),(24,23),(25,23),(26,23),(27,23),(28,23),(29,23),(30,29)] ] testcaseConsistentFactors n = TestCase $ assertBool (show n) (product (pfactors n) == n) testlistConsistentFactors = TestList $ map testcaseConsistentFactors $ [10^6..10^6+10^2] ++ [10^16..10^16+10^2] testlistFactorOrder = let f1 = nextPrime 50000; f2 = nextPrime 70000 in TestList [ TestCase (assertEqual "" [2,2,2,3,3,5] (pfactors (2^3*3^2*5))), TestCase (assertEqual "" [f1,f1,f1,f2,f2] (pfactors (f1^3*f2^2))), TestCase (assertEqual "" [2,2,2,3,3,5,f1,f1,f1,f2,f2] (pfactors (2^3*3^2*5*f1^3*f2^2))) ] HaskellForMaths-0.4.8/Math/Test/TNumberTheory/TQuadraticField.hs0000644000000000000000000000253412514742102022662 0ustar0000000000000000-- 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 systemHaskellForMaths-0.4.8/Math/Test/TProjects/0000755000000000000000000000000012514742102016463 5ustar0000000000000000HaskellForMaths-0.4.8/Math/Test/TProjects/TMiniquaternionGeometry.hs0000644000000000000000000000307712514742102023670 0ustar0000000000000000-- Copyright (c) David Amos, 2009-2011. All rights reserved. module Math.Test.TProjects.TMiniquaternionGeometry where {- import qualified Data.List as L import Math.Common.ListSet as LS import Math.Algebra.Field.Base import Math.Combinatorics.FiniteGeometry (pnf, ispnf, orderPGL) import Math.Combinatorics.Graph (combinationsOf) import Math.Combinatorics.GraphAuts import Math.Algebra.Group.PermutationGroup hiding (order) import qualified Math.Algebra.Group.SchreierSims as SS import Math.Algebra.Group.RandomSchreierSims import Math.Combinatorics.Design as D import Math.Algebra.LinearAlgebra -- ( (<.>), (<+>) ) import Math.Projects.ChevalleyGroup.Classical -} import Test.QuickCheck import Math.Projects.MiniquaternionGeometry -- Near fields prop_NearField (a,b,c) = a+(b+c) == (a+b)+c && -- addition is associative a+b == b+a && -- addition is commutative a+0 == a && -- additive identity a+(-a) == 0 && -- additive inverse a*(b*c) == (a*b)*c && -- multiplication is associative a*1 == a && 1*a == a && -- multiplicative identity (a+b)*c == a*c + b*c && -- right-distributivity a*0 == 0 instance Arbitrary F9 where arbitrary = do x <- arbitrary :: Gen Int return (f9 !! (x `mod` 9)) instance Arbitrary J9 where arbitrary = do x <- arbitrary :: Gen Int return (j9 !! (x `mod` 9)) prop_NearFieldF9 (a,b,c) = prop_NearField (a,b,c) where types = (a,b,c) :: (F9,F9,F9) prop_NearFieldJ9 (a,b,c) = prop_NearField (a,b,c) where types = (a,b,c) :: (J9,J9,J9)