{- IB102 Automaty a gramatiky -}
{- Martin Ukrop, UCO 374297 -}

-- | Task 5 - Construct automaton :A from given A ("doubles letters in a word")
-- | used packages: only standard

import Data.Map (Map, foldrWithKey, unions, singleton, toAscList, fromList)
import System.IO (isEOF)

-- | plati pre cely program:
-- | m = pocet znakov abecedy
-- | n = pocet stavov automatu (priebehom algoritmu sa meni!)
-- | trans = vsetky prechody = asociativna mapa, ktora dvojici (stav, symbol) priradi novy stav
-- | init = inicialny stav
-- | final = zoznam koncovych stavov

-- | Deterministic Definite Automaton (|Q|, |S|, tansitions, init, [final])
-- | transitions are in Map asigning state to pair (state, symbol)
type DA = (Int, Int, Map (Int,Char) Int, Int, [Int])
-- | transitions in a list structure [(from, symbol), to)]
type TransList = [((Int, Char), Int)]

-- | funkcia, ktora transformuje automat zadanym sposobom ("zdvoji kazde pismeno v slove")
-- | myslienka: kazdy prechod p --(a)--> q nahradim dvomi prechodmi cez novy stav
-- | takze vznikne nieco ako p --(a)--> pq --(a)--> q
-- | pre zachovanie totality idu prechody z pq pod ostatnymi symbolmi do tzv. cierna diera
-- | povodne stavy sa zachovavaju s povodnymi cislami
-- | cierna diera ma cislo (pocet_povodnych_stavov + 1)
f :: DA -> DA
f (n, m, trans, init, final) = foldrWithKey {-postupny prechod cez vsetky dane prechody-}
				(\(p,a) q (n2, m, trans2, init, final) -> (n2+1, m, unions [
						{-prechody doteraz-}			trans2, 
						{-novy prechod do medzistavu pq-}	singleton (p,a) (n2+1), 
						{-prechod z medzistavu pq naspat-}	singleton (n2+1,a) q, 
						{-prechody z pq do ciernej diery-}	allTrans (n2+1) (n+1)],
									   init, final))
				(n+1, m, allTrans (n+1) (n+1), init, final) {-cierna s prechodmi do seba-}
				trans {-mapa povodnych prechodov-}
	where allTrans from to = fromList . take m $ zip (zip (repeat from) ['a','b'..]) (repeat to)

-- | vypisuje DA v tvare zo zadania do stdout
writeDA :: DA -> IO ()
writeDA (n, m, trans, init, final) = mapM_ putStrLn [show n, show m, show init, unwords $ map show final, 
						     writeTrans m $ toAscList trans]
	where writeTrans m trans = if b == [] then unwords $ map (show . snd) a
				              else writeTrans m a ++ "\n" ++ writeTrans m b
				   where (a,b) = splitAt m trans

-- | nacitava DA v tvare zo zadania zo stdin
readDA :: IO DA
readDA = do n <- fmap read getLine
	    m <- fmap read getLine
	    init <- fmap read getLine
	    final <- fmap (map read . words) getLine
            trans <- fmap fromList (readTrans n)
	    return (n,m,trans,init,final)
	where readTrans n = mapM readRow [1..n] >>= return . concat
	      readRow from = getLine >>= return . zip (zip (repeat from) ['a','b'..]) . map read . words

-- | reads DAs from stdin, transforms and writes out to stdout
main :: IO ()
main = do readDA >>= writeDA . f
	  isEOF >>= (\bool -> if bool then return ()
				      else putStrLn "" >> getLine >> main)