module Ideas.Common.Strategy.Sequential
( Sequential(..)
, Process
, Builder, build
, empty, firsts, scanChoice, prune
, fromAtoms
, Sym(..)
, atomic, concurrent, (<@>)
, withPath, replay
, uniquePath, tidyProcess
) where
import Ideas.Common.Strategy.Path
class Sequential f where
ok, stop :: f a
single :: a -> f a
(~>) :: a -> f a -> f a
(<|>) :: f a -> f a -> f a
(<?>) :: f a -> f a -> f a
(<*>) :: f a -> f a -> f a
choice :: [f a] -> f a
single a = a ~> ok
a ~> p = single a <*> p
p <?> q = p <|> q
choice = foldr (<|>) stop
infixr 3 :~>, ~>
data Process a
= Process a :|: Process a
| Process a :?: Process a
| a :~> Process a
| Ok
| Stop
deriving (Show, Eq)
instance Sequential Process where
ok = Ok
stop = Stop
(~>) = (:~>)
(<?>) = (:?:)
(<|>) = (:|:)
p <*> Ok = p
p <*> q = fold (Alg (<|>) (:?:) (:~>) q Stop) p
newtype Builder a = B (Process a -> Process a)
instance Sequential Builder where
ok = B id
stop = B (const Stop)
single a = B (a ~>)
a ~> B f = B ((a ~>) . f)
B f <|> B g = B (\p -> f p <|> g p)
B f <?> B g = B (\p -> f p <?> g p)
B f <*> B g = B (f . g)
build :: Builder a -> Process a
build (B f) = f Ok
data Alg a b = Alg
{ forChoice :: b -> b -> b
, forEither :: b -> b -> b
, forPrefix :: a -> b -> b
, forOk :: b
, forStop :: b
}
fold :: Alg a b -> Process a -> b
fold alg = rec
where
rec (p :|: q) = forChoice alg (rec p) (rec q)
rec (p :?: q) = forEither alg (rec p) (rec q)
rec (a :~> p) = forPrefix alg a (rec p)
rec Ok = forOk alg
rec Stop = forStop alg
empty :: Process a -> Bool
empty = fold $ Alg (||) (||) (\_ _ -> False) True False
firsts :: Process a -> [(a, Process a)]
firsts = ($ []) . rec
where
rec (p :|: q) = rec p . rec q
rec (p :?: q) = rec p . rec q
rec (a :~> p) = ((a, p):)
rec Ok = id
rec Stop = id
scanChoice :: (a -> b -> [(a, c)]) -> a -> Process b -> Process c
scanChoice f = rec
where
rec a (p :|: q) = rec a p :|: rec a q
rec a (p :?: q) = rec a p :?: rec a q
rec a (b :~> p) = choice [ c :~> rec a2 p | (a2, c) <- f a b ]
rec _ Ok = Ok
rec _ Stop = Stop
prune :: (a -> Bool) -> Process a -> Process a
prune f = fst . fold Alg
{ forChoice = \ ~(p, b1) ~(q, b2) -> (p <|> q, b1 || b2)
, forEither = \p q -> if snd p then p else q
, forPrefix = \a ~(p, b) -> (a ~> p, f a || b)
, forOk = (ok, True)
, forStop = (stop, False)
}
useFirst :: Sequential f => (a -> Process a -> f b) -> f b -> Process a -> f b
useFirst op e = rec
where
rec (p :|: q) = rec p <|> rec q
rec (p :?: q) = rec p <?> rec q
rec (a :~> p) = op a p
rec Ok = e
rec Stop = stop
data Sym a = Single a | Composed (Process a)
fromAtoms :: Process (Sym a) -> Process a
fromAtoms (Single a :~> q) = a ~> fromAtoms q
fromAtoms (Composed p :~> q) = p <*> fromAtoms q
fromAtoms (p :|: q) = fromAtoms p <|> fromAtoms q
fromAtoms (p :?: q) = fromAtoms p <?> fromAtoms q
fromAtoms Ok = ok
fromAtoms Stop = stop
atomic :: Sequential f => Process (Sym a) -> f (Sym a)
atomic = single . Composed . fromAtoms
concurrent :: Sequential f => (a -> Bool) -> Process a -> Process a -> f a
concurrent switch = normal
where
normal p q = stepBoth q p <|> (stepRight q p <|> stepRight p q)
stepBoth = useFirst stop2 . useFirst stop2 ok
stop2 _ _ = stop
stepRight p = useFirst op stop
where
op a = (a ~>) . (if switch a then normal else stepRight) p
(<@>) :: Sequential f => Process a -> Process a -> f a
p <@> q = useFirst (\a r -> a ~> (q <@> r)) bothOk p
where
bothOk = useFirst (\_ _ -> stop) ok q
withPath :: Process a -> Process (a, Path)
withPath = rec emptyPath
where
rec path (p :|: q) = rec (toLeft path) p :|: rec (toRight path) q
rec path (p :?: q) = rec (toLeft path) p :?: rec (toRight path) q
rec path (a :~> p) = let next = tick path
in (a, next) :~> rec next p
rec _ Ok = Ok
rec _ Stop = Stop
replay :: Monad m => Path -> Process a -> m ([a], Process a)
replay = flip (rec [])
where
rec acc process path
| path == emptyPath = return (acc, process)
| otherwise =
case process of
p :|: q -> choose p q
p :?: q -> choose p q
a :~> p -> untick path >>= rec (a:acc) p
_ -> fail "replay: invalid path"
where
choose p q = leftOrRight path >>= either (rec acc p) (rec acc q)
filterP :: (a -> Bool) -> Process a -> Process a
filterP p = fold idAlg
{ forPrefix = \a q -> if p a then a ~> q else stop }
idAlg :: Sequential f => Alg a (f a)
idAlg = Alg
{ forChoice = (<|>)
, forEither = (<?>)
, forPrefix = (~>)
, forOk = ok
, forStop = stop
}
tidyProcess :: (a -> a -> Bool) -> (a -> Bool) -> Process a -> Process a
tidyProcess eq cond = step2 . step1
where
step1 = fold idAlg { forChoice = rmChoiceUnitZero
, forPrefix = rmPrefix
}
step2 = fold idAlg { forChoice = rmSameChoice }
rmChoiceUnitZero p q =
case (p, q) of
(Stop, _) -> q
(_, Stop) -> p
(Ok, _) -> ok
(_, Ok) -> ok
_ -> p <|> q
rmPrefix a p | cond a = p
| otherwise = a ~> p
rmSameChoice p q = if cmpProcesses eq p q
then p
else p <|> q
cmpProcesses :: (a -> b -> Bool) -> Process a -> Process b -> Bool
cmpProcesses f = rec
where
rec (p :|: q) (r :|: s) = rec p r && rec q s
rec (p :?: q) (r :?: s) = rec p r && rec q s
rec (a :~> p) (b :~> q) = f a b && rec p q
rec Ok Ok = True
rec Stop Stop = True
rec _ _ = False
uniquePath :: (a -> Bool) -> (a -> a -> Bool) -> Process a -> Process a
uniquePath cond eq = rec
where
rec (p :|: q) = let f x = not $ any (eq x) (map fst $ firstsWith cond p)
in rec p <|> rec (filterP f q)
rec (p :?: q) = rec p :?: rec q
rec (a :~> p) = a :~> rec p
rec Ok = Ok
rec Stop = Stop
firstsWith :: (a -> Bool) -> Process a -> [(a, Process a)]
firstsWith p = concatMap f . firsts
where
f (r, q) | p r = [(r, q)]
| otherwise = firstsWith p q