;;
-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 =
projects / helm.git / blobdiff