more abstract discrimination tree

[helm.git] / helm / software / components / cic / cicUtil.ml

diff --git a/helm/software/components/cic/cicUtil.ml b/helm/software/components/cic/cicUtil.ml
index dd165219694c2f1bbf1f0dc361f952e709e74532..8c42aed6131a5348fb542f580eb1422f423d87e8 100644 (file)
--- a/helm/software/components/cic/cicUtil.ml
+++ b/helm/software/components/cic/cicUtil.ml
@@ -79,7 +79,8 @@ let is_closed =
     | C.Cast (te,ty) -> is_closed k te && is_closed k ty
     | C.Prod (name,so,dest) -> is_closed k so && is_closed (k+1) dest
     | C.Lambda (_,so,dest) -> is_closed k so && is_closed (k+1) dest
-    | C.LetIn (_,so,dest) -> is_closed k so && is_closed (k+1) dest
+    | C.LetIn (_,so,ty,dest) ->
+       is_closed k so && is_closed k ty && is_closed (k+1) dest
     | C.Appl l ->
        List.fold_right (fun x i -> i && is_closed k x) l true
     | C.Var (_,exp_named_subst)
@@ -116,7 +117,10 @@ let rec is_meta_closed =
     | C.Cast (te,ty) -> is_meta_closed te && is_meta_closed ty
     | C.Prod (name,so,dest) -> is_meta_closed so && is_meta_closed dest
     | C.Lambda (_,so,dest) -> is_meta_closed so && is_meta_closed dest
-    | C.LetIn (_,so,dest) -> is_meta_closed so && is_meta_closed dest
+    | C.LetIn (_,so,ty,dest) ->
+       is_meta_closed so &&
+       is_meta_closed ty &&
+       is_meta_closed dest
     | C.Appl l ->
        not (List.exists (fun x -> not (is_meta_closed x)) l)
     | C.Var (_,exp_named_subst)
@@ -250,7 +254,7 @@ let id_of_annterm =
   | C.ACast (id,_,_)
   | C.AProd (id,_,_,_)
   | C.ALambda (id,_,_,_)
-  | C.ALetIn (id,_,_,_)
+  | C.ALetIn (id,_,_,_,_)
   | C.AAppl (id,_)
   | C.AConst (id,_,_)
   | C.AMutInd (id,_,_,_)
@@ -290,7 +294,8 @@ let rec rehash_term =
    | C.Cast (te,ty) -> C.Cast (rehash_term te, rehash_term ty)
    | C.Prod (n,s,t) -> C.Prod (n, rehash_term s, rehash_term t)
    | C.Lambda (n,s,t) -> C.Lambda (n, rehash_term s, rehash_term t)
-   | C.LetIn (n,s,t) -> C.LetIn (n, rehash_term s, rehash_term t)
+   | C.LetIn (n,s,ty,t) ->
+      C.LetIn (n, rehash_term s, rehash_term ty, rehash_term t)
    | C.Appl l -> C.Appl (List.map rehash_term l)
    | C.Const (uri,exp_named_subst) ->
       let uri' = recons uri in
@@ -355,12 +360,7 @@ let rehash_obj =
              | Some (name,C.Decl t) ->
                  Some (name,C.Decl (rehash_term t))
              | Some (name,C.Def (bo,ty)) ->
-                 let ty' =
-                   match ty with
-                     None -> None
-                   | Some ty'' -> Some (rehash_term ty'')
-                 in
-                 Some (name,C.Def (rehash_term bo, ty'))) hyps,
+                 Some (name,C.Def (rehash_term bo, rehash_term ty))) hyps,
            rehash_term ty))
          conjs
      in
@@ -400,8 +400,9 @@ let rec metas_of_term = function
       List.flatten (List.map (fun (u, t) -> metas_of_term t) ens)
   | C.Cast (s, t)
   | C.Prod (_, s, t)
-  | C.Lambda (_, s, t)
-  | C.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t)
+  | C.Lambda (_, s, t) -> (metas_of_term s) @ (metas_of_term t)
+  | C.LetIn (_, s, ty, t) ->
+     (metas_of_term s) @ (metas_of_term ty) @ (metas_of_term t)
   | C.Appl l -> List.flatten (List.map metas_of_term l)
   | C.MutCase (uri, i, s, t, l) ->
       (metas_of_term s) @ (metas_of_term t) @
@@ -435,8 +436,10 @@ let rec metas_of_term_set = function
         S.empty ens
   | C.Cast (s, t)
   | C.Prod (_, s, t)
-  | C.Lambda (_, s, t)
-  | C.LetIn (_, s, t) -> S.union (metas_of_term_set s) (metas_of_term_set t)
+  | C.Lambda (_, s, t) -> S.union (metas_of_term_set s) (metas_of_term_set t)
+  | C.LetIn (_, s, ty, t) ->
+     S.union (metas_of_term_set s)
+      (S.union (metas_of_term_set ty) (metas_of_term_set t))
   | C.Appl l -> 
       List.fold_left 
         (fun s t -> S.union s (metas_of_term_set t)) 
@@ -482,8 +485,8 @@ let alpha_equivalence =
         aux s s' && aux t t'
      | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
         aux s s' && aux t t'
-     | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
-        aux s s' && aux t t'
+     | C.LetIn (_,s,ty,t), C.LetIn(_,s',ty',t') ->
+        aux s s' && aux ty ty' && aux t t'
      | C.Appl l, C.Appl l' when List.length l = List.length l' ->
         (try
           List.fold_left2
@@ -554,42 +557,44 @@ let alpha_equivalence =
   in
    aux
 
-let is_sober t =
-   let rec sober_term g = function
+let is_sober c t =
+   let rec sober_term c g = function
       | C.Rel _ 
       | C.Sort _  
       | C.Implicit _                    -> g      
       | C.Const (_, xnss) 
       | C.Var (_, xnss) 
       | C.MutConstruct (_, _, _, xnss)
-      | C.MutInd (_, _, xnss)           -> sober_xnss g xnss
-      | C.Meta (_, xss)                 -> sober_xss g xss
-      | C.LetIn (_, v, t)
+      | C.MutInd (_, _, xnss)           -> sober_xnss c g xnss
+      | C.Meta (_, xss)                 -> sober_xss c g xss
       | C.Lambda (_, v, t)
       | C.Prod (_, v, t)
-      | C.Cast (t, v)                   -> sober_term (sober_term g t) v
+      | C.Cast (t, v)                   ->
+         sober_term c (sober_term c g t) v
+      | C.LetIn (_, v, ty, t)           ->
+         sober_term c (sober_term c (sober_term c g t) ty) v
       | C.Appl []                       
       | C.Appl [_]                      -> fun b -> false
-      | C.Appl ts                       -> sober_terms g ts
+      | C.Appl ts                       -> sober_terms c g ts
       | C.MutCase (_, _, t, v, ts)      -> 
-         sober_terms (sober_term (sober_term g t) v) ts
-      | C.Fix (_, ifs)                  -> sober_ifs g ifs
-      | C.CoFix (_, cifs)               -> sober_cifs g cifs
-   and sober_terms g = List.fold_left sober_term g
-   and sober_xnss g =
-      let map g (_, t) = sober_term g t in
+         sober_terms c (sober_term c (sober_term c g t) v) ts
+      | C.Fix (_, ifs)                  -> sober_ifs c g ifs
+      | C.CoFix (_, cifs)               -> sober_cifs c g cifs
+   and sober_terms c g = List.fold_left (sober_term c) g
+   and sober_xnss c g =
+      let map g (_, t) = sober_term c g t in
       List.fold_left map g
-   and sober_xss g =
+   and sober_xss c g =
       let map g = function 
          | None   -> g
-        | Some t -> sober_term g t
+        | Some t -> sober_term c g t
       in
       List.fold_left map g
-   and sober_ifs g =
-      let map g (_, _, t, v) = sober_term (sober_term g t) v in
+   and sober_ifs c g =
+      let map g (_, _, t, v) = sober_term c (sober_term c g t) v in
       List.fold_left map g
-   and sober_cifs g =
-      let map g (_, t, v) = sober_term (sober_term g t) v in
+   and sober_cifs c g =
+      let map g (_, t, v) = sober_term c (sober_term c g t) v in
       List.fold_left map g
    in 
-   sober_term (fun b -> b) t true
+   sober_term c (fun b -> b) t true