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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
module McCarthy where
import Prelude hiding ((^), (+), null)
data Sexp = Atom String | Pair Sexp Sexp deriving Show
at = Atom
l [] = at"NIL"
l (x : xs) = Pair x (l xs)
t = l[l[at"AB",at"C"],at"D"]
atom (Atom _ ) = at"T"
atom (Pair _ _) = at"F"
eq (Atom x, Atom y)
| x == y = at"T"
| otherwise = at"F"
eq _ = error "undefined"
car (Pair e1 _) = e1
car _ = error "undefined"
cdr (Pair _ e2) = e2
cdr _ = error "undefined"
cons (e1, e2) = Pair e1 e2
cases ((Atom x, y) : ps)
| x == "T" = y
| x == "F" = cases ps
cases _ = error "undefined"
(^) p q = cases[(p, q), (at"T",at"F")]
(+) p q = cases[(p, at"T"), (at"T", q)]
n p = cases[(p, at"F"), (at"T", at"T")]
(-->) p q = cases[(p,q), (at"T",at"T")]
ff(x) = cases[(atom(x), x), (at"T",ff(car(x)))]
subst(x, y, z) = cases
[ (atom(z), cases[(eq(z, y), x), (at"T", z)])
, (at"T", cons(subst(x, y, car(z)), subst(x, y, cdr(z))))
]
equal(x, y) =
(atom(x) ^ atom(y) ^ eq(x,y)) +
(n (atom(x)) ^ n(atom(y)) ^ equal(car(x), car(y)) ^ equal(cdr(x), cdr(y)))
null(x) = atom(x) ^ eq(x, at"NIL")
append(x, y) = cases
[ (null(x), y)
, (at"T", cons(car(x), append(cdr(x),y)))
]
pair(x, y) = cases
[ (null(x) ^ null(y), at"NIL")
, (n(atom(x)) ^ n(atom(y)), cons(l[car(x), car(y)], pair(cdr(x), cdr(y))))
]
caar(x) = car(car(x))
cadar(x) = car(cdr(car(x)))
cadr(x) = car(cdr(x))
caddr(x) = car(cdr(cdr(x)))
caddar(x) = car(cdr(cdr(car(x))))
assoc(x, y) = cases
[ (eq(caar(y), x), cadar(y))
, (at"T", assoc(x, cdr(y)))
]
sub2(x, z) = cases
[ (null(x), z)
, (eq(caar(x), z), cadar(x))
, (at"T", sub2(cdr(x), z))
]
sublis(x, y) = cases
[ (atom(y), sub2(x, y))
, (at"T", cons(sublis(x, car(y)),sublis(x, cdr(y))))
]
apply(f, args) = eval(cons(f, appq(args)), at"NIL")
appq(m) = cases
[ (null(m), at"NIL")
, (at"T", cons(l[at"QUOTE", car(m)], appq(cdr(m))))
]
eval(e, a) = cases
[ (atom(e), assoc(e, a))
, (atom(car(e)), cases
[ (eq(car(e), at"QUOTE"), cadr(e))
, (eq(car(e), at"ATOM"), atom(eval(cadr(e), a)))
, (eq(car(e), at"EQ"), eq(eval(cadr(e), a), eval(caddr(e), a)))
, (eq(car(e), at"COND"), evcon(cadr(e), a))
, (eq(car(e), at"CAR"), car(eval(cadr(e), a)))
, (eq(car(e), at"CDR"), cdr(eval(cadr(e), a)))
, (eq(car(e), at"CONS"), cons(eval(cadr(e), a), eval(caddr(e), a)))
, (at"T", eval(cons(assoc(car(e), a), cdr(e)), a))
-- , (at"T", eval(cons(assoc(car(e), a), evlis(cdr(e), a)), a))
]
)
, (eq(caar(e), at"LABEL"), eval(cons(caddar(e), cdr(e)), cons(l[cadar(e), car(e)], a)))
, (eq(caar(e), at"LAMBDA"), eval(caddar(e), append(pair(cadar(e), evlis(cdr(e), a)), a)))
]
where
evcon(c, a) = cases[(eval(caar(c), a), eval(cadar(c), a)), (at"T", evcon(cdr(c),a))]
evlis(m, a) = cases[(null(m), at"NIL"), (at"T", cons(eval(car(m), a), evlis(cdr(m), a)))]
|
