----------------------------------------------------------------------
-- |
-- Module      : FiniteState
-- Maintainer  : BB
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/10 16:43:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.16 $
--
-- A simple finite state network module.
-----------------------------------------------------------------------------
module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
                              startState, finalStates,
                              states, transitions,
                              isInternal,
                              newFA, newFA_,
                              addFinalState,
                              newState, newStates,
                              newTransition, newTransitions,
                              insertTransitionWith, insertTransitionsWith,
                              mapStates, mapTransitions,
                              modifyTransitions,
                              nonLoopTransitionsTo, nonLoopTransitionsFrom,
                              loops,
                              removeState,
                              oneFinalState,
                              insertNFA,
                              onGraph,
                              moveLabelsToNodes, removeTrivialEmptyNodes,
                              minimize,
                              dfa2nfa,
                              unusedNames, renameStates,
                              prFAGraphviz, faToGraphviz) 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
import GF.Data.Graph
import qualified GF.Data.Graphviz as Dot

type State = Int

-- | Type parameters: node id type, state label type, edge label type
--   Data constructor arguments: nodes and edges, start state, final states
data FA n a b = FA !(Graph n a b) !n ![n]

type NFA a = FA State () (Maybe a)

type DFA a = FA State () a


startState :: FA n a b -> n
startState :: FA n a b -> n
startState (FA Graph n a b
_ n
s [n]
_) = n
s

finalStates :: FA n a b -> [n]
finalStates :: FA n a b -> [n]
finalStates (FA Graph n a b
_ n
_ [n]
ss) = [n]
ss

states :: FA n a b -> [(n,a)]
states :: FA n a b -> [(n, a)]
states (FA Graph n a b
g n
_ [n]
_) = Graph n a b -> [(n, a)]
forall n a b. Graph n a b -> [Node n a]
nodes Graph n a b
g

transitions :: FA n a b -> [(n,n,b)]
transitions :: FA n a b -> [(n, n, b)]
transitions (FA Graph n a b
g n
_ [n]
_) = Graph n a b -> [(n, n, b)]
forall n a b. Graph n a b -> [Edge n b]
edges Graph n a b
g

newFA :: Enum n => a -- ^ Start node label
      -> FA n a b
newFA :: a -> FA n a b
newFA a
l = Graph n a b -> n -> [n] -> FA n a b
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA Graph n a b
forall b. Graph n a b
g n
s []
    where (Graph n a b
g,n
s) = a -> Graph n a b -> (Graph n a b, n)
forall a n b. a -> Graph n a b -> (Graph n a b, n)
newNode a
l ([n] -> Graph n a b
forall n a b. [n] -> Graph n a b
newGraph [Int -> n
forall a. Enum a => Int -> a
toEnum Int
0..])

-- | Create a new finite automaton with an initial and a final state.
newFA_ :: Enum n => (FA n () b, n, n)
newFA_ :: (FA n () b, n, n)
newFA_ = (FA n () b
forall b. FA n () b
fa'', n
s, n
f)
    where fa :: FA n () b
fa = () -> FA n () b
forall n a b. Enum n => a -> FA n a b
newFA ()
          s :: n
s = FA n () Any -> n
forall n a b. FA n a b -> n
startState FA n () Any
forall b. FA n () b
fa
          (FA n () b
fa',n
f) = () -> FA n () b -> (FA n () b, n)
forall a n b. a -> FA n a b -> (FA n a b, n)
newState () FA n () b
forall b. FA n () b
fa
          fa'' :: FA n () b
fa'' = n -> FA n () b -> FA n () b
forall n a b. n -> FA n a b -> FA n a b
addFinalState n
f FA n () b
forall b. FA n () b
fa'

addFinalState :: n -> FA n a b -> FA n a b
addFinalState :: n -> FA n a b -> FA n a b
addFinalState n
f (FA Graph n a b
g n
s [n]
ss) = Graph n a b -> n -> [n] -> FA n a b
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA Graph n a b
g n
s (n
fn -> [n] -> [n]
forall a. a -> [a] -> [a]
:[n]
ss)

newState :: a -> FA n a b -> (FA n a b, n)
newState :: a -> FA n a b -> (FA n a b, n)
newState a
x (FA Graph n a b
g n
s [n]
ss) = (Graph n a b -> n -> [n] -> FA n a b
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA Graph n a b
g' n
s [n]
ss, n
n)
    where (Graph n a b
g',n
n) = a -> Graph n a b -> (Graph n a b, n)
forall a n b. a -> Graph n a b -> (Graph n a b, n)
newNode a
x Graph n a b
g

newStates :: [a] -> FA n a b -> (FA n a b, [(n,a)])
newStates :: [a] -> FA n a b -> (FA n a b, [(n, a)])
newStates [a]
xs (FA Graph n a b
g n
s [n]
ss) = (Graph n a b -> n -> [n] -> FA n a b
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA Graph n a b
g' n
s [n]
ss, [(n, a)]
ns)
    where (Graph n a b
g',[(n, a)]
ns) = [a] -> Graph n a b -> (Graph n a b, [(n, a)])
forall a n b. [a] -> Graph n a b -> (Graph n a b, [Node n a])
newNodes [a]
xs Graph n a b
g

newTransition :: n -> n -> b -> FA n a b -> FA n a b
newTransition :: n -> n -> b -> FA n a b -> FA n a b
newTransition n
f n
t b
l = (Graph n a b -> Graph n a b) -> FA n a b -> FA n a b
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph (Edge n b -> Graph n a b -> Graph n a b
forall n b a. Edge n b -> Graph n a b -> Graph n a b
newEdge (n
f,n
t,b
l))

newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
newTransitions [(n, n, b)]
es = (Graph n a b -> Graph n a b) -> FA n a b -> FA n a b
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph ([(n, n, b)] -> Graph n a b -> Graph n a b
forall n b a. [Edge n b] -> Graph n a b -> Graph n a b
newEdges [(n, n, b)]
es)

insertTransitionWith :: Eq n =>
                        (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
insertTransitionWith :: (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
insertTransitionWith b -> b -> b
f (n, n, b)
t = (Graph n a b -> Graph n a b) -> FA n a b -> FA n a b
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph ((b -> b -> b) -> (n, n, b) -> Graph n a b -> Graph n a b
forall n b a.
Eq n =>
(b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
insertEdgeWith b -> b -> b
f (n, n, b)
t)

insertTransitionsWith :: Eq n =>
                         (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b
insertTransitionsWith :: (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b
insertTransitionsWith b -> b -> b
f [(n, n, b)]
ts FA n a b
fa =
    (FA n a b -> (n, n, b) -> FA n a b)
-> FA n a b -> [(n, n, b)] -> FA n a b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((n, n, b) -> FA n a b -> FA n a b)
-> FA n a b -> (n, n, b) -> FA n a b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
forall n b a.
Eq n =>
(b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
insertTransitionWith b -> b -> b
f)) FA n a b
fa [(n, n, b)]
ts

mapStates :: (a -> c) -> FA n a b -> FA n c b
mapStates :: (a -> c) -> FA n a b -> FA n c b
mapStates a -> c
f = (Graph n a b -> Graph n c b) -> FA n a b -> FA n c b
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph ((a -> c) -> Graph n a b -> Graph n c b
forall a c n b. (a -> c) -> Graph n a b -> Graph n c b
nmap a -> c
f)

mapTransitions :: (b -> c) -> FA n a b -> FA n a c
mapTransitions :: (b -> c) -> FA n a b -> FA n a c
mapTransitions b -> c
f = (Graph n a b -> Graph n a c) -> FA n a b -> FA n a c
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph ((b -> c) -> Graph n a b -> Graph n a c
forall b c n a. (b -> c) -> Graph n a b -> Graph n a c
emap b -> c
f)

modifyTransitions :: ([(n,n,b)] -> [(n,n,b)]) -> FA n a b -> FA n a b
modifyTransitions :: ([(n, n, b)] -> [(n, n, b)]) -> FA n a b -> FA n a b
modifyTransitions [(n, n, b)] -> [(n, n, b)]
f = (Graph n a b -> Graph n a b) -> FA n a b -> FA n a b
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph (\ (Graph [n]
r [Node n a]
ns [(n, n, b)]
es) -> [n] -> [Node n a] -> [(n, n, b)] -> Graph n a b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
r [Node n a]
ns ([(n, n, b)] -> [(n, n, b)]
f [(n, n, b)]
es))

removeState :: Ord n => n -> FA n a b -> FA n a b
removeState :: n -> FA n a b -> FA n a b
removeState n
n = (Graph n a b -> Graph n a b) -> FA n a b -> FA n a b
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph (n -> Graph n a b -> Graph n a b
forall n a b. Ord n => n -> Graph n a b -> Graph n a b
removeNode n
n)

minimize :: Ord a => NFA a -> DFA a
minimize :: NFA a -> DFA a
minimize = NFA a -> DFA a
forall a. Ord a => NFA a -> DFA a
determinize (NFA a -> DFA a) -> (NFA a -> NFA a) -> NFA a -> DFA a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NFA a -> NFA a
forall a. NFA a -> NFA a
reverseNFA (NFA a -> NFA a) -> (NFA a -> NFA a) -> NFA a -> NFA a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DFA a -> NFA a
forall a. DFA a -> NFA a
dfa2nfa (DFA a -> NFA a) -> (NFA a -> DFA a) -> NFA a -> NFA a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NFA a -> DFA a
forall a. Ord a => NFA a -> DFA a
determinize (NFA a -> DFA a) -> (NFA a -> NFA a) -> NFA a -> DFA a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NFA a -> NFA a
forall a. NFA a -> NFA a
reverseNFA

unusedNames :: FA n a b -> [n]
unusedNames :: FA n a b -> [n]
unusedNames (FA (Graph [n]
names [Node n a]
_ [Edge n b]
_) n
_ [n]
_) = [n]
names

-- | Gets all incoming transitions to a given state, excluding
-- transtions from the state itself.
nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)]
nonLoopTransitionsTo :: n -> FA n a b -> [(n, b)]
nonLoopTransitionsTo n
s FA n a b
fa =
    [(n
f,b
l) | (n
f,n
t,b
l) <- FA n a b -> [(n, n, b)]
forall n a b. FA n a b -> [(n, n, b)]
transitions FA n a b
fa, n
t n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
s Bool -> Bool -> Bool
&& n
f n -> n -> Bool
forall a. Eq a => a -> a -> Bool
/= n
s]

nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)]
nonLoopTransitionsFrom :: n -> FA n a b -> [(n, b)]
nonLoopTransitionsFrom n
s FA n a b
fa =
    [(n
t,b
l) | (n
f,n
t,b
l) <- FA n a b -> [(n, n, b)]
forall n a b. FA n a b -> [(n, n, b)]
transitions FA n a b
fa, n
f n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
s Bool -> Bool -> Bool
&& n
t n -> n -> Bool
forall a. Eq a => a -> a -> Bool
/= n
s]

loops :: Eq n => n -> FA n a b -> [b]
loops :: n -> FA n a b -> [b]
loops n
s FA n a b
fa = [b
l | (n
f,n
t,b
l) <- FA n a b -> [(n, n, b)]
forall n a b. FA n a b -> [(n, n, b)]
transitions FA n a b
fa, n
f n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
s Bool -> Bool -> Bool
&& n
t n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
s]

-- | Give new names to all nodes.
renameStates :: Ord x => [y] -- ^ Infinite supply of new names
             -> FA x a b
             -> FA y a b
renameStates :: [y] -> FA x a b -> FA y a b
renameStates [y]
supply (FA Graph x a b
g x
s [x]
fs) = Graph y a b -> y -> [y] -> FA y a b
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA ((x -> y) -> [y] -> Graph x a b -> Graph y a b
forall n m a b. (n -> m) -> [m] -> Graph n a b -> Graph m a b
renameNodes x -> y
newName [y]
rest Graph x a b
g) y
s' [y]
fs'
    where ([y]
ns,[y]
rest) = Int -> [y] -> ([y], [y])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Node x a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Graph x a b -> [Node x a]
forall n a b. Graph n a b -> [Node n a]
nodes Graph x a b
g)) [y]
supply
          newNodes :: Map x y
newNodes = [(x, y)] -> Map x y
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([x] -> [y] -> [(x, y)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Node x a -> x) -> [Node x a] -> [x]
forall a b. (a -> b) -> [a] -> [b]
map Node x a -> x
forall a b. (a, b) -> a
fst (Graph x a b -> [Node x a]
forall n a b. Graph n a b -> [Node n a]
nodes Graph x a b
g)) [y]
ns)
          newName :: x -> y
newName x
n = y -> x -> Map x y -> y
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ([Char] -> y
forall a. HasCallStack => [Char] -> a
error [Char]
"FiniteState.newName") x
n Map x y
newNodes
          s' :: y
s' = x -> y
newName x
s
          fs' :: [y]
fs' = (x -> y) -> [x] -> [y]
forall a b. (a -> b) -> [a] -> [b]
map x -> y
newName [x]
fs

-- | Insert an NFA into another
insertNFA :: NFA a -- ^ NFA to insert into
          -> (State, State) -- ^ States to insert between
          -> NFA a -- ^ NFA to insert.
          -> NFA a
insertNFA :: NFA a -> (Int, Int) -> NFA a -> NFA a
insertNFA (FA Graph Int () (Maybe a)
g1 Int
s1 [Int]
fs1) (Int
f,Int
t) (FA Graph Int () (Maybe a)
g2 Int
s2 [Int]
fs2)
    = Graph Int () (Maybe a) -> Int -> [Int] -> NFA a
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA ([Edge Int (Maybe a)]
-> Graph Int () (Maybe a) -> Graph Int () (Maybe a)
forall n b a. [Edge n b] -> Graph n a b -> Graph n a b
newEdges [Edge Int (Maybe a)]
forall a. [(Int, Int, Maybe a)]
es Graph Int () (Maybe a)
g') Int
s1 [Int]
fs1
    where
    es :: [(Int, Int, Maybe a)]
es = (Int
f,Int -> Int
ren Int
s2,Maybe a
forall a. Maybe a
Nothing)(Int, Int, Maybe a)
-> [(Int, Int, Maybe a)] -> [(Int, Int, Maybe a)]
forall a. a -> [a] -> [a]
:[(Int -> Int
ren Int
f2,Int
t,Maybe a
forall a. Maybe a
Nothing) | Int
f2 <- [Int]
fs2]
    (Graph Int () (Maybe a)
g',Int -> Int
ren) = Graph Int () (Maybe a)
-> Graph Int () (Maybe a) -> (Graph Int () (Maybe a), Int -> Int)
forall m n a b.
Ord m =>
Graph n a b -> Graph m a b -> (Graph n a b, m -> n)
mergeGraphs Graph Int () (Maybe a)
g1 Graph Int () (Maybe a)
g2

onGraph :: (Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph :: (Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph Graph n a b -> Graph n c d
f (FA Graph n a b
g n
s [n]
ss) = Graph n c d -> n -> [n] -> FA n c d
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA (Graph n a b -> Graph n c d
f Graph n a b
g) n
s [n]
ss


-- | Make the finite automaton have a single final state
--   by adding a new final state and adding an edge
--   from the old final states to the new state.
oneFinalState :: a        -- ^ Label to give the new node
              -> b        -- ^ Label to give the new edges
              -> FA n a b -- ^ The old network
              -> FA n a b -- ^ The new network
oneFinalState :: a -> b -> FA n a b -> FA n a b
oneFinalState a
nl b
el FA n a b
fa =
    let (FA Graph n a b
g n
s [n]
fs,n
nf) = a -> FA n a b -> (FA n a b, n)
forall a n b. a -> FA n a b -> (FA n a b, n)
newState a
nl FA n a b
fa
        es :: [(n, n, b)]
es = [ (n
f,n
nf,b
el) | n
f <- [n]
fs ]
     in Graph n a b -> n -> [n] -> FA n a b
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA ([(n, n, b)] -> Graph n a b -> Graph n a b
forall n b a. [Edge n b] -> Graph n a b -> Graph n a b
newEdges [(n, n, b)]
es Graph n a b
g) n
s [n
nf]

-- | 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 :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
moveLabelsToNodes :: FA n () (Maybe a) -> FA n (Maybe a) ()
moveLabelsToNodes = (Graph n () (Maybe a) -> Graph n (Maybe a) ())
-> FA n () (Maybe a) -> FA n (Maybe a) ()
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph Graph n () (Maybe a) -> Graph n (Maybe a) ()
forall n a.
(Ord n, Eq a) =>
Graph n () (Maybe a) -> Graph n (Maybe a) ()
f
  where f :: Graph n () (Maybe a) -> Graph n (Maybe a) ()
f g :: Graph n () (Maybe a)
g@(Graph [n]
c [Node n ()]
_ [Edge n (Maybe a)]
_) = [n] -> [Node n (Maybe a)] -> [Edge n ()] -> Graph n (Maybe a) ()
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
c' [Node n (Maybe a)]
ns ([[Edge n ()]] -> [Edge n ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge n ()]]
ess)
         where is :: [(Node n (), [Edge n (Maybe a)])]
is = [ ((n
n,()
l),[Edge n (Maybe a)]
inc) | (n
n, (()
l,[Edge n (Maybe a)]
inc,[Edge n (Maybe a)]
_)) <- Map n ((), [Edge n (Maybe a)], [Edge n (Maybe a)])
-> [(n, ((), [Edge n (Maybe a)], [Edge n (Maybe a)]))]
forall k a. Map k a -> [(k, a)]
Map.toList (Graph n () (Maybe a)
-> Map n ((), [Edge n (Maybe a)], [Edge n (Maybe a)])
forall n a b. Ord n => Graph n a b -> NodeInfo n a b
nodeInfo Graph n () (Maybe a)
g)]
               ([n]
c',[[(Node n (Maybe a), [Edge n ()])]]
is') = ([n]
 -> (Node n (), [Edge n (Maybe a)])
 -> ([n], [(Node n (Maybe a), [Edge n ()])]))
-> [n]
-> [(Node n (), [Edge n (Maybe a)])]
-> ([n], [[(Node n (Maybe a), [Edge n ()])]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL [n]
-> (Node n (), [Edge n (Maybe a)])
-> ([n], [(Node n (Maybe a), [Edge n ()])])
forall n a.
(Ord n, Eq a) =>
[n]
-> (Node n (), [Edge n (Maybe a)])
-> ([n], [(Node n (Maybe a), [Edge n ()])])
fixIncoming [n]
c [(Node n (), [Edge n (Maybe a)])]
is
               ([Node n (Maybe a)]
ns,[[Edge n ()]]
ess) = [(Node n (Maybe a), [Edge n ()])]
-> ([Node n (Maybe a)], [[Edge n ()]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([[(Node n (Maybe a), [Edge n ()])]]
-> [(Node n (Maybe a), [Edge n ()])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Node n (Maybe a), [Edge n ()])]]
is')


-- | Remove empty nodes which are not start or final, and have
--   exactly one outgoing edge or exactly one incoming edge.
removeTrivialEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
removeTrivialEmptyNodes :: FA n (Maybe a) () -> FA n (Maybe a) ()
removeTrivialEmptyNodes = FA n (Maybe a) () -> FA n (Maybe a) ()
forall n a. Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
pruneUnusable (FA n (Maybe a) () -> FA n (Maybe a) ())
-> (FA n (Maybe a) () -> FA n (Maybe a) ())
-> FA n (Maybe a) ()
-> FA n (Maybe a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FA n (Maybe a) () -> FA n (Maybe a) ()
forall a n. (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
skipSimpleEmptyNodes

-- | Move edges to empty nodes to point to the next node(s).
--   This is not done if the pointed-to node is a final node.
skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
skipSimpleEmptyNodes :: FA n (Maybe a) () -> FA n (Maybe a) ()
skipSimpleEmptyNodes FA n (Maybe a) ()
fa = (Graph n (Maybe a) () -> Graph n (Maybe a) ())
-> FA n (Maybe a) () -> FA n (Maybe a) ()
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph Graph n (Maybe a) () -> Graph n (Maybe a) ()
forall a. Graph n (Maybe a) () -> Graph n (Maybe a) ()
og FA n (Maybe a) ()
fa
  where
  og :: Graph n (Maybe a) () -> Graph n (Maybe a) ()
og g :: Graph n (Maybe a) ()
g@(Graph [n]
c [Node n (Maybe a)]
ns [Edge n ()]
es) = if [Edge n ()]
es' [Edge n ()] -> [Edge n ()] -> Bool
forall a. Eq a => a -> a -> Bool
== [Edge n ()]
es then Graph n (Maybe a) ()
g else Graph n (Maybe a) () -> Graph n (Maybe a) ()
og ([n] -> [Node n (Maybe a)] -> [Edge n ()] -> Graph n (Maybe a) ()
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
c [Node n (Maybe a)]
ns [Edge n ()]
es')
    where
    es' :: [Edge n ()]
es' = (Edge n () -> [Edge n ()]) -> [Edge n ()] -> [Edge n ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Edge n () -> [Edge n ()]
forall a. (a, n, ()) -> [(a, n, ())]
changeEdge [Edge n ()]
es
    info :: NodeInfo n (Maybe a) ()
info = Graph n (Maybe a) () -> NodeInfo n (Maybe a) ()
forall n a b. Ord n => Graph n a b -> NodeInfo n a b
nodeInfo Graph n (Maybe a) ()
g
    changeEdge :: (a, n, ()) -> [(a, n, ())]
changeEdge e :: (a, n, ())
e@(a
f,n
t,())
      | Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (NodeInfo n (Maybe a) () -> n -> Maybe a
forall n a b. Ord n => NodeInfo n a b -> n -> a
getNodeLabel NodeInfo n (Maybe a) ()
info n
t)
       -- && (i * o <= i + o)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (FA n (Maybe a) () -> n -> Bool
forall n a b. Eq n => FA n a b -> n -> Bool
isFinal FA n (Maybe a) ()
fa n
t)
          = [ (a
f,n
t',()) | (n
_,n
t',()) <- NodeInfo n (Maybe a) () -> n -> [Edge n ()]
forall n a b. Ord n => NodeInfo n a b -> n -> [Edge n b]
getOutgoing NodeInfo n (Maybe a) ()
info n
t]
      | Bool
otherwise = [(a, n, ())
e]
--     where i = inDegree info t
--           o = outDegree info t

isInternal :: Eq n => FA n a b -> n -> Bool
isInternal :: FA n a b -> n -> Bool
isInternal (FA Graph n a b
_ n
start [n]
final) n
n = n
n n -> n -> Bool
forall a. Eq a => a -> a -> Bool
/= n
start Bool -> Bool -> Bool
&& n
n n -> [n] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [n]
final

isFinal :: Eq n => FA n a b -> n -> Bool
isFinal :: FA n a b -> n -> Bool
isFinal (FA Graph n a b
_ n
_ [n]
final) n
n = n
n n -> [n] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [n]
final

-- | Remove all internal nodes with no incoming edges
--   or no outgoing edges.
pruneUnusable :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
pruneUnusable :: FA n (Maybe a) () -> FA n (Maybe a) ()
pruneUnusable FA n (Maybe a) ()
fa = (Graph n (Maybe a) () -> Graph n (Maybe a) ())
-> FA n (Maybe a) () -> FA n (Maybe a) ()
forall n a b c d.
(Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph Graph n (Maybe a) () -> Graph n (Maybe a) ()
forall a b. Graph n a b -> Graph n a b
f FA n (Maybe a) ()
fa
 where
 f :: Graph n a b -> Graph n a b
f Graph n a b
g = if Set n -> Bool
forall a. Set a -> Bool
Set.null Set n
rns then Graph n a b
g else Graph n a b -> Graph n a b
f (Set n -> Graph n a b -> Graph n a b
forall n a b. Ord n => Set n -> Graph n a b -> Graph n a b
removeNodes Set n
rns Graph n a b
g)
  where info :: NodeInfo n a b
info = Graph n a b -> NodeInfo n a b
forall n a b. Ord n => Graph n a b -> NodeInfo n a b
nodeInfo Graph n a b
g
        rns :: Set n
rns = [n] -> Set n
forall a. Ord a => [a] -> Set a
Set.fromList [ n
n | (n
n,a
_) <- Graph n a b -> [(n, a)]
forall n a b. Graph n a b -> [Node n a]
nodes Graph n a b
g,
                             FA n (Maybe a) () -> n -> Bool
forall n a b. Eq n => FA n a b -> n -> Bool
isInternal FA n (Maybe a) ()
fa n
n,
                             NodeInfo n a b -> n -> Int
forall n a b. Ord n => NodeInfo n a b -> n -> Int
inDegree NodeInfo n a b
info n
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                             Bool -> Bool -> Bool
|| NodeInfo n a b -> n -> Int
forall n a b. Ord n => NodeInfo n a b -> n -> Int
outDegree NodeInfo n a b
info n
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0]

fixIncoming :: (Ord n, Eq a) => [n]
            -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges
            -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their
                                                      -- incoming edges.
fixIncoming :: [n]
-> (Node n (), [Edge n (Maybe a)])
-> ([n], [(Node n (Maybe a), [Edge n ()])])
fixIncoming [n]
cs c :: (Node n (), [Edge n (Maybe a)])
c@((n
n,()),[Edge n (Maybe a)]
es) = ([n]
cs'', ((n
n,Maybe a
forall a. Maybe a
Nothing),[Edge n ()]
es')(Node n (Maybe a), [Edge n ()])
-> [(Node n (Maybe a), [Edge n ()])]
-> [(Node n (Maybe a), [Edge n ()])]
forall a. a -> [a] -> [a]
:[(Node n (Maybe a), [Edge n ()])]
newContexts)
  where ls :: [Maybe a]
ls = [Maybe a] -> [Maybe a]
forall a. Eq a => [a] -> [a]
nub ([Maybe a] -> [Maybe a]) -> [Maybe a] -> [Maybe a]
forall a b. (a -> b) -> a -> b
$ (Edge n (Maybe a) -> Maybe a) -> [Edge n (Maybe a)] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map Edge n (Maybe a) -> Maybe a
forall n b. Edge n b -> b
edgeLabel [Edge n (Maybe a)]
es
        ([n]
cs',[n]
cs'') = Int -> [n] -> ([n], [n])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Maybe a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe a]
ls) [n]
cs
        newNodes :: [Node n (Maybe a)]
newNodes = [n] -> [Maybe a] -> [Node n (Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [n]
cs' [Maybe a]
ls
        es' :: [Edge n ()]
es' = [ (n
x,n
n,()) | n
x <- (Node n (Maybe a) -> n) -> [Node n (Maybe a)] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map Node n (Maybe a) -> n
forall a b. (a, b) -> a
fst [Node n (Maybe a)]
newNodes ]
        -- separate cyclic and non-cyclic edges
        ([Edge n (Maybe a)]
cyc,[Edge n (Maybe a)]
ncyc) = (Edge n (Maybe a) -> Bool)
-> [Edge n (Maybe a)] -> ([Edge n (Maybe a)], [Edge n (Maybe a)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ (n
f,n
_,Maybe a
_) -> n
f n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
n) [Edge n (Maybe a)]
es
                  -- keep all incoming non-cyclic edges with the right label
        to :: (b, Maybe a) -> [(n, b, ())]
to (b
x,Maybe a
l) = [ (n
f,b
x,()) | (n
f,n
_,Maybe a
l') <- [Edge n (Maybe a)]
ncyc, Maybe a
l Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe a
l']
                  -- for each cyclic edge with the right label,
                  -- add an edge from each of the new nodes (including this one)
                  [(n, b, ())] -> [(n, b, ())] -> [(n, b, ())]
forall a. [a] -> [a] -> [a]
++ [ (n
y,b
x,()) | (n
f,n
_,Maybe a
l') <- [Edge n (Maybe a)]
cyc, Maybe a
l Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe a
l', (n
y,Maybe a
_) <- [Node n (Maybe a)]
newNodes]
        newContexts :: [(Node n (Maybe a), [Edge n ()])]
newContexts = [ (Node n (Maybe a)
v, Node n (Maybe a) -> [Edge n ()]
forall b. (b, Maybe a) -> [(n, b, ())]
to Node n (Maybe a)
v) | Node n (Maybe a)
v <- [Node n (Maybe a)]
newNodes ]

--alphabet :: Eq b => Graph n a (Maybe b) -> [b]
--alphabet = nub . catMaybes . map edgeLabel . edges

determinize :: Ord a => NFA a -> DFA a
determinize :: NFA a -> DFA a
determinize (FA Graph Int () (Maybe a)
g Int
s [Int]
f) = let (Set (Set Int)
ns,Set (Set Int, Set Int, a)
es) = Set (Set Int)
-> Set (Set Int)
-> Set (Set Int, Set Int, a)
-> (Set (Set Int), Set (Set Int, Set Int, a))
h (Set Int -> Set (Set Int)
forall a. a -> Set a
Set.singleton Set Int
start) Set (Set Int)
forall a. Set a
Set.empty Set (Set Int, Set Int, a)
forall a. Set a
Set.empty
                             ([Set Int]
ns',[(Set Int, Set Int, a)]
es') = (Set (Set Int) -> [Set Int]
forall a. Set a -> [a]
Set.toList Set (Set Int)
ns, Set (Set Int, Set Int, a) -> [(Set Int, Set Int, a)]
forall a. Set a -> [a]
Set.toList Set (Set Int, Set Int, a)
es)
                             final :: [Set Int]
final = (Set Int -> Bool) -> [Set Int] -> [Set Int]
forall a. (a -> Bool) -> [a] -> [a]
filter Set Int -> Bool
isDFAFinal [Set Int]
ns'
                             fa :: FA (Set Int) () a
fa = Graph (Set Int) () a -> Set Int -> [Set Int] -> FA (Set Int) () a
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA ([Set Int]
-> [Node (Set Int) ()]
-> [(Set Int, Set Int, a)]
-> Graph (Set Int) () a
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [Set Int]
forall a. HasCallStack => a
undefined [(Set Int
n,()) | Set Int
n <- [Set Int]
ns'] [(Set Int, Set Int, a)]
es') Set Int
start [Set Int]
final
                         in [Int] -> FA (Set Int) () a -> DFA a
forall x y a b. Ord x => [y] -> FA x a b -> FA y a b
renameStates [Int
0..] FA (Set Int) () a
fa
  where info :: NodeInfo Int () (Maybe a)
info = Graph Int () (Maybe a) -> NodeInfo Int () (Maybe a)
forall n a b. Ord n => Graph n a b -> NodeInfo n a b
nodeInfo Graph Int () (Maybe a)
g
--        reach = nodesReachable out
        start :: Set Int
start = NodeInfo Int () (Maybe a) -> Set Int -> Set Int
forall n a b. Ord n => NodeInfo n a (Maybe b) -> Set n -> Set n
closure NodeInfo Int () (Maybe a)
info (Set Int -> Set Int) -> Set Int -> Set Int
forall a b. (a -> b) -> a -> b
$ Int -> Set Int
forall a. a -> Set a
Set.singleton Int
s
        isDFAFinal :: Set Int -> Bool
isDFAFinal Set Int
n = Bool -> Bool
not (Set Int -> Bool
forall a. Set a -> Bool
Set.null ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int]
f Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set Int
n))
        h :: Set (Set Int)
-> Set (Set Int)
-> Set (Set Int, Set Int, a)
-> (Set (Set Int), Set (Set Int, Set Int, a))
h Set (Set Int)
currentStates Set (Set Int)
oldStates Set (Set Int, Set Int, a)
es
            | Set (Set Int) -> Bool
forall a. Set a -> Bool
Set.null Set (Set Int)
currentStates = (Set (Set Int)
oldStates,Set (Set Int, Set Int, a)
es)
            | Bool
otherwise = ((Set (Set Int)
-> Set (Set Int)
-> Set (Set Int, Set Int, a)
-> (Set (Set Int), Set (Set Int, Set Int, a))
h (Set (Set Int)
 -> Set (Set Int)
 -> Set (Set Int, Set Int, a)
 -> (Set (Set Int), Set (Set Int, Set Int, a)))
-> Set (Set Int)
-> Set (Set Int)
-> Set (Set Int, Set Int, a)
-> (Set (Set Int), Set (Set Int, Set Int, a))
forall a b. (a -> b) -> a -> b
$! Set (Set Int)
uniqueNewStates) (Set (Set Int)
 -> Set (Set Int, Set Int, a)
 -> (Set (Set Int), Set (Set Int, Set Int, a)))
-> Set (Set Int)
-> Set (Set Int, Set Int, a)
-> (Set (Set Int), Set (Set Int, Set Int, a))
forall a b. (a -> b) -> a -> b
$! Set (Set Int)
allOldStates) (Set (Set Int, Set Int, a)
 -> (Set (Set Int), Set (Set Int, Set Int, a)))
-> Set (Set Int, Set Int, a)
-> (Set (Set Int), Set (Set Int, Set Int, a))
forall a b. (a -> b) -> a -> b
$! Set (Set Int, Set Int, a)
es'
            where
            allOldStates :: Set (Set Int)
allOldStates = Set (Set Int)
oldStates Set (Set Int) -> Set (Set Int) -> Set (Set Int)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (Set Int)
currentStates
            (Set (Set Int)
newStates,Set (Set Int, Set Int, a)
es') = [Set Int]
-> Set (Set Int)
-> Set (Set Int, Set Int, a)
-> (Set (Set Int), Set (Set Int, Set Int, a))
new (Set (Set Int) -> [Set Int]
forall a. Set a -> [a]
Set.toList Set (Set Int)
currentStates) Set (Set Int)
forall a. Set a
Set.empty Set (Set Int, Set Int, a)
es
            uniqueNewStates :: Set (Set Int)
uniqueNewStates = Set (Set Int)
newStates Set (Set Int) -> Set (Set Int) -> Set (Set Int)
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (Set Int)
allOldStates
        -- Get the sets of states reachable from the given states
        -- by consuming one symbol, and the associated edges.
        new :: [Set Int]
-> Set (Set Int)
-> Set (Set Int, Set Int, a)
-> (Set (Set Int), Set (Set Int, Set Int, a))
new [] Set (Set Int)
rs Set (Set Int, Set Int, a)
es = (Set (Set Int)
rs,Set (Set Int, Set Int, a)
es)
        new (Set Int
n:[Set Int]
ns) Set (Set Int)
rs Set (Set Int, Set Int, a)
es = [Set Int]
-> Set (Set Int)
-> Set (Set Int, Set Int, a)
-> (Set (Set Int), Set (Set Int, Set Int, a))
new [Set Int]
ns Set (Set Int)
rs' Set (Set Int, Set Int, a)
es'
          where cs :: [(a, Set Int)]
cs = NodeInfo Int () (Maybe a) -> Set Int -> [(a, Set Int)]
forall n b a.
(Ord n, Ord b) =>
NodeInfo n a (Maybe b) -> Set n -> [(b, Set n)]
reachable NodeInfo Int () (Maybe a)
info Set Int
n --reachable reach n
                rs' :: Set (Set Int)
rs' = Set (Set Int)
rs Set (Set Int) -> Set (Set Int) -> Set (Set Int)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [Set Int] -> Set (Set Int)
forall a. Ord a => [a] -> Set a
Set.fromList (((a, Set Int) -> Set Int) -> [(a, Set Int)] -> [Set Int]
forall a b. (a -> b) -> [a] -> [b]
map (a, Set Int) -> Set Int
forall a b. (a, b) -> b
snd [(a, Set Int)]
cs)
                es' :: Set (Set Int, Set Int, a)
es' = Set (Set Int, Set Int, a)
es Set (Set Int, Set Int, a)
-> Set (Set Int, Set Int, a) -> Set (Set Int, Set Int, a)
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [(Set Int, Set Int, a)] -> Set (Set Int, Set Int, a)
forall a. Ord a => [a] -> Set a
Set.fromList [(Set Int
n,Set Int
s,a
c) | (a
c,Set Int
s) <- [(a, Set Int)]
cs]


-- | Get all the nodes reachable from a list of nodes by only empty edges.
closure :: Ord n => NodeInfo n a (Maybe b) -> Set n -> Set n
closure :: NodeInfo n a (Maybe b) -> Set n -> Set n
closure NodeInfo n a (Maybe b)
info Set n
x = Set n -> Set n -> Set n
closure_ Set n
x Set n
x
  where closure_ :: Set n -> Set n -> Set n
closure_ Set n
acc Set n
check | Set n -> Bool
forall a. Set a -> Bool
Set.null Set n
check = Set n
acc
                           | Bool
otherwise = Set n -> Set n -> Set n
closure_ Set n
acc' Set n
check'
            where
            reach :: Set n
reach = [n] -> Set n
forall a. Ord a => [a] -> Set a
Set.fromList [n
y | n
x <- Set n -> [n]
forall a. Set a -> [a]
Set.toList Set n
check,
                                      (n
_,n
y,Maybe b
Nothing) <- NodeInfo n a (Maybe b) -> n -> [(n, n, Maybe b)]
forall n a b. Ord n => NodeInfo n a b -> n -> [Edge n b]
getOutgoing NodeInfo n a (Maybe b)
info n
x]
            acc' :: Set n
acc' = Set n
acc Set n -> Set n -> Set n
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set n
reach
            check' :: Set n
check' = Set n
reach Set n -> Set n -> Set n
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set n
acc

-- | Get a map of labels to sets of all nodes reachable
--   from a the set of nodes by one edge with the given
--   label and then any number of empty edges.
reachable :: (Ord n,Ord b) => NodeInfo n a (Maybe b) -> Set n -> [(b,Set n)]
reachable :: NodeInfo n a (Maybe b) -> Set n -> [(b, Set n)]
reachable NodeInfo n a (Maybe b)
info Set n
ns = Map b (Set n) -> [(b, Set n)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map b (Set n) -> [(b, Set n)]) -> Map b (Set n) -> [(b, Set n)]
forall a b. (a -> b) -> a -> b
$ ([n] -> Set n) -> Map b [n] -> Map b (Set n)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (NodeInfo n a (Maybe b) -> Set n -> Set n
forall n a b. Ord n => NodeInfo n a (Maybe b) -> Set n -> Set n
closure NodeInfo n a (Maybe b)
info (Set n -> Set n) -> ([n] -> Set n) -> [n] -> Set n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [n] -> Set n
forall a. Ord a => [a] -> Set a
Set.fromList) (Map b [n] -> Map b (Set n)) -> Map b [n] -> Map b (Set n)
forall a b. (a -> b) -> a -> b
$ NodeInfo n a (Maybe b) -> Set n -> Map b [n]
forall k a a.
(Ord k, Ord a) =>
NodeInfo a a (Maybe k) -> Set a -> Map k [a]
reachable1 NodeInfo n a (Maybe b)
info Set n
ns
reachable1 :: NodeInfo a a (Maybe k) -> Set a -> Map k [a]
reachable1 NodeInfo a a (Maybe k)
info Set a
ns = ([a] -> [a] -> [a]) -> [(k, [a])] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) [(k
c, [a
y]) | a
n <- Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
ns, (a
_,a
y,Just k
c) <- NodeInfo a a (Maybe k) -> a -> [(a, a, Maybe k)]
forall n a b. Ord n => NodeInfo n a b -> n -> [Edge n b]
getOutgoing NodeInfo a a (Maybe k)
info a
n]

reverseNFA :: NFA a -> NFA a
reverseNFA :: NFA a -> NFA a
reverseNFA (FA Graph Int () (Maybe a)
g Int
s [Int]
fs) = Graph Int () (Maybe a) -> Int -> [Int] -> NFA a
forall n a b. Graph n a b -> n -> [n] -> FA n a b
FA Graph Int () (Maybe a)
g''' Int
s' [Int
s]
    where g' :: Graph Int () (Maybe a)
g' = Graph Int () (Maybe a) -> Graph Int () (Maybe a)
forall n a b. Graph n a b -> Graph n a b
reverseGraph Graph Int () (Maybe a)
g
          (Graph Int () (Maybe a)
g'',Int
s') = () -> Graph Int () (Maybe a) -> (Graph Int () (Maybe a), Int)
forall a n b. a -> Graph n a b -> (Graph n a b, n)
newNode () Graph Int () (Maybe a)
g'
          g''' :: Graph Int () (Maybe a)
g''' = [Edge Int (Maybe a)]
-> Graph Int () (Maybe a) -> Graph Int () (Maybe a)
forall n b a. [Edge n b] -> Graph n a b -> Graph n a b
newEdges [(Int
s',Int
f,Maybe a
forall a. Maybe a
Nothing) | Int
f <- [Int]
fs] Graph Int () (Maybe a)
g''

dfa2nfa :: DFA a -> NFA a
dfa2nfa :: DFA a -> NFA a
dfa2nfa = (a -> Maybe a) -> DFA a -> NFA a
forall b c n a. (b -> c) -> FA n a b -> FA n a c
mapTransitions a -> Maybe a
forall a. a -> Maybe a
Just

--
-- * Visualization
--

prFAGraphviz :: (Eq n,Show n) => FA n String String -> String
prFAGraphviz :: FA n [Char] [Char] -> [Char]
prFAGraphviz  = Graph -> [Char]
Dot.prGraphviz (Graph -> [Char])
-> (FA n [Char] [Char] -> Graph) -> FA n [Char] [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FA n [Char] [Char] -> Graph
forall n. (Eq n, Show n) => FA n [Char] [Char] -> Graph
faToGraphviz

--prFAGraphviz_ :: (Eq n,Show n,Show a, Show b) => FA n a b -> String
--prFAGraphviz_  = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show

faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
faToGraphviz :: FA n [Char] [Char] -> Graph
faToGraphviz (FA (Graph [n]
_ [Node n [Char]]
ns [Edge n [Char]]
es) n
s [n]
f)
    = GraphType
-> Maybe [Char] -> [Attr] -> [Node] -> [Edge] -> [Graph] -> Graph
Dot.Graph GraphType
Dot.Directed Maybe [Char]
forall a. Maybe a
Nothing [] ((Node n [Char] -> Node) -> [Node n [Char]] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Node n [Char] -> Node
mkNode [Node n [Char]]
ns) ((Edge n [Char] -> Edge) -> [Edge n [Char]] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map Edge n [Char] -> Edge
forall a a. (Show a, Show a) => (a, a, [Char]) -> Edge
mkEdge [Edge n [Char]]
es) []
   where mkNode :: Node n [Char] -> Node
mkNode (n
n,[Char]
l) = [Char] -> [Attr] -> Node
Dot.Node (n -> [Char]
forall a. Show a => a -> [Char]
show n
n) [Attr]
attrs
          where attrs :: [Attr]
attrs = [([Char]
"label",[Char]
l)]
                 [Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++ if n
n n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
s then [([Char]
"shape",[Char]
"box")] else []
                 [Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++ if n
n n -> [n] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [n]
f then [([Char]
"style",[Char]
"bold")] else []
         mkEdge :: (a, a, [Char]) -> Edge
mkEdge (a
x,a
y,[Char]
l) = [Char] -> [Char] -> [Attr] -> Edge
Dot.Edge (a -> [Char]
forall a. Show a => a -> [Char]
show a
x) (a -> [Char]
forall a. Show a => a -> [Char]
show a
y) [([Char]
"label",[Char]
l)]

--
-- * Utilities
--

--lookups :: Ord k => [k] -> Map k a -> [a]
--lookups xs m = mapMaybe (flip Map.lookup m) xs