From b8c5ae5af83015c1c0671cb9c5360d3e4b6df4e0 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 21 May 2018 21:36:57 +0200
Subject: FST operations
---
edit-lens/src/Control/DFST.lhs | 2 +-
edit-lens/src/Control/FST.lhs | 114 ++++++++++++++++++++++++++++++++++++++++-
2 files changed, 113 insertions(+), 3 deletions(-)
(limited to 'edit-lens/src/Control')
diff --git a/edit-lens/src/Control/DFST.lhs b/edit-lens/src/Control/DFST.lhs
index 94df533..9bd1629 100644
--- a/edit-lens/src/Control/DFST.lhs
+++ b/edit-lens/src/Control/DFST.lhs
@@ -46,7 +46,7 @@ toFST :: forall state input output. (Ord state, Ord input, Ord output) => DFST s
toFST DFST{..} = flip execState initialFST $ forM_ (Map.toList stTransition) handleTransition
where
initialFST = FST
- { stInitial = (stInitial, Nothing)
+ { stInitial = Set.singleton (stInitial, Nothing)
, stTransition = Map.empty
, stAccept = Set.map (, Nothing) stAccept
}
diff --git a/edit-lens/src/Control/FST.lhs b/edit-lens/src/Control/FST.lhs
index d3c8ca9..d37072f 100644
--- a/edit-lens/src/Control/FST.lhs
+++ b/edit-lens/src/Control/FST.lhs
@@ -1,24 +1,134 @@
\begin{code}
+{-# LANGUAGE ScopedTypeVariables
+#-}
{-|
Description: Finite state transducers with epsilon-transitions
-}
module Control.FST
( FST(..)
+ -- * Constructing FSTs
+ , wordFST
+ -- * Operations on FSTs
+ , productFST, invertFST, restrictFST
+ -- * Debugging Utilities
+ , liveFST
) where
-import Data.Map.Strict (Map)
+import Data.Map.Strict (Map, (!?))
import qualified Data.Map.Strict as Map
import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+
+import Data.Maybe (mapMaybe, fromMaybe)
+
+import Numeric.Natural
import Control.Lens.TH
+import Control.Monad.State.Strict
+
+import Text.PrettyPrint.Leijen (Pretty(..))
+import qualified Text.PrettyPrint.Leijen as PP
+
+import Debug.Trace
+
data FST state input output = FST
- { stInitial :: state
+ { stInitial :: Set state
, stTransition :: Map (state, Maybe input) (Set (state, Maybe output))
, stAccept :: Set state
+ } deriving (Show, Read)
+
+instance (Show state, Show input, Show output) => Pretty (FST state input output) where
+ pretty FST{..} = PP.vsep
+ [ PP.text "Initial states:" PP.</> PP.hang 2 (PP.list . map (PP.text . show) $ Set.toAscList stInitial)
+ , PP.text "State transitions:" PP.<$> PP.indent 2 (PP.vsep
+ [ PP.text (show st)
+ PP.<+> (PP.text "-" PP.<> PP.tupled [label inS, label outS] PP.<> PP.text "→")
+ PP.<+> PP.text (show st')
+ | ((st, inS), to) <- Map.toList stTransition
+ , (st', outS) <- Set.toAscList to
+ ])
+ , PP.text "Accepting states:" PP.</> PP.hang 2 (PP.list . map (PP.text . show) $ Set.toAscList stAccept)
+ ]
+ where
+ label :: Show a => Maybe a -> PP.Doc
+ label = maybe (PP.text "ɛ") (PP.text . show)
+
+wordFST :: forall input output. Seq output -> FST Natural input output
+-- ^ @wordFST str@ is the minimal FST generating @str@ as output when given no input
+wordFST outs = FST
+ { stInitial = Set.singleton 0
+ , stAccept = Set.singleton l
+ , stTransition = Map.fromSet next states
}
+ where
+ l :: Natural
+ l = fromIntegral $ Seq.length outs
+ states :: Set (Natural, Maybe input)
+ states = Set.fromDistinctAscList [ (n, Nothing) | n <- [0..pred l] ]
+ next :: (Natural, Maybe input) -> Set (Natural, Maybe output)
+ next (i, _) = Set.singleton (succ i, Just . Seq.index outs $ fromIntegral i)
+
+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
+-- ^ Cartesian product on states, logical conjunction on transitions and state-properties (initial and accept)
+--
+-- This is most intuitive when thought of as the component-wise product of weighted FSTs with weights in the boolean semiring.
+productFST fst1 fst2 = FST
+ { stInitial = stInitial fst1 `setProduct` stInitial fst2
+ , stAccept = stAccept fst1 `setProduct` stAccept fst2
+ , stTransition = Map.fromSet transitions . Set.fromList . mapMaybe filterTransition . Set.toAscList $ Map.keysSet (stTransition fst1) `setProduct` Map.keysSet (stTransition fst2)
+ }
+ where
+ setProduct :: forall a b. Set a -> Set b -> Set (a, b)
+ setProduct as bs = Set.fromDistinctAscList $ (,) <$> Set.toAscList as <*> Set.toAscList bs
+ filterTransition :: forall label. Eq label => ((state1, Maybe label), (state2, Maybe label)) -> Maybe ((state1, state2), Maybe label)
+ filterTransition ((st1, Nothing ), (st2, in2 )) = Just ((st1, st2), in2)
+ filterTransition ((st1, in1 ), (st2, Nothing )) = Just ((st1, st2), in1)
+ filterTransition ((st1, Just in1), (st2, Just in2))
+ | in1 == in2 = Just ((st1, st2), Just in1)
+ | otherwise = Nothing
+ transitions :: ((state1, state2), Maybe input) -> Set ((state1, state2), Maybe output)
+ transitions ((st1, st2), inS) = Set.fromList . mapMaybe filterTransition . Set.toAscList $ out1 `setProduct` out2
+ where
+ out1 = (fromMaybe Set.empty $ stTransition fst1 !? (st1, inS)) `Set.union` (fromMaybe Set.empty $ stTransition fst1 !? (st1, Nothing))
+ out2 = (fromMaybe Set.empty $ stTransition fst2 !? (st2, inS)) `Set.union` (fromMaybe Set.empty $ stTransition fst2 !? (st2, Nothing))
+
+restrictFST :: forall state input output. (Ord state, Ord input, Ord output) => Set state -> FST state input output -> FST state input output
+restrictFST sts FST{..} = FST
+ { stInitial = stInitial `Set.intersection` sts
+ , stAccept = stAccept `Set.intersection` sts
+ , stTransition = Map.mapMaybeWithKey restrictTransition stTransition
+ }
+ where
+ restrictTransition :: (state, Maybe input) -> Set (state, Maybe output) -> Maybe (Set (state, Maybe output))
+ restrictTransition (st, _) tos = tos' <$ guard (st `Set.member` sts)
+ where
+ tos' = Set.filter (\(st', _) -> st' `Set.member` sts) tos
+
+
+liveFST :: forall state input output. (Ord state, Ord input, Ord output, Show state) => FST state input output -> Set state
+-- ^ Compute the set of "live" states (with no particular complexity)
+--
+-- A state is "live" iff there is a path from it to an accepting state and a path from an initial state to it
+liveFST fst@FST{..} = flip execState Set.empty $ mapM_ (depthSearch Set.empty) stInitial
+ where
+ stTransition' :: Map state (Set state)
+ stTransition' = Map.map (Set.map $ \(st, _) -> st) $ Map.mapKeysWith Set.union (\(st, _) -> st) stTransition
+ depthSearch :: Set state -> state -> State (Set state) ()
+ depthSearch acc curr = do
+ let acc' = Set.insert curr acc
+ next = fromMaybe Set.empty $ stTransition' !? curr
+ alreadyLive <- get
+ when (not . Set.null $ Set.insert curr next `Set.intersection` Set.union stAccept alreadyLive) $
+ modify $ Set.union acc'
+ mapM_ (depthSearch acc') $ next `Set.difference` alreadyLive
+
+
+invertFST :: FST state input output -> Seq output -> Set (Seq input)
+invertFST = undefined
\end{code}
--
cgit v1.2.3