-- Informatics 1 - Functional Programming 
-- Tutorial 8
--
-- Solutions
--
-- Remember: there are many possible solutions, and if your solution produces
-- the right results, then it is (most likely) correct. However, if your code
-- looks far more complicated than these sample solutions, then you're probably
-- making things too difficult for yourself---try to keep it simple!


import Data.List
import Test.QuickCheck



-- Type declarations

type FSM q = ([q], Alphabet, q, [q], [Transition q])
type Alphabet = [Char]
type Transition q = (q, Char, q)



-- Example machines

m1 :: FSM Int
m1 = ([0,1,2,3,4],
      ['a','b'],
      0,
      [4],
      [(0,'a',1), (0,'b',1), (0,'a',2), (0,'b',2),
       (1,'b',4), (2,'a',3), (2,'b',3), (3,'b',4),
       (4,'a',4), (4,'b',4)])

m2 :: FSM Char
m2 = (['A','B','C','D'],
      ['0','1'],
      'B',
      ['A','B','C'],
      [('A', '0', 'D'), ('A', '1', 'B'),
       ('B', '0', 'A'), ('B', '1', 'C'),
       ('C', '0', 'B'), ('C', '1', 'D'),
       ('D', '0', 'D'), ('D', '1', 'D')])

dm1 :: FSM [Int] 
dm1 =  ([[],[0],[1,2],[3],[3,4],[4]],
        ['a','b'],
        [0],
        [[3,4],[4]],
        [([],   'a',[]),
         ([],   'b',[]),
         ([0],  'a',[1,2]),
         ([0],  'b',[1,2]),
         ([1,2],'a',[3]),
         ([1,2],'b',[3,4]),
         ([3],  'a',[]),
         ([3],  'b',[4]),
         ([3,4],'a',[4]),
         ([3,4],'b',[4]),
         ([4],  'a',[4]),
         ([4],  'b',[4])])



-- 1.
states :: FSM q -> [q]
alph   :: FSM q -> Alphabet
start  :: FSM q -> q
final  :: FSM q -> [q]
trans  :: FSM q -> [Transition q]

states (u, _, _, _, _) = u
alph   (_, a, _, _, _) = a
start  (_, _, s, _, _) = s
final  (_, _, _, f, _) = f
trans  (_, _, _, _, t) = t


-- 2.
delta :: (Eq q) => FSM q -> q -> Char -> [q]
delta m state symbol = [ q1 | (q0, x, q1) <- trans m, q0 == state, x == symbol ]


-- 3.
accepts :: (Eq q) => FSM q -> String -> Bool
accepts m xs = acceptsFrom m (start m) xs

acceptsFrom :: (Eq q) => FSM q -> q -> String -> Bool
acceptsFrom m q "" = q `elem` final m
acceptsFrom m q (x:xs) = or [ acceptsFrom m q' xs | q' <- delta m q x ]


-- 4.
canonical :: (Ord q) => [q] -> [q]
canonical = nub . sort


-- 5.
ddelta :: (Ord q) => FSM q -> [q] -> Char -> [q]
ddelta m superq symbol =
    canonical (concat [ delta m q symbol | q <- superq ])

-- 6.
next :: (Ord q) => FSM q -> [[q]] -> [[q]]
next m superqs = canonical (
     superqs ++ [ddelta m superq symbol | superq <- superqs, symbol <- alph m])


-- 7.
reachable :: (Ord q) => FSM q -> [[q]] -> [[q]]
reachable m superqs = if superqs' == superqs then superqs
                      else reachable m superqs'
                          where
                            superqs' = next m superqs

-- 8.
containsFinal m superq = or [finalq == q | finalq <- final m, q <- superq]

dfinal :: (Ord q) => FSM q -> [[q]] -> [[q]]
dfinal m superqs = filter (containsFinal m) superqs

--    (alternate solution, using list comprehension and partial application)
-- dfinal m superqs = [superq | superq <- superqs, any (`elem` final m) superq]


-- 9.
dtrans :: (Ord q) => FSM q -> [[q]] -> [Transition [q]]
dtrans m superqs = 
    [(sq, symbol, ddelta m sq symbol) | sq <- superqs, symbol <- alph m]


-- 10.
deterministic :: (Ord q) => FSM q -> FSM [q]
deterministic m = (states, alph m, [start m], dfinal m states, dtrans m states)
  where states = reachable m [[start m]]


-- 11.
prop_deterministic :: FSM Int -> [Int] -> Bool
prop_deterministic m xs  =  accepts m str == accepts (deterministic m) str
    where
      str  =  makeInput (alph m) xs

makeInput :: Alphabet -> [Int] -> String
makeInput [] _     =  error "makeInput: empty alphabet"
makeInput alph xs  =  map f xs
    where f x  =  alph !! (x `mod` length alph)


-- OPTIONAL MATERIAL ------------------------------------

data Step q = State q 
            | Symbol Char
            deriving (Eq )
                             
type Trace q = [Step q]

instance (Show q) => Show (Step q) where
  show (State q)  = show q
  show (Symbol x) = [x]

-- 12.
      
traces :: Eq q => FSM q -> String -> [Trace q]
traces m  =  trace (start m)
    where
      trace q []     = [ [State q] | q `elem` final m ]
      trace q (x:xs) = [ [State q, Symbol x] ++ t | q1 <- delta m q x, t <- trace q1 xs ]