helm/ocaml/paramodulation/inference.ml

   1 (* Copyright (C) 2005, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 open Utils;;
  27
  28
  29 type equality =
  30     int  *               (* weight *)
  31     proof *
  32     (Cic.term *          (* type *)
  33      Cic.term *          (* left side *)
  34      Cic.term *          (* right side *)
  35      Utils.comparison) * (* ordering *)
  36     Cic.metasenv *       (* environment for metas *)
  37     Cic.term list        (* arguments *)
  38
  39 and proof =
  40   | NoProof
  41   | BasicProof of Cic.term
  42   | ProofBlock of
  43       Cic.substitution * UriManager.uri *
  44         (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof
  45   | ProofGoalBlock of proof * proof
  46   | ProofSymBlock of Cic.term list * proof
  47   | SubProof of Cic.term * int * proof
  48 ;;
  49
  50
  51 let string_of_equality ?env =
  52   match env with
  53   | None -> (
  54       function
  55         | w, _, (ty, left, right, o), _, _ ->
  56             Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.ppterm ty)
  57               (CicPp.ppterm left) (string_of_comparison o) (CicPp.ppterm right)
  58     )
  59   | Some (_, context, _) -> (
  60       let names = names_of_context context in
  61       function
  62         | w, _, (ty, left, right, o), _, _ ->
  63             Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.pp ty names)
  64               (CicPp.pp left names) (string_of_comparison o)
  65               (CicPp.pp right names)
  66     )
  67 ;;
  68
  69
  70 let rec string_of_proof = function
  71   | NoProof -> "NoProof"
  72   | BasicProof t -> "BasicProof " ^ (CicPp.ppterm t)
  73   | SubProof (t, i, p) ->
  74       Printf.sprintf "SubProof(%s, %s, %s)"
  75         (CicPp.ppterm t) (string_of_int i) (string_of_proof p)
  76   | ProofSymBlock _ -> "ProofSymBlock"
  77   | ProofBlock _ -> "ProofBlock"
  78   | ProofGoalBlock (p1, p2) ->
  79       Printf.sprintf "ProofGoalBlock(%s, %s)"
  80         (string_of_proof p1) (string_of_proof p2)
  81 ;;
  82
  83
  84 (* returns an explicit named subst and a list of arguments for sym_eq_URI *)
  85 let build_ens_for_sym_eq sym_eq_URI termlist =
  86   let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph sym_eq_URI in
  87   match obj with
  88   | Cic.Constant (_, _, _, uris, _) ->
  89       assert (List.length uris <= List.length termlist);
  90       let rec aux = function
  91         | [], tl -> [], tl
  92         | (uri::uris), (term::tl) ->
  93             let ens, args = aux (uris, tl) in
  94             (uri, term)::ens, args
  95         | _, _ -> assert false
  96       in
  97       aux (uris, termlist)
  98   | _ -> assert false
  99 ;;
 100
 101
 102 let build_proof_term proof =
 103   let rec do_build_proof proof =
 104     match proof with
 105     | NoProof ->
 106         Printf.fprintf stderr "WARNING: no proof!\n";
 107         Cic.Implicit None
 108     | BasicProof term -> term
 109     | ProofGoalBlock (proofbit, proof) ->
 110         print_endline "found ProofGoalBlock, going up...";
 111         do_build_goal_proof proofbit proof
 112     | ProofSymBlock (termlist, proof) ->
 113         let proof = do_build_proof proof in
 114         let ens, args = build_ens_for_sym_eq (Utils.sym_eq_URI ()) termlist in
 115         Cic.Appl ([Cic.Const (Utils.sym_eq_URI (), ens)] @ args @ [proof])
 116     | ProofBlock (subst, eq_URI, (name, ty), bo, (pos, eq), eqproof) ->
 117         let t' = Cic.Lambda (name, ty, bo) in
 118         let proof' =
 119           let _, proof', _, _, _ = eq in
 120           do_build_proof proof'
 121         in
 122         let eqproof = do_build_proof eqproof in
 123         let _, _, (ty, what, other, _), menv', args' = eq in
 124         let what, other =
 125           if pos = Utils.Left then what, other else other, what
 126         in
 127         CicMetaSubst.apply_subst subst
 128           (Cic.Appl [Cic.Const (eq_URI, []); ty;
 129                      what; t'; eqproof; other; proof'])
 130     | SubProof (term, meta_index, proof) ->
 131         let proof = do_build_proof proof in
 132         let eq i = function
 133           | Cic.Meta (j, _) -> i = j
 134           | _ -> false
 135         in
 136         ProofEngineReduction.replace
 137           ~equality:eq ~what:[meta_index] ~with_what:[proof] ~where:term
 138
 139   and do_build_goal_proof proofbit proof =
 140     match proof with
 141     | ProofGoalBlock (pb, p) ->
 142         do_build_proof (ProofGoalBlock (replace_proof proofbit pb, p))
 143     | _ -> do_build_proof (replace_proof proofbit proof)
 144
 145   and replace_proof newproof = function
 146     | ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof) ->
 147         let eqproof' = replace_proof newproof eqproof in
 148         ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof')
 149     | ProofGoalBlock (pb, p) ->
 150         let pb' = replace_proof newproof pb in
 151         ProofGoalBlock (pb', p)
 152     | BasicProof _ -> newproof
 153     | SubProof (term, meta_index, p) ->
 154         SubProof (term, meta_index, replace_proof newproof p)
 155     | p -> p
 156   in
 157   do_build_proof proof
 158 ;;
 159
 160
 161 let rec metas_of_term = function
 162   | Cic.Meta (i, c) -> [i]
 163   | Cic.Var (_, ens)
 164   | Cic.Const (_, ens)
 165   | Cic.MutInd (_, _, ens)
 166   | Cic.MutConstruct (_, _, _, ens) ->
 167       List.flatten (List.map (fun (u, t) -> metas_of_term t) ens)
 168   | Cic.Cast (s, t)
 169   | Cic.Prod (_, s, t)
 170   | Cic.Lambda (_, s, t)
 171   | Cic.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t)
 172   | Cic.Appl l -> List.flatten (List.map metas_of_term l)
 173   | Cic.MutCase (uri, i, s, t, l) ->
 174       (metas_of_term s) @ (metas_of_term t) @
 175         (List.flatten (List.map metas_of_term l))
 176   | Cic.Fix (i, il) ->
 177       List.flatten
 178         (List.map (fun (s, i, t1, t2) ->
 179                      (metas_of_term t1) @ (metas_of_term t2)) il)
 180   | Cic.CoFix (i, il) ->
 181       List.flatten
 182         (List.map (fun (s, t1, t2) ->
 183                      (metas_of_term t1) @ (metas_of_term t2)) il)
 184   | _ -> []
 185 ;;
 186
 187
 188 exception NotMetaConvertible;;
 189
 190 let meta_convertibility_aux table t1 t2 =
 191   let module C = Cic in
 192   let print_table t =
 193     String.concat ", "
 194       (List.map
 195          (fun (k, v) -> Printf.sprintf "(%d, %d)" k v) t)
 196   in
 197   let rec aux ((table_l, table_r) as table) t1 t2 =
 198     match t1, t2 with
 199     | C.Meta (m1, tl1), C.Meta (m2, tl2) ->
 200         let m1_binding, table_l =
 201           try List.assoc m1 table_l, table_l
 202           with Not_found -> m2, (m1, m2)::table_l
 203         and m2_binding, table_r =
 204           try List.assoc m2 table_r, table_r
 205           with Not_found -> m1, (m2, m1)::table_r
 206         in
 207         if (m1_binding <> m2) || (m2_binding <> m1) then
 208           raise NotMetaConvertible
 209         else (
 210           try
 211             List.fold_left2
 212               (fun res t1 t2 ->
 213                  match t1, t2 with
 214                  | None, Some _ | Some _, None -> raise NotMetaConvertible
 215                  | None, None -> res
 216                  | Some t1, Some t2 -> (aux res t1 t2))
 217               (table_l, table_r) tl1 tl2
 218           with Invalid_argument _ ->
 219             raise NotMetaConvertible
 220         )
 221     | C.Var (u1, ens1), C.Var (u2, ens2)
 222     | C.Const (u1, ens1), C.Const (u2, ens2) when (UriManager.eq u1 u2) ->
 223         aux_ens table ens1 ens2
 224     | C.Cast (s1, t1), C.Cast (s2, t2)
 225     | C.Prod (_, s1, t1), C.Prod (_, s2, t2)
 226     | C.Lambda (_, s1, t1), C.Lambda (_, s2, t2)
 227     | C.LetIn (_, s1, t1), C.LetIn (_, s2, t2) ->
 228         let table = aux table s1 s2 in
 229         aux table t1 t2
 230     | C.Appl l1, C.Appl l2 -> (
 231         try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
 232         with Invalid_argument _ -> raise NotMetaConvertible
 233       )
 234     | C.MutInd (u1, i1, ens1), C.MutInd (u2, i2, ens2)
 235         when (UriManager.eq u1 u2) && i1 = i2 -> aux_ens table ens1 ens2
 236     | C.MutConstruct (u1, i1, j1, ens1), C.MutConstruct (u2, i2, j2, ens2)
 237         when (UriManager.eq u1 u2) && i1 = i2 && j1 = j2 ->
 238         aux_ens table ens1 ens2
 239     | C.MutCase (u1, i1, s1, t1, l1), C.MutCase (u2, i2, s2, t2, l2)
 240         when (UriManager.eq u1 u2) && i1 = i2 ->
 241         let table = aux table s1 s2 in
 242         let table = aux table t1 t2 in (
 243           try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
 244           with Invalid_argument _ -> raise NotMetaConvertible
 245         )
 246     | C.Fix (i1, il1), C.Fix (i2, il2) when i1 = i2 -> (
 247         try
 248           List.fold_left2
 249             (fun res (n1, i1, s1, t1) (n2, i2, s2, t2) ->
 250                if i1 <> i2 then raise NotMetaConvertible
 251                else
 252                  let res = (aux res s1 s2) in aux res t1 t2)
 253             table il1 il2
 254         with Invalid_argument _ -> raise NotMetaConvertible
 255       )
 256     | C.CoFix (i1, il1), C.CoFix (i2, il2) when i1 = i2 -> (
 257         try
 258           List.fold_left2
 259             (fun res (n1, s1, t1) (n2, s2, t2) ->
 260                let res = aux res s1 s2 in aux res t1 t2)
 261             table il1 il2
 262         with Invalid_argument _ -> raise NotMetaConvertible
 263       )
 264     | t1, t2 when t1 = t2 -> table
 265     | _, _ -> raise NotMetaConvertible
 266
 267   and aux_ens table ens1 ens2 =
 268     let cmp (u1, t1) (u2, t2) =
 269       compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2)
 270     in
 271     let ens1 = List.sort cmp ens1
 272     and ens2 = List.sort cmp ens2 in
 273     try
 274       List.fold_left2
 275         (fun res (u1, t1) (u2, t2) ->
 276            if not (UriManager.eq u1 u2) then raise NotMetaConvertible
 277            else aux res t1 t2)
 278         table ens1 ens2
 279     with Invalid_argument _ -> raise NotMetaConvertible
 280   in
 281   aux table t1 t2
 282 ;;
 283
 284
 285 let meta_convertibility_eq eq1 eq2 =
 286   let _, _, (ty, left, right, _), _, _ = eq1
 287   and _, _, (ty', left', right', _), _, _ = eq2 in
 288   if ty <> ty' then
 289     false
 290   else if (left = left') && (right = right') then
 291     true
 292   else if (left = right') && (right = left') then
 293     true
 294   else
 295     try
 296       let table = meta_convertibility_aux ([], []) left left' in
 297       let _ = meta_convertibility_aux table right right' in
 298       true
 299     with NotMetaConvertible ->
 300       try
 301         let table = meta_convertibility_aux ([], []) left right' in
 302         let _ = meta_convertibility_aux table right left' in
 303         true
 304       with NotMetaConvertible ->
 305         false
 306 ;;
 307
 308
 309 let meta_convertibility t1 t2 =
 310   let f t =
 311     String.concat ", "
 312       (List.map
 313          (fun (k, v) -> Printf.sprintf "(%d, %d)" k v) t)
 314   in
 315   if t1 = t2 then
 316     true
 317   else
 318     try
 319       let l, r = meta_convertibility_aux ([], []) t1 t2 in
 320       true
 321     with NotMetaConvertible ->
 322       false
 323 ;;
 324
 325
 326 let rec check_irl start = function
 327   | [] -> true
 328   | None::tl -> check_irl (start+1) tl
 329   | (Some (Cic.Rel x))::tl ->
 330       if x = start then check_irl (start+1) tl else false
 331   | _ -> false
 332 ;;
 333
 334
 335 let rec is_simple_term = function
 336   | Cic.Appl ((Cic.Meta _)::_) -> false
 337   | Cic.Appl l -> List.for_all is_simple_term l
 338   | Cic.Meta (i, l) -> check_irl 1 l
 339   | Cic.Rel _ -> true
 340   | Cic.Const _ -> true
 341   | Cic.MutInd (_, _, []) -> true
 342   | Cic.MutConstruct (_, _, _, []) -> true
 343   | _ -> false
 344 ;;
 345
 346
 347 let lookup_subst meta subst =
 348   match meta with
 349   | Cic.Meta (i, _) -> (
 350       try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t
 351       with Not_found -> meta
 352     )
 353   | _ -> assert false
 354 ;;
 355
 356
 357 let unification_simple metasenv context t1 t2 ugraph =
 358   let module C = Cic in
 359   let module M = CicMetaSubst in
 360   let module U = CicUnification in
 361   let lookup = lookup_subst in
 362   let rec occurs_check subst what where =
 363     match where with
 364     | t when what = t -> true
 365     | C.Appl l -> List.exists (occurs_check subst what) l
 366     | C.Meta _ ->
 367         let t = lookup where subst in
 368         if t <> where then occurs_check subst what t else false
 369     | _ -> false
 370   in
 371   let rec unif subst menv s t =
 372     let s = match s with C.Meta _ -> lookup s subst | _ -> s
 373     and t = match t with C.Meta _ -> lookup t subst | _ -> t
 374     in
 375     match s, t with
 376     | s, t when s = t -> subst, menv
 377     | C.Meta (i, _), C.Meta (j, _) when i > j ->
 378         unif subst menv t s
 379     | C.Meta _, t when occurs_check subst s t ->
 380         raise
 381           (U.UnificationFailure (lazy "Inference.unification.unif"))
 382     | C.Meta (i, l), t -> (
 383         try
 384           let _, _, ty = CicUtil.lookup_meta i menv in
 385           let subst =
 386             if not (List.mem_assoc i subst) then (i, (context, t, ty))::subst
 387             else subst
 388           in
 389           let menv = menv in (* List.filter (fun (m, _, _) -> i <> m) menv in *)
 390           subst, menv
 391         with CicUtil.Meta_not_found m ->
 392           let names = names_of_context context in
 393           debug_print
 394             (lazy
 395                (Printf.sprintf "Meta_not_found %d!: %s %s\n%s\n\n%s" m
 396                   (CicPp.pp t1 names) (CicPp.pp t2 names)
 397                   (print_metasenv menv) (print_metasenv metasenv)));
 398           assert false
 399       )
 400     | _, C.Meta _ -> unif subst menv t s
 401     | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt ->
 402         raise (U.UnificationFailure (lazy "Inference.unification.unif"))
 403     | C.Appl (hds::tls), C.Appl (hdt::tlt) -> (
 404         try
 405           List.fold_left2
 406             (fun (subst', menv) s t -> unif subst' menv s t)
 407             (subst, menv) tls tlt
 408         with Invalid_argument _ ->
 409           raise (U.UnificationFailure (lazy "Inference.unification.unif"))
 410       )
 411     | _, _ ->
 412         raise (U.UnificationFailure (lazy "Inference.unification.unif"))
 413   in
 414   let subst, menv = unif [] metasenv t1 t2 in
 415   let menv =
 416     List.filter
 417       (fun (m, _, _) ->
 418          try let _ = List.find (fun (i, _) -> m = i) subst in false
 419          with Not_found -> true)
 420       menv
 421   in
 422   List.rev subst, menv, ugraph
 423 ;;
 424
 425
 426 let unification metasenv context t1 t2 ugraph =
 427   let subst, menv, ug =
 428     if not (is_simple_term t1) || not (is_simple_term t2) then (
 429       debug_print
 430         (lazy
 431            (Printf.sprintf "NOT SIMPLE TERMS: %s %s"
 432               (CicPp.ppterm t1) (CicPp.ppterm t2)));
 433       CicUnification.fo_unif metasenv context t1 t2 ugraph
 434     ) else
 435       unification_simple metasenv context t1 t2 ugraph
 436   in
 437   let rec fix_term = function
 438     | (Cic.Meta (i, l) as t) ->
 439         let t' = lookup_subst t subst in
 440         if t <> t' then fix_term t' else t
 441     | Cic.Appl l -> Cic.Appl (List.map fix_term l)
 442     | t -> t
 443   in
 444   let rec fix_subst = function
 445     | [] -> []
 446     | (i, (c, t, ty))::tl -> (i, (c, fix_term t, fix_term ty))::(fix_subst tl)
 447   in
 448   fix_subst subst, menv, ug
 449 ;;
 450
 451
 452 (* let unification = CicUnification.fo_unif;; *)
 453
 454 exception MatchingFailure;;
 455
 456
 457 (*
 458 let matching_simple metasenv context t1 t2 ugraph =
 459   let module C = Cic in
 460   let module M = CicMetaSubst in
 461   let module U = CicUnification in
 462   let lookup meta subst =
 463     match meta with
 464     | C.Meta (i, _) -> (
 465         try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t
 466         with Not_found -> meta
 467       )
 468     | _ -> assert false
 469   in
 470   let rec do_match subst menv s t =
 471     match s, t with
 472     | s, t when s = t -> subst, menv
 473     | s, C.Meta (i, l) ->
 474         let filter_menv i menv =
 475           List.filter (fun (m, _, _) -> i <> m) menv
 476         in
 477         let subst, menv =
 478           let value = lookup t subst in
 479           match value with
 480           | value when value = t ->
 481               let _, _, ty = CicUtil.lookup_meta i menv in
 482               (i, (context, s, ty))::subst, filter_menv i menv
 483           | value when value <> s ->
 484               raise MatchingFailure
 485           | value -> do_match subst menv s value
 486         in
 487         subst, menv
 488     | C.Appl ls, C.Appl lt -> (
 489         try
 490           List.fold_left2
 491             (fun (subst, menv) s t -> do_match subst menv s t)
 492             (subst, menv) ls lt
 493         with Invalid_argument _ ->
 494           raise MatchingFailure
 495       )
 496     | _, _ ->
 497         raise MatchingFailure
 498   in
 499   let subst, menv = do_match [] metasenv t1 t2 in
 500   subst, menv, ugraph
 501 ;;
 502 *)
 503
 504
 505 let matching metasenv context t1 t2 ugraph =
 506     try
 507       let subst, metasenv, ugraph =
 508         unification metasenv context t1 t2 ugraph
 509       in
 510       let t' = CicMetaSubst.apply_subst subst t1 in
 511       if not (meta_convertibility t1 t') then
 512         raise MatchingFailure
 513       else
 514         let metas = metas_of_term t1 in
 515         let fix_subst = function
 516           | (i, (c, Cic.Meta (j, lc), ty)) when List.mem i metas ->
 517               (j, (c, Cic.Meta (i, lc), ty))
 518           | s -> s
 519         in
 520         let subst = List.map fix_subst subst in
 521         subst, metasenv, ugraph
 522     with
 523     | CicUnification.UnificationFailure _
 524     | CicUnification.Uncertain _ ->
 525       raise MatchingFailure
 526 ;;
 527
 528
 529 let find_equalities context proof =
 530   let module C = Cic in
 531   let module S = CicSubstitution in
 532   let module T = CicTypeChecker in
 533   let eq_uri = LibraryObjects.eq_URI () in
 534   let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in
 535   let ok_types ty menv =
 536     List.for_all (fun (_, _, mt) -> mt = ty) menv
 537   in
 538   let rec aux index newmeta = function
 539     | [] -> [], newmeta
 540     | (Some (_, C.Decl (term)))::tl ->
 541         let do_find context term =
 542           match term with
 543           | C.Prod (name, s, t) ->
 544               let (head, newmetas, args, newmeta) =
 545                 ProofEngineHelpers.saturate_term newmeta []
 546                   context (S.lift index term) 0
 547               in
 548               let p =
 549                 if List.length args = 0 then
 550                   C.Rel index
 551                 else
 552                   C.Appl ((C.Rel index)::args)
 553               in (
 554                 match head with
 555                 | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
 556                     when (UriManager.eq uri eq_uri) && (ok_types ty newmetas) ->
 557                     debug_print
 558                       (lazy
 559                          (Printf.sprintf "OK: %s" (CicPp.ppterm term)));
 560                     let o = !Utils.compare_terms t1 t2 in
 561                     let w = compute_equality_weight ty t1 t2 in
 562                     let proof = BasicProof p in
 563                     let e = (w, proof, (ty, t1, t2, o), newmetas, args) in
 564                     Some e, (newmeta+1)
 565                 | _ -> None, newmeta
 566               )
 567           | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
 568               when UriManager.eq uri eq_uri ->
 569               let t1 = S.lift index t1
 570               and t2 = S.lift index t2 in
 571               let o = !Utils.compare_terms t1 t2 in
 572               let w = compute_equality_weight ty t1 t2 in
 573               let e = (w, BasicProof (C.Rel index), (ty, t1, t2, o), [], []) in
 574               Some e, (newmeta+1)
 575           | _ -> None, newmeta
 576         in (
 577           match do_find context term with
 578           | Some p, newmeta ->
 579               let tl, newmeta' = (aux (index+1) newmeta tl) in
 580               (index, p)::tl, max newmeta newmeta'
 581           | None, _ ->
 582               aux (index+1) newmeta tl
 583         )
 584     | _::tl ->
 585         aux (index+1) newmeta tl
 586   in
 587   let il, maxm = aux 1 newmeta context in
 588   let indexes, equalities = List.split il in
 589   indexes, equalities, maxm
 590 ;;
 591
 592
 593 let equations_blacklist =
 594   List.fold_left
 595     (fun s u -> UriManager.UriSet.add (UriManager.uri_of_string u) s)
 596     UriManager.UriSet.empty [
 597       "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)";
 598       "cic:/Coq/Init/Logic/trans_eq.con";
 599       "cic:/Coq/Init/Logic/f_equal.con";
 600       "cic:/Coq/Init/Logic/f_equal2.con";
 601       "cic:/Coq/Init/Logic/f_equal3.con";
 602       "cic:/Coq/Init/Logic/f_equal4.con";
 603       "cic:/Coq/Init/Logic/f_equal5.con";
 604       "cic:/Coq/Init/Logic/sym_eq.con";
 605       "cic:/Coq/Init/Logic/eq_ind.con";
 606       "cic:/Coq/Init/Logic/eq_ind_r.con";
 607       "cic:/Coq/Init/Logic/eq_rec.con";
 608       "cic:/Coq/Init/Logic/eq_rec_r.con";
 609       "cic:/Coq/Init/Logic/eq_rect.con";
 610       "cic:/Coq/Init/Logic/eq_rect_r.con";
 611       "cic:/Coq/Logic/Eqdep/UIP.con";
 612       "cic:/Coq/Logic/Eqdep/UIP_refl.con";
 613       "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con";
 614       "cic:/Coq/ZArith/Zcompare/rename.con";
 615       (* ALB !!!! questo e` imbrogliare, ma x ora lo lasciamo cosi`...
 616          perche' questo cacchio di teorema rompe le scatole :'( *)
 617       "cic:/Rocq/SUBST/comparith/mult_n_2.con";
 618
 619       "cic:/matita/logic/equality/eq_f.con";
 620       "cic:/matita/logic/equality/eq_f2.con";
 621       "cic:/matita/logic/equality/eq_rec.con";
 622       "cic:/matita/logic/equality/eq_rect.con";
 623     ]
 624 ;;
 625
 626 let find_library_equalities dbd context status maxmeta =
 627   let module C = Cic in
 628   let module S = CicSubstitution in
 629   let module T = CicTypeChecker in
 630   let blacklist =
 631     List.fold_left
 632       (fun s u -> UriManager.UriSet.add u s)
 633       equations_blacklist
 634       [eq_XURI (); sym_eq_URI (); trans_eq_URI (); eq_ind_URI ();
 635        eq_ind_r_URI ()]
 636   in
 637   let candidates =
 638     List.fold_left
 639       (fun l uri ->
 640         let suri = UriManager.string_of_uri uri in
 641          if UriManager.UriSet.mem uri blacklist then
 642            l
 643          else
 644            let t = CicUtil.term_of_uri uri in
 645            let ty, _ =
 646              CicTypeChecker.type_of_aux' [] context t CicUniv.empty_ugraph
 647            in
 648            (uri, t, ty)::l)
 649       []
 650       (let t1 = Unix.gettimeofday () in
 651        let eqs = (MetadataQuery.equations_for_goal ~dbd status) in
 652        let t2 = Unix.gettimeofday () in
 653        (debug_print
 654           (lazy
 655              (Printf.sprintf "Tempo di MetadataQuery.equations_for_goal: %.9f\n"
 656                 (t2 -. t1))));
 657        eqs)
 658   in
 659   let eq_uri1 = eq_XURI ()
 660   and eq_uri2 = LibraryObjects.eq_URI () in
 661   let iseq uri =
 662     (UriManager.eq uri eq_uri1) || (UriManager.eq uri eq_uri2)
 663   in
 664   let ok_types ty menv =
 665     List.for_all (fun (_, _, mt) -> mt = ty) menv
 666   in
 667   let rec has_vars = function
 668     | C.Meta _ | C.Rel _ | C.Const _ -> false
 669     | C.Var _ -> true
 670     | C.Appl l -> List.exists has_vars l
 671     | C.Prod (_, s, t) | C.Lambda (_, s, t)
 672     | C.LetIn (_, s, t) | C.Cast (s, t) ->
 673         (has_vars s) || (has_vars t)
 674     | _ -> false
 675   in
 676   let rec aux newmeta = function
 677     | [] -> [], newmeta
 678     | (uri, term, termty)::tl ->
 679         debug_print
 680           (lazy
 681              (Printf.sprintf "Examining: %s (%s)"
 682                 (CicPp.ppterm term) (CicPp.ppterm termty)));
 683         let res, newmeta =
 684           match termty with
 685           | C.Prod (name, s, t) when not (has_vars termty) ->
 686               let head, newmetas, args, newmeta =
 687                 ProofEngineHelpers.saturate_term newmeta [] context termty 0
 688               in
 689               let p =
 690                 if List.length args = 0 then
 691                   term
 692                 else
 693                   C.Appl (term::args)
 694               in (
 695                 match head with
 696                 | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
 697                     when (iseq uri) && (ok_types ty newmetas) ->
 698                     debug_print
 699                       (lazy
 700                          (Printf.sprintf "OK: %s" (CicPp.ppterm term)));
 701                     let o = !Utils.compare_terms t1 t2 in
 702                     let w = compute_equality_weight ty t1 t2 in
 703                     let proof = BasicProof p in
 704                     let e = (w, proof, (ty, t1, t2, o), newmetas, args) in
 705                     Some e, (newmeta+1)
 706                 | _ -> None, newmeta
 707               )
 708           | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
 709               when iseq uri && not (has_vars termty) ->
 710               let o = !Utils.compare_terms t1 t2 in
 711               let w = compute_equality_weight ty t1 t2 in
 712               let e = (w, BasicProof term, (ty, t1, t2, o), [], []) in
 713               Some e, (newmeta+1)
 714           | _ -> None, newmeta
 715         in
 716         match res with
 717         | Some e ->
 718             let tl, newmeta' = aux newmeta tl in
 719             (uri, e)::tl, max newmeta newmeta'
 720         | None ->
 721             aux newmeta tl
 722   in
 723   let found, maxm = aux maxmeta candidates in
 724   let uriset, eqlist =
 725     (List.fold_left
 726        (fun (s, l) (u, e) ->
 727           if List.exists (meta_convertibility_eq e) l then (
 728             debug_print
 729               (lazy
 730                  (Printf.sprintf "NO!! %s already there!"
 731                     (string_of_equality e)));
 732             (UriManager.UriSet.add u s, l)
 733           ) else (UriManager.UriSet.add u s, e::l))
 734        (UriManager.UriSet.empty, []) found)
 735   in
 736   uriset, eqlist, maxm
 737 ;;
 738
 739
 740 let find_library_theorems dbd env status equalities_uris =
 741   let module C = Cic in
 742   let module S = CicSubstitution in
 743   let module T = CicTypeChecker in
 744   let blacklist =
 745     let refl_equal =
 746       UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)" in
 747     let s =
 748       UriManager.UriSet.remove refl_equal
 749         (UriManager.UriSet.union equalities_uris equations_blacklist)
 750     in
 751     List.fold_left
 752       (fun s u -> UriManager.UriSet.add u s)
 753       s [eq_XURI () ;sym_eq_URI (); trans_eq_URI (); eq_ind_URI ();
 754          eq_ind_r_URI ()]
 755   in
 756   let metasenv, context, ugraph = env in
 757   let candidates =
 758     List.fold_left
 759       (fun l uri ->
 760          if UriManager.UriSet.mem uri blacklist then l
 761          else
 762            let t = CicUtil.term_of_uri uri in
 763            let ty, _ = CicTypeChecker.type_of_aux' metasenv context t ugraph in
 764            (t, ty, [])::l)
 765       [] (MetadataQuery.signature_of_goal ~dbd status)
 766   in
 767   let refl_equal =
 768     let u = eq_XURI () in
 769     let t = CicUtil.term_of_uri u in
 770     let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in
 771     (t, ty, [])
 772   in
 773   refl_equal::candidates
 774 ;;
 775
 776
 777 let find_context_hypotheses env equalities_indexes =
 778   let metasenv, context, ugraph = env in
 779   let _, res =
 780     List.fold_left
 781       (fun (n, l) entry ->
 782          match entry with
 783          | None -> (n+1, l)
 784          | Some _ ->
 785              if List.mem n equalities_indexes then
 786                (n+1, l)
 787              else
 788                let t = Cic.Rel n in
 789                let ty, _ =
 790                  CicTypeChecker.type_of_aux' metasenv context t ugraph in
 791                (n+1, (t, ty, [])::l))
 792       (1, []) context
 793   in
 794   res
 795 ;;
 796
 797
 798 let fix_metas newmeta ((w, p, (ty, left, right, o), menv, args) as equality) =
 799   let table = Hashtbl.create (List.length args) in
 800   let newargs, newmeta =
 801     List.fold_right
 802       (fun t (newargs, index) ->
 803          match t with
 804          | Cic.Meta (i, l) ->
 805              if Hashtbl.mem table i then
 806                let idx = Hashtbl.find table i in
 807                ((Cic.Meta (idx, l))::newargs, index+1)
 808              else
 809                let _ = Hashtbl.add table i index in
 810                ((Cic.Meta (index, l))::newargs, index+1)
 811          | _ -> assert false)
 812       args ([], newmeta+1)
 813   in
 814   let repl where =
 815     ProofEngineReduction.replace ~equality:(=) ~what:args ~with_what:newargs
 816       ~where
 817   in
 818   let menv' =
 819     List.fold_right
 820       (fun (i, context, term) menv ->
 821          try
 822            let index = Hashtbl.find table i in
 823            (index, context, term)::menv
 824          with Not_found ->
 825            (i, context, term)::menv)
 826       menv []
 827   in
 828   let ty = repl ty
 829   and left = repl left
 830   and right = repl right in
 831   let metas = (metas_of_term left) @ (metas_of_term right) in
 832   let menv' = List.filter (fun (i, _, _) -> List.mem i metas) menv' in
 833   let newargs =
 834     List.filter
 835       (function Cic.Meta (i, _) -> List.mem i metas | _ -> assert false) newargs
 836   in
 837   let _ =
 838     if List.length metas > 0 then
 839       let first = List.hd metas in
 840       (* this new equality might have less variables than its parents: here
 841          we fill the gap with a dummy arg. Example:
 842          with (f X Y) = X we can simplify
 843          (g X) = (f X Y) in
 844          (g X) = X.
 845          So the new equation has only one variable, but it still has type like
 846          \lambda X,Y:..., so we need to pass a dummy arg for Y
 847          (I hope this makes some sense...)
 848       *)
 849       Hashtbl.iter
 850         (fun k v ->
 851            if not (List.exists
 852                      (function Cic.Meta (i, _) -> i = v | _ -> assert false)
 853                      newargs) then
 854              Hashtbl.replace table k first)
 855         (Hashtbl.copy table)
 856   in
 857   let rec fix_proof = function
 858     | NoProof -> NoProof
 859     | BasicProof term -> BasicProof (repl term)
 860     | ProofBlock (subst, eq_URI, namety, bo, (pos, eq), p) ->
 861         let subst' =
 862           List.fold_left
 863             (fun s arg ->
 864                match arg with
 865                | Cic.Meta (i, l) -> (
 866                    try
 867                      let j = Hashtbl.find table i in
 868                      if List.mem_assoc i subst then
 869                        s
 870                      else
 871                        let _, context, ty = CicUtil.lookup_meta i menv in
 872                        (i, (context, Cic.Meta (j, l), ty))::s
 873                    with Not_found | CicUtil.Meta_not_found _ ->
 874                      s
 875                  )
 876                | _ -> assert false)
 877             [] args
 878         in
 879         ProofBlock (subst' @ subst, eq_URI, namety, bo(* t' *), (pos, eq), p)
 880     | p -> assert false
 881   in
 882   let neweq = (w, fix_proof p, (ty, left, right, o), menv', newargs) in
 883   (newmeta + 1, neweq)
 884 ;;
 885
 886
 887 let term_is_equality term =
 888   let iseq uri = UriManager.eq uri (LibraryObjects.eq_URI ()) in
 889   match term with
 890   | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _] when iseq uri -> true
 891   | _ -> false
 892 ;;
 893
 894
 895 exception TermIsNotAnEquality;;
 896
 897 let equality_of_term proof term =
 898   let eq_uri = LibraryObjects.eq_URI () in
 899   let iseq uri = UriManager.eq uri eq_uri in
 900   match term with
 901   | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] when iseq uri ->
 902       let o = !Utils.compare_terms t1 t2 in
 903       let w = compute_equality_weight ty t1 t2 in
 904       let e = (w, BasicProof proof, (ty, t1, t2, o), [], []) in
 905       e
 906   | _ ->
 907       raise TermIsNotAnEquality
 908 ;;
 909
 910
 911 type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph;;
 912
 913
 914 let is_identity ((_, context, ugraph) as env) = function
 915   | ((_, _, (ty, left, right, _), _, _) as equality) ->
 916       (left = right ||
 917           (meta_convertibility left right) ||
 918           (fst (CicReduction.are_convertible context left right ugraph)))
 919 ;;