open Utils;;
+type equality =
+ int * (* weight *)
+ (Cic.term * (* type *)
+ Cic.term * (* left side *)
+ Cic.term * (* right side *)
+ Utils.comparison) * (* ordering *)
+ Cic.metasenv * (* environment for metas *)
+ Cic.term list (* arguments *)
+;;
+
+
+type proof =
+ | BasicProof of Cic.term
+ | ProofBlock of
+ Cic.substitution * UriManager.uri * Cic.term * (Utils.pos * equality) *
+ equality
+ | NoProof
+;;
+
+
let string_of_equality ?env =
match env with
| None -> (
;;
+let prooftable = Hashtbl.create 2001;;
+
+let store_proof equality proof =
+ if not (Hashtbl.mem prooftable equality) then
+ Hashtbl.add prooftable equality proof
+;;
+
+
+let delete_proof equality =
+(* Printf.printf "| Removing proof of %s" (string_of_equality equality); *)
+(* print_newline (); *)
+ Hashtbl.remove prooftable equality
+;;
+
+
+let rec build_term_proof equality =
+(* Printf.printf "build_term_proof %s" (string_of_equality equality); *)
+(* print_newline (); *)
+ let proof = try Hashtbl.find prooftable equality with Not_found -> NoProof in
+ match proof with
+ | NoProof ->
+ Printf.fprintf stderr "WARNING: no proof for %s\n"
+ (string_of_equality equality);
+ Cic.Implicit None
+ | BasicProof term -> term
+ | ProofBlock (subst, eq_URI, t', (pos, eq), eq') ->
+(* Printf.printf " ProofBlock: eq = %s, eq' = %s" *)
+(* (string_of_equality eq) (string_of_equality eq'); *)
+(* print_newline (); *)
+ let proof' = build_term_proof eq in
+ let eqproof = build_term_proof eq' in
+ let _, (ty, what, other, _), menv', args' = eq in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ CicMetaSubst.apply_subst subst
+ (Cic.Appl [Cic.Const (eq_URI, []); ty;
+ what; t'; eqproof; other; proof'])
+;;
+
+
let rec metas_of_term = function
| Cic.Meta (i, c) -> [i]
| Cic.Var (_, ens)
;;
-exception MatchingFailure;;
+let rec check_irl start = function
+ | [] -> true
+ | None::tl -> check_irl (start+1) tl
+ | (Some (Cic.Rel x))::tl ->
+ if x = start then check_irl (start+1) tl else false
+ | _ -> false
+;;
-let matching metasenv context t1 t2 ugraph =
- try
- let subst, metasenv, ugraph =
- CicUnification.fo_unif metasenv context t1 t2 ugraph
+let rec is_simple_term = function
+ | Cic.Appl ((Cic.Meta _)::_) -> false
+ | Cic.Appl l -> List.for_all is_simple_term l
+ | Cic.Meta (i, l) -> check_irl 1 l
+ | Cic.Rel _ -> true
+ | _ -> false
+;;
+
+
+let lookup_subst meta subst =
+ match meta with
+ | Cic.Meta (i, _) -> (
+ try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t
+ with Not_found -> meta
+ )
+ | _ -> assert false
+;;
+
+
+let unification_simple metasenv context t1 t2 ugraph =
+ let module C = Cic in
+ let module M = CicMetaSubst in
+ let module U = CicUnification in
+ let lookup = lookup_subst in
+ let rec occurs_check subst what where =
+ (* Printf.printf "occurs_check %s %s" *)
+ (* (CicPp.ppterm what) (CicPp.ppterm where); *)
+ (* print_newline (); *)
+ match where with
+ | t when what = t -> true
+ | C.Appl l -> List.exists (occurs_check subst what) l
+ | C.Meta _ ->
+ let t = lookup where subst in
+ if t <> where then occurs_check subst what t else false
+ | _ -> false
+ in
+ let rec unif subst menv s t =
+(* Printf.printf "unif %s %s\n%s\n" (CicPp.ppterm s) (CicPp.ppterm t) *)
+(* (print_subst subst); *)
+(* print_newline (); *)
+ let s = match s with C.Meta _ -> lookup s subst | _ -> s
+ and t = match t with C.Meta _ -> lookup t subst | _ -> t
in
- let t' = CicMetaSubst.apply_subst subst t1 in
- if not (meta_convertibility t1 t') then
- raise MatchingFailure
+ (* Printf.printf "after apply_subst: %s %s\n%s" *)
+ (* (CicPp.ppterm s) (CicPp.ppterm t) (print_subst subst); *)
+ (* print_newline (); *)
+ match s, t with
+ | s, t when s = t -> subst, menv
+ | C.Meta (i, _), C.Meta (j, _) when i > j ->
+ unif subst menv t s
+ | C.Meta _, t when occurs_check subst s t ->
+ raise (U.UnificationFailure "Inference.unification.unif")
+(* | C.Meta (i, l), C.Meta (j, l') -> *)
+(* let _, _, ty = CicUtil.lookup_meta i menv in *)
+(* let _, _, ty' = CicUtil.lookup_meta j menv in *)
+(* let binding1 = lookup s subst in *)
+(* let binding2 = lookup t subst in *)
+(* let subst, menv = *)
+(* if binding1 != s then *)
+(* if binding2 != t then *)
+(* unif subst menv binding1 binding2 *)
+(* else *)
+(* if binding1 = t then *)
+(* subst, menv *)
+(* else *)
+(* ((j, (context, binding1, ty'))::subst, *)
+(* List.filter (fun (m, _, _) -> j <> m) menv) *)
+(* else *)
+(* if binding2 != t then *)
+(* if s = binding2 then *)
+(* subst, menv *)
+(* else *)
+(* ((i, (context, binding2, ty))::subst, *)
+(* List.filter (fun (m, _, _) -> i <> m) menv) *)
+(* else *)
+(* ((i, (context, t, ty))::subst, *)
+(* List.filter (fun (m, _, _) -> i <> m) menv) *)
+(* in *)
+(* subst, menv *)
+
+ | C.Meta (i, l), t ->
+ let _, _, ty = CicUtil.lookup_meta i menv in
+ let subst =
+ if not (List.mem_assoc i subst) then (i, (context, t, ty))::subst
+ else subst
+ in
+ let menv = List.filter (fun (m, _, _) -> i <> m) menv in
+ subst, menv
+ | _, C.Meta _ -> unif subst menv t s
+ | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt ->
+ raise (U.UnificationFailure "Inference.unification.unif")
+ | C.Appl (hds::tls), C.Appl (hdt::tlt) -> (
+ try
+ List.fold_left2
+ (fun (subst', menv) s t -> unif subst' menv s t)
+ (subst, menv) tls tlt
+ with e ->
+ raise (U.UnificationFailure "Inference.unification.unif")
+ )
+ | _, _ -> raise (U.UnificationFailure "Inference.unification.unif")
+ in
+ let subst, menv = unif [] metasenv t1 t2 in
+ (* Printf.printf "DONE!: subst = \n%s\n" (print_subst subst); *)
+ (* print_newline (); *)
+(* let rec fix_term = function *)
+(* | (C.Meta (i, l) as t) -> *)
+(* lookup t subst *)
+(* | C.Appl l -> C.Appl (List.map fix_term l) *)
+(* | t -> t *)
+(* in *)
+(* let rec fix_subst = function *)
+(* | [] -> [] *)
+(* | (i, (c, t, ty))::tl -> (i, (c, fix_term t, fix_term ty))::(fix_subst tl) *)
+(* in *)
+(* List.rev (fix_subst subst), menv, ugraph *)
+ List.rev subst, menv, ugraph
+;;
+
+
+let unification metasenv context t1 t2 ugraph =
+(* Printf.printf "| unification %s %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); *)
+ let subst, menv, ug =
+ if not (is_simple_term t1) || not (is_simple_term t2) then
+ CicUnification.fo_unif metasenv context t1 t2 ugraph
else
- let metas = metas_of_term t1 in
- let fix_subst = function
- | (i, (c, Cic.Meta (j, lc), ty)) when List.mem i metas ->
- (j, (c, Cic.Meta (i, lc), ty))
- | s -> s
+ unification_simple metasenv context t1 t2 ugraph
+ in
+ let rec fix_term = function
+ | (Cic.Meta (i, l) as t) ->
+ let t' = lookup_subst t subst in
+ if t <> t' then fix_term t' else t
+ | Cic.Appl l -> Cic.Appl (List.map fix_term l)
+ | t -> t
+ in
+ let rec fix_subst = function
+ | [] -> []
+ | (i, (c, t, ty))::tl -> (i, (c, fix_term t, fix_term ty))::(fix_subst tl)
+ in
+(* Printf.printf "| subst: %s\n" (print_subst ~prefix:" ; " subst); *)
+(* print_endline "|"; *)
+ (* fix_subst *) subst, menv, ug
+;;
+
+(* let unification = CicUnification.fo_unif;; *)
+
+exception MatchingFailure;;
+
+
+let matching_simple metasenv context t1 t2 ugraph =
+ let module C = Cic in
+ let module M = CicMetaSubst in
+ let module U = CicUnification in
+ let lookup meta subst =
+ match meta with
+ | C.Meta (i, _) -> (
+ try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t
+ with Not_found -> meta
+ )
+ | _ -> assert false
+ in
+ let rec do_match subst menv s t =
+(* Printf.printf "do_match %s %s\n%s\n" (CicPp.ppterm s) (CicPp.ppterm t) *)
+(* (print_subst subst); *)
+(* print_newline (); *)
+(* let s = match s with C.Meta _ -> lookup s subst | _ -> s *)
+(* let t = match t with C.Meta _ -> lookup t subst | _ -> t in *)
+ (* Printf.printf "after apply_subst: %s %s\n%s" *)
+ (* (CicPp.ppterm s) (CicPp.ppterm t) (print_subst subst); *)
+ (* print_newline (); *)
+ match s, t with
+ | s, t when s = t -> subst, menv
+(* | C.Meta (i, _), C.Meta (j, _) when i > j -> *)
+(* do_match subst menv t s *)
+(* | C.Meta _, t when occurs_check subst s t -> *)
+(* raise MatchingFailure *)
+(* | s, C.Meta _ when occurs_check subst t s -> *)
+(* raise MatchingFailure *)
+ | s, C.Meta (i, l) ->
+ let filter_menv i menv =
+ List.filter (fun (m, _, _) -> i <> m) menv
+ in
+ let subst, menv =
+ let value = lookup t subst in
+ match value with
+(* | C.Meta (i', l') when Hashtbl.mem table i' -> *)
+(* (i', (context, s, ty))::subst, menv (\* filter_menv i' menv *\) *)
+ | value when value = t ->
+ let _, _, ty = CicUtil.lookup_meta i menv in
+ (i, (context, s, ty))::subst, filter_menv i menv
+ | value when value <> s ->
+ raise MatchingFailure
+ | value -> do_match subst menv s value
+ in
+ subst, menv
+(* else if value <> s then *)
+(* raise MatchingFailure *)
+(* else subst *)
+(* if not (List.mem_assoc i subst) then (i, (context, t, ty))::subst *)
+(* else subst *)
+(* in *)
+(* let menv = List.filter (fun (m, _, _) -> i <> m) menv in *)
+(* subst, menv *)
+(* | _, C.Meta _ -> do_match subst menv t s *)
+(* | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt -> *)
+(* raise MatchingFailure *)
+ | C.Appl ls, C.Appl lt -> (
+ try
+ List.fold_left2
+ (fun (subst, menv) s t -> do_match subst menv s t)
+ (subst, menv) ls lt
+ with e ->
+(* print_endline (Printexc.to_string e); *)
+(* Printf.printf "NO MATCH: %s %s\n" (CicPp.ppterm s) (CicPp.ppterm t); *)
+(* print_newline (); *)
+ raise MatchingFailure
+ )
+ | _, _ ->
+(* Printf.printf "NO MATCH: %s %s\n" (CicPp.ppterm s) (CicPp.ppterm t); *)
+(* print_newline (); *)
+ raise MatchingFailure
+ in
+ let subst, menv = do_match [] metasenv t1 t2 in
+ (* Printf.printf "DONE!: subst = \n%s\n" (print_subst subst); *)
+ (* print_newline (); *)
+ subst, menv, ugraph
+;;
+
+
+let matching metasenv context t1 t2 ugraph =
+(* if (is_simple_term t1) && (is_simple_term t2) then *)
+(* let subst, menv, ug = *)
+(* matching_simple metasenv context t1 t2 ugraph in *)
+(* (\* Printf.printf "matching %s %s:\n%s\n" *\) *)
+(* (\* (CicPp.ppterm t1) (CicPp.ppterm t2) (print_subst subst); *\) *)
+(* (\* print_newline (); *\) *)
+(* subst, menv, ug *)
+(* else *)
+ try
+ let subst, metasenv, ugraph =
+ (* CicUnification.fo_unif metasenv context t1 t2 ugraph *)
+ unification metasenv context t1 t2 ugraph
in
- let subst = List.map fix_subst subst in
- subst, metasenv, ugraph
- with e ->
- raise MatchingFailure
+ let t' = CicMetaSubst.apply_subst subst t1 in
+ if not (meta_convertibility t1 t') then
+ raise MatchingFailure
+ else
+ let metas = metas_of_term t1 in
+ let fix_subst = function
+ | (i, (c, Cic.Meta (j, lc), ty)) when List.mem i metas ->
+ (j, (c, Cic.Meta (i, lc), ty))
+ | s -> s
+ in
+ let subst = List.map fix_subst subst in
+
+(* Printf.printf "matching %s %s:\n%s\n" *)
+(* (CicPp.ppterm t1) (CicPp.ppterm t2) (print_subst subst); *)
+(* print_newline (); *)
+
+ subst, metasenv, ugraph
+ with e ->
+(* Printf.printf "failed to match %s %s\n" *)
+(* (CicPp.ppterm t1) (CicPp.ppterm t2); *)
+ raise MatchingFailure
;;
+(* let matching = *)
+(* let profile = CicUtil.profile "Inference.matching" in *)
+(* (fun metasenv context t1 t2 ugraph -> *)
+(* profile (matching metasenv context t1 t2) ugraph) *)
+(* ;; *)
+
let beta_expand ?(metas_ok=true) ?(match_only=false)
what type_of_what where context metasenv ugraph =
;;
-type equality =
- Cic.term * (* proof *)
- (Cic.term * (* type *)
- Cic.term * (* left side *)
- Cic.term * (* right side *)
- Utils.comparison) * (* ordering *)
- Cic.metasenv * (* environment for metas *)
- Cic.term list (* arguments *)
-;;
-
-
let find_equalities ?(eq_uri=HelmLibraryObjects.Logic.eq_URI) context proof =
let module C = Cic in
let module S = CicSubstitution in
| C.Appl [C.MutInd (uri, _, _); ty; t1; t2] when uri = eq_uri ->
Printf.printf "OK: %s\n" (CicPp.ppterm term);
let o = !Utils.compare_terms t1 t2 in
- Some (p, (ty, t1, t2, o), newmetas, args), (newmeta+1)
+ let w = compute_equality_weight ty t1 t2 in
+ let e = (w, (ty, t1, t2, o), newmetas, args) in
+ store_proof e (BasicProof p);
+ Some e, (newmeta+1)
| _ -> None, newmeta
)
| C.Appl [C.MutInd (uri, _, _); ty; t1; t2] when uri = eq_uri ->
let t1 = S.lift index t1
and t2 = S.lift index t2 in
let o = !Utils.compare_terms t1 t2 in
- Some (C.Rel index, (ty, t1, t2, o), [], []), (newmeta+1)
+ let w = compute_equality_weight ty t1 t2 in
+ let e = (w, (ty, t1, t2, o), [], []) in
+ store_proof e (BasicProof (C.Rel index));
+ Some e, (newmeta+1)
| _ -> None, newmeta
in (
match do_find context term with
;;
-let fix_metas newmeta ((proof, (ty, left, right, o), menv, args) as equality) =
+let fix_metas newmeta ((weight, (ty, left, right, o), menv, args) as equality) =
let table = Hashtbl.create (List.length args) in
let newargs, _ =
List.fold_right
(function Cic.Meta (i, _) -> List.mem i metas | _ -> assert false) newargs
in
(newmeta + (List.length newargs) + 1,
- (repl proof, (ty, left, right, o), menv', newargs))
+ (weight, (ty, left, right, o), menv', newargs))
;;
let equality_of_term ?(eq_uri=HelmLibraryObjects.Logic.eq_URI) proof = function
| Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] when uri = eq_uri ->
let o = !Utils.compare_terms t1 t2 in
- (proof, (ty, t1, t2, o), [], [])
+ let w = compute_equality_weight ty t1 t2 in
+ let e = (w, (ty, t1, t2, o), [], []) in
+ store_proof e (BasicProof proof);
+ e
+(* (proof, (ty, t1, t2, o), [], []) *)
| _ ->
raise TermIsNotAnEquality
;;
type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph;;
+(*
let superposition_left (metasenv, context, ugraph) target source =
let module C = Cic in
let module S = CicSubstitution in
(!maxmeta,
(List.filter ok (new1 @ new2 @ new3 @ new4)))
;;
+*)
let is_identity ((_, context, ugraph) as env) = function
;;
+(*
let demodulation newmeta (metasenv, context, ugraph) target source =
let module C = Cic in
let module S = CicSubstitution in
);
res
;;
+*)
let extract_differing_subterms t1 t2 =
projects / helm.git / blobdiff