propL now produces correct complement

1 files changed, 55 insertions, 22 deletions

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