species 0.2.1 → 0.3
raw patch · 16 files changed
+1991/−767 lines, 16 filesdep +multiset-combdep +template-haskelldep −lubdep ~basedep ~containersdep ~np-extras
Dependencies added: multiset-comb, template-haskell
Dependencies removed: lub
Dependency ranges changed: base, containers, np-extras
Files
- Math/Combinatorics/Species.hs +40/−13
- Math/Combinatorics/Species/AST.hs +248/−138
- Math/Combinatorics/Species/AST/Instances.hs +262/−0
- Math/Combinatorics/Species/Class.hs +26/−23
- Math/Combinatorics/Species/CycleIndex.hs +9/−2
- Math/Combinatorics/Species/Enumerate.hs +386/−0
- Math/Combinatorics/Species/Generate.hs +0/−303
- Math/Combinatorics/Species/Labelled.hs +26/−28
- Math/Combinatorics/Species/NewtonRaphson.hs +82/−0
- Math/Combinatorics/Species/Simplify.hs +158/−0
- Math/Combinatorics/Species/Structures.hs +155/−0
- Math/Combinatorics/Species/TH.hs +427/−0
- Math/Combinatorics/Species/Types.hs +7/−248
- Math/Combinatorics/Species/Unlabelled.hs +11/−5
- Math/Combinatorics/Species/Util/Interval.hs +136/−0
- species.cabal +18/−7
Math/Combinatorics/Species.hs view
@@ -12,8 +12,12 @@ -- For a friendly introduction to combinatorial species in general -- and this library in particular, see my series of blog posts: ----- <http://byorgey.wordpress.com/2009/07/24/introducing-math-combinatorics-species/>+-- * <http://byorgey.wordpress.com/2009/07/24/introducing-math-combinatorics-species/> --+-- * <http://byorgey.wordpress.com/2009/07/30/primitive-species-and-species-operations/>+--+-- * <http://byorgey.wordpress.com/2009/07/31/primitive-species-and-species-operations-part-ii/>+-- -- For a good reference (really, the -- only English-language reference!) on combinatorial species, see -- Bergeron, Labelle, and Leroux, \"Combinatorial Species and@@ -32,7 +36,7 @@ , madeOf , (><), (@@) , x, sets, cycles- , lists+ , linOrds , subsets , ksubsets , elements@@ -48,37 +52,52 @@ , simpleGraph, simpleGraphs , directedGraph, directedGraphs - -- * Computing with species+ -- * Counting species structures+ -- $counting , labelled , unlabelled - -- * Generating species structures- , generate-- , generateTyped+ -- * Enumerating species structures+ -- $enum+ , Enumerable(..) , structureType+ , enumerate+ , enumerateL+ , enumerateU+ , enumerateM+ , enumerateAll, enumerateAllU -- ** Types used for generation -- $types- , Identity(..), Const(..)+ , Void, Unit(..)+ , Id(..), Const(..) , Sum(..), Prod(..), Comp(..) , Star(..), Cycle(..), Set(..) -- * Species AST -- $ast- , SpeciesTypedAST(..) , SpeciesAST(..)+ , ESpeciesAST(..) , reify , reflect + -- * Recursive species+ -- $rec+ , Mu(..), Interp, ASTFunctor(..)++ -- * Template Haskell+ , deriveSpecies+ ) 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.Structures+import Math.Combinatorics.Species.Enumerate import Math.Combinatorics.Species.AST+import Math.Combinatorics.Species.AST.Instances+import Math.Combinatorics.Species.TH -- $DSL -- The combinatorial species DSL consists of the 'Species' type class,@@ -93,11 +112,19 @@ -- and plural versions of species, for example, @set \`o\` nonEmpty -- sets@. +-- $counting+-- XXX++-- $enum+-- XXX+ -- $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'.+-- XXX++-- $rec+-- XXX
Math/Combinatorics/Species/AST.hs view
@@ -1,176 +1,286 @@ {-# LANGUAGE NoImplicitPrelude , GADTs- , TypeOperators+ , TypeFamilies+ , KindSignatures , FlexibleContexts+ , RankNTypes #-} -- | A data structure to reify combinatorial species. module Math.Combinatorics.Species.AST (- SpeciesTypedAST(..)- , SpeciesAST(..)- , needsZT, needsZ+ SpeciesAST(..), SizedSpeciesAST(..)+ , interval, annI, getI, stripI+ , ESpeciesAST(..), wrap, unwrap+ , ASTFunctor(..) - , reify- , reflectT- , reflect+ , needsZ, needsZE - ) where+ , USpeciesAST(..), erase, erase', unerase+ , substRec -import Math.Combinatorics.Species.Class-import Math.Combinatorics.Species.Types+ ) where -import qualified Algebra.Additive as Additive-import qualified Algebra.Ring as Ring-import qualified Algebra.Differential as Differential+import Math.Combinatorics.Species.Structures+import Math.Combinatorics.Species.Util.Interval+import qualified Math.Combinatorics.Species.Util.Interval as I import Data.Typeable+import Unsafe.Coerce +import Data.Maybe (fromMaybe)+ import NumericPrelude import PreludeBase hiding (cycle) --- | Reified combinatorial species. Note that 'SpeciesTypedAST' has a+-- | Reified combinatorial species. Note that 'SpeciesAST' 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.+-- can write quasi-dependently-typed functions over species, in+-- particular for species enumeration. -- -- 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+-- 'SpeciesAST' cannot be an instance of the 'Species' class;+-- for that purpose the existential wrapper 'ESpeciesAST' is -- provided.-data SpeciesTypedAST s where- N :: Integer -> SpeciesTypedAST Z- X :: SpeciesTypedAST X- E :: SpeciesTypedAST E- C :: SpeciesTypedAST C- L :: SpeciesTypedAST L- 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+--+-- 'SpeciesAST' is defined via mutual recursion with+-- 'SizedSpeciesAST', which pairs a 'SpeciesAST' with an interval+-- annotation indicating (a conservative approximation of) the label+-- set sizes for which the species actually yields any structures.+-- A value of 'SizedSpeciesAST' is thus an annotated species+-- expression tree with interval annotations at every node.+data SpeciesAST (s :: * -> *) where+ Zero :: SpeciesAST Void+ One :: SpeciesAST Unit+ N :: Integer -> SpeciesAST (Const Integer)+ X :: SpeciesAST Id+ E :: SpeciesAST Set+ C :: SpeciesAST Cycle+ L :: SpeciesAST []+ Subset :: SpeciesAST Set+ KSubset :: Integer -> SpeciesAST Set+ Elt :: SpeciesAST Id+ (:+:) :: SizedSpeciesAST f -> SizedSpeciesAST g -> SpeciesAST (Sum f g)+ (:*:) :: SizedSpeciesAST f -> SizedSpeciesAST g -> SpeciesAST (Prod f g)+ (:.:) :: SizedSpeciesAST f -> SizedSpeciesAST g -> SpeciesAST (Comp f g)+ (:><:) :: SizedSpeciesAST f -> SizedSpeciesAST g -> SpeciesAST (Prod f g)+ (:@:) :: SizedSpeciesAST f -> SizedSpeciesAST g -> SpeciesAST (Comp f g)+ Der :: SizedSpeciesAST f -> SpeciesAST (Comp f Star)+ OfSize :: SizedSpeciesAST f -> (Integer -> Bool) -> SpeciesAST f+ OfSizeExactly :: SizedSpeciesAST f -> Integer -> SpeciesAST f+ NonEmpty :: SizedSpeciesAST f -> SpeciesAST f+ Rec :: ASTFunctor f => f -> SpeciesAST (Mu f) -instance Show (SpeciesTypedAST s) where- showsPrec _ (N n) = shows n- showsPrec _ X = showChar 'X'- showsPrec _ E = showChar 'E'- showsPrec _ C = showChar 'C'- showsPrec _ L = showChar 'L'- 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 '+'+ Omega :: SpeciesAST Void --- | 'needsZT' is a predicate which checks whether a species uses any+data SizedSpeciesAST (s :: * -> *) where+ Sized :: Interval -> SpeciesAST s -> SizedSpeciesAST s++-- | Given a 'SpeciesAST', compute (a conservative approximation of)+-- the interval of label set sizes on which the species yields any+-- structures.+interval :: SpeciesAST s -> Interval+interval Zero = emptyI+interval One = 0+interval (N n) = 0+interval X = 1+interval E = natsI+interval C = fromI 1+interval L = natsI+interval Subset = natsI+interval (KSubset k) = fromI (fromInteger k)+interval Elt = fromI 1+interval (f :+: g) = getI f `I.union` getI g+interval (f :*: g) = getI f + getI g+interval (f :.: g) = getI f * getI g+interval (f :><: g) = getI f `I.intersect` getI g+interval (f :@: g) = natsI+ -- Note, the above interval for functor composition is obviously+ -- overly conservative. To do this right we'd have to compute the+ -- generating function for g --- and actually it would depend on+ -- whether we were doing labelled or unlabelled enumeration, which+ -- we don't know at this point.+interval (Der f) = decrI (getI f)+interval (OfSize f p) = fromI $ smallestIn (getI f) p+interval (OfSizeExactly f n) = fromInteger n `I.intersect` getI f+interval (NonEmpty f) = fromI 1 `I.intersect` getI f+interval (Rec f) = interval (apply f Omega)+interval Omega = omegaI++-- | Find the smallest integer in the given interval satisfying a predicate.+smallestIn :: Interval -> (Integer -> Bool) -> NatO+smallestIn i p = case filter p (toList i) of+ [] -> I.omega+ (x:_) -> fromIntegral x+++-- | Annotate a 'SpeciesAST' with the interval of label set sizes for+-- which it yields structures.+annI :: SpeciesAST s -> SizedSpeciesAST s+annI s = Sized (interval s) s++-- | Strip the interval annotation from a 'SizedSpeciesAST'.+stripI :: SizedSpeciesAST s -> SpeciesAST s+stripI (Sized _ s) = s++-- | Retrieve the interval annotation.+getI :: SizedSpeciesAST s -> Interval+getI (Sized i _) = i++-- | Type class for codes which can be interpreted as higher-order+-- functors.+class (Typeable f, Show f, Typeable1 (Interp f (Mu f))) => ASTFunctor f where+ apply :: Typeable1 g => f -> SpeciesAST g -> SpeciesAST (Interp f g)++-- | 'needsZ' 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+needsZ :: USpeciesAST -> Bool+needsZ UL = True+needsZ (f :+:% g) = needsZ f || needsZ g+needsZ (f :*:% g) = needsZ f || needsZ g+needsZ (_ :.:% _) = True+needsZ (_ :><:% _) = True+needsZ (_ :@:% _) = True+needsZ (UDer _) = True+needsZ (UOfSize f _) = needsZ f+needsZ (UOfSizeExactly f _) = needsZ f+needsZ (UNonEmpty f) = needsZ f+needsZ (URec _) = True -- Newton-Raphson iteration uses composition+needsZ _ = 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+-- 'SizedSpeciesAST', so we can make it an instance of 'Species'.+data ESpeciesAST where+ Wrap :: Typeable1 s => SizedSpeciesAST s -> ESpeciesAST -instance Additive.C SpeciesAST where- zero = SA (N 0)- (SA f) + (SA g) = SA (f :+: g)- negate = error "negation is not implemented yet! wait until virtual species..."+-- | Smart wrap constructor which also adds an appropriate interval+-- annotation.+wrap :: Typeable1 s => SpeciesAST s -> ESpeciesAST+wrap = Wrap . annI -instance Ring.C SpeciesAST where- (SA f) * (SA g) = SA (f :*: g)- one = SA (N 1)- fromInteger n = SA (N n)+-- | Unwrap the existential wrapper and get out a typed AST. You can+-- get out any type you like as long as it is the right one.+--+-- CAUTION: Don't try this at home.+unwrap :: Typeable1 s => ESpeciesAST -> SpeciesAST s+unwrap (Wrap f) = gcast1'+ . stripI+ $ f+ where gcast1' x = r+ where r = if typeOf1 (getArg x) == typeOf1 (getArg r)+ then unsafeCoerce x+ else error ("unwrap: cast failed. Wanted " +++ show (typeOf1 (getArg r)) +++ ", instead got " +++ show (typeOf1 (getArg x)))+ getArg :: c x -> x ()+ getArg = undefined -instance Differential.C SpeciesAST where- differentiate (SA f) = SA (Der f)+-- | A version of 'needsZ' for 'ESpeciesAST'.+needsZE :: ESpeciesAST -> Bool+needsZE = needsZ . erase -instance Species SpeciesAST where- singleton = SA X- set = SA E- cycle = SA C- list = SA L- 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)+-- | A plain old untyped variant of the species AST, for more easily+-- doing things like analysis, simplification, deriving+-- isomorphisms, and so on. Converting between 'ESpeciesAST' and+-- 'USpeciesAST' can be done with 'erase' and 'unerase'.+data USpeciesAST where+ UZero :: USpeciesAST+ UOne :: USpeciesAST+ UN :: Integer -> USpeciesAST+ UX :: USpeciesAST+ UE :: USpeciesAST+ UC :: USpeciesAST+ UL :: USpeciesAST+ USubset :: USpeciesAST+ UKSubset :: Integer -> USpeciesAST+ UElt :: USpeciesAST+ (:+:%) :: USpeciesAST -> USpeciesAST -> USpeciesAST+ (:*:%) :: USpeciesAST -> USpeciesAST -> USpeciesAST+ (:.:%) :: USpeciesAST -> USpeciesAST -> USpeciesAST+ (:><:%) :: USpeciesAST -> USpeciesAST -> USpeciesAST+ (:@:%) :: USpeciesAST -> USpeciesAST -> USpeciesAST+ UDer :: USpeciesAST -> USpeciesAST+ UOfSize :: USpeciesAST -> (Integer -> Bool) -> USpeciesAST+ UOfSizeExactly :: USpeciesAST -> Integer -> USpeciesAST+ UNonEmpty :: USpeciesAST -> USpeciesAST+ URec :: ASTFunctor f => f -> USpeciesAST+ UOmega :: USpeciesAST --- | 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 . L+--- > > reify (ksubset 3)--- > E3 * E+-- | Erase the type and interval information from a species AST.+erase :: ESpeciesAST -> USpeciesAST+erase (Wrap s) = erase' (stripI s) -reify :: SpeciesAST -> SpeciesAST-reify = id+erase' :: SpeciesAST f -> USpeciesAST+erase' Zero = UZero+erase' One = UOne+erase' (N n) = UN n+erase' X = UX+erase' E = UE+erase' C = UC+erase' L = UL+erase' Subset = USubset+erase' (KSubset k) = UKSubset k+erase' Elt = UElt+erase' (f :+: g) = erase' (stripI f) :+:% erase' (stripI g)+erase' (f :*: g) = erase' (stripI f) :*:% erase' (stripI g)+erase' (f :.: g) = erase' (stripI f) :.:% erase' (stripI g)+erase' (f :><: g) = erase' (stripI f) :><:% erase' (stripI g)+erase' (f :@: g) = erase' (stripI f) :@:% erase' (stripI g)+erase' (Der f) = UDer . erase' . stripI $ f+erase' (OfSize f p) = UOfSize (erase' . stripI $ f) p+erase' (OfSizeExactly f k) = UOfSizeExactly (erase' . stripI $ f) k+erase' (NonEmpty f) = UNonEmpty . erase' . stripI $ f+erase' (Rec f) = URec f+erase' Omega = UOmega --- | Reflect an AST back into any instance of the 'Species' class.-reflectT :: Species s => SpeciesTypedAST f -> s-reflectT (N n) = fromInteger n-reflectT X = singleton-reflectT E = set-reflectT C = cycle-reflectT L = list-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)+-- | Reconstruct the type and interval annotations on a species AST.+unerase :: USpeciesAST -> ESpeciesAST+unerase UZero = wrap Zero+unerase UOne = wrap One+unerase (UN n) = wrap (N n)+unerase UX = wrap X+unerase UE = wrap E+unerase UC = wrap C+unerase UL = wrap L+unerase USubset = wrap Subset+unerase (UKSubset k) = wrap (KSubset k)+unerase UElt = wrap Elt+unerase (f :+:% g) = unerase f + unerase g+ where Wrap f + Wrap g = wrap $ f :+: g+unerase (f :*:% g) = unerase f * unerase g+ where Wrap f * Wrap g = wrap $ f :*: g+unerase (f :.:% g) = unerase f . unerase g+ where Wrap f . Wrap g = wrap $ f :.: g+unerase (f :><:% g) = unerase f >< unerase g+ where Wrap f >< Wrap g = wrap $ f :><: g+unerase (f :@:% g) = unerase f @@ unerase g+ where Wrap f @@ Wrap g = wrap $ f :@: g+unerase (UDer f) = der $ unerase f+ where der (Wrap f) = wrap (Der f)+unerase (UOfSize f p) = ofSize $ unerase f+ where ofSize (Wrap f) = wrap $ OfSize f p+unerase (UOfSizeExactly f k) = ofSize $ unerase f+ where ofSize (Wrap f) = wrap $ OfSizeExactly f k+unerase (UNonEmpty f) = nonEmpty $ unerase f+ where nonEmpty (Wrap f) = wrap $ NonEmpty f+unerase (URec f) = wrap $ Rec f+unerase UOmega = wrap Omega --- | Reflect an AST back into any instance of the 'Species' class.-reflect :: Species s => SpeciesAST -> s-reflect (SA f) = reflectT f+-- | Substitute an expression for recursive occurrences.+substRec :: ASTFunctor f => f -> USpeciesAST -> USpeciesAST -> USpeciesAST+substRec c e (f :+:% g) = substRec c e f :+:% substRec c e g+substRec c e (f :*:% g) = substRec c e f :*:% substRec c e g+substRec c e (f :.:% g) = substRec c e f :.:% substRec c e g+substRec c e (f :><:% g) = substRec c e f :><:% substRec c e g+substRec c e (f :@:% g) = substRec c e f :@:% substRec c e g+substRec c e (UDer f) = UDer (substRec c e f)+substRec c e (UOfSize f p) = UOfSize (substRec c e f) p+substRec c e (UOfSizeExactly f k) = UOfSizeExactly (substRec c e f) k+substRec c e (UNonEmpty f) = UNonEmpty (substRec c e f)+substRec c e (URec c')+ | (show . typeOf $ c) == (show . typeOf $ c') = e+substRec _ _ f = f
+ Math/Combinatorics/Species/AST/Instances.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE GADTs #-}++-- | Type class instances for 'SpeciesAST', 'ESpeciesAST', and+-- 'USpeciesAST', in a separate module to avoid a dependency cycle+-- between "Math.Combinatorics.Species.AST" and+-- "Math.Combinatorics.Species.Class".+module Math.Combinatorics.Species.AST.Instances+ ( reify, reflectT, reflectU, reflect )+ where++import NumericPrelude+import PreludeBase hiding (cycle)++import Math.Combinatorics.Species.Class+import Math.Combinatorics.Species.AST+import Math.Combinatorics.Species.Util.Interval hiding (omega)+import qualified Math.Combinatorics.Species.Util.Interval as I++import qualified Algebra.Additive as Additive+import qualified Algebra.Ring as Ring+import qualified Algebra.Differential as Differential++import Data.Typeable++-- grr -- can't autoderive this because of URec constructor! =P+instance Eq USpeciesAST where+ UZero == UZero = True+ UOne == UOne = True+ (UN m) == (UN n) = m == n+ UX == UX = True+ UE == UE = True+ UC == UC = True+ UL == UL = True+ USubset == USubset = True+ (UKSubset k) == (UKSubset j) = k == j+ UElt == UElt = True+ (f1 :+:% g1) == (f2 :+:% g2) = f1 == f2 && g1 == g2+ (f1 :*:% g1) == (f2 :*:% g2) = f1 == f2 && g1 == g2+ (f1 :.:% g1) == (f2 :.:% g2) = f1 == f2 && g1 == g2+ (f1 :><:% g1) == (f2 :><:% g2) = f1 == f2 && g1 == g2+ (f1 :@:% g1) == (f2 :@:% g2) = f1 == f2 && g1 == g2+ UDer f1 == UDer f2 = f1 == f2+ -- note, UOfSize will always compare False since we can't compare the functions for equality+ UOfSizeExactly f1 k1 == UOfSizeExactly f2 k2 = f1 == f2 && k1 == k2+ UNonEmpty f1 == UNonEmpty f2 = f1 == f2+ URec f1 == URec f2 = typeOf f1 == typeOf f2+ UOmega == UOmega = True+ _ == _ = False++instance Ord USpeciesAST where+ compare x y | x == y = EQ+ compare UZero _ = LT+ compare _ UZero = GT+ compare UOne _ = LT+ compare _ UOne = GT+ compare (UN m) (UN n) = compare m n+ compare (UN _) _ = LT+ compare _ (UN _) = GT+ compare UX _ = LT+ compare _ UX = GT+ compare UE _ = LT+ compare _ UE = GT+ compare UC _ = LT+ compare _ UC = GT+ compare UL _ = LT+ compare _ UL = GT+ compare USubset _ = LT+ compare _ USubset = GT+ compare (UKSubset j) (UKSubset k) = compare j k+ compare (UKSubset _) _ = LT+ compare _ (UKSubset _) = GT+ compare UElt _ = LT+ compare _ UElt = GT+ compare (f1 :+:% g1) (f2 :+:% g2) | f1 == f2 = compare g1 g2+ | otherwise = compare f1 f2+ compare (_ :+:% _) _ = LT+ compare _ (_ :+:% _) = GT+ compare (f1 :*:% g1) (f2 :*:% g2) | f1 == f2 = compare g1 g2+ | otherwise = compare f1 f2+ compare (_ :*:% _) _ = LT+ compare _ (_ :*:% _) = GT+ compare (f1 :.:% g1) (f2 :.:% g2) | f1 == f2 = compare g1 g2+ | otherwise = compare f1 f2+ compare (_ :.:% _) _ = LT+ compare _ (_ :.:% _) = GT+ compare (f1 :><:% g1) (f2 :><:% g2) | f1 == f2 = compare g1 g2+ | otherwise = compare f1 f2+ compare (_ :><:% _) _ = LT+ compare _ (_ :><:% _) = GT+ compare (f1 :@:% g1) (f2 :@:% g2) | f1 == f2 = compare g1 g2+ | otherwise = compare f1 f2+ compare (_ :@:% _) _ = LT+ compare _ (_ :@:% _) = GT+ compare (UDer f1) (UDer f2) = compare f1 f2+ compare (UDer _) _ = LT+ compare _ (UDer _) = GT+ compare (UOfSize f1 p1) (UOfSize f2 p2) = compare f1 f2+ compare (UOfSize _ _) _ = LT+ compare _ (UOfSize _ _) = GT+ compare (UOfSizeExactly f1 k1) (UOfSizeExactly f2 k2)+ | f1 == f2 = compare k1 k2+ | otherwise = compare f1 f2+ compare (UOfSizeExactly _ _) _ = LT+ compare _ (UOfSizeExactly _ _) = GT+ compare (UNonEmpty f1) (UNonEmpty f2) = compare f1 f2+ compare (UNonEmpty _) _ = LT+ compare _ (UNonEmpty _) = GT+ compare (URec f1) (URec f2) = compare (show $ typeOf f1) (show $ typeOf f2)+ compare UOmega _ = LT+ compare _ UOmega = GT++instance Show USpeciesAST where+ showsPrec _ UZero = shows (0 :: Int)+ showsPrec _ UOne = shows (1 :: Int)+ showsPrec _ (UN n) = shows n+ showsPrec _ UX = showChar 'X'+ showsPrec _ UE = showChar 'E'+ showsPrec _ UC = showChar 'C'+ showsPrec _ UL = showChar 'L'+ showsPrec _ USubset = showChar 'p'+ showsPrec _ (UKSubset n) = showChar 'p' . shows n+ showsPrec _ (UElt) = 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 (UDer f) = showsPrec 11 f . showChar '\''+ showsPrec _ (UOfSize f p) = showChar '<' . showsPrec 0 f . showChar '>'+ showsPrec _ (UOfSizeExactly f n) = showsPrec 11 f . shows n+ showsPrec _ (UNonEmpty f) = showsPrec 11 f . showChar '+'+ showsPrec _ (URec f) = shows f++instance Additive.C USpeciesAST where+ zero = UZero+ (+) = (:+:%)+ negate = error "negation is not implemented yet! wait until virtual species..."++instance Ring.C USpeciesAST where+ (*) = (:*:%)+ one = UOne+ fromInteger 0 = zero+ fromInteger 1 = one+ fromInteger n = UN n+ _ ^ 0 = one+ w ^ 1 = w+ f ^ n = f * (f ^ (n-1))++instance Differential.C USpeciesAST where+ differentiate = UDer++instance Species USpeciesAST where+ singleton = UX+ set = UE+ cycle = UC+ linOrd = UL+ subset = USubset+ ksubset k = UKSubset k+ element = UElt+ o = (:.:%)+ cartesian = (:><:%)+ fcomp = (:@:%)+ ofSize = UOfSize+ ofSizeExactly = UOfSizeExactly+ nonEmpty = UNonEmpty+ rec = URec+ omega = UOmega++instance Show (SpeciesAST s) where+ show = show . erase'++instance Show ESpeciesAST where+ show = show . erase++instance Additive.C ESpeciesAST where+ zero = wrap Zero+ Wrap f + Wrap g = wrap $ f :+: g+ negate = error "negation is not implemented yet! wait until virtual species..."++instance Ring.C ESpeciesAST where+ Wrap f * Wrap g = wrap $ f :*: g+ one = wrap One+ fromInteger 0 = zero+ fromInteger 1 = one+ fromInteger n = wrap $ N n+ _ ^ 0 = one+ w@(Wrap{}) ^ 1 = w+ (Wrap f) ^ n = case (Wrap f) ^ (n-1) of+ (Wrap f') -> wrap $ f :*: f'++instance Differential.C ESpeciesAST where+ differentiate (Wrap f) = wrap (Der f)++instance Species ESpeciesAST where+ singleton = wrap X+ set = wrap E+ cycle = wrap C+ linOrd = wrap L+ subset = wrap Subset+ ksubset k = wrap $ KSubset k+ element = wrap Elt+ o (Wrap f) (Wrap g) = wrap $ f :.: g+ cartesian (Wrap f) (Wrap g) = wrap $ f :><: g+ fcomp (Wrap f) (Wrap g) = wrap $ f :@: g+ ofSize (Wrap f) p = wrap $ OfSize f p+ ofSizeExactly (Wrap f) n = wrap $ OfSizeExactly f n+ nonEmpty (Wrap f) = wrap $ NonEmpty f+ rec f = wrap $ Rec f+ omega = wrap Omega++-- | 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 . L++-- > > reify (ksubset 3)+-- > E3 * E++reify :: ESpeciesAST -> ESpeciesAST+reify = id++-- | Reflect an AST back into any instance of the 'Species' class.+reflectU :: Species s => USpeciesAST -> s+reflectU UZero = 0+reflectU UOne = 1+reflectU (UN n) = fromInteger n+reflectU UX = singleton+reflectU UE = set+reflectU UC = cycle+reflectU UL = linOrd+reflectU USubset = subset+reflectU (UKSubset k) = ksubset k+reflectU UElt = element+reflectU (f :+:% g) = reflectU f + reflectU g+reflectU (f :*:% g) = reflectU f * reflectU g+reflectU (f :.:% g) = reflectU f `o` reflectU g+reflectU (f :><:% g) = reflectU f >< reflectU g+reflectU (f :@:% g) = reflectU f @@ reflectU g+reflectU (UDer f) = oneHole (reflectU f)+reflectU (UOfSize f p) = ofSize (reflectU f) p+reflectU (UOfSizeExactly f n) = ofSizeExactly (reflectU f) n+reflectU (UNonEmpty f) = nonEmpty (reflectU f)+reflectU (URec f) = rec f+reflectU UOmega = omega++reflectT :: Species s => SpeciesAST f -> s+reflectT = reflectU . erase'++-- | Reflect an AST back into any instance of the 'Species' class.+reflect :: Species s => ESpeciesAST -> s+reflect = reflectU . erase
Math/Combinatorics/Species/Class.hs view
@@ -17,7 +17,7 @@ , x , sets , cycles- , lists+ , linOrds , subsets , ksubsets , elements@@ -44,6 +44,8 @@ import NumericPrelude import PreludeBase hiding (cycle) +import Math.Combinatorics.Species.AST+ -- | 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"@@ -64,7 +66,7 @@ -- '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+-- generalization of both 'EGF' and 'GF'), and 'ESpeciesAST' (reified -- species expressions). class (Differential.C s) => Species s where @@ -80,21 +82,22 @@ -- | The species C of cyclical orderings (cycles/rings). cycle :: s - -- | The species L of linear orderings (lists): since lists are- -- isomorphic to cycles with a hole, we may take L = C' as the- -- default implementation; list is included in the 'Species' class- -- so it can be special-cased for generation.- list :: s- list = oneHole cycle+ -- | The species L of linear orderings (lists): since linear+ -- orderings are isomorphic to cyclic orderings with a hole, we+ -- may take L = C' as the default implementation; linOrd is+ -- included in the 'Species' class so it can be special-cased for+ -- enumeration.+ linOrd :: s+ linOrd = oneHole cycle -- | 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+ -- 'Species' class so it can be overridden when enumerating -- structures: since subset is defined as @set * set@, the- -- generation code by default generates a pair of the subset and+ -- enumeration 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@+ -- enumerate subset/complement pairs, you can use @set * set@ -- directly. subset :: s subset = set * set@@ -106,7 +109,7 @@ 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+ -- the underlying set: e = X * E. Included with a default -- definition in 'Species' class for the same reason as 'subset' -- and 'ksubset'. element :: s@@ -125,7 +128,7 @@ -- | 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+ fcomp :: s -> s -> s -- | Only put a structure on underlying sets whose size satisfies -- the predicate.@@ -146,12 +149,12 @@ nonEmpty :: s -> s nonEmpty = flip ofSize (>0) - -- | @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 -+ -- | 'rec f' is the least fixpoint of (the interpretation of) the+ -- higher-order species constructor 'f'.+ rec :: ASTFunctor f => f -> s + -- XXX don't export this!+ omega :: s -- | A convenient synonym for differentiation. F'-structures look -- like F-structures on a set formed by adjoining a distinguished@@ -194,8 +197,8 @@ -- Some species that can be defined in terms of the primitive species -- operations. -lists :: Species s => s-lists = list+linOrds :: Species s => s+linOrds = linOrd elements :: Species s => s elements = element@@ -204,7 +207,7 @@ -- the lists look like \"tentacles\" attached to the cyclic -- \"body\": Oct = C o E+ . octopi, octopus :: Species s => s-octopus = cycle `o` nonEmpty lists+octopus = cycle `o` nonEmpty linOrds octopi = octopus -- | The species of set partitions is just the composition E o E+,@@ -224,7 +227,7 @@ -- | 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+ballot = linOrd `o` nonEmpty sets ballots = ballot ksubsets :: Species s => Integer -> s@@ -238,7 +241,7 @@ simpleGraphs = simpleGraph -- | A directed graph (with loops) is a subset of all pairs drawn--- (without replacement) from the set of vertices: D = p \@\@ (e ><+-- (with 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)
Math/Combinatorics/Species/CycleIndex.hs view
@@ -22,6 +22,8 @@ import Math.Combinatorics.Species.Class import Math.Combinatorics.Species.Labelled +import Math.Combinatorics.Species.NewtonRaphson+ import qualified MathObj.PowerSeries as PowerSeries import qualified MathObj.MultiVarPolynomial as MVP import qualified MathObj.Monomial as Monomial@@ -56,6 +58,11 @@ ( takeWhile ((==n) . Monomial.pDegree) . dropWhile ((<n) . Monomial.pDegree))) s + rec f = case newtonRaphsonRec f 10 of+ Nothing -> error $ "Unable to express " ++ show f ++ " in the form T = X*R(T)."+ Just ls -> ls++ -- | Convert an integer partition to the corresponding monomial in the -- cycle index series for the species of sets. partToMonomial :: CycleType -> Monomial.T Rational@@ -74,7 +81,7 @@ 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+-- | Enumerate 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@. The result type is @[CycleType]@ -- since each integer partition of @n@ corresponds to the cycle type@@ -105,7 +112,7 @@ -- function: F(x) = Z_F(x,0,0,0,...). zToEGF :: CycleIndex -> EGF zToEGF (CI (MVP.Cons xs))- = EGF . PowerSeries.fromCoeffs . map LR+ = EGF . PowerSeries.fromCoeffs . insertZeros . concatMap (\(c,as) -> case as of { [] -> [(0,c)] ; [(1,p)] -> [(p,c)] ; _ -> [] }) . map (Monomial.coeff &&& (M.assocs . Monomial.powers))
+ Math/Combinatorics/Species/Enumerate.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE NoImplicitPrelude+ , GADTs+ , FlexibleContexts+ , ScopedTypeVariables+ , KindSignatures+ , TypeFamilies+ , DeriveDataTypeable+ #-}++-- | Enumeration of labelled and unlabelled species.+module Math.Combinatorics.Species.Enumerate+ (+ -- * Enumeration methods++ enumerate++ , enumerateL+ , enumerateU+ , enumerateM++ , enumerateAll+ , enumerateAllU++ -- * Where all the work actually happens++ , enumerate', enumerateE++ -- * Tools for dealing with structure types++ , Enumerable(..)++ , Structure(..), extractStructure, unsafeExtractStructure+ , structureType, showStructureType++ ) where++import Math.Combinatorics.Species.Class+import Math.Combinatorics.Species.Types+import Math.Combinatorics.Species.AST+import Math.Combinatorics.Species.Structures+import qualified Math.Combinatorics.Species.Util.Interval as I++import qualified Math.Combinatorics.Multiset as MS+import Math.Combinatorics.Multiset (Multiset(..), (+:))++import Data.Typeable++import NumericPrelude+import PreludeBase hiding (cycle)++-- | Given an AST describing a species, with a phantom type parameter+-- representing the structure of the species, and an underlying+-- multiset of elements, compute a list of all possible structures+-- built over the underlying multiset. (Of course, it would be+-- really nice to have a real dependently-typed language for this!)+--+-- Unfortunately, 'SpeciesAST' cannot be made an instance of+-- 'Species', so if we want to be able to enumerate structures given+-- an expression of the 'Species' DSL as input, we must take+-- 'ESpeciesAST' as input, which existentially wraps the phantom+-- structure type---but this means that the output list type must be+-- existentially quantified as well; see 'enumerateE'.+--+-- Generating structures over base elements from a /multiset/+-- unifies labelled and unlabelled generation into one framework.+-- To enumerate labelled structures, use a multiset where each+-- element occurs exactly once; to enumerate unlabelled structures,+-- use a multiset with the desired number of copies of a single+-- element. To do labelled generation we could get away without the+-- generality of multisets, but to do unlabelled generation we need+-- the full generality anyway.+--+-- 'enumerate'' does all the actual work, but is not meant to be used+-- directly; use one of the specialized @enumerateXX@ methods.+enumerate' :: SpeciesAST s -> Multiset a -> [s a]+enumerate' Zero _ = []+enumerate' One (MS []) = [Unit]+enumerate' One _ = []+enumerate' (N n) (MS []) = map Const [1..n]+enumerate' (N _) _ = []+enumerate' X (MS [(x,1)]) = [Id x]+enumerate' X _ = []+enumerate' E xs = [Set (MS.toList xs)]+enumerate' C m = map Cycle (MS.cycles m)+enumerate' L xs = MS.permutations xs+enumerate' Subset xs = map (Set . MS.toList . fst) (MS.splits xs)+enumerate' (KSubset k) xs = map (Set . MS.toList)+ (MS.kSubsets (fromIntegral k) xs)+enumerate' Elt xs = map (Id . fst) . MS.toCounts $ xs+enumerate' (f :+: g) xs = map Inl (enumerate' (stripI f) xs)+ ++ map Inr (enumerate' (stripI g) xs)++ -- XXX working here. Need to change this to use the annotations+ -- which are now contained in f and g. I suppose MS.splits should+ -- be changed (?) to only return splits which are of appropriate+ -- sizes. I guess a quick and dirty solution is just to filter the+ -- things returned by splits to make sure they are in the+ -- appropriate ranges.++ -- XXX use multiset operations instead of 'length'++enumerate' (f :*: g) xs = [ Prod x y+ | (s1,s2) <- MS.splits xs+ , (fromIntegral $ MS.size s1) `I.elem` (getI f)+ , (fromIntegral $ MS.size s2) `I.elem` (getI g)+ , x <- enumerate' (stripI f) s1+ , y <- enumerate' (stripI g) s2+ ]+enumerate' (f :.: g) xs = [ Comp y+ | p <- MS.partitions xs+ , (fromIntegral $ MS.size p) `I.elem` (getI f)+ , all ((`I.elem` (getI g)) . fromIntegral . MS.size) (MS.toList p)+ , xs' <- MS.sequenceMS . fmap (enumerate' (stripI g)) $ p+ , y <- enumerate' (stripI f) xs'+ ]+enumerate' (f :><: g) xs = [ Prod x y+ | x <- enumerate' (stripI f) xs+ , y <- enumerate' (stripI g) xs+ ]+enumerate' (f :@: g) xs = map Comp+ . enumerate' (stripI f)+ . MS.fromDistinctList+ . enumerate' (stripI g)+ $ xs+enumerate' (Der f) xs = map Comp+ . enumerate' (stripI f)+ $ (Star,1) +: fmap Original xs+enumerate' (NonEmpty f) (MS []) = []+enumerate' (NonEmpty f) xs = enumerate' (stripI f) xs+enumerate' (Rec f) xs = map Mu $ enumerate' (apply f (Rec f)) xs+enumerate' (OfSize f p) xs+ | p (fromIntegral . sum . MS.getCounts $ xs)+ = enumerate' (stripI f) xs+ | otherwise = []+enumerate' (OfSizeExactly f n) xs+ | (fromIntegral . sum . MS.getCounts $ xs) == n+ = enumerate' (stripI f) xs+ | otherwise = []++-- | An existential wrapper for structures, hiding the structure+-- functor and ensuring that it is 'Typeable'.+data Structure a where+ Structure :: Typeable1 f => f a -> Structure a++-- | Extract the contents from a 'Structure' wrapper, if we know the+-- type, and map it into an isomorphic type. If the type doesn't+-- match, return a helpful error message instead.+extractStructure :: forall f a. (Enumerable f, Typeable a) =>+ Structure a -> Either String (f a)+extractStructure (Structure s) =+ case cast s of+ Nothing -> Left $+ "Structure type mismatch.\n"+ ++ " Expected: " ++ showStructureType (typeOf (undefined :: StructTy f a)) ++ "\n"+ ++ " Inferred: " ++ showStructureType (typeOf s)+ Just y -> Right (iso y)++-- | A version of 'extractStructure' which calls 'error' with the+-- message in the case of a type mismatch, instead of returning an+-- 'Either'.+unsafeExtractStructure :: (Enumerable f, Typeable a) => Structure a -> f a+unsafeExtractStructure = either error id . extractStructure++-- | @'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 'enumerate' and friends by writing+--+-- > enumerate s ls :: [T L]+--+-- where @ls :: [L]@.+--+-- For example,+--+-- > > structureType octopus+-- > "Comp Cycle []"+-- > > enumerate octopus [1,2,3] :: [Comp Cycle [] Int]+-- > [<[3,2,1]>,<[3,1,2]>,<[2,3,1]>,<[2,1,3]>,<[1,3,2]>+-- > ,<[1,2,3]>,<[1],[3,2]>,<[1],[2,3]>,<[3,1],[2]>+-- > ,<[1,3],[2]>,<[2,1],[3]>,<[1,2],[3]>,<[2],[1],[3]>+-- > ,<[1],[2],[3]>]+structureType :: ESpeciesAST -> String+structureType (Wrap s) = showStructureType . extractType $ (stripI s)+ where extractType :: forall s. Typeable1 s => SpeciesAST s -> TypeRep+ extractType _ = typeOf1 (undefined :: 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, [x]) | tyConString tycon == "[]"+ -> showChar '[' . showsPrecST 11 x . showChar ']'+ (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++-- | 'enumerateE' is a variant of 'enumerate'' which takes an+-- (existentially quantified) 'ESpeciesAST' and returns a list of+-- structures wrapped in the (also existentially quantified)+-- 'Structure' type. This is also not meant to be used directly.+-- Instead, you should use one of the other @enumerateX@ methods.+enumerateE :: ESpeciesAST -> Multiset a -> [Structure a]+enumerateE (Wrap s) m+ | fromIntegral (sum (MS.getCounts m)) `I.elem` (getI s) = map Structure (enumerate' (stripI s) m)+ | otherwise = []+++-- XXX add examples to all of these.++-- | @enumerate s ls@ computes a complete list of distinct+-- @s@-structures over the underlying multiset of labels @ls@. For+-- example:+--+-- > > enumerate octopi [1,2,3] :: [Comp Cycle [] Int]+-- > [<[3,2,1]>,<[3,1,2]>,<[2,3,1]>,<[2,1,3]>,<[1,3,2]>,<[1,2,3]>,+-- > <[1],[3,2]>,<[1],[2,3]>,<[3,1],[2]>,<[1,3],[2]>,<[2,1],[3]>,+-- > <[1,2],[3]>,<[2],[1],[3]>,<[1],[2],[3]>]+-- >+-- > > enumerate octopi [1,1,2] :: [Comp Cycle [] Int]+-- > [<[2,1,1]>,<[1,2,1]>,<[1,1,2]>,<[2,1],[1]>,<[1,2],[1]>,+-- > <[1,1],[2]>,<[1],[1],[2]>]+-- >+-- > > enumerate subsets "abc" :: [Set Int]+-- > [{'a','b','c'},{'a','b'},{'a','c'},{'a'},{'b','c'},{'b'},{'c'},{}]+-- >+-- > > enumerate simpleGraphs [1,2,3] :: [Comp Set Set 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, they must be cast (using the magic+-- of "Data.Typeable") out of an existential wrapper; this is why+-- type annotations are required in all the examples above. Of+-- course, if a call to 'enumerate' is used in the context of some+-- larger program, a type annotation will probably not be needed,+-- due to the magic of type inference.+--+-- For help in knowing what type annotation you can give when+-- enumerating the structures of a particular species, see the+-- 'structureType' function. To be able to use your own custom data+-- type in an enumeration, just make your data type an instance of+-- the 'Enumerable' type class.+--+-- If an invalid type annotation is given, 'enumerate' will call+-- 'error' with a helpful error message. This should not be much of+-- an issue in practice, since usually 'enumerate' will be used at a+-- specific type; it's hard to imagine a usage of 'enumerate' which+-- will sometimes work and sometimes fail. However, those who like+-- their functions total can use 'extractStructure' to make a+-- version of 'enumerate' (or the other variants) with a return type+-- of @[Either String (f a)]@ (which will return an annoying ton of+-- duplicate error message) or @Either String [f a]@ (which has the+-- unfortunate property of being much less lazy than the current+-- versions, since it must compute the entire list before deciding+-- whether to return @Left@ or @Right@).+--+-- For slight variants on 'enumerate', see 'enumerateL',+-- 'enumerateU', and 'enumerateM'.+enumerate :: (Enumerable f, Typeable a, Eq a) => ESpeciesAST -> [a] -> [f a]+enumerate s = enumerateM s . MS.fromListEq++-- | Labelled enumeration: given a species expression and a list of+-- labels (which are assumed to be distinct), compute the list of+-- all structures built from the given labels. If the type given+-- for the enumeration does not match the species expression (via an+-- 'Enumerable' instance), call 'error' with an error message+-- explaining the mismatch.+enumerateL :: (Enumerable f, Typeable a) => ESpeciesAST -> [a] -> [f a]+enumerateL s = enumerateM s . MS.fromDistinctList++-- | Unlabelled enumeration: given a species expression and an integer+-- indicating the number of labels to use, compute the list of all+-- unlabelled structures of the given size. If the type given for+-- the enumeration does not match the species expression, call+-- 'error' with an error message explaining the mismatch.+--+-- Note that @'enumerateU' s n@ is equivalent to @'enumerate' s+-- (replicate n ())@.+enumerateU :: Enumerable f => ESpeciesAST -> Int -> [f ()]+enumerateU s n = enumerateM s (MS.fromCounts [((),n)])++-- | General enumeration: given a species expression and a multiset of+-- labels, compute the list of all distinct structures built from+-- the given labels. If the type given for the enumeration does not+-- match the species expression, call 'error' with a message+-- explaining the mismatch.+enumerateM :: (Enumerable f, Typeable a) => ESpeciesAST -> Multiset a -> [f a]+enumerateM s m = map unsafeExtractStructure $ enumerateE s m++-- | Lazily enumerate all unlabelled structures.+enumerateAllU :: Enumerable f => ESpeciesAST -> [f ()]+enumerateAllU s = concatMap (enumerateU s) [0..]++-- | Lazily enumerate all labelled structures, using [1..] as the+-- labels.+enumerateAll :: Enumerable f => ESpeciesAST -> [f Int]+enumerateAll s = concatMap (\n -> enumerateL s (take n [1..])) [0..]++-- | The 'Enumerable' class allows you to enumerate structures of any+-- type, by declaring an instance of 'Enumerable'. The 'Enumerable'+-- instance requires you to declare a standard structure type (see+-- "Math.Combinatorics.Species.Structures") associated with your+-- type, and a mapping 'iso' from the standard type to your custom+-- one. Instances are provided for all the standard structure types+-- so you can enumerate species without having to provide your own+-- custom data type as the target of the enumeration if you don't+-- want to.+--+-- See "Math.Combinatorics.Species.Rec" for some example instances+-- of 'Enumerable'.+class Typeable1 (StructTy f) => Enumerable (f :: * -> *) where+ -- | The standard structure type (see+ -- "Math.Combinatorics.Species.Structures") that will map into @f@.+ type StructTy f :: * -> *++ -- | The mapping from @'StructTy' f@ to @f@.+ iso :: StructTy f a -> f a++instance Enumerable Void where+ type StructTy Void = Void+ iso = id++instance Enumerable Unit where+ type StructTy Unit = Unit+ iso = id++instance Typeable a => Enumerable (Const a) where+ type StructTy (Const a) = Const a+ iso = id++instance Enumerable Id where+ type StructTy Id = Id+ iso = id++instance (Enumerable f, Enumerable g) => Enumerable (Sum f g) where+ type StructTy (Sum f g) = Sum (StructTy f) (StructTy g)+ iso (Inl x) = Inl (iso x)+ iso (Inr y) = Inr (iso y)++instance (Enumerable f, Enumerable g) => Enumerable (Prod f g) where+ type StructTy (Prod f g) = Prod (StructTy f) (StructTy g)+ iso (Prod x y) = Prod (iso x) (iso y)++instance (Enumerable f, Functor f, Enumerable g) => Enumerable (Comp f g) where+ type StructTy (Comp f g) = Comp (StructTy f) (StructTy g)+ iso (Comp fgx) = Comp (fmap iso (iso fgx))++instance Enumerable [] where+ type StructTy [] = []+ iso = id++instance Enumerable Cycle where+ type StructTy Cycle = Cycle+ iso = id++instance Enumerable Set where+ type StructTy Set = Set+ iso = id++instance Enumerable Star where+ type StructTy Star = Star+ iso = id++instance Typeable f => Enumerable (Mu f) where+ type StructTy (Mu f) = Mu f+ iso = id++instance Enumerable Maybe where+ type StructTy Maybe = Sum Unit Id+ iso (Inl Unit) = Nothing+ iso (Inr (Id x)) = Just x
− Math/Combinatorics/Species/Generate.hs
@@ -1,303 +0,0 @@-{-# LANGUAGE NoImplicitPrelude- , GADTs- , MultiParamTypeClasses- , FlexibleInstances- , FlexibleContexts- , ScopedTypeVariables- #-}---- | 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- , generateTyped- , structureType-- ) where--import Math.Combinatorics.Species.Class-import Math.Combinatorics.Species.Types-import Math.Combinatorics.Species.AST-import Math.Combinatorics.Species.CycleIndex (intPartitions)--import Control.Arrow (first, second)-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; 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, '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--- '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' and--- 'generateTyped' below.-generateF :: SpeciesTypedAST s -> [a] -> [StructureF s a]-generateF (N n) [] = map Const [1..n]-generateF (N _) _ = []-generateF X [x] = [Identity x]-generateF X _ = []-generateF E xs = [Set xs]-generateF C [] = []-generateF C (x:xs) = map (Cycle . (x:)) (sPermutations xs)-generateF L xs = 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- 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 [] = [[]]-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, 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, Typeable1 f, Functor f) => f a -> Structure a--instance (Show a) => Show (Structure a) where- show (Structure t) = showF t--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>>]--- >--- > > generate subsets "abc"--- > [{'a','b','c'},{'a','b'},{'a','c'},{'a'},{'b','c'},{'b'},{'c'},{}]------ > > 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--- > <interactive>: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, [x]) | tyConString tycon == "[]" - -> showChar '[' . showsPrecST 11 x . showChar ']'- (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.------ 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) => 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))-
Math/Combinatorics/Species/Labelled.hs view
@@ -1,16 +1,26 @@-{-# LANGUAGE NoImplicitPrelude +{-# LANGUAGE NoImplicitPrelude , GeneralizedNewtypeDeriving , PatternGuards #-} -- | An interpretation of species as exponential generating functions, -- which count labelled structures.-module Math.Combinatorics.Species.Labelled +module Math.Combinatorics.Species.Labelled ( labelled ) where +-- 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.+ import Math.Combinatorics.Species.Types import Math.Combinatorics.Species.Class +import Math.Combinatorics.Species.AST+import Math.Combinatorics.Species.AST.Instances+import Math.Combinatorics.Species.NewtonRaphson+ import qualified MathObj.PowerSeries as PS import qualified MathObj.FactoredRational as FQ @@ -22,14 +32,14 @@ instance Species EGF where singleton = egfFromCoeffs [0,1]- set = egfFromCoeffs (map (LR . (1%)) facts)- cycle = egfFromCoeffs (0 : map (LR . (1%)) [1..])+ set = egfFromCoeffs (map (1%) facts)+ cycle = egfFromCoeffs (0 : map (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)))+ fcomp = liftEGF2 . PS.lift2 $ \fs gs -> map (\(n,gn) -> let gn' = numerator $ gn+ in (fs `safeIndex` gn')+ * toRational (FQ.factorial gn' / FQ.factorial n)) (zip [0..] $ zipWith (*) (map fromIntegral facts) gs) where safeIndex [] _ = 0 safeIndex (x:_) 0 = x@@ -38,6 +48,12 @@ ofSize s p = (liftEGF . PS.lift1 $ filterCoeffs p) s ofSizeExactly s n = (liftEGF . PS.lift1 $ selectIndex n) s + -- XXX Think about this more carefully -- is there a way to make this actually+ -- return a lazy, infinite list?+ rec f = case newtonRaphsonRec f 100 of+ Nothing -> error $ "Unable to express " ++ show f ++ " in the form T = X*R(T)."+ Just ls -> ls+ -- | 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@@ -52,26 +68,8 @@ -- gives the number of labelled octopi on 0, 1, 2, 3, ... 9 elements. labelled :: EGF -> [Integer]-labelled (EGF f) = (++repeat 0) - . map numerator - . zipWith (*) (map fromInteger facts) - . map unLR +labelled (EGF f) = (++repeat 0)+ . map numerator+ . zipWith (*) (map fromInteger facts) $ 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---
+ Math/Combinatorics/Species/NewtonRaphson.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE NoImplicitPrelude+ #-}++-- | Newton-Raphson's iterative method for computing with recursive+-- species.+module Math.Combinatorics.Species.NewtonRaphson+ (+ newtonRaphsonIter+ , inits'+ , newtonRaphson+ , newtonRaphsonRec+ , solveForR+ ) where++import NumericPrelude+import PreludeBase++import Math.Combinatorics.Species.Class+import Math.Combinatorics.Species.AST+import Math.Combinatorics.Species.AST.Instances (reflectU)+import Math.Combinatorics.Species.Simplify++import Data.Typeable++import Control.Monad (guard)+import Data.List (delete)++-- | @newtonRaphson r k a@ assumes that @a@ is a species having+-- contact of order @k@ with species @t = x * (r `o` t)@ (that is, @a@+-- and @t@ agree on all label sets of size up to and including @k@),+-- and returns a new species with contact of order @2k+2@ with @t@.+--+-- See BLL section 3.3.+newtonRaphsonIter :: Species s => s -> Integer -> s -> s+newtonRaphsonIter r k a = a + sum as+ where p = x * (r `o` a)+ q = x * (oneHole r `o` a)+ ps = map (p `ofSizeExactly`) [k+1..2*k+2]+ qs = map (q `ofSizeExactly`) [1..k+1]+ as = zipWith (+) ps+ (map (sum . zipWith (*) qs) $ map reverse (inits' as))++inits' xs = [] : inits'' xs+inits'' [] = []+inits'' (x:xs) = map (x:) (inits' xs)++-- | Given a species @r@ and a desired accuracy @k@, @newtonRaphson r+-- k@ computes a species which has contact at least @k@ with the+-- species @t = x * (r `o` t)@.+newtonRaphson :: Species s => s -> Integer -> s+newtonRaphson r n = newtonRaphson' 0 0+ where newtonRaphson' a k+ | k >= n = a+ | otherwise = newtonRaphson' (newtonRaphsonIter r k a) (2*k + 2)++newtonRaphsonRec :: (ASTFunctor f, Species s) => f -> Integer -> Maybe s+newtonRaphsonRec code k = fmap (\(n,r) -> n + newtonRaphson r k) (solveForR code)++solveForR :: (ASTFunctor f, Species s) => f -> Maybe (s, s)+solveForR code = do+ let terms = sumOfProducts . erase' $ apply code (Rec code)+ guard . not . null $ terms++ -- If there is a constant term, it will be the first one; pull it+ -- out.+ let (n, terms') = case terms of+ ([UOne] : ts) -> (UOne, ts)+ ([UN n] : ts) -> (UN n, ts)+ ts -> (UZero, ts)++ -- Now we need to be able to factor an X out of the rest.+ guard $ all (UX `elem`) terms'++ -- XXX this is wrong, what if there are still occurrences of X remaining?+ -- Now replace every recursive occurrence by (n + X).+ let r = foldr1 (+) $ map ( foldr1 (*)+ . map (substRec code (n + x))+ . delete UX)+ terms'++ return (reflectU n, reflectU r)+
+ Math/Combinatorics/Species/Simplify.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE NoImplicitPrelude, GADTs #-}++-- | Functions to manipulate and simplify species expressions+-- according to algebraic species isomorphisms.+module Math.Combinatorics.Species.Simplify+ ( simplify, sumOfProducts+ ) where++import NumericPrelude+import PreludeBase++import Math.Combinatorics.Species.AST+import Math.Combinatorics.Species.AST.Instances++import Data.List (genericLength)+import Data.Typeable++simplify :: USpeciesAST -> USpeciesAST+simplify UZero = UZero+simplify UOne = UOne+simplify (UN 0) = UZero+simplify (UN 1) = UOne+simplify f@(UN _) = f+simplify UX = UX+simplify UE = UE+simplify UC = UC+simplify UL = UL+simplify USubset = USubset+simplify f@(UKSubset _) = f+simplify UElt = UElt+simplify (f :+:% g) = simplSum (simplify f) (simplify g)+simplify (f :*:% g) = simplProd (simplify f) (simplify g)+simplify (f :.:% g) = simplComp (simplify f) (simplify g)+simplify (f :><:% g) = simplCart (simplify f) (simplify g)+simplify (f :@:% g) = simplFunc (simplify f) (simplify g)+simplify (UDer f) = simplDer (simplify f)+simplify (UOfSize f p) = simplOfSize (simplify f) p+simplify (UOfSizeExactly f k) = simplOfSizeExactly (simplify f) k+simplify (UNonEmpty f) = simplNonEmpty (simplify f)+simplify (URec f) = URec f+simplify UOmega = UOmega++simplSum :: USpeciesAST -> USpeciesAST -> USpeciesAST+simplSum UZero g = g+simplSum f UZero = f+simplSum UOne UOne = UN 2+simplSum UOne (UN n) = UN $ succ n+simplSum (UN n) UOne = UN $ succ n+simplSum (UN m) (UN n) = UN $ m + n+simplSum UOne (UOne :+:% g) = simplSum (UN 2) g+simplSum UOne ((UN n) :+:% g) = simplSum (UN $ succ n) g+simplSum (UN n) (UOne :+:% g) = simplSum (UN $ succ n) g+simplSum (UN m) ((UN n) :+:% g) = simplSum (UN (m + n)) g+simplSum (f :+:% g) h = simplSum f (simplSum g h)+simplSum f g | f == g = simplProd (UN 2) f+simplSum f (g :+:% h) | f == g = simplSum (simplProd (UN 2) f) h+simplSum (UN n :*:% f) g | f == g = UN (succ n) :*:% f+simplSum f (UN n :*:% g) | f == g = UN (succ n) :*:% f+simplSum (UN m :*:% f) (UN n :*:% g) | f == g = UN (m + n) :*:% f+simplSum f (g :+:% h) | g < f = simplSum g (simplSum f h)+simplSum f g | g < f = g :+:% f+simplSum f g = f :+:% g++simplProd :: USpeciesAST -> USpeciesAST -> USpeciesAST+simplProd UZero _ = UZero+simplProd _ UZero = UZero+simplProd UOne g = g+simplProd f UOne = f+simplProd (UN m) (UN n) = UN $ m * n+simplProd (f1 :+:% f2) g = simplSum (simplProd f1 g) (simplProd f2 g)+simplProd f (g1 :+:% g2) = simplSum (simplProd f g1) (simplProd f g2)+simplProd f (UN n) = simplProd (UN n) f+simplProd (UN m) (UN n :*:% g) = simplProd (UN $ m * n) g+simplProd f ((UN n) :*:% g) = simplProd (UN n) (simplProd f g)+simplProd (f :*:% g) h = simplProd f (simplProd g h)+simplProd f (g :*:% h) | g < f = simplProd g (simplProd f h)+simplProd f g | g < f = g :*:% f+simplProd f g = f :*:% g++simplComp :: USpeciesAST -> USpeciesAST -> USpeciesAST+simplComp UZero _ = UZero+simplComp UOne _ = UOne+simplComp (UN n) _ = UN n+simplComp UX g = g+simplComp f UX = f+simplComp f UZero = simplOfSizeExactly f 0+simplComp (f1 :+:% f2) g = simplSum (simplComp f1 g) (simplComp f2 g)+simplComp (f1 :*:% f2) g = simplProd (simplComp f1 g) (simplComp f2 g)+simplComp (f :.:% g) h = f :.:% (g :.:% h)+simplComp f g = f :.:% g++simplCart :: USpeciesAST -> USpeciesAST -> USpeciesAST+simplCart f g = f :><:% g -- XXX++simplFunc :: USpeciesAST -> USpeciesAST -> USpeciesAST+simplFunc f g = f :@:% g -- XXX++simplDer :: USpeciesAST -> USpeciesAST+simplDer UZero = UZero+simplDer UOne = UZero+simplDer (UN _) = UZero+simplDer UX = UOne+simplDer UE = UE+simplDer UC = UL+simplDer UL = UL :*:% UL+simplDer (f :+:% g) = simplSum (simplDer f) (simplDer g)+simplDer (f :*:% g) = simplSum (simplProd f (simplDer g)) (simplProd (simplDer f) g)+simplDer (f :.:% g) = simplProd (simplComp (simplDer f) g) (simplDer g)+simplDer f = UDer f++simplOfSize :: USpeciesAST -> (Integer -> Bool) -> USpeciesAST+simplOfSize f p = UOfSize f p -- XXX++simplOfSizeExactly :: USpeciesAST -> Integer -> USpeciesAST+simplOfSizeExactly UZero _ = UZero+simplOfSizeExactly UOne 0 = UOne+simplOfSizeExactly UOne _ = UZero+simplOfSizeExactly (UN n) 0 = UN n+simplOfSizeExactly (UN _) _ = UZero+simplOfSizeExactly UX 1 = UX+simplOfSizeExactly UX _ = UZero+simplOfSizeExactly UE 0 = UOne+simplOfSizeExactly UC 0 = UZero+simplOfSizeExactly UL 0 = UOne+simplOfSizeExactly (f :+:% g) k = simplSum (simplOfSizeExactly f k) (simplOfSizeExactly g k)+simplOfSizeExactly (f :*:% g) k = foldr simplSum UZero+ [ simplProd (simplOfSizeExactly f j) (simplOfSizeExactly g (k - j)) | j <- [0..k] ]++-- XXX get this to work?+--+-- Note, it's incorrect to multiply by f. For regular f we can just+-- multiply together all the g's. However for non-regular f this+-- doesn't work. Seems difficult to do this properly...++-- simplOfSizeExactly (f :.:% g) k = foldr simplSum UZero $+-- map (\gs -> simplProd (simplOfSizeExactly f (genericLength gs)) (foldr simplProd UOne gs))+-- [ map (simplOfSizeExactly g) p | p <- intPartitions k ]++simplOfSizeExactly f k = UOfSizeExactly f k++simplNonEmpty :: USpeciesAST -> USpeciesAST+simplNonEmpty f = UNonEmpty f -- XXX++intPartitions :: Integer -> [[Integer]]+intPartitions k = intPartitions' k k+ -- intPartitions' k j gives partitions of k into parts of size at most j+ where intPartitions' 0 _ = [[]]+ intPartitions' k 1 = [replicate (fromInteger k) 1]+ intPartitions' k j = map (j:) (intPartitions' (k - j) (min (k-j) j))+ ++ intPartitions' k (j-1)++-- | Simplify a species and decompose it into a sum of products.+sumOfProducts :: USpeciesAST -> [[USpeciesAST]]+sumOfProducts = terms . simplify+ where terms (f :+:% g) = factors f : terms g+ terms f = [factors f]+ factors (f :*:% g) = f : factors g+ factors f = [f]
+ Math/Combinatorics/Species/Structures.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE NoImplicitPrelude+ , GeneralizedNewtypeDeriving+ , FlexibleContexts+ , DeriveDataTypeable+ , TypeFamilies+ , EmptyDataDecls+ #-}++-- | Types used for expressing generic structures when enumerating species.+module Math.Combinatorics.Species.Structures+ ( -- * Structure functors+ -- $struct++ Void+ , Unit(..)+ , Const(..)+ , Id(..)+ , Sum(..)+ , Prod(..)+ , Comp(..)+ , Cycle(..)+ , Set(..)+ , Star(..)++ , Mu(..), Interp++ ) where++import NumericPrelude+import PreludeBase+import Data.List (intercalate)++import Data.Typeable++--------------------------------------------------------------------------------+-- Structure functors --------------------------------------------------------+--------------------------------------------------------------------------------++-- $struct+-- 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 (constantly) void functor.+data Void a+ deriving Typeable+instance Functor Void where+ fmap _ _ = undefined+instance Show (Void a) where+ show _ = undefined++-- | The (constantly) unit functor.+data Unit a = Unit+ deriving (Typeable, Show)+instance Functor Unit where+ fmap _ Unit = Unit++-- | 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 Typeable2 Const where+ typeOf2 _ = mkTyConApp (mkTyCon "Const") []+instance Typeable x => Typeable1 (Const x) where+ typeOf1 = typeOf1Default++-- | The identity functor.+newtype Id a = Id a+ deriving Typeable+instance Functor Id where+ fmap f (Id x) = Id (f x)+instance (Show a) => Show (Id a) where+ show (Id x) = show x++-- | Functor coproduct.+data Sum f g a = Inl (f a) | Inr (g a)+instance (Functor f, Functor g) => Functor (Sum f g) where+ fmap f (Inl fa) = Inl (fmap f fa)+ fmap f (Inr ga) = Inr (fmap f ga)+instance (Show (f a), Show (g a)) => Show (Sum f g a) where+ show (Inl fa) = "inl(" ++ show fa ++ ")"+ show (Inr ga) = "inr(" ++ show 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.+data Prod f g a = Prod (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 y) = show (x,y)+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)) }+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 (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 { getCycle :: [a] }+ deriving (Functor, Typeable)+instance (Show a) => Show (Cycle a) where+ show (Cycle xs) = "<" ++ intercalate "," (map show xs) ++ ">"++-- | 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) ++ "}"++-- | '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)+instance (Show a) => Show (Star a) where+ show Star = "*"+ show (Original a) = show a++-- | Higher-order fixpoint. @'Mu' f a@ is morally isomorphic to @f ('Mu'+-- f) a@, except that we actually need a level of indirection. In+-- fact @'Mu' f a@ is isomorphic to @'Interp' f ('Mu' f) a@; @f@ is a+-- placeholder which is interpreted by the 'Interp' type function.+data Mu f a = Mu { unMu :: Interp f (Mu f) a }+ deriving Typeable++-- | Interpretation type function for codes for higher-order type+-- constructors, used as arguments to the higher-order fixpoint 'Mu'.+type family Interp f self :: * -> *+
+ Math/Combinatorics/Species/TH.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE NoImplicitPrelude+ , TemplateHaskell+ , FlexibleInstances+ , TypeSynonymInstances+ , TypeFamilies+ , PatternGuards+ , DeriveDataTypeable+ #-}++{- Refactoring plan:++ * need function to compute a (default) species from a Struct.+ - currently have structToSp :: Struct -> Q Exp.+ - [X] refactor it into two pieces, Struct -> USpeciesAST and USpeciesAST -> Q Exp.++ * should really go through and add some comments to things!+ Unfortunately I wasn't good about that when I wrote the code... =P++ * Maybe need to do a similar refactoring of the structToTy stuff?++ * make version of deriveSpecies that takes a USpeciesAST as an argument,+ and use Struct -> USpeciesAST to generate default++ * deriveSpecies should pass the USpeciesAST to... other things that+ currently just destruct the Struct to decide what to do. Will have to+ pattern-match on both the species and the Struct now and make sure+ that they match, which is a bit annoying, but can't really be helped.++-}++-- | Code to derive species instances for user-defined data types.+module Math.Combinatorics.Species.TH where++import NumericPrelude+import PreludeBase hiding (cycle)++import Math.Combinatorics.Species.Class+import Math.Combinatorics.Species.Enumerate+import Math.Combinatorics.Species.Structures+import Math.Combinatorics.Species.AST+import Math.Combinatorics.Species.AST.Instances () -- only import instances++import Control.Arrow (first, second, (***))+import Control.Monad (zipWithM, liftM2, mapM, ap)+import Control.Applicative (Applicative(..), (<$>), (<*>))+import Data.Char (toLower)+import Data.Maybe (isJust)++import Data.Typeable++import Language.Haskell.TH+import Language.Haskell.TH.Syntax (lift)++------------------------------------------------------------+-- Preliminaries -----------------------------------------+------------------------------------------------------------++instance Applicative Q where+ pure = return+ (<*>) = ap++-- | Report a fatal error and stop processing in the 'Q' monad.+errorQ :: String -> Q a+errorQ msg = report True msg >> error msg++------------------------------------------------------------+-- Parsing type declarations -----------------------------+------------------------------------------------------------++-- XXX possible improvement: add special cases to Struct for things+-- like Bool, Either, and (,)++-- | A data structure to represent data type declarations.+data Struct = SId+ | SList+ | SConst Type -- ^ for types of kind *+ | SEnum Type -- ^ for Enumerable type constructors of kind (* -> *)+ | SSumProd [(Name, [Struct])] -- ^ sum-of-products+ | SComp Struct Struct -- ^ composition+ | SSelf -- ^ recursive occurrence+ deriving Show++-- | Extract the relevant information about a type constructor into a+-- 'Struct'.+nameToStruct :: Name -> Q Struct+nameToStruct nm = reify nm >>= infoToStruct+ where infoToStruct (TyConI d) = decToStruct nm d+ infoToStruct _ = errorQ (show nm ++ " is not a type constructor.")++-- XXX do something with contexts? Later extension...++-- | Extract the relevant information about a data type declaration+-- into a 'Struct', given the name of the type and the declaraion.+decToStruct :: Name -> Dec -> Q Struct+decToStruct _ (DataD _ nm [bndr] cons _)+ = SSumProd <$> mapM (conToStruct nm (tyVarNm bndr)) cons+decToStruct _ (NewtypeD _ nm [bndr] con _)+ = SSumProd . (:[]) <$> conToStruct nm (tyVarNm bndr) con+decToStruct _ (TySynD nm [bndr] ty)+ = tyToStruct nm (tyVarNm bndr) ty+decToStruct nm _+ = errorQ $ "Processing " ++ show nm ++ ": Only type constructors of kind * -> * are supported."++-- | Throw away kind annotations to extract the type variable name.+tyVarNm :: TyVarBndr -> Name+tyVarNm (PlainTV n) = n+tyVarNm (KindedTV n _) = n++-- | Extract relevant information about a data constructor. The first+-- two arguments are the name of the type constructor, and the name+-- of its type argument. Returns the name of the data constructor+-- and a list of descriptions of its arguments.+conToStruct :: Name -> Name -> Con -> Q (Name, [Struct])+conToStruct nm var (NormalC cnm tys)+ = (,) cnm <$> mapM (tyToStruct nm var) (map snd tys)+conToStruct nm var (RecC cnm tys)+ = (,) cnm <$> mapM (tyToStruct nm var) (map thrd tys)+ where thrd (_,_,t) = t+conToStruct nm var (InfixC ty1 cnm ty2)+ = (,) cnm <$> mapM (tyToStruct nm var) [snd ty1, snd ty2]++ -- XXX do something with ForallC?++-- XXX check this...+-- | Extract a 'Struct' describing an arbitrary type.+tyToStruct :: Name -> Name -> Type -> Q Struct+tyToStruct nm var (VarT v) | v == var = return SId+ | otherwise = errorQ $ "Unknown variable " ++ show v+tyToStruct nm var ListT = return SList+tyToStruct nm var t@(ConT b)+ | b == ''[] = return SList+ | otherwise = return $ SConst t++tyToStruct nm var (AppT t (VarT v)) -- F `o` X === F+ | v == var && t == (ConT nm) = return $ SSelf -- recursive occurrence+ | v == var = return $ SEnum t -- t had better be Enumerable+ | otherwise = errorQ $ "Unknown variable " ++ show v+tyToStruct nm var (AppT t1 t2@(AppT _ _)) -- composition+ = SComp <$> tyToStruct nm var t1 <*> tyToStruct nm var t2+tyToStruct nm vars t@(AppT _ _)+ = return $ SConst t++-- XXX add something to deal with tuples?+-- XXX add something to deal with things that are actually OK like Either a [a]+-- and so on+-- XXX deal with arrow types?++------------------------------------------------------------+-- Misc Struct utilities ---------------------------------+------------------------------------------------------------++-- | Decide whether a type is recursively defined, given its+-- description.+isRecursive :: Struct -> Bool+isRecursive (SSumProd cons) = any isRecursive (concatMap snd cons)+isRecursive (SComp s1 s2) = isRecursive s1 || isRecursive s2+isRecursive SSelf = True+isRecursive _ = False++------------------------------------------------------------+-- Generating default species ----------------------------+------------------------------------------------------------++-- | Convert a 'Struct' into a default corresponding species.+structToSp :: Struct -> USpeciesAST+structToSp SId = UX+structToSp SList = UL+structToSp (SConst (ConT t))+ | t == ''Bool = UN 2+ | otherwise = error $ "structToSp: unrecognized type " ++ show t ++ " in SConst"+structToSp (SEnum t) = error "SEnum in structToSp"+structToSp (SSumProd []) = UZero+structToSp (SSumProd ss) = foldl1 (+) $ map conToSp ss+structToSp (SComp s1 s2) = structToSp s1 `o` structToSp s2+structToSp SSelf = UOmega++-- | Convert a data constructor and its arguments into a default+-- species.+conToSp :: (Name, [Struct]) -> USpeciesAST+conToSp (_,[]) = UOne+conToSp (_,ps) = foldl1 (*) $ map structToSp ps++------------------------------------------------------------+-- Generating things from species ------------------------+------------------------------------------------------------++-- | Given a name to use in recursive occurrences, convert a species+-- AST into an actual splice-able expression of type Species s => s.+spToExp :: Name -> USpeciesAST -> Q Exp+spToExp self = spToExp'+ where+ spToExp' UZero = [| 0 |]+ spToExp' UOne = [| 1 |]+ spToExp' (UN n) = lift n+ spToExp' UX = [| singleton |]+ spToExp' UE = [| set |]+ spToExp' UC = [| cycle |]+ spToExp' UL = [| linOrd |]+ spToExp' USubset = [| subset |]+ spToExp' (UKSubset k) = [| ksubset $(lift k) |]+ spToExp' UElt = [| element |]+ spToExp' (f :+:% g) = [| $(spToExp' f) + $(spToExp' g) |]+ spToExp' (f :*:% g) = [| $(spToExp' f) * $(spToExp' g) |]+ spToExp' (f :.:% g) = [| $(spToExp' f) `o` $(spToExp' g) |]+ spToExp' (f :><:% g) = [| $(spToExp' f) >< $(spToExp' g) |]+ spToExp' (f :@:% g) = [| $(spToExp' f) @@ $(spToExp' g) |]+ spToExp' (UDer f) = [| oneHole $(spToExp' f) |]+ spToExp' (UOfSize _ _) = error "Can't reify general size predicate into code"+ spToExp' (UOfSizeExactly f k) = [| $(spToExp' f) `ofSizeExactly` $(lift k) |]+ spToExp' (UNonEmpty f) = [| nonEmpty $(spToExp' f) |]+ spToExp' (URec _) = [| wrap $(varE self) |]+ spToExp' UOmega = [| wrap $(varE self) |]++-- | Generate the structure type for a given species.+spToTy :: Name -> USpeciesAST -> Q Type+spToTy self = spToTy'+ where+ spToTy' UZero = [t| Void |]+ spToTy' UOne = [t| Unit |]+ spToTy' (UN n) = [t| Const Integer |] -- was finTy n, but that+ -- doesn't match up with the+ -- type annotation on SpeciesAST+ spToTy' UX = [t| Id |]+ spToTy' UE = [t| Set |]+ spToTy' UC = [t| Cycle |]+ spToTy' UL = [t| [] |]+ spToTy' USubset = [t| Set |]+ spToTy' (UKSubset _) = [t| Set |]+ spToTy' UElt = [t| Id |]+ spToTy' (f :+:% g) = [t| Sum $(spToTy' f) $(spToTy' g) |]+ spToTy' (f :*:% g) = [t| Prod $(spToTy' f) $(spToTy' g) |]+ spToTy' (f :.:% g) = [t| Comp $(spToTy' f) $(spToTy' g) |]+ spToTy' (f :><:% g) = [t| Prod $(spToTy' f) $(spToTy' g) |]+ spToTy' (f :@:% g) = [t| Comp $(spToTy' f) $(spToTy' g) |]+ spToTy' (UDer f) = [t| Star $(spToTy' f) |]+ spToTy' (UOfSize f _) = spToTy' f+ spToTy' (UOfSizeExactly f _) = spToTy' f+ spToTy' (UNonEmpty f) = spToTy' f+ spToTy' (URec _) = varT self+ spToTy' UOmega = varT self++{-+-- | Generate a finite type of a given size, using a binary scheme.+finTy :: Integer -> Q Type+finTy 0 = [t| Void |]+finTy 1 = [t| Unit |]+finTy 2 = [t| Const Bool |]+finTy n | even n = [t| Prod (Const Bool) $(finTy $ n `div` 2) |]+ | otherwise = [t| Sum Unit $(finTy $ pred n) |]+-}++------------------------------------------------------------+-- Code generation ---------------------------------------+------------------------------------------------------------++-- Enumerable ----------------++-- | Generate an instance of the Enumerable type class, i.e. an+-- isomorphism from the user's data type and the structure type+-- corresponding to the chosen species (or to the default species if+-- the user did not specify one).+--+-- If the third argument is @Nothing@, generate a normal+-- non-recursive instance. If the third argument is @Just code@,+-- then the instance is for a recursive type with the given code.+mkEnumerableInst :: Name -> USpeciesAST -> Struct -> Maybe Name -> Q Dec+mkEnumerableInst nm sp st code = do+ clauses <- mkIsoClauses (isJust code) sp st+ let stTy = case code of+ Just cd -> [t| Mu $(conT cd) |]+ Nothing -> spToTy undefined sp -- undefined is OK, it isn't recursive+ -- so won't use that argument+ instanceD (return []) (appT (conT ''Enumerable) (conT nm))+ [ tySynInstD ''StructTy [conT nm] stTy+ , return $ FunD 'iso clauses+ ]++-- | Generate the clauses for the definition of the 'iso' method in+-- the 'Enumerable' instance, which translates from the structure+-- type of the species to the user's data type. The first argument+-- indicates whether the type is recursive.+mkIsoClauses :: Bool -> USpeciesAST -> Struct -> Q [Clause]+mkIsoClauses isRec sp st = (fmap.map) (mkClause isRec) (mkIsoMatches sp st)+ where mkClause False (pat, exp) = Clause [pat] (NormalB $ exp) []+ mkClause True (pat, exp) = Clause [ConP 'Mu [pat]] (NormalB $ exp) []++mkIsoMatches :: USpeciesAST -> Struct -> Q [(Pat, Exp)]+mkIsoMatches _ SId = newName "x" >>= \x ->+ return [(ConP 'Id [VarP x], VarE x)]+mkIsoMatches _ (SConst t)+ | t == ConT ''Bool = return [(ConP 'Const [LitP $ IntegerL 1], ConE 'False)+ ,(ConP 'Const [LitP $ IntegerL 2], ConE 'True)]+ | otherwise = error "mkIsoMatches: unrecognized type in SConst case"+mkIsoMatches _ (SEnum t) = newName "x" >>= \x ->+ return [(VarP x, AppE (VarE 'iso) (VarE x))]+mkIsoMatches _ (SSumProd []) = return []+mkIsoMatches sp (SSumProd [con]) = mkIsoConMatches sp con+mkIsoMatches sp (SSumProd cons) = addInjs 0 <$> zipWithM mkIsoConMatches (terms sp) cons+ where terms (f :+:% g) = terms f ++ [g]+ terms f = [f]++ addInjs :: Int -> [[(Pat, Exp)]] -> [(Pat, Exp)]+ addInjs n [ps] = map (addInj (n-1) 'Inr) ps+ addInjs n (ps:pss) = map (addInj n 'Inl) ps ++ addInjs (n+1) pss+ addInj 0 c = first (ConP c . (:[]))+ addInj n c = first (ConP 'Inr . (:[])) . addInj (n-1) c++-- XXX the below is not correct...+-- should really do iso1 . fmap iso2 where iso1 = ... iso2 = ...+-- which are obtained from recursive calls.+mkIsoMatches _ (SComp s1 s2) = newName "x" >>= \x ->+ return [ (ConP 'Comp [VarP x]+ , AppE (VarE 'iso) (AppE (AppE (VarE 'fmap) (VarE 'iso)) (VarE x))) ]+mkIsoMatches _ SSelf = newName "s" >>= \s ->+ return [(VarP s, AppE (VarE 'iso) (VarE s))]++mkIsoConMatches :: USpeciesAST -> (Name, [Struct]) -> Q [(Pat, Exp)]+mkIsoConMatches _ (cnm, []) = return [(ConP 'Unit [], ConE cnm)]+mkIsoConMatches sp (cnm, ps) = map mkProd . sequence <$> zipWithM mkIsoMatches (factors sp) ps+ where factors (f :*:% g) = factors f ++ [g]+ factors f = [f]++ mkProd :: [(Pat, Exp)] -> (Pat, Exp)+ mkProd = (foldl1 (\x y -> (ConP 'Prod [x, y])) *** foldl AppE (ConE cnm))+ . unzip++-- Species definition --------++-- | Given a name n, generate the declaration+--+-- > n :: Species s => s+--+mkSpeciesSig :: Name -> Q Dec+mkSpeciesSig nm = sigD nm [t| Species s => s |]++-- XXX can this use quasiquoting?+-- | Given a name n and a species, generate a declaration for it of+-- that name. The third parameter indicates whether the species is+-- recursive, and if so what the name of the code is.+mkSpecies :: Name -> USpeciesAST -> Maybe Name -> Q Dec+mkSpecies nm sp (Just code) = valD (varP nm) (normalB (appE (varE 'rec) (conE code))) []+mkSpecies nm sp Nothing = valD (varP nm) (normalB (spToExp undefined sp)) []++{-+structToSpAST :: Name -> Struct -> Q Exp+structToSpAST _ SId = [| X |]+structToSpAST _ (SConst t) = error "SConst in structToSpAST?"+structToSpAST self (SEnum t) = typeToSpAST self t+structToSpAST _ (SSumProd []) = [| Zero |]+structToSpAST self (SSumProd ss) = foldl1 (\x y -> [| annI $x :+: annI $y |])+ $ map (conToSpAST self) ss+structToSpAST self (SComp s1 s2) = [| annI $(structToSpAST self s1) :.: annI $(structToSpAST self s2) |]+structToSpAST self SSelf = varE self++conToSpAST :: Name -> (Name, [Struct]) -> Q Exp+conToSpAST _ (_,[]) = [| One |]+conToSpAST self (_,ps) = foldl1 (\x y -> [| annI $x :*: annI $y |]) $ map (structToSpAST self) ps++typeToSpAST :: Name -> Type -> Q Exp+typeToSpAST _ ListT = [| L |]+typeToSpAST self (ConT c) | c == ''[] = [| L |]+ | otherwise = nameToStruct c >>= structToSpAST self -- XXX this is wrong! Need to do something else for recursive types?+typeToSpAST _ _ = error "non-constructor in typeToSpAST?"+-}++------------------------------------------------------------+-- Putting it all together -------------------------------+------------------------------------------------------------++-- XXX need to add something to check whether the type and given+-- species are compatible.++deriveDefaultSpecies :: Name -> Q [Dec]+deriveDefaultSpecies nm = do+ st <- nameToStruct nm+ deriveSpecies nm (structToSp st)++deriveSpecies :: Name -> USpeciesAST -> Q [Dec]+deriveSpecies nm sp = do+ st <- nameToStruct nm+ let spNm = mkName . map toLower . nameBase $ nm+ if (isRecursive st)+ then mkEnumerableRec nm spNm st sp+ else mkEnumerableNonrec nm spNm st sp+ where+ mkEnumerableRec nm spNm st sp = do+ codeNm <- newName (nameBase nm)+ self <- newName "self"++ let declCode = DataD [] codeNm [] [NormalC codeNm []] [''Typeable]++ [showCode] <- [d| instance Show $(conT codeNm) where+ show _ = $(lift (nameBase nm))+ |]++ [interpCode] <- [d| type instance Interp $(conT codeNm) $(varT self)+ = $(spToTy self sp)+ |]++ applyBody <- NormalB <$> [| unwrap $(spToExp self sp) |]+ let astFunctorInst = InstanceD [] (AppT (ConT ''ASTFunctor) (ConT codeNm))+ [FunD 'apply [Clause [WildP, VarP self] applyBody []]]++ [showMu] <- [d| instance Show a => Show (Mu $(conT codeNm) a) where+ show = show . unMu+ |]++ enum <- mkEnumerableInst nm sp st (Just codeNm)+ sig <- mkSpeciesSig spNm+ spD <- mkSpecies spNm sp (Just codeNm)++ return $ [ declCode+ , showCode+ , interpCode+ , astFunctorInst+ , showMu+ , enum+ , sig+ , spD+ ]++ mkEnumerableNonrec nm spNm st sp =+ sequence+ [ mkEnumerableInst nm sp st Nothing+ , mkSpeciesSig spNm+ , mkSpecies spNm sp Nothing+ ]
Math/Combinatorics/Species/Types.hs view
@@ -1,10 +1,5 @@ {-# LANGUAGE NoImplicitPrelude- , EmptyDataDecls- , TypeFamilies- , TypeOperators- , FlexibleContexts , GeneralizedNewtypeDeriving- , DeriveDataTypeable #-} -- | Some common types used by the species library, along with some@@ -14,12 +9,6 @@ CycleType - -- * Lazy multiplication-- , LazyRing(..)- , LazyQ- , LazyZ- -- * Series types , EGF(..)@@ -40,34 +29,13 @@ , filterCoeffs , selectIndex - -- * Higher-order Show-- , ShowF(..)- , RawString(..)-- -- * Structure functors- -- $struct-- , Const(..)- , Identity(..)- , Sum(..)- , Prod(..)- , Comp(..)- , Cycle(..)- , Set(..)- , Star(..)-- -- * Type-level species- -- $typespecies-- , Z, X, E, C, L, Sub, Elt, (:+:), (:*:), (:.:), (:><:), (:@:), Der- , StructureF ) where -import Data.List (intercalate, genericReplicate) import NumericPrelude import PreludeBase+import Data.List (genericReplicate) + import qualified MathObj.PowerSeries as PS import qualified MathObj.MultiVarPolynomial as MVP import qualified MathObj.Monomial as Monomial@@ -78,56 +46,26 @@ import qualified Algebra.ZeroTestable as ZeroTestable import qualified Algebra.Field as Field -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 -------------------------------------------------------------------------------------------------------------------------------------------- | 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)+newtype EGF = EGF { unEGF :: PS.T Rational }+ deriving (Additive.C, Differential.C, Ring.C, Show) -egfFromCoeffs :: [LazyQ] -> EGF+egfFromCoeffs :: [Rational] -> EGF egfFromCoeffs = EGF . PS.fromCoeffs -liftEGF :: (PS.T LazyQ -> PS.T LazyQ) -> EGF -> EGF+liftEGF :: (PS.T Rational -> PS.T Rational) -> EGF -> EGF liftEGF f (EGF x) = EGF (f x) -liftEGF2 :: (PS.T LazyQ -> PS.T LazyQ -> PS.T LazyQ)+liftEGF2 :: (PS.T Rational -> PS.T Rational -> PS.T Rational) -> EGF -> EGF -> EGF liftEGF2 f (EGF x) (EGF y) = EGF (f x y) @@ -180,182 +118,3 @@ 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. 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-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-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- 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 (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) }-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 ++ ")"-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)) }-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)-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 { getCycle :: [a] }- deriving (Functor, Typeable)-instance (Show a) => Show (Cycle a) where- 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)-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--- '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 X-data E-data C-data L-data Sub-data Elt-data (:+:) f g-data (:*:) f g-data (:.:) f g-data (:><:) f g-data (:@:) f g-data Der 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 X = Identity-type instance StructureF E = Set-type instance StructureF C = Cycle-type instance StructureF L = []-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-
Math/Combinatorics/Species/Unlabelled.hs view
@@ -1,12 +1,14 @@ -- | An interpretation of species as ordinary generating functions, -- which count unlabelled structures.-module Math.Combinatorics.Species.Unlabelled +module Math.Combinatorics.Species.Unlabelled ( unlabelled ) where import Math.Combinatorics.Species.Types import Math.Combinatorics.Species.Class import Math.Combinatorics.Species.AST+import Math.Combinatorics.Species.AST.Instances (reflect) import Math.Combinatorics.Species.CycleIndex+import Math.Combinatorics.Species.NewtonRaphson import qualified MathObj.PowerSeries as PS @@ -31,6 +33,10 @@ ofSize s p = (liftGF . PS.lift1 $ filterCoeffs p) s ofSizeExactly s n = (liftGF . PS.lift1 $ selectIndex n) s + rec f = case newtonRaphsonRec f 100 of+ Nothing -> error $ "Unable to express " ++ show f ++ " in the form T = X*R(T)."+ Just ls -> ls+ unlabelledCoeffs :: GF -> [Integer] unlabelledCoeffs (GF p) = PS.coeffs p ++ repeat 0 @@ -46,7 +52,7 @@ -- -- 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 'SpeciesAST' rather than the expected 'GF'. The reason+-- which is 'ESpeciesAST' 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, -- other operations such as composition and differentiation do not!@@ -58,7 +64,7 @@ -- 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+unlabelled :: ESpeciesAST -> [Integer]+unlabelled s+ | needsZE s = unlabelledCoeffs . zToGF . reflect $ s | otherwise = unlabelledCoeffs . reflect $ s
+ Math/Combinatorics/Species/Util/Interval.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE NoImplicitPrelude+ #-}+-- | A simple implementation of intervals of natural numbers, for use+-- in tracking the possible sizes of structures of a species. For+-- example, the species X + X^2 + X^3 will correspond to the+-- interval [1,3].+module Math.Combinatorics.Species.Util.Interval+ (+ -- * The 'NatO' type+ NatO, omega, natO++ -- * The 'Interval' type+ , Interval, iLow, iHigh++ -- * Interval operations+ , decrI, union, intersect, elem, toList++ -- * Constructing intervals+ , natsI, fromI, emptyI, omegaI+ ) where++import NumericPrelude+import PreludeBase hiding (elem)++import qualified Algebra.Additive as Additive+import qualified Algebra.Ring as Ring++-- | 'NatO' is an explicit representation of the co-inductive Nat type+-- which admits an infinite value, omega. Our intuition for the+-- semantics of 'NatO' comes from thinking of it as an efficient+-- representation of lazy unary natural numbers, except that we can+-- actually test for omega in finite time.+data NatO = Nat Integer | Omega+ deriving (Eq, Ord, Show)++omega :: NatO+omega = Omega++-- | Eliminator for 'NatO' values.+natO :: (Integer -> a) -> a -> NatO -> a+natO _ o Omega = o+natO f _ (Nat n) = f n++-- | Decrement a possibly infinite natural. Zero and omega are both+-- fixed points of 'decr'.+decr :: NatO -> NatO+decr (Nat 0) = Nat 0+decr (Nat n) = Nat (n-1)+decr Omega = Omega++-- | 'NatO' forms an additive monoid, with zero as the identity. This+-- doesn't quite fit since Additive.C is supposed to be for groups,+-- so the 'negate' method just throws an error. But we'll never use+-- it and 'NatO' won't be directly exposed to users of the species+-- library anyway.+instance Additive.C NatO where+ zero = Nat 0+ Nat m + Nat n = Nat (m + n)+ _ + _ = Omega+ negate = error "naturals with omega only form a semiring"++-- | In fact, 'NatO' forms a semiring, with 1 as the multiplicative+-- unit.+instance Ring.C NatO where+ one = Nat 1+ Nat 0 * _ = Nat 0+ _ * Nat 0 = Nat 0+ Nat m * Nat n = Nat (m * n)+ _ * _ = Omega++ fromInteger = Nat++-- | An 'Interval' is a closed range of consecutive integers. Both+-- endpoints are represented as 'NatO' values. For example, [2,5]+-- represents the values 2,3,4,5; [2,omega] represents all integers+-- greater than 1; intervals where the first endpoint is greater than the+-- second also represent the empty interval.+data Interval = I { iLow :: NatO+ , iHigh :: NatO+ }+ deriving Show++-- | Decrement both endpoints of an interval.+decrI :: Interval -> Interval+decrI (I l h) = I (decr l) (decr h)++-- | The union of two intervals is the smallest interval containing+-- both.+union :: Interval -> Interval -> Interval+union (I l1 h1) (I l2 h2) = I (min l1 l2) (max h1 h2)++-- | The intersection of two intervals is the largest interval+-- contained in both.+intersect :: Interval -> Interval -> Interval+intersect (I l1 h1) (I l2 h2) = I (max l1 l2) (min h1 h2)++-- | Intervals can be added by adding their endpoints pointwise.+instance Additive.C Interval where+ zero = I 0 0+ (I l1 h1) + (I l2 h2) = I (l1 + l2) (h1 + h2)+ negate = error "Interval negation: intervals only form a semiring"++-- | Intervals form a semiring, with the multiplication operation+-- being pointwise multiplication of their endpoints.+instance Ring.C Interval where+ one = I 1 1+ (I l1 h1) * (I l2 h2) = I (l1 * l2) (h1 * h2)+ fromInteger n = I (Nat n) (Nat n)++-- | Test a given integer for interval membership.+elem :: Integer -> Interval -> Bool+elem n (I lo Omega) = lo <= fromInteger n+elem n (I lo (Nat hi)) = lo <= fromInteger n && n <= hi++-- | Convert an interval to a list of Integers.+toList :: Interval -> [Integer]+toList (I Omega Omega) = []+toList (I lo hi) | lo > hi = []+toList (I (Nat lo) Omega) = [lo..]+toList (I (Nat lo) (Nat hi)) = [lo..hi]++-- | The range [0,omega] containing all natural numbers.+natsI :: Interval+natsI = I 0 Omega++-- | Construct an open range [n,omega].+fromI :: NatO -> Interval+fromI n = I n Omega++-- | The empty interval.+emptyI :: Interval+emptyI = I 1 0++-- | The interval which contains only omega.+omegaI :: Interval+omegaI = I Omega Omega
species.cabal view
@@ -1,10 +1,10 @@ name: species-version: 0.2.1+version: 0.3 license: BSD3 license-file: LICENSE build-type: Simple-cabal-version: >= 1.2.3-tested-with: GHC == 6.10.3+cabal-version: >= 1.6+tested-with: GHC >= 6.10 && < 6.11, GHC == 6.12.1 author: Brent Yorgey maintainer: Brent Yorgey <byorgey@cis.upenn.edu> category: Math@@ -13,11 +13,16 @@ 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.+homepage: http://www.cis.upenn.edu/~byorgey/species+source-repository head+ type: darcs+ location: http://code.haskell.org/~byorgey/code/species Library- build-depends: base >= 3.0 && < 4.2, numeric-prelude >= 0.1.1 && < 0.2,- np-extras >= 0.2 && < 0.3, containers >= 0.2 && < 0.3,- lub >= 0.0.5 && < 0.1+ build-depends: base >= 3 && < 5, numeric-prelude >= 0.1.1 && < 0.2,+ np-extras >= 0.2.0.2 && < 0.3, containers >= 0.2 && < 0.4,+ multiset-comb >= 0.2,+ template-haskell >= 2.4 && < 2.5 exposed-modules: Math.Combinatorics.Species Math.Combinatorics.Species.Class@@ -26,5 +31,11 @@ Math.Combinatorics.Species.Unlabelled Math.Combinatorics.Species.CycleIndex Math.Combinatorics.Species.AST- Math.Combinatorics.Species.Generate+ Math.Combinatorics.Species.AST.Instances+ Math.Combinatorics.Species.Structures+ Math.Combinatorics.Species.Enumerate+ Math.Combinatorics.Species.TH+ Math.Combinatorics.Species.Util.Interval+ Math.Combinatorics.Species.NewtonRaphson+ Math.Combinatorics.Species.Simplify extensions: NoImplicitPrelude