summaryrefslogtreecommitdiff
path: root/edit-lens/src
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2019-05-30 12:18:08 +0200
committerGregor Kleen <gkleen@yggdrasil.li>2019-05-30 12:18:08 +0200
commitf4c419b9ddec15bad267a4463f0720d6e28042d2 (patch)
tree54a0259116476150247619c4410eae33f8669314 /edit-lens/src
parent8afbe1f7df24034dd16fdf2e89b0665b2318ae2a (diff)
downloadincremental-dfsts-f4c419b9ddec15bad267a4463f0720d6e28042d2.tar
incremental-dfsts-f4c419b9ddec15bad267a4463f0720d6e28042d2.tar.gz
incremental-dfsts-f4c419b9ddec15bad267a4463f0720d6e28042d2.tar.bz2
incremental-dfsts-f4c419b9ddec15bad267a4463f0720d6e28042d2.tar.xz
incremental-dfsts-f4c419b9ddec15bad267a4463f0720d6e28042d2.zip
Further work
Diffstat (limited to 'edit-lens/src')
l---------edit-lens/src/Control/DFST.lhs.tex1
-rw-r--r--edit-lens/src/Control/DFST/Lens.lhs405
l---------edit-lens/src/Control/DFST/Lens.lhs.tex1
-rw-r--r--edit-lens/src/Control/Edit.lhs2
l---------edit-lens/src/Control/Edit.lhs.tex1
-rw-r--r--edit-lens/src/Control/Edit/String.lhs120
l---------edit-lens/src/Control/Edit/String.lhs.tex1
-rw-r--r--edit-lens/src/Control/Edit/String/Affected.lhs73
l---------edit-lens/src/Control/Edit/String/Affected.lhs.tex1
-rw-r--r--edit-lens/src/Control/FST.lhs22
l---------edit-lens/src/Control/FST.lhs.tex1
-rw-r--r--edit-lens/src/Control/Lens/Edit.lhs6
l---------edit-lens/src/Control/Lens/Edit.lhs.tex1
-rw-r--r--edit-lens/src/Control/Lens/Edit/ActionTree.lhs204
l---------edit-lens/src/Control/Lens/Edit/ActionTree.lhs.tex1
15 files changed, 561 insertions, 279 deletions
diff --git a/edit-lens/src/Control/DFST.lhs.tex b/edit-lens/src/Control/DFST.lhs.tex
new file mode 120000
index 0000000..eb8c83e
--- /dev/null
+++ b/edit-lens/src/Control/DFST.lhs.tex
@@ -0,0 +1 @@
DFST.lhs \ No newline at end of file
diff --git a/edit-lens/src/Control/DFST/Lens.lhs b/edit-lens/src/Control/DFST/Lens.lhs
index 1e5bbb1..8222db2 100644
--- a/edit-lens/src/Control/DFST/Lens.lhs
+++ b/edit-lens/src/Control/DFST/Lens.lhs
@@ -7,11 +7,9 @@
7#-} 7#-}
8 8
9module Control.DFST.Lens 9module Control.DFST.Lens
10 ( StringEdit(..), sePos, seInsertion 10 ( DFSTAction(..), DFSTComplement
11 , StringEdits(..), _StringEdits, _SEFail, stringEdits
12 , insert, delete, replace
13 , DFSTAction(..), DFSTComplement
14 , dfstLens 11 , dfstLens
12 , module Control.Edit.String
15 , module Control.DFST 13 , module Control.DFST
16 , module Control.Lens.Edit 14 , module Control.Lens.Edit
17 ) where 15 ) where
@@ -20,9 +18,12 @@ import Control.DFST
20import Control.FST hiding (stInitial, stTransition, stAccept) 18import Control.FST hiding (stInitial, stTransition, stAccept)
21import qualified Control.FST as FST (stInitial, stTransition, stAccept, step) 19import qualified Control.FST as FST (stInitial, stTransition, stAccept, step)
22import Control.Lens.Edit 20import Control.Lens.Edit
21import Control.Lens.Edit.ActionTree
23import Control.Lens 22import Control.Lens
24import Control.Lens.TH 23import Control.Lens.TH
25import Control.Edit 24import Control.Edit
25import Control.Edit.String
26import Control.Edit.String.Affected
26 27
27import Control.Monad 28import Control.Monad
28 29
@@ -64,94 +65,8 @@ import Data.Universe (Finite(..))
64\end{code} 65\end{code}
65\end{comment} 66\end{comment}
66 67
67 68\begin{defn}[Ausgabe-Wirkung von DFSTs]
68\begin{defn}[Atomare edits of strings] 69Wir definieren zunächst die \emph{Ausgabe-Wirkung}\footnote{Wir schreiben im Folgenden auch nur \emph{Wirkung}} eines DFST auf einen festen String als eine Abbildung \texttt{state -> (Seq output, Maybe state)}, die den aktuellen Zustand vor dem Parsen des Strings auf den Zustand danach und die (womöglich leere) Ausgabe schickt.
69Wir betrachten, zur Einfachheit, ein minimiales Set von Edits auf Strings\footnote{Wie in der Konstruktion zum Longest Common Subsequence Problem}, bestehend nur aus Einfügung eines einzelnen Zeichens und löschen des Zeichens an einer einzelnen Position:
70
71\begin{code}
72data StringEdit pos char = Insert { _sePos :: pos, _seInsertion :: char }
73 | Delete { _sePos :: pos }
74 deriving (Eq, Ord, Show, Read)
75
76-- Automatically derive van-leerhoven-lenses:
77--
78-- @sePos :: Lens' (StringEdits pos char) pos@
79-- @seInsertion :: Traversal' (StringEdits pos char) char@
80makeLenses ''StringEdit
81\end{code}
82
83Atomare edits werden, als Liste, zu edits komponiert.
84Wir führen einen speziellen edit ein, der nicht-Anwendbarkeit der edits repräsentiert:
85\begin{code}
86data StringEdits pos char = StringEdits (Seq (StringEdit pos char))
87 | SEFail
88 deriving (Eq, Ord, Show, Read)
89
90makePrisms ''StringEdits
91
92stringEdits :: Traversal (StringEdits pos char) (StringEdits pos' char') (StringEdit pos char) (StringEdit pos' char')
93\end{code}
94\end{defn}
95
96\begin{comment}
97\begin{code}
98stringEdits = _StringEdits . traverse
99
100insert :: pos -> char -> StringEdits pos char
101insert n c = StringEdits . Seq.singleton $ Insert n c
102
103delete :: pos -> StringEdits pos char
104delete n = StringEdits . Seq.singleton $ Delete n
105
106replace :: Eq pos => pos -> char -> StringEdits pos char
107replace n c = insert n c <> delete n
108
109-- | Rudimentarily optimize edit composition
110instance Eq pos => Monoid (StringEdits pos char) where
111 mempty = StringEdits Seq.empty
112 SEFail `mappend` _ = SEFail
113 _ `mappend` SEFail = SEFail
114 (StringEdits Seq.Empty) `mappend` x = x
115 x `mappend` (StringEdits Seq.Empty) = x
116 (StringEdits x@(bs :|> b)) `mappend` (StringEdits y@(a :<| as))
117 | (Insert n _) <- a
118 , (Delete n') <- b
119 , n == n'
120 = StringEdits bs `mappend` StringEdits as
121 | otherwise = StringEdits $ x `mappend` y
122\end{code}
123\end{comment}
124
125Da wir ein minimales Set an atomaren edits gewählt haben, ist die Definiton der Modulnstruktur über Strings des passenden Alphabets recht einfach:
126\begin{code}
127instance Module (StringEdits Natural char) where
128 type Domain (StringEdits Natural char) = Seq char
129 apply str SEFail = Nothing
130 apply str (StringEdits Seq.Empty) = Just str
131 apply str (StringEdits (es :|> Insert n c)) = flip apply (StringEdits es) =<< go str n c
132 where
133 go Seq.Empty n c
134 | n == 0 = Just $ Seq.singleton c
135 | otherwise = Nothing
136 go str@(x :<| xs) n c
137 | n == 0 = Just $ c <| str
138 | otherwise = (x <|) <$> go xs (pred n) c
139 apply str (StringEdits (es :|> Delete n)) = flip apply (StringEdits es) =<< go str n
140 where
141 go Seq.Empty _ = Nothing
142 go (x :<| xs) n
143 | n == 0 = Just xs
144 | otherwise = (x <|) <$> go xs (pred n)
145
146 init = Seq.empty
147 divInit = StringEdits . Seq.unfoldl go . (0,)
148 where
149 go (_, Seq.Empty) = Nothing
150 go (n, c :<| cs ) = Just ((succ n, cs), Insert n c)
151
152\end{code}
153
154Wir definieren zunächst die \emph{Wirkung} eines DFST auf einen festen String als eine Abbildung \texttt{state -> (Seq output, Maybe state)}, die den aktuellen Zustand vor dem Parsen des Strings auf den Zustand danach und die (womöglich leere) Ausgabe schickt.
155Wir annotieren Wirkungen zudem mit dem konsumierten String. 70Wir annotieren Wirkungen zudem mit dem konsumierten String.
156Diese Wirkungen bilden einen Monoiden analog zu Endomorphismen, wobei die Resultat-Strings concateniert werden. 71Diese Wirkungen bilden einen Monoiden analog zu Endomorphismen, wobei die Resultat-Strings concateniert werden.
157 72
@@ -175,13 +90,24 @@ instance Monoid (DFSTAction state input output) where
175 } 90 }
176\end{code} 91\end{code}
177\end{comment} 92\end{comment}
93\end{defn}
178 94
95\begin{eg} \label{eg:linebreakonw100}
96 Die Wirkung des DFST aus Beispiel~\ref{eg:linebreak} auf das Wort $w$ aus Beispiel~\ref{eg:w100} ist:
97
98 \begin{align*}
99 \text{act} & \colon Q \to \Delta^\star \times \{ \bot \} \cup Q \\
100 0 & \mapsto (0\, 1\, \ldots\, 80\, \text{\tt \textbackslash n}\, 81\, \ldots\, 98, 19) \\
101 1 & \mapsto (0\, 1\, \ldots\, 79\, \text{\tt \textbackslash n}\, 80\, \ldots\, 98, 18) \\
102 & \vdots
103 \end{align*}
104\end{eg}
105
106
107\begin{comment}
179\begin{code} 108\begin{code}
180dfstAction :: forall state input output. (Finite state, Ord state, Ord input) => DFST state input output -> input -> DFSTAction state input output 109dfstAction :: forall state input output. (Finite state, Ord state, Ord input) => DFST state input output -> input -> DFSTAction state input output
181-- | Smart constructor of `DFSTAction` ensuring that `Seq.length . dfstaConsumes == const 1` and that `runDFSTAction` has constant complexity 110-- | Smart constructor of `DFSTAction` ensuring that `Seq.length . dfstaConsumes == const 1` and that `runDFSTAction` has constant complexity
182\end{code}
183\begin{comment}
184\begin{code}
185dfstAction dfst (Seq.singleton -> dfstaConsumes) = DFSTAction{..} 111dfstAction dfst (Seq.singleton -> dfstaConsumes) = DFSTAction{..}
186 where 112 where
187 runDFSTAction :: state -> (Seq output, Maybe state) 113 runDFSTAction :: state -> (Seq output, Maybe state)
@@ -193,11 +119,35 @@ dfstAction dfst (Seq.singleton -> dfstaConsumes) = DFSTAction{..}
193\end{comment} 119\end{comment}
194 120
195Wir halten im Komplement der edit-lens einen Cache der monoidalen Summen aller kontinuirlichen Teillisten. 121Wir halten im Komplement der edit-lens einen Cache der monoidalen Summen aller kontinuirlichen Teillisten.
196\texttt{Compositions} ist ein balancierter Binärbaum, dessen innere Knoten mit der monoidalen Summe der Annotationen aller Blätter annotiert sind. 122\texttt{Compositions} ist hierbei ein balancierter Binärbaum, dessen innere Knoten mit der monoidalen Summe der Annotationen aller Blätter des jeweiligen Teilbaums annotiert sind.
197\begin{code} 123\begin{code}
198type DFSTComplement state input output = Compositions (DFSTAction state input output) 124type DFSTComplement state input output = Compositions (DFSTAction state input output)
199\end{code} 125\end{code}
200 126
127Wir bedienen uns hierbei einer bestehenden Programmbibliothek \cite{composition-tree} um das Balancieren bei Modifikation des Baums nicht implementieren zu müssen.
128
129\begin{eg}
130 Wir definieren zunächst einen weiteren, sehr einfachen, DFST:
131
132 \begin{figure}[H]
133 \centering
134 \pinclude{presentation/switchdfst.tex}
135 \caption{\label{fig:switchdfst} Ein einfacher DFST, der zwischen zwei Zustanden wechselt und Ausgabe abhängig vom aktuellen Zustand erzeugt}
136 \end{figure}
137
138 Auf $s$ wechselt der DFST seinen Zustand, auf $p$ produziert er, abhängig vom aktuellen Zustand, genau ein Zeichen.
139
140 Wir stellen die Wirkung des DFST auf den Eingabe-String $spp$ grafisch analog zur Baumstruktur von \texttt{Compositions} dar.
141 Wir bedienen uns hier der Darstellung von Automaten-Wirkungen als \emph{Schaltboxen} aus \cite{hofmann2011automatentheorie}, angepasst für DFSTs indem wir die Ausgabe des Automaten an den Pfaden innerhalb der Schaltbox annotieren.
142
143 \begin{figure}[H]
144 \centering
145 \pinclude{presentation/comptree.tex}
146 \caption{Die Wirkung der Eingabe $spp$ auf den Automaten aus Abbildung \ref{fig:switchdfst}}
147 \end{figure}
148\end{eg}
149
150\begin{comment}
201\begin{code} 151\begin{code}
202runDFSTAction' :: DFSTComplement state input output -> state -> (Seq output, Maybe state) 152runDFSTAction' :: DFSTComplement state input output -> state -> (Seq output, Maybe state)
203runDFSTAction' = runDFSTAction . Comp.composed 153runDFSTAction' = runDFSTAction . Comp.composed
@@ -208,6 +158,7 @@ dfstaConsumes' = dfstaConsumes . Comp.composed
208dfstaProduces :: DFSTComplement state input output -> state -> Seq output 158dfstaProduces :: DFSTComplement state input output -> state -> Seq output
209dfstaProduces = fmap fst . runDFSTAction' 159dfstaProduces = fmap fst . runDFSTAction'
210\end{code} 160\end{code}
161\end{comment}
211 162
212Für $\Rrightarrow$ können wir die alte DFST-Wirkung zunächst anhand des Intervalls indem der input-String von allen gegebenen edits betroffen ist (\texttt{affected}) in einen unveränderten Prefix und einen womöglich betroffenen Suffix unterteilen. 163Für $\Rrightarrow$ können wir die alte DFST-Wirkung zunächst anhand des Intervalls indem der input-String von allen gegebenen edits betroffen ist (\texttt{affected}) in einen unveränderten Prefix und einen womöglich betroffenen Suffix unterteilen.
213 164
@@ -229,6 +180,55 @@ Die input-edits können nun wiederum, unter Beachtung der Verschiebung der indic
229\begin{comment} 180\begin{comment}
230\begin{code} 181\begin{code}
231type LState state input output = (Natural, (state, Maybe (input, Natural))) 182type LState state input output = (Natural, (state, Maybe (input, Natural)))
183
184instance (Ord state, Ord input, Ord output, Show state, Show input, Show output, Finite state) => Action (DFSTAction state input output) input output where
185 type ActionParam (DFSTAction state input output) = DFST state input output
186 type ActionState (DFSTAction state input output) = state
187
188 actionFail = DFSTAction (\_ -> (Seq.empty, Nothing)) Seq.empty
189
190 actionSingleInput = dfstAction
191
192 actionGroundState = stInitial
193 actionStateFinal DFST{..} final = final `Set.member` stAccept
194 actionState _ act st = view _2 $ runDFSTAction' act st
195 actionProduces _ act st = dfstaProduces act st
196
197 actionConsumes _ = dfstaConsumes'
198
199 actionFindPath DFST{..} iState affNewOut fState suffix = do
200 let
201 outFST :: FST (LState state input output) input output
202 outFST = restrictOutput affNewOut $ toFST DFST
203 { stInitial = iState
204 , stTransition
205 , stAccept = Set.fromList $ do
206 fin <- Set.toList $ stAccept `Set.union` Set.map fst (Map.keysSet stTransition)
207 (suffOut, Just fin') <- return $ runDFSTAction' suffix fin
208 guard $ Set.member fin' stAccept
209 guard $ suffOut == dfstaProduces suffix fState
210 return fin
211 }
212 -- trace (show $ pretty outFST) $ Just ()
213
214 newPath <-
215 let
216 FST{..} = outFST
217 detOutgoing :: Maybe (LState state input output) -> [(LState state input output, (Maybe input, Maybe output))]
218 detOutgoing Nothing = concatMap detOutgoing . map Just $ toList stInitial
219 detOutgoing (Just st) = concatMap (\((_, inS), outs) -> map (\(st', outS) -> (st', (inS, outS))) $ toList outs) . Map.toList $ Map.filterWithKey (\(st', _) _ -> st == st') stTransition
220 predicate :: [(LState state input output, (Maybe input, Maybe output))] -> Maybe Bool
221 predicate []
222 | not . Set.null $ Set.intersection stInitial stAccept = Just True
223 | otherwise = Nothing
224 predicate ((lastSt, _) : _)
225 | Set.member lastSt stAccept = Just True
226 | otherwise = Nothing
227 in bfs detOutgoing predicate
228
229 -- trace (show newPath) $ Just ()
230
231 return . Seq.fromList . mapMaybe (\(_st, (inS, _outS)) -> inS) $ reverse newPath
232\end{code} 232\end{code}
233\end{comment} 233\end{comment}
234\begin{code} 234\begin{code}
@@ -236,130 +236,12 @@ dfstLens :: forall state input output. (Ord state, Ord input, Ord output, Show s
236\end{code} 236\end{code}
237\begin{comment} 237\begin{comment}
238\begin{code} 238\begin{code}
239dfstLens dfst@DFST{..} = EditLens ground propR propL 239dfstLens = treeLens
240 where
241 ground :: DFSTComplement state input output
242 ground = mempty
243
244 propR :: (DFSTComplement state input output, StringEdits Natural input) -> (DFSTComplement state input output, StringEdits Natural output)
245 propR (c, SEFail) = (c, SEFail)
246 propR (c, StringEdits Seq.Empty) = (c, mempty)
247 propR (c, lEs@(StringEdits (es :> e)))
248 | (_, Just final) <- runDFSTAction' c' stInitial
249 , final `Set.member` stAccept
250 = (c', rEs)
251 | otherwise
252 = (c, SEFail)
253 where
254 Just int = affected lEs
255 (cAffSuffix, cAffPrefix) = Comp.splitAt (Comp.length c - fromIntegral (Int.inf int)) c
256 (cSuffix, cPrefix) = Comp.splitAt (Comp.length c - (e ^. sePos . from enum)) c
257 cSuffix'
258 | Delete _ <- e
259 , Comp.length cSuffix > 0 = Comp.take (pred $ Comp.length cSuffix) cSuffix
260 | Insert _ nChar <- e = cSuffix <> Comp.singleton (dfstAction dfst nChar)
261 | otherwise = Comp.singleton $ DFSTAction (\_ -> (Seq.empty, Nothing)) Seq.empty
262 (c', _) = propR (cSuffix' <> cPrefix, StringEdits es)
263 (cAffSuffix', _) = Comp.splitAt (Comp.length c' - Comp.length cAffPrefix) c'
264 (_, Just pFinal) = runDFSTAction' cAffPrefix stInitial
265 rEs = strDiff (dfstaProduces cAffSuffix pFinal) (dfstaProduces cAffSuffix' pFinal) & stringEdits . sePos . from enum +~ length (dfstaProduces cAffPrefix stInitial)
266
267
268 propL :: (DFSTComplement state input output, StringEdits Natural output) -> (DFSTComplement state input output, StringEdits Natural input)
269 propL (c, StringEdits Seq.Empty) = (c, mempty)
270 propL (c, es) = fromMaybe (c, SEFail) $ do
271 -- Determine states @(iState, fState)@ at the boundary of the region affected by @es@
272 ((,) <$> Int.inf <*> Int.sup -> (minAff, maxAff)) <- affected es
273 trace (show (minAff, maxAff)) $ Just ()
274 let
275 prevTrans :: Natural -> Maybe ( DFSTComplement state input output -- ^ Run after chosen transition to accepting state
276 , (state, input, Seq output, state)
277 , DFSTComplement state input output -- ^ Run from `stInitial` up to chosen transition
278 )
279 -- ^ Given an index in the output, find the associated transition in @c@
280 prevTrans needle = do
281 let (after, before) = prevTrans' (c, mempty)
282 transSt <- view _2 $ runDFSTAction (Comp.composed before) stInitial
283 trace ("transSt = " ++ show transSt) $ Just ()
284 let (after', trans) = Comp.splitAt (pred $ Comp.length after) after
285 DFSTAction{..} = Comp.composed trans
286 [inS] <- return $ toList dfstaConsumes
287 (outSs , Just postTransSt) <- return $ runDFSTAction transSt
288 return (after', (transSt, inS, outSs, postTransSt), before)
289 where
290 -- | Move monoid summands from @after@ to @before@ until first transition of @after@ produces @needle@ or @after@ is a singleton
291 prevTrans' (after, before)
292 | producedNext > needle = (after, before)
293 | Comp.length after == 1 = (after, before)
294 | otherwise = prevTrans' (after', before')
295 where
296 producedNext = fromIntegral . Seq.length . traceShowId $ dfstaProduces before' stInitial
297 (after', nextTrans) = Comp.splitAt (pred $ Comp.length after) after
298 before' = nextTrans `mappend` before
299 (_, (iState, _, _, _), prefix) <- prevTrans minAff
300 trace (show (iState, Comp.length prefix)) $ Just ()
301 (suffix, (pfState, _, _, fState), _) <- prevTrans maxAff
302 trace (show (pfState, fState, Comp.length suffix)) $ Just ()
303
304 newOut <- dfstaProduces c stInitial `apply` es
305 let affNewOut = (\s -> Seq.take (Seq.length s - Seq.length (dfstaProduces suffix fState)) s) $ Seq.drop (Seq.length $ dfstaProduces prefix stInitial) newOut
306 trace (show (iState, fState, affNewOut)) $ Just ()
307
308 let outFST :: FST (LState state input output) input output
309 outFST = restrictOutput affNewOut $ toFST DFST
310 { stInitial = iState
311 , stTransition
312 , stAccept = Set.fromList $ do
313 fin <- Set.toList $ stAccept `Set.union` Set.map fst (Map.keysSet stTransition)
314 (suffOut, Just fin') <- return $ runDFSTAction' suffix fin
315 guard $ Set.member fin' stAccept
316 guard $ suffOut == dfstaProduces suffix fState
317 return fin
318 }
319 trace (show $ pretty outFST) $ Just ()
320
321 newPath <-
322 let
323 FST{ .. } = outFST
324 detOutgoing :: Maybe (LState state input output) -> [(LState state input output, (Maybe input, Maybe output))]
325 detOutgoing Nothing = concatMap detOutgoing . map Just $ toList stInitial
326 detOutgoing (Just st) = concatMap (\((_, inS), outs) -> map (\(st', outS) -> (st', (inS, outS))) $ toList outs) . Map.toList $ Map.filterWithKey (\(st', _) _ -> st == st') stTransition
327 predicate :: [(LState state input output, (Maybe input, Maybe output))] -> Maybe Bool
328 predicate []
329 | not . Set.null $ Set.intersection stInitial stAccept = Just True
330 | otherwise = Nothing
331 predicate ((lastSt, _) : _)
332 | Set.member lastSt stAccept = Just True
333 | otherwise = Nothing
334 in bfs detOutgoing predicate
335
336 trace (show newPath) $ Just ()
337
338 let oldIn = dfstaConsumes' . Comp.drop (Comp.length suffix) $ Comp.take (Comp.length c - Comp.length prefix) c
339 newIn = Seq.fromList . mapMaybe (\(_st, (inS, _outS)) -> inS) $ reverse newPath
340 inDiff = oldIn `strDiff` newIn
341 diffOffset = fromIntegral . Seq.length $ dfstaConsumes' prefix
342 inDiff' = inDiff & stringEdits . sePos +~ diffOffset
343
344 trace (show (oldIn, newIn, inDiff')) $ Just ()
345
346 let affComp = Comp.fromList [ dfstAction dfst inS | (_st, (Just inS, _outS)) <- newPath ]
347
348 return (suffix <> affComp <> prefix, inDiff')
349
350strDiff :: forall sym pos. (Eq sym, Integral pos) => Seq sym -> Seq sym -> StringEdits pos sym
351-- ^ @strDiff a b@ calculates a set of edits, which, when applied to @a@, produce @b@
352strDiff a b = snd . foldl toEdit (0, mempty) $ (getDiff `on` toList) a b
353 where
354 toEdit :: (pos, StringEdits pos sym) -> Diff sym -> (pos, StringEdits pos sym)
355 toEdit (n, es) (Diff.Both _ _) = (succ n, es)
356 toEdit (n, es) (Diff.First _ ) = (n, delete n <> es)
357 toEdit (n, es) (Diff.Second c) = (succ n, insert n c <> es)
358 240
359-- | Generic breadth-first search 241-- | Generic breadth-first search
360bfs :: forall state transition. Ord state 242bfs :: forall state transition. Ord state
361 => (Maybe state -> [(state, transition)]) -- ^ Find outgoing edges 243 => (Maybe state -> [(state, transition)]) -- ^ Find outgoing edges
362 -> ([(state, transition)] {- ^ Reverse path -} -> Maybe Bool {- ^ Continue search, finish successfully, or abort search on this branch -}) -- ^ Search predicate 244 -> ([(state, transition)] {- Reverse path -} -> Maybe Bool {- Continue search, finish successfully, or abort search on this branch -}) -- ^ Search predicate
363 -> Maybe [(state, transition)] -- ^ Reverse path 245 -> Maybe [(state, transition)] -- ^ Reverse path
364bfs outgoing predicate 246bfs outgoing predicate
365 | Just True <- emptyRes = Just [] 247 | Just True <- emptyRes = Just []
@@ -378,59 +260,46 @@ bfs outgoing predicate
378 Nothing -> bfs' visited' $ cs <> Seq.fromList (map (: c) . filter (\(st, _) -> not $ Set.member st visited) . outgoing $ Just lastSt) 260 Nothing -> bfs' visited' $ cs <> Seq.fromList (map (: c) . filter (\(st, _) -> not $ Set.member st visited) . outgoing $ Just lastSt)
379 where 261 where
380 visited' = Set.insert lastSt visited 262 visited' = Set.insert lastSt visited
381\end{code}
382\end{comment}
383 263
384Um eine obere Schranke an das von einer Serie von edits betroffene Intervall zu bestimmen ordnen wir zunächst jeder von mindestens einem atomaren edit betroffenen Position $n$ im Eingabe-Wort einen $\text{offset}_n = \text{\# deletions} - \text{\# inserts}$ zu. 264-- trace :: String -> a -> a
385Das gesuchte Intervall ist nun $(\text{minK}, \text{maxK})$, mit $\text{minK}$ der Position im Eingabe-Wort mit niedrigstem $\text{offset}$ und $\text{maxK}$ die Position im Eingabe-Wort mit höchstem $\text{offset}$, $\text{maxK}^\prime$, modifiziert um das Maximum aus $\{ 0 \} \cup \{ \text{maxK}_n \colon n \in \{ 0 \ldots \text{maxK}^\prime \} \}$ wobei $\text{maxK}_n = -1 \cdot (n + \text{offset}_n)$ an Position $n$ ist. 265-- {-# NOINLINE trace #-}
266-- trace str y = flip seq y . unsafePerformIO . withFile "lens.log" AppendMode $ \h ->
267-- hPutStrLn h str
386 268
387\begin{code} 269-- traceShowId :: Show a => a -> a
388affected :: forall char. StringEdits Natural char -> Maybe (Interval Natural) 270-- traceShowId x = trace (show x) x
389-- ^ For a given set of edits @es@ return the interval @i = a ... b@ such that for any given string @str@ of sufficient length the following holds:
390--
391-- - For all @n :: Natural@: @n < a ==> str ! n == (str `apply` es) ! n@
392-- - There exists a @k :: Integer@ such that for all @n :: Integer@: @n > b ==> str ! (n + k) == (str `apply` es) ! n@
393--
394-- Intuitively: for any character @c@ of the new string @str `apply` es@ there exists a corresponding character in @str@ (offset by either 0 or a constant shift @k@) if the index of @c@ is /not/ contained in @affected es@.
395\end{code}
396\begin{comment}
397\begin{code}
398affected SEFail = Nothing
399affected (StringEdits es) = Just . toInterval $ go es Map.empty
400 where
401 toInterval :: Map Natural Integer -> Interval Natural
402 toInterval map
403 | Just (((minK, _), _), ((maxK, _), _)) <- (,) <$> Map.minViewWithKey map <*> Map.maxViewWithKey map
404 = let
405 maxV' = maximum . (0 :) $ do
406 offset <- [0..maxK]
407 v <- maybeToList $ Map.lookup (maxK - offset) map
408 v' <- maybeToList . fmap fromInteger $ negate v <$ guard (v <= 0)
409 guard $ v' >= succ offset
410 return $ v' - offset
411 in (minK Int.... maxK + maxV')
412 | otherwise
413 = Int.empty
414 go :: Seq (StringEdit Natural char) -> Map Natural Integer -> Map Natural Integer
415 go Seq.Empty offsets = offsets
416 go (es :> e) offsets = go es offsets'
417 where
418 p = e ^. sePos
419 -- p' = fromIntegral $ Map.foldrWithKey (\k o p -> bool (fromIntegral p) (o + p) $ k < fromIntegral p) (fromIntegral p) offsets
420 offsets' = Map.alter (Just . myOffset . fromMaybe 0) p offsets
421 myOffset :: Integer -> Integer
422 myOffset
423 | Insert _ _ <- e = pred
424 | Delete _ <- e = succ
425
426trace :: String -> a -> a
427{-# NOINLINE trace #-}
428trace str y = flip seq y . unsafePerformIO . withFile "lens.log" AppendMode $ \h ->
429 hPutStrLn h str
430
431traceShowId :: Show a => a -> a
432traceShowId x = trace (show x) x
433
434
435\end{code} 271\end{code}
436\end{comment} 272\end{comment}
273
274\begin{eg}
275 Wir wollen einen edit $e^\prime = \rho_{80}$ anwenden auf das Ergebnis $w^\prime$ der Ausführung des Zeilenumbruch-DFST aus Beispiel \ref{eg:linebreak} auf das Wort $w = 0\, 1\, \ldots\, 80\, \text{\tt \textbackslash n}\, 81\, \ldots\, 98$ aus Beispiel \ref{eg:w100} und dabei $e^\prime$ mittels $\Lleftarrow$ nach links propagieren und den assoziierten edit $e$ auf $w$ konstruieren.
276
277 \begin{equation*}
278 w^\prime = w = 0\, 1\, \ldots\, 80\, \text{\textbackslash n}\, 81\, \ldots\, 98
279 \end{equation*}
280
281 Das von $e$ betroffene Intervall von $w^\prime$ ist $(80, 80)$.
282
283 Das Komplement nach Anwendung des DFST auf $w$ ist, wie in Beispiel \ref{eg:linebreakonw100} dargelegt:
284
285 \begin{align*}
286 \text{act} & \colon Q \to \Delta^\star \times \{ \bot \} \cup Q \\
287 0 & \mapsto (0\, 1\, \ldots\, 80\, \text{\tt \textbackslash n}\, 81\, \ldots\, 98, 19) \\
288 1 & \mapsto (0\, 1\, \ldots\, 79\, \text{\tt \textbackslash n}\, 80\, \ldots\, 98, 18) \\
289 & \vdots
290 \end{align*}
291
292 Wir unterteilen $\text{act}$ an $(80, 80)$ in $\text{act}_\text{R} \circ \text{act}_e \circ \text{act}_\text{L}$:
293
294 \begin{align*}
295 \text{act}_\text{R} & \colon Q \to \Delta^\star \times \{ \bot \} \cup Q \\
296 n & \mapsto (81\, \ldots\, 98, \min ( 80, n + 19 ) ) \\
297 & \\
298 \text{act}_e & \colon Q \to \Delta^\star \times \{ \bot \} \cup Q \\
299 n & \mapsto ( \text{\tt \textbackslash n}, 0 ) \\
300 & \\
301 \text{act}_\text{L} & \colon Q \to \Delta^\star \times \{ \bot \} \cup Q \\
302 n & \mapsto (0\, 1\, \ldots\, 80, 80) \\
303 \text{other} & \mapsto (\epsilon, \bot)
304 \end{align*}
305\end{eg}
diff --git a/edit-lens/src/Control/DFST/Lens.lhs.tex b/edit-lens/src/Control/DFST/Lens.lhs.tex
new file mode 120000
index 0000000..09aa15c
--- /dev/null
+++ b/edit-lens/src/Control/DFST/Lens.lhs.tex
@@ -0,0 +1 @@
Lens.lhs \ No newline at end of file
diff --git a/edit-lens/src/Control/Edit.lhs b/edit-lens/src/Control/Edit.lhs
index 8c4f045..ba4b8e6 100644
--- a/edit-lens/src/Control/Edit.lhs
+++ b/edit-lens/src/Control/Edit.lhs
@@ -6,6 +6,8 @@ module Control.Edit
6\end{code} 6\end{code}
7\end{comment} 7\end{comment}
8 8
9Um das Intuitive Verhalten von Änderungen auf Texten\footnote{Im folgenden \emph{edits}} und ihre interne algebraische Struktur zu fassen formalisieren wir sie als \emph{Moduln}:
10
9\begin{defn}[Moduln] 11\begin{defn}[Moduln]
10Ein Modul $M$ ist eine \emph{partielle Monoidwirkung} zusammen mit einem schwach-initialen Element\footnote{Gemeint ist hier die übliche Definition von \emph{schwach-initial} aus der Kategorientheorie—ein Modul $M$ bildet eine Kategorie mit Objekten aus $\Dom M$ und Morphismen von $x$ nach $y$ den Monoidelementen $\partial x \in \partial M$ sodass $x \cdot \partial x = y$} (bzgl. der Monoidwirkung) auf dem Träger, d.h. $M = (\Dom M, \partial M, \init_M)$ ist ein Tupel aus einer Trägermenge $\Dom M$, einem Monoid $\partial M$ zusammen mit mit einer partiellen Funktion $\cdot \colon \Dom M \times \partial M \to \Dom$, die \emph{kompatibel} ist mit der Monoid-Struktur: 12Ein Modul $M$ ist eine \emph{partielle Monoidwirkung} zusammen mit einem schwach-initialen Element\footnote{Gemeint ist hier die übliche Definition von \emph{schwach-initial} aus der Kategorientheorie—ein Modul $M$ bildet eine Kategorie mit Objekten aus $\Dom M$ und Morphismen von $x$ nach $y$ den Monoidelementen $\partial x \in \partial M$ sodass $x \cdot \partial x = y$} (bzgl. der Monoidwirkung) auf dem Träger, d.h. $M = (\Dom M, \partial M, \init_M)$ ist ein Tupel aus einer Trägermenge $\Dom M$, einem Monoid $\partial M$ zusammen mit mit einer partiellen Funktion $\cdot \colon \Dom M \times \partial M \to \Dom$, die \emph{kompatibel} ist mit der Monoid-Struktur:
11 13
diff --git a/edit-lens/src/Control/Edit.lhs.tex b/edit-lens/src/Control/Edit.lhs.tex
new file mode 120000
index 0000000..33d3341
--- /dev/null
+++ b/edit-lens/src/Control/Edit.lhs.tex
@@ -0,0 +1 @@
Edit.lhs \ No newline at end of file
diff --git a/edit-lens/src/Control/Edit/String.lhs b/edit-lens/src/Control/Edit/String.lhs
new file mode 100644
index 0000000..c1411cf
--- /dev/null
+++ b/edit-lens/src/Control/Edit/String.lhs
@@ -0,0 +1,120 @@
1\begin{comment}
2\begin{code}
3{-# LANGUAGE TemplateHaskell
4#-}
5
6module Control.Edit.String
7 ( StringEdit(..), sePos, seInsertion
8 , StringEdits(..), _StringEdits, _SEFail, stringEdits
9 , insert, delete, replace
10 ) where
11
12import Control.Lens
13import Control.Lens.TH
14
15import Control.Edit
16
17import Numeric.Natural
18
19import Data.Sequence (Seq((:<|), (:|>)))
20import qualified Data.Sequence as Seq
21
22import Data.Monoid
23\end{code}
24\end{comment}
25
26\begin{defn}[Atomare edits of strings]
27Wir betrachten, zur Einfachheit, ein minimiales Set von Edits auf Strings\footnote{Wie in der Konstruktion zum Longest Common Subsequence Problem}, bestehend nur aus Einfügung eines einzelnen Zeichens $\sigma$ an einer bestimmten Position $\iota_n(\sigma)$ und löschen des Zeichens an einer einzelnen Position $\rho_n$:
28
29\begin{code}
30data StringEdit pos char = Insert { _sePos :: pos, _seInsertion :: char }
31 | Delete { _sePos :: pos }
32 deriving (Eq, Ord, Show, Read)
33
34-- Automatically derive van-leerhoven-lenses:
35--
36-- @sePos :: Lens' (StringEdits pos char) pos@
37-- @seInsertion :: Traversal' (StringEdits pos char) char@
38makeLenses ''StringEdit
39\end{code}
40
41Atomare edits werden, als Liste, zu edits komponiert.
42Wir führen einen speziellen edit ein, der nicht-Anwendbarkeit der edits repräsentiert:
43\begin{code}
44data StringEdits pos char = StringEdits (Seq (StringEdit pos char))
45 | SEFail
46 deriving (Eq, Ord, Show, Read)
47
48makePrisms ''StringEdits
49
50stringEdits :: Traversal (StringEdits pos char) (StringEdits pos' char') (StringEdit pos char) (StringEdit pos' char')
51\end{code}
52\end{defn}
53
54\begin{comment}
55\begin{code}
56stringEdits = _StringEdits . traverse
57
58insert :: pos -> char -> StringEdits pos char
59insert n c = StringEdits . Seq.singleton $ Insert n c
60
61delete :: pos -> StringEdits pos char
62delete n = StringEdits . Seq.singleton $ Delete n
63
64replace :: Eq pos => pos -> char -> StringEdits pos char
65replace n c = insert n c <> delete n
66
67-- | Rudimentarily optimize edit composition
68instance Eq pos => Monoid (StringEdits pos char) where
69 mempty = StringEdits Seq.empty
70 SEFail `mappend` _ = SEFail
71 _ `mappend` SEFail = SEFail
72 (StringEdits Seq.Empty) `mappend` x = x
73 x `mappend` (StringEdits Seq.Empty) = x
74 (StringEdits x@(bs :|> b)) `mappend` (StringEdits y@(a :<| as))
75 | (Insert n _) <- a
76 , (Delete n') <- b
77 , n == n'
78 = StringEdits bs `mappend` StringEdits as
79 | otherwise = StringEdits $ x `mappend` y
80\end{code}
81\end{comment}
82
83Da wir ein minimales Set an atomaren edits gewählt haben, ist die Definiton der Modulnstruktur über Strings des passenden Alphabets recht einfach:
84\begin{code}
85instance Module (StringEdits Natural char) where
86 type Domain (StringEdits Natural char) = Seq char
87 apply str SEFail = Nothing
88 apply str (StringEdits Seq.Empty) = Just str
89 apply str (StringEdits (es :|> Insert n c)) = flip apply (StringEdits es) =<< go str n c
90 where
91 go str (fromIntegral -> n) c
92 | Seq.length str >= n
93 = Just $ Seq.insertAt n c str
94 | otherwise
95 = Nothing
96 apply str (StringEdits (es :|> Delete n)) = flip apply (StringEdits es) =<< go str n
97 where
98 go str (fromIntegral -> n)
99 | Seq.length str > n
100 = Just $ Seq.deleteAt n str
101 | otherwise
102 = Nothing
103
104 init = Seq.empty
105 divInit = StringEdits . Seq.unfoldl go . (0,)
106 where
107 go (_, Seq.Empty) = Nothing
108 go (n, c :<| cs ) = Just ((succ n, cs), Insert n c)
109
110\end{code}
111
112\begin{eg}
113 Wir wenden $\iota_{80}(100) \rho_{80}$ auf das Wort $w$ aus Beispiel~\ref{eg:w100} an:
114
115 \begin{align*}
116 w^\prime & = w \cdot \iota_{80}(100) \rho_{80} \\
117 & = 0\, 1\, \ldots\, 80\, 100\, 81\, 82\, \ldots\, 98
118 \end{align*}
119\end{eg}
120
diff --git a/edit-lens/src/Control/Edit/String.lhs.tex b/edit-lens/src/Control/Edit/String.lhs.tex
new file mode 120000
index 0000000..6a78642
--- /dev/null
+++ b/edit-lens/src/Control/Edit/String.lhs.tex
@@ -0,0 +1 @@
String.lhs \ No newline at end of file
diff --git a/edit-lens/src/Control/Edit/String/Affected.lhs b/edit-lens/src/Control/Edit/String/Affected.lhs
new file mode 100644
index 0000000..851267b
--- /dev/null
+++ b/edit-lens/src/Control/Edit/String/Affected.lhs
@@ -0,0 +1,73 @@
1\begin{comment}
2\begin{code}
3module Control.Edit.String.Affected
4 ( affected
5 ) where
6
7import Control.Lens
8import Control.Lens.TH
9
10import Control.Edit
11import Control.Edit.String
12
13import Numeric.Natural
14import Numeric.Interval (Interval, (...))
15import qualified Numeric.Interval as Int
16
17import Data.Sequence (Seq((:<|), (:|>)))
18import qualified Data.Sequence as Seq
19
20import Data.Map.Lazy (Map)
21import qualified Data.Map.Lazy as Map
22
23import Data.Monoid
24
25import Control.Monad
26
27import Data.Maybe (fromMaybe, maybeToList, listToMaybe, catMaybes, isNothing, isJust, mapMaybe)
28\end{code}
29\end{comment}
30
31Um eine obere Schranke an das von einer Serie von edits betroffene Intervall zu bestimmen ordnen wir zunächst jeder von mindestens einem atomaren edit betroffenen Position $n$ im Eingabe-Wort einen $\text{offset}_n = \text{\# deletions} - \text{\# inserts}$ zu.
32Das gesuchte Intervall ist nun $(\text{minK}, \text{maxK})$, mit $\text{minK}$ der Position im Eingabe-Wort mit niedrigstem $\text{offset}$ und $\text{maxK}$ die Position im Eingabe-Wort mit höchstem $\text{offset}$, $\text{maxK}^\prime$, modifiziert um das Maximum aus $\{ 0 \} \cup \{ \text{maxK}_n \colon n \in \{ 0 \ldots \text{maxK}^\prime \} \}$ wobei $\text{maxK}_n = -1 \cdot (n + \text{offset}_n)$ an Position $n$ ist.
33
34\begin{code}
35affected :: forall char. StringEdits Natural char -> Maybe (Interval Natural)
36-- ^ For a given set of edits @es@ return the interval @i = a ... b@ such that for any given string @str@ of sufficient length the following holds:
37--
38-- - For all @n :: Natural@: @n < a ==> str ! n == (str `apply` es) ! n@
39-- - There exists a @k :: Integer@ such that for all @n :: Integer@: @n > b ==> str ! (n + k) == (str `apply` es) ! n@
40--
41-- Intuitively: for any character @c@ of the new string @str `apply` es@ there exists a corresponding character in @str@ (offset by either 0 or a constant shift @k@) if the index of @c@ is /not/ contained in @affected es@.
42\end{code}
43\begin{comment}
44\begin{code}
45affected SEFail = Nothing
46affected (StringEdits es) = Just . toInterval $ go es Map.empty
47 where
48 toInterval :: Map Natural Integer -> Interval Natural
49 toInterval map
50 | Just (((minK, _), _), ((maxK, _), _)) <- (,) <$> Map.minViewWithKey map <*> Map.maxViewWithKey map
51 = let
52 maxV' = maximum . (0 :) $ do
53 offset <- [0..maxK]
54 v <- maybeToList $ Map.lookup (maxK - offset) map
55 v' <- maybeToList . fmap fromInteger $ negate v <$ guard (v <= 0)
56 guard $ v' >= succ offset
57 return $ v' - offset
58 in (minK Int.... maxK + maxV')
59 | otherwise
60 = Int.empty
61 go :: Seq (StringEdit Natural char) -> Map Natural Integer -> Map Natural Integer
62 go Seq.Empty offsets = offsets
63 go (es :> e) offsets = go es offsets'
64 where
65 p = e ^. sePos
66 -- p' = fromIntegral $ Map.foldrWithKey (\k o p -> bool (fromIntegral p) (o + p) $ k < fromIntegral p) (fromIntegral p) offsets
67 offsets' = Map.alter (Just . myOffset . fromMaybe 0) p offsets
68 myOffset :: Integer -> Integer
69 myOffset
70 | Insert _ _ <- e = pred
71 | Delete _ <- e = succ
72\end{code}
73\end{comment}
diff --git a/edit-lens/src/Control/Edit/String/Affected.lhs.tex b/edit-lens/src/Control/Edit/String/Affected.lhs.tex
new file mode 120000
index 0000000..b85cc7a
--- /dev/null
+++ b/edit-lens/src/Control/Edit/String/Affected.lhs.tex
@@ -0,0 +1 @@
Affected.lhs \ No newline at end of file
diff --git a/edit-lens/src/Control/FST.lhs b/edit-lens/src/Control/FST.lhs
index 9357da7..9739adc 100644
--- a/edit-lens/src/Control/FST.lhs
+++ b/edit-lens/src/Control/FST.lhs
@@ -77,7 +77,9 @@ data FST state input output = FST
77 & \cup \{ (80, \sigma, \sigma, 80) \mid \sigma \in \Sigma \mysetminus \{ \text{\tt ' '}, \text{\tt \textbackslash n} \} \} 77 & \cup \{ (80, \sigma, \sigma, 80) \mid \sigma \in \Sigma \mysetminus \{ \text{\tt ' '}, \text{\tt \textbackslash n} \} \}
78 \end{align*} 78 \end{align*}
79 79
80 \begin{figure}[p] 80 Siehe auch Abbildung~\ref{fig:linebreak}
81
82 \begin{figure}[h]
81 \centering 83 \centering
82 \begin{tikzpicture}[->,auto,node distance=5cm] 84 \begin{tikzpicture}[->,auto,node distance=5cm]
83 \node[initial,state,accepting] (0) {$0$}; 85 \node[initial,state,accepting] (0) {$0$};
@@ -101,7 +103,7 @@ data FST state input output = FST
101 \draw[-] (rest)--(i.north); 103 \draw[-] (rest)--(i.north);
102 \draw[-] (rest)--(si.west); 104 \draw[-] (rest)--(si.west);
103 \end{tikzpicture} 105 \end{tikzpicture}
104 \caption{Beispiel \ref{eg:linebreak} dargestellt als Graph} 106 \caption{\label{fig:linebreak} Ein Transducer der, durch Übersetzung zwischen Leerzeichen und Zeilenumbrüchen, sicher stellt, dass jede Zeile eines Texts mindestens 80 Zeichen hat}
105 \end{figure} 107 \end{figure}
106\end{eg} 108\end{eg}
107 109
@@ -314,7 +316,9 @@ wordFST inps outs = FST
314 & \cup \{ (i, \sigma, \epsilon, i) \mid \sigma \in \Sigma \cup \{ \epsilon \}, i \in Q \mysetminus \{ 99 \} \} 316 & \cup \{ (i, \sigma, \epsilon, i) \mid \sigma \in \Sigma \cup \{ \epsilon \}, i \in Q \mysetminus \{ 99 \} \}
315 \end{align*} 317 \end{align*}
316 318
317 \begin{figure}[p] 319 Siehe auch Abbildung~\ref{fig:w100}.
320
321 \begin{figure}[h]
318 \centering 322 \centering
319 \begin{tikzpicture}[->,auto,node distance=5cm] 323 \begin{tikzpicture}[->,auto,node distance=5cm]
320 \node[initial,state] (0) {$0$}; 324 \node[initial,state] (0) {$0$};
@@ -323,11 +327,11 @@ wordFST inps outs = FST
323 327
324 \path (0) edge [loop above] node {$\{(\sigma, \epsilon) \mid \sigma \in \Sigma \cup \{ \epsilon \} \}$} (0) 328 \path (0) edge [loop above] node {$\{(\sigma, \epsilon) \mid \sigma \in \Sigma \cup \{ \epsilon \} \}$} (0)
325 edge node {$\{ (\sigma, 1) \mid \sigma \in \Sigma \cup \{ \epsilon \} \}$} (rest) 329 edge node {$\{ (\sigma, 1) \mid \sigma \in \Sigma \cup \{ \epsilon \} \}$} (rest)
326 (rest) edge node {$\{ \sigma, 100 \} \mid \sigma \in \Sigma \cup \{ \epsilon \}$} (99) 330 (rest) edge node {$\{ (\sigma, 98) \mid \sigma \in \Sigma \cup \{ \epsilon \} \}$} (99)
327 (99) edge [loop above] node {$\{(\sigma, \epsilon) \mid \sigma \in \Sigma \}$} (99); 331 (99) edge [loop above] node {$\{(\sigma, \epsilon) \mid \sigma \in \Sigma \}$} (99);
328 \end{tikzpicture} 332 \end{tikzpicture}
329 333
330 \caption{Beispiel \ref{eg:w100} dargestellt als Graph} 334 \caption{\label{fig:w100} Der Wort-FST eines längeren Wortes}
331 \end{figure} 335 \end{figure}
332\end{eg} 336\end{eg}
333 337
@@ -351,7 +355,9 @@ restrictOutput :: forall state input output. (Ord state, Ord input, Ord output)
351 & \cup \{ ((80, 80), \text{\tt \textbackslash n}, \text{\tt \textbackslash n}, (81, 0)) \} 355 & \cup \{ ((80, 80), \text{\tt \textbackslash n}, \text{\tt \textbackslash n}, (81, 0)) \}
352 \end{align*} 356 \end{align*}
353 357
354 \begin{figure}[p] 358 Siehe auch Abbildung~\ref{fig:l80timesw100}.
359
360 \begin{figure}[h]
355 \centering 361 \centering
356 \begin{tikzpicture}[->,auto,node distance=5cm] 362 \begin{tikzpicture}[->,auto,node distance=5cm]
357 \node[initial,state] (0) {$0_{W_w}\, 0_{L_{80}}$}; 363 \node[initial,state] (0) {$0_{W_w}\, 0_{L_{80}}$};
@@ -368,12 +374,12 @@ restrictOutput :: forall state input output. (Ord state, Ord input, Ord output)
368 (rest2) edge node {$(98, 98)$} (99); 374 (rest2) edge node {$(98, 98)$} (99);
369 \end{tikzpicture} 375 \end{tikzpicture}
370 376
371 \caption{Beispiel \ref{eg:l80timesw100} dargestellt als Graph} 377 \caption{\label{fig:l80timesw100} Die Einschränkung des Automaten aus Abbildung \ref{fig:linebreak} auf das Wort aus Abbildung \ref{fig:w100}}
372 \end{figure} 378 \end{figure}
373\end{eg} 379\end{eg}
374 380
375\begin{rem} 381\begin{rem}
376 Es ist bemerkenswert, dass in Beispiel \ref{eg:l80timesw100} die Zirkuläre Struktur von $L_80$ durch Produkt mit einem Wort verloren geht. 382 Es ist bemerkenswert, dass in Beispiel \ref{eg:l80timesw100} die Zirkuläre Struktur von $L_{80}$ durch Produkt mit einem Wort verloren geht.
377 383
378 I.\@A.\@ ist das Produkt eines beliebigen FST mit einem Wort-FST zwar nicht azyklisch, erbt jedoch die lineare Struktur des Wort-FST in dem Sinne, dass Fortschritt in Richtung der akzeptierenden Zustände nur möglich ist indem der $(i, \sigma, w_i, i + 1)$-Klasse von Transitionen des Wort-FSTs gefolgt wird. 384 I.\@A.\@ ist das Produkt eines beliebigen FST mit einem Wort-FST zwar nicht azyklisch, erbt jedoch die lineare Struktur des Wort-FST in dem Sinne, dass Fortschritt in Richtung der akzeptierenden Zustände nur möglich ist indem der $(i, \sigma, w_i, i + 1)$-Klasse von Transitionen des Wort-FSTs gefolgt wird.
379\end{rem} 385\end{rem}
diff --git a/edit-lens/src/Control/FST.lhs.tex b/edit-lens/src/Control/FST.lhs.tex
new file mode 120000
index 0000000..b6f3a8f
--- /dev/null
+++ b/edit-lens/src/Control/FST.lhs.tex
@@ -0,0 +1 @@
FST.lhs \ No newline at end of file
diff --git a/edit-lens/src/Control/Lens/Edit.lhs b/edit-lens/src/Control/Lens/Edit.lhs
index 96b2114..6561528 100644
--- a/edit-lens/src/Control/Lens/Edit.lhs
+++ b/edit-lens/src/Control/Lens/Edit.lhs
@@ -12,7 +12,7 @@ import Control.Edit
12\end{comment} 12\end{comment}
13 13
14\begin{defn}[Zustandsbehaftete Monoidhomomorphismen] 14\begin{defn}[Zustandsbehaftete Monoidhomomorphismen]
15Gegeben eine Menge von Komplementen $C$ und Monoiden $M$ und $N$ nennen wir eine partielle Funktion $\psi \colon C \times M \to C \times N$ einen zustandsbehafteten Monoidhomomorphismus wenn sie den folgenden Ansprüchen genügt: 15Gegeben eine Menge $C$ von \emph{Komplementen} und zwei Monoiden $M$ und $N$ nennen wir eine partielle Funktion $\psi \colon C \times M \to C \times N$ einen zustandsbehafteten Monoidhomomorphismus wenn sie den folgenden Ansprüchen genügt:
16 16
17\begin{itemize} 17\begin{itemize}
18 \item $\forall c \in C \colon \psi(1_M, c) = (1_N, c)$ 18 \item $\forall c \in C \colon \psi(1_M, c) = (1_N, c)$
@@ -28,7 +28,7 @@ type StateMonoidHom s m n = (s, m) -> (s, n)
28\end{defn} 28\end{defn}
29 29
30\begin{defn}[edit-lenses] 30\begin{defn}[edit-lenses]
31Für Moduln $M$ und $N$ besteht eine symmetrische edit-lens zwischen $M$ und $N$ aus zwei zustandsbehafteten Monoidhomomorphismen $\Rrightarrow \colon C \times \partial M \to C \times \partial N$ und $\Lleftarrow \colon C \times \partial N \to C \times \partial M$, mit kompatiblem Komplement $C$, einem ausgezeichneten Element $\ground_C$ und einer \emph{Konsistenzrelation} $K \subset \Dom M \times C \times \Dom N$ sodass gilt: 31Für Moduln $M$ und $N$ besteht eine symmetrische edit-lens zwischen $M$ und $N$ aus zwei zustandsbehafteten Monoidhomomorphismen $\Rrightarrow \colon C \times \partial M \to C \times \partial N$ und $\Lleftarrow \colon C \times \partial N \to C \times \partial M$, mit kompatiblem Komplement $C$, einem ausgezeichneten Element $\ground_C \in C$ und einer \emph{Konsistenzrelation} $K \subset \Dom M \times C \times \Dom N$ sodass gilt:
32 32
33\begin{itemize} 33\begin{itemize}
34 \item $(\init_M, \ground_C, \init_N) \in K$ 34 \item $(\init_M, \ground_C, \init_N) \in K$
@@ -67,7 +67,7 @@ instance (Module m, Module n) => HasEditLens (EditLens c m n) m n where
67\end{code} 67\end{code}
68\end{defn} 68\end{defn}
69 69
70\paragraph{Kompatibilität mit bestehenden lens frameworks} 70\subsection{Kompatibilität mit bestehenden lens frameworks}
71 71
72Das einschlägige bestehende lens framework \cite{lens} konstruiert seine Linsen alá \citeauthor{laarhoven} wie folgt: 72Das einschlägige bestehende lens framework \cite{lens} konstruiert seine Linsen alá \citeauthor{laarhoven} wie folgt:
73 73
diff --git a/edit-lens/src/Control/Lens/Edit.lhs.tex b/edit-lens/src/Control/Lens/Edit.lhs.tex
new file mode 120000
index 0000000..33d3341
--- /dev/null
+++ b/edit-lens/src/Control/Lens/Edit.lhs.tex
@@ -0,0 +1 @@
Edit.lhs \ No newline at end of file
diff --git a/edit-lens/src/Control/Lens/Edit/ActionTree.lhs b/edit-lens/src/Control/Lens/Edit/ActionTree.lhs
new file mode 100644
index 0000000..6632dce
--- /dev/null
+++ b/edit-lens/src/Control/Lens/Edit/ActionTree.lhs
@@ -0,0 +1,204 @@
1\begin{comment}
2\begin{code}
3{-# LANGUAGE ScopedTypeVariables
4 , TypeApplications
5 , TypeFamilyDependencies
6 #-}
7
8module Control.Lens.Edit.ActionTree
9 ( Action(..)
10 , treeLens
11 ) where
12
13import Control.Edit
14import Control.Edit.String
15import Control.Edit.String.Affected
16import Control.Lens.Edit
17
18import Control.Lens
19
20import Numeric.Natural
21import Numeric.Interval (Interval, (...))
22import qualified Numeric.Interval as Int
23
24import Data.Compositions (Compositions)
25import qualified Data.Compositions as Comp
26
27import Data.Algorithm.Diff (Diff, getDiff)
28import qualified Data.Algorithm.Diff as Diff
29
30import Data.Sequence (Seq((:<|), (:|>)))
31import qualified Data.Sequence as Seq
32import Data.Set (Set)
33import qualified Data.Set as Set
34
35import Data.Monoid
36import Data.Function (on)
37import Data.Foldable (toList)
38import Data.Maybe (fromMaybe)
39
40import System.IO (Handle, hPutStrLn, IOMode(AppendMode), withFile)
41import System.IO.Unsafe
42\end{code}
43\end{comment}
44
45Das beschrieben Verfahren wurde prinzipiell agnostisch in Bezug auf die konkret gewählte Parser-Konstruktion gewählt.
46
47Hierfür wurden die benötigten Operationen auf der DFST-Wirkung und das in $\Lleftarrow$ verwendete Suchschema abstrakt als Typklasse angegeben:
48
49\begin{code}
50class Monoid action => Action action input output | action -> input, action -> output where
51\end{code}
52\begin{comment}
53\begin{code}
54 -- | Most operations of `Action` permit access to some underlying description of the parser (i.e. an automaton)
55 type ActionParam action = param | param -> action
56
57 -- | A full capture of the Parser-State (i.e. a state for a given automaton)
58 type ActionState action :: *
59
60 -- | `mempty` should be neutral under `(<>)`, `actionFail` should be absorptive
61 actionFail :: action
62
63 -- | Construct an @action@ from a single character of input
64 actionSingleInput :: ActionParam action -> input -> action
65 -- | Initial state of the parser
66 actionGroundState :: ActionParam action -> ActionState action
67 -- | Is a certain state acceptable as final?
68 actionStateFinal :: ActionParam action -> ActionState action -> Bool
69 -- | Run an @action@ (actually a binary tree thereof, use `Comp.composed` to extract the root) on a given state
70 actionState :: ActionParam action -> Compositions action -> ActionState action -> Maybe (ActionState action)
71 -- | What @output@ does running an @action@ on a given state produce?
72 actionProduces :: ActionParam action -> Compositions action -> ActionState action -> Seq output
73 -- | What @input@ does running an @action@ on a given state consume?
74 actionConsumes :: ActionParam action -> Compositions action -> Seq input
75
76 -- | Find a new string of @input@-symbols to travel between the given states while producing exactly the given @output@
77 --
78 -- @actionFindPath@ also has access to the remaining action to be run after it's new @input@ has been consumed.
79 -- This is necessary to further restrict the considered paths in such a way that the resulting run as a whole is acceptable in the sense of `actionStateFinal`.
80 actionFindPath :: ActionParam action
81 -> ActionState action -- ^ From
82 -> Seq output -- ^ New output to be produced
83 -> ActionState action -- ^ To
84 -> Compositions action -- ^ Suffix
85 -> Maybe (Seq input)
86\end{code}
87\end{comment}
88
89Das Verfahren kann nun auf andere Sorten von Parser angewendet werden, indem nur die oben aufgeführte \texttt{Action}-Typklasse implementiert wird:
90
91\begin{code}
92treeLens :: forall action input output.
93 ( Ord input, Ord output
94 , Show input, Show output
95 , Action action input output
96 , Show (ActionState action)
97 ) => ActionParam action -> EditLens (Compositions action) (StringEdits Natural input) (StringEdits Natural output)
98\end{code}
99\begin{comment}
100\begin{code}
101treeLens param = EditLens ground propR propL
102 where
103 ground :: Compositions action
104 ground = mempty
105
106 propR :: (Compositions action, StringEdits Natural input)
107 -> (Compositions action, StringEdits Natural output)
108 propR (c, SEFail) = (c, SEFail)
109 propR (c, StringEdits Seq.Empty) = (c, mempty)
110 propR (c, lEs@(StringEdits (es :> e)))
111 | Just final <- actionState param c' $ actionGroundState @action param
112 , actionStateFinal param final
113 = (c', rEs)
114 | otherwise
115 = (c, SEFail)
116 where
117 Just int = affected lEs
118 (cAffSuffix, cAffPrefix) = Comp.splitAt (Comp.length c - fromIntegral (Int.inf int)) c
119 (cSuffix, cPrefix) = Comp.splitAt (Comp.length c - (e ^. sePos . from enum)) c
120 cSuffix'
121 | Delete _ <- e
122 , Comp.length cSuffix > 0 = Comp.take (pred $ Comp.length cSuffix) cSuffix
123 | Insert _ nChar <- e = cSuffix <> Comp.singleton (actionSingleInput param nChar)
124 | otherwise = Comp.singleton actionFail
125 (c', _) = propR (cSuffix' <> cPrefix, StringEdits es)
126 (cAffSuffix', _) = Comp.splitAt (Comp.length c' - Comp.length cAffPrefix) c'
127 Just pFinal = actionState param cAffPrefix $ actionGroundState @action param
128 rEs = strDiff (actionProduces param cAffSuffix pFinal) (actionProduces param cAffSuffix' pFinal) & stringEdits . sePos . from enum +~ length (actionProduces param cAffPrefix $ actionGroundState @action param)
129
130 propL :: (Compositions action, StringEdits Natural output)
131 -> (Compositions action, StringEdits Natural input)
132 propL (c, StringEdits Seq.Empty) = (c, mempty)
133 propL (c, es) = fromMaybe (c, SEFail) $ do
134 -- Determine states @(iState, fState)@ at the boundary of the region affected by @es@
135 ((,) <$> Int.inf <*> Int.sup -> (minAff, maxAff)) <- affected es
136 trace (show (minAff, maxAff)) $ Just ()
137 let
138 prevTrans :: Natural -> Maybe ( Compositions action {- Run after chosen transition to accepting state -}
139 , (ActionState action, input, Seq output, ActionState action)
140 , Compositions action {- Run from `stInitial` up to chosen transition -}
141 )
142 -- ^ Given an index in the output, find the associated transition in @c@
143 prevTrans needle = do
144 let (after, before) = prevTrans' (c, mempty)
145 transSt <- actionState param before $ actionGroundState @action param
146 trace ("transSt = " ++ show transSt) $ Just ()
147 let (after', trans) = Comp.splitAt (pred $ Comp.length after) after
148 [inS] <- return . toList $ actionConsumes param trans
149 Just postTransSt <- return $ actionState param trans transSt
150 outSs <- return $ actionProduces param trans transSt
151 return (after', (transSt, inS, outSs, postTransSt), before)
152 where
153 -- | Move monoid summands from @after@ to @before@ until first transition of @after@ produces @needle@ or @after@ is a singleton
154 prevTrans' :: (Compositions action, Compositions action)
155 -> (Compositions action, Compositions action)
156 prevTrans' (after, before)
157 | producedNext > needle = (after, before)
158 | Comp.length after == 1 = (after, before)
159 | otherwise = prevTrans' (after', before')
160 where
161 producedNext = fromIntegral . Seq.length . traceShowId . actionProduces param before' $ actionGroundState @action param
162 (after', nextTrans) = Comp.splitAt (pred $ Comp.length after) after
163 before' = nextTrans `mappend` before
164 (_, (iState, _, _, _), prefix) <- prevTrans minAff
165 trace (show (iState, Comp.length prefix)) $ Just ()
166 (suffix, (pfState, _, _, fState), _) <- prevTrans maxAff
167 trace (show (pfState, fState, Comp.length suffix)) $ Just ()
168
169 newOut <- actionProduces param c (actionGroundState @action param) `apply` es
170 let affNewOut = (\s -> Seq.take (Seq.length s - Seq.length (actionProduces param suffix fState)) s) $ Seq.drop (Seq.length . actionProduces param prefix $ actionGroundState @action param) newOut
171 trace (show (iState, fState, affNewOut)) $ Just ()
172
173 newIn <- actionFindPath param iState affNewOut fState suffix
174
175 let oldIn = actionConsumes param . Comp.drop (Comp.length suffix) $ Comp.take (Comp.length c - Comp.length prefix) c
176 inDiff = oldIn `strDiff` newIn
177 diffOffset = fromIntegral . Seq.length $ actionConsumes param prefix
178 inDiff' = inDiff & stringEdits . sePos +~ diffOffset
179
180 trace (show (oldIn, newIn, inDiff')) $ Just ()
181
182 let affComp = Comp.fromList $ actionSingleInput param <$> toList newIn
183
184 return (suffix <> affComp <> prefix, inDiff')
185
186
187strDiff :: forall sym pos. (Eq sym, Integral pos) => Seq sym -> Seq sym -> StringEdits pos sym
188-- ^ @strDiff a b@ calculates a set of edits, which, when applied to @a@, produce @b@
189strDiff a b = snd . foldl toEdit (0, mempty) $ (getDiff `on` toList) a b
190 where
191 toEdit :: (pos, StringEdits pos sym) -> Diff sym -> (pos, StringEdits pos sym)
192 toEdit (n, es) (Diff.Both _ _) = (succ n, es)
193 toEdit (n, es) (Diff.First _ ) = (n, delete n <> es)
194 toEdit (n, es) (Diff.Second c) = (succ n, insert n c <> es)
195
196trace :: String -> a -> a
197{-# NOINLINE trace #-}
198trace str y = flip seq y . unsafePerformIO . withFile "lens.log" AppendMode $ \h ->
199 hPutStrLn h str
200
201traceShowId :: Show a => a -> a
202traceShowId x = trace (show x) x
203\end{code}
204\end{comment}
diff --git a/edit-lens/src/Control/Lens/Edit/ActionTree.lhs.tex b/edit-lens/src/Control/Lens/Edit/ActionTree.lhs.tex
new file mode 120000
index 0000000..6e3c68c
--- /dev/null
+++ b/edit-lens/src/Control/Lens/Edit/ActionTree.lhs.tex
@@ -0,0 +1 @@
ActionTree.lhs \ No newline at end of file