module Cbau where

-- finite automata and regular expressions (Skript, §§ 2.1 und 2.2)

 data Ext a = Epsilon | Def a deriving Eq

 instance Show a => Show (Ext a) where show Epsilon = "eps"
			               show (Def a) = show a	    

 iter :: Eq state => (state -> Ext input -> [state]) 
		     -> state -> [input] -> [state]
 iter delta q = foldl f (epsHull delta [q])
	        where f qs x = epsHull delta (joinMap (flip delta (Def x)) qs)
			      
 epsHull :: Eq state => (state -> Ext input -> [state]) -> [state] -> [state]
 epsHull delta qs = f qs qs 
	 where f qs visited = if null new then visited else f new (visited++new)
		     where new = joinMap (flip delta Epsilon) qs `minus` visited

 joinMap :: Eq b => (a -> [b]) -> [a] -> [b]
 joinMap f = foldl join [] . map f

 minus,join :: Eq a => [a] -> [a] -> [a]
 xs `minus` ys = [x | x <- xs, x `notElem` ys]
 xs `join` ys = xs++(ys `minus` xs)

 type NonDetAuto input output state = 
                       (state -> Ext input -> [state], state -> [output], state)
 type DetAuto input output state = 
                       (state -> input -> state, state -> output, state)

 makeDet :: (Eq state,Eq output) => 
                 NonDetAuto input output state -> DetAuto input [output] [state]
 makeDet (delta, beta, q0) = (delta', joinMap beta, epsHull delta [q0])
	    where delta' qs x = epsHull delta (joinMap (flip delta (Def x)) qs)

 data RegExp a = Const a | Eps | Empty | Seq (RegExp a) (RegExp a) | 
		 Par (RegExp a) (RegExp a) | Plus (RegExp a)

 refl e = Par e Eps
 star e = Par (Plus e) Eps

 reg0 = Seq (Const 0) (Seq (Const 1) (Const 2))
 reg1 = Plus (Const 0)
 reg2 = Par (Plus (Const 0)) (Plus (Const 1))
 reg3 = star (Par (Const 1) (Const 2))

 type IntAuto a = (NonDetAuto a Bool Int,[Int],[a])

 regToAuto :: Eq a => RegExp a -> IntAuto a

 regToAuto e = ((delta,beta,0),[0..nextq-1],symbols e)
	     where (delta,nextq) = autoRec e 0 1 (const (const [])) 2
		   beta q = if q == 1 then [True] else [False]
                   symbols (Const a)  = [a]
		   symbols (Seq e e') = symbols e `join` symbols e'
		   symbols (Par e e') = symbols e `join` symbols e'
		   symbols (Plus e)   = symbols e 
		   symbols _          = []

 autoRec :: Eq a => RegExp a   -> Int           -> Int
	         -- expression    initial state    final state 
		 -> (Int -> Ext a -> [Int]) -> Int 
		 -- delta		       next unused state
		 -> (Int -> Ext a -> [Int], Int)
		 -- (new delta, next unused state)
 autoRec (Const a) q q' delta nextq  = (upd2 delta q (Def a) q',nextq)
 autoRec Eps q q' delta nextq        = (upd2 delta q Epsilon q',nextq)
 autoRec Empty _ _ delta nextq       = (delta,nextq)
 autoRec (Seq e e') q q' delta nextq = autoRec e' nextq q' delta' nextq'
		       where (delta',nextq') = autoRec e q nextq delta (nextq+1)
 autoRec (Par e e') q q' delta nextq = autoRec e' q q' delta' nextq'
		       where (delta',nextq') = autoRec e q q' delta nextq
 autoRec (Plus e) q q' delta nextq   = (upd2 delta3 q1 Epsilon q',nextq1)
		       where q1 = nextq+1
                             (delta1,nextq1) = autoRec e nextq q1 delta (q1+1)
		             delta2 = upd2 delta1 q Epsilon nextq
 		             delta3 = upd2 delta2 q1 Epsilon nextq
		
 upd2 :: (Eq a,Eq b) => (a -> b -> [c]) -> a -> b -> c -> (a -> b -> [c])
 upd2 f a b c a' b' = if a == a' && b == b' then c:cs else cs where cs = f a' b'

 writeAuto :: (Eq a,Show a) => IntAuto a -> String
 writeAuto ((delta,beta,q0),qs,as) = initial++trips++finals
       where initial = "\ninitial state: "++show q0
	     trips = "\ntransition function:"++
		     fun2ToTrips delta qs (Epsilon:map Def as)
	     finals = "\nfinal states: "++show [i | i <- qs, True `elem` beta i]

 fun2ToTrips :: (Show a,Show b,Show c) => 
		(a -> b -> [c]) -> [a] -> [b] -> String
 fun2ToTrips f as bs = concatMap h [trip | trip@(_,_,_:_) <- concatMap g as]
		    where g a = [(a,b,f a b) | b <- bs]
			  h (a,b,cs) = '\n':show (a,b)++" leads to "++show cs

 mwa :: (Eq a,Show a) => RegExp a -> IO ()
 mwa = writeFile "autos" . writeAuto . regToAuto

-- Beispielgrammatik

 start = "S"
 nonterminals = words "S A B"
 terminals = words "c d *"  
 rules = [("S","A"),("A","A * B"),("A","B"),("B","c"),("B","d")]

-- Berechnung der first-Mengen (Skript, § 3.2)

 first :: String -> [String]						
 first ""    = [""]						          -- (1)
 first alpha = f (words alpha)
               where f (a:alpha) = if notNullable a then g a 
                                                    else g a `join` f alpha
		                   where (g,notNullable) = firstPlus

 firstPlus :: (String -> [String],String -> Bool)			  
 firstPlus = loop1 init (const True)
        where init = fold2 upd (const []) terminals (map single terminals)-- (2)
              single x = [x]
			     						  
 loop1 :: (String -> [String]) -> (String -> Bool)
		               -> (String -> [String],String -> Bool)
 loop1 f notNullable = if b then loop1 f' notNullable' else (f,notNullable)  
      where (b,f',notNullable') = loop2 rules False f notNullable

 loop2 :: [(String,String)] -> Bool -> (String -> [String]) -> (String -> Bool)
	  -> (Bool,String -> [String],String -> Bool)			   
 loop2 ((a,rhs):rules) b f notNullable = 
	  case search notNullable wrhs of                
               Just i -> loop2 rules (b || f a /= xs) (upd f a xs) notNullable
			 where xs = joinMap f (a:take (i+1) wrhs)         -- (3)
               _ -> loop2 rules (b || notNullable a) f (upd notNullable a False)
          where wrhs = words rhs
 loop2 _ b f notNullable = (b,f,notNullable)

 fold2 :: (a -> b -> c -> a) -> a -> [b] -> [c] -> a
 fold2 f a (x:xs) (y:ys) = fold2 f (f a x y) xs ys
 fold2 _ a _ _           = a

 upd :: Eq a => (a -> b) -> a -> b -> a -> b
 upd f x y z = if x == z then y else f z

 search :: (a -> Bool) -> [a] -> Maybe Int
 search f s = g s 0 where g (x:s) i = if f x then Just i else g s (i+1)
                          g _ _     = Nothing
 
 fs = first "S" -- ["c","d"]

-- Berechnung des LR(1)-Automaten (Skript, § 3.5)

 data Set a = Set {list::[a]}

 instance Eq a => Eq (Set a) where Set s == Set s' = all (`elem` s) s' &&
						     all (`elem` s') s
 
 instance Show a => Show (Set a) where show (Set s) = show s

 type LRState = Set (String,String,String,String)

 symbols = nonterminals++terminals

 q0 :: LRState
 q0 = Set [(a,[],alpha,"") | (a,alpha) <- rules, a == start]              -- (1)

 extend :: LRState -> LRState
 extend q = if q == q' then q else extend q'			  	  -- (2)
    where qL = list q
          q' = Set (qL `join` [(a,"",beta,y) | 
                                      (_,_,balpha,x) <- qL, (a,beta) <- rules,
			 	      not (null balpha), a == headw balpha,
				      y <- first (unwords (tailw balpha++[x]))]) 
 
 trans :: LRState -> String -> Maybe (String,LRState)
 trans q x = if null s then Nothing else Just (x,extend (Set s))
    where s = [(a,alpha++' ':x,unwords (tailw zbeta),y) 		  -- (3)
                                       | (a,alpha,zbeta,y) <- list q, 
                                         not (null zbeta), headw zbeta == x]

 headw = head . words
 tailw = tail . words

 type Transitions = [(LRState,String,LRState)]
 
 mkLRauto :: ([Int],[(Int,String,Int)]) 
 mkLRauto = (map encode qs,map f rel)
            where (qs,rel) = loop [extend q0] [] []
		  encode q = case search (== q) qs of Just i -> i
				                      _ -> 0
	          f (q,x,q') = (encode q,x,encode q')

 loop :: [LRState] -> [LRState] -> Transitions -> ([LRState],Transitions)
 loop (q:qs) visited rel = loop (foldl add qs nonVisited) visited' 
				(rel++map f allTrans)
                  where allTrans = map get (filter just (map (trans q) symbols))
                        visited' = add visited q
                        nonVisited = map snd allTrans `minus` visited'
                        f (x,q') = (q,x,q')
 loop _ qs2 rel = (qs2,rel)

 just :: Maybe a -> Bool
 just (Just _) = True
 just _ = False

 get :: Maybe a -> a
 get (Just x) = x
 
 add :: Eq a => [Set a] -> Set a -> [Set a]
 add s@(x:s') y = if x == y then s else x:add s' y
 add _ x        = [x]

{- fst (loop [extend q0] [] []) =
    [[("S","","A",""),("A","","A * B",""),("A","","B",""),("A","","A * B","*"),
      ("A","","B","*"),("B","","c",""),("B","","d",""),("B","","c","*"),
      ("B","","d","*")],
     [("S"," A","",""),("A"," A","* B",""),("A"," A","* B","*")],
     [("A"," B","",""),("A"," B","","*")],
     [("B"," c","",""),("B"," c","","*")],
     [("B"," d","",""),("B"," d","","*")],
     [("A"," A *","B",""),("A"," A *","B","*"),("B","","c",""),("B","","d",""),
      ("B","","c","*"),("B","","d","*")],
     [("A"," A * B","",""),("A"," A * B","","*")]]

   mkLRauto = ([0,1,2,3,4,5,6],
               [(0,"A",1),(0,"B",2),(0,"c",3),(0,"d",4),(1,"*",5),(5,"B",6),
                (5,"c",3),(5,"d",4)])
-}
 state = extend (Set [("S","","A","")])
-- [("S","","A",""),("A","","A * B",""),("A","","B",""),("A","","A * B","*"),
--  ("A","","B","*"),("B","","c",""),("B","","d",""),("B","","c","*"),
--  ("B","","d","*")]