module Ideas.Common.Strategy.Core
( GCore(..), Core
, (.|.), (.*.), (.%.)
, coreMany, coreRepeat, coreOrElse, coreFix
, noLabels, substCoreVar
) where
import Control.Applicative
import Ideas.Common.Classes
import Ideas.Common.Rule
import Ideas.Common.Utils.QuickCheck
import Ideas.Common.Utils.Uniplate
import qualified Data.Foldable as F
import qualified Data.Traversable as T
infixr 2 :%:, :!%:, .%.
infixr 3 :|:, :|>:, .|.
infixr 5 :*:, .*.
type Core l a = GCore l (Rule a)
data GCore l a
= GCore l a :*: GCore l a
| GCore l a :|: GCore l a
| GCore l a :|>: GCore l a
| GCore l a :%: GCore l a
| GCore l a :!%: GCore l a
| Many (GCore l a)
| Repeat (GCore l a)
| Not (GCore l a)
| Label l (GCore l a)
| Atomic (GCore l a)
| Succeed
| Fail
| Rule a
| Var Int
| Rec Int (GCore l a)
deriving Show
instance Functor (GCore l) where
fmap = mapSecond
instance Uniplate (GCore l a) where
uniplate core =
case core of
a :*: b -> plate (:*:) |* a |* b
a :|: b -> plate (:|:) |* a |* b
a :|>: b -> plate (:|>:) |* a |* b
a :%: b -> plate (:%:) |* a |* b
a :!%: b -> plate (:!%:) |* a |* b
Many a -> plate Many |* a
Repeat a -> plate Repeat |* a
Label l a -> plate Label |- l |* a
Atomic a -> plate Atomic |* a
Rec n a -> plate Rec |- n |* a
Not a -> plate Not |* a
_ -> plate core
instance BiFunctor GCore where
biMap f g = rec
where
rec core =
case core of
a :*: b -> rec a :*: rec b
a :|: b -> rec a :|: rec b
a :|>: b -> rec a :|>: rec b
a :%: b -> rec a :%: rec b
a :!%: b -> rec a :!%: rec b
Many a -> Many (rec a)
Repeat a -> Repeat (rec a)
Not a -> Not (rec a)
Atomic a -> Atomic (rec a)
Rec n a -> Rec n (rec a)
Label l a -> Label (f l) (rec a)
Rule a -> Rule (g a)
Var n -> Var n
Succeed -> Succeed
Fail -> Fail
instance T.Traversable (GCore l) where
traverse f core =
case core of
a :*: b -> (:*:) <$> T.traverse f a <*> T.traverse f b
a :|: b -> (:|:) <$> T.traverse f a <*> T.traverse f b
a :|>: b -> (:|>:) <$> T.traverse f a <*> T.traverse f b
a :%: b -> (:%:) <$> T.traverse f a <*> T.traverse f b
a :!%: b -> (:!%:) <$> T.traverse f a <*> T.traverse f b
Many a -> Many <$> T.traverse f a
Repeat a -> Repeat <$> T.traverse f a
Label l a -> Label l <$> T.traverse f a
Atomic a -> Atomic <$> T.traverse f a
Rec n a -> Rec n <$> T.traverse f a
Not a -> Not <$> T.traverse f a
Rule r -> Rule <$> f r
Succeed -> pure Succeed
Fail -> pure Fail
Var n -> pure $ Var n
instance F.Foldable (GCore l) where
foldMap = T.foldMapDefault
instance (Arbitrary l, Arbitrary a) => Arbitrary (GCore l a) where
arbitrary = generators
[ constGens [Succeed, Fail]
, unaryGen Atomic, arbGen Rule, unaryArbGen Label
, binaryGens [(:*:), (:|:), (:%:)]
]
(.|.) :: GCore l a -> GCore l a -> GCore l a
Fail .|. b = b
a .|. Fail = a
a .|. b = a :|: b
(.*.) :: GCore l a -> GCore l a -> GCore l a
Fail .*. _ = Fail
Succeed .*. b = b
_ .*. Fail = Fail
a .*. Succeed = a
a .*. b = a :*: b
(.%.) :: GCore l a -> GCore l a -> GCore l a
Fail .%. _ = Fail
Succeed .%. b = b
_ .%. Fail = Fail
a .%. Succeed = a
a .%. b = a :%: b
coreMany :: GCore l a -> GCore l a
coreMany a = Rec n (Succeed :|: (a :*: Var n))
where n = nextVar a
coreRepeat :: GCore l a -> GCore l a
coreRepeat a = Many a :*: Not a
coreOrElse :: GCore l a -> GCore l a -> GCore l a
coreOrElse a b = a :|: (Not a :*: b)
coreFix :: (GCore l a -> GCore l a) -> GCore l a
coreFix f =
let i = nextVar (f (Var (1)))
in Rec i (f (Var i))
substCoreVar :: Int -> GCore l a -> GCore l a -> GCore l a
substCoreVar i a core =
case core of
Var j | i==j -> a
Rec j _ | i==j -> core
_ -> descend (substCoreVar i a) core
nextVar :: GCore l a -> Int
nextVar p
| null xs = 0
| otherwise = maximum xs + 1
where xs = coreVars p
coreVars :: GCore l a -> [Int]
coreVars core =
case core of
Var n -> [n]
Rec n a -> n : coreVars a
_ -> concatMap coreVars (children core)
noLabels :: GCore l a -> GCore l a
noLabels (Label _ a) = noLabels a
noLabels core = descend noLabels core