{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Math.Combinatorics.Species.AST
(
SpeciesAST(..)
, TSpeciesAST(..)
, SizedSpeciesAST(..)
, interval, annI, getI, stripI
, ESpeciesAST(..), wrap, unwrap
, erase, erase', annotate
, ASTFunctor(..)
, needsCI
, substRec
) where
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 NumericPrelude
#if MIN_VERSION_numeric_prelude(0,2,0)
#else
import PreludeBase hiding (cycle)
#endif
data SpeciesAST where
Zero :: SpeciesAST
One :: SpeciesAST
N :: Integer -> SpeciesAST
X :: SpeciesAST
E :: SpeciesAST
C :: SpeciesAST
B :: SpeciesAST
L :: SpeciesAST
Subset :: SpeciesAST
KSubset :: Integer -> SpeciesAST
Elt :: SpeciesAST
(:+) :: SpeciesAST -> SpeciesAST -> SpeciesAST
(:*) :: SpeciesAST -> SpeciesAST -> SpeciesAST
(:.) :: SpeciesAST -> SpeciesAST -> SpeciesAST
(:><) :: SpeciesAST -> SpeciesAST -> SpeciesAST
(:@) :: SpeciesAST -> SpeciesAST -> SpeciesAST
Der :: SpeciesAST -> SpeciesAST
OfSize :: SpeciesAST -> (Integer -> Bool) -> SpeciesAST
OfSizeExactly :: SpeciesAST -> Integer -> SpeciesAST
NonEmpty :: SpeciesAST -> SpeciesAST
Rec :: ASTFunctor f => f -> SpeciesAST
Omega :: SpeciesAST
data TSpeciesAST (s :: * -> *) where
TZero :: TSpeciesAST Void
TOne :: TSpeciesAST Unit
TN :: Integer -> TSpeciesAST (Const Integer)
TX :: TSpeciesAST Id
TE :: TSpeciesAST Set
TC :: TSpeciesAST Cycle
TB :: TSpeciesAST Bracelet
TL :: TSpeciesAST []
TSubset :: TSpeciesAST Set
TKSubset :: Integer -> TSpeciesAST Set
TElt :: TSpeciesAST Id
(:+::) :: SizedSpeciesAST f -> SizedSpeciesAST g -> TSpeciesAST (f :+: g)
(:*::) :: SizedSpeciesAST f -> SizedSpeciesAST g -> TSpeciesAST (f :*: g)
(:.::) :: SizedSpeciesAST f -> SizedSpeciesAST g -> TSpeciesAST (f :.: g)
(:><::) :: SizedSpeciesAST f -> SizedSpeciesAST g -> TSpeciesAST (f :*: g)
(:@::) :: SizedSpeciesAST f -> SizedSpeciesAST g -> TSpeciesAST (f :.: g)
TDer :: SizedSpeciesAST f -> TSpeciesAST (f :.: Star)
TOfSize :: SizedSpeciesAST f -> (Integer -> Bool) -> TSpeciesAST f
TOfSizeExactly :: SizedSpeciesAST f -> Integer -> TSpeciesAST f
TNonEmpty :: SizedSpeciesAST f -> TSpeciesAST f
TRec :: ASTFunctor f => f -> TSpeciesAST (Mu f)
TOmega :: TSpeciesAST Void
data SizedSpeciesAST (s :: * -> *) where
Sized :: Interval -> TSpeciesAST s -> SizedSpeciesAST s
interval :: TSpeciesAST s -> Interval
interval TZero = emptyI
interval TOne = zero
interval (TN _) = zero
interval TX = one
interval TE = natsI
interval TC = fromI one
interval TB = fromI one
interval TL = natsI
interval TSubset = natsI
interval (TKSubset k) = fromI (fromInteger k)
interval TElt = fromI one
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 (_ :@:: _) = natsI
interval (TDer f) = decrI (getI f)
interval (TOfSize f p) = fromI $ smallestIn (getI f) p
interval (TOfSizeExactly f n) = fromInteger n `I.intersect` getI f
interval (TNonEmpty f) = fromI one `I.intersect` getI f
interval (TRec f) = interval (apply f TOmega)
interval TOmega = omegaI
smallestIn :: Interval -> (Integer -> Bool) -> NatO
smallestIn i p = case filter p (toList i) of
[] -> I.omega
(x:_) -> fromIntegral x
annI :: TSpeciesAST s -> SizedSpeciesAST s
annI s = Sized (interval s) s
stripI :: SizedSpeciesAST s -> TSpeciesAST s
stripI (Sized _ s) = s
getI :: SizedSpeciesAST s -> Interval
getI (Sized i _) = i
data ESpeciesAST where
Wrap :: Typeable s => SizedSpeciesAST s -> ESpeciesAST
wrap :: Typeable s => TSpeciesAST s -> ESpeciesAST
wrap = Wrap . annI
unwrap :: Typeable s => ESpeciesAST -> TSpeciesAST 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
erase :: ESpeciesAST -> SpeciesAST
erase (Wrap s) = erase' (stripI s)
erase' :: TSpeciesAST f -> SpeciesAST
erase' TZero = Zero
erase' TOne = One
erase' (TN n) = N n
erase' TX = X
erase' TE = E
erase' TC = C
erase' TB = B
erase' TL = L
erase' TSubset = Subset
erase' (TKSubset k) = KSubset k
erase' TElt = Elt
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' (TDer f) = Der . erase' . stripI $ f
erase' (TOfSize f p) = OfSize (erase' . stripI $ f) p
erase' (TOfSizeExactly f k) = OfSizeExactly (erase' . stripI $ f) k
erase' (TNonEmpty f) = NonEmpty . erase' . stripI $ f
erase' (TRec f) = Rec f
erase' TOmega = Omega
annotate :: SpeciesAST -> ESpeciesAST
annotate Zero = wrap TZero
annotate One = wrap TOne
annotate (N n) = wrap (TN n)
annotate X = wrap TX
annotate E = wrap TE
annotate C = wrap TC
annotate B = wrap TB
annotate L = wrap TL
annotate Subset = wrap TSubset
annotate (KSubset k) = wrap (TKSubset k)
annotate Elt = wrap TElt
annotate (f :+ g) = annotate f + annotate g
where Wrap f + Wrap g = wrap $ f :+:: g
annotate (f :* g) = annotate f * annotate g
where Wrap f * Wrap g = wrap $ f :*:: g
annotate (f :. g) = annotate f . annotate g
where Wrap f . Wrap g = wrap $ f :.:: g
annotate (f :>< g) = annotate f >< annotate g
where Wrap f >< Wrap g = wrap $ f :><:: g
annotate (f :@ g) = annotate f @@ annotate g
where Wrap f @@ Wrap g = wrap $ f :@:: g
annotate (Der f) = der $ annotate f
where der (Wrap f) = wrap (TDer f)
annotate (OfSize f p) = ofSize $ annotate f
where ofSize (Wrap f) = wrap $ TOfSize f p
annotate (OfSizeExactly f k) = ofSize $ annotate f
where ofSize (Wrap f) = wrap $ TOfSizeExactly f k
annotate (NonEmpty f) = nonEmpty $ annotate f
where nonEmpty (Wrap f) = wrap $ TNonEmpty f
annotate (Rec f) = wrap $ TRec f
annotate Omega = wrap TOmega
class (Typeable f, Show f, Typeable (Interp f (Mu f))) => ASTFunctor f where
apply :: Typeable g => f -> TSpeciesAST g -> TSpeciesAST (Interp f g)
needsCI :: SpeciesAST -> Bool
needsCI L = True
needsCI (f :+ g) = needsCI f || needsCI g
needsCI (f :* g) = needsCI f || needsCI g
needsCI (_ :. _) = True
needsCI (_ :>< _) = True
needsCI (_ :@ _) = True
needsCI (Der _) = True
needsCI (OfSize f _) = needsCI f
needsCI (OfSizeExactly f _) = needsCI f
needsCI (NonEmpty f) = needsCI f
needsCI (Rec _) = True
needsCI _ = False
substRec :: ASTFunctor f => f -> SpeciesAST -> SpeciesAST -> SpeciesAST
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 (Der f) = Der (substRec c e f)
substRec c e (OfSize f p) = OfSize (substRec c e f) p
substRec c e (OfSizeExactly f k) = OfSizeExactly (substRec c e f) k
substRec c e (NonEmpty f) = NonEmpty (substRec c e f)
substRec c e (Rec c')
| (show . typeOf $ c) == (show . typeOf $ c') = e
substRec _ _ f = f