diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Brent Yorgey 2009 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. diff --git a/Math/Combinatorics/Species.hs b/Math/Combinatorics/Species.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species.hs @@ -0,0 +1,53 @@ +{-# 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. +-- +-- 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. +module Math.Combinatorics.Species + ( -- * The combinatorial species DSL + Species(..) + + -- ** Convenience methods + , oneHole + , madeOf + , x, e, sets, cycles + + -- ** Derived operations + , pointed + , nonEmpty + + -- ** Derived species + , list, lists + , element, elements + , octopus, octopi + , partition, partitions + , permutation, permutations + , subset, subsets + , ballot, ballots + , ksubset, ksubsets + + -- * Computing with species + , labelled + , unlabelled + , generate + + ) where + +import Math.Combinatorics.Species.Class +import Math.Combinatorics.Species.Labelled +import Math.Combinatorics.Species.Unlabelled +import Math.Combinatorics.Species.Generate + + diff --git a/Math/Combinatorics/Species/Algebra.hs b/Math/Combinatorics/Species/Algebra.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Algebra.hs @@ -0,0 +1,142 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Class.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The Species type class, which defines a small DSL for describing +-- combinatorial species. Other modules in this library provide +-- specific instances which allow computing various properties of +-- combinatorial species. +module Math.Combinatorics.Species.Class + ( + -- * The Species type class + Species(..) + + -- * Convenience methods + -- $synonyms + + , oneHole + , madeOf + , x + , e + , sets + , cycles + + -- * 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 + + ) where + +import qualified Algebra.Differential as Differential + +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" +-- (the species 0 and species addition, i.e. disjoint sum), +-- "Algebra.Ring" (the species 1 and species multiplication, +-- i.e. partitional product), and "Algebra.Differential" (species +-- differentiation, i.e. adjoining a distinguished element). +-- +-- 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@. +class (Differential.C s) => Species s where + + -- | The species X of singletons + singleton :: s + + -- | The species E of sets + set :: s + + -- | The species C of cyclical orderings (cycles/rings) + cycle :: s + + -- | Partitional composition + o :: 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. + ofSizeExactly :: s -> Integer -> s + + -- | @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 + +-- $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@. + +-- | 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. +oneHole :: (Species s) => s -> s +oneHole = Differential.differentiate + +-- | A synonym for 'o' (partitional composition). +madeOf :: Species s => s -> s -> s +madeOf = o + +-- | 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 + +cycles :: Species s => s +cycles = cycle + +-- $derived_ops +-- Some derived operations on species. + +-- | Combinatorially, the operation of pointing picks out a +-- distinguished element from an underlying set. It is equivalent +-- to the operator @x d/dx@. +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. + +-- | The species L of linear orderings (lists): since lists are +-- isomorphic to cycles with a hole, we may take L = C'. +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 = element + +-- | An octopus is a cyclic arrangement of lists, so called because +-- the lists look like \"tentacles\" attached to the cyclic +-- \"body\": Oct = C o E+ . +octopi, octopus :: Species s => s +octopus = cycle `o` nonEmpty lists +octopi = octopus + +-- | The species of set partitions is just the composition E o E+, +-- that is, sets of nonempty sets. +partitions, partition :: Species s => s +partition = set `o` nonEmpty sets +partitions = partition + +-- | A permutation is a set of disjoint cycles: S = E o C. +permutations, permutation :: Species s => s +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 = subset + +-- | The species Bal of ballots consists of linear orderings of +-- nonempty sets: Bal = L o E+. +ballots, ballot :: Species s => s +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 = ksubset diff --git a/Math/Combinatorics/Species/CycleIndex.hs b/Math/Combinatorics/Species/CycleIndex.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/CycleIndex.hs @@ -0,0 +1,123 @@ +{-# 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 + ( zToEGF + , zToGF + ) where + +import Math.Combinatorics.Species.Types +import Math.Combinatorics.Species.Class +import Math.Combinatorics.Species.Labelled + +import qualified MathObj.PowerSeries as PowerSeries +import qualified MathObj.MultiVarPolynomial as MVP +import qualified MathObj.Monomial as Monomial +import qualified MathObj.FactoredRational as FQ + +import qualified Algebra.Ring as Ring + +import qualified Data.Map as M +import Data.List (genericReplicate, genericDrop, groupBy, sort, intercalate) +import Data.Function (on) +import Control.Arrow ((&&&), first, second) + +import NumericPrelude +import PreludeBase hiding (cycle) + +instance Species CycleIndex where + singleton = CI $ MVP.x 1 + set = ciFromMonomials . map partToMonomial . concatMap intPartitions $ [0..] + + cycle = ciFromMonomials . concatMap cycleMonomials $ [1..] + + o = liftCI2 MVP.compose + + 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) + +-- | @'zCoeff' 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 + +-- | @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 +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@. +-- +-- Also, the partitions are generated in an order corresponding to +-- the Ord instance for 'Monomial'. +intPartitions :: Integer -> [[(Integer, Integer)]] +intPartitions n = intPartitions' n n + where intPartitions' :: Integer -> Integer -> [[(Integer,Integer)]] + intPartitions' 0 _ = [[]] + intPartitions' n 0 = [] + intPartitions' n k = + [ if (j == 0) then js else (k,j):js + | j <- reverse [0..n `div` k] + , js <- intPartitions' (n - j*k) (min (k-1) (n - j*k)) ] + +-- | @cycleMonomials d@ generates all monomials of partition degree +-- @d@ in the cycle index series for the species C of cycles. +cycleMonomials :: Integer -> [Monomial.T Rational] +cycleMonomials n = map cycleMonomial ds + where n' = fromIntegral n + ds = sort . FQ.divisors $ n' + cycleMonomial d = Monomial.Cons (FQ.eulerPhi (n' / d) % n) + (M.singleton (n `div` (toInteger d)) (toInteger d)) + +-- | Convert a cycle index series to an exponential generating +-- function: F(x) = Z_F(x,0,0,0,...). +zToEGF :: CycleIndex -> EGF +zToEGF (CI (MVP.Cons xs)) + = EGF . PowerSeries.fromCoeffs . map LR + . insertZeros + . concatMap (\(c,as) -> case as of { [] -> [(0,c)] ; [(1,p)] -> [(p,c)] ; _ -> [] }) + . map (Monomial.coeff &&& (M.assocs . Monomial.powers)) + $ xs + +-- | Convert a cycle index series to an ordinary generating function: +-- F~(x) = Z_F(x,x^2,x^3,...). +zToGF :: CycleIndex -> GF +zToGF (CI (MVP.Cons xs)) + = GF . PowerSeries.fromCoeffs . map numerator + . insertZeros + . map ((fst . head) &&& (sum . map snd)) + . groupBy ((==) `on` fst) + . map ((sum . map (uncurry (*)) . M.assocs . Monomial.powers) &&& Monomial.coeff) + $ xs + +-- | Since cycle index series use a sparse representation, not every +-- power of x may be present after converting to an ordinary or +-- exponential generating function; 'insertZeros' inserts +-- coefficients of zero where necessary. +insertZeros :: Ring.C a => [(Integer, a)] -> [a] +insertZeros = insertZeros' [0..] + where + insertZeros' _ [] = [] + 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 diff --git a/Math/Combinatorics/Species/Generate.hs b/Math/Combinatorics/Species/Generate.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Generate.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE NoImplicitPrelude + , GADTs + , MultiParamTypeClasses + , FlexibleInstances + , FlexibleContexts + #-} + +-- | Generation of species: given a species and an underlying set of +-- labels, generate a list of all structures built from the +-- underlying set. +module Math.Combinatorics.Species.Generate + ( generateF + , Structure(..) + , generate + + ) where + +import Math.Combinatorics.Species.Class +import Math.Combinatorics.Species.Types +import Math.Combinatorics.Species.Algebra + +import Control.Arrow (first, second) +import Data.List (genericLength) + +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 +-- 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 +-- '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 +-- 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) +generateF (OfSize f p) xs | p (genericLength xs) = generateF f xs + | otherwise = [] +generateF (OfSizeExactly f n) xs | genericLength xs == n = generateF f xs + | otherwise = [] + +-- | @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 + where mapx which = map (which (x:)) $ pSet xs + +-- | Generate all partitions of a set. +sPartitions :: [a] -> [[[a]]] +sPartitions [] = [[]] +sPartitions (s:s') = do (sub,compl) <- pSet s' + let firstSubset = s:sub + map (firstSubset:) $ sPartitions compl + +-- | Generate all permutations of a list. +sPermutations :: [a] -> [[a]] +sPermutations [] = [[]] +sPermutations xs = [ y:p | (y,ys) <- select xs + , p <- sPermutations ys + ] + +-- | Select each element of a list in turn, yielding a list of +-- elements, each paired with a list of the remaining elements. +select :: [a] -> [(a,[a])] +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. +data Structure a where + Structure :: (ShowF 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: +-- +-- > > 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}}] +-- +-- 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 (SA s) xs = map Structure (generateF s xs) + + +-- Experimental stuff below, automatically converting between +-- isomorphic structures. +-- +-- class Iso f g where +-- iso :: f a -> g a + +-- instance Iso (Comp Cycle Star) [] where +-- iso (Comp (Cycle (_:xs))) = map (\(Original x) -> x) xs + +-- instance (Iso f g, Functor h) => Iso (Comp h f) (Comp h g) where +-- iso (Comp h) = Comp (fmap iso h) + +-- instance (Iso f1 f2, Iso g1 g2) => Iso (Sum f1 g1) (Sum f2 g2) where +-- iso (Sum (Left x)) = Sum (Left (iso x)) +-- iso (Sum (Right x)) = Sum (Right (iso x)) + +-- 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 s xs = map iso $ generateF s xs diff --git a/Math/Combinatorics/Species/Labelled.hs b/Math/Combinatorics/Species/Labelled.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Labelled.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude + , GeneralizedNewtypeDeriving + , PatternGuards + #-} +-- | An interpretation of species as exponential generating functions, +-- which count labelled structures. +module Math.Combinatorics.Species.Labelled + ( labelled + ) where + +import Math.Combinatorics.Species.Types +import Math.Combinatorics.Species.Class + +import qualified MathObj.PowerSeries as PS + +import NumericPrelude +import PreludeBase hiding (cycle) + +facts :: [Integer] +facts = 1 : zipWith (*) [1..] facts + +instance Species EGF where + singleton = egfFromCoeffs [0,1] + set = egfFromCoeffs (map (LR . (1%)) facts) + cycle = egfFromCoeffs (0 : map (LR . (1%)) [1..]) + o = liftEGF2 PS.compose + 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 +-- 'Species', the idea is that 'labelled' can be applied directly to +-- an expression of the Species DSL. In particular, @labelled s !! +-- n@ is the number of labelled s-structures on an underlying set of +-- size n. For example: +-- +-- > > take 10 $ labelled octopi +-- > [0,1,3,14,90,744,7560,91440,1285200,20603520] +-- +-- gives the number of labelled octopi on 0, 1, 2, 3, ... 9 elements. + +labelled :: EGF -> [Integer] +labelled (EGF f) = map numerator . zipWith (*) (map fromInteger facts) . map unLR + $ PS.coeffs f + +-- A previous version of this module used an EGF library which +-- explicitly computed with EGF's. However, it turned out to be much +-- slower than just computing explicitly with normal power series and +-- zipping/unzipping with factorial denominators as necessary, which +-- is the current approach. +-- +-- instance Species (EGF.T Integer) where +-- singleton = EGF.fromCoeffs [0,1] +-- set = EGF.fromCoeffs $ repeat 1 +-- list = EGF.fromCoeffs facts +-- o = EGF.compose +-- nonEmpty (EGF.Cons (_:xs)) = EGF.Cons (0:xs) +-- nonEmpty x = x +-- +-- labelled :: EGF.T Integer -> [Integer] +-- labelled = EGF.coeffs +-- diff --git a/Math/Combinatorics/Species/Types.hs b/Math/Combinatorics/Species/Types.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Types.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE NoImplicitPrelude + , EmptyDataDecls + , TypeFamilies + , TypeOperators + , FlexibleContexts + , GeneralizedNewtypeDeriving + #-} + +-- | Some common types used by the species library. +module Math.Combinatorics.Species.Types + ( -- * Lazy multiplication + + LazyRing(..) + , LazyQ + , LazyZ + + -- * Series types + + , EGF(..) + , egfFromCoeffs + , liftEGF + , liftEGF2 + + , GF(..) + , gfFromCoeffs + , liftGF + , liftGF2 + + , CycleIndex(..) + , ciFromMonomials + , liftCI + , liftCI2 + + , filterCoeffs + , selectIndex + + -- * Higher-order Show + + , ShowF(..) + , RawString(..) + + -- * Structure functors + -- $struct + + , Const(..) + , Identity(..) + , Sum(..) + , Prod(..) + , Comp(..) + , Cycle(..) + , Star(..) + + -- * Type-level species + -- $typespecies + + , Z, S, X, (:+:), (:*:), (:.:), Der, E, C, NonEmpty + , StructureF + ) where + +import Data.List (intercalate, genericReplicate) +import NumericPrelude +import PreludeBase + +import qualified MathObj.PowerSeries as PS +import qualified MathObj.MultiVarPolynomial as MVP +import qualified MathObj.Monomial as Monomial + +import qualified Algebra.Additive as Additive +import qualified Algebra.Ring as Ring +import qualified Algebra.Differential as Differential +import qualified Algebra.ZeroTestable as ZeroTestable +import qualified Algebra.Field as Field + +import Data.Lub (parCommute, HasLub(..), flatLub) + +-------------------------------------------------------------------------------- +-- Lazy multiplication ------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | If @T@ is an instance of @Ring@, then @LazyRing T@ is isomorphic +-- to T but with a lazy multiplication: @0 * undefined = undefined * 0 +-- = 0@. +newtype LazyRing a = LR { unLR :: a } + deriving (Eq, Ord, Additive.C, ZeroTestable.C, Field.C) + +instance HasLub (LazyRing a) where + lub = flatLub + +instance Show a => Show (LazyRing a) where + show (LR r) = show r + +instance (Eq a, Ring.C a) => Ring.C (LazyRing a) where + (*) = parCommute lazyTimes + where lazyTimes (LR 0) _ = LR 0 + lazyTimes (LR 1) x = x + lazyTimes (LR a) (LR b) = LR (a*b) + fromInteger = LR . fromInteger + +type LazyQ = LazyRing Rational +type LazyZ = LazyRing Integer + +-------------------------------------------------------------------------------- +-- Series types -------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | Exponential generating functions, for counting labelled species. +newtype EGF = EGF (PS.T LazyQ) + deriving (Additive.C, Ring.C, Differential.C, Show) + +egfFromCoeffs :: [LazyQ] -> EGF +egfFromCoeffs = EGF . PS.fromCoeffs + +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) + -> EGF -> EGF -> EGF +liftEGF2 f (EGF x) (EGF y) = EGF (f x y) + +-- | Ordinary generating functions, for counting unlabelled species. +newtype GF = GF (PS.T Integer) + deriving (Additive.C, Ring.C, Show) + +gfFromCoeffs :: [Integer] -> GF +gfFromCoeffs = GF . PS.fromCoeffs + +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) + -> GF -> GF -> GF +liftGF2 f (GF x) (GF y) = GF (f x y) + +-- | Cycle index series. +newtype CycleIndex = CI (MVP.T Rational) + deriving (Additive.C, Ring.C, Differential.C, Show) + +ciFromMonomials :: [Monomial.T Rational] -> CycleIndex +ciFromMonomials = CI . MVP.Cons + +liftCI :: (MVP.T Rational -> MVP.T Rational) + -> CycleIndex -> CycleIndex +liftCI f (CI x) = CI (f x) + +liftCI2 :: (MVP.T Rational -> MVP.T Rational -> MVP.T Rational) + -> CycleIndex -> CycleIndex -> CycleIndex +liftCI2 f (CI x) (CI y) = CI (f x y) + +-- Some series utility functions + +-- | Filter the coefficients of a series according to a predicate. +filterCoeffs :: (Additive.C a) => (Integer -> Bool) -> [a] -> [a] +filterCoeffs p = zipWith (filterCoeff p) [0..] + where filterCoeff p n x | p n = x + | otherwise = Additive.zero + +-- | Set every coefficient of a series to 0 except the selected +-- index. Truncate any trailing zeroes. +selectIndex :: (Ring.C a, Eq a) => Integer -> [a] -> [a] +selectIndex n xs = xs' + where mx = safeIndex n xs + safeIndex _ [] = Nothing + safeIndex 0 (x:_) = Just x + safeIndex n (_:xs) = safeIndex (n-1) xs + xs' = case mx of + Just 0 -> [] + Just x -> genericReplicate n 0 ++ [x] + _ -> [] + +-------------------------------------------------------------------------------- +-- Higher-order Show --------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | When generating species, we build up a functor representing +-- structures of that species; in order to display generated +-- structures, we need to know that applying the computed functor to +-- a Showable type will also yield something Showable. +class Functor f => ShowF f where + showF :: (Show a) => f a -> String + +instance ShowF [] where + showF = show + +-- | 'RawString' is like String, but with a Show instance that doesn't +-- add quotes or do any escaping. This is a (somewhat silly) hack +-- needed to implement a 'ShowF' instance for 'Comp'. +newtype RawString = RawString String +instance Show RawString where + show (RawString s) = s + +-------------------------------------------------------------------------------- +-- Structure functors -------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- $struct +-- Functors used in building up structures for species generation. + +-- | The constant functor. +newtype Const x a = Const x +instance Functor (Const x) where + fmap _ (Const x) = Const x +instance (Show x) => Show (Const x a) where + show (Const x) = show x +instance (Show x) => ShowF (Const x) where + showF = show + +-- | The identity functor. +newtype Identity a = Identity a +instance Functor Identity where + fmap f (Identity x) = Identity (f x) +instance (Show a) => Show (Identity a) where + show (Identity x) = show x +instance ShowF Identity where + showF = show + +-- | Functor coproduct. +newtype Sum f g a = Sum { unSum :: Either (f a) (g a) } +instance (Functor f, Functor g) => Functor (Sum f g) where + 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 +instance (ShowF f, ShowF g) => ShowF (Sum f g) where + showF (Sum (Left fa)) = "inl(" ++ showF fa ++ ")" + showF (Sum (Right ga)) = "inr(" ++ showF ga ++ ")" + +-- | Functor product. +newtype Prod f g a = Prod { unProd :: (f a, g a) } +instance (Functor f, Functor g) => Functor (Prod f g) where + fmap f (Prod (fa, ga)) = Prod (fmap f fa, fmap f ga) +instance (Show (f a), Show (g a)) => Show (Prod f g a) where + show (Prod x) = show x +instance (ShowF f, ShowF g) => ShowF (Prod f g) where + showF (Prod (fa, ga)) = "(" ++ showF fa ++ "," ++ showF ga ++ ")" + +-- | Functor composition. +data Comp f g a = Comp { unComp :: (f (g a)) } +instance (Functor f, Functor g) => Functor (Comp f g) where + fmap f (Comp fga) = Comp (fmap (fmap f) fga) +instance (Show (f (g a))) => Show (Comp f g a) where + show (Comp x) = show x +instance (ShowF f, ShowF g) => ShowF (Comp f g) where + showF (Comp fga) = showF (fmap (RawString . showF) fga) + +-- | 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) +instance (Show a) => Show (Cycle a) where + show (Cycle xs) = "{" ++ intercalate "," (map show xs) ++ "}" +instance ShowF Cycle 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 +instance Functor Star where + fmap _ Star = Star + fmap f (Original a) = Original (f a) +instance (Show a) => Show (Star a) where + show Star = "*" + show (Original a) = show a +instance ShowF Star where + showF = show + +-------------------------------------------------------------------------------- +-- Type-level species -------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- $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. + +data Z +data S n +data X +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 +-- species with type-level representation @s@, on the underlying set +-- @a@, has type @StructureF s a@. +type family StructureF t :: * -> * +type instance StructureF Z = Const Integer +type instance StructureF (S s) = Const Integer +type instance StructureF X = 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 (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 new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Unlabelled.hs @@ -0,0 +1,62 @@ +-- | An interpretation of species as ordinary generating functions, +-- which count unlabelled structures. +module Math.Combinatorics.Species.Unlabelled + ( unlabelled ) where + +import Math.Combinatorics.Species.Types +import Math.Combinatorics.Species.Class +import Math.Combinatorics.Species.Algebra +import Math.Combinatorics.Species.CycleIndex + +import qualified MathObj.PowerSeries as PS + +import qualified Algebra.Differential as Differential + +import NumericPrelude +import PreludeBase hiding (cycle) + +instance Differential.C GF where + differentiate = error "unlabelled differentiation must go via cycle index series." + +instance Species GF where + singleton = gfFromCoeffs [0,1] + set = gfFromCoeffs (repeat 1) + cycle = set + o = error "unlabelled composition must go via cycle index series." + 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 + +-- | Extract the coefficients of an ordinary generating function as a +-- list of Integers. In particular, @unlabelled s !! n@ is the +-- number of unlabelled s-structures on an underlying set of size n. +-- For example: +-- +-- > > take 10 $ unlabelled octopi +-- > [0,1,2,3,5,7,13,19,35,59] +-- +-- gives the number of unlabelled octopi on 0, 1, 2, 3, ... 9 elements. +-- +-- 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 +-- 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] +unlabelled s + | needsZ s = unlabelledCoeffs . zToGF . reflect $ s + | otherwise = unlabelledCoeffs . reflect $ s diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/species.cabal b/species.cabal new file mode 100644 --- /dev/null +++ b/species.cabal @@ -0,0 +1,30 @@ +name: species +version: 0.1 +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.2.3 +tested-with: GHC == 6.10.3 +author: Brent Yorgey +maintainer: Brent Yorgey +category: Math +synopsis: Combinatorial species library + +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. + +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, + lub >= 0.0.5 && < 0.1 + exposed-modules: + Math.Combinatorics.Species + Math.Combinatorics.Species.Class + Math.Combinatorics.Species.Types + Math.Combinatorics.Species.Labelled + Math.Combinatorics.Species.Unlabelled + Math.Combinatorics.Species.CycleIndex + Math.Combinatorics.Species.Algebra + Math.Combinatorics.Species.Generate + extensions: NoImplicitPrelude