First prototype of working DFST-propL

1 files changed, 36 insertions, 17 deletions

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