-(* filter out from metasenv the variables in substs *)
-let filter subst metasenv =
- List.filter
- (fun (m, _, _) ->
- try let _ = List.find (fun (i, _) -> m = i) subst in false
- with Not_found -> true)
- metasenv
-;;
-
-(* returns an explicit named subst and a list of arguments for sym_eq_URI *)
-let build_ens_for_sym_eq sym_eq_URI termlist =
- let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph sym_eq_URI in
- match obj with
- | Cic.Constant (_, _, _, uris, _) ->
- assert (List.length uris <= List.length termlist);
- let rec aux = function
- | [], tl -> [], tl
- | (uri::uris), (term::tl) ->
- let ens, args = aux (uris, tl) in
- (uri, term)::ens, args
- | _, _ -> assert false
- in
- aux (uris, termlist)
- | _ -> assert false
-;;
-
-
-let build_proof_term ?(noproof=Cic.Implicit None) proof =
- let rec do_build_proof proof =
- match proof with
- | NoProof ->
- Printf.fprintf stderr "WARNING: no proof!\n";
- noproof
- | BasicProof term -> term
- | ProofGoalBlock (proofbit, proof) ->
- print_endline "found ProofGoalBlock, going up...";
- do_build_goal_proof proofbit proof
- | ProofSymBlock (termlist, proof) ->
- let proof = do_build_proof proof in
- let ens, args = build_ens_for_sym_eq (Utils.sym_eq_URI ()) termlist in
- Cic.Appl ([Cic.Const (Utils.sym_eq_URI (), ens)] @ args @ [proof])
- | ProofBlock (subst, eq_URI, (name, ty), bo, (pos, eq), eqproof) ->
- let t' = Cic.Lambda (name, ty, bo) in
- let proof' =
- let _, proof', _, _, _ = eq in
- do_build_proof proof'
- in
- let eqproof = do_build_proof eqproof 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'])
- | SubProof (term, meta_index, proof) ->
- let proof = do_build_proof proof in
- let eq i = function
- | Cic.Meta (j, _) -> i = j
- | _ -> false
- in
- ProofEngineReduction.replace
- ~equality:eq ~what:[meta_index] ~with_what:[proof] ~where:term
-
- and do_build_goal_proof proofbit proof =
- match proof with
- | ProofGoalBlock (pb, p) ->
- do_build_proof (ProofGoalBlock (replace_proof proofbit pb, p))
- | _ -> do_build_proof (replace_proof proofbit proof)
-
- and replace_proof newproof = function
- | ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof) ->
- let eqproof' = replace_proof newproof eqproof in
- ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof')
- | ProofGoalBlock (pb, p) ->
- let pb' = replace_proof newproof pb in
- ProofGoalBlock (pb', p)
- | BasicProof _ -> newproof
- | SubProof (term, meta_index, p) ->
- SubProof (term, meta_index, replace_proof newproof p)
- | p -> p
- in
- do_build_proof proof
-;;
-
-
-let rec metas_of_term = function
- | Cic.Meta (i, c) -> [i]
- | Cic.Var (_, ens)
- | Cic.Const (_, ens)
- | Cic.MutInd (_, _, ens)
- | Cic.MutConstruct (_, _, _, ens) ->
- List.flatten (List.map (fun (u, t) -> metas_of_term t) ens)
- | Cic.Cast (s, t)
- | Cic.Prod (_, s, t)
- | Cic.Lambda (_, s, t)
- | Cic.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t)
- | Cic.Appl l -> List.flatten (List.map metas_of_term l)
- | Cic.MutCase (uri, i, s, t, l) ->
- (metas_of_term s) @ (metas_of_term t) @
- (List.flatten (List.map metas_of_term l))
- | Cic.Fix (i, il) ->
- List.flatten
- (List.map (fun (s, i, t1, t2) ->
- (metas_of_term t1) @ (metas_of_term t2)) il)
- | Cic.CoFix (i, il) ->
- List.flatten
- (List.map (fun (s, t1, t2) ->
- (metas_of_term t1) @ (metas_of_term t2)) il)
- | _ -> []
-;;
-
-let rec metas_of_proof p =
- if Utils.debug then
- let t1 = Unix.gettimeofday () in
- let res = metas_of_term (build_proof_term p) in
- let t2 = Unix.gettimeofday () in
- metas_of_proof_time := !metas_of_proof_time +. (t2 -. t1);
- res
- else
- metas_of_term (build_proof_term p)
-;;
-
-exception NotMetaConvertible;;
-
-let meta_convertibility_aux table t1 t2 =
- let module C = Cic in
- let rec aux ((table_l, table_r) as table) t1 t2 =
- match t1, t2 with
- | C.Meta (m1, tl1), C.Meta (m2, tl2) ->
- let m1_binding, table_l =
- try List.assoc m1 table_l, table_l
- with Not_found -> m2, (m1, m2)::table_l
- and m2_binding, table_r =
- try List.assoc m2 table_r, table_r
- with Not_found -> m1, (m2, m1)::table_r
- in
- if (m1_binding <> m2) || (m2_binding <> m1) then
- raise NotMetaConvertible
- else (
- try
- List.fold_left2
- (fun res t1 t2 ->
- match t1, t2 with
- | None, Some _ | Some _, None -> raise NotMetaConvertible
- | None, None -> res
- | Some t1, Some t2 -> (aux res t1 t2))
- (table_l, table_r) tl1 tl2
- with Invalid_argument _ ->
- raise NotMetaConvertible
- )
- | C.Var (u1, ens1), C.Var (u2, ens2)
- | C.Const (u1, ens1), C.Const (u2, ens2) when (UriManager.eq u1 u2) ->
- aux_ens table ens1 ens2
- | C.Cast (s1, t1), C.Cast (s2, t2)
- | C.Prod (_, s1, t1), C.Prod (_, s2, t2)
- | C.Lambda (_, s1, t1), C.Lambda (_, s2, t2)
- | C.LetIn (_, s1, t1), C.LetIn (_, s2, t2) ->
- let table = aux table s1 s2 in
- aux table t1 t2
- | C.Appl l1, C.Appl l2 -> (
- try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | C.MutInd (u1, i1, ens1), C.MutInd (u2, i2, ens2)
- when (UriManager.eq u1 u2) && i1 = i2 -> aux_ens table ens1 ens2
- | C.MutConstruct (u1, i1, j1, ens1), C.MutConstruct (u2, i2, j2, ens2)
- when (UriManager.eq u1 u2) && i1 = i2 && j1 = j2 ->
- aux_ens table ens1 ens2
- | C.MutCase (u1, i1, s1, t1, l1), C.MutCase (u2, i2, s2, t2, l2)
- when (UriManager.eq u1 u2) && i1 = i2 ->
- let table = aux table s1 s2 in
- let table = aux table t1 t2 in (
- try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | C.Fix (i1, il1), C.Fix (i2, il2) when i1 = i2 -> (
- try
- List.fold_left2
- (fun res (n1, i1, s1, t1) (n2, i2, s2, t2) ->
- if i1 <> i2 then raise NotMetaConvertible
- else
- let res = (aux res s1 s2) in aux res t1 t2)
- table il1 il2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | C.CoFix (i1, il1), C.CoFix (i2, il2) when i1 = i2 -> (
- try
- List.fold_left2
- (fun res (n1, s1, t1) (n2, s2, t2) ->
- let res = aux res s1 s2 in aux res t1 t2)
- table il1 il2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | t1, t2 when t1 = t2 -> table
- | _, _ -> raise NotMetaConvertible
-
- and aux_ens table ens1 ens2 =
- let cmp (u1, t1) (u2, t2) =
- compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2)
- in
- let ens1 = List.sort cmp ens1
- and ens2 = List.sort cmp ens2 in
- try
- List.fold_left2
- (fun res (u1, t1) (u2, t2) ->
- if not (UriManager.eq u1 u2) then raise NotMetaConvertible
- else aux res t1 t2)
- table ens1 ens2
- with Invalid_argument _ -> raise NotMetaConvertible
- in
- aux table t1 t2
-;;
-
-
-let meta_convertibility_eq eq1 eq2 =
- let _, _, (ty, left, right, _), _, _ = eq1
- and _, _, (ty', left', right', _), _, _ = eq2 in
- if ty <> ty' then
- false
- else if (left = left') && (right = right') then
- true
- else if (left = right') && (right = left') then
- true
- else
- try
- let table = meta_convertibility_aux ([], []) left left' in
- let _ = meta_convertibility_aux table right right' in
- true
- with NotMetaConvertible ->
- try
- let table = meta_convertibility_aux ([], []) left right' in
- let _ = meta_convertibility_aux table right left' in
- true
- with NotMetaConvertible ->
- false
-;;
-
-
-let meta_convertibility t1 t2 =
- if t1 = t2 then
- true
- else
- try
- ignore(meta_convertibility_aux ([], []) t1 t2);
- true
- with NotMetaConvertible ->
- false
-;;
-
-