From 6d1f39826963890e9612b39f92843f134b6973f3 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 5 Feb 2018 17:02:55 +0100
Subject: Framework for DFST edit lens

---
 edit-lens/src/Control/Edit.lhs          |  8 +++-
 edit-lens/src/Data/String/DFST.hs       | 25 +++++-----
 edit-lens/src/Data/String/DFST/Lens.lhs | 82 +++++++++++++++++++++++++++++++++
 3 files changed, 102 insertions(+), 13 deletions(-)
 create mode 100644 edit-lens/src/Data/String/DFST/Lens.lhs

(limited to 'edit-lens/src')

diff --git a/edit-lens/src/Control/Edit.lhs b/edit-lens/src/Control/Edit.lhs
index 7be8db4..19fe336 100644
--- a/edit-lens/src/Control/Edit.lhs
+++ b/edit-lens/src/Control/Edit.lhs
@@ -1,7 +1,7 @@
 \begin{comment}
 \begin{code}
 module Control.Edit
-  ( Module(..) 
+  ( Module(..), apply'
   ) where
 \end{code}
 \end{comment}
@@ -24,6 +24,8 @@ In Haskell charakterisieren wir Moduln über ihren Monoid, d.h. die Wahl des Mon
 Eine Repräsentierung als Typklasse bietet sich an:
 
 \begin{code}
+infix 5 `apply`
+
 class Monoid m => Module m where
   type Domain m :: *
   apply :: Domain m -> m -> Maybe (Domain m)
@@ -37,6 +39,10 @@ class Monoid m => Module m where
   -- ^ Calculate a representation of an element of 'Domain m' in 'Del m'
   --
   -- prop> init `apply` divInit m = m
+
+infixl 5 `apply'`
+apply' :: Module m => Maybe (Domain m) -> m -> Maybe (Domain m)
+apply' md e = flip apply e =<< md
 \end{code}
 \end{defn}
 
diff --git a/edit-lens/src/Data/String/DFST.hs b/edit-lens/src/Data/String/DFST.hs
index 8a22dd3..75ca1cd 100644
--- a/edit-lens/src/Data/String/DFST.hs
+++ b/edit-lens/src/Data/String/DFST.hs
@@ -8,7 +8,7 @@ Description: Deterministic finite state transducers
 -}
 module Data.String.DFST
   ( DFST(..)
-  , runDFST
+  , runDFST, runDFST'
   ) where
 
 import Data.Map.Strict (Map, (!?))
@@ -17,6 +17,8 @@ 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, Maybe Char)
@@ -25,14 +27,13 @@ data DFST state = DFST
   }
   
 runDFST :: forall state. Ord state => DFST state -> String -> Maybe String
-runDFST DFST{..} str = ($ []) <$> go stInitial str id
-  where
-    go :: state -> String -> (String -> String) -> Maybe (String -> String)
-    go st [] acc
-      | st `Set.member` stAccept = Just acc
-      | otherwise = Nothing
-    go st (c:cs) acc
-      | Just (st', mc') <- stTransition !? (st, c)
-      = go st' cs $ acc . maybe id (:) mc'
-      | otherwise
-      = go st cs acc
+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 -> String -> (String -> String) -> (state, (String -> String))
+runDFST' _ st [] acc = (st, acc)
+runDFST' dfst@DFST{..} st (c:cs) acc
+  | Just (st', mc') <- stTransition !? (st, c)
+  = runDFST' dfst st' cs $ acc . maybe id (:) mc'
+  | otherwise
+  = runDFST' dfst st cs acc
diff --git a/edit-lens/src/Data/String/DFST/Lens.lhs b/edit-lens/src/Data/String/DFST/Lens.lhs
new file mode 100644
index 0000000..52c80d0
--- /dev/null
+++ b/edit-lens/src/Data/String/DFST/Lens.lhs
@@ -0,0 +1,82 @@
+\begin{code}
+{-# LANGUAGE TupleSections
+  #-}
+
+module Data.String.DFST.Lens
+  (
+  ) where
+
+import Data.String.DFST
+import Control.Lens.Edit
+import Control.Edit
+
+import Numeric.Natural
+import Data.Sequence (Seq((:<|), (:|>)))
+import qualified Data.Sequence as Seq
+
+data StringEdit = Insert Natural Char
+                | Delete Natural
+  deriving (Eq, Ord, Show, Read)
+
+data StringEdits = StringEdits (Seq StringEdit)
+                 | SEFail
+  deriving (Eq, Ord, Show, Read)
+
+insert :: Natural -> Char -> StringEdits
+insert n c = StringEdits .  Seq.singleton $ Insert n c
+  
+delete :: Natural -> StringEdits
+delete n = StringEdits .  Seq.singleton $ Delete n
+
+instance Monoid StringEdits 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 where
+  type Domain StringEdits = String
+  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]
+        | 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 [] _ = Nothing
+      go (x:xs) n
+        | n == 0 = Just xs
+        | otherwise = (x:) <$> go xs (pred n)
+
+  init = ""
+  divInit = StringEdits . Seq.unfoldl go . (0,)
+    where
+      go (_, []) = Nothing
+      go (n, (c:cs)) = Just ((succ n, cs), Insert n c)
+
+data DFSTAction state = DFSTBranch (Map state (state, String)) (DFSTAction state) (DFSTAction state)
+                      | DFSTLeaf
+
+dfstLens :: forall state. Ord state => DFST state -> EditLens (DFSTAction state) StringEdits StringEdits
+dfstLens DFST{..} = EditLens ground propR propL
+  where
+    ground :: DFSTAction state
+    ground = DFSTLeaf
+
+    propR :: (DFSTAction state, StringEdits) -> (DFSTAction state, StringEdits)
+    propR = undefined
+    propL :: (DFSTAction state, StringEdits) -> (DFSTAction state, StringEdits)
+    propL = undefined
+\end{code}
-- 
cgit v1.2.3