author | wenzelm |
Sat, 07 Apr 2012 16:41:59 +0200 | |
changeset 47389 | e8552cba702d |
parent 42102 | fcfd07f122d4 |
child 72004 | 913162a47d9f |
permissions | -rw-r--r-- |
39348 | 1 |
(* ========================================================================= *) |
2 |
(* FIRST ORDER LOGIC ATOMS *) |
|
39502 | 3 |
(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *) |
39348 | 4 |
(* ========================================================================= *) |
5 |
||
6 |
structure Atom :> Atom = |
|
7 |
struct |
|
8 |
||
9 |
open Useful; |
|
10 |
||
11 |
(* ------------------------------------------------------------------------- *) |
|
12 |
(* A type for storing first order logic atoms. *) |
|
13 |
(* ------------------------------------------------------------------------- *) |
|
14 |
||
15 |
type relationName = Name.name; |
|
16 |
||
17 |
type relation = relationName * int; |
|
18 |
||
19 |
type atom = relationName * Term.term list; |
|
20 |
||
21 |
(* ------------------------------------------------------------------------- *) |
|
22 |
(* Constructors and destructors. *) |
|
23 |
(* ------------------------------------------------------------------------- *) |
|
24 |
||
25 |
fun name ((rel,_) : atom) = rel; |
|
26 |
||
27 |
fun arguments ((_,args) : atom) = args; |
|
28 |
||
29 |
fun arity atm = length (arguments atm); |
|
30 |
||
31 |
fun relation atm = (name atm, arity atm); |
|
32 |
||
33 |
val functions = |
|
34 |
let |
|
35 |
fun f (tm,acc) = NameAritySet.union (Term.functions tm) acc |
|
36 |
in |
|
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
37 |
fn atm => List.foldl f NameAritySet.empty (arguments atm) |
39348 | 38 |
end; |
39 |
||
40 |
val functionNames = |
|
41 |
let |
|
42 |
fun f (tm,acc) = NameSet.union (Term.functionNames tm) acc |
|
43 |
in |
|
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
44 |
fn atm => List.foldl f NameSet.empty (arguments atm) |
39348 | 45 |
end; |
46 |
||
47 |
(* Binary relations *) |
|
48 |
||
49 |
fun mkBinop p (a,b) : atom = (p,[a,b]); |
|
50 |
||
51 |
fun destBinop p (x,[a,b]) = |
|
52 |
if Name.equal x p then (a,b) else raise Error "Atom.destBinop: wrong binop" |
|
53 |
| destBinop _ _ = raise Error "Atom.destBinop: not a binop"; |
|
54 |
||
55 |
fun isBinop p = can (destBinop p); |
|
56 |
||
57 |
(* ------------------------------------------------------------------------- *) |
|
58 |
(* The size of an atom in symbols. *) |
|
59 |
(* ------------------------------------------------------------------------- *) |
|
60 |
||
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
61 |
fun symbols atm = |
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
62 |
List.foldl (fn (tm,z) => Term.symbols tm + z) 1 (arguments atm); |
39348 | 63 |
|
64 |
(* ------------------------------------------------------------------------- *) |
|
65 |
(* A total comparison function for atoms. *) |
|
66 |
(* ------------------------------------------------------------------------- *) |
|
67 |
||
68 |
fun compare ((p1,tms1),(p2,tms2)) = |
|
69 |
case Name.compare (p1,p2) of |
|
70 |
LESS => LESS |
|
71 |
| EQUAL => lexCompare Term.compare (tms1,tms2) |
|
72 |
| GREATER => GREATER; |
|
73 |
||
74 |
fun equal atm1 atm2 = compare (atm1,atm2) = EQUAL; |
|
75 |
||
76 |
(* ------------------------------------------------------------------------- *) |
|
77 |
(* Subterms. *) |
|
78 |
(* ------------------------------------------------------------------------- *) |
|
79 |
||
80 |
fun subterm _ [] = raise Bug "Atom.subterm: empty path" |
|
81 |
| subterm ((_,tms) : atom) (h :: t) = |
|
82 |
if h >= length tms then raise Error "Atom.subterm: bad path" |
|
83 |
else Term.subterm (List.nth (tms,h)) t; |
|
84 |
||
85 |
fun subterms ((_,tms) : atom) = |
|
86 |
let |
|
42102 | 87 |
fun f ((n,tm),l) = List.map (fn (p,s) => (n :: p, s)) (Term.subterms tm) @ l |
39348 | 88 |
in |
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
89 |
List.foldl f [] (enumerate tms) |
39348 | 90 |
end; |
91 |
||
92 |
fun replace _ ([],_) = raise Bug "Atom.replace: empty path" |
|
93 |
| replace (atm as (rel,tms)) (h :: t, res) : atom = |
|
94 |
if h >= length tms then raise Error "Atom.replace: bad path" |
|
95 |
else |
|
96 |
let |
|
97 |
val tm = List.nth (tms,h) |
|
98 |
val tm' = Term.replace tm (t,res) |
|
99 |
in |
|
100 |
if Portable.pointerEqual (tm,tm') then atm |
|
101 |
else (rel, updateNth (h,tm') tms) |
|
102 |
end; |
|
103 |
||
104 |
fun find pred = |
|
105 |
let |
|
106 |
fun f (i,tm) = |
|
107 |
case Term.find pred tm of |
|
108 |
SOME path => SOME (i :: path) |
|
109 |
| NONE => NONE |
|
110 |
in |
|
111 |
fn (_,tms) : atom => first f (enumerate tms) |
|
112 |
end; |
|
113 |
||
114 |
(* ------------------------------------------------------------------------- *) |
|
115 |
(* Free variables. *) |
|
116 |
(* ------------------------------------------------------------------------- *) |
|
117 |
||
118 |
fun freeIn v atm = List.exists (Term.freeIn v) (arguments atm); |
|
119 |
||
120 |
val freeVars = |
|
121 |
let |
|
122 |
fun f (tm,acc) = NameSet.union (Term.freeVars tm) acc |
|
123 |
in |
|
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
124 |
fn atm => List.foldl f NameSet.empty (arguments atm) |
39348 | 125 |
end; |
126 |
||
127 |
(* ------------------------------------------------------------------------- *) |
|
128 |
(* Substitutions. *) |
|
129 |
(* ------------------------------------------------------------------------- *) |
|
130 |
||
131 |
fun subst sub (atm as (p,tms)) : atom = |
|
132 |
let |
|
133 |
val tms' = Sharing.map (Subst.subst sub) tms |
|
134 |
in |
|
135 |
if Portable.pointerEqual (tms',tms) then atm else (p,tms') |
|
136 |
end; |
|
137 |
||
138 |
(* ------------------------------------------------------------------------- *) |
|
139 |
(* Matching. *) |
|
140 |
(* ------------------------------------------------------------------------- *) |
|
141 |
||
142 |
local |
|
143 |
fun matchArg ((tm1,tm2),sub) = Subst.match sub tm1 tm2; |
|
144 |
in |
|
145 |
fun match sub (p1,tms1) (p2,tms2) = |
|
146 |
let |
|
147 |
val _ = (Name.equal p1 p2 andalso length tms1 = length tms2) orelse |
|
148 |
raise Error "Atom.match" |
|
149 |
in |
|
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
150 |
List.foldl matchArg sub (zip tms1 tms2) |
39348 | 151 |
end; |
152 |
end; |
|
153 |
||
154 |
(* ------------------------------------------------------------------------- *) |
|
155 |
(* Unification. *) |
|
156 |
(* ------------------------------------------------------------------------- *) |
|
157 |
||
158 |
local |
|
159 |
fun unifyArg ((tm1,tm2),sub) = Subst.unify sub tm1 tm2; |
|
160 |
in |
|
161 |
fun unify sub (p1,tms1) (p2,tms2) = |
|
162 |
let |
|
163 |
val _ = (Name.equal p1 p2 andalso length tms1 = length tms2) orelse |
|
164 |
raise Error "Atom.unify" |
|
165 |
in |
|
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
166 |
List.foldl unifyArg sub (zip tms1 tms2) |
39348 | 167 |
end; |
168 |
end; |
|
169 |
||
170 |
(* ------------------------------------------------------------------------- *) |
|
171 |
(* The equality relation. *) |
|
172 |
(* ------------------------------------------------------------------------- *) |
|
173 |
||
174 |
val eqRelationName = Name.fromString "="; |
|
175 |
||
176 |
val eqRelationArity = 2; |
|
177 |
||
178 |
val eqRelation = (eqRelationName,eqRelationArity); |
|
179 |
||
180 |
val mkEq = mkBinop eqRelationName; |
|
181 |
||
182 |
fun destEq x = destBinop eqRelationName x; |
|
183 |
||
184 |
fun isEq x = isBinop eqRelationName x; |
|
185 |
||
186 |
fun mkRefl tm = mkEq (tm,tm); |
|
187 |
||
188 |
fun destRefl atm = |
|
189 |
let |
|
190 |
val (l,r) = destEq atm |
|
191 |
val _ = Term.equal l r orelse raise Error "Atom.destRefl" |
|
192 |
in |
|
193 |
l |
|
194 |
end; |
|
195 |
||
196 |
fun isRefl x = can destRefl x; |
|
197 |
||
198 |
fun sym atm = |
|
199 |
let |
|
200 |
val (l,r) = destEq atm |
|
201 |
val _ = not (Term.equal l r) orelse raise Error "Atom.sym: refl" |
|
202 |
in |
|
203 |
mkEq (r,l) |
|
204 |
end; |
|
205 |
||
206 |
fun lhs atm = fst (destEq atm); |
|
207 |
||
208 |
fun rhs atm = snd (destEq atm); |
|
209 |
||
210 |
(* ------------------------------------------------------------------------- *) |
|
211 |
(* Special support for terms with type annotations. *) |
|
212 |
(* ------------------------------------------------------------------------- *) |
|
213 |
||
214 |
fun typedSymbols ((_,tms) : atom) = |
|
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
215 |
List.foldl (fn (tm,z) => Term.typedSymbols tm + z) 1 tms; |
39348 | 216 |
|
217 |
fun nonVarTypedSubterms (_,tms) = |
|
218 |
let |
|
219 |
fun addArg ((n,arg),acc) = |
|
220 |
let |
|
221 |
fun addTm ((path,tm),acc) = (n :: path, tm) :: acc |
|
222 |
in |
|
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
223 |
List.foldl addTm acc (Term.nonVarTypedSubterms arg) |
39348 | 224 |
end |
225 |
in |
|
39443
e330437cd22a
copied the unmodified official Metis 2.3 (15 Sept. 2010) sources into Isabelle
blanchet
parents:
39353
diff
changeset
|
226 |
List.foldl addArg [] (enumerate tms) |
39348 | 227 |
end; |
228 |
||
229 |
(* ------------------------------------------------------------------------- *) |
|
230 |
(* Parsing and pretty printing. *) |
|
231 |
(* ------------------------------------------------------------------------- *) |
|
232 |
||
233 |
val pp = Print.ppMap Term.Fn Term.pp; |
|
234 |
||
235 |
val toString = Print.toString pp; |
|
236 |
||
237 |
fun fromString s = Term.destFn (Term.fromString s); |
|
238 |
||
239 |
val parse = Parse.parseQuotation Term.toString fromString; |
|
240 |
||
241 |
end |
|
242 |
||
243 |
structure AtomOrdered = |
|
244 |
struct type t = Atom.atom val compare = Atom.compare end |
|
245 |
||
246 |
structure AtomMap = KeyMap (AtomOrdered); |
|
247 |
||
248 |
structure AtomSet = ElementSet (AtomMap); |