diff --git a/Math/Combinatorics/Species.hs b/Math/Combinatorics/Species.hs --- a/Math/Combinatorics/Species.hs +++ b/Math/Combinatorics/Species.hs @@ -12,8 +12,12 @@ -- For a friendly introduction to combinatorial species in general -- and this library in particular, see my series of blog posts: -- --- +-- * -- +-- * +-- +-- * +-- -- For a good reference (really, the -- only English-language reference!) on combinatorial species, see -- Bergeron, Labelle, and Leroux, \"Combinatorial Species and @@ -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 diff --git a/Math/Combinatorics/Species/AST.hs b/Math/Combinatorics/Species/AST.hs --- a/Math/Combinatorics/Species/AST.hs +++ b/Math/Combinatorics/Species/AST.hs @@ -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 diff --git a/Math/Combinatorics/Species/AST/Instances.hs b/Math/Combinatorics/Species/AST/Instances.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/AST/Instances.hs @@ -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 diff --git a/Math/Combinatorics/Species/Class.hs b/Math/Combinatorics/Species/Class.hs --- a/Math/Combinatorics/Species/Class.hs +++ b/Math/Combinatorics/Species/Class.hs @@ -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) diff --git a/Math/Combinatorics/Species/CycleIndex.hs b/Math/Combinatorics/Species/CycleIndex.hs --- a/Math/Combinatorics/Species/CycleIndex.hs +++ b/Math/Combinatorics/Species/CycleIndex.hs @@ -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 (( 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)) diff --git a/Math/Combinatorics/Species/Enumerate.hs b/Math/Combinatorics/Species/Enumerate.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Enumerate.hs @@ -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 diff --git a/Math/Combinatorics/Species/Generate.hs b/Math/Combinatorics/Species/Generate.hs deleted file mode 100644 --- a/Math/Combinatorics/Species/Generate.hs +++ /dev/null @@ -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 --- > :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)) - diff --git a/Math/Combinatorics/Species/Labelled.hs b/Math/Combinatorics/Species/Labelled.hs --- a/Math/Combinatorics/Species/Labelled.hs +++ b/Math/Combinatorics/Species/Labelled.hs @@ -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 --- diff --git a/Math/Combinatorics/Species/NewtonRaphson.hs b/Math/Combinatorics/Species/NewtonRaphson.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/NewtonRaphson.hs @@ -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) + diff --git a/Math/Combinatorics/Species/Simplify.hs b/Math/Combinatorics/Species/Simplify.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Simplify.hs @@ -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] diff --git a/Math/Combinatorics/Species/Structures.hs b/Math/Combinatorics/Species/Structures.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Structures.hs @@ -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 :: * -> * + diff --git a/Math/Combinatorics/Species/TH.hs b/Math/Combinatorics/Species/TH.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/TH.hs @@ -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 + ] diff --git a/Math/Combinatorics/Species/Types.hs b/Math/Combinatorics/Species/Types.hs --- a/Math/Combinatorics/Species/Types.hs +++ b/Math/Combinatorics/Species/Types.hs @@ -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 - diff --git a/Math/Combinatorics/Species/Unlabelled.hs b/Math/Combinatorics/Species/Unlabelled.hs --- a/Math/Combinatorics/Species/Unlabelled.hs +++ b/Math/Combinatorics/Species/Unlabelled.hs @@ -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 diff --git a/Math/Combinatorics/Species/Util/Interval.hs b/Math/Combinatorics/Species/Util/Interval.hs new file mode 100644 --- /dev/null +++ b/Math/Combinatorics/Species/Util/Interval.hs @@ -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 diff --git a/species.cabal b/species.cabal --- a/species.cabal +++ b/species.cabal @@ -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 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