|
1 (** |
|
2 * the Nominal Unification algorithm by Urban, Pitts & Gabbay |
|
3 * June, 2003 |
|
4 *) |
|
5 |
|
6 open List;; |
|
7 exception Fail;; (* exception for unification failure *) |
|
8 |
|
9 (* terms *) |
|
10 type term = |
|
11 Unit (* units *) |
|
12 | Atm of string (* atoms *) |
|
13 | Susp of (string * string) list * string (* suspensions *) |
|
14 | Fun of string * term (* function symbols *) |
|
15 | Abst of string * term (* abstracted terms *) |
|
16 | Pair of term * term;; (* pairs *) |
|
17 |
|
18 (* swapping operation on atoms *) |
|
19 let swap (a,b) c = |
|
20 if a=c then b else if b=c then a else c;; |
|
21 let swaps pi c = fold_right swap pi c;; |
|
22 |
|
23 (* permutation on terms *) |
|
24 let rec perm pi t = |
|
25 match t with |
|
26 Unit -> Unit |
|
27 | Atm(a) -> Atm(swaps pi a) |
|
28 | Susp(pi',x) -> Susp(pi@pi',x) |
|
29 | Fun(name,t') -> Fun(name, perm pi t') |
|
30 | Abst(a,t') -> Abst(swaps pi a,perm pi t') |
|
31 | Pair(t1,t2) -> Pair(perm pi t1,perm pi t2);; |
|
32 |
|
33 (* substitution operation |
|
34 * - implements the simple operation of "hole filling" or "context substitution" |
|
35 *) |
|
36 let rec subst t sigma = |
|
37 match t with |
|
38 Unit -> Unit |
|
39 | Atm(a) -> Atm(a) |
|
40 | Susp(pi,y) -> (try (perm pi (assoc y sigma)) with Not_found -> Susp(pi,y)) |
|
41 | Fun(name,t') -> Fun(name,subst t' sigma) |
|
42 | Abst(a,t') -> Abst(a,subst t' sigma) |
|
43 | Pair(t1,t2) -> Pair(subst t1 sigma,subst t2 sigma);; |
|
44 |
|
45 (* substitution composition *) |
|
46 let rec subst_compose sigma = |
|
47 match sigma with |
|
48 [] -> [] |
|
49 | h::tail -> h::(map (fun (v,t) -> (v,subst t [h])) (subst_compose tail));; |
|
50 |
|
51 (* occurs check *) |
|
52 let rec occurs x t = |
|
53 match t with |
|
54 Unit -> false |
|
55 | Atm(a) -> false |
|
56 | Susp(pi,y) -> if x=y then true else false |
|
57 | Fun(_,t') | Abst(_,t') -> occurs x t' |
|
58 | Pair(t1,t2) -> (occurs x t1) || (occurs x t2);; |
|
59 |
|
60 (* deletes duplicates from a list |
|
61 * - used for calculating disagreement sets |
|
62 *) |
|
63 let rec delete_dups l = |
|
64 match l with |
|
65 [] -> [] |
|
66 | h::t -> let t' = delete_dups t in if mem h t' then t' else (h::t');; |
|
67 |
|
68 (* disagreement set |
|
69 * - takes two permutation (lists of pairs of atoms) as arguments |
|
70 *) |
|
71 let rec ds pi pi' = |
|
72 let (l1,l2) = split (pi@pi') |
|
73 in filter (fun a -> (swaps pi a)!=(swaps pi' a)) (delete_dups (l1@l2)) |
|
74 |
|
75 (* eliminates a solved equation *) |
|
76 let eliminate (v,t) (eprobs,fprobs) = |
|
77 if occurs v t |
|
78 then raise Fail |
|
79 else (map (fun (t1,t2) -> (subst t1 [(v,t)],subst t2 [(v,t)])) eprobs, |
|
80 map (fun (a,t') -> (a,subst t' [(v,t)])) fprobs);; |
|
81 |
|
82 (***************) |
|
83 (* unification *) |
|
84 (***************) |
|
85 |
|
86 (* checks and solves all freshness problems *) |
|
87 let rec check fprobs = |
|
88 match fprobs with |
|
89 [] -> [] |
|
90 | (a,Unit)::tail -> check tail |
|
91 | (a,Atm(b))::tail -> if a=b then raise Fail else check tail |
|
92 | (a,Susp(pi,x))::tail -> (swaps (rev pi) a,x)::(check tail) |
|
93 | (a,Fun(_,t))::tail -> check ((a,t)::tail) |
|
94 | (a,Abst(b,t))::tail -> if a=b then (check tail) else (check ((a,t)::tail)) |
|
95 | (a,Pair(t1,t2))::tail -> check ((a,t1)::(a,t2)::tail);; |
|
96 |
|
97 (* solves all equational problems *) |
|
98 let rec solve eprobs fprobs = solve_aux eprobs fprobs [] |
|
99 and solve_aux eprobs fprobs sigma = |
|
100 match eprobs with |
|
101 [] -> (subst_compose sigma, delete_dups (check fprobs)) |
|
102 | (Unit,Unit)::tail -> solve_aux tail fprobs sigma |
|
103 | (Atm(a),Atm(b))::tail -> if a=b then (solve_aux tail fprobs sigma) else raise Fail |
|
104 | (Susp(pi,x),Susp(pi',x'))::tail when x=x' -> |
|
105 let new_fps = map (fun a -> (a,Susp([],x))) (ds pi pi') |
|
106 in solve_aux tail (new_fps @ fprobs) sigma |
|
107 | (Susp(pi,x),t)::tail | (t,Susp(pi,x))::tail -> |
|
108 let new_sigma = (x,perm (rev pi) t) in |
|
109 let (new_eprobs,new_fprobs) = eliminate new_sigma (tail,fprobs) |
|
110 in solve_aux new_eprobs new_fprobs (new_sigma::sigma) |
|
111 | (Fun(n1,t1),Fun(n2,t2))::tail -> |
|
112 if n1 = n2 |
|
113 then solve_aux ((t1,t2)::tail) fprobs sigma |
|
114 else raise Fail |
|
115 | (Abst(a1,t1),Abst(a2,t2))::tail -> |
|
116 if a1 = a2 |
|
117 then solve_aux ((t1,t2)::tail) fprobs sigma |
|
118 else solve_aux ((t1,perm [(a1,a2)] t2)::tail) ((a1,t2)::fprobs) sigma |
|
119 | (Pair(t1,t2),Pair(s1,s2))::tail -> |
|
120 solve_aux ((t1,s1)::(t2,s2)::tail) fprobs sigma |
|
121 | _ -> raise Fail;; |
|
122 |
|
123 |
|
124 (************) |
|
125 (* Examples *) |
|
126 (************) |
|
127 |
|
128 (* a few variables*) |
|
129 let x = Susp([],"X") |
|
130 and y = Susp([],"Y") |
|
131 and z = Susp([],"Z");; |
|
132 |
|
133 (* lam a.(X a) =? lam b.(c b) --> [X:=c] *) |
|
134 let t1 = Abst("a",Pair(x,Atm("a")));; |
|
135 let t2 = Abst("b",Pair(Atm("c"),Atm("b")));; |
|
136 solve [(t1,t2)] [];; |
|
137 |
|
138 (* lam a.(X a) =? lam b.(a b) --> fails *) |
|
139 let t1 = Abst("a",Pair(x,Atm("a")));; |
|
140 let t2 = Abst("b",Pair(Atm("a"),Atm("b")));; |
|
141 solve [(t1,t2)] [];; |
|
142 |
|
143 (* lam a.(X a) =? lam b.(X b) --> a#X, b#X *) |
|
144 let t1 = Abst("a",Pair(x,Atm("a")));; |
|
145 let t2 = Abst("b",Pair(x,Atm("b")));; |
|
146 solve [(t1,t2)] [];; |
|
147 |
|
148 (* lam a.(X a) =? lam b.(Y b) --> [X:=(a b)oY] a#Y *) |
|
149 (* --> [Y:=(b a)oX] b#X *) |
|
150 let t1 = Abst("a",Pair(x,Atm("a")));; |
|
151 let t2 = Abst("b",Pair(y,Atm("b")));; |
|
152 solve [(t1,t2)] [];; |
|
153 solve [(t2,t1)] [];; |
|
154 |
|
155 (* quiz-questions from the paper *) |
|
156 let m1 = Susp([],"M1") |
|
157 and m2 = Susp([],"M2") |
|
158 and m3 = Susp([],"M3") |
|
159 and m4 = Susp([],"M4") |
|
160 and m5 = Susp([],"M5") |
|
161 and m6 = Susp([],"M6") |
|
162 and m7 = Susp([],"M7");; |
|
163 |
|
164 (* 1 --> fail *) |
|
165 let t1 = Abst("a",Abst("b",Pair(m1,Atm("b"))));; |
|
166 let t2 = Abst("b",Abst("a",Pair(Atm("a"),m1)));; |
|
167 solve [(t1,t2)] [];; |
|
168 |
|
169 (* 2 --> [M2:=b ,M3:=a] *) |
|
170 let t1 = Abst("a",Abst("b",Pair(m2,Atm("b"))));; |
|
171 let t2 = Abst("b",Abst("a",Pair(Atm("a"),m3)));; |
|
172 solve [(t1,t2)] [];; |
|
173 |
|
174 (* 3 --> [M4:=(a b)o M5] *) |
|
175 let t1 = Abst("a",Abst("b",Pair(Atm("b"),m4)));; |
|
176 let t2 = Abst("b",Abst("a",Pair(Atm("a"),m5)));; |
|
177 solve [(t1,t2)] [];; |
|
178 |
|
179 (* 4 --> [M6:=(b a)oM7] b#M7 *) |
|
180 let t1 = Abst("a",Abst("b",Pair(Atm("b"),m6)));; |
|
181 let t2 = Abst("a",Abst("a",Pair(Atm("a"),m7)));; |
|
182 solve [(t1,t2)] [];; |