X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Fsoftware%2Fcomponents%2Fcic%2FcicUtil.ml;h=8fa9828590a604242c234bb25cf39cff3de17ce3;hb=3d16e43756f5e7c7e551e93e003a15c90627b77b;hp=d26d422d526318b3efedb7786ea0e7e2bc90ca62;hpb=111df95ac03f2ee21dfa2422a7f531f675b1c16d;p=helm.git

diff --git a/helm/software/components/cic/cicUtil.ml b/helm/software/components/cic/cicUtil.ml
index d26d422d5..8fa982859 100644
--- a/helm/software/components/cic/cicUtil.ml
+++ b/helm/software/components/cic/cicUtil.ml
@@ -25,7 +25,8 @@
 
 (* $Id$ *)
 
-module C = Cic
+module C  = Cic
+module UM = UriManager
 
 exception Meta_not_found of int
 exception Subst_not_found of int
@@ -79,7 +80,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 +118,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)
@@ -211,16 +216,6 @@ let attributes_of_obj = function
 
 let is_generated obj = List.exists ((=) `Generated) (attributes_of_obj obj)
 
-let arity_of_composed_coercion obj =
-  let attrs = attributes_of_obj obj in
-  try
-    let tag=List.find (function `Class (`Coercion _) -> true|_->false) attrs in
-    match tag with
-    |  `Class (`Coercion n) -> n
-    | _-> assert false 
-  with Not_found -> 0
-;;
-
 let projections_of_record obj uri =
   let attrs = attributes_of_obj obj in
   try
@@ -250,7 +245,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 +285,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 +351,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 +391,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 +427,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,9 +476,9 @@ 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.Appl l, C.Appl l' ->
+     | 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
            (fun b t1 t2 -> b && aux t1 t2) true l l'
@@ -535,7 +529,8 @@ let alpha_equivalence =
 	     | _               -> b
            ) true subst subst'
          with
-          Invalid_argument _ -> false)     
+          Invalid_argument _ -> false)
+     | C.Appl [t], t' | t, C.Appl [t'] -> assert false
 (* FG: are we _really_ sure of these?      
      | C.Sort (C.Type u), C.Sort (C.Type u') -> u = u' 
      | C.Implicit a, C.Implicit a' -> a = a'
@@ -552,3 +547,183 @@ let alpha_equivalence =
      Invalid_argument _ -> false
   in
    aux
+
+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 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 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 c g ts
+      | C.MutCase (_, _, t, v, ts)      -> 
+         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 c g =
+      let map g = function 
+         | None   -> g
+	 | Some t -> sober_term c g t
+      in
+      List.fold_left map g
+   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 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 c (fun b -> b) t true
+
+(* raw cic prettyprinter ****************************************************)
+
+let xiter out so ss sc map l =
+   let rec aux = function
+      | hd :: tl when tl <> [] -> map hd; out ss; aux tl
+      | hd :: tl               -> map hd; aux tl
+      | []                     -> ()
+   in
+   out so; aux l; out sc
+
+let abst s w = Some (s, C.Decl w)
+
+let abbr s v w = Some (s, C.Def (v, w))
+
+let pp_sort out = function
+   | C.Type _  -> out "*Type"
+   | C.Prop    -> out "*Prop"
+   | C.CProp _ -> out "*CProp"
+   | C.Set     -> out "*Set"
+
+let pp_name out = function
+   | C.Name s    -> out s
+   | C.Anonymous -> out "_"
+
+let pp_rel out c i =
+   try match List.nth c (pred i) with
+      | None           -> out (Printf.sprintf "%u[?]" i)
+      | Some (s, _)    -> out (Printf.sprintf "%u[" i); pp_name out s; out "]"
+   with Failure "nth" -> out (Printf.sprintf "%u[%i]" i (List.length c - i))
+
+let pp_implict out = function
+   | None         -> out "?"
+   | Some `Closed -> out "?[Closed]" 
+   | Some `Type   -> out "?[Type]"
+   | Some `Hole   -> out "?[Hole]"
+
+let pp_uri out a =
+   out (Printf.sprintf "%s<%s>" (UM.name_of_uri a) (UM.string_of_uri a)) 
+
+let rec pp_term out e c = function
+   | C.Sort h                      -> pp_sort out h
+   | C.Rel i                       -> pp_rel out c i
+   | C.Implicit x                  -> pp_implict out x
+   | C.Meta (i, iss)               ->
+      let map = function None   -> out "_" | Some v -> pp_term out e c v in
+      out (Printf.sprintf "?%u" i); xiter out "[" "; " "]" map iss
+   | C.Var (a, xss)              ->
+      pp_uri out a; pp_xss out e c xss
+   | C.Const (a, xss)              ->
+      pp_uri out a; pp_xss out e c xss
+   | C.MutInd (a, m, xss)          ->
+      pp_uri out a; out (Printf.sprintf "/%u" m);
+      pp_xss out e c xss
+   | C.MutConstruct (a, m, n, xss) ->
+      pp_uri out a; out (Printf.sprintf "/%u/%u" m n);
+      pp_xss out e c xss
+   | C.Cast (v, w)                 ->
+      out "type "; pp_term out e c w; out " contains "; pp_term out e c v
+   | C.Appl vs                     ->
+      xiter out "(" " @ " ")" (pp_term out e c) vs
+   | C.MutCase (a, m, w, v, vs)    ->
+      out "match "; pp_term out e c v;
+      out " of "; pp_uri out a; out (Printf.sprintf "/%u" m);
+      out " to "; pp_term out e c w;
+      xiter out " cases " " | " "" (pp_term out e c) vs
+   | C.Prod (s, w, t)             ->
+      out "forall "; pp_name out s; out " of "; pp_term out e c w;
+      out " in "; pp_term out e (abst s w :: c) t
+   | C.Lambda (s, w, t)            ->
+      out "fun "; pp_name out s; out " of "; pp_term out e c w;
+      out " in "; pp_term out e (abst s w :: c) t
+   | C.LetIn (s, v, w, t)          ->
+      out "let "; pp_name out s; 
+      out " def "; pp_term out e c v; out " of "; pp_term out e c w;
+      out " in "; pp_term out e (abbr s v w :: c) t
+   | C.Fix (i, fs)                 ->
+      let map c (s, _, w, v) = abbr (C.Name s) v w :: c in
+      let c' = List.fold_left map c fs in
+      let map (s, i, w, v) =
+         out (Printf.sprintf "%s[%u] def " s i); pp_term out e c' v; 
+	 out " of "; pp_term out e c w;
+      in
+      xiter out "let rec " " and " " in " map fs; pp_rel out c' (succ i)
+   | C.CoFix (i, fs)                 ->
+      let map c (s, w, v) = abbr (C.Name s) v w :: c in
+      let c' = List.fold_left map c fs in
+      let map (s, w, v) =
+         out s; pp_term out e c' v; 
+	 out " of "; pp_term out e c w;
+      in
+      xiter out "let corec " " and " " in " map fs; pp_rel out c' (succ i)
+
+and pp_xss out e c xss = 
+   let map (a, v) = pp_uri out a; out " <- "; pp_term out e c v in
+   xiter out "[" "; " "]" map xss 
+
+let pp_int out i =
+   out (Printf.sprintf "%u" i)
+
+let pp_attrs out attrs = 
+   let map = function
+      | _ -> ()
+   in
+   xiter out "[" "; " "] " map attrs 
+   
+let pp_pars out pars = 
+   xiter out " (" ", " ")\n" (pp_uri out) pars 
+
+let pp_point out point =
+   if point then out "ind " else out "coind "
+
+let pp_constructor out (s, w) =
+   out s; out " of "; pp_term out [] [] w
+
+let pp_definition out (s, point, w, ts) =
+   out "let "; pp_point out point; out s; out " of "; pp_term out [] [] w;  
+   xiter out "\ndef " "\nor " "" (pp_constructor out) ts
+
+let pp_obj out = function
+   | C.Constant (s, None, u, pars, attrs)           ->
+      out "fun "; pp_attrs out attrs; out s; pp_pars out pars;
+      out " of "; pp_term out [] [] u
+   | C.Constant (s, Some t, u, pars, attrs)         ->
+      out "let "; pp_attrs out attrs; out s; pp_pars out pars;
+      out " def "; pp_term out [] [] t; out " of "; pp_term out [] [] u
+   | C.Variable (s, None, u, pars, attrs)           ->
+      out "local fun "; pp_attrs out attrs; out s; pp_pars out pars;
+      out " of "; pp_term out [] [] u
+   | C.Variable (s, Some t, u, pars, attrs)         ->
+      out "local let "; pp_attrs out attrs; out s; pp_pars out pars;
+      out " def "; pp_term out [] [] t; out " of "; pp_term out [] [] u
+   | C.InductiveDefinition (us, pars, lpsno, attrs) ->
+      out "Inductive "; pp_attrs out attrs; pp_int out lpsno; pp_pars out pars;
+      xiter out "" "\n" "" (pp_definition out) us
+   | C.CurrentProof (s, e, t, u, pars, attrs)       ->
+      out "Current Proof" 
+