Introduce FSTs & Generalize input/output

`toFST` is currently invalid

5 files changed, 151 insertions, 82 deletions

diff --git a/edit-lens/package.yaml b/edit-lens/package.yaml
index 970d50a..2374898 100644
--- a/edit-lens/package.yaml
+++ b/edit-lens/package.yaml
@@ -20,6 +20,7 @@ library:
     - TypeApplications
     - GADTs
     - RecordWildCards
+    - NamedFieldPuns
     - PatternGuards
     - TupleSections
     - RankNTypes
@@ -31,9 +32,12 @@ library:
     - containers
     - composition-tree
     - Diff
+    - mtl
   exposed-modules:
     - Control.Edit
-    - Data.String.DFST
     - Control.Lens.Edit
+    - Control.DFST
+    - Control.FST
+    - Control.DFST.Lens
     
   
diff --git a/edit-lens/src/Control/DFST.lhs b/edit-lens/src/Control/DFST.lhs
new file mode 100644
index 0000000..aec7bbb
--- /dev/null
+++ b/edit-lens/src/Control/DFST.lhs
@@ -0,0 +1,78 @@
+\begin{code}
+{-# LANGUAGE ScopedTypeVariables
+#-}
+
+{-|
+Description: Deterministic finite state transducers
+-}
+module Control.DFST
+  ( DFST(..)
+  , runDFST, runDFST'
+  , toFST
+  ) where
+
+import Data.Map.Strict (Map, (!?))
+import qualified Data.Map.Strict as Map
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Data.Sequence (Seq(..))
+import qualified Data.Sequence as Seq
+
+import Data.Monoid
+
+import Numeric.Natural
+
+import Control.Monad
+import Control.Monad.State
+
+import Control.FST (FST(FST))
+import qualified Control.FST as FST
+
+
+data DFST state input output = DFST
+  { stInitial :: state
+  , stTransition :: Map (state, input) (state, Seq output)
+    -- ^ All @(s, c)@-combinations not mapped are assumed to map to @(s, Nothing)@
+  , stAccept :: Set state
+  }
+
+
+toFST :: forall state input output. (Ord state, Ord input, Ord output) => DFST state input output -> FST (state, Natural) input output
+-- ^ Split apart non-singleton outputs into a series of epsilon-transitions
+--
+-- This function is currently invalid since multiple out-edges in the `DFST` visit the same intermediate states (we should label intermediate states not only with an ordinal but also with the input Symbol from the `DFST`)
+toFST DFST{..} = flip execState initialFST $ forM_ (Map.toList stTransition) handleTransition
+  where
+    initialFST = FST
+      { stInitial = (stInitial, 0)
+      , stTransition = Map.empty
+      , stAccept = Set.map (,0) stAccept
+      }
+    addTransition :: forall state input output. (Ord state, Ord input, Ord output) => (state, Maybe input) -> (state, Maybe output) -> State (FST state input output) ()
+    addTransition k v = modify $ \f@FST{ stTransition } -> f { FST.stTransition = Map.insertWith Set.union k (Set.singleton v) stTransition }
+    handleTransition :: ((state, input), (state, Seq output)) -> State (FST (state, Natural) input output) ()
+    handleTransition ((st, inS), (st', outs)) = handleTransition' (st, 0) (Just inS) outs (st', 0)
+    handleTransition' :: (state, Natural) -> Maybe input -> Seq output -> (state, Natural) -> State (FST (state, Natural) input output) ()
+    handleTransition' from inS Empty to = addTransition (from, inS) (to, Nothing)
+    handleTransition' from inS (outS :<| Empty) to = addTransition (from, inS) (to, Just outS)
+    handleTransition' from@(st, i) inS (outS :<| oo) to = addTransition (from, inS) ((st, succ i), Just outS) >> handleTransition' (st, succ i) Nothing oo to
+  
+runDFST :: forall state input output. (Ord state, Ord input) => DFST state input output -> Seq input -> Maybe (Seq output)
+runDFST dfst@DFST{..} str = let (finalState, str') = runDFST' dfst stInitial str Seq.empty
+                            in str' <$ guard (finalState `Set.member` stAccept)
+
+runDFST' :: forall state input output. (Ord state, Ord input)
+         => DFST state input output
+         -> state               -- ^ Current state
+         -> Seq input           -- ^ Remaining input
+         -> Seq output          -- ^ Accumulator containing previous output
+         -> (state, Seq output) -- ^ Next state, altered output
+runDFST' _             st  Empty     acc = (st, acc)
+runDFST' dfst@DFST{..} st (c :<| cs) acc
+  | Just (st', mc') <- stTransition !? (st, c)
+  = runDFST' dfst st' cs $ acc <> mc'
+  | otherwise
+  = runDFST' dfst st cs acc
+\end{code}
diff --git a/edit-lens/src/Data/String/DFST/Lens.lhs b/edit-lens/src/Control/DFST/Lens.lhs
index bf06f53..0976314 100644
--- a/edit-lens/src/Data/String/DFST/Lens.lhs
+++ b/edit-lens/src/Control/DFST/Lens.lhs
@@ -3,17 +3,17 @@
            , TemplateHaskell
 #-}
 
-module Data.String.DFST.Lens
+module Control.DFST.Lens
   ( StringEdit(..)
   , StringEdits(..)
   , insert, delete
   , DFSTAction(..), DFSTComplement
   , dfstLens
-  , module Data.String.DFST
+  , module Control.DFST
   , module Control.Lens.Edit
   ) where
 
-import Data.String.DFST
+import Control.DFST
 import Control.Lens.Edit
 import Control.Lens
 import Control.Lens.TH
@@ -31,30 +31,31 @@ import qualified Data.Algorithm.Diff as Diff
 
 import Data.Monoid
 import Data.Function (on)
+import Data.Foldable (toList)
 
 
-data StringEdit = Insert { _sePos :: Natural, _seInsertion :: Char }
-                | Delete { _sePos :: Natural }
+data StringEdit char = Insert { _sePos :: Natural, _seInsertion :: char }
+                     | Delete { _sePos :: Natural }
   deriving (Eq, Ord, Show, Read)
 
 makeLenses ''StringEdit
 
-data StringEdits = StringEdits (Seq StringEdit)
-                 | SEFail
+data StringEdits char = StringEdits (Seq (StringEdit char))
+                      | SEFail
   deriving (Eq, Ord, Show, Read)
 
 makePrisms ''StringEdits
 
-stringEdits :: Traversal' StringEdits StringEdit
+stringEdits :: Traversal' (StringEdits char) (StringEdit char)
 stringEdits = _StringEdits . traverse
 
-insert :: Natural -> Char -> StringEdits
+insert :: Natural -> char -> StringEdits char
 insert n c = StringEdits .  Seq.singleton $ Insert n c
   
-delete :: Natural -> StringEdits
+delete :: Natural -> StringEdits char
 delete n = StringEdits .  Seq.singleton $ Delete n
 
-instance Monoid StringEdits where
+instance Monoid (StringEdits char) where
   mempty = StringEdits Seq.empty
   SEFail `mappend` _ = SEFail
   _ `mappend` SEFail = SEFail
@@ -67,30 +68,30 @@ instance Monoid StringEdits where
     = StringEdits bs `mappend` StringEdits as
     | otherwise = StringEdits $ x `mappend` y
 
-instance Module StringEdits where
-  type Domain StringEdits = String
+instance Module (StringEdits char) where
+  type Domain (StringEdits char) = Seq char
   apply str SEFail = Nothing
   apply str (StringEdits Seq.Empty) = Just str
   apply str (StringEdits (es :|> Insert n c)) = (flip apply) (StringEdits es) =<< go str n c
     where
-      go [] n c
-        | n == 0 = Just [c]
+      go Seq.Empty n c
+        | n == 0 = Just $ Seq.singleton c
         | otherwise = Nothing
-      go str@(x:xs) n c
-        | n == 0 = Just $ c : str
-        | otherwise = (x:) <$> go xs (pred n) c
+      go str@(x :<| xs) n c
+        | n == 0 = Just $ c <| str
+        | otherwise = (x <|) <$> go xs (pred n) c
   apply str (StringEdits (es :|> Delete n)) = (flip apply) (StringEdits es) =<< go str n
     where
-      go [] _ = Nothing
-      go (x:xs) n
+      go Seq.Empty _ = Nothing
+      go (x :<| xs) n
         | n == 0 = Just xs
-        | otherwise = (x:) <$> go xs (pred n)
+        | otherwise = (x <|) <$> go xs (pred n)
 
-  init = ""
+  init = Seq.empty
   divInit = StringEdits . Seq.unfoldl go . (0,)
     where
-      go (_, []) = Nothing
-      go (n, (c:cs)) = Just ((succ n, cs), Insert n c)
+      go (_, Seq.Empty) = Nothing
+      go (n, (c :<| cs)) = Just ((succ n, cs), Insert n c)
 
 \end{code}
 
@@ -119,46 +120,50 @@ Nun gilt es nur noch die Differenz (als `StringEdits`) des vorherigen Suffixes i
 
 % Kann nicht funktionieren, denn $A^{-1}$ ist notwendigerweise nondeterministisch. Wird $A^{-1}$ dann zu einem DFST forciert (durch arbiträre Wahl einer Transition pro Zustand) gehen Informationen verloren—$A^{-1}$ produziert nicht den minimale edit auf dem input string (in der Tat beliebig schlecht) für einen gegeben edit auf dem output string.
   
+% Stelle im bisherigen Lauf isolieren, an der edit im output-string passieren soll, breitensuche auf pfaden, die sich von dieser stelle aus unterscheiden?
+% Gegeben einen Pfad und eine markierte Transition, finde Liste aller Pfade aufsteigend sortiert nach Unterschied zu gegebenem Pfad, mit Unterschieden "nahe" der markierten Transition zuerst — zudem jeweils edit auf dem Eingabestring
+% Einfacher ist Breitensuche ab `stInitial` und zunächst diff auf eingabe-strings.
+  
 \begin{code}
 
-data DFSTAction state = DFSTAction { runDFSTAction :: state -> (state, String -> String) }
+data DFSTAction state input output = DFSTAction { runDFSTAction :: state -> (state, Seq output) }
 
-instance Monoid (DFSTAction state) where
-  mempty = DFSTAction $ \x -> (x, id)
-  (DFSTAction f) `mappend` (DFSTAction g) = DFSTAction $ \s -> let ((f -> (s', out')), out) = g s in (s', out' . out)
+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')
 
-type DFSTComplement state = Compositions (DFSTAction state)
+type DFSTComplement state input output = Compositions (DFSTAction state input output)
 
-dfstLens :: forall state. Ord state => DFST state -> EditLens (DFSTComplement state) StringEdits StringEdits
+dfstLens :: forall state input output. (Ord state, Ord input, Ord output) => DFST state input output -> EditLens (DFSTComplement state input output) (StringEdits input) (StringEdits output)
 dfstLens dfst@DFST{..} = EditLens ground propR propL
   where
-    ground :: DFSTComplement state
+    ground :: DFSTComplement state input output
     ground = Comp.fromList []
 
-    propR :: (DFSTComplement state, StringEdits) -> (DFSTComplement state, StringEdits)
+    propR :: (DFSTComplement state input output, StringEdits input) -> (DFSTComplement state input output, StringEdits output)
     propR (c, SEFail) = (c, SEFail)
     propR (c, StringEdits (es :|> e)) = (c', es' <> es'')
       where
         (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) id)
+          | Insert _ nChar <- e = cSuffix <> Comp.singleton (DFSTAction $ \x -> runDFST' dfst x (pure nChar) Seq.empty)
         (pState, pOutput)  = runDFSTAction (Comp.composed cPrefix) stInitial
         (_, sOutput ) = runDFSTAction (Comp.composed cSuffix ) pState
         (_, sOutput') = runDFSTAction (Comp.composed cSuffix') pState
         (c', es') = propR (cSuffix' <> cPrefix, StringEdits es)
-        es'' = (strDiff `on` ($ "")) sOutput sOutput' & stringEdits . sePos . from enum +~ (length $ pOutput [])
-    propR (c, mempty) = (c, mempty)
+        es'' = strDiff sOutput sOutput' & stringEdits . sePos . from enum +~ Seq.length pOutput
+    propR (c, StringEdits Seq.Empty) = (c, mempty)
         
 
-    propL :: (DFSTComplement state, StringEdits) -> (DFSTComplement state, StringEdits)
+    propL :: (DFSTComplement state input output, StringEdits output) -> (DFSTComplement state input output, StringEdits input)
     propL = undefined
 
-strDiff :: String -> String -> StringEdits
+strDiff :: forall sym. Eq sym => Seq sym -> Seq sym -> StringEdits sym
 -- ^ @strDiff a b@ calculates a set of edits, which, when applied to @a@, produce @b@
-strDiff a b = snd . foldr toEdit (0, mempty) $ getDiff a b
+strDiff a b = snd . foldr toEdit (0, mempty) $ (getDiff `on` toList) a b
   where
-    toEdit :: Diff Char -> (Natural, StringEdits) -> (Natural, StringEdits)
+    toEdit :: Diff sym -> (Natural, StringEdits sym) -> (Natural, StringEdits sym)
     toEdit (Diff.Both _ _) (n, es) = (succ n, es)
     toEdit (Diff.First _ ) (n, es) = (succ n, delete n <> es)
     toEdit (Diff.Second c) (n, es) = (succ (succ n), insert n c <> es)
diff --git a/edit-lens/src/Control/FST.lhs b/edit-lens/src/Control/FST.lhs
new file mode 100644
index 0000000..d3c8ca9
--- /dev/null
+++ b/edit-lens/src/Control/FST.lhs
@@ -0,0 +1,24 @@
+\begin{code}
+
+{-|
+Description: Finite state transducers with epsilon-transitions
+-}
+module Control.FST
+  ( FST(..)
+  ) where
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+
+import Data.Set (Set)
+
+import Data.Sequence (Seq)
+
+import Control.Lens.TH
+
+data FST state input output = FST
+  { stInitial :: state
+  , stTransition :: Map (state, Maybe input) (Set (state, Maybe output))
+  , stAccept :: Set state
+  }
+\end{code}
diff --git a/edit-lens/src/Data/String/DFST.hs b/edit-lens/src/Data/String/DFST.hs
deleted file mode 100644
index 54a1336..0000000
--- a/edit-lens/src/Data/String/DFST.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables
-#-}
-
-{-|
-Description: Deterministic finite state transducers
--}
-module Data.String.DFST
-  ( DFST(..)
-  , runDFST, runDFST'
-  ) where
-
-import Data.Map.Strict (Map, (!?))
-import qualified Data.Map.Strict as Map
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-import Control.Monad
-
-data DFST state = DFST
-  { stInitial :: state
-  , stTransition :: Map (state, Char) (state, String)
-    -- ^ All @(s, c)@-combinations not mapped are assumed to map to @(s, Nothing)@
-  , stAccept :: Set state
-  }
-  
-runDFST :: forall state. Ord state => DFST state -> String -> Maybe String
-runDFST dfst@DFST{..} str = let (finalState, str') = runDFST' dfst stInitial str id
-                            in str' "" <$ guard (finalState `Set.member` stAccept)
-
-runDFST' :: forall state. Ord state
-         => DFST state
-         -> state -- ^ Current state
-         -> String -- ^ Remaining input
-         -> (String -> String) -- ^ Output as difference list
-         -> (state, (String -> String)) -- ^ Next state, altered output
-runDFST' _ st [] acc = (st, acc)
-runDFST' dfst@DFST{..} st (c:cs) acc
-  | Just (st', mc') <- stTransition !? (st, c)
-  = runDFST' dfst st' cs $ acc . (mc' ++)
-  | otherwise
-  = runDFST' dfst st cs acc