DFA.hs

{-
 - DFA minimizer. See:
 -
 - https://www.tutorialspoint.com/automata_theory/dfa_minimization.htm
 -}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
module DFA (main) where

import Control.Monad.State.Lazy

import Data.List  (sort, nub, intercalate)
import Data.Maybe (fromMaybe)

data DFA s i = DFA { states :: [s]
                   , finals :: [s]
                   , inputs :: [i]
                   , step   :: [((s, i), s)]
                   }

instance (Show s, Show i) => Show (DFA s i) where
  show DFA{states, finals, inputs, step} = intercalate "\n"
                                                   [ "States: " ++ intercalate ", "         (map show states)
                                                   , "Finals: " ++ intercalate ", "         (map show finals)
                                                   , "Inputs: " ++ intercalate ", "         (map show inputs)
                                                   , "Step  : " ++ intercalate "\n        " (map show step)
                                                   ]

example :: DFA Char Int
example = DFA { states = ['a', 'b', 'c', 'd', 'e', 'f']
              , finals = ['c', 'd', 'e']
              , inputs = [0, 1]
              , step   = [ (('a', 0), 'b'), (('a', 1), 'c')
                         , (('b', 0), 'a'), (('b', 1), 'd')
                         , (('c', 0), 'e'), (('c', 1), 'f')
                         , (('d', 0), 'e'), (('d', 1), 'f')
                         , (('e', 0), 'e'), (('e', 1), 'f')
                         , (('f', 0), 'f'), (('f', 1), 'f')
                         ]
              }

newtype Search s a = Search (State [((s, s), Bool)] a) deriving (Functor, Applicative, Monad, MonadState [((s, s), Bool)])

recordVisited :: Ord s => s -> s -> Bool -> Search s ()
recordVisited a b isSame = do v <- get
                              put $ ((a, b), isSame) : [p | p@(ss, _) <- v, ss /= (a, b)]

isVisited :: Ord s => s -> s -> Search s (Maybe Bool)
isVisited a b = do v <- get
                   return $ lookup (a, b) v

sameSearch :: (Show s, Show i, Eq i, Ord s) => DFA s i -> (s, s) -> Search s Bool
sameSearch dfa@DFA{finals, step, inputs} (aIn, bIn)
   = do let (a, b) = if aIn <= bIn then (aIn, bIn) else (bIn, aIn)
        mv <- isVisited a b
        case mv of
          Just r  -> return r
          Nothing -> if (a `elem` finals) /= (b `elem` finals)
                        then do recordVisited a b False
                                return False
                        else do recordVisited a b True
                                let move s i = fromMaybe (error $ "No transition for: " ++ show (s, i)) ((s, i) `lookup` step)
                                bs <- mapM (\c -> sameSearch dfa (move a c, move b c)) inputs
                                let allSame = and bs
                                recordVisited a b allSame
                                return allSame

eqStates :: (Show s, Show i, Eq i, Ord s) => DFA s i -> [[s]]
eqStates dfa@DFA{states} = nub $ sort $ map classify states
  where initState  = [((s, s), True) | s <- states]
        pairs      = [(s1, s2) | s1 <- states, s2 <- states, s1 <= s2]
        runSearch  = let Search f = mapM (sameSearch dfa) pairs in execState f initState
        equivs     = [p | (p@(a, b), True) <- runSearch, a /= b]
        classify s = nub $ sort $ s : concat [[a, b] | (a, b) <- equivs, s == a || s == b]


minimize :: (Show s, Show i, Eq i, Ord s) => DFA s i -> DFA [s] i
minimize dfa@DFA{finals, inputs, step} = DFA { states = ss
                                             , finals = filter (any (`elem` finals)) ss
                                             , inputs = inputs
                                             , step   = [((s, i), locate (head s, i)) | s <- ss, i <- inputs]
                                             }
  where ss = eqStates dfa
        locate (s, i) = case (s, i) `lookup` step of
                         Nothing -> error $ "No transition for: " ++ show (s, i)
                         Just s' -> case [ns | ns <- ss, s' `elem` ns] of
                                      [n] -> n
                                      _   -> error $ "Cannot locate the transition for: " ++ show (s, i)

-- We get:
-- *DFA> main
-- States: 'a', 'b', 'c', 'd', 'e', 'f'
-- Finals: 'c', 'd', 'e'
-- Inputs: 0, 1
-- Step  : (('a',0),'b')
--         (('a',1),'c')
--         (('b',0),'a')
--         (('b',1),'d')
--         (('c',0),'e')
--         (('c',1),'f')
--         (('d',0),'e')
--         (('d',1),'f')
--         (('e',0),'e')
--         (('e',1),'f')
--         (('f',0),'f')
--         (('f',1),'f')
-- =====================================
-- States: "ab", "cde", "f"
-- Finals: "cde"
-- Inputs: 0, 1
-- Step  : (("ab",0),"ab")
--         (("ab",1),"cde")
--         (("cde",0),"cde")
--         (("cde",1),"f")
--         (("f",0),"f")
--         (("f",1),"f")
main :: IO ()
main = do print example
          putStrLn "====================================="
          print $ minimize example