summaryrefslogtreecommitdiff
path: root/edit-lens/src/Control/FST.lhs
diff options
context:
space:
mode:
Diffstat (limited to 'edit-lens/src/Control/FST.lhs')
-rw-r--r--edit-lens/src/Control/FST.lhs24
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
35import Text.PrettyPrint.Leijen (Pretty(..)) 35import Text.PrettyPrint.Leijen (Pretty(..))
36import qualified Text.PrettyPrint.Leijen as PP 36import qualified Text.PrettyPrint.Leijen as PP
37 37
38import Debug.Trace
39
40data FST state input output = FST 38data 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
46instance (Show state, Show input, Show output) => Pretty (FST state input output) where 44instance (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
62wordFST :: forall input output. Seq output -> FST Natural input output 62wordFST :: 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
64wordFST outs = FST 64wordFST 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
77productFST :: 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 77productFST :: 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.
81productFST fst1 fst2 = FST 83productFST 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
101restrictFST :: forall state input output. (Ord state, Ord input, Ord output) => Set state -> FST state input output -> FST state input output 103restrictFST :: 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
102restrictFST sts FST{..} = FST 105restrictFST 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
132invertFST :: FST state input output -> Seq output -> Set (Seq input)
133invertFST = undefined
134\end{code} 134\end{code}