module Math.Combinatorics.Species.Types
(
CycleType
, LazyRing(..)
, LazyQ
, LazyZ
, EGF(..)
, egfFromCoeffs
, liftEGF
, liftEGF2
, GF(..)
, gfFromCoeffs
, liftGF
, liftGF2
, CycleIndex(..)
, ciFromMonomials
, liftCI
, liftCI2
, filterCoeffs
, selectIndex
, ShowF(..)
, RawString(..)
, Const(..)
, Identity(..)
, Sum(..)
, Prod(..)
, Comp(..)
, Cycle(..)
, Set(..)
, Star(..)
, Z, X, E, C, L, Sub, Elt, (:+:), (:*:), (:.:), (:><:), (:@:), Der
, StructureF
) where
import Data.List (intercalate, genericReplicate)
import NumericPrelude
import PreludeBase
import qualified MathObj.PowerSeries as PS
import qualified MathObj.MultiVarPolynomial as MVP
import qualified MathObj.Monomial as Monomial
import qualified Algebra.Additive as Additive
import qualified Algebra.Ring as Ring
import qualified Algebra.Differential as Differential
import qualified Algebra.ZeroTestable as ZeroTestable
import qualified Algebra.Field as Field
import Data.Lub (parCommute, HasLub(..), flatLub)
import Data.Typeable
type CycleType = [(Integer, Integer)]
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
newtype EGF = EGF (PS.T LazyQ)
deriving (Additive.C, Ring.C, Differential.C, Show)
egfFromCoeffs :: [LazyQ] -> EGF
egfFromCoeffs = EGF . PS.fromCoeffs
liftEGF :: (PS.T LazyQ -> PS.T LazyQ) -> EGF -> EGF
liftEGF f (EGF x) = EGF (f x)
liftEGF2 :: (PS.T LazyQ -> PS.T LazyQ -> PS.T LazyQ)
-> EGF -> EGF -> EGF
liftEGF2 f (EGF x) (EGF y) = EGF (f x y)
newtype GF = GF (PS.T Integer)
deriving (Additive.C, Ring.C, Show)
gfFromCoeffs :: [Integer] -> GF
gfFromCoeffs = GF . PS.fromCoeffs
liftGF :: (PS.T Integer -> PS.T Integer) -> GF -> GF
liftGF f (GF x) = GF (f x)
liftGF2 :: (PS.T Integer -> PS.T Integer -> PS.T Integer)
-> GF -> GF -> GF
liftGF2 f (GF x) (GF y) = GF (f x y)
newtype CycleIndex = CI (MVP.T Rational)
deriving (Additive.C, Ring.C, Differential.C, Show)
ciFromMonomials :: [Monomial.T Rational] -> CycleIndex
ciFromMonomials = CI . MVP.Cons
liftCI :: (MVP.T Rational -> MVP.T Rational)
-> CycleIndex -> CycleIndex
liftCI f (CI x) = CI (f x)
liftCI2 :: (MVP.T Rational -> MVP.T Rational -> MVP.T Rational)
-> CycleIndex -> CycleIndex -> CycleIndex
liftCI2 f (CI x) (CI y) = CI (f x y)
filterCoeffs :: (Additive.C a) => (Integer -> Bool) -> [a] -> [a]
filterCoeffs p = zipWith (filterCoeff p) [0..]
where filterCoeff p n x | p n = x
| otherwise = Additive.zero
selectIndex :: (Ring.C a, Eq a) => Integer -> [a] -> [a]
selectIndex n xs = xs'
where mx = safeIndex n xs
safeIndex _ [] = Nothing
safeIndex 0 (x:_) = Just x
safeIndex n (_:xs) = safeIndex (n1) xs
xs' = case mx of
Just 0 -> []
Just x -> genericReplicate n 0 ++ [x]
_ -> []
class Functor f => ShowF f where
showF :: (Show a) => f a -> String
instance ShowF [] where
showF = show
newtype RawString = RawString String
instance Show RawString where
show (RawString s) = s
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
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
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
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
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
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
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
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
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
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