From 0916a479d8c9f6ed4e4ffe72d89691fc88b2ea3e Mon Sep 17 00:00:00 2001
From: bringert <unknown>
Date: Wed, 14 Sep 2005 15:08:35 +0000
Subject: [PATCH] Parametrized the type of FAs over the state type.

---
 src/GF/Speech/CFGToFiniteState.hs |  10 +--
 src/GF/Speech/FiniteState.hs      | 125 +++++++++++++++---------------
 src/GF/Speech/PrSLF.hs            |   6 +-
 3 files changed, 70 insertions(+), 71 deletions(-)

diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs
index 1816e4502..73765aed0 100644
--- a/src/GF/Speech/CFGToFiniteState.hs
+++ b/src/GF/Speech/CFGToFiniteState.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/14 15:17:29 $ 
+-- > CVS $Date: 2005/09/14 16:08:35 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.3 $
+-- > CVS $Revision: 1.4 $
 --
 -- Approximates CFGs with finite state networks.
 -----------------------------------------------------------------------------
@@ -27,7 +27,7 @@ import GF.Speech.FiniteState
 import GF.Speech.TransformCFG
 
 cfgToFA :: Ident -- ^ Grammar name
-	-> Options -> CGrammar -> FA () (Maybe String)
+	-> Options -> CGrammar -> NFA String
 cfgToFA name opts = minimize . compileAutomaton start . makeSimpleRegular
   where start = getStartCat opts
 
@@ -67,7 +67,7 @@ mutRecCats incAll g = equivalenceClasses $ symmetricSubrelation $ transitiveClos
 -- Convert a strongly regular grammar to a finite automaton.
 compileAutomaton :: Cat_ -- ^ Start category
 		 -> CFRules
-		 -> FA () (Maybe Token)
+		 -> NFA Token
 compileAutomaton start g = make_fa s [Cat start] f fa''
   where fa = newFA ()
 	s = startState fa
@@ -77,7 +77,7 @@ compileAutomaton start g = make_fa s [Cat start] f fa''
 	-- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\",
 	--   Mark-Jan Nederhof. International Workshop on Parsing Technologies, 1997.
 	make_fa :: State -> [Symbol Cat_ Token] -> State 
-		-> FA () (Maybe Token) -> FA () (Maybe Token)
+		-> NFA Token -> NFA Token
 	make_fa q0 alpha q1 fa = 
 	    case alpha of
 		   []       -> newTransition q0 q1 Nothing fa
diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index 428ad8f76..d6d952aaa 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/src/GF/Speech/FiniteState.hs
@@ -5,13 +5,13 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/14 15:29:53 $ 
+-- > CVS $Date: 2005/09/14 16:08:35 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.8 $
+-- > CVS $Revision: 1.9 $
 --
 -- A simple finite state network module.
 -----------------------------------------------------------------------------
-module GF.Speech.FiniteState (FA, State,
+module GF.Speech.FiniteState (FA, State, NFA, DFA,
 			      startState, finalStates,
 			      states, transitions,
 			      newFA, 
@@ -22,71 +22,106 @@ module GF.Speech.FiniteState (FA, State,
 			      prFAGraphviz) where
 
 import Data.List
-import Data.Maybe (fromJust)
+import Data.Maybe (catMaybes,fromJust)
 
 import GF.Data.Utilities
 import qualified GF.Visualization.Graphviz as Dot
 
+type State = Int
 
-data FA a b = FA (Graph State a b) State [State]
+data FA n a b = FA (Graph n a b) n [n]
 
-type State = Node
+type NFA a = FA State () (Maybe a)
 
-startState :: FA a b -> State
+type DFA a = FA [State] () a
+
+
+startState :: FA n a b -> n
 startState (FA _ s _) = s
 
-finalStates :: FA a b -> [State]
+finalStates :: FA n a b -> [n]
 finalStates (FA _ _ ss) = ss
 
-states :: FA a b -> [(State,a)]
+states :: FA n a b -> [(n,a)]
 states (FA g _ _) = nodes g
 
-transitions :: FA a b -> [(State,State,b)]
+transitions :: FA n a b -> [(n,n,b)]
 transitions (FA g _ _) = edges g
 
-newFA :: a -- ^ Start node label
-      -> FA a b
+newFA :: Enum n => a -- ^ Start node label
+      -> FA n a b
 newFA l = FA g s []
-    where (g,s) = newNode l (newGraph [0..])
+    where (g,s) = newNode l (newGraph [toEnum 0..])
 
-addFinalState :: State -> FA a b -> FA a b
+addFinalState :: n -> FA n a b -> FA n a b
 addFinalState f (FA g s ss) = FA g s (f:ss)
 
-newState :: a -> FA a b -> (FA a b, State)
+newState :: a -> FA n a b -> (FA n a b, n)
 newState x (FA g s ss) = (FA g' s ss, n)
     where (g',n) = newNode x g
 
-newTransition :: State -> State -> b -> FA a b -> FA a b
+newTransition :: n -> n -> b -> FA n a b -> FA n a b
 newTransition f t l = onGraph (newEdge f t l)
 
-mapStates :: (a -> c) -> FA a b -> FA c b
+mapStates :: (a -> c) -> FA n a b -> FA n c b
 mapStates f = onGraph (nmap f)
 
-mapTransitions :: (b -> c) -> FA a b -> FA a c
+mapTransitions :: (b -> c) -> FA n a b -> FA n a c
 mapTransitions f = onGraph (emap f)
 
-minimize :: FA () (Maybe a) -> FA () (Maybe a)
-minimize = onGraph mimimizeGr1
+minimize :: NFA a -> NFA a
+minimize = onGraph id
 
-onGraph :: (Graph State a b -> Graph State c d) -> FA a b -> FA c d
+onGraph :: (Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
 onGraph f (FA g s ss) = FA (f g) s ss
 
 -- | Transform a standard finite automaton with labelled edges
 --   to one where the labels are on the nodes instead. This can add
 --   up to one extra node per edge.
-moveLabelsToNodes :: Eq a => FA () (Maybe a) -> FA (Maybe a) ()
+moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
 moveLabelsToNodes = onGraph moveLabelsToNodes_
+  where 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')
 
-prFAGraphviz :: FA String String -> String
-prFAGraphviz  = Dot.prGraphviz . mkGraphviz
- where
- mkGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed [] (map mkNode ns) (map mkEdge es)
+fixIncoming :: (Eq n, Eq a) => [n] -> (n,(),[(n,n,Maybe a)]) -> ([n],[(n,Maybe a,[(n,n,())])])
+fixIncoming cs c@(n,(),es) = (cs'', (n,Nothing,es'):newContexts)
+  where ls = nub $ map getLabel es
+	(cs',cs'') = splitAt (length ls) cs
+	newNodes = zip cs' 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 ]
+
+alphabet :: Eq b => Graph n a (Maybe b) -> [b]
+alphabet = nub . catMaybes . map getLabel . edges
+
+reachable :: (Eq b, Eq n) => Graph n a (Maybe b) -> n -> b -> [n]
+reachable = undefined
+
+determinize :: NFA a -> DFA a
+determinize (FA g s f) = undefined
+
+
+prFAGraphviz :: (Eq n,Show n) => FA n String String -> String
+prFAGraphviz  = Dot.prGraphviz . toGraphviz
+
+toGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
+toGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed [] (map mkNode ns) (map mkEdge es)
    where mkNode (n,l) = Dot.Node (show n) attrs
 	     where attrs = [("label",l)] 
 			   ++ if n == s then [("shape","box")] else []
 			   ++ if n `elem` f then [("style","bold")] else []
 	 mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
 
+
 --
 -- * Graphs 
 --
@@ -94,8 +129,6 @@ prFAGraphviz  = Dot.prGraphviz . mkGraphviz
 data Graph n a b = Graph [n] [(n,a)] [(n,n,b)]
 		 deriving (Eq,Show)
 
-type Node = Int
-
 newGraph :: [n] -> Graph n a b
 newGraph ns = Graph ns [] []
 
@@ -124,43 +157,9 @@ incoming (Graph _ ns es) = snd $ mapAccumL f (sortBy compareDest es) (sortBy com
 	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_ :: (Ord n, Eq a) => Graph n () (Maybe a) -> Graph n (Maybe a) ()
-moveLabelsToNodes_ gr@(Graph c _ _) = mimimizeGr2 $ 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 n, Eq a) => [n] -> (n,(),[(n,n,Maybe a)]) -> ([n],[(n,Maybe a,[(n,n,())])])
-fixIncoming cs c@(n,(),es) = (cs'', (n,Nothing,es'):newContexts)
-  where ls = nub $ map getLabel es
-	(cs',cs'') = splitAt (length ls) cs
-	newNodes = zip cs' 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 :: (n,n,b) -> b
 getLabel (_,_,l) = l
 
-mimimizeGr1 :: Eq n => Graph n () (Maybe a) -> Graph n () (Maybe a)
-mimimizeGr1 = removeEmptyLoops1
-
-removeEmptyLoops1 :: Eq n => Graph n () (Maybe a) -> Graph n () (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 n (Maybe a) () -> Graph n (Maybe a) ()
-mimimizeGr2 = id
-
-removeDuplicateEdges :: (Eq n, Ord b) => Graph n a b -> Graph n a b
-removeDuplicateEdges (Graph c ns es) = Graph c ns (nub es)
-
 reverseGraph :: Graph n a b -> Graph n a b
 reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
+
diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs
index fac25ed77..33ddf03ca 100644
--- a/src/GF/Speech/PrSLF.hs
+++ b/src/GF/Speech/PrSLF.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/14 15:17:30 $ 
+-- > CVS $Date: 2005/09/14 16:08:35 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.9 $
+-- > CVS $Revision: 1.10 $
 --
 -- This module converts a CFG to an SLF finite-state network
 -- for use with the ATK recognizer. The SLF format is described
@@ -71,7 +71,7 @@ regularPrinter = prCFRules . makeSimpleRegular
   join g = concat . intersperse g
   showRhs = unwords . map (symbol id show)
 
-automatonToSLF :: FA (Maybe String) () -> SLF
+automatonToSLF :: FA State (Maybe String) () -> SLF
 automatonToSLF fa = 
     SLF { slfNodes = map mkSLFNode (states fa), 
 	  slfEdges = zipWith mkSLFEdge [0..] (transitions fa) }