From b0b18979d5ccd109d5a56937396acdeb85c857aa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 2 Jul 2018 11:16:26 +0200 Subject: propL now produces correct complement --- edit-lens/src/Control/DFST/Lens.lhs | 77 ++++++++++++++++++++++++++----------- 1 file changed, 55 insertions(+), 22 deletions(-) (limited to 'edit-lens/src/Control') diff --git a/edit-lens/src/Control/DFST/Lens.lhs b/edit-lens/src/Control/DFST/Lens.lhs index 3959b39..95be34e 100644 --- a/edit-lens/src/Control/DFST/Lens.lhs +++ b/edit-lens/src/Control/DFST/Lens.lhs @@ -7,7 +7,7 @@ module Control.DFST.Lens ( StringEdit(..) , StringEdits(..) - , insert, delete + , insert, delete, replace , DFSTAction(..), DFSTComplement , dfstLens , module Control.DFST @@ -32,8 +32,8 @@ import Data.Sequence (Seq((:<|), (:|>))) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Compositions.Snoc (Compositions) import qualified Data.Compositions.Snoc as Comp @@ -43,7 +43,7 @@ import qualified Data.Algorithm.Diff as Diff import Data.Monoid import Data.Bool (bool) -import Data.Maybe (fromMaybe, maybeToList, listToMaybe, catMaybes) +import Data.Maybe (fromMaybe, maybeToList, listToMaybe, catMaybes, isNothing, isJust) import Data.Function (on) import Data.Foldable (toList) import Data.List (partition) @@ -107,6 +107,9 @@ insert n c = StringEdits . Seq.singleton $ Insert n c delete :: Natural -> StringEdits char delete n = StringEdits . Seq.singleton $ Delete n +replace :: Natural -> char -> StringEdits char +replace n c = insert n c <> delete n + instance Monoid (StringEdits char) where mempty = StringEdits Seq.empty SEFail `mappend` _ = SEFail @@ -198,6 +201,9 @@ runDFSTAction' = runDFSTAction . Comp.composed dfstaConsumes' :: DFSTComplement state input output -> Seq input dfstaConsumes' = dfstaConsumes . Comp.composed +dfstaProduces :: DFST state input output -> DFSTComplement state input output -> Seq output +dfstaProduces DFST{..} = snd . flip runDFSTAction' stInitial + type Debug state input output = (Show state, Show input, Show output) type LState state input output = (Natural, (state, Maybe (input, Natural))) @@ -245,19 +251,22 @@ dfstLens dfst@DFST{..} = EditLens ground propR propL max = fromIntegral $ Seq.length newOut 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 focus = continueRun (Seq.empty, mempty) c 0 + -> [ ( Seq (LState state input output, Maybe output) -- ^ Computed run + , StringEdits input + , DFSTComplement state input output + ) + ] + runCandidates focus = continueRun (Seq.empty, mempty) (c, mempty) 0 where - -- TODO: generate new complement continueRun :: (Seq (LState state input output, Maybe output), StringEdits input) - -> DFSTComplement state input output + -> (DFSTComplement state input output, DFSTComplement state input output) -- ^ Zipper into complement -> Natural -- ^ Input position - -> [(Seq (LState state input output, Maybe output), StringEdits input)] - continueRun (run, inEdits) c' inP = do + -> [(Seq (LState state input output, Maybe output), StringEdits input, DFSTComplement state input output)] + continueRun (run, inEdits) (c', remC) inP = do let pos :: Natural pos = fromIntegral $ Comp.length c - Comp.length c' - (c'', step) = Comp.splitAt (pred $ Comp.length c') c' -- TODO: unsafe + (c'', step) = Comp.splitAt (pred $ Comp.length c') c' -- TODO: unsafe? current :: LState state input output current | Seq.Empty <- run = (0, (stInitial, Nothing)) @@ -276,26 +285,50 @@ dfstLens dfst@DFST{..} = EditLens ground propR propL in Map.foldrWithKey go [] $ FST.stTransition outFST isPreferred :: (LState state input output, Maybe input, Maybe output) -> Bool isPreferred ((_, (st, Nothing)), inS, _) = st == next' && (fromMaybe True $ (==) <$> oldIn <*> inS) - isPreferred (st, _, _) = any isPreferred $ outgoing st + isPreferred (st, _, _) = any isPreferred $ outgoing st -- By construction of `outFST`, `outgoing st` is a singleton (preferred, alternate) = partition isPreferred $ outgoing current - assocEdit :: (LState state input output, Maybe input, Maybe output) -> [(DFSTComplement state input output, StringEdits input, Natural)] + assocEdit :: (LState state input output, Maybe input, Maybe output) -- ^ Transition + -> [ ( (DFSTComplement state input output, DFSTComplement state input output) -- ^ new `(c', remC)`, i.e. complement-zipper `(c', remC)` but with edit applied + , 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)] + | oldIn == Just inS = [((c'', step <> remC), mempty, succ inP)] + | isJust oldIn = [((c'', altStep inS <> remC), replace inP inS, succ inP), ((c', altStep inS <> remC), insert inP inS, succ inP)] + | otherwise = [((c', altStep inS <> remC), insert inP inS, succ inP)] + assocEdit (_, Nothing, _) = [((c', remC), mempty, inP)] -- TODO: is this correct? + altStep :: input -> DFSTComplement state input output + altStep inS = Comp.singleton DFSTAction{..} + where + dfstaConsumes = Seq.singleton inS + runDFSTAction x = runDFST' dfst x (pure inS) Seq.empty options | 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' - + ((c3, remC'), inEdits', inP') <- assocEdit choice + -- let + -- -- | Replace prefix of old complement to reflect current candidate + -- -- TODO: smarter? + -- (_, ((c3 <>) -> newComplement')) = Comp.splitAt (Comp.length c') c -- TODO: unsafe? + -- acc = (run :> (next, outS), inEdits' <> inEdits, newComplement') + -- dropSuffix = mconcat (replicate (Seq.length $ dfstaConsumes' c3) $ delete inP') + -- fin + -- | (trans, inEs, newComplement) <- acc = (trans, dropSuffix <> inEs, newComplement) + let + acc = (run :> (next, outS), inEdits' <> inEdits) + dropSuffix = mconcat (replicate (Seq.length $ dfstaConsumes' c3) $ delete inP') + fin + | (trans, inEs) <- acc = (trans, dropSuffix <> inEs, remC') + bool id (fin :) (next `Set.member` FST.stAccept outFST) $ continueRun acc (c3, remC') inP' -- Properties of the edits computed are determined mostly by the order candidates are generated below - chosenRun <- (\xs -> foldr (\x f -> x `seq` f) listToMaybe xs $ xs) $ traceShowId fragmentIntervals >>= (\x -> traceShowId <$> runCandidates x) + -- (_, inEs, c') <- (\xs -> foldr (\x f -> x `seq` f) listToMaybe xs $ xs) $ traceShowId fragmentIntervals >>= (\x -> (\y@(y1, y2, _) -> traceShow (y1, y2) y) <$> runCandidates x) + + (_, inEs, c') <- listToMaybe $ runCandidates =<< fragmentIntervals - return $ traceShow chosenRun undefined + return (c', inEs) where (_, prevOut) = runDFSTAction' c stInitial -- cgit v1.2.3