From 7291311bf2adb79f261890a05e67604ea395b62f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 18 Jun 2018 14:16:53 +0200 Subject: First prototype of working DFST-propL --- edit-lens/src/Control/DFST/Lens.lhs | 53 +++++++++++++++++++++++++------------ 1 file changed, 36 insertions(+), 17 deletions(-) (limited to 'edit-lens') diff --git a/edit-lens/src/Control/DFST/Lens.lhs b/edit-lens/src/Control/DFST/Lens.lhs index 35a7d38..3959b39 100644 --- a/edit-lens/src/Control/DFST/Lens.lhs +++ b/edit-lens/src/Control/DFST/Lens.lhs @@ -43,7 +43,7 @@ import qualified Data.Algorithm.Diff as Diff import Data.Monoid import Data.Bool (bool) -import Data.Maybe (fromMaybe, maybeToList, listToMaybe) +import Data.Maybe (fromMaybe, maybeToList, listToMaybe, catMaybes) import Data.Function (on) import Data.Foldable (toList) import Data.List (partition) @@ -178,17 +178,26 @@ Nun gilt es nur noch die Differenz (als `StringEdits`) des vorherigen Suffixes i \begin{code} -data DFSTAction state input output = DFSTAction { runDFSTAction :: state -> (state, Seq output) } +data DFSTAction state input output = DFSTAction + { runDFSTAction :: state -> (state, Seq output) + , dfstaConsumes :: Seq input + } instance Monoid (DFSTAction state input output) where - mempty = DFSTAction $ \x -> (x, Seq.empty) - DFSTAction f `mappend` DFSTAction g = DFSTAction $ \s -> let ((f -> (s', out')), out) = g s in (s', out <> out') + mempty = DFSTAction (\x -> (x, Seq.empty)) Seq.empty + DFSTAction f cf `mappend` DFSTAction g cg = DFSTAction + { runDFSTAction = \s -> let ((f -> (s', out')), out) = g s in (s', out <> out') + , dfstaConsumes = cg <> cf + } type DFSTComplement state input output = Compositions (DFSTAction state input output) runDFSTAction' :: DFSTComplement state input output -> state -> (state, Seq output) runDFSTAction' = runDFSTAction . Comp.composed +dfstaConsumes' :: DFSTComplement state input output -> Seq input +dfstaConsumes' = dfstaConsumes . Comp.composed + type Debug state input output = (Show state, Show input, Show output) type LState state input output = (Natural, (state, Maybe (input, Natural))) @@ -209,7 +218,7 @@ dfstLens dfst@DFST{..} = EditLens ground propR propL (cSuffix, cPrefix) = Comp.splitAt (Comp.length c - (e ^. sePos . from enum)) c cSuffix' | Delete _ <- e = Comp.take (pred $ Comp.length cSuffix) cSuffix -- TODO unsafe - | Insert _ nChar <- e = cSuffix <> Comp.singleton (DFSTAction $ \x -> runDFST' dfst x (pure nChar) Seq.empty) + | Insert _ nChar <- e = cSuffix <> Comp.singleton (DFSTAction (\x -> runDFST' dfst x (pure nChar) Seq.empty) (Seq.singleton nChar)) (pState, pOutput) = runDFSTAction' cPrefix stInitial (_, sOutput ) = runDFSTAction' cSuffix pState (_, sOutput') = runDFSTAction' cSuffix' pState @@ -237,13 +246,18 @@ dfstLens dfst@DFST{..} = EditLens ground propR propL all = 0 Int.... max runCandidates :: Interval Natural -- ^ Departure from complement-run only permitted within interval (to guarantee locality) -> [(Seq ((Natural, (state, Maybe (input, Natural))), Maybe output), StringEdits input)] - runCandidates ((,) <$> Int.inf <*> Int.sup -> (fInf, fSup)) = continueRun (Seq.empty, mempty) c + runCandidates focus = continueRun (Seq.empty, mempty) c 0 where + -- TODO: generate new complement continueRun :: (Seq (LState state input output, Maybe output), StringEdits input) -> DFSTComplement state input output + -> Natural -- ^ Input position -> [(Seq (LState state input output, Maybe output), StringEdits input)] - continueRun (run, inEdits) c' = do + continueRun (run, inEdits) c' inP = do let + pos :: Natural + pos = fromIntegral $ Comp.length c - Comp.length c' + (c'', step) = Comp.splitAt (pred $ Comp.length c') c' -- TODO: unsafe current :: LState state input output current | Seq.Empty <- run = (0, (stInitial, Nothing)) @@ -251,30 +265,35 @@ dfstLens dfst@DFST{..} = EditLens ground propR propL current' :: state current' = let (_, (st, _)) = current in st - (c'', step) = Comp.splitAt (pred $ Comp.length c') c' -- TODO: unsafe - pos :: Natural - pos = fromIntegral $ Comp.length c - Comp.length c' next' :: state next' = fst . runDFSTAction' step $ current' + oldIn :: Maybe input + oldIn = Seq.lookup 0 $ dfstaConsumes' step outgoing :: LState state input output -> [(LState state input output, Maybe input, Maybe output)] outgoing current = let go (st, minS) os acc | st == current = ($ acc) $ Set.fold (\(st', moutS) -> (. ((st', minS, moutS) :))) id os | otherwise = acc in Map.foldrWithKey go [] $ FST.stTransition outFST isPreferred :: (LState state input output, Maybe input, Maybe output) -> Bool - isPreferred ((_, (st, Nothing)), _, _) = st == next' + isPreferred ((_, (st, Nothing)), inS, _) = st == next' && (fromMaybe True $ (==) <$> oldIn <*> inS) isPreferred (st, _, _) = any isPreferred $ outgoing st (preferred, alternate) = partition isPreferred $ outgoing current + assocEdit :: (LState state input output, Maybe input, Maybe output) -> [(DFSTComplement state input output, StringEdits input, Natural)] + assocEdit (_, Just inS, _) + | oldIn == Just inS = [(c'', mempty, succ inP)] + | otherwise = [(c', insert inP inS, succ inP), (c'', insert inP inS <> delete inP, succ inP)] + assocEdit (_, Nothing, _) = [(c', mempty, inP)] options - | pos >= fInf = preferred ++ alternate - | otherwise = preferred - (next, inS, outS) <- options - let acc = (run :> (next, outS), undefined {- TODO -}) - bool id (acc :) (next `Set.member` FST.stAccept outFST) $ continueRun acc c'' + | pos `Int.member` focus = preferred ++ alternate + | otherwise = preferred + choice@(next, inS, outS) <- options + (c', inEdits', inP') <- assocEdit choice + let acc = (run :> (next, outS), inEdits' <> inEdits) + bool id (acc :) (next `Set.member` FST.stAccept outFST) $ continueRun acc c' inP' -- Properties of the edits computed are determined mostly by the order candidates are generated below - chosenRun <- listToMaybe . (\x -> trace (show $ map fst x) x) $ fragmentIntervals >>= runCandidates + chosenRun <- (\xs -> foldr (\x f -> x `seq` f) listToMaybe xs $ xs) $ traceShowId fragmentIntervals >>= (\x -> traceShowId <$> runCandidates x) return $ traceShow chosenRun undefined where -- cgit v1.2.3