diff options
Diffstat (limited to 'edit-lens/src')
l--------- | edit-lens/src/Control/DFST.lhs.tex | 1 | ||||
-rw-r--r-- | edit-lens/src/Control/DFST/Lens.lhs | 405 | ||||
l--------- | edit-lens/src/Control/DFST/Lens.lhs.tex | 1 | ||||
-rw-r--r-- | edit-lens/src/Control/Edit.lhs | 2 | ||||
l--------- | edit-lens/src/Control/Edit.lhs.tex | 1 | ||||
-rw-r--r-- | edit-lens/src/Control/Edit/String.lhs | 120 | ||||
l--------- | edit-lens/src/Control/Edit/String.lhs.tex | 1 | ||||
-rw-r--r-- | edit-lens/src/Control/Edit/String/Affected.lhs | 73 | ||||
l--------- | edit-lens/src/Control/Edit/String/Affected.lhs.tex | 1 | ||||
-rw-r--r-- | edit-lens/src/Control/FST.lhs | 22 | ||||
l--------- | edit-lens/src/Control/FST.lhs.tex | 1 | ||||
-rw-r--r-- | edit-lens/src/Control/Lens/Edit.lhs | 6 | ||||
l--------- | edit-lens/src/Control/Lens/Edit.lhs.tex | 1 | ||||
-rw-r--r-- | edit-lens/src/Control/Lens/Edit/ActionTree.lhs | 204 | ||||
l--------- | edit-lens/src/Control/Lens/Edit/ActionTree.lhs.tex | 1 |
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 | ||
9 | module Control.DFST.Lens | 9 | module 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 | |||
20 | import Control.FST hiding (stInitial, stTransition, stAccept) | 18 | import Control.FST hiding (stInitial, stTransition, stAccept) |
21 | import qualified Control.FST as FST (stInitial, stTransition, stAccept, step) | 19 | import qualified Control.FST as FST (stInitial, stTransition, stAccept, step) |
22 | import Control.Lens.Edit | 20 | import Control.Lens.Edit |
21 | import Control.Lens.Edit.ActionTree | ||
23 | import Control.Lens | 22 | import Control.Lens |
24 | import Control.Lens.TH | 23 | import Control.Lens.TH |
25 | import Control.Edit | 24 | import Control.Edit |
25 | import Control.Edit.String | ||
26 | import Control.Edit.String.Affected | ||
26 | 27 | ||
27 | import Control.Monad | 28 | import 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] | 69 | Wir 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. |
69 | Wir 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} | ||
72 | data 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@ | ||
80 | makeLenses ''StringEdit | ||
81 | \end{code} | ||
82 | |||
83 | Atomare edits werden, als Liste, zu edits komponiert. | ||
84 | Wir führen einen speziellen edit ein, der nicht-Anwendbarkeit der edits repräsentiert: | ||
85 | \begin{code} | ||
86 | data StringEdits pos char = StringEdits (Seq (StringEdit pos char)) | ||
87 | | SEFail | ||
88 | deriving (Eq, Ord, Show, Read) | ||
89 | |||
90 | makePrisms ''StringEdits | ||
91 | |||
92 | stringEdits :: 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} | ||
98 | stringEdits = _StringEdits . traverse | ||
99 | |||
100 | insert :: pos -> char -> StringEdits pos char | ||
101 | insert n c = StringEdits . Seq.singleton $ Insert n c | ||
102 | |||
103 | delete :: pos -> StringEdits pos char | ||
104 | delete n = StringEdits . Seq.singleton $ Delete n | ||
105 | |||
106 | replace :: Eq pos => pos -> char -> StringEdits pos char | ||
107 | replace n c = insert n c <> delete n | ||
108 | |||
109 | -- | Rudimentarily optimize edit composition | ||
110 | instance 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 | |||
125 | Da 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} | ||
127 | instance 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 | |||
154 | Wir 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. | ||
155 | Wir annotieren Wirkungen zudem mit dem konsumierten String. | 70 | Wir annotieren Wirkungen zudem mit dem konsumierten String. |
156 | Diese Wirkungen bilden einen Monoiden analog zu Endomorphismen, wobei die Resultat-Strings concateniert werden. | 71 | Diese 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} |
180 | dfstAction :: forall state input output. (Finite state, Ord state, Ord input) => DFST state input output -> input -> DFSTAction state input output | 109 | dfstAction :: 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} | ||
185 | dfstAction dfst (Seq.singleton -> dfstaConsumes) = DFSTAction{..} | 111 | dfstAction 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 | ||
195 | Wir halten im Komplement der edit-lens einen Cache der monoidalen Summen aller kontinuirlichen Teillisten. | 121 | Wir 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} |
198 | type DFSTComplement state input output = Compositions (DFSTAction state input output) | 124 | type DFSTComplement state input output = Compositions (DFSTAction state input output) |
199 | \end{code} | 125 | \end{code} |
200 | 126 | ||
127 | Wir 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} |
202 | runDFSTAction' :: DFSTComplement state input output -> state -> (Seq output, Maybe state) | 152 | runDFSTAction' :: DFSTComplement state input output -> state -> (Seq output, Maybe state) |
203 | runDFSTAction' = runDFSTAction . Comp.composed | 153 | runDFSTAction' = runDFSTAction . Comp.composed |
@@ -208,6 +158,7 @@ dfstaConsumes' = dfstaConsumes . Comp.composed | |||
208 | dfstaProduces :: DFSTComplement state input output -> state -> Seq output | 158 | dfstaProduces :: DFSTComplement state input output -> state -> Seq output |
209 | dfstaProduces = fmap fst . runDFSTAction' | 159 | dfstaProduces = fmap fst . runDFSTAction' |
210 | \end{code} | 160 | \end{code} |
161 | \end{comment} | ||
211 | 162 | ||
212 | Fü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. | 163 | Fü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} |
231 | type LState state input output = (Natural, (state, Maybe (input, Natural))) | 182 | type LState state input output = (Natural, (state, Maybe (input, Natural))) |
183 | |||
184 | instance (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} |
239 | dfstLens dfst@DFST{..} = EditLens ground propR propL | 239 | dfstLens = 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 | |||
350 | strDiff :: 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@ | ||
352 | strDiff 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 |
360 | bfs :: forall state transition. Ord state | 242 | bfs :: 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 |
364 | bfs outgoing predicate | 246 | bfs 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 | ||
384 | Um 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 |
385 | Das 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 |
388 | affected :: 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} | ||
398 | affected SEFail = Nothing | ||
399 | affected (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 | |||
426 | trace :: String -> a -> a | ||
427 | {-# NOINLINE trace #-} | ||
428 | trace str y = flip seq y . unsafePerformIO . withFile "lens.log" AppendMode $ \h -> | ||
429 | hPutStrLn h str | ||
430 | |||
431 | traceShowId :: Show a => a -> a | ||
432 | traceShowId 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 | ||
9 | Um 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] |
10 | Ein 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: | 12 | Ein 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 | |||
6 | module Control.Edit.String | ||
7 | ( StringEdit(..), sePos, seInsertion | ||
8 | , StringEdits(..), _StringEdits, _SEFail, stringEdits | ||
9 | , insert, delete, replace | ||
10 | ) where | ||
11 | |||
12 | import Control.Lens | ||
13 | import Control.Lens.TH | ||
14 | |||
15 | import Control.Edit | ||
16 | |||
17 | import Numeric.Natural | ||
18 | |||
19 | import Data.Sequence (Seq((:<|), (:|>))) | ||
20 | import qualified Data.Sequence as Seq | ||
21 | |||
22 | import Data.Monoid | ||
23 | \end{code} | ||
24 | \end{comment} | ||
25 | |||
26 | \begin{defn}[Atomare edits of strings] | ||
27 | Wir 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} | ||
30 | data 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@ | ||
38 | makeLenses ''StringEdit | ||
39 | \end{code} | ||
40 | |||
41 | Atomare edits werden, als Liste, zu edits komponiert. | ||
42 | Wir führen einen speziellen edit ein, der nicht-Anwendbarkeit der edits repräsentiert: | ||
43 | \begin{code} | ||
44 | data StringEdits pos char = StringEdits (Seq (StringEdit pos char)) | ||
45 | | SEFail | ||
46 | deriving (Eq, Ord, Show, Read) | ||
47 | |||
48 | makePrisms ''StringEdits | ||
49 | |||
50 | stringEdits :: 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} | ||
56 | stringEdits = _StringEdits . traverse | ||
57 | |||
58 | insert :: pos -> char -> StringEdits pos char | ||
59 | insert n c = StringEdits . Seq.singleton $ Insert n c | ||
60 | |||
61 | delete :: pos -> StringEdits pos char | ||
62 | delete n = StringEdits . Seq.singleton $ Delete n | ||
63 | |||
64 | replace :: Eq pos => pos -> char -> StringEdits pos char | ||
65 | replace n c = insert n c <> delete n | ||
66 | |||
67 | -- | Rudimentarily optimize edit composition | ||
68 | instance 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 | |||
83 | Da 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} | ||
85 | instance 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} | ||
3 | module Control.Edit.String.Affected | ||
4 | ( affected | ||
5 | ) where | ||
6 | |||
7 | import Control.Lens | ||
8 | import Control.Lens.TH | ||
9 | |||
10 | import Control.Edit | ||
11 | import Control.Edit.String | ||
12 | |||
13 | import Numeric.Natural | ||
14 | import Numeric.Interval (Interval, (...)) | ||
15 | import qualified Numeric.Interval as Int | ||
16 | |||
17 | import Data.Sequence (Seq((:<|), (:|>))) | ||
18 | import qualified Data.Sequence as Seq | ||
19 | |||
20 | import Data.Map.Lazy (Map) | ||
21 | import qualified Data.Map.Lazy as Map | ||
22 | |||
23 | import Data.Monoid | ||
24 | |||
25 | import Control.Monad | ||
26 | |||
27 | import Data.Maybe (fromMaybe, maybeToList, listToMaybe, catMaybes, isNothing, isJust, mapMaybe) | ||
28 | \end{code} | ||
29 | \end{comment} | ||
30 | |||
31 | Um 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. | ||
32 | Das 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} | ||
35 | affected :: 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} | ||
45 | affected SEFail = Nothing | ||
46 | affected (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] |
15 | Gegeben 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: | 15 | Gegeben 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] |
31 | Fü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: | 31 | Fü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 | ||
72 | Das einschlägige bestehende lens framework \cite{lens} konstruiert seine Linsen alá \citeauthor{laarhoven} wie folgt: | 72 | Das 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 | |||
8 | module Control.Lens.Edit.ActionTree | ||
9 | ( Action(..) | ||
10 | , treeLens | ||
11 | ) where | ||
12 | |||
13 | import Control.Edit | ||
14 | import Control.Edit.String | ||
15 | import Control.Edit.String.Affected | ||
16 | import Control.Lens.Edit | ||
17 | |||
18 | import Control.Lens | ||
19 | |||
20 | import Numeric.Natural | ||
21 | import Numeric.Interval (Interval, (...)) | ||
22 | import qualified Numeric.Interval as Int | ||
23 | |||
24 | import Data.Compositions (Compositions) | ||
25 | import qualified Data.Compositions as Comp | ||
26 | |||
27 | import Data.Algorithm.Diff (Diff, getDiff) | ||
28 | import qualified Data.Algorithm.Diff as Diff | ||
29 | |||
30 | import Data.Sequence (Seq((:<|), (:|>))) | ||
31 | import qualified Data.Sequence as Seq | ||
32 | import Data.Set (Set) | ||
33 | import qualified Data.Set as Set | ||
34 | |||
35 | import Data.Monoid | ||
36 | import Data.Function (on) | ||
37 | import Data.Foldable (toList) | ||
38 | import Data.Maybe (fromMaybe) | ||
39 | |||
40 | import System.IO (Handle, hPutStrLn, IOMode(AppendMode), withFile) | ||
41 | import System.IO.Unsafe | ||
42 | \end{code} | ||
43 | \end{comment} | ||
44 | |||
45 | Das beschrieben Verfahren wurde prinzipiell agnostisch in Bezug auf die konkret gewählte Parser-Konstruktion gewählt. | ||
46 | |||
47 | Hierfür wurden die benötigten Operationen auf der DFST-Wirkung und das in $\Lleftarrow$ verwendete Suchschema abstrakt als Typklasse angegeben: | ||
48 | |||
49 | \begin{code} | ||
50 | class 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 | |||
89 | Das 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} | ||
92 | treeLens :: 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} | ||
101 | treeLens 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 | |||
187 | strDiff :: 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@ | ||
189 | strDiff 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 | |||
196 | trace :: String -> a -> a | ||
197 | {-# NOINLINE trace #-} | ||
198 | trace str y = flip seq y . unsafePerformIO . withFile "lens.log" AppendMode $ \h -> | ||
199 | hPutStrLn h str | ||
200 | |||
201 | traceShowId :: Show a => a -> a | ||
202 | traceShowId 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 | |||