module Main where getStr Literal var var getStr Abstr term1 term2 Lam

 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
module Main where
getStr (Literal var) = var
getStr (Abstr term1 term2) = "Lam " ++ (term1) ++ " . " ++ (getStr term2)
getStr (Apply term1 term2) = "(" ++ (getStr term1) ++ ") (" ++ (getStr term2) ++ ")"
data Lam = Literal String
| Abstr String Lam
| Apply Lam Lam
eval (Literal var) = Literal var
eval (Abstr var body) = Abstr var (eval body) -- can be not evaluated
eval (Apply (Literal _) term2) = eval term2
eval (Apply (Abstr var body) term2) = eval (passLits body var term2)
eval (Apply term1 term2) = eval $ Apply (eval term1) (eval term2)
passLits (Abstr currVar term) var newLam | currVar == var =
Abstr (var ++ (show 0)) (passLits (rename term var) var newLam)
passLits (Abstr currVar term) var newLam | otherwise =
Abstr (currVar) (passLits (rename term var) var newLam)
passLits (Apply t1 t2) var newLam = Apply (passLits t1 var newLam) (passLits t2 var newLam)
passLits (Literal currVar) var newLam | currVar == var = newLam
passLits (Literal currVar) _ _ | otherwise = Literal currVar
passLits term var newLam = term
rename term name = rename' term name 0
where rename' :: Lam -> String -> Int -> Lam
rename' (Literal oldName) name i | oldName == name = Literal (name ++ (show i))
rename' (Literal oldName) _ _ | otherwise = Literal (oldName)
rename' (Apply t1 t2) name i = Apply (rename' t1 name i) (rename' t1 name i)
rename' (Abstr oldName t) name i | oldName == name = Abstr (name ++ (show (i+1))) (rename' t name (i+1))
rename' (Abstr oldName t) name i | otherwise = Abstr (oldName) (rename' t name (i))
main = print (getStr ( eval (Apply (Abstr "x" (Literal "x")) (Abstr "y" (Literal "y")))))