module Math.Combinatorics.Species.AST
(
SpeciesTypedAST(..)
, SpeciesAST(..)
, needsZT, needsZ
, reify
, reflectT
, reflect
) where
import Math.Combinatorics.Species.Class
import Math.Combinatorics.Species.Types
import qualified Algebra.Additive as Additive
import qualified Algebra.Ring as Ring
import qualified Algebra.Differential as Differential
import Data.Typeable
import NumericPrelude
import PreludeBase hiding (cycle)
data SpeciesTypedAST s where
O :: SpeciesTypedAST Z
I :: SpeciesTypedAST (S Z)
X :: SpeciesTypedAST X
E :: SpeciesTypedAST E
C :: SpeciesTypedAST C
Subset :: SpeciesTypedAST Sub
KSubset :: Integer -> SpeciesTypedAST Sub
Elt :: SpeciesTypedAST Elt
(:+:) :: (ShowF (StructureF f), ShowF (StructureF g))
=> SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :+: g)
(:*:) :: (ShowF (StructureF f), ShowF (StructureF g))
=> SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :*: g)
(:.:) :: (ShowF (StructureF f), ShowF (StructureF g))
=> SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :.: g)
(:><:) :: (ShowF (StructureF f), ShowF (StructureF g))
=> SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :><: g)
(:@:) :: (ShowF (StructureF f), ShowF (StructureF g))
=> SpeciesTypedAST f -> SpeciesTypedAST g -> SpeciesTypedAST (f :@: g)
Der :: (ShowF (StructureF f))
=> SpeciesTypedAST f -> SpeciesTypedAST (Der f)
OfSize :: SpeciesTypedAST f -> (Integer -> Bool) -> SpeciesTypedAST f
OfSizeExactly :: SpeciesTypedAST f -> Integer -> SpeciesTypedAST f
NonEmpty :: SpeciesTypedAST f -> SpeciesTypedAST f
instance Show (SpeciesTypedAST s) where
showsPrec _ O = showChar '0'
showsPrec _ I = showChar '1'
showsPrec _ X = showChar 'X'
showsPrec _ E = showChar 'E'
showsPrec _ C = showChar 'C'
showsPrec _ Subset = showChar 'p'
showsPrec _ (KSubset n) = showChar 'p' . shows n
showsPrec _ (Elt) = showChar 'e'
showsPrec p (f :+: g) = showParen (p>6) $ showsPrec 6 f . showString " + " . showsPrec 6 g
showsPrec p (f :*: g) = showParen (p>=7) $ showsPrec 7 f . showString " * " . showsPrec 7 g
showsPrec p (f :.: g) = showParen (p>=7) $ showsPrec 7 f . showString " . " . showsPrec 7 g
showsPrec p (f :><: g) = showParen (p>=7) $ showsPrec 7 f . showString " >< " . showsPrec 7 g
showsPrec p (f :@: g) = showParen (p>=7) $ showsPrec 7 f . showString " @ " . showsPrec 7 g
showsPrec p (Der f) = showsPrec 11 f . showChar '\''
showsPrec _ (OfSize f p) = showChar '<' . showsPrec 0 f . showChar '>'
showsPrec _ (OfSizeExactly f n) = showsPrec 11 f . shows n
showsPrec _ (NonEmpty f) = showsPrec 11 f . showChar '+'
needsZT :: 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
data SpeciesAST where
SA :: (ShowF (StructureF s), Typeable1 (StructureF s))
=> SpeciesTypedAST s -> SpeciesAST
needsZ :: SpeciesAST -> Bool
needsZ (SA s) = needsZT s
instance Show SpeciesAST where
show (SA f) = show f
instance Additive.C SpeciesAST where
zero = SA O
(SA f) + (SA g) = SA (f :+: g)
negate = error "negation is not implemented yet! wait until virtual species..."
instance Ring.C SpeciesAST where
(SA f) * (SA g) = SA (f :*: g)
one = SA I
instance Differential.C SpeciesAST where
differentiate (SA f) = SA (Der f)
instance Species SpeciesAST where
singleton = SA X
set = SA E
cycle = SA C
subset = SA Subset
ksubset k = SA (KSubset k)
element = SA Elt
o (SA f) (SA g) = SA (f :.: g)
cartesian (SA f) (SA g) = SA (f :><: g)
fcomp (SA f) (SA g) = SA (f :@: g)
ofSize (SA f) p = SA (OfSize f p)
ofSizeExactly (SA f) n = SA (OfSizeExactly f n)
nonEmpty (SA f) = SA (NonEmpty f)
reify :: SpeciesAST -> SpeciesAST
reify = id
reflectT :: Species s => SpeciesTypedAST f -> s
reflectT O = zero
reflectT I = one
reflectT X = singleton
reflectT E = set
reflectT C = cycle
reflectT Subset = subset
reflectT (KSubset k) = ksubset k
reflectT Elt = element
reflectT (f :+: g) = reflectT f + reflectT g
reflectT (f :*: g) = reflectT f * reflectT g
reflectT (f :.: g) = reflectT f `o` reflectT g
reflectT (f :><: g) = reflectT f >< reflectT g
reflectT (f :@: g) = reflectT f @@ reflectT g
reflectT (Der f) = oneHole (reflectT f)
reflectT (OfSize f p) = ofSize (reflectT f) p
reflectT (OfSizeExactly f n) = ofSizeExactly (reflectT f) n
reflectT (NonEmpty f) = nonEmpty (reflectT f)
reflect :: Species s => SpeciesAST -> s
reflect (SA f) = reflectT f