forked from GitHub/gf-core
Moved Graph and Relation stuff to separate modules. Added some QuickCheck properties for Relation. Improved relation datastructure and algorithms, making FA generation much faster.
This commit is contained in:
bringert
@@ -5,9 +5,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/14 16:08:35 $
|
||||
-- > CVS $Date: 2005/10/26 17:13:13 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- Approximates CFGs with finite state networks.
|
||||
-----------------------------------------------------------------------------
|
||||
@@ -24,6 +24,7 @@ import GF.Infra.Ident (Ident)
|
||||
import GF.Infra.Option (Options)
|
||||
|
||||
import GF.Speech.FiniteState
|
||||
import GF.Speech.Relation
|
||||
import GF.Speech.TransformCFG
|
||||
|
||||
cfgToFA :: Ident -- ^ Grammar name
|
||||
@@ -59,10 +60,10 @@ makeRegular g = groupProds $ concatMap trSet (mutRecCats True g)
|
||||
mutRecCats :: Bool -- ^ If true, all categories will be in some set.
|
||||
-- If false, only recursive categories will be included.
|
||||
-> CFRules -> [[Cat_]]
|
||||
mutRecCats incAll g = equivalenceClasses $ symmetricSubrelation $ transitiveClosure r'
|
||||
where r = nub [(c,c') | (_,rs) <- g, CFRule c ss _ <- rs, Cat c' <- ss]
|
||||
mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r
|
||||
where r = mkRel [(c,c') | (_,rs) <- g, CFRule c ss _ <- rs, Cat c' <- ss]
|
||||
allCats = map fst g
|
||||
r' = (if incAll then reflexiveClosure allCats else id) r
|
||||
refl = if incAll then reflexiveClosure_ allCats else reflexiveSubrelation
|
||||
|
||||
-- Convert a strongly regular grammar to a finite automaton.
|
||||
compileAutomaton :: Cat_ -- ^ Start category
|
||||
@@ -130,34 +131,3 @@ isLeftLinear :: Eq c => [c] -- ^ The categories to consider
|
||||
-> CFRule c n t -- ^ The rule to check for right-linearity
|
||||
-> Bool
|
||||
isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs
|
||||
|
||||
|
||||
--
|
||||
-- * Relations
|
||||
--
|
||||
|
||||
-- FIXME: these could use a more efficent data structures and algorithms.
|
||||
|
||||
type Rel a = [(a,a)]
|
||||
|
||||
isRelatedTo :: Eq a => Rel a -> a -> a -> Bool
|
||||
isRelatedTo r x y = (x,y) `elem` r
|
||||
|
||||
transitiveClosure :: Eq a => Rel a -> Rel a
|
||||
transitiveClosure r = fix (\r -> r `union` [ (x,w) | (x,y) <- r, (z,w) <- r, y == z ]) r
|
||||
|
||||
reflexiveClosure :: Eq a => [a] -- ^ The set over which the relation is defined.
|
||||
-> Rel a -> Rel a
|
||||
reflexiveClosure u r = [(x,x) | x <- u] `union` r
|
||||
|
||||
symmetricSubrelation :: Eq a => Rel a -> Rel a
|
||||
symmetricSubrelation r = [p | p@(x,y) <- r, (y,x) `elem` r]
|
||||
|
||||
-- | Get the equivalence classes from an equivalence relation. Since
|
||||
-- the relation is relexive, the set can be recoved from the relation.
|
||||
equivalenceClasses :: Eq a => Rel a -> [[a]]
|
||||
equivalenceClasses r = equivalenceClasses_ (nub (map fst r)) r
|
||||
where equivalenceClasses_ [] _ = []
|
||||
equivalenceClasses_ (x:xs) r = (x:ys):equivalenceClasses_ zs r
|
||||
where (ys,zs) = partition (isRelatedTo r x) xs
|
||||
|
||||
|
||||
@@ -5,9 +5,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/22 17:08:48 $
|
||||
-- > CVS $Date: 2005/10/26 17:13:13 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.13 $
|
||||
-- > CVS $Revision: 1.14 $
|
||||
--
|
||||
-- A simple finite state network module.
|
||||
-----------------------------------------------------------------------------
|
||||
@@ -25,6 +25,7 @@ import Data.List
|
||||
import Data.Maybe (catMaybes,fromJust)
|
||||
|
||||
import GF.Data.Utilities
|
||||
import GF.Speech.Graph
|
||||
import qualified GF.Visualization.Graphviz as Dot
|
||||
|
||||
type State = Int
|
||||
@@ -171,68 +172,3 @@ toGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed [] (map mkNode ns)
|
||||
++ if n `elem` f then [("style","bold")] else []
|
||||
mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
|
||||
|
||||
--
|
||||
-- * Graphs
|
||||
--
|
||||
|
||||
data Graph n a b = Graph [n] [Node n a] [Edge n b]
|
||||
deriving (Eq,Show)
|
||||
|
||||
type Node n a = (n,a)
|
||||
type Edge n b = (n,n,b)
|
||||
|
||||
type Incoming n a b = [(Node n a,[Edge n b])]
|
||||
type Outgoing n a b = [(Node n a,[Edge n b])]
|
||||
|
||||
newGraph :: [n] -> Graph n a b
|
||||
newGraph ns = Graph ns [] []
|
||||
|
||||
nodes :: Graph n a b -> [Node n a]
|
||||
nodes (Graph _ ns _) = ns
|
||||
|
||||
edges :: Graph n a b -> [Edge n b]
|
||||
edges (Graph _ _ es) = es
|
||||
|
||||
nmap :: (a -> c) -> Graph n a b -> Graph n c b
|
||||
nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
|
||||
|
||||
emap :: (b -> c) -> Graph n a b -> Graph n a c
|
||||
emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
|
||||
|
||||
newNode :: a -> Graph n a b -> (Graph n a b,n)
|
||||
newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
|
||||
|
||||
newEdge :: Edge n b -> Graph n a b -> Graph n a b
|
||||
newEdge e (Graph c ns es) = Graph c ns (e:es)
|
||||
|
||||
newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
|
||||
newEdges es' (Graph c ns es) = Graph c ns (es'++es)
|
||||
|
||||
-- | Get a list of all nodes and their incoming edges.
|
||||
incoming :: Ord n => Graph n a b -> Incoming n a b
|
||||
incoming = groupEdgesBy getTo
|
||||
|
||||
-- | Get a list of all nodes and their outgoing edges.
|
||||
outgoing :: Ord n => Graph n a b -> Outgoing n a b
|
||||
outgoing = groupEdgesBy getFrom
|
||||
|
||||
getOutgoing :: Eq n => Outgoing n a b -> n -> [Edge n b]
|
||||
getOutgoing out x = head [ es | ((y,_),es) <- out, x == y ]
|
||||
|
||||
groupEdgesBy :: (Ord n) => (Edge n b -> n) -> Graph n a b -> [(Node n a,[Edge n b])]
|
||||
groupEdgesBy h (Graph _ ns es) =
|
||||
snd $ mapAccumL f (sortBy (compareBy h) es) (sortBy (compareBy fst) ns)
|
||||
where f es' v@(n,_) = let (nes,es'') = span ((==n) . h) es' in (es'',(v,nes))
|
||||
|
||||
getFrom :: Edge n b -> n
|
||||
getFrom (f,_,_) = f
|
||||
|
||||
getTo :: Edge n b -> n
|
||||
getTo (_,t,_) = t
|
||||
|
||||
getLabel :: Edge n b -> b
|
||||
getLabel (_,_,l) = l
|
||||
|
||||
reverseGraph :: Graph n a b -> Graph n a b
|
||||
reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
|
||||
|
||||
|
||||
88
src/GF/Speech/Graph.hs
Normal file
88
src/GF/Speech/Graph.hs
Normal file
@@ -0,0 +1,88 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Graph
|
||||
-- Maintainer : BB
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/26 17:13:13 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-- A simple graph module.
|
||||
-----------------------------------------------------------------------------
|
||||
module GF.Speech.Graph ( Graph(..), Node, Edge, Incoming, Outgoing
|
||||
, newGraph, nodes, edges
|
||||
, nmap, emap, newNode, newEdge, newEdges
|
||||
, incoming, outgoing, getOutgoing
|
||||
, getFrom, getTo, getLabel
|
||||
, reverseGraph
|
||||
) where
|
||||
|
||||
import GF.Data.Utilities
|
||||
|
||||
import Data.List
|
||||
|
||||
data Graph n a b = Graph [n] [Node n a] [Edge n b]
|
||||
deriving (Eq,Show)
|
||||
|
||||
type Node n a = (n,a)
|
||||
type Edge n b = (n,n,b)
|
||||
|
||||
type Incoming n a b = [(Node n a,[Edge n b])]
|
||||
type Outgoing n a b = [(Node n a,[Edge n b])]
|
||||
|
||||
newGraph :: [n] -> Graph n a b
|
||||
newGraph ns = Graph ns [] []
|
||||
|
||||
nodes :: Graph n a b -> [Node n a]
|
||||
nodes (Graph _ ns _) = ns
|
||||
|
||||
edges :: Graph n a b -> [Edge n b]
|
||||
edges (Graph _ _ es) = es
|
||||
|
||||
nmap :: (a -> c) -> Graph n a b -> Graph n c b
|
||||
nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
|
||||
|
||||
emap :: (b -> c) -> Graph n a b -> Graph n a c
|
||||
emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
|
||||
|
||||
newNode :: a -> Graph n a b -> (Graph n a b,n)
|
||||
newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
|
||||
|
||||
newEdge :: Edge n b -> Graph n a b -> Graph n a b
|
||||
newEdge e (Graph c ns es) = Graph c ns (e:es)
|
||||
|
||||
newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
|
||||
newEdges es' (Graph c ns es) = Graph c ns (es'++es)
|
||||
|
||||
-- | Get a list of all nodes and their incoming edges.
|
||||
incoming :: Ord n => Graph n a b -> Incoming n a b
|
||||
incoming = groupEdgesBy getTo
|
||||
|
||||
-- | Get a list of all nodes and their outgoing edges.
|
||||
outgoing :: Ord n => Graph n a b -> Outgoing n a b
|
||||
outgoing = groupEdgesBy getFrom
|
||||
|
||||
-- | From a list of outgoing edges, get all edges
|
||||
-- starting at a given node.
|
||||
getOutgoing :: Eq n => Outgoing n a b -> n -> [Edge n b]
|
||||
getOutgoing out x = head [ es | ((y,_),es) <- out, x == y ]
|
||||
|
||||
groupEdgesBy :: (Ord n) => (Edge n b -> n) -> Graph n a b -> [(Node n a,[Edge n b])]
|
||||
groupEdgesBy h (Graph _ ns es) =
|
||||
snd $ mapAccumL f (sortBy (compareBy h) es) (sortBy (compareBy fst) ns)
|
||||
where f es' v@(n,_) = let (nes,es'') = span ((==n) . h) es' in (es'',(v,nes))
|
||||
|
||||
getFrom :: Edge n b -> n
|
||||
getFrom (f,_,_) = f
|
||||
|
||||
getTo :: Edge n b -> n
|
||||
getTo (_,t,_) = t
|
||||
|
||||
getLabel :: Edge n b -> b
|
||||
getLabel (_,_,l) = l
|
||||
|
||||
reverseGraph :: Graph n a b -> Graph n a b
|
||||
reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
|
||||
|
||||
124
src/GF/Speech/Relation.hs
Normal file
124
src/GF/Speech/Relation.hs
Normal file
@@ -0,0 +1,124 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Relation
|
||||
-- Maintainer : BB
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/26 17:13:13 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-- A simple module for relations.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Speech.Relation (Rel, mkRel
|
||||
, isRelatedTo
|
||||
, transitiveClosure
|
||||
, reflexiveClosure, reflexiveClosure_
|
||||
, symmetricClosure
|
||||
, symmetricSubrelation, reflexiveSubrelation
|
||||
, equivalenceClasses
|
||||
, isTransitive, isReflexive, isSymmetric
|
||||
, isEquivalence,
|
||||
, isSubRelationOf) where
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import GF.Data.Utilities
|
||||
|
||||
type Rel a = Map a (Set a)
|
||||
|
||||
-- | Creates a relation from a list of related pairs.
|
||||
mkRel :: Ord a => [(a,a)] -> Rel a
|
||||
mkRel ps = relates ps Map.empty
|
||||
|
||||
relToList :: Rel a -> [(a,a)]
|
||||
relToList r = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys ]
|
||||
|
||||
-- | Add a pair to the relation.
|
||||
relate :: Ord a => a -> a -> Rel a -> Rel a
|
||||
relate x y r = Map.insertWith Set.union x (Set.singleton y) r
|
||||
|
||||
-- | Add a list of pairs to the relation.
|
||||
relates :: Ord a => [(a,a)] -> Rel a -> Rel a
|
||||
relates ps r = foldl (\r' (x,y) -> relate x y r') r ps
|
||||
|
||||
-- | Checks if an element is related to another.
|
||||
isRelatedTo :: Ord a => Rel a -> a -> a -> Bool
|
||||
isRelatedTo r x y = maybe False (y `Set.member`) (Map.lookup x r)
|
||||
|
||||
-- | Get the set of elements to which a given element is related.
|
||||
allRelated :: Ord a => Rel a -> a -> Set a
|
||||
allRelated r x = fromMaybe Set.empty (Map.lookup x r)
|
||||
|
||||
-- | Get all elements in the relation.
|
||||
domain :: Ord a => Rel a -> Set a
|
||||
domain r = foldl Set.union (Map.keysSet r) (Map.elems r)
|
||||
|
||||
-- | Keep only pairs for which both elements are in the given set.
|
||||
intersectSetRel :: Ord a => Set a -> Rel a -> Rel a
|
||||
intersectSetRel s = filterRel (\x y -> x `Set.member` s && y `Set.member` s)
|
||||
|
||||
transitiveClosure :: Ord a => Rel a -> Rel a
|
||||
transitiveClosure r = fix (Map.map growSet) r
|
||||
where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
|
||||
|
||||
reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
|
||||
-> Rel a -> Rel a
|
||||
reflexiveClosure_ u r = relates [(x,x) | x <- u] r
|
||||
|
||||
-- | Uses 'domain'
|
||||
reflexiveClosure :: Ord a => Rel a -> Rel a
|
||||
reflexiveClosure r = reflexiveClosure_ (Set.toList $ domain r) r
|
||||
|
||||
symmetricClosure :: Ord a => Rel a -> Rel a
|
||||
symmetricClosure r = relates [ (y,x) | (x,y) <- relToList r ] r
|
||||
|
||||
symmetricSubrelation :: Ord a => Rel a -> Rel a
|
||||
symmetricSubrelation r = filterRel (flip $ isRelatedTo r) r
|
||||
|
||||
reflexiveSubrelation :: Ord a => Rel a -> Rel a
|
||||
reflexiveSubrelation r = intersectSetRel (reflexiveElements r) r
|
||||
|
||||
-- | Get the set of elements which are related to themselves.
|
||||
reflexiveElements :: Ord a => Rel a -> Set a
|
||||
reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
|
||||
|
||||
-- | Keep the related pairs for which the predicate is true.
|
||||
filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
|
||||
filterRel p = purgeEmpty . Map.mapWithKey (Set.filter . p)
|
||||
|
||||
-- | Remove keys that map to no elements.
|
||||
purgeEmpty :: Ord a => Rel a -> Rel a
|
||||
purgeEmpty r = Map.filter (not . Set.null) r
|
||||
|
||||
|
||||
-- | Get the equivalence classes from an equivalence relation.
|
||||
equivalenceClasses :: Ord a => Rel a -> [[a]]
|
||||
equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
|
||||
where equivalenceClasses_ [] _ = []
|
||||
equivalenceClasses_ (x:xs) r = Set.toList ys:equivalenceClasses_ zs r
|
||||
where ys = allRelated r x
|
||||
zs = [x' | x' <- xs, not (x' `Set.member` ys)]
|
||||
|
||||
isTransitive :: Ord a => Rel a -> Bool
|
||||
isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
|
||||
y <- Set.toList ys, z <- Set.toList (allRelated r y)]
|
||||
|
||||
isReflexive :: Ord a => Rel a -> Bool
|
||||
isReflexive r = all (\ (x,ys) -> x `Set.member` ys) (Map.toList r)
|
||||
|
||||
isSymmetric :: Ord a => Rel a -> Bool
|
||||
isSymmetric r = and [isRelatedTo r y x | (x,y) <- relToList r]
|
||||
|
||||
isEquivalence :: Ord a => Rel a -> Bool
|
||||
isEquivalence r = isReflexive r && isSymmetric r && isTransitive r
|
||||
|
||||
isSubRelationOf :: Ord a => Rel a -> Rel a -> Bool
|
||||
isSubRelationOf r1 r2 = all (uncurry (isRelatedTo r2)) (relToList r1)
|
||||
39
src/GF/Speech/RelationQC.hs
Normal file
39
src/GF/Speech/RelationQC.hs
Normal file
@@ -0,0 +1,39 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : RelationQC
|
||||
-- Maintainer : BB
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/26 17:13:13 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-- QuickCheck properties for GF.Speech.Relation
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Speech.RelationQC where
|
||||
|
||||
import GF.Speech.Relation
|
||||
|
||||
import Test.QuickCheck
|
||||
|
||||
prop_transitiveClosure_trans :: [(Int,Int)] -> Bool
|
||||
prop_transitiveClosure_trans ps = isTransitive (transitiveClosure (mkRel ps))
|
||||
|
||||
prop_symmetricSubrelation_symm :: [(Int,Int)] -> Bool
|
||||
prop_symmetricSubrelation_symm ps = isSymmetric (symmetricSubrelation (mkRel ps))
|
||||
|
||||
prop_symmetricSubrelation_sub :: [(Int,Int)] -> Bool
|
||||
prop_symmetricSubrelation_sub ps = symmetricSubrelation r `isSubRelationOf` r
|
||||
where r = mkRel ps
|
||||
|
||||
prop_symmetricClosure_symm :: [(Int,Int)] -> Bool
|
||||
prop_symmetricClosure_symm ps = isSymmetric (symmetricClosure (mkRel ps))
|
||||
|
||||
prop_reflexiveClosure_refl :: [(Int,Int)] -> Bool
|
||||
prop_reflexiveClosure_refl ps = isReflexive (reflexiveClosure (mkRel ps))
|
||||
|
||||
prop_mkEquiv_equiv :: [(Int,Int)] -> Bool
|
||||
prop_mkEquiv_equiv ps = isEquivalence (mkEquiv ps)
|
||||
where mkEquiv = transitiveClosure . symmetricClosure . reflexiveClosure . mkRel
|
||||
@@ -5,9 +5,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/14 15:17:30 $
|
||||
-- > CVS $Date: 2005/10/26 17:13:13 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.17 $
|
||||
-- > CVS $Revision: 1.18 $
|
||||
--
|
||||
-- Representation of, conversion to, and utilities for
|
||||
-- printing of a general Speech Recognition Grammar.
|
||||
@@ -33,6 +33,7 @@ import Data.List
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.FiniteMap
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
data SRG = SRG { grammarName :: String -- ^ grammar name
|
||||
, startCat :: String -- ^ start category name
|
||||
|
||||
Reference in New Issue
Block a user