diff options
Diffstat (limited to 'edit-lens/src/Control')
| 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 | |||
