diff --git a/Math/Combinatorics/Species.hs b/Math/Combinatorics/Species.hs --- a/Math/Combinatorics/Species.hs +++ b/Math/Combinatorics/Species.hs @@ -1,53 +1,103 @@ {-# LANGUAGE NoImplicitPrelude #-} --- | A DSL for describing combinatorial species and computing various --- properties. This module re-exports the most generally useful --- functionality; for more specialized functionality (for example, --- computing directly with cycle index series), see the various --- sub-modules. +-- | A DSL for describing and computing with combinatorial species. +-- This module re-exports the most generally useful functionality; +-- for more specialized functionality (for example, computing +-- directly with cycle index series), see the various sub-modules. -- -- Note that this library makes extensive use of the numeric-prelude -- library; to use it you will want to use -XNoImplicitPrelude, and -- import NumericPrelude and PreludeBase. -- --- For a good reference (really, the only English-language --- reference!) on combinatorial species, see Bergeron, Labelle, and --- Leroux, \"Combinatorial Species and Tree-Like Structures\", --- Vol. 67 of the Encyclopedia of Mathematics and its Applications, --- Gian-Carlo Rota, ed., Cambridge University Press, 1998. +-- For a friendly introduction to combinatorial species in general +-- and this library in particular, see my series of blog posts: +-- +-- +-- +-- For a good reference (really, the +-- only English-language reference!) on combinatorial species, see +-- Bergeron, Labelle, and Leroux, \"Combinatorial Species and +-- Tree-Like Structures\", Vol. 67 of the Encyclopedia of +-- Mathematics and its Applications, Gian-Carlo Rota, ed., Cambridge +-- University Press, 1998. module Math.Combinatorics.Species ( -- * The combinatorial species DSL + -- $DSL Species(..) -- ** Convenience methods + -- $synonyms + , oneHole , madeOf - , x, e, sets, cycles - + , (><), (@@) + , x, sets, cycles + , subsets + , ksubsets + , elements + -- ** Derived operations , pointed - , nonEmpty -- ** Derived species , list, lists - , element, elements , octopus, octopi , partition, partitions , permutation, permutations - , subset, subsets , ballot, ballots - , ksubset, ksubsets + , simpleGraph, simpleGraphs + , directedGraph, directedGraphs -- * Computing with species , labelled , unlabelled + + -- * Generating species structures , generate + , generateTyped + , structureType + + -- ** Types used for generation + -- $types + , Identity(..), Const(..) + , Sum(..), Prod(..), Comp(..) + , Star(..), Cycle(..), Set(..) + + -- * Species AST + -- $ast + , SpeciesTypedAST(..) + , SpeciesAST(..) + , reify + , reflect + ) where +import Math.Combinatorics.Species.Types import Math.Combinatorics.Species.Class import Math.Combinatorics.Species.Labelled import Math.Combinatorics.Species.Unlabelled import Math.Combinatorics.Species.Generate - +import Math.Combinatorics.Species.AST +-- $DSL +-- The combinatorial species DSL consists of the 'Species' type class, +-- which defines some primitive species and species operations. +-- Expressions of type @Species s => s@ can then be interpreted at +-- various instance types in order to compute with species in various +-- ways. + +-- $synonyms +-- Some synonyms are provided for convenience. In particular, +-- gramatically it can often be convenient to have both the singular +-- and plural versions of species, for example, @set \`o\` nonEmpty +-- sets@. + +-- $types +-- Many of these functors are already defined elsewhere, in other +-- packages; but to avoid a plethora of imports, inconsistent +-- naming/instance schemes, etc., we just redefine them here. + +-- $ast +-- Species can be converted to and from 'SpeciesAST' via the functions +-- 'reify' and 'reflect'. diff --git a/Math/Combinatorics/Species/AST.hs b/Math/Combinatorics/Species/AST.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/AST.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE NoImplicitPrelude + , GADTs + , TypeOperators + , FlexibleContexts + #-} + +-- | A data structure to reify combinatorial species. +module Math.Combinatorics.Species.AST + ( + SpeciesTypedAST(..) + , SpeciesAST(..) + , needsZT, needsZ + + , reify + , reflectT + , reflect + + ) where + +import Math.Combinatorics.Species.Class +import Math.Combinatorics.Species.Types + +import qualified Algebra.Additive as Additive +import qualified Algebra.Ring as Ring +import qualified Algebra.Differential as Differential + +import Data.Typeable + +import NumericPrelude +import PreludeBase hiding (cycle) + +-- | Reified combinatorial species. Note that 'SpeciesTypedAST' has a +-- phantom type parameter which also reflects the structure, so we +-- can do case analysis on species at both the value and type level. +-- +-- Of course, the non-uniform type parameter means that +-- 'SpeciesTypedAST' cannot be an instance of the 'Species' class; +-- for that purpose the existential wrapper 'SpeciesAST' is +-- provided. +data SpeciesTypedAST s where + O :: SpeciesTypedAST Z + I :: SpeciesTypedAST (S Z) + X :: SpeciesTypedAST X + E :: SpeciesTypedAST E + C :: SpeciesTypedAST C + Subset :: SpeciesTypedAST Sub + KSubset :: Integer -> SpeciesTypedAST Sub + Elt :: SpeciesTypedAST Elt + (:+:) :: (ShowF (StructureF f), ShowF (StructureF g)) + => SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :+: g) + (:*:) :: (ShowF (StructureF f), ShowF (StructureF g)) + => SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :*: g) + (:.:) :: (ShowF (StructureF f), ShowF (StructureF g)) + => SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :.: g) + (:><:) :: (ShowF (StructureF f), ShowF (StructureF g)) + => SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :><: g) + (:@:) :: (ShowF (StructureF f), ShowF (StructureF g)) + => SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :@: g) + Der :: (ShowF (StructureF f)) + => SpeciesTypedAST f -> SpeciesTypedAST (Der f) + OfSize :: SpeciesTypedAST f -> (Integer -> Bool) -> SpeciesTypedAST f + OfSizeExactly :: SpeciesTypedAST f -> Integer -> SpeciesTypedAST f + NonEmpty :: SpeciesTypedAST f -> SpeciesTypedAST f + +instance Show (SpeciesTypedAST s) where + showsPrec _ O = showChar '0' + showsPrec _ I = showChar '1' + showsPrec _ X = showChar 'X' + showsPrec _ E = showChar 'E' + showsPrec _ C = showChar 'C' + showsPrec _ Subset = showChar 'p' + showsPrec _ (KSubset n) = showChar 'p' . shows n + showsPrec _ (Elt) = showChar 'e' + showsPrec p (f :+: g) = showParen (p>6) $ showsPrec 6 f . showString " + " . showsPrec 6 g + showsPrec p (f :*: g) = showParen (p>=7) $ showsPrec 7 f . showString " * " . showsPrec 7 g + showsPrec p (f :.: g) = showParen (p>=7) $ showsPrec 7 f . showString " . " . showsPrec 7 g + showsPrec p (f :><: g) = showParen (p>=7) $ showsPrec 7 f . showString " >< " . showsPrec 7 g + showsPrec p (f :@: g) = showParen (p>=7) $ showsPrec 7 f . showString " @ " . showsPrec 7 g + showsPrec p (Der f) = showsPrec 11 f . showChar '\'' + showsPrec _ (OfSize f p) = showChar '<' . showsPrec 0 f . showChar '>' + showsPrec _ (OfSizeExactly f n) = showsPrec 11 f . shows n + showsPrec _ (NonEmpty f) = showsPrec 11 f . showChar '+' + +-- | 'needsZT' is a predicate which checks whether a species uses any +-- of the operations which are not supported directly by ordinary +-- generating functions (composition, differentiation, cartesian +-- product, and functor composition), and hence need cycle index +-- series. +needsZT :: SpeciesTypedAST s -> Bool +needsZT (f :+: g) = needsZT f || needsZT g +needsZT (f :*: g) = needsZT f || needsZT g +needsZT (_ :.: _) = True +needsZT (_ :><: _) = True +needsZT (_ :@: _) = True +needsZT (Der _) = True +needsZT (OfSize f _) = needsZT f +needsZT (OfSizeExactly f _) = needsZT f +needsZT (NonEmpty f) = needsZT f +needsZT _ = False + +-- | An existential wrapper to hide the phantom type parameter to +-- 'SpeciesTypedAST', so we can make it an instance of 'Species'. +data SpeciesAST where + SA :: (ShowF (StructureF s), Typeable1 (StructureF s)) + => SpeciesTypedAST s -> SpeciesAST + +-- | A version of 'needsZT' for 'SpeciesAST'. +needsZ :: SpeciesAST -> Bool +needsZ (SA s) = needsZT s + +instance Show SpeciesAST where + show (SA f) = show f + +instance Additive.C SpeciesAST where + zero = SA O + (SA f) + (SA g) = SA (f :+: g) + negate = error "negation is not implemented yet! wait until virtual species..." + +instance Ring.C SpeciesAST where + (SA f) * (SA g) = SA (f :*: g) + one = SA I + +instance Differential.C SpeciesAST where + differentiate (SA f) = SA (Der f) + +instance Species SpeciesAST where + singleton = SA X + set = SA E + cycle = SA C + subset = SA Subset + ksubset k = SA (KSubset k) + element = SA Elt + o (SA f) (SA g) = SA (f :.: g) + cartesian (SA f) (SA g) = SA (f :><: g) + fcomp (SA f) (SA g) = SA (f :@: g) + ofSize (SA f) p = SA (OfSize f p) + ofSizeExactly (SA f) n = SA (OfSizeExactly f n) + nonEmpty (SA f) = SA (NonEmpty f) + +-- | Reify a species expression into an AST. Of course, this is just +-- the identity function with a usefully restricted type. For +-- example: +-- +-- > > reify octopus +-- > C . C'+ +-- > > reify (ksubset 3) +-- > E3 * E + +reify :: SpeciesAST -> SpeciesAST +reify = id + +-- | Reflect an AST back into any instance of the 'Species' class. +reflectT :: Species s => SpeciesTypedAST f -> s +reflectT O = zero +reflectT I = one +reflectT X = singleton +reflectT E = set +reflectT C = cycle +reflectT Subset = subset +reflectT (KSubset k) = ksubset k +reflectT Elt = element +reflectT (f :+: g) = reflectT f + reflectT g +reflectT (f :*: g) = reflectT f * reflectT g +reflectT (f :.: g) = reflectT f `o` reflectT g +reflectT (f :><: g) = reflectT f >< reflectT g +reflectT (f :@: g) = reflectT f @@ reflectT g +reflectT (Der f) = oneHole (reflectT f) +reflectT (OfSize f p) = ofSize (reflectT f) p +reflectT (OfSizeExactly f n) = ofSizeExactly (reflectT f) n +reflectT (NonEmpty f) = nonEmpty (reflectT f) + +-- | Reflect an AST back into any instance of the 'Species' class. +reflect :: Species s => SpeciesAST -> s +reflect (SA f) = reflectT f diff --git a/Math/Combinatorics/Species/Algebra.hs b/Math/Combinatorics/Species/Algebra.hs deleted file mode 100644 --- a/Math/Combinatorics/Species/Algebra.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude - , GADTs - , TypeOperators - , FlexibleContexts - #-} - --- | A data structure to reify combinatorial species. -module Math.Combinatorics.Species.Algebra - ( - SpeciesAlgT(..) - , SpeciesAlg(..) - , needsZT, needsZ - - , reify - , reflectT - , reflect - - ) where - -import Math.Combinatorics.Species.Class -import Math.Combinatorics.Species.Types - -import qualified Algebra.Additive as Additive -import qualified Algebra.Ring as Ring -import qualified Algebra.Differential as Differential - -import NumericPrelude -import PreludeBase hiding (cycle) - --- | Reified combinatorial species. Note that 'SpeciesAlgT' has a --- phantom type parameter which also reflects the structure, so we --- can do case analysis on species at both the value and type level. --- --- Of course, the non-uniform type parameter means that --- 'SpeciesAlgT' cannot be an instance of the 'Species' class; for --- that purpose the existential wrapper 'SpeciesAlg' is provided. -data SpeciesAlgT s where - O :: SpeciesAlgT Z - I :: SpeciesAlgT (S Z) - X :: SpeciesAlgT X - (:+:) :: (ShowF (StructureF f), ShowF (StructureF g)) - => SpeciesAlgT f -> SpeciesAlgT g -> SpeciesAlgT (f :+: g) - (:*:) :: (ShowF (StructureF f), ShowF (StructureF g)) - => SpeciesAlgT f -> SpeciesAlgT g -> SpeciesAlgT (f :*: g) - (:.:) :: (ShowF (StructureF f), ShowF (StructureF g)) - => SpeciesAlgT f -> SpeciesAlgT g -> SpeciesAlgT (f :.: g) - Der :: (ShowF (StructureF f)) - => SpeciesAlgT f -> SpeciesAlgT (Der f) - E :: SpeciesAlgT E - C :: SpeciesAlgT C - OfSize :: SpeciesAlgT f -> (Integer -> Bool) -> SpeciesAlgT f - OfSizeExactly :: SpeciesAlgT f -> Integer -> SpeciesAlgT f - --- (:.) :: (ShowF (StructureF f), ShowF (StructureF g)) --- => SpeciesAlgT f -> SpeciesAlgT g -> SpeciesAlgT (f :. g) - --- XXX improve this -instance Show (SpeciesAlgT s) where - show O = "0" - show I = "1" - show X = "X" - show (f :+: g) = "(" ++ show f ++ " + " ++ show g ++ ")" - show (f :*: g) = "(" ++ show f ++ " * " ++ show g ++ ")" - show (f :.: g) = "(" ++ show f ++ " . " ++ show g ++ ")" - show (Der f) = show f ++ "'" - show E = "E" - show C = "C" - show (OfSize f p) = "<" ++ show f ++ ">" - show (OfSizeExactly f n) = show f ++ "_" ++ show n - --- show (f :. g) = show f ++ ".:" ++ show g - --- | 'needsZT' is a predicate which checks whether a species uses any --- of the operations which are not supported directly by ordinary --- generating functions (composition and differentiation), and hence --- need cycle index series. -needsZT :: SpeciesAlgT s -> Bool -needsZT (f :+: g) = needsZT f || needsZT g -needsZT (f :*: g) = needsZT f || needsZT g -needsZT (_ :.: _) = True -needsZT (Der _) = True -needsZT (OfSize f _) = needsZT f -needsZT (OfSizeExactly f _) = needsZT f -needsZT _ = False - --- | An existential wrapper to hide the phantom type parameter to --- 'SpeciesAlgT', so we can make it an instance of 'Species'. -data SpeciesAlg where - SA :: (ShowF (StructureF s)) => SpeciesAlgT s -> SpeciesAlg - --- | A version of 'needsZT' for 'SpeciesAlg'. -needsZ :: SpeciesAlg -> Bool -needsZ (SA s) = needsZT s - -instance Show SpeciesAlg where - show (SA f) = show f - -instance Additive.C SpeciesAlg where - zero = SA O - (SA f) + (SA g) = SA (f :+: g) - negate = error "negation is not implemented yet! wait until virtual species..." - -instance Ring.C SpeciesAlg where - (SA f) * (SA g) = SA (f :*: g) - one = SA I - -instance Differential.C SpeciesAlg where - differentiate (SA f) = SA (Der f) - -instance Species SpeciesAlg where - singleton = SA X - set = SA E - cycle = SA C - o (SA f) (SA g) = SA (f :.: g) - ofSize (SA f) p = SA (OfSize f p) - ofSizeExactly (SA f) n = SA (OfSizeExactly f n) - --- | Reify a species expression into a tree. Of course, this is just --- the identity function with a usefully restricted type. For example: --- --- > > reify octopus --- > (C . C'_+) -reify :: SpeciesAlg -> SpeciesAlg -reify = id - --- | Reflect a species back into any instance of the 'Species' class. -reflectT :: Species s => SpeciesAlgT f -> s -reflectT O = zero -reflectT I = one -reflectT X = singleton -reflectT (f :+: g) = reflectT f + reflectT g -reflectT (f :*: g) = reflectT f * reflectT g -reflectT (f :.: g) = reflectT f `o` reflectT g -reflectT (Der f) = oneHole (reflectT f) -reflectT E = set -reflectT C = cycle -reflectT (OfSize f p) = ofSize (reflectT f) p -reflectT (OfSizeExactly f n) = ofSizeExactly (reflectT f) n - --- | A version of 'reflectT' for the existential wrapper 'SpeciesAlg'. -reflect :: Species s => SpeciesAlg -> s -reflect (SA f) = reflectT f diff --git a/Math/Combinatorics/Species/Class.hs b/Math/Combinatorics/Species/Class.hs --- a/Math/Combinatorics/Species/Class.hs +++ b/Math/Combinatorics/Species/Class.hs @@ -10,32 +10,32 @@ Species(..) -- * Convenience methods - -- $synonyms , oneHole , madeOf + , (><), (@@) , x - , e , sets , cycles + , subsets + , ksubsets + , elements -- * Derived operations -- $derived_ops , pointed - , nonEmpty -- * Derived species -- $derived , list, lists - , element, elements , octopus, octopi , partition, partitions , permutation, permutations - , subset, subsets , ballot, ballots - , ksubset, ksubsets + , simpleGraph, simpleGraphs + , directedGraph, directedGraphs ) where @@ -44,8 +44,6 @@ import NumericPrelude import PreludeBase hiding (cycle) -infixr 5 .: - -- | The Species type class. Note that the @Differential@ constraint -- requires s to be a differentiable ring, which means that every -- instance must also implement instances for "Algebra.Additive" @@ -54,45 +52,100 @@ -- i.e. partitional product), and "Algebra.Differential" (species -- differentiation, i.e. adjoining a distinguished element). -- +-- Minimal complete definition: 'singleton', 'set', 'cycle', 'o', +-- 'cartesian', 'fcomp', 'ofSize'. +-- -- Note that the 'o' operation can be used infix to suggest common -- notation for composition, and also to be read as an abbreviation -- for \"of\", as in \"top o' the mornin'\": @set \`o\` nonEmpty -- sets@. +-- +-- In this version of the library, 'Species' has four instances: +-- 'EGF' (exponential generating functions, for counting labelled +-- structures), 'GF' (ordinary generating function, for counting +-- unlabelled structures), 'CycleIndex' (cycle index series, a +-- generalization of both 'EGF' and 'GF'), and 'SpeciesAST' (reified +-- species expressions). class (Differential.C s) => Species s where - -- | The species X of singletons + -- | The species X of singletons. X puts a singleton structure on an + -- underlying set of size 1, and no structures on any other + -- underlying sets. singleton :: s - -- | The species E of sets + -- | The species E of sets. E puts a singleton structure on any + -- underlying set. set :: s - -- | The species C of cyclical orderings (cycles/rings) + -- | The species C of cyclical orderings (cycles/rings). cycle :: s - -- | Partitional composition + -- | The species p of subsets is given by p = E * E. 'subset' has a + -- default implementation of @set * set@, but is included in the + -- 'Species' class so it can be overridden when generating + -- structures: since subset is defined as @set * set@, the + -- generation code by default generates a pair of the subset and + -- its complement, but normally when thinking about subsets we + -- only want to see the elements in the subset. To explicitly + -- generate subset/complement pairs, you can use @set * set@ + -- directly. + subset :: s + subset = set * set + + -- | Subsets of size exactly k, p[k] = E_k * E. Included with a + -- default definition in the 'Species' class for the same reason + -- as 'subset'. + ksubset :: Integer -> s + ksubset k = (set `ofSizeExactly` k) * set + + -- | Structures of the species e of elements are just elements of + -- the underlying set: e = X * E. Included with default + -- definition in 'Species' class for the same reason as 'subset' + -- and 'ksubset'. + element :: s + element = x * set + + -- | Partitional composition. To form all (F o G)-structures on the + -- underlying set U, first form all set partitions of U; for each + -- partition p, put an F-structure on the classes of p, and a + -- separate G-structure on the elements in each class. o :: s -> s -> s + -- | Cartisian product of two species. An (F x G)-structure + -- consists of an F structure superimposed on a G structure over + -- the same underlying set. + cartesian :: s -> s -> s + + -- | Functor composition of two species. An (F \@\@ G)-structure + -- consists of an F-structure on the set of all G-structures. + fcomp :: s -> s -> s + -- | Only put a structure on underlying sets whose size satisfies -- the predicate. ofSize :: s -> (Integer -> Bool) -> s - -- | Only put a structure on underlying sets of the given size. We - -- include this as a special case, instead of just using @ofSize - -- (==k)@, since it can be more efficient: we get to turn infinite - -- lists of coefficients into finite ones. + -- | Only put a structure on underlying sets of the given size. A + -- default implementation of @ofSize (==k)@ is provided, but this + -- method is included in the 'Species' class as a special case + -- since it can be more efficient: we get to turn infinite lists + -- of coefficients into finite ones. ofSizeExactly :: s -> Integer -> s + ofSizeExactly s n = s `ofSize` (==n) - -- | @s1 .: s2@ is the species which puts an s1 structure on the - -- empty set and an s2 structure on anything else. Useful for - -- getting recursively defined species off the ground. - (.:) :: s -> s -> s + -- | Don't put a structure on the empty set. The default definition + -- uses 'ofSize'; included in the 'Species' class so it can be + -- overriden in special cases (such as when reifying species + -- expressions). + nonEmpty :: s -> s + nonEmpty = flip ofSize (>0) --- $synonyms --- Some synonyms are provided for convenience. In particular, --- gramatically it can often be convenient to have both the singular --- and plural versions of species, for example, @set \`o\` nonEmpty --- sets@. + -- | @rec n s f@ is the species which puts an s-structure on label + -- sets of size <= n, and which are described recusively by (fix + -- f) for larger label sets. + -- rec :: Integer -> s -> (s -> s) -> s + + -- | A convenient synonym for differentiation. F'-structures look -- like F-structures on a set formed by adjoining a distinguished -- \"hole\" element to the underlying set. @@ -103,14 +156,18 @@ madeOf :: Species s => s -> s -> s madeOf = o +-- | A synonym for cartesian product. +(><) :: Species s => s -> s -> s +(><) = cartesian + +-- | A synonym for functor composition. +(@@) :: Species s => s -> s -> s +(@@) = fcomp + -- | A synonym for 'singleton'. x :: Species s => s x = singleton --- | A synonym for 'set'. -e :: Species s => s -e = set - sets :: Species s => s sets = set @@ -126,11 +183,6 @@ pointed :: Species s => s -> s pointed = (x *) . Differential.differentiate --- | Don't put a structure on the empty set. -nonEmpty :: Species s => s -> s -nonEmpty = flip ofSize (>0) - - -- $derived -- Some species that can be defined in terms of the primitive species -- operations. @@ -140,14 +192,10 @@ list :: Species s => s list = oneHole cycle --- | A convenient synonym for 'list'. lists :: Species s => s lists = list --- | Structures of the species eps of elements are just elements of --- the underlying set: eps = X * E. -elements, element :: Species s => s -element = x * e +elements :: Species s => s elements = element -- | An octopus is a cyclic arrangement of lists, so called because @@ -168,9 +216,7 @@ permutation = set `o` cycles permutations = permutation --- | The species p of subsets is given by p = E * E. -subsets, subset :: Species s => s -subset = set * set +subsets :: Species s => s subsets = subset -- | The species Bal of ballots consists of linear orderings of @@ -179,7 +225,19 @@ ballot = list `o` nonEmpty sets ballots = ballot --- | Subsets of size exactly k, p[k] = E_k * E. -ksubsets, ksubset :: Species s => Integer -> s -ksubset k = (set `ofSizeExactly` k) * set +ksubsets :: Species s => Integer -> s ksubsets = ksubset + +-- | Simple graphs (undirected, without loops). A simple graph is a +-- subset of the set of all size-two subsets of the vertices: G = p +-- \@\@ p_2. +simpleGraphs, simpleGraph :: Species s => s +simpleGraph = subset @@ (ksubset 2) +simpleGraphs = simpleGraph + +-- | A directed graph (with loops) is a subset of all pairs drawn +-- (without replacement) from the set of vertices: D = p \@\@ (e >< +-- e). It can also be thought of as the species of binary relations. +directedGraphs, directedGraph :: Species s => s +directedGraph = subset @@ (element >< element) +directedGraphs = directedGraph diff --git a/Math/Combinatorics/Species/CycleIndex.hs b/Math/Combinatorics/Species/CycleIndex.hs --- a/Math/Combinatorics/Species/CycleIndex.hs +++ b/Math/Combinatorics/Species/CycleIndex.hs @@ -1,13 +1,21 @@ -{-# LANGUAGE NoImplicitPrelude +{-# LANGUAGE NoImplicitPrelude , FlexibleInstances #-} -- | An instance of 'Species' for cycle index series. For details on -- cycle index series, see \"Combinatorial Species and Tree-Like -- Structures\", chapter 1. -module Math.Combinatorics.Species.CycleIndex +module Math.Combinatorics.Species.CycleIndex ( zToEGF , zToGF + + , zCoeff + , zFix + + -- * Miscellaneous + , aut + , intPartitions + , cyclePower ) where import Math.Combinatorics.Species.Types @@ -20,9 +28,11 @@ import qualified MathObj.FactoredRational as FQ import qualified Algebra.Ring as Ring +import qualified Algebra.ZeroTestable as ZeroTestable import qualified Data.Map as M -import Data.List (genericReplicate, genericDrop, groupBy, sort, intercalate) +import Data.List ( genericReplicate, genericDrop, groupBy, sort, intercalate, scanl + , genericIndex) import Data.Function (on) import Control.Arrow ((&&&), first, second) @@ -37,39 +47,42 @@ o = liftCI2 MVP.compose + cartesian = liftCI2 . MVP.lift2 $ \x y -> hadamard x y + + fcomp = zFComp + ofSize s p = (liftCI . MVP.lift1 $ filter (p . Monomial.pDegree)) s ofSizeExactly s n = (liftCI . MVP.lift1 $ ( takeWhile ((==n) . Monomial.pDegree) . dropWhile (( Monomial.T Rational -partToMonomial js = Monomial.Cons (zCoeff js) (M.fromList js) +partToMonomial :: CycleType -> Monomial.T Rational +partToMonomial js = Monomial.Cons (ezCoeff js) (M.fromList js) --- | @'zCoeff' js@ is the coefficient of the corresponding monomial in +-- | @'ezCoeff' js@ is the coefficient of the corresponding monomial in -- the cycle index series for the species of sets. -zCoeff :: [(Integer, Integer)] -> Rational -zCoeff js = toRational $ 1 / aut js +ezCoeff :: CycleType -> Rational +ezCoeff js = toRational $ 1 / aut js -- | @aut js@ is is the number of automorphisms of a permutation with -- cycle type @js@ (i.e. a permutation which has @n@ cycles of size --- @i@ for each @(i,n)@ in @js@). -aut :: [(Integer, Integer)] -> FQ.T +-- @i@ for each @(i,n)@ in @js@). Another way to look at it is that +-- there are @n!/aut js@ permutations on n elements with cycle type +-- @js@. The result type is a @'FactoredRational.T'@. +aut :: CycleType -> FQ.T aut = product . map (\(b,e) -> FQ.factorial e * (fromInteger b)^e) -- | Generate all partitions of an integer. In particular, if @p@ is -- an element of the list output by @intPartitions n@, then @sum --- . map (uncurry (*)) $ p == n@. +-- . map (uncurry (*)) $ p == n@. The result type is @[CycleType]@ +-- since each integer partition of @n@ corresponds to the cycle type +-- of a permutation on @n@ elements. -- --- Also, the partitions are generated in an order corresponding to +-- The partitions are generated in an order corresponding to -- the Ord instance for 'Monomial'. -intPartitions :: Integer -> [[(Integer, Integer)]] +intPartitions :: Integer -> [CycleType] intPartitions n = intPartitions' n n where intPartitions' :: Integer -> Integer -> [[(Integer,Integer)]] intPartitions' 0 _ = [[]] @@ -117,7 +130,116 @@ insertZeros = insertZeros' [0..] where insertZeros' _ [] = [] - insertZeros' (n:ns) ((pow,c):pcs) - | n < pow = genericReplicate (pow - n) 0 + insertZeros' (n:ns) ((pow,c):pcs) + | n < pow = genericReplicate (pow - n) 0 ++ insertZeros' (genericDrop (pow - n) (n:ns)) ((pow,c):pcs) | otherwise = c : insertZeros' ns pcs + +-- | Hadamard product. +hadamard :: (Ring.C a, ZeroTestable.C a) => [Monomial.T a] -> [Monomial.T a] -> [Monomial.T a] +hadamard = MVP.merge False zap + where zap m1 m2 = Monomial.Cons (Monomial.coeff m1 * Monomial.coeff m2 * + (fromInteger . toInteger . aut . M.assocs . Monomial.powers $ m1)) + (Monomial.powers m1) + +-- | @cyclePower s n@ computes the cycle type of sigma^n, where sigma +-- is any permutation of cycle type s. +-- +-- In particular, if s = (s_1, s_2, s_3, ...) (i.e. sigma has s_1 +-- fixed points, s_2 2-cycles, ... s_k k-cycles), then +-- +-- sigma^n_j = sum_{j*gcd(n,k) = k} gcd(n,k)*s_k +cyclePower :: CycleType -> Integer -> CycleType +cyclePower [] _ = [] +cyclePower s n = concatMap jCycles [1..maximum (map fst s)] + where jCycles j = let snj = sum . map (\(k,sk) -> if j*gcd n k == k then gcd n k * sk else 0) $ s + in [ (j, snj) | snj > 0 ] + +-- | Extract a particular coefficient from a cycle index series. +zCoeff :: CycleIndex -> CycleType -> Rational +zCoeff (CI (MVP.Cons z)) ix = c + where ixm = Monomial.mkMonomial 1 ix + z' = dropWhile ( 0 + (m:_) -> if (Monomial.powers m == Monomial.powers ixm) + then Monomial.coeff m + else 0 + +-- | Compute @fix F[n]@, i.e. the number of F-structures fixed by a +-- permutation with cycle type n, given the cycle index series Z_F. +-- +-- In particular, @fix F[n] = aut(n) * zCoeff Z_F n@. +zFix :: CycleIndex -> CycleType -> Integer +zFix z n = numerator $ toRational (aut n) * zCoeff z n + +-- | Functor composition for cycle index series. See BLL pp. 72--73. +-- +-- We have +-- +-- Z_F \@ Z_G = sum_{n>=0} +-- sum_{nn \in Par(n)} +-- 1/aut(nn) * fix F[(G[nn])_1, (G[nn])_2, ...] +-- * x_1^nn_1 x_2^nn_2 ... +-- +-- where +-- +-- (G[nn])_k = 1/k sum_{d|k} \mu(k/d) fix G[nn^d] +-- +-- and we use (G[nn])_k to denote (G[sigma])_k, the number of +-- k-cycles in the image of sigma under G, where sigma has cycle +-- type nn. In fact, this only depends on the cycle type nn and not +-- on sigma, so the notation is well-defined. +-- +-- How to know how far to compute G[nn]? We know that nn is a +-- permutation of n labels, so we can compute G(n) (by converting to +-- an egf) and keep computing elements of G[nn] until the partition +-- degree equals G(n). +zFComp :: CycleIndex -> CycleIndex -> CycleIndex +zFComp f g = ciFromMonomials $ + concat $ for [0..] $ \n -> + for (intPartitions n) $ \nn -> + Monomial.mkMonomial + (toRational (1 / aut nn) * (zFix f (gnn nn n) % 1)) + nn + + where for = flip map + + -- Convert g to an EGF for later reference. + gEGF = labelled $ zToEGF g + + -- Given a cycle type @nn@ (corresponding to a permutation + -- sigma on @n@ elements), compute the cycle type of G[sigma], + -- which we abbreviate G[nn] since it is determined by the + -- cycle type. + -- + -- We first use gnn' to compute an infinite list of (cycle + -- size, count) pairs, then truncate it to the right length: + -- we know how many G-structures there are on a set of size n, + -- so we know we are looking for a permutation on that many + -- elements. + gnn :: CycleType -> Integer -> CycleType + gnn [] _ = [] + gnn nn n = (gnn' nn) `truncToPartitionOf` (gEGF `genericIndex` n) + + -- Compute the image of a cycle type under G. + gnn' :: CycleType -> CycleType + gnn' nn = concat $ for [1..] $ \k -> let xk = gnnk nn k + in [ (k,xk) | xk > 0 ] + + -- Compute (G[nn])_k for a particular k, that is, the number + -- of cycles of size k in the image under G of any permutation + -- with cycle type nn. + gnnk :: CycleType -> Integer -> Integer + gnnk nn k = (`div` k) . sum $ + for (FQ.divisors k') $ \d -> + FQ.mu (k'/d) * zFix g (cyclePower nn (toInteger d)) + where k' = fromIntegral k + + truncToPartitionOf :: CycleType -> Integer -> CycleType + truncToPartitionOf _ 0 = [] + truncToPartitionOf p n = map snd $ takeUntil ((>=n) . fst) partials + where partials = zip (tail $ scanl (\soFar cyc -> soFar + uncurry (*) cyc) 0 p) p + takeUntil p [] = [] + takeUntil p (x:xs) | p x = [x] + | otherwise = x : takeUntil p xs diff --git a/Math/Combinatorics/Species/Generate.hs b/Math/Combinatorics/Species/Generate.hs --- a/Math/Combinatorics/Species/Generate.hs +++ b/Math/Combinatorics/Species/Generate.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE NoImplicitPrelude +{-# LANGUAGE NoImplicitPrelude , GADTs , MultiParamTypeClasses , FlexibleInstances , FlexibleContexts + , ScopedTypeVariables #-} -- | Generation of species: given a species and an underlying set of @@ -12,64 +13,85 @@ ( generateF , Structure(..) , generate + , generateTyped + , structureType ) where import Math.Combinatorics.Species.Class import Math.Combinatorics.Species.Types -import Math.Combinatorics.Species.Algebra +import Math.Combinatorics.Species.AST +import Math.Combinatorics.Species.CycleIndex (intPartitions) import Control.Arrow (first, second) -import Data.List (genericLength) +import Data.List (genericLength, genericReplicate) +import Data.Typeable + import NumericPrelude import PreludeBase hiding (cycle) -- | Given an AST describing a species, with a phantom type parameter -- describing the species at the type level, and an underlying set, -- generate a list of all possible structures built over the --- underlying set. Of course, the type of the output list is a +-- underlying set; the type of the output list is a -- function of the species structure. (Of course, it would be -- really nice to have a real dependently-typed language for this!) -- --- Unfortunately, 'SpeciesAlgT' cannot be made an instance of +-- Unfortunately, 'SpeciesTypedAST' cannot be made an instance of -- 'Species', so if we want to be able to generate structures given -- an expression of the 'Species' DSL as input, we must take --- 'SpeciesAlg' as input, which existentially wraps the phantom +-- 'SpeciesAST' as input, which existentially wraps the phantom -- structure type---but this means that the output list type must be --- existentially quantified as well; see 'generate' below. -generateF :: SpeciesAlgT s -> [a] -> [StructureF s a] -generateF O _ = [] -generateF I [] = [Const 1] -generateF I _ = [] -generateF X [x] = [Identity x] -generateF X _ = [] -generateF (f :+: g) xs = map (Sum . Left ) (generateF f xs) - ++ map (Sum . Right) (generateF g xs) -generateF (f :*: g) xs = [ Prod (x, y) | (s1,s2) <- pSet xs - , x <- generateF f s1 - , y <- generateF g s2 - ] -generateF (f :.: g) xs = [ Comp y | p <- sPartitions xs - , xs <- mapM (generateF g) p - , y <- generateF f xs - ] -generateF (Der f) xs = map Comp $ generateF f (Star : map Original xs) -generateF E xs = [xs] -generateF C [] = [] -generateF C (x:xs) = map (Cycle . (x:)) (sPermutations xs) +-- existentially quantified as well; see 'generate' and +-- 'generateTyped' below. +generateF :: SpeciesTypedAST s -> [a] -> [StructureF s a] +generateF O _ = [] +generateF I [] = [Const 1] +generateF I _ = [] +generateF X [x] = [Identity x] +generateF X _ = [] +generateF E xs = [Set xs] +generateF C [] = [] +generateF C (x:xs) = map (Cycle . (x:)) (sPermutations xs) +generateF Subset xs = map (Set . fst) (pSet xs) +generateF (KSubset k) xs = map Set (sKSubsets k xs) +generateF Elt xs = map Identity xs +generateF (f :+: g) xs = map (Sum . Left ) (generateF f xs) + ++ map (Sum . Right) (generateF g xs) +generateF (f :*: g) xs = [ Prod (x, y) | (s1,s2) <- pSet xs + , x <- generateF f s1 + , y <- generateF g s2 + ] +generateF (f :.: g) xs = [ Comp y | p <- sPartitions xs + , xs <- mapM (generateF g) p + , y <- generateF f xs + ] +generateF (f :><: g) xs = [ Prod (x,y) | x <- generateF f xs + , y <- generateF g xs ] +generateF (f :@: g) xs = map Comp $ generateF f (generateF g xs) +generateF (Der f) xs = map Comp $ generateF f (Star : map Original xs) + generateF (OfSize f p) xs | p (genericLength xs) = generateF f xs | otherwise = [] generateF (OfSizeExactly f n) xs | genericLength xs == n = generateF f xs | otherwise = [] +generateF (NonEmpty f) [] = [] +generateF (NonEmpty f) xs = generateF f xs -- | @pSet xs@ generates the power set of @xs@, yielding a list of -- subsets of @xs@ paired with their complements. pSet :: [a] -> [([a],[a])] pSet [] = [([],[])] -pSet (x:xs) = mapx first ++ mapx second +pSet (x:xs) = mapx first ++ mapx second where mapx which = map (which (x:)) $ pSet xs +-- | @sKSubsets k xs@ generate all the size-k subsets of @xs@. +sKSubsets :: Integer -> [a] -> [[a]] +sKSubsets 0 _ = [[]] +sKSubsets _ [] = [] +sKSubsets n (x:xs) = map (x:) (sKSubsets (n-1) xs) ++ sKSubsets n xs + -- | Generate all partitions of a set. sPartitions :: [a] -> [[[a]]] sPartitions [] = [[]] @@ -90,37 +112,129 @@ select [] = [] select (x:xs) = (x,xs) : map (second (x:)) (select xs) --- | An existential wrapper for structures. For now we just ensure --- that they are Showable; in a future version of the library I hope --- to be able to add a Typeable constraint as well, so that we can --- actually usefully recover the generated values if we know what --- type we are expecting. +-- | An existential wrapper for structures, ensuring that the +-- structure functor results in something Showable and Typeable (when +-- applied to a Showable and Typeable argument type). data Structure a where - Structure :: (ShowF f) => f a -> Structure a + Structure :: (ShowF f, Typeable1 f, Functor f) => f a -> Structure a instance (Show a) => Show (Structure a) where show (Structure t) = showF t --- | We can generate structures from a 'SpeciesAlg' (which is an --- instance of 'Species') only if we existentially quantify over the --- output type. However, we have guaranteed that the structures --- will be Showable. For example: +instance Functor Structure where + fmap f (Structure fa) = Structure (fmap f fa) + +extractStructure :: (Typeable1 f, Typeable a) => Structure a -> Maybe (f a) +extractStructure (Structure s) = cast s + +-- | @generate s ls@ generates a complete list of all s-structures +-- over the underlying set of labels @ls@. For example: -- -- > > generate octopi ([1,2,3] :: [Int]) --- > [{{*,1,2,3}},{{*,1,3,2}},{{*,2,1,3}},{{*,2,3,1}},{{*,3,1,2}},{{*,3,2,1}}, --- > {{*,1,2},{*,3}},{{*,2,1},{*,3}},{{*,1,3},{*,2}},{{*,3,1},{*,2}},{{*,1}, --- > {*,2,3}},{{*,1},{*,3,2}},{{*,1},{*,2},{*,3}},{{*,1},{*,3},{*,2}}] +-- > [<<*,1,2,3>>,<<*,1,3,2>>,<<*,2,1,3>>,<<*,2,3,1>>,<<*,3,1,2>>,<<*,3,2,1>>, +-- > <<*,1,2>,<*,3>>,<<*,2,1>,<*,3>>,<<*,1,3>,<*,2>>,<<*,3,1>,<*,2>>,<<*,1>, +-- > <*,2,3>>,<<*,1>,<*,3,2>>,<<*,1>,<*,2>,<*,3>>,<<*,1>,<*,3>,<*,2>>] +-- > +-- > > generate subsets "abc" +-- > [{'a','b','c'},{'a','b'},{'a','c'},{'a'},{'b','c'},{'b'},{'c'},{}] -- --- Of course, this is not the output we might hope for; octopi are --- cycles of lists, but above we are seeing the fact that lists are --- implemented as the derivative of cycles, so each list is --- represented by a cycle containing *. In a future version of this --- library I plan to implement a system for automatically converting --- between isomorphic structures during species generation. -generate :: SpeciesAlg -> [a] -> [Structure a] +-- > > generate simpleGraphs ([1,2,3] :: [Int]) +-- > [{{1,2},{1,3},{2,3}},{{1,2},{1,3}},{{1,2},{2,3}},{{1,2}},{{1,3},{2,3}}, +-- > {{1,3}},{{2,3}},{}] +-- +-- There is one caveat: since the type of the generated structures +-- is different for each species, it must be existentially +-- quantified! The output of 'generate' can always be Shown, but +-- not much else. +-- +-- However! All is not lost. It's possible, by the magic of +-- "Data.Typeable", to yank the type information (kicking and +-- screaming) back into the open, so that you can then manipulate +-- the generated structures to your heart's content. To see how, +-- consult 'structureType' and 'generateTyped'. +generate :: SpeciesAST -> [a] -> [Structure a] generate (SA s) xs = map Structure (generateF s xs) +-- | @generateTyped s ls@ generates a complete list of all s-structures +-- over the underlying set of labels @ls@, where the type of the +-- generated structures is known ('structureType' may be used to +-- compute this type). For example: +-- +-- > > structureType subsets +-- > "Set" +-- > > generateTyped subsets ([1,2,3] :: [Int]) :: [Set Int] +-- > [{1,2,3},{1,2},{1,3},{1},{2,3},{2},{3},{}] +-- > > map (sum . getSet) $ it +-- > [6,3,4,1,5,2,3,0] +-- +-- Although the output from 'generate' appears the same, trying to +-- compute the subset sums fails spectacularly if we use 'generate' +-- instead of 'generateTyped': +-- +-- > > generate subsets ([1..3] :: [Int]) +-- > [{1,2,3},{1,2},{1,3},{1},{2,3},{2},{3},{}] +-- > > map (sum . getSet) $ it +-- > :1:21: +-- > Couldn't match expected type `Set a' +-- > against inferred type `Math.Combinatorics.Species.Generate.Structure +-- > Int' +-- > Expected type: [Set a] +-- > Inferred type: [Math.Combinatorics.Species.Generate.Structure Int] +-- > In the second argument of `($)', namely `it' +-- > In the expression: map (sum . getSet) $ it +-- +-- If we use the wrong type, we get a nice error message: +-- +-- > > generateTyped octopi ([1..3] :: [Int]) :: [Set Int] +-- > *** Exception: structure type mismatch. +-- > Expected: Set Int +-- > Inferred: Comp Cycle (Comp Cycle Star) Int +generateTyped :: forall f a. (Typeable1 f, Typeable a) => SpeciesAST -> [a] -> [f a] +generateTyped s xs = + case (mapM extractStructure . generate s $ xs) of + Nothing -> error $ + "structure type mismatch.\n" + ++ " Expected: " ++ showStructureType (typeOf (undefined :: f a)) ++ "\n" + ++ " Inferred: " ++ structureType s ++ " " ++ show (typeOf (undefined :: a)) + Just ys -> ys +-- | @'structureType' s@ returns a String representation of the +-- functor type which represents the structure of the species @s@. +-- In particular, if @structureType s@ prints @\"T\"@, then you can +-- safely use 'generateTyped' by writing +-- +-- > generateTyped s ls :: [T L] +-- +-- where @ls :: [L]@. +structureType :: SpeciesAST -> String +structureType (SA s) = showStructureType . extractType $ s + where extractType :: forall s. Typeable1 (StructureF s) => SpeciesTypedAST s -> TypeRep + extractType _ = typeOf1 (undefined :: StructureF s ()) + +-- | Show a TypeRep while stripping off qualifier portions of TyCon +-- names. This is essentially copied and pasted from the +-- Data.Typeable source, with a number of cases taken out that we +-- don't care about (special cases for (->), tuples, etc.). +showStructureType :: TypeRep -> String +showStructureType t = showsPrecST 0 t "" + where showsPrecST :: Int -> TypeRep -> ShowS + showsPrecST p t = + case splitTyConApp t of + (tycon, []) -> showString (dropQuals $ tyConString tycon) + (tycon, args) -> showParen (p > 9) + $ showString (dropQuals $ tyConString tycon) + . showChar ' ' + . showArgsST args + + showArgsST :: [TypeRep] -> ShowS + showArgsST [] = id + showArgsST [t] = showsPrecST 10 t + showArgsST (t:ts) = showsPrecST 10 t . showChar ' ' . showArgsST ts + + dropQuals :: String -> String + dropQuals = reverse . takeWhile (/= '.') . reverse + + -- Experimental stuff below, automatically converting between -- isomorphic structures. -- @@ -140,5 +254,48 @@ -- instance (Iso f1 f2, Iso g1 g2) => Iso (Prod f1 g1) (Prod f2 g2) where -- iso (Prod (x,y)) = Prod (iso x, iso y) --- generateFI :: (Iso (StructureF s) f) => SpeciesAlgT s -> [a] -> [f a] +-- generateFI :: (Iso (StructureF s) f) => SpeciesTypedAST s -> [a] -> [f a] -- generateFI s xs = map iso $ generateF s xs + + + +-- More old code below: a first try at *unlabelled* generation, but +-- it's not quite so easy---for exactly the same reasons that ordinary +-- generating function composition/derivative etc. don't correspond to +-- species operations. + +-- | Given an AST describing a species, with a phantom type parameter +-- describing the species at the type level, and the size of the +-- underlying set, generate a list of all possible unlabelled +-- structures built by the species. +-- generateFU :: SpeciesTypedAST s -> Integer -> [StructureF s ()] +-- generateFU O _ = [] +-- generateFU I 0 = [Const 1] +-- generateFU I _ = [] +-- generateFU X 1 = [Identity ()] +-- generateFU X _ = [] +-- generateFU (f :+: g) n = map (Sum . Left ) (generateFU f n) +-- ++ map (Sum . Right) (generateFU g n) +-- generateFU (f :*: g) n = [ Prod (x, y) | n1 <- [0..n] +-- , x <- generateFU f n1 +-- , y <- generateFU g (n - n1) +-- ] +-- generateFU (f :.: g) n = [ Comp y | p <- intPartitions n +-- , xs <- mapM (generateFU g) $ expandPartition p +-- , y <- generateF f xs +-- ] +-- -- generateFU (Der f) n = map -- XXX how to do this? +-- generateFU E n = [Set $ genericReplicate n ()] +-- generateFU C 0 = [] +-- generateFU C n = [Cycle $ genericReplicate n ()] +-- generateFU (OfSize f p) n | p n = generateFU f n +-- | otherwise = [] +-- generateFU (OfSizeExactly f s) n | s == n = generateFU f n +-- | otherwise = [] +-- generateFU (f :><: g) n = [ Prod (x,y) | x <- generateFU f n +-- , y <- generateFU g n +-- ] + +-- expandPartition :: [(Integer, Integer)] -> [Integer] +-- expandPartition = concatMap (uncurry (flip genericReplicate)) + diff --git a/Math/Combinatorics/Species/Labelled.hs b/Math/Combinatorics/Species/Labelled.hs --- a/Math/Combinatorics/Species/Labelled.hs +++ b/Math/Combinatorics/Species/Labelled.hs @@ -12,6 +12,7 @@ import Math.Combinatorics.Species.Class import qualified MathObj.PowerSeries as PS +import qualified MathObj.FactoredRational as FQ import NumericPrelude import PreludeBase hiding (cycle) @@ -24,11 +25,18 @@ set = egfFromCoeffs (map (LR . (1%)) facts) cycle = egfFromCoeffs (0 : map (LR . (1%)) [1..]) o = liftEGF2 PS.compose + cartesian = liftEGF2 . PS.lift2 $ \xs ys -> zipWith3 mult xs ys (map fromIntegral facts) + where mult x y z = x * y * z + fcomp = liftEGF2 . PS.lift2 $ \fs gs -> map (\(n,gn) -> let gn' = numerator . unLR $ gn + in (fs `safeIndex` gn') + * LR (toRational (FQ.factorial gn' / FQ.factorial n))) + (zip [0..] $ zipWith (*) (map fromIntegral facts) gs) + where safeIndex [] _ = 0 + safeIndex (x:_) 0 = x + safeIndex (_:xs) n = safeIndex xs (n-1) + ofSize s p = (liftEGF . PS.lift1 $ filterCoeffs p) s ofSizeExactly s n = (liftEGF . PS.lift1 $ selectIndex n) s - - (EGF (PS.Cons (x:_))) .: EGF (PS.Cons ~(_:xs)) - = EGF (PS.Cons (x:xs)) -- | Extract the coefficients of an exponential generating function as -- a list of Integers. Since 'EGF' is an instance of diff --git a/Math/Combinatorics/Species/Types.hs b/Math/Combinatorics/Species/Types.hs --- a/Math/Combinatorics/Species/Types.hs +++ b/Math/Combinatorics/Species/Types.hs @@ -4,13 +4,19 @@ , TypeOperators , FlexibleContexts , GeneralizedNewtypeDeriving + , DeriveDataTypeable #-} --- | Some common types used by the species library. +-- | Some common types used by the species library, along with some +-- utility functions. module Math.Combinatorics.Species.Types - ( -- * Lazy multiplication - - LazyRing(..) + ( -- * Miscellaneous + + CycleType + + -- * Lazy multiplication + + , LazyRing(..) , LazyQ , LazyZ @@ -48,12 +54,13 @@ , Prod(..) , Comp(..) , Cycle(..) + , Set(..) , Star(..) -- * Type-level species - -- $typespecies - - , Z, S, X, (:+:), (:*:), (:.:), Der, E, C, NonEmpty + -- $typespecies + + , Z, S, X, E, C, Sub, Elt, (:+:), (:*:), (:.:), (:><:), (:@:), Der , StructureF ) where @@ -73,6 +80,13 @@ import Data.Lub (parCommute, HasLub(..), flatLub) +import Data.Typeable + +-- | A representation of the cycle type of a permutation. If @c :: +-- CycleType@ and @(k,n) `elem` c@, then the permutation has @n@ +-- cycles of size @k@. +type CycleType = [(Integer, Integer)] + -------------------------------------------------------------------------------- -- Lazy multiplication ------------------------------------------------------- -------------------------------------------------------------------------------- @@ -113,7 +127,7 @@ liftEGF :: (PS.T LazyQ -> PS.T LazyQ) -> EGF -> EGF liftEGF f (EGF x) = EGF (f x) -liftEGF2 :: (PS.T LazyQ -> PS.T LazyQ -> PS.T LazyQ) +liftEGF2 :: (PS.T LazyQ -> PS.T LazyQ -> PS.T LazyQ) -> EGF -> EGF -> EGF liftEGF2 f (EGF x) (EGF y) = EGF (f x y) @@ -127,7 +141,7 @@ liftGF :: (PS.T Integer -> PS.T Integer) -> GF -> GF liftGF f (GF x) = GF (f x) -liftGF2 :: (PS.T Integer -> PS.T Integer -> PS.T Integer) +liftGF2 :: (PS.T Integer -> PS.T Integer -> PS.T Integer) -> GF -> GF -> GF liftGF2 f (GF x) (GF y) = GF (f x y) @@ -193,7 +207,10 @@ -------------------------------------------------------------------------------- -- $struct --- Functors used in building up structures for species generation. +-- Functors used in building up structures for species +-- generation. Many of these functors are already defined elsewhere, +-- in other packages; but to avoid a plethora of imports, inconsistent +-- naming/instance schemes, etc., we just redefine them here. -- | The constant functor. newtype Const x a = Const x @@ -203,9 +220,14 @@ show (Const x) = show x instance (Show x) => ShowF (Const x) where showF = show +instance Typeable2 Const where + typeOf2 _ = mkTyConApp (mkTyCon "Const") [] +instance Typeable x => Typeable1 (Const x) where + typeOf1 = typeOf1Default -- | The identity functor. newtype Identity a = Identity a + deriving Typeable instance Functor Identity where fmap f (Identity x) = Identity (f x) instance (Show a) => Show (Identity a) where @@ -219,10 +241,17 @@ fmap f (Sum (Left fa)) = Sum (Left (fmap f fa)) fmap f (Sum (Right ga)) = Sum (Right (fmap f ga)) instance (Show (f a), Show (g a)) => Show (Sum f g a) where - show (Sum x) = show x + show (Sum (Left fa)) = "inl(" ++ show fa ++ ")" + show (Sum (Right ga)) = "inr(" ++ show ga ++ ")" instance (ShowF f, ShowF g) => ShowF (Sum f g) where showF (Sum (Left fa)) = "inl(" ++ showF fa ++ ")" showF (Sum (Right ga)) = "inr(" ++ showF ga ++ ")" +instance (Typeable1 f, Typeable1 g) => Typeable1 (Sum f g) where + typeOf1 x = mkTyConApp (mkTyCon "Math.Combinatorics.Species.Types.Sum") [typeOf1 (getF x), typeOf1 (getG x)] + where getF :: Sum f g a -> f a + getF = undefined + getG :: Sum f g a -> g a + getG = undefined -- | Functor product. newtype Prod f g a = Prod { unProd :: (f a, g a) } @@ -232,6 +261,12 @@ show (Prod x) = show x instance (ShowF f, ShowF g) => ShowF (Prod f g) where showF (Prod (fa, ga)) = "(" ++ showF fa ++ "," ++ showF ga ++ ")" +instance (Typeable1 f, Typeable1 g) => Typeable1 (Prod f g) where + typeOf1 x = mkTyConApp (mkTyCon "Math.Combinatorics.Species.Types.Prod") [typeOf1 (getF x), typeOf1 (getG x)] + where getF :: Prod f g a -> f a + getF = undefined + getG :: Prod f g a -> g a + getG = undefined -- | Functor composition. data Comp f g a = Comp { unComp :: (f (g a)) } @@ -241,21 +276,37 @@ show (Comp x) = show x instance (ShowF f, ShowF g) => ShowF (Comp f g) where showF (Comp fga) = showF (fmap (RawString . showF) fga) +instance (Typeable1 f, Typeable1 g) => Typeable1 (Comp f g) where + typeOf1 x = mkTyConApp (mkTyCon "Math.Combinatorics.Species.Types.Comp") [typeOf1 (getF x), typeOf1 (getG x)] + where getF :: Comp f g a -> f a + getF = undefined + getG :: Comp f g a -> g a + getG = undefined -- | Cycle structure. A value of type 'Cycle a' is implemented as -- '[a]', but thought of as a directed cycle. -newtype Cycle a = Cycle [a] -instance Functor Cycle where - fmap f (Cycle xs) = Cycle (fmap f xs) +newtype Cycle a = Cycle { getCycle :: [a] } + deriving (Functor, Typeable) instance (Show a) => Show (Cycle a) where - show (Cycle xs) = "{" ++ intercalate "," (map show xs) ++ "}" + show (Cycle xs) = "<" ++ intercalate "," (map show xs) ++ ">" instance ShowF Cycle where showF = show + +-- | Set structure. A value of type 'Set a' is implemented as '[a]', +-- but thought of as an unordered set. +newtype Set a = Set { getSet :: [a] } + deriving (Functor, Typeable) +instance (Show a) => Show (Set a) where + show (Set xs) = "{" ++ intercalate "," (map show xs) ++ "}" +instance ShowF Set where + showF = show + -- | 'Star' is isomorphic to 'Maybe', but with a more useful 'Show' -- instance for our purposes. Used to implement species -- differentiation. data Star a = Star | Original a + deriving (Typeable) instance Functor Star where fmap _ Star = Star fmap f (Original a) = Original (f a) @@ -270,21 +321,24 @@ -------------------------------------------------------------------------------- -- $typespecies --- Some constructor-less data types used as indices to 'SpeciesAlgT' --- to reflect the species structure at the type level. This is the --- point at which we wish we were doing this in a dependently typed --- language. +-- Some constructor-less data types used as indices to +-- 'SpeciesTypedAST' to reflect the species structure at the type +-- level. This is the point at which we wish we were doing this in a +-- dependently typed language. data Z data S n data X +data E +data C +data Sub +data Elt data (:+:) f g data (:*:) f g data (:.:) f g +data (:><:) f g +data (:@:) f g data Der f -data E -data C -data NonEmpty f -- | 'StructureF' is a type function which maps type-level species -- descriptions to structure functors. That is, a structure of the @@ -294,11 +348,14 @@ type instance StructureF Z = Const Integer type instance StructureF (S s) = Const Integer type instance StructureF X = Identity +type instance StructureF E = Set +type instance StructureF C = Cycle +type instance StructureF Sub = Set +type instance StructureF Elt = Identity type instance StructureF (f :+: g) = Sum (StructureF f) (StructureF g) type instance StructureF (f :*: g) = Prod (StructureF f) (StructureF g) type instance StructureF (f :.: g) = Comp (StructureF f) (StructureF g) +type instance StructureF (f :><: g) = Prod (StructureF f) (StructureF g) +type instance StructureF (f :@: g) = Comp (StructureF f) (StructureF g) type instance StructureF (Der f) = Comp (StructureF f) Star -type instance StructureF E = [] -type instance StructureF C = Cycle -type instance StructureF (NonEmpty f) = StructureF f diff --git a/Math/Combinatorics/Species/Unlabelled.hs b/Math/Combinatorics/Species/Unlabelled.hs --- a/Math/Combinatorics/Species/Unlabelled.hs +++ b/Math/Combinatorics/Species/Unlabelled.hs @@ -5,7 +5,7 @@ import Math.Combinatorics.Species.Types import Math.Combinatorics.Species.Class -import Math.Combinatorics.Species.Algebra +import Math.Combinatorics.Species.AST import Math.Combinatorics.Species.CycleIndex import qualified MathObj.PowerSeries as PS @@ -15,20 +15,22 @@ import NumericPrelude import PreludeBase hiding (cycle) +needsCI :: String -> a +needsCI op = error ("unlabelled " ++ op ++ " must go via cycle index series.") + instance Differential.C GF where - differentiate = error "unlabelled differentiation must go via cycle index series." + differentiate = needsCI "differentiation" instance Species GF where singleton = gfFromCoeffs [0,1] set = gfFromCoeffs (repeat 1) cycle = set - o = error "unlabelled composition must go via cycle index series." + o = needsCI "composition" + cartesian = needsCI "cartesian product" + fcomp = needsCI "functor composition" ofSize s p = (liftGF . PS.lift1 $ filterCoeffs p) s ofSizeExactly s n = (liftGF . PS.lift1 $ selectIndex n) s - (GF (PS.Cons (x:_))) .: GF (PS.Cons xs) - = GF (PS.Cons (x:tail xs)) - unlabelledCoeffs :: GF -> [Integer] unlabelledCoeffs (GF p) = PS.coeffs p @@ -44,19 +46,19 @@ -- -- Actually, the above is something of a white lie, as you may have -- already realized by looking at the input type of 'unlabelled', --- which is 'SpeciesAlg' rather than the expected 'GF'. The --- reason is that although products and sums of unlabelled species +-- which is 'SpeciesAST' rather than the expected 'GF'. The reason +-- is that although products and sums of unlabelled species -- correspond to products and sums of ordinary generating functions, --- composition and differentiation do not! In order to compute an --- ordinary generating function for a species defined in terms of --- composition and/or differentiation, we must compute the cycle --- index series for the species and then convert it to an ordinary --- generating function. So 'unlabelled' actually works by first --- reifying the species to an AST and checking whether it uses --- composition or differentiation, and using operations on cycle --- index series if it does, and (much faster) operations directly on --- ordinary generating functions otherwise. -unlabelled :: SpeciesAlg -> [Integer] +-- other operations such as composition and differentiation do not! +-- In order to compute an ordinary generating function for a species +-- defined in terms of composition and/or differentiation, we must +-- compute the cycle index series for the species and then convert +-- it to an ordinary generating function. So 'unlabelled' actually +-- works by first reifying the species to an AST and checking which +-- operations are used in its definition, and then choosing to work +-- with cycle index series or directly with (much faster) ordinary +-- generating functions as appropriate. +unlabelled :: SpeciesAST -> [Integer] unlabelled s - | needsZ s = unlabelledCoeffs . zToGF . reflect $ s - | otherwise = unlabelledCoeffs . reflect $ s + | needsZ s = unlabelledCoeffs . zToGF . reflect $ s + | otherwise = unlabelledCoeffs . reflect $ s diff --git a/species.cabal b/species.cabal --- a/species.cabal +++ b/species.cabal @@ -1,5 +1,5 @@ name: species -version: 0.1 +version: 0.2 license: BSD3 license-file: LICENSE build-type: Simple @@ -8,15 +8,15 @@ author: Brent Yorgey maintainer: Brent Yorgey category: Math -synopsis: Combinatorial species library +synopsis: Computational combinatorial species -description: A DSL for describing combinatorial species, along with a number - of ways to interpret it, to e.g. count labelled or unlabelled - species, or generate species elements. +description: A DSL for describing and computing with combinatorial species, + e.g. counting labelled or unlabelled structures, or generating + a list of all labeled structures for a species. Library build-depends: base >= 3.0 && < 4.2, numeric-prelude >= 0.1.1 && < 0.2, - np-extras >= 0.1 && < 0.2, containers >= 0.2 && < 0.3, + np-extras >= 0.2 && < 0.3, containers >= 0.2 && < 0.3, lub >= 0.0.5 && < 0.1 exposed-modules: Math.Combinatorics.Species @@ -25,6 +25,6 @@ Math.Combinatorics.Species.Labelled Math.Combinatorics.Species.Unlabelled Math.Combinatorics.Species.CycleIndex - Math.Combinatorics.Species.Algebra + Math.Combinatorics.Species.AST Math.Combinatorics.Species.Generate extensions: NoImplicitPrelude