-- | -- This module contains a VPA (Visibly Pushdown Automaton) implementation of the internal derivative algorithm. -- -- It is intended to be used for explanation purposes. -- -- It shows how our algorithm is effectively equivalent to a visibly pushdown automaton. module Data.Katydid.Relapse.VpaDerive ( derive ) where import qualified Data.Map.Strict as M import Control.Monad.State (State, runState, state, lift) import Data.Foldable (foldlM) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Data.Katydid.Parser.Parser import qualified Data.Katydid.Relapse.Derive as Derive import Data.Katydid.Relapse.Smart (Grammar, Pattern) import qualified Data.Katydid.Relapse.Smart as Smart import Data.Katydid.Relapse.IfExprs import Data.Katydid.Relapse.Expr import Data.Katydid.Relapse.Zip mem :: Ord k => (k -> v) -> k -> M.Map k v -> (v, M.Map k v) mem f k m | M.member k m = (m M.! k, m) | otherwise = let res = f k in (res, M.insert k res m) type VpaState = [Pattern] type StackElm = ([Pattern], Zipper) type Calls = M.Map VpaState ZippedIfExprs type Nullable = M.Map [Pattern] [Bool] type Returns = M.Map ([Pattern], Zipper, [Bool]) [Pattern] newtype Vpa = Vpa (Nullable, Calls, Returns, Grammar) newVpa :: Grammar -> Vpa newVpa g = Vpa (M.empty, M.empty, M.empty, g) nullable :: [Pattern] -> State Vpa [Bool] nullable key = state $ \(Vpa (n, c, r, g)) -> let (v', n') = mem (map Smart.nullable) key n; in (v', Vpa (n', c, r, g)) calls :: [Pattern] -> State Vpa ZippedIfExprs calls key = state $ \(Vpa (n, c, r, g)) -> let (v', c') = mem (zipIfExprs . Derive.calls g) key c; in (v', Vpa (n, c', r, g)) vpacall :: VpaState -> Label -> ExceptT String (State Vpa) (StackElm, VpaState) vpacall vpastate label = do { zifexprs <- lift $ calls vpastate; (nextstate, zipper) <- hoistExcept $ evalZippedIfExprs zifexprs label; let stackelm = (vpastate, zipper) ; return (stackelm, nextstate) } hoistExcept :: (Monad m) => Either e a -> ExceptT e m a hoistExcept = ExceptT . return returns :: ([Pattern], Zipper, [Bool]) -> State Vpa [Pattern] returns key = state $ \(Vpa (n, c, r, g)) -> let (v', r') = mem (\(ps, zipper, znulls) -> Derive.returns g (ps, unzipby zipper znulls)) key r in (v', Vpa (n, c, r', g)) vpareturn :: StackElm -> VpaState -> State Vpa VpaState vpareturn (vpastate, zipper) current = do { zipnulls <- nullable current; returns (vpastate, zipper, zipnulls) } deriv :: Tree t => VpaState -> t -> ExceptT String (State Vpa) VpaState deriv current tree = do { (stackelm, nextstate) <- vpacall current (getLabel tree); resstate <- foldlM deriv nextstate (getChildren tree); lift $ vpareturn stackelm resstate } foldLT :: Tree t => Vpa -> VpaState -> [t] -> Either String [Pattern] foldLT _ current [] = return current foldLT m current (t:ts) = let (newstate, newm) = runState (runExceptT $ deriv current t) m in case newstate of (Left l) -> Left l (Right r) -> foldLT newm r ts -- | -- derive is the derivative implementation for trees. -- This implementation makes use of visual pushdown automata. derive :: Tree t => Grammar -> [t] -> Either String Pattern derive g ts = let start = [Smart.lookupMain g] in case foldLT (newVpa g) start ts of (Left l) -> Left $ show l (Right [r]) -> return r (Right rs) -> Left $ "Number of patterns is not one, but " ++ show rs