Started wotking on NFA to DFA.

2 files changed, 56 insertions, 26 deletions

diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs
index f32e43af3..7bc5040fd 100644
--- a/src/GF/Data/Utilities.hs
+++ b/src/GF/Data/Utilities.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/14 15:17:29 $ 
+-- > CVS $Date: 2005/09/14 18:00:19 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.3 $
+-- > CVS $Revision: 1.4 $
 --
 -- Basic functions not in the standard libraries
 -----------------------------------------------------------------------------
@@ -85,6 +85,14 @@ unionAll = nub . concat
 lookup' :: Eq a => a -> [(a,b)] -> b
 lookup' x = fromJust . lookup x
 
+-- * ordering functions
+
+compareBy :: Ord b => (a -> b) -> a -> a -> Ordering
+compareBy f = both f compare
+
+both :: (a -> b) -> (b -> b -> c) -> a -> a -> c
+both f g x y = g (f x) (f y)
+
 -- * functions on pairs
 
 mapFst :: (a -> a') -> (a, b) -> (a', b)
diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index d6d952aaa..a57328a03 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/src/GF/Speech/FiniteState.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/14 16:08:35 $ 
+-- > CVS $Date: 2005/09/14 18:00:19 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.9 $
+-- > CVS $Revision: 1.10 $
 --
 -- A simple finite state network module.
 -----------------------------------------------------------------------------
@@ -21,6 +21,7 @@ module GF.Speech.FiniteState (FA, State, NFA, DFA,
 			      moveLabelsToNodes, minimize,
 			      prFAGraphviz) where
 
+import GF.Data.Utilities
 import Data.List
 import Data.Maybe (catMaybes,fromJust)
 
@@ -80,13 +81,13 @@ onGraph f (FA g s ss) = FA (f g) s ss
 --   up to one extra node per edge.
 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 moveLabelsToNodes_ gr@(Graph c _ _) = Graph c' ns (concat ess)
 	    where is = incoming gr
 		  (c',is') = mapAccumL fixIncoming c is
-		  (ns,ls,ess) = unzip3 (concat is')
+		  (ns,ess) = unzip (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)
+fixIncoming :: (Eq n, Eq a) => [n] -> (Node n (),[Edge n (Maybe a)]) -> ([n],[(Node n (Maybe a),[Edge 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
@@ -94,21 +95,29 @@ fixIncoming cs c@(n,(),es) = (cs'', (n,Nothing,es'):newContexts)
 	-- 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 ]
+	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 = [ (v, to v) | v <- 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
+reachable :: (Eq b, Ord n) => Graph n a (Maybe b) -> n -> b -> [n]
+reachable g s c = fix reachable_ [s]
+  where reachable_ r = r `union` [y | x <- r, es <- outf x, (_,y,l) <- es, maybe True (==c) l]
+	out = outgoing g
+	outf x = [ es | ((y,_),es) <- out, x == y ]
+
+determinize :: Eq a => NFA a -> DFA a
 determinize (FA g s f) = undefined
+  where sigma = alphabet g
 
+--
+-- * Visualization
+--
 
 prFAGraphviz :: (Eq n,Show n) => FA n String String -> String
 prFAGraphviz  = Dot.prGraphviz . toGraphviz
@@ -126,16 +135,19 @@ toGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed [] (map mkNode ns)
 -- * Graphs 
 --
 
-data Graph n a b = Graph [n] [(n,a)] [(n,n,b)]
+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)
+
 newGraph :: [n] -> Graph n a b
 newGraph ns = Graph ns [] []
 
-nodes :: Graph n a b -> [(n,a)]
+nodes :: Graph n a b -> [Node n a]
 nodes (Graph _ ns _) = ns
 
-edges :: Graph n a b -> [(n,n,b)]
+edges :: Graph n a b -> [Edge n b]
 edges (Graph _ _ es) = es
 
 nmap :: (a -> c) -> Graph n a b -> Graph n c b
@@ -150,14 +162,24 @@ newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
 newEdge :: n -> n -> b -> Graph n a b -> Graph n a b
 newEdge f t l (Graph c ns es) = Graph c ns ((f,t,l):es)
 
-incoming :: Ord n => Graph n a b -> [(n,a,[(n,n,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))
+incoming :: Ord n => Graph n a b -> [(Node n a,[Edge n b])]
+incoming = groupEdgesBy getTo
+
+outgoing :: Ord n => Graph n a b -> [(Node n a,[Edge n b])]
+outgoing = groupEdgesBy getTo
+
+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 :: (n,n,b) -> b
+getLabel :: Edge n b -> b
 getLabel (_,_,l) = l
 
 reverseGraph :: Graph n a b -> Graph n a b