1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
|
import TRS
import Read
letDropping :: [Rule] -> [Rule]
letDropping rules = filter (not . letRule) (map (insertLetInRule rules) rules)
where
letRule (Rule f _ _) = take 4 (snd (break (=='#') f)) == "#LET"
insertLetInRule :: [Rule] -> Rule -> Rule
insertLetInRule rules (Rule f args exp) =
Rule f args (insertLetInExp rules exp)
insertLetInExp :: [Rule] -> Term -> Term
insertLetInExp _ (Var i) = Var i
insertLetInExp rls (Func Cons c args) =
Func Cons c (map (insertLetInExp rls) args)
insertLetInExp rls (Func Def f args) =
let (_,hashp) = break (=='#') f
in if null hashp || take 4 hashp /= "#LET"
then Func Def f (map (insertLetInExp rls) args)
else let letrules = funcRules f rls
in if length letrules /= 1
then error ("LetDropping: incorrect rules for "++f)
else let (largs,lexp) = head letrules
freenums = readNat (fst (break (=='_') (drop 4 hashp)))
in replaceLetCall f args freenums
(insertLetInRule rls (Rule f largs lexp))
replaceLetCall f args freenums (Rule _ largs lexp) =
if length args == length largs
then Func Def "LET"
(map (\ (v,e) -> Func Cons "(,)" [v,e])
(drop freenums (zip largs args))
++ [lexp])
else if null args
then Func Def "LAMBDA" (largs++[lexp])
else Func Def f args
where
exps2tuple exps =
if length exps == 1
then head exps
else Func Cons ("("++take (length exps - 1) (repeat ',')++")") exps
|