QuotMain.thy
changeset 552 d9151fa76f84
parent 551 34d12737b379
child 554 8395fc6a6945
child 556 287ea842a7d4
--- a/QuotMain.thy	Sat Dec 05 00:06:27 2009 +0100
+++ b/QuotMain.thy	Sat Dec 05 13:49:35 2009 +0100
@@ -470,8 +470,6 @@
        then rtrm 
        else raise (LIFT_MATCH "regularize (bounds mismatch)")
 
-  
-
   | (rt, qt) =>
        raise (LIFT_MATCH "regularize (default)")
 *}
@@ -702,6 +700,15 @@
 *}
 
 ML {*
+fun strip_combn n u =
+    let fun stripc 0 x = x
+        |   stripc n (f $ t, ts) = stripc (n - 1) (f, t::ts)
+        |   stripc _ x =  x
+    in  stripc n (u, [])  end
+*}
+
+
+ML {*
 (* bound variables need to be treated properly,  *)
 (* as the type of subterms need to be calculated *)
 
@@ -713,10 +720,13 @@
   case (rtrm, qtrm) of
     (Const (@{const_name "Ball"}, T) $ r $ t, Const (@{const_name "All"}, _) $ t') =>
        Const (@{const_name "Ball"}, T) $ r $ (inj_repabs_trm lthy (t, t'))
+
   | (Const (@{const_name "Bex"}, T) $ r $ t, Const (@{const_name "Ex"}, _) $ t') =>
        Const (@{const_name "Bex"}, T) $ r $ (inj_repabs_trm lthy (t, t'))
-  | (Const (@{const_name "Babs"}, T) $ r $ t, t') =>
+
+  | (Const (@{const_name "Babs"}, T) $ r $ t, t' as (Abs _)) =>
        Const (@{const_name "Babs"}, T) $ r $ (inj_repabs_trm lthy (t, t'))
+
   | (Abs (x, T, t), Abs (x', T', t')) =>
       let
         val (y, s) = Term.dest_abs (x, T, t)
@@ -730,8 +740,8 @@
       end
   | _ =>
       let
-        val (rhead, rargs) = strip_comb rtrm
         val (qhead, qargs) = strip_comb qtrm
+        val (rhead, rargs) = strip_combn (length qargs) rtrm
         val rargs' = map (inj_repabs_trm lthy) (rargs ~~ qargs)
       in
         case (rhead, qhead) of
@@ -745,7 +755,12 @@
              else list_comb (mk_repabs lthy (T, T') rhead, rargs')
         | (Abs _, Abs _) =>
              list_comb (inj_repabs_trm lthy (rhead, qhead), rargs') 
-        | _ => raise (LIFT_MATCH "injection")
+ 
+        (* FIXME: when there is an (op =), then lhs might have been a term *) 
+        | (_, Const (@{const_name "op ="}, T)) =>
+             list_comb (rhead, rargs')
+        | _ => raise (LIFT_MATCH ("injection: rhead: " ^ (Syntax.string_of_term lthy rhead) 
+                                          ^ " qhead: " ^ (Syntax.string_of_term lthy qhead)))
       end
 end
 *}
@@ -1220,9 +1235,11 @@
   val reg_goal = 
         Syntax.check_term ctxt (regularize_trm ctxt rtrm' qtrm')
         handle (LIFT_MATCH s) => lift_match_error ctxt s rtrm qtrm
+  val _ = tracing "Regularization done."
   val inj_goal = 
         Syntax.check_term ctxt (inj_repabs_trm ctxt (reg_goal, qtrm'))
         handle (LIFT_MATCH s) => lift_match_error ctxt s rtrm qtrm
+  val _ = tracing "RepAbs Injection done."
 in
   Drule.instantiate' []
     [SOME (cterm_of thy rtrm'),