msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Used home-grown graph implementation in FiniteState, to remove dependency on fgl. This also lead to a dramatic performance increase.

Browse Source
This commit is contained in:
bringert
2005-09-12 20:41:19 +00:00
parent 9112e13c60
commit fea451f06c
3 changed files with 96 additions and 96 deletions
Download Patch File Download Diff File Expand all files Collapse all files

179
src/GF/Speech/FiniteState.hs
View File

@@ -5,26 +5,27 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/09/12 15:46:44 $ -- > CVS $Date: 2005/09/12 21:41:19 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.3 $ -- > CVS $Revision: 1.4 $
-- --
-- A simple finite state network module. -- A simple finite state network module.
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Speech.FiniteState (FA, State, module GF.Speech.FiniteState (FA, State,
startState, finalStates, startState, finalStates,
states, transitions, states, transitions,
newFA, addFinalState, newFA,
newState, newTransition, newTransitions, addFinalState,
moveLabelsToNodes, minimize, asGraph) where newState, newTransition,
moveLabelsToNodes, minimize, asGraph,
Graph, prGraphGraphviz, nmap, emap) where
import Data.Graph.Inductive import Data.List
import Data.List (nub,partition)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Debug.Trace import Debug.Trace
data FA a b = FA (Gr a b) Node [Node] data FA a b = FA (Graph a b) State [State]
type State = Node type State = Node
@@ -35,123 +36,125 @@ finalStates :: FA a b -> [State]
finalStates (FA _ _ ss) = ss finalStates (FA _ _ ss) = ss
states :: FA a b -> [(State,a)] states :: FA a b -> [(State,a)]
states (FA g _ _) = labNodes g states (FA g _ _) = nodes g
transitions :: FA a b -> [(State,State,b)] transitions :: FA a b -> [(State,State,b)]
transitions (FA g _ _) = labEdges g transitions (FA g _ _) = edges g
newFA :: a -- ^ Start node label newFA :: a -- ^ Start node label
-> FA a b -> FA a b
newFA l = FA g' s [] newFA l = FA g s []
where g = empty where (g,s) = newNode l newGraph
s = freshNode g
g' = insNode (s,l) g
addFinalState :: Node -> FA a b -> FA a b addFinalState :: Node -> FA a b -> FA a b
addFinalState f (FA g s ss) = FA g s (f:ss) addFinalState f (FA g s ss) = FA g s (f:ss)
newState :: a -> FA a b -> (FA a b, State) newState :: a -> FA a b -> (FA a b, State)
newState x (FA g s ss) = (FA g' s ss, n) newState x (FA g s ss) = (FA g' s ss, n)
where (g',n) = addNode x g where (g',n) = newNode x g
newTransition :: Node -> Node -> b -> FA a b -> FA a b newTransition :: Node -> Node -> b -> FA a b -> FA a b
newTransition f t l = onGraph (insEdge (f,t,l)) newTransition f t l = onGraph (newEdge f t l)
newTransitions :: [(Node,Node,b)] -> FA a b -> FA a b
newTransitions ts = onGraph (insEdges ts)
mapStates :: (a -> c) -> FA a b -> FA c b mapStates :: (a -> c) -> FA a b -> FA c b
mapStates f (FA g s ss) = FA (nmap f g) s ss mapStates f (FA g s ss) = FA (nmap f g) s ss
asGraph :: FA a b -> Gr a b asGraph :: FA a b -> Graph a b
asGraph (FA g _ _) = g asGraph (FA g _ _) = g
minimize :: FA () (Maybe a) -> FA () (Maybe a) minimize :: FA () (Maybe a) -> FA () (Maybe a)
minimize = onGraph mimimizeGr1 minimize = onGraph mimimizeGr1
--
-- * Graph functions
--
onGraph :: (Gr a b -> Gr c d) -> FA a b -> FA c d
onGraph f (FA g s ss) = FA (f g) s ss
addNode :: DynGraph gr => a -> gr a b -> (gr a b, Node)
addNode x g = let s = freshNode g in (insNode (s,x) g, s)
freshNode :: Graph gr => gr a b -> Node
freshNode = succ . snd . nodeRange
-- | Get an infinte supply of new nodes.
freshNodes :: Graph gr => gr a b -> [Node]
freshNodes g = [snd (nodeRange g)+1..]
-- | Transform a standard finite automaton with labelled edges -- | Transform a standard finite automaton with labelled edges
-- to one where the labels are on the nodes instead. This can add -- to one where the labels are on the nodes instead. This can add
-- up to one extra node per edge. -- up to one extra node per edge.
moveLabelsToNodes :: Eq a => FA () (Maybe a) -> FA (Maybe a) () moveLabelsToNodes :: Eq a => FA () (Maybe a) -> FA (Maybe a) ()
moveLabelsToNodes = onGraph moveLabelsToNodes_ moveLabelsToNodes = onGraph moveLabelsToNodes_
moveLabelsToNodes_ :: (DynGraph gr, Eq a) => gr () (Maybe a) -> gr (Maybe a) () --
moveLabelsToNodes_ g = gmap f g' -- * Graphs
where g' = sameLabelIncoming g --
f (to,n,(),fr) = (removeAdjLabels to, n, l, removeAdjLabels fr) type Node = Int
where l | not (allEqual ls)
= error $ "moveLabelsToNodes: not all incoming labels are equal"
| null ls = Nothing
| otherwise = head ls
ls = map snd $ lpre g' n
removeAdjLabels = map (\ (_,n) -> ((),n))
-- | Add the extra nodes needed to make sure that all edges to a node data Graph a b = Graph Node [(Node,a)] [(Node,Node,b)]
-- have the same label. deriving (Eq,Show)
sameLabelIncoming :: (DynGraph gr, Eq b) => gr () (Maybe b) -> gr () (Maybe b)
sameLabelIncoming gr = foldr fixIncoming gr (nodes gr)
fixIncoming :: (DynGraph gr, Eq b) => Node -> gr () (Maybe b) -> gr () (Maybe b) onGraph :: (Graph a b -> Graph c d) -> FA a b -> FA c d
fixIncoming n gr | allLabelsEqual to' = gr onGraph f (FA g s ss) = FA (f g) s ss
| otherwise = addContexts newContexts $ delNode n gr
where (to,_,_,fr) = context gr n
-- move cyclic edges to the list of incoming edges
(cyc,fr') = partition (\ (_,t) -> t == n) fr
to' = to ++ cyc
-- make new nodes for each unique label
newNodes = zip (nub $ map fst to') (freshNodes gr)
-- for each cyclic edge, add an edge to the node for
-- that label (could be the current node).
fr'' = fr' ++ [ (l',fromJust (lookup l' newNodes)) | (l',f) <- to', f == n ]
-- keep all incoming non-cyclic edges with the right label.
to'' l = [ e | e@(l',f) <- to', l'==l, f /= n ]
newContexts = [ (to'' l,n',(),fr'') | (l,n') <- newNodes]
allLabelsEqual :: Eq b => Adj b -> Bool -- graphToFA :: State -> [State] -> Graph a b -> FA a b
allLabelsEqual = allEqual . map fst -- graphToFA s fs (Graph _ ss ts) = buildFA s fs ss ts
edgeLabel :: LEdge b -> b newGraph :: Graph a b
edgeLabel (_,_,l) = l newGraph = Graph 0 [] []
ledgeToEdge :: LEdge b -> Edge nodes :: Graph a b -> [(Node,a)]
ledgeToEdge (f,t,_) = (f,t) nodes (Graph _ ns _) = ns
addContexts :: DynGraph gr => [Context a b] -> gr a b -> gr a b edges :: Graph a b -> [(Node,Node,b)]
addContexts cs gr = foldr (&) gr cs edges (Graph _ _ es) = es
mimimizeGr1 :: DynGraph gr => gr () (Maybe a) -> gr () (Maybe a) nmap :: (a -> c) -> Graph a b -> Graph c b
mimimizeGr1 = removeEmptyLoops nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
removeEmptyLoops :: DynGraph gr => gr () (Maybe a) -> gr () (Maybe a) emap :: (b -> c) -> Graph a b -> Graph a c
removeEmptyLoops = gmap (\ (i,n,(),o) -> (filter (r n) i,n,(),filter (r n) o)) emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
where r n (Nothing,n') | n' == n = False
r _ _ = True
mimimizeGr2 :: DynGraph gr => gr (Maybe a) () -> gr (Maybe a) () newNode :: a -> Graph a b -> (Graph a b,State)
newNode l (Graph c ns es) = (Graph s ((s,l):ns) es, s)
where s = c+1
newEdge :: State -> State -> b -> Graph a b -> Graph a b
newEdge f t l (Graph c ns es) = Graph c ns ((f,t,l):es)
incoming :: Graph a b -> [(Node,a,[(Node,Node,b)])]
incoming (Graph _ ns es) = snd $ mapAccumL f (sortBy compareDest es) (sortBy compareFst ns)
where destIs d (_,t,_) = t == d
compareDest (_,t1,_) (_,t2,_) = compare t1 t2
compareFst p1 p2 = compare (fst p1) (fst p2)
f es' (n,l) = let (nes,es'') = span (destIs n) es' in (es'',(n,l,nes))
moveLabelsToNodes_ :: Eq a => Graph () (Maybe a) -> Graph (Maybe a) ()
moveLabelsToNodes_ gr@(Graph c _ _) = Graph c' (zip ns ls) (concat ess)
where is = incoming gr
(c',is') = mapAccumL fixIncoming c is
(ns,ls,ess) = unzip3 (concat is')
fixIncoming :: Eq a => Node -> (Node,(),[(Node,Node,Maybe a)]) -> (Node,[(Node,Maybe a,[(Node,Node,())])])
fixIncoming next c@(n,(),es) = (next', (n,Nothing,es'):newContexts)
where ls = nub $ map getLabel es
next' = next + length ls
newNodes = zip [next..next'-1] ls
es' = [ (x,n,()) | x <- map fst newNodes ]
-- separate cyclic and non-cyclic edges
(cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
-- keep all incoming non-cyclic edges with the right label
to x l = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
-- for each cyclic edge with the right label,
-- add an edge from each of the new nodes (including this one)
++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
newContexts = [ (x, l, to x l) | (x,l) <- newNodes ]
getLabel :: (Node,Node,b) -> b
getLabel (_,_,l) = l
mimimizeGr1 :: Graph () (Maybe a) -> Graph () (Maybe a)
mimimizeGr1 = removeEmptyLoops1
removeEmptyLoops1 :: Graph () (Maybe a) -> Graph () (Maybe a)
removeEmptyLoops1 (Graph c ns es) = Graph c ns (filter (not . isEmptyLoop) es)
where isEmptyLoop (f,t,Nothing) | f == t = True
isEmptyLoop _ = False
mimimizeGr2 :: Graph (Maybe a) () -> Graph (Maybe a) ()
mimimizeGr2 gr = gr mimimizeGr2 gr = gr
--
-- * Utilities
--
allEqual :: Eq a => [a] -> Bool
allEqual [] = True
allEqual (x:xs) = all (==x) xs
prGraphGraphviz :: Graph String String -> String
prGraphGraphviz (Graph _ ss ts) =
"digraph {\n" ++ unlines (map prNode ss)
++ "\n"
++ unlines (map prEdge ts)
++ "\n}\n"
where prNode (n,l) = show n ++ " [label = " ++ show l ++ "]"
prEdge (f,t,l) = show f ++ " -> " ++ show t ++ " [label = " ++ show l ++ "]"

11
src/GF/Speech/PrSLF.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable) -- Stability : (stable)
-- Portability : (portable) -- Portability : (portable)
-- --
-- > CVS $Date: 2005/09/12 16:10:23 $ -- > CVS $Date: 2005/09/12 21:41:19 $
-- > CVS $Author: bringert $ -- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $ -- > CVS $Revision: 1.6 $
-- --
-- This module converts a CFG to an SLF finite-state network -- This module converts a CFG to an SLF finite-state network
-- for use with the ATK recognizer. The SLF format is described -- for use with the ATK recognizer. The SLF format is described
@@ -36,9 +36,6 @@ import Data.Char (toUpper,toLower)
import Data.List import Data.List
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Graph.Inductive (emap,nmap)
import Data.Graph.Inductive.Graphviz
data SLF = SLF { slfNodes :: [SLFNode], slfEdges :: [SLFEdge] } data SLF = SLF { slfNodes :: [SLFNode], slfEdges :: [SLFEdge] }
data SLFNode = SLFNode { nId :: Int, nWord :: SLFWord } data SLFNode = SLFNode { nId :: Int, nWord :: SLFWord }
@@ -56,12 +53,12 @@ slfPrinter name opts cfg = prSLF (automatonToSLF $ moveLabelsToNodes $ cfgToFA n
slfGraphvizPrinter :: Ident -- ^ Grammar name slfGraphvizPrinter :: Ident -- ^ Grammar name
-> Options -> CGrammar -> String -> Options -> CGrammar -> String
slfGraphvizPrinter name opts cfg = slfGraphvizPrinter name opts cfg =
graphviz (nmap (fromMaybe "") $ asGraph $ moveLabelsToNodes $ cfgToFA name opts cfg) (prIdent name) (8.5,11.0) (1,1) Landscape prGraphGraphviz (nmap (fromMaybe "") $ emap (const "") $ asGraph $ moveLabelsToNodes $ cfgToFA name opts cfg)
faGraphvizPrinter :: Ident -- ^ Grammar name faGraphvizPrinter :: Ident -- ^ Grammar name
-> Options -> CGrammar -> String -> Options -> CGrammar -> String
faGraphvizPrinter name opts cfg = faGraphvizPrinter name opts cfg =
graphviz (nmap (const "") $ emap (fromMaybe "") $ asGraph $ cfgToFA name opts cfg) (prIdent name) (8.5,11.0) (1,1) Landscape prGraphGraphviz (nmap (const "") $ emap (fromMaybe "") $ asGraph $ cfgToFA name opts cfg)
-- | Convert the grammar to a regular grammar and print it in BNF -- | Convert the grammar to a regular grammar and print it in BNF
regularPrinter :: CGrammar -> String regularPrinter :: CGrammar -> String

2
src/Makefile
View File

@@ -3,7 +3,7 @@ include config.mk
GHMAKE=$(GHC) --make GHMAKE=$(GHC) --make
GHCXMAKE=ghcxmake GHCXMAKE=ghcxmake
GHCFLAGS+= -fglasgow-exts -package fgl GHCFLAGS+= -fglasgow-exts
GHCOPTFLAGS=-O2 GHCOPTFLAGS=-O2
GHCFUDFLAG= GHCFUDFLAG=
JAVAFLAGS=-target 1.4 -source 1.4 JAVAFLAGS=-target 1.4 -source 1.4