X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fng_kernel%2FnCicReduction.ml;h=0393fbcdd7f5927d06cb44c0903f8d91f352ec3d;hb=7bc72d8afaebb1d2070a26b07f9bf4242b648e2c;hp=3b082339507b3739ae816516f507ebdef1a34e52;hpb=dc0eae6607f2b299deeeb1a2c4e145e7a6d40629;p=helm.git

diff --git a/helm/software/components/ng_kernel/nCicReduction.ml b/helm/software/components/ng_kernel/nCicReduction.ml
index 3b0823395..0393fbcdd 100644
--- a/helm/software/components/ng_kernel/nCicReduction.ml
+++ b/helm/software/components/ng_kernel/nCicReduction.ml
@@ -164,7 +164,7 @@ module Reduction(RS : Strategy) = struct
         | (_, _, C.Const (Ref.Ref (_,Ref.Con (_,j,lno))), s')->
           let _,params = HExtlib.split_nth lno s' in
           aux (k, e, List.nth pl (j-1), params@s)
-        | _ -> config,reduced == match_head)
+        | _ -> config, true)
    in
     aux
   ;;
@@ -257,7 +257,7 @@ let are_convertible ~metasenv ~subst =
          in
          (try
              HExtlib.list_forall_default3_var
-              (fun t1 t2 b -> not b || aux test_eq_only context t1 t2 )
+              (fun t1 t2 b -> not b || aux true context t1 t2 )
               tl1 tl2 true relevance
             with Invalid_argument _ -> false
 	       | HExtlib.FailureAt fail ->
@@ -272,7 +272,7 @@ let are_convertible ~metasenv ~subst =
 	           let _,tl2 = HExtlib.split_nth (fail+1) tl2 in
 	             try
                         HExtlib.list_forall_default3
-                        (fun t1 t2 b -> not b || aux test_eq_only context t1 t2)
+                        (fun t1 t2 b -> not b || aux true context t1 t2)
                         tl1 tl2 true relevance
                      with Invalid_argument _ -> false
 	         else false)
@@ -282,7 +282,7 @@ let are_convertible ~metasenv ~subst =
 	   let relevance = !get_relevance ~metasenv ~subst context hd1 tl1 in
             (try
              HExtlib.list_forall_default3
-              (fun t1 t2 b -> not b || aux test_eq_only context t1 t2)
+              (fun t1 t2 b -> not b || aux true context t1 t2)
               tl1 tl2 true relevance
             with Invalid_argument _ -> false)
 
@@ -339,7 +339,7 @@ let are_convertible ~metasenv ~subst =
         R.reduce ~delta ~subst context m1,
         R.reduce ~delta ~subst context m2
      in
-     let rec convert_machines 
+     let rec convert_machines test_eq_only
        ((k1,e1,t1,s1),norm1 as m1),((k2,e2,t2,s2), norm2 as m2) 
      =
        (alpha_eq test_eq_only
@@ -354,33 +354,41 @@ let are_convertible ~metasenv ~subst =
              not b ||
              let t1 = RS.from_stack t1 in
              let t2 = RS.from_stack t2 in
-             convert_machines (put_in_whd t1 t2)) s1 s2 true relevance
+             convert_machines true (put_in_whd t1 t2)) s1 s2 true relevance
         with Invalid_argument _ -> false) || 
-       (not (norm1 && norm2) && convert_machines (small_delta_step m1 m2))
+       (not (norm1 && norm2) && convert_machines test_eq_only (small_delta_step m1 m2))
      in
-     convert_machines (put_in_whd (0,[],t1,[]) (0,[],t2,[]))
+     convert_machines test_eq_only (put_in_whd (0,[],t1,[]) (0,[],t2,[]))
  in
   aux false 
 ;;
 
-let rec head_beta_reduce ?(delta=max_int) ?(upto=(-1)) t l =
+let rec head_beta_reduce ~delta ~upto ~subst t l =
  match upto, t, l with
   | 0, C.Appl l1, _ -> C.Appl (l1 @ l)
   | 0, t, [] -> t
   | 0, t, _ -> C.Appl (t::l)
-  | _, C.Appl (hd::tl), _ -> head_beta_reduce ~delta ~upto hd (tl @ l)
+  | _, C.Meta (n,ctx), _ ->
+     (try
+       let _,_, term,_ = NCicUtils.lookup_subst n subst in
+       head_beta_reduce ~delta ~upto ~subst 
+         (NCicSubstitution.subst_meta ctx term) l
+     with NCicUtils.Subst_not_found _ -> if l = [] then t else C.Appl (t::l))
+  | _, C.Appl (hd::tl), _ -> head_beta_reduce ~delta ~upto ~subst hd (tl @ l)
   | _, C.Lambda(_,_,bo), arg::tl ->
      let bo = NCicSubstitution.subst arg bo in
-     head_beta_reduce ~delta ~upto:(upto - 1) bo tl
+     head_beta_reduce ~delta ~upto:(upto - 1) ~subst bo tl
   | _, C.Const (Ref.Ref (_, Ref.Def height) as re), _ 
     when delta <= height ->
       let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def re in
-      head_beta_reduce ~upto ~delta bo l
+      head_beta_reduce ~upto ~delta ~subst bo l
   | _, t, [] -> t
   | _, t, _ -> C.Appl (t::l)
 ;;
 
-let head_beta_reduce ?delta ?upto t = head_beta_reduce ?delta ?upto t [];;
+let head_beta_reduce ?(delta=max_int) ?(upto= -1) ?(subst=[]) t = 
+  head_beta_reduce ~delta ~upto ~subst t []
+;;
 
 type stack_item = RS.stack_term
 type environment_item = RS.env_term
@@ -391,4 +399,9 @@ let reduce_machine = R.reduce
 let from_stack = RS.from_stack
 let unwind = R.unwind
 
+let _ = 
+  NCicUtils.set_head_beta_reduce (fun ~upto t -> head_beta_reduce ~upto t)
+;;
+
+
 (* vim:set foldmethod=marker: *)