diff options
Diffstat (limited to 'edit-lens/src/Control/FST.lhs')
-rw-r--r-- | edit-lens/src/Control/FST.lhs | 24 |
1 files changed, 12 insertions, 12 deletions
diff --git a/edit-lens/src/Control/FST.lhs b/edit-lens/src/Control/FST.lhs index d37072f..4f1f364 100644 --- a/edit-lens/src/Control/FST.lhs +++ b/edit-lens/src/Control/FST.lhs | |||
@@ -10,7 +10,7 @@ module Control.FST | |||
10 | -- * Constructing FSTs | 10 | -- * Constructing FSTs |
11 | , wordFST | 11 | , wordFST |
12 | -- * Operations on FSTs | 12 | -- * Operations on FSTs |
13 | , productFST, invertFST, restrictFST | 13 | , productFST, restrictFST |
14 | -- * Debugging Utilities | 14 | -- * Debugging Utilities |
15 | , liveFST | 15 | , liveFST |
16 | ) where | 16 | ) where |
@@ -35,8 +35,6 @@ import Control.Monad.State.Strict | |||
35 | import Text.PrettyPrint.Leijen (Pretty(..)) | 35 | import Text.PrettyPrint.Leijen (Pretty(..)) |
36 | import qualified Text.PrettyPrint.Leijen as PP | 36 | import qualified Text.PrettyPrint.Leijen as PP |
37 | 37 | ||
38 | import Debug.Trace | ||
39 | |||
40 | data FST state input output = FST | 38 | data FST state input output = FST |
41 | { stInitial :: Set state | 39 | { stInitial :: Set state |
42 | , stTransition :: Map (state, Maybe input) (Set (state, Maybe output)) | 40 | , stTransition :: Map (state, Maybe input) (Set (state, Maybe output)) |
@@ -45,7 +43,7 @@ data FST state input output = FST | |||
45 | 43 | ||
46 | instance (Show state, Show input, Show output) => Pretty (FST state input output) where | 44 | instance (Show state, Show input, Show output) => Pretty (FST state input output) where |
47 | pretty FST{..} = PP.vsep | 45 | pretty FST{..} = PP.vsep |
48 | [ PP.text "Initial states:" PP.</> PP.hang 2 (PP.list . map (PP.text . show) $ Set.toAscList stInitial) | 46 | [ PP.text "Initial states:" PP.</> PP.hang 2 (list . map (PP.text . show) $ Set.toAscList stInitial) |
49 | , PP.text "State transitions:" PP.<$> PP.indent 2 (PP.vsep | 47 | , PP.text "State transitions:" PP.<$> PP.indent 2 (PP.vsep |
50 | [ PP.text (show st) | 48 | [ PP.text (show st) |
51 | PP.<+> (PP.text "-" PP.<> PP.tupled [label inS, label outS] PP.<> PP.text "→") | 49 | PP.<+> (PP.text "-" PP.<> PP.tupled [label inS, label outS] PP.<> PP.text "→") |
@@ -53,14 +51,16 @@ instance (Show state, Show input, Show output) => Pretty (FST state input output | |||
53 | | ((st, inS), to) <- Map.toList stTransition | 51 | | ((st, inS), to) <- Map.toList stTransition |
54 | , (st', outS) <- Set.toAscList to | 52 | , (st', outS) <- Set.toAscList to |
55 | ]) | 53 | ]) |
56 | , PP.text "Accepting states:" PP.</> PP.hang 2 (PP.list . map (PP.text . show) $ Set.toAscList stAccept) | 54 | , PP.text "Accepting states:" PP.</> PP.hang 2 (list . map (PP.text . show) $ Set.toAscList stAccept) |
57 | ] | 55 | ] |
58 | where | 56 | where |
59 | label :: Show a => Maybe a -> PP.Doc | 57 | label :: Show a => Maybe a -> PP.Doc |
60 | label = maybe (PP.text "ɛ") (PP.text . show) | 58 | label = maybe (PP.text "ɛ") (PP.text . show) |
59 | list :: [PP.Doc] -> PP.Doc | ||
60 | list = PP.encloseSep (PP.lbracket PP.<> PP.space) (PP.space PP.<> PP.rbracket) (PP.comma PP.<> PP.space) | ||
61 | 61 | ||
62 | wordFST :: forall input output. Seq output -> FST Natural input output | 62 | wordFST :: forall input output. Seq output -> FST Natural input output |
63 | -- ^ @wordFST str@ is the minimal FST generating @str@ as output when given no input | 63 | -- ^ @wordFST str@ is the linear FST generating @str@ as output when given no input |
64 | wordFST outs = FST | 64 | wordFST outs = FST |
65 | { stInitial = Set.singleton 0 | 65 | { stInitial = Set.singleton 0 |
66 | , stAccept = Set.singleton l | 66 | , stAccept = Set.singleton l |
@@ -77,7 +77,9 @@ wordFST outs = FST | |||
77 | productFST :: forall state1 state2 input output. (Ord state1, Ord state2, Ord input, Ord output) => FST state1 input output -> FST state2 input output -> FST (state1, state2) input output | 77 | productFST :: forall state1 state2 input output. (Ord state1, Ord state2, Ord input, Ord output) => FST state1 input output -> FST state2 input output -> FST (state1, state2) input output |
78 | -- ^ Cartesian product on states, logical conjunction on transitions and state-properties (initial and accept) | 78 | -- ^ Cartesian product on states, logical conjunction on transitions and state-properties (initial and accept) |
79 | -- | 79 | -- |
80 | -- This is most intuitive when thought of as the component-wise product of weighted FSTs with weights in the boolean semiring. | 80 | -- This is the "natural" (that is component-wise) product when considering FSTs to be weighted in the boolean semiring. |
81 | -- | ||
82 | -- Intuitively this corresponds to running both FSTs at the same time requiring them to produce the same output and "agree" (epsilon agreeing with every character) on their input. | ||
81 | productFST fst1 fst2 = FST | 83 | productFST fst1 fst2 = FST |
82 | { stInitial = stInitial fst1 `setProduct` stInitial fst2 | 84 | { stInitial = stInitial fst1 `setProduct` stInitial fst2 |
83 | , stAccept = stAccept fst1 `setProduct` stAccept fst2 | 85 | , stAccept = stAccept fst1 `setProduct` stAccept fst2 |
@@ -99,6 +101,7 @@ productFST fst1 fst2 = FST | |||
99 | out2 = (fromMaybe Set.empty $ stTransition fst2 !? (st2, inS)) `Set.union` (fromMaybe Set.empty $ stTransition fst2 !? (st2, Nothing)) | 101 | out2 = (fromMaybe Set.empty $ stTransition fst2 !? (st2, inS)) `Set.union` (fromMaybe Set.empty $ stTransition fst2 !? (st2, Nothing)) |
100 | 102 | ||
101 | restrictFST :: forall state input output. (Ord state, Ord input, Ord output) => Set state -> FST state input output -> FST state input output | 103 | restrictFST :: forall state input output. (Ord state, Ord input, Ord output) => Set state -> FST state input output -> FST state input output |
104 | -- ^ @restrictFST states fst@ removes from @fst@ all states not in @states@ including transitions leading to or originating from them | ||
102 | restrictFST sts FST{..} = FST | 105 | restrictFST sts FST{..} = FST |
103 | { stInitial = stInitial `Set.intersection` sts | 106 | { stInitial = stInitial `Set.intersection` sts |
104 | , stAccept = stAccept `Set.intersection` sts | 107 | , stAccept = stAccept `Set.intersection` sts |
@@ -124,11 +127,8 @@ liveFST fst@FST{..} = flip execState Set.empty $ mapM_ (depthSearch Set.empty) s | |||
124 | let acc' = Set.insert curr acc | 127 | let acc' = Set.insert curr acc |
125 | next = fromMaybe Set.empty $ stTransition' !? curr | 128 | next = fromMaybe Set.empty $ stTransition' !? curr |
126 | alreadyLive <- get | 129 | alreadyLive <- get |
127 | when (not . Set.null $ Set.insert curr next `Set.intersection` Set.union stAccept alreadyLive) $ | 130 | when (curr `Set.member` Set.union stAccept alreadyLive) $ |
128 | modify $ Set.union acc' | 131 | modify $ Set.union acc' |
132 | alreadyLive <- get | ||
129 | mapM_ (depthSearch acc') $ next `Set.difference` alreadyLive | 133 | mapM_ (depthSearch acc') $ next `Set.difference` alreadyLive |
130 | |||
131 | |||
132 | invertFST :: FST state input output -> Seq output -> Set (Seq input) | ||
133 | invertFST = undefined | ||
134 | \end{code} | 134 | \end{code} |