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","*")]