Introduce FSTs & Generalize input/output

`toFST` is currently invalid

3 files changed, 272 insertions, 0 deletions

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/Control/DFST/Lens.lhs b/edit-lens/src/Control/DFST/Lens.lhs
new file mode 100644
index 0000000..0976314
--- /dev/null
+++ b/edit-lens/src/Control/DFST/Lens.lhs
@@ -0,0 +1,170 @@
+\begin{code}
+{-# LANGUAGE ScopedTypeVariables
+           , TemplateHaskell
+#-}
+
+module Control.DFST.Lens
+  ( StringEdit(..)
+  , StringEdits(..)
+  , insert, delete
+  , DFSTAction(..), DFSTComplement
+  , dfstLens
+  , module Control.DFST
+  , module Control.Lens.Edit
+  ) where
+
+import Control.DFST
+import Control.Lens.Edit
+import Control.Lens
+import Control.Lens.TH
+import Control.Edit
+
+import Numeric.Natural
+import Data.Sequence (Seq((:<|), (:|>)))
+import qualified Data.Sequence as Seq
+
+import Data.Compositions.Snoc (Compositions)
+import qualified Data.Compositions.Snoc as Comp
+
+import Data.Algorithm.Diff (Diff, getDiff)
+import qualified Data.Algorithm.Diff as Diff
+
+import Data.Monoid
+import Data.Function (on)
+import Data.Foldable (toList)
+
+
+data StringEdit char = Insert { _sePos :: Natural, _seInsertion :: char }
+                     | Delete { _sePos :: Natural }
+  deriving (Eq, Ord, Show, Read)
+
+makeLenses ''StringEdit
+
+data StringEdits char = StringEdits (Seq (StringEdit char))
+                      | SEFail
+  deriving (Eq, Ord, Show, Read)
+
+makePrisms ''StringEdits
+
+stringEdits :: Traversal' (StringEdits char) (StringEdit char)
+stringEdits = _StringEdits . traverse
+
+insert :: Natural -> char -> StringEdits char
+insert n c = StringEdits .  Seq.singleton $ Insert n c
+  
+delete :: Natural -> StringEdits char
+delete n = StringEdits .  Seq.singleton $ Delete n
+
+instance Monoid (StringEdits char) where
+  mempty = StringEdits Seq.empty
+  SEFail `mappend` _ = SEFail
+  _ `mappend` SEFail = SEFail
+  (StringEdits Seq.Empty) `mappend` x = x
+  x `mappend` (StringEdits Seq.Empty) = x
+  (StringEdits x@(bs :|> b)) `mappend` (StringEdits y@(a :<| as))
+    | (Insert n _) <- a
+    , (Delete n') <- b
+    , n == n'
+    = StringEdits bs `mappend` StringEdits as
+    | otherwise = StringEdits $ x `mappend` y
+
+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 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
+  apply str (StringEdits (es :|> Delete n)) = (flip apply) (StringEdits es) =<< go str n
+    where
+      go Seq.Empty _ = Nothing
+      go (x :<| xs) n
+        | n == 0 = Just xs
+        | otherwise = (x <|) <$> go xs (pred n)
+
+  init = Seq.empty
+  divInit = StringEdits . Seq.unfoldl go . (0,)
+    where
+      go (_, Seq.Empty) = Nothing
+      go (n, (c :<| cs)) = Just ((succ n, cs), Insert n c)
+
+\end{code}
+
+% TODO Make notation mathy
+
+Um zunächst eine asymmetrische edit-lens `StringEdits -> StringEdits` mit akzeptabler Komplexität für einen bestimmten `DFST s` (entlang der \emph{Richtung} des DFSTs) zu konstruieren möchten wir folgendes Verfahren anwenden:
+
+Gegeben eine Sequenz (`StringEdits`) von zu übersetzenden Änderungen genügt es die Übersetzung eines einzelnen `StringEdit`s in eine womöglich längere Sequenz von `StringEdits` anzugeben, alle `StringEdits` aus der Sequenz zu übersetzen (hierbei muss auf die korrekte Handhabung des Komplements geachtet werden) und jene Übersetzungen dann zu concatenieren.
+
+Wir definieren zunächst die \emph{Wirkung} eines DFST auf einen festen String als eine Abbildung `state -> (state, String)`, die den aktuellen Zustand vorm Parsen des Strings auf den Zustand danach und die (womöglich leere) Ausgabe schickt.
+Diese Wirkungen bilden einen Monoiden analog zu Endomorphismen, wobei die Resultat-Strings concateniert werden.
+
+Die Unterliegende Idee ist nun im Komplement der edit-lens eine Liste von Wirkungen (eine für jedes Zeichen der Eingabe des DFSTs) und einen Cache der monoidalen Summen aller kontinuirlichen Teillisten zu halten.
+Da wir wissen welche Stelle im input-String von einem gegebenen edit betroffen ist können wir, anhand der Wirkung des Teilstücks bis zu jener Stelle, den output-String in einen durch den edit unveränderten Prefix und einen womöglich betroffenen Suffix unterteilen.
+Die Wirkung ab der betroffenen Stelle im input-String können wir also Komposition der Wirkung der durch den edit betroffenen Stelle und derer aller Zeichen danach bestimmen.
+Nun gilt es nur noch die Differenz (als `StringEdits`) des vorherigen Suffixes im output-String und des aus der gerade berechneten Wirkung Bestimmten zu bestimmen.
+
+
+% Für die Rückrichtung bietet es sich an eine Art primitive Invertierung des DFSTs zu berechnen.
+% Gegeben den aktuellen DFST $A$ möchten wir einen anderen $A^{-1}$ finden, sodass gilt:
+
+% \begin{itemize}
+%   \item $A^{-1}$ akzeptiert einen String $s^{-1}$ (endet seinen Lauf in einem finalen Zustand) gdw. es einen String $s$ gibt, der unter $A$ die Ausgabe $s^{-1}$ produziert.
+%   \item Wenn $A^{-1}$ einen String $s^{-1}$ akzeptiert so produziert die resultierende Ausgabe $s$ unter $A$ die Ausgabe $s^{-1}$.
+% \end{itemize}
+
+% 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 input output = DFSTAction { runDFSTAction :: state -> (state, Seq output) }
+
+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 input output = Compositions (DFSTAction state input output)
+
+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 input output
+    ground = Comp.fromList []
+
+    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) 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 sOutput sOutput' & stringEdits . sePos . from enum +~ Seq.length pOutput
+    propR (c, StringEdits Seq.Empty) = (c, mempty)
+        
+
+    propL :: (DFSTComplement state input output, StringEdits output) -> (DFSTComplement state input output, StringEdits input)
+    propL = undefined
+
+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 `on` toList) a b
+  where
+    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)
+\end{code}
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}