new year's resolution: reindented code in function package
authorkrauss
Sat Jan 02 23:18:58 2010 +0100 (2010-01-02)
changeset 3423236a2a3029fd3
parent 34231 da4d7d40f2f9
child 34233 156c42518cfc
new year's resolution: reindented code in function package
src/HOL/Tools/Function/context_tree.ML
src/HOL/Tools/Function/fun.ML
src/HOL/Tools/Function/function.ML
src/HOL/Tools/Function/function_common.ML
src/HOL/Tools/Function/function_core.ML
src/HOL/Tools/Function/function_lib.ML
src/HOL/Tools/Function/induction_schema.ML
src/HOL/Tools/Function/lexicographic_order.ML
src/HOL/Tools/Function/measure_functions.ML
src/HOL/Tools/Function/mutual.ML
src/HOL/Tools/Function/pattern_split.ML
src/HOL/Tools/Function/relation.ML
src/HOL/Tools/Function/sum_tree.ML
src/HOL/Tools/Function/termination.ML
     1.1 --- a/src/HOL/Tools/Function/context_tree.ML	Sat Jan 02 23:18:58 2010 +0100
     1.2 +++ b/src/HOL/Tools/Function/context_tree.ML	Sat Jan 02 23:18:58 2010 +0100
     1.3 @@ -1,39 +1,41 @@
     1.4  (*  Title:      HOL/Tools/Function/context_tree.ML
     1.5      Author:     Alexander Krauss, TU Muenchen
     1.6  
     1.7 -A package for general recursive function definitions. 
     1.8 +A package for general recursive function definitions.
     1.9  Builds and traverses trees of nested contexts along a term.
    1.10  *)
    1.11  
    1.12  signature FUNCTION_CTXTREE =
    1.13  sig
    1.14 -    type ctxt = (string * typ) list * thm list (* poor man's contexts: fixes + assumes *)
    1.15 -    type ctx_tree
    1.16 +  (* poor man's contexts: fixes + assumes *)
    1.17 +  type ctxt = (string * typ) list * thm list
    1.18 +  type ctx_tree
    1.19  
    1.20 -    (* FIXME: This interface is a mess and needs to be cleaned up! *)
    1.21 -    val get_function_congs : Proof.context -> thm list
    1.22 -    val add_function_cong : thm -> Context.generic -> Context.generic
    1.23 -    val map_function_congs : (thm list -> thm list) -> Context.generic -> Context.generic
    1.24 +  (* FIXME: This interface is a mess and needs to be cleaned up! *)
    1.25 +  val get_function_congs : Proof.context -> thm list
    1.26 +  val add_function_cong : thm -> Context.generic -> Context.generic
    1.27 +  val map_function_congs : (thm list -> thm list) -> Context.generic -> Context.generic
    1.28  
    1.29 -    val cong_add: attribute
    1.30 -    val cong_del: attribute
    1.31 +  val cong_add: attribute
    1.32 +  val cong_del: attribute
    1.33  
    1.34 -    val mk_tree: (string * typ) -> term -> Proof.context -> term -> ctx_tree
    1.35 +  val mk_tree: (string * typ) -> term -> Proof.context -> term -> ctx_tree
    1.36  
    1.37 -    val inst_tree: theory -> term -> term -> ctx_tree -> ctx_tree
    1.38 +  val inst_tree: theory -> term -> term -> ctx_tree -> ctx_tree
    1.39  
    1.40 -    val export_term : ctxt -> term -> term
    1.41 -    val export_thm : theory -> ctxt -> thm -> thm
    1.42 -    val import_thm : theory -> ctxt -> thm -> thm
    1.43 +  val export_term : ctxt -> term -> term
    1.44 +  val export_thm : theory -> ctxt -> thm -> thm
    1.45 +  val import_thm : theory -> ctxt -> thm -> thm
    1.46  
    1.47 -    val traverse_tree : 
    1.48 +  val traverse_tree :
    1.49     (ctxt -> term ->
    1.50     (ctxt * thm) list ->
    1.51     (ctxt * thm) list * 'b ->
    1.52     (ctxt * thm) list * 'b)
    1.53     -> ctx_tree -> 'b -> 'b
    1.54  
    1.55 -    val rewrite_by_tree : theory -> term -> thm -> (thm * thm) list -> ctx_tree -> thm * (thm * thm) list
    1.56 +  val rewrite_by_tree : theory -> term -> thm -> (thm * thm) list ->
    1.57 +    ctx_tree -> thm * (thm * thm) list
    1.58  end
    1.59  
    1.60  structure Function_Ctx_Tree : FUNCTION_CTXTREE =
    1.61 @@ -64,8 +66,8 @@
    1.62  
    1.63  type depgraph = int IntGraph.T
    1.64  
    1.65 -datatype ctx_tree 
    1.66 -  = Leaf of term
    1.67 +datatype ctx_tree =
    1.68 +  Leaf of term
    1.69    | Cong of (thm * depgraph * (ctxt * ctx_tree) list)
    1.70    | RCall of (term * ctx_tree)
    1.71  
    1.72 @@ -76,204 +78,210 @@
    1.73  
    1.74  (*** Dependency analysis for congruence rules ***)
    1.75  
    1.76 -fun branch_vars t = 
    1.77 -    let 
    1.78 -      val t' = snd (dest_all_all t)
    1.79 -      val (assumes, concl) = Logic.strip_horn t'
    1.80 -    in (fold Term.add_vars assumes [], Term.add_vars concl [])
    1.81 -    end
    1.82 +fun branch_vars t =
    1.83 +  let
    1.84 +    val t' = snd (dest_all_all t)
    1.85 +    val (assumes, concl) = Logic.strip_horn t'
    1.86 +  in
    1.87 +    (fold Term.add_vars assumes [], Term.add_vars concl [])
    1.88 +  end
    1.89  
    1.90  fun cong_deps crule =
    1.91 -    let
    1.92 -      val num_branches = map_index (apsnd branch_vars) (prems_of crule)
    1.93 -    in
    1.94 -      IntGraph.empty
    1.95 -        |> fold (fn (i,_)=> IntGraph.new_node (i,i)) num_branches
    1.96 -        |> fold_product (fn (i, (c1, _)) => fn (j, (_, t2)) => 
    1.97 -               if i = j orelse null (inter (op =) c1 t2)
    1.98 -               then I else IntGraph.add_edge_acyclic (i,j))
    1.99 -             num_branches num_branches
   1.100 +  let
   1.101 +    val num_branches = map_index (apsnd branch_vars) (prems_of crule)
   1.102 +  in
   1.103 +    IntGraph.empty
   1.104 +    |> fold (fn (i,_)=> IntGraph.new_node (i,i)) num_branches
   1.105 +    |> fold_product (fn (i, (c1, _)) => fn (j, (_, t2)) =>
   1.106 +         if i = j orelse null (inter (op =) c1 t2)
   1.107 +         then I else IntGraph.add_edge_acyclic (i,j))
   1.108 +       num_branches num_branches
   1.109      end
   1.110 -    
   1.111 -val default_congs = map (fn c => c RS eq_reflection) [@{thm "cong"}, @{thm "ext"}] 
   1.112  
   1.113 -
   1.114 +val default_congs =
   1.115 +  map (fn c => c RS eq_reflection) [@{thm "cong"}, @{thm "ext"}]
   1.116  
   1.117  (* Called on the INSTANTIATED branches of the congruence rule *)
   1.118 -fun mk_branch ctx t = 
   1.119 -    let
   1.120 -      val (ctx', fixes, impl) = dest_all_all_ctx ctx t
   1.121 -      val (assms, concl) = Logic.strip_horn impl
   1.122 -    in
   1.123 -      (ctx', fixes, assms, rhs_of concl)
   1.124 -    end
   1.125 -    
   1.126 +fun mk_branch ctx t =
   1.127 +  let
   1.128 +    val (ctx', fixes, impl) = dest_all_all_ctx ctx t
   1.129 +    val (assms, concl) = Logic.strip_horn impl
   1.130 +  in
   1.131 +    (ctx', fixes, assms, rhs_of concl)
   1.132 +  end
   1.133 +
   1.134  fun find_cong_rule ctx fvar h ((r,dep)::rs) t =
   1.135 -    (let
   1.136 -       val thy = ProofContext.theory_of ctx
   1.137 +  (let
   1.138 +     val thy = ProofContext.theory_of ctx
   1.139  
   1.140 -       val tt' = Logic.mk_equals (Pattern.rewrite_term thy [(Free fvar, h)] [] t, t)
   1.141 -       val (c, subs) = (concl_of r, prems_of r)
   1.142 +     val tt' = Logic.mk_equals (Pattern.rewrite_term thy [(Free fvar, h)] [] t, t)
   1.143 +     val (c, subs) = (concl_of r, prems_of r)
   1.144  
   1.145 -       val subst = Pattern.match (ProofContext.theory_of ctx) (c, tt') (Vartab.empty, Vartab.empty)
   1.146 -       val branches = map (mk_branch ctx o Envir.beta_norm o Envir.subst_term subst) subs
   1.147 -       val inst = map (fn v =>
   1.148 -        (cterm_of thy (Var v), cterm_of thy (Envir.subst_term subst (Var v)))) (Term.add_vars c [])
   1.149 -     in
   1.150 -   (cterm_instantiate inst r, dep, branches)
   1.151 -     end
   1.152 -    handle Pattern.MATCH => find_cong_rule ctx fvar h rs t)
   1.153 +     val subst = Pattern.match (ProofContext.theory_of ctx) (c, tt') (Vartab.empty, Vartab.empty)
   1.154 +     val branches = map (mk_branch ctx o Envir.beta_norm o Envir.subst_term subst) subs
   1.155 +     val inst = map (fn v =>
   1.156 +       (cterm_of thy (Var v), cterm_of thy (Envir.subst_term subst (Var v)))) (Term.add_vars c [])
   1.157 +   in
   1.158 +     (cterm_instantiate inst r, dep, branches)
   1.159 +   end
   1.160 +   handle Pattern.MATCH => find_cong_rule ctx fvar h rs t)
   1.161    | find_cong_rule _ _ _ [] _ = sys_error "Function/context_tree.ML: No cong rule found!"
   1.162  
   1.163  
   1.164  fun mk_tree fvar h ctxt t =
   1.165 -    let 
   1.166 -      val congs = get_function_congs ctxt
   1.167 -      val congs_deps = map (fn c => (c, cong_deps c)) (congs @ default_congs) (* FIXME: Save in theory *)
   1.168 +  let
   1.169 +    val congs = get_function_congs ctxt
   1.170  
   1.171 -      fun matchcall (a $ b) = if a = Free fvar then SOME b else NONE
   1.172 -        | matchcall _ = NONE
   1.173 +    (* FIXME: Save in theory: *)
   1.174 +    val congs_deps = map (fn c => (c, cong_deps c)) (congs @ default_congs)
   1.175 +
   1.176 +    fun matchcall (a $ b) = if a = Free fvar then SOME b else NONE
   1.177 +      | matchcall _ = NONE
   1.178  
   1.179 -      fun mk_tree' ctx t =
   1.180 -          case matchcall t of
   1.181 -            SOME arg => RCall (t, mk_tree' ctx arg)
   1.182 -          | NONE => 
   1.183 -            if not (exists_subterm (fn Free v => v = fvar | _ => false) t) then Leaf t
   1.184 -            else 
   1.185 -              let val (r, dep, branches) = find_cong_rule ctx fvar h congs_deps t in
   1.186 -                Cong (r, dep, 
   1.187 -                      map (fn (ctx', fixes, assumes, st) => 
   1.188 -                              ((fixes, map (assume o cterm_of (ProofContext.theory_of ctx)) assumes), 
   1.189 -                               mk_tree' ctx' st)) branches)
   1.190 -              end
   1.191 -    in
   1.192 -      mk_tree' ctxt t
   1.193 -    end
   1.194 -    
   1.195 +    fun mk_tree' ctx t =
   1.196 +      case matchcall t of
   1.197 +        SOME arg => RCall (t, mk_tree' ctx arg)
   1.198 +      | NONE =>
   1.199 +        if not (exists_subterm (fn Free v => v = fvar | _ => false) t) then Leaf t
   1.200 +        else
   1.201 +          let
   1.202 +            val (r, dep, branches) = find_cong_rule ctx fvar h congs_deps t
   1.203 +            fun subtree (ctx', fixes, assumes, st) =
   1.204 +              ((fixes,
   1.205 +                map (assume o cterm_of (ProofContext.theory_of ctx)) assumes),
   1.206 +               mk_tree' ctx' st)
   1.207 +          in
   1.208 +            Cong (r, dep, map subtree branches)
   1.209 +          end
   1.210 +  in
   1.211 +    mk_tree' ctxt t
   1.212 +  end
   1.213  
   1.214  fun inst_tree thy fvar f tr =
   1.215 -    let
   1.216 -      val cfvar = cterm_of thy fvar
   1.217 -      val cf = cterm_of thy f
   1.218 -               
   1.219 -      fun inst_term t = 
   1.220 -          subst_bound(f, abstract_over (fvar, t))
   1.221 +  let
   1.222 +    val cfvar = cterm_of thy fvar
   1.223 +    val cf = cterm_of thy f
   1.224  
   1.225 -      val inst_thm = forall_elim cf o forall_intr cfvar 
   1.226 +    fun inst_term t =
   1.227 +      subst_bound(f, abstract_over (fvar, t))
   1.228 +
   1.229 +    val inst_thm = forall_elim cf o forall_intr cfvar
   1.230  
   1.231 -      fun inst_tree_aux (Leaf t) = Leaf t
   1.232 -        | inst_tree_aux (Cong (crule, deps, branches)) =
   1.233 -          Cong (inst_thm crule, deps, map inst_branch branches)
   1.234 -        | inst_tree_aux (RCall (t, str)) =
   1.235 -          RCall (inst_term t, inst_tree_aux str)
   1.236 -      and inst_branch ((fxs, assms), str) = 
   1.237 -          ((fxs, map (assume o cterm_of thy o inst_term o prop_of) assms), inst_tree_aux str)
   1.238 -    in
   1.239 -      inst_tree_aux tr
   1.240 -    end
   1.241 +    fun inst_tree_aux (Leaf t) = Leaf t
   1.242 +      | inst_tree_aux (Cong (crule, deps, branches)) =
   1.243 +        Cong (inst_thm crule, deps, map inst_branch branches)
   1.244 +      | inst_tree_aux (RCall (t, str)) =
   1.245 +        RCall (inst_term t, inst_tree_aux str)
   1.246 +    and inst_branch ((fxs, assms), str) =
   1.247 +      ((fxs, map (assume o cterm_of thy o inst_term o prop_of) assms),
   1.248 +       inst_tree_aux str)
   1.249 +  in
   1.250 +    inst_tree_aux tr
   1.251 +  end
   1.252  
   1.253  
   1.254  (* Poor man's contexts: Only fixes and assumes *)
   1.255  fun compose (fs1, as1) (fs2, as2) = (fs1 @ fs2, as1 @ as2)
   1.256  
   1.257  fun export_term (fixes, assumes) =
   1.258 -    fold_rev (curry Logic.mk_implies o prop_of) assumes 
   1.259 + fold_rev (curry Logic.mk_implies o prop_of) assumes
   1.260   #> fold_rev (Logic.all o Free) fixes
   1.261  
   1.262  fun export_thm thy (fixes, assumes) =
   1.263 -    fold_rev (implies_intr o cprop_of) assumes
   1.264 + fold_rev (implies_intr o cprop_of) assumes
   1.265   #> fold_rev (forall_intr o cterm_of thy o Free) fixes
   1.266  
   1.267  fun import_thm thy (fixes, athms) =
   1.268 -    fold (forall_elim o cterm_of thy o Free) fixes
   1.269 + fold (forall_elim o cterm_of thy o Free) fixes
   1.270   #> fold Thm.elim_implies athms
   1.271  
   1.272  
   1.273  (* folds in the order of the dependencies of a graph. *)
   1.274  fun fold_deps G f x =
   1.275 -    let
   1.276 -      fun fill_table i (T, x) =
   1.277 -          case Inttab.lookup T i of
   1.278 -            SOME _ => (T, x)
   1.279 -          | NONE => 
   1.280 -            let
   1.281 -              val (T', x') = fold fill_table (IntGraph.imm_succs G i) (T, x)
   1.282 -              val (v, x'') = f (the o Inttab.lookup T') i x'
   1.283 -            in
   1.284 -              (Inttab.update (i, v) T', x'')
   1.285 -            end
   1.286 -            
   1.287 -      val (T, x) = fold fill_table (IntGraph.keys G) (Inttab.empty, x)
   1.288 -    in
   1.289 -      (Inttab.fold (cons o snd) T [], x)
   1.290 -    end
   1.291 -    
   1.292 +  let
   1.293 +    fun fill_table i (T, x) =
   1.294 +      case Inttab.lookup T i of
   1.295 +        SOME _ => (T, x)
   1.296 +      | NONE =>
   1.297 +        let
   1.298 +          val (T', x') = fold fill_table (IntGraph.imm_succs G i) (T, x)
   1.299 +          val (v, x'') = f (the o Inttab.lookup T') i x'
   1.300 +        in
   1.301 +          (Inttab.update (i, v) T', x'')
   1.302 +        end
   1.303 +
   1.304 +    val (T, x) = fold fill_table (IntGraph.keys G) (Inttab.empty, x)
   1.305 +  in
   1.306 +    (Inttab.fold (cons o snd) T [], x)
   1.307 +  end
   1.308 +
   1.309  fun traverse_tree rcOp tr =
   1.310 -    let 
   1.311 -  fun traverse_help ctx (Leaf _) _ x = ([], x)
   1.312 -    | traverse_help ctx (RCall (t, st)) u x =
   1.313 -      rcOp ctx t u (traverse_help ctx st u x)
   1.314 -    | traverse_help ctx (Cong (_, deps, branches)) u x =
   1.315 +  let
   1.316 +    fun traverse_help ctx (Leaf _) _ x = ([], x)
   1.317 +      | traverse_help ctx (RCall (t, st)) u x =
   1.318 +        rcOp ctx t u (traverse_help ctx st u x)
   1.319 +      | traverse_help ctx (Cong (_, deps, branches)) u x =
   1.320        let
   1.321 -    fun sub_step lu i x =
   1.322 -        let
   1.323 -          val (ctx', subtree) = nth branches i
   1.324 -          val used = fold_rev (append o lu) (IntGraph.imm_succs deps i) u
   1.325 -          val (subs, x') = traverse_help (compose ctx ctx') subtree used x
   1.326 -          val exported_subs = map (apfst (compose ctx')) subs (* FIXME: Right order of composition? *)
   1.327 -        in
   1.328 -          (exported_subs, x')
   1.329 -        end
   1.330 +        fun sub_step lu i x =
   1.331 +          let
   1.332 +            val (ctx', subtree) = nth branches i
   1.333 +            val used = fold_rev (append o lu) (IntGraph.imm_succs deps i) u
   1.334 +            val (subs, x') = traverse_help (compose ctx ctx') subtree used x
   1.335 +            val exported_subs = map (apfst (compose ctx')) subs (* FIXME: Right order of composition? *)
   1.336 +          in
   1.337 +            (exported_subs, x')
   1.338 +          end
   1.339        in
   1.340          fold_deps deps sub_step x
   1.341 -          |> apfst flat
   1.342 +        |> apfst flat
   1.343        end
   1.344 -    in
   1.345 -      snd o traverse_help ([], []) tr []
   1.346 -    end
   1.347 +  in
   1.348 +    snd o traverse_help ([], []) tr []
   1.349 +  end
   1.350  
   1.351  fun rewrite_by_tree thy h ih x tr =
   1.352 -    let
   1.353 -      fun rewrite_help _ _ x (Leaf t) = (reflexive (cterm_of thy t), x)
   1.354 -        | rewrite_help fix h_as x (RCall (_ $ arg, st)) =
   1.355 -          let
   1.356 -            val (inner, (lRi,ha)::x') = rewrite_help fix h_as x st (* "a' = a" *)
   1.357 -                                                     
   1.358 -            val iha = import_thm thy (fix, h_as) ha (* (a', h a') : G *)
   1.359 -                 |> Conv.fconv_rule (Conv.arg_conv (Conv.comb_conv (Conv.arg_conv (K inner))))
   1.360 +  let
   1.361 +    fun rewrite_help _ _ x (Leaf t) = (reflexive (cterm_of thy t), x)
   1.362 +      | rewrite_help fix h_as x (RCall (_ $ arg, st)) =
   1.363 +        let
   1.364 +          val (inner, (lRi,ha)::x') = rewrite_help fix h_as x st (* "a' = a" *)
   1.365 +
   1.366 +          val iha = import_thm thy (fix, h_as) ha (* (a', h a') : G *)
   1.367 +            |> Conv.fconv_rule (Conv.arg_conv (Conv.comb_conv (Conv.arg_conv (K inner))))
   1.368                                                      (* (a, h a) : G   *)
   1.369 -            val inst_ih = instantiate' [] [SOME (cterm_of thy arg)] ih
   1.370 -            val eq = implies_elim (implies_elim inst_ih lRi) iha (* h a = f a *)
   1.371 -                     
   1.372 -            val h_a'_eq_h_a = combination (reflexive (cterm_of thy h)) inner
   1.373 -            val h_a_eq_f_a = eq RS eq_reflection
   1.374 -            val result = transitive h_a'_eq_h_a h_a_eq_f_a
   1.375 -          in
   1.376 -            (result, x')
   1.377 -          end
   1.378 -        | rewrite_help fix h_as x (Cong (crule, deps, branches)) =
   1.379 -          let
   1.380 -            fun sub_step lu i x =
   1.381 -                let
   1.382 -                  val ((fixes, assumes), st) = nth branches i
   1.383 -                  val used = map lu (IntGraph.imm_succs deps i)
   1.384 -                             |> map (fn u_eq => (u_eq RS sym) RS eq_reflection)
   1.385 -                             |> filter_out Thm.is_reflexive
   1.386 +          val inst_ih = instantiate' [] [SOME (cterm_of thy arg)] ih
   1.387 +          val eq = implies_elim (implies_elim inst_ih lRi) iha (* h a = f a *)
   1.388 +
   1.389 +          val h_a'_eq_h_a = combination (reflexive (cterm_of thy h)) inner
   1.390 +          val h_a_eq_f_a = eq RS eq_reflection
   1.391 +          val result = transitive h_a'_eq_h_a h_a_eq_f_a
   1.392 +        in
   1.393 +          (result, x')
   1.394 +        end
   1.395 +      | rewrite_help fix h_as x (Cong (crule, deps, branches)) =
   1.396 +        let
   1.397 +          fun sub_step lu i x =
   1.398 +            let
   1.399 +              val ((fixes, assumes), st) = nth branches i
   1.400 +              val used = map lu (IntGraph.imm_succs deps i)
   1.401 +                |> map (fn u_eq => (u_eq RS sym) RS eq_reflection)
   1.402 +                |> filter_out Thm.is_reflexive
   1.403  
   1.404 -                  val assumes' = map (simplify (HOL_basic_ss addsimps used)) assumes
   1.405 -                                 
   1.406 -                  val (subeq, x') = rewrite_help (fix @ fixes) (h_as @ assumes') x st
   1.407 -                  val subeq_exp = export_thm thy (fixes, assumes) (subeq RS meta_eq_to_obj_eq)
   1.408 -                in
   1.409 -                  (subeq_exp, x')
   1.410 -                end
   1.411 -                
   1.412 -            val (subthms, x') = fold_deps deps sub_step x
   1.413 -          in
   1.414 -            (fold_rev (curry op COMP) subthms crule, x')
   1.415 -          end
   1.416 -    in
   1.417 -      rewrite_help [] [] x tr
   1.418 -    end
   1.419 -    
   1.420 +              val assumes' = map (simplify (HOL_basic_ss addsimps used)) assumes
   1.421 +
   1.422 +              val (subeq, x') =
   1.423 +                rewrite_help (fix @ fixes) (h_as @ assumes') x st
   1.424 +              val subeq_exp =
   1.425 +                export_thm thy (fixes, assumes) (subeq RS meta_eq_to_obj_eq)
   1.426 +            in
   1.427 +              (subeq_exp, x')
   1.428 +            end
   1.429 +          val (subthms, x') = fold_deps deps sub_step x
   1.430 +        in
   1.431 +          (fold_rev (curry op COMP) subthms crule, x')
   1.432 +        end
   1.433 +  in
   1.434 +    rewrite_help [] [] x tr
   1.435 +  end
   1.436 +
   1.437  end
     2.1 --- a/src/HOL/Tools/Function/fun.ML	Sat Jan 02 23:18:58 2010 +0100
     2.2 +++ b/src/HOL/Tools/Function/fun.ML	Sat Jan 02 23:18:58 2010 +0100
     2.3 @@ -7,14 +7,14 @@
     2.4  
     2.5  signature FUNCTION_FUN =
     2.6  sig
     2.7 -    val add_fun : Function_Common.function_config ->
     2.8 -      (binding * typ option * mixfix) list -> (Attrib.binding * term) list ->
     2.9 -      bool -> local_theory -> Proof.context
    2.10 -    val add_fun_cmd : Function_Common.function_config ->
    2.11 -      (binding * string option * mixfix) list -> (Attrib.binding * string) list ->
    2.12 -      bool -> local_theory -> Proof.context
    2.13 +  val add_fun : Function_Common.function_config ->
    2.14 +    (binding * typ option * mixfix) list -> (Attrib.binding * term) list ->
    2.15 +    bool -> local_theory -> Proof.context
    2.16 +  val add_fun_cmd : Function_Common.function_config ->
    2.17 +    (binding * string option * mixfix) list -> (Attrib.binding * string) list ->
    2.18 +    bool -> local_theory -> Proof.context
    2.19  
    2.20 -    val setup : theory -> theory
    2.21 +  val setup : theory -> theory
    2.22  end
    2.23  
    2.24  structure Function_Fun : FUNCTION_FUN =
    2.25 @@ -25,64 +25,64 @@
    2.26  
    2.27  
    2.28  fun check_pats ctxt geq =
    2.29 -    let 
    2.30 -      fun err str = error (cat_lines ["Malformed definition:",
    2.31 -                                      str ^ " not allowed in sequential mode.",
    2.32 -                                      Syntax.string_of_term ctxt geq])
    2.33 -      val thy = ProofContext.theory_of ctxt
    2.34 -                
    2.35 -      fun check_constr_pattern (Bound _) = ()
    2.36 -        | check_constr_pattern t =
    2.37 -          let
    2.38 -            val (hd, args) = strip_comb t
    2.39 -          in
    2.40 -            (((case Datatype.info_of_constr thy (dest_Const hd) of
    2.41 -                 SOME _ => ()
    2.42 -               | NONE => err "Non-constructor pattern")
    2.43 -              handle TERM ("dest_Const", _) => err "Non-constructor patterns");
    2.44 -             map check_constr_pattern args; 
    2.45 -             ())
    2.46 -          end
    2.47 -          
    2.48 -      val (_, qs, gs, args, _) = split_def ctxt geq 
    2.49 -                                       
    2.50 -      val _ = if not (null gs) then err "Conditional equations" else ()
    2.51 -      val _ = map check_constr_pattern args
    2.52 -                  
    2.53 -                  (* just count occurrences to check linearity *)
    2.54 -      val _ = if fold (fold_aterms (fn Bound _ => Integer.add 1 | _ => I)) args 0 > length qs
    2.55 -              then err "Nonlinear patterns" else ()
    2.56 -    in
    2.57 -      ()
    2.58 -    end
    2.59 -    
    2.60 +  let
    2.61 +    fun err str = error (cat_lines ["Malformed definition:",
    2.62 +      str ^ " not allowed in sequential mode.",
    2.63 +      Syntax.string_of_term ctxt geq])
    2.64 +    val thy = ProofContext.theory_of ctxt
    2.65 +
    2.66 +    fun check_constr_pattern (Bound _) = ()
    2.67 +      | check_constr_pattern t =
    2.68 +      let
    2.69 +        val (hd, args) = strip_comb t
    2.70 +      in
    2.71 +        (((case Datatype.info_of_constr thy (dest_Const hd) of
    2.72 +             SOME _ => ()
    2.73 +           | NONE => err "Non-constructor pattern")
    2.74 +          handle TERM ("dest_Const", _) => err "Non-constructor patterns");
    2.75 +         map check_constr_pattern args;
    2.76 +         ())
    2.77 +      end
    2.78 +
    2.79 +    val (_, qs, gs, args, _) = split_def ctxt geq
    2.80 +
    2.81 +    val _ = if not (null gs) then err "Conditional equations" else ()
    2.82 +    val _ = map check_constr_pattern args
    2.83 +
    2.84 +    (* just count occurrences to check linearity *)
    2.85 +    val _ = if fold (fold_aterms (fn Bound _ => Integer.add 1 | _ => I)) args 0 > length qs
    2.86 +      then err "Nonlinear patterns" else ()
    2.87 +  in
    2.88 +    ()
    2.89 +  end
    2.90 +
    2.91  val by_pat_completeness_auto =
    2.92 -    Proof.global_future_terminal_proof
    2.93 -      (Method.Basic Pat_Completeness.pat_completeness,
    2.94 -       SOME (Method.Source_i (Args.src (("HOL.auto", []), Position.none))))
    2.95 +  Proof.global_future_terminal_proof
    2.96 +    (Method.Basic Pat_Completeness.pat_completeness,
    2.97 +     SOME (Method.Source_i (Args.src (("HOL.auto", []), Position.none))))
    2.98  
    2.99  fun termination_by method int =
   2.100 -    Function.termination_proof NONE
   2.101 -    #> Proof.global_future_terminal_proof (Method.Basic method, NONE) int
   2.102 +  Function.termination_proof NONE
   2.103 +  #> Proof.global_future_terminal_proof (Method.Basic method, NONE) int
   2.104  
   2.105  fun mk_catchall fixes arity_of =
   2.106 -    let
   2.107 -      fun mk_eqn ((fname, fT), _) =
   2.108 -          let 
   2.109 -            val n = arity_of fname
   2.110 -            val (argTs, rT) = chop n (binder_types fT)
   2.111 -                                   |> apsnd (fn Ts => Ts ---> body_type fT) 
   2.112 -                              
   2.113 -            val qs = map Free (Name.invent_list [] "a" n ~~ argTs)
   2.114 -          in
   2.115 -            HOLogic.mk_eq(list_comb (Free (fname, fT), qs),
   2.116 -                          Const ("HOL.undefined", rT))
   2.117 -              |> HOLogic.mk_Trueprop
   2.118 -              |> fold_rev Logic.all qs
   2.119 -          end
   2.120 -    in
   2.121 -      map mk_eqn fixes
   2.122 -    end
   2.123 +  let
   2.124 +    fun mk_eqn ((fname, fT), _) =
   2.125 +      let
   2.126 +        val n = arity_of fname
   2.127 +        val (argTs, rT) = chop n (binder_types fT)
   2.128 +          |> apsnd (fn Ts => Ts ---> body_type fT)
   2.129 +
   2.130 +        val qs = map Free (Name.invent_list [] "a" n ~~ argTs)
   2.131 +      in
   2.132 +        HOLogic.mk_eq(list_comb (Free (fname, fT), qs),
   2.133 +          Const ("HOL.undefined", rT))
   2.134 +        |> HOLogic.mk_Trueprop
   2.135 +        |> fold_rev Logic.all qs
   2.136 +      end
   2.137 +  in
   2.138 +    map mk_eqn fixes
   2.139 +  end
   2.140  
   2.141  fun add_catchall ctxt fixes spec =
   2.142    let val fqgars = map (split_def ctxt) spec
   2.143 @@ -93,55 +93,53 @@
   2.144    end
   2.145  
   2.146  fun warn_if_redundant ctxt origs tss =
   2.147 -    let
   2.148 -        fun msg t = "Ignoring redundant equation: " ^ quote (Syntax.string_of_term ctxt t)
   2.149 -                    
   2.150 -        val (tss', _) = chop (length origs) tss
   2.151 -        fun check (t, []) = (warning (msg t); [])
   2.152 -          | check (t, s) = s
   2.153 -    in
   2.154 -        (map check (origs ~~ tss'); tss)
   2.155 -    end
   2.156 +  let
   2.157 +    fun msg t = "Ignoring redundant equation: " ^ quote (Syntax.string_of_term ctxt t)
   2.158  
   2.159 +    val (tss', _) = chop (length origs) tss
   2.160 +    fun check (t, []) = (warning (msg t); [])
   2.161 +      | check (t, s) = s
   2.162 +  in
   2.163 +    (map check (origs ~~ tss'); tss)
   2.164 +  end
   2.165  
   2.166  fun sequential_preproc (config as FunctionConfig {sequential, ...}) ctxt fixes spec =
   2.167 -      if sequential then
   2.168 -        let
   2.169 -          val (bnds, eqss) = split_list spec
   2.170 -                            
   2.171 -          val eqs = map the_single eqss
   2.172 -                    
   2.173 -          val feqs = eqs
   2.174 -                      |> tap (check_defs ctxt fixes) (* Standard checks *)
   2.175 -                      |> tap (map (check_pats ctxt))    (* More checks for sequential mode *)
   2.176 +  if sequential then
   2.177 +    let
   2.178 +      val (bnds, eqss) = split_list spec
   2.179 +
   2.180 +      val eqs = map the_single eqss
   2.181  
   2.182 -          val compleqs = add_catchall ctxt fixes feqs   (* Completion *)
   2.183 +      val feqs = eqs
   2.184 +        |> tap (check_defs ctxt fixes) (* Standard checks *)
   2.185 +        |> tap (map (check_pats ctxt)) (* More checks for sequential mode *)
   2.186 +
   2.187 +      val compleqs = add_catchall ctxt fixes feqs (* Completion *)
   2.188  
   2.189 -          val spliteqs = warn_if_redundant ctxt feqs
   2.190 -                           (Function_Split.split_all_equations ctxt compleqs)
   2.191 +      val spliteqs = warn_if_redundant ctxt feqs
   2.192 +        (Function_Split.split_all_equations ctxt compleqs)
   2.193 +
   2.194 +      fun restore_spec thms =
   2.195 +        bnds ~~ take (length bnds) (unflat spliteqs thms)
   2.196  
   2.197 -          fun restore_spec thms =
   2.198 -              bnds ~~ take (length bnds) (unflat spliteqs thms)
   2.199 -              
   2.200 -          val spliteqs' = flat (take (length bnds) spliteqs)
   2.201 -          val fnames = map (fst o fst) fixes
   2.202 -          val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) spliteqs'
   2.203 +      val spliteqs' = flat (take (length bnds) spliteqs)
   2.204 +      val fnames = map (fst o fst) fixes
   2.205 +      val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) spliteqs'
   2.206  
   2.207 -          fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1) (indices ~~ xs)
   2.208 -                                       |> map (map snd)
   2.209 +      fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1) (indices ~~ xs)
   2.210 +        |> map (map snd)
   2.211  
   2.212  
   2.213 -          val bnds' = bnds @ replicate (length spliteqs - length bnds) Attrib.empty_binding
   2.214 +      val bnds' = bnds @ replicate (length spliteqs - length bnds) Attrib.empty_binding
   2.215  
   2.216 -          (* using theorem names for case name currently disabled *)
   2.217 -          val case_names = map_index (fn (i, (_, es)) => mk_case_names i "" (length es)) 
   2.218 -                                     (bnds' ~~ spliteqs)
   2.219 -                           |> flat
   2.220 -        in
   2.221 -          (flat spliteqs, restore_spec, sort, case_names)
   2.222 -        end
   2.223 -      else
   2.224 -        Function_Common.empty_preproc check_defs config ctxt fixes spec
   2.225 +      (* using theorem names for case name currently disabled *)
   2.226 +      val case_names = map_index (fn (i, (_, es)) => mk_case_names i "" (length es)) 
   2.227 +        (bnds' ~~ spliteqs) |> flat
   2.228 +    in
   2.229 +      (flat spliteqs, restore_spec, sort, case_names)
   2.230 +    end
   2.231 +  else
   2.232 +    Function_Common.empty_preproc check_defs config ctxt fixes spec
   2.233  
   2.234  val setup =
   2.235    Context.theory_map (Function_Common.set_preproc sequential_preproc)
   2.236 @@ -152,10 +150,10 @@
   2.237  
   2.238  fun gen_fun add config fixes statements int lthy =
   2.239    lthy
   2.240 -    |> add fixes statements config
   2.241 -    |> by_pat_completeness_auto int
   2.242 -    |> Local_Theory.restore
   2.243 -    |> termination_by (Function_Common.get_termination_prover lthy) int
   2.244 +  |> add fixes statements config
   2.245 +  |> by_pat_completeness_auto int
   2.246 +  |> Local_Theory.restore
   2.247 +  |> termination_by (Function_Common.get_termination_prover lthy) int
   2.248  
   2.249  val add_fun = gen_fun Function.add_function
   2.250  val add_fun_cmd = gen_fun Function.add_function_cmd
     3.1 --- a/src/HOL/Tools/Function/function.ML	Sat Jan 02 23:18:58 2010 +0100
     3.2 +++ b/src/HOL/Tools/Function/function.ML	Sat Jan 02 23:18:58 2010 +0100
     3.3 @@ -7,26 +7,23 @@
     3.4  
     3.5  signature FUNCTION =
     3.6  sig
     3.7 -    include FUNCTION_DATA
     3.8 +  include FUNCTION_DATA
     3.9 +
    3.10 +  val add_function: (binding * typ option * mixfix) list ->
    3.11 +    (Attrib.binding * term) list -> Function_Common.function_config ->
    3.12 +    local_theory -> Proof.state
    3.13  
    3.14 -    val add_function :  (binding * typ option * mixfix) list
    3.15 -                       -> (Attrib.binding * term) list
    3.16 -                       -> Function_Common.function_config
    3.17 -                       -> local_theory
    3.18 -                       -> Proof.state
    3.19 -    val add_function_cmd :  (binding * string option * mixfix) list
    3.20 -                      -> (Attrib.binding * string) list
    3.21 -                      -> Function_Common.function_config
    3.22 -                      -> local_theory
    3.23 -                      -> Proof.state
    3.24 +  val add_function_cmd: (binding * string option * mixfix) list ->
    3.25 +    (Attrib.binding * string) list -> Function_Common.function_config ->
    3.26 +    local_theory -> Proof.state
    3.27  
    3.28 -    val termination_proof : term option -> local_theory -> Proof.state
    3.29 -    val termination_proof_cmd : string option -> local_theory -> Proof.state
    3.30 +  val termination_proof : term option -> local_theory -> Proof.state
    3.31 +  val termination_proof_cmd : string option -> local_theory -> Proof.state
    3.32  
    3.33 -    val setup : theory -> theory
    3.34 -    val get_congs : Proof.context -> thm list
    3.35 +  val setup : theory -> theory
    3.36 +  val get_congs : Proof.context -> thm list
    3.37  
    3.38 -    val get_info : Proof.context -> term -> info
    3.39 +  val get_info : Proof.context -> term -> info
    3.40  end
    3.41  
    3.42  
    3.43 @@ -37,148 +34,149 @@
    3.44  open Function_Common
    3.45  
    3.46  val simp_attribs = map (Attrib.internal o K)
    3.47 -    [Simplifier.simp_add,
    3.48 -     Code.add_default_eqn_attribute,
    3.49 -     Nitpick_Simps.add]
    3.50 +  [Simplifier.simp_add,
    3.51 +   Code.add_default_eqn_attribute,
    3.52 +   Nitpick_Simps.add]
    3.53  
    3.54  val psimp_attribs = map (Attrib.internal o K)
    3.55 -    [Simplifier.simp_add,
    3.56 -     Nitpick_Psimps.add]
    3.57 +  [Simplifier.simp_add,
    3.58 +   Nitpick_Psimps.add]
    3.59  
    3.60  fun mk_defname fixes = fixes |> map (fst o fst) |> space_implode "_"
    3.61  
    3.62 -fun add_simps fnames post sort extra_qualify label mod_binding moreatts simps lthy =
    3.63 -    let
    3.64 -      val spec = post simps
    3.65 -                   |> map (apfst (apsnd (fn ats => moreatts @ ats)))
    3.66 -                   |> map (apfst (apfst extra_qualify))
    3.67 +fun add_simps fnames post sort extra_qualify label mod_binding moreatts
    3.68 +  simps lthy =
    3.69 +  let
    3.70 +    val spec = post simps
    3.71 +      |> map (apfst (apsnd (fn ats => moreatts @ ats)))
    3.72 +      |> map (apfst (apfst extra_qualify))
    3.73  
    3.74 -      val (saved_spec_simps, lthy) =
    3.75 -        fold_map Local_Theory.note spec lthy
    3.76 +    val (saved_spec_simps, lthy) =
    3.77 +      fold_map Local_Theory.note spec lthy
    3.78  
    3.79 -      val saved_simps = maps snd saved_spec_simps
    3.80 -      val simps_by_f = sort saved_simps
    3.81 +    val saved_simps = maps snd saved_spec_simps
    3.82 +    val simps_by_f = sort saved_simps
    3.83  
    3.84 -      fun add_for_f fname simps =
    3.85 -        Local_Theory.note
    3.86 -          ((mod_binding (Binding.qualify true fname (Binding.name label)), []), simps)
    3.87 -        #> snd
    3.88 -    in
    3.89 -      (saved_simps,
    3.90 -       fold2 add_for_f fnames simps_by_f lthy)
    3.91 -    end
    3.92 +    fun add_for_f fname simps =
    3.93 +      Local_Theory.note
    3.94 +        ((mod_binding (Binding.qualify true fname (Binding.name label)), []), simps)
    3.95 +      #> snd
    3.96 +  in
    3.97 +    (saved_simps, fold2 add_for_f fnames simps_by_f lthy)
    3.98 +  end
    3.99  
   3.100  fun gen_add_function is_external prep default_constraint fixspec eqns config lthy =
   3.101 -    let
   3.102 -      val constrn_fxs = map (fn (b, T, mx) => (b, SOME (the_default default_constraint T), mx))
   3.103 -      val ((fixes0, spec0), ctxt') = prep (constrn_fxs fixspec) eqns lthy
   3.104 -      val fixes = map (apfst (apfst Binding.name_of)) fixes0;
   3.105 -      val spec = map (fn (bnd, prop) => (bnd, [prop])) spec0;
   3.106 -      val (eqs, post, sort_cont, cnames) = get_preproc lthy config ctxt' fixes spec
   3.107 +  let
   3.108 +    val constrn_fxs = map (fn (b, T, mx) => (b, SOME (the_default default_constraint T), mx))
   3.109 +    val ((fixes0, spec0), ctxt') = prep (constrn_fxs fixspec) eqns lthy
   3.110 +    val fixes = map (apfst (apfst Binding.name_of)) fixes0;
   3.111 +    val spec = map (fn (bnd, prop) => (bnd, [prop])) spec0;
   3.112 +    val (eqs, post, sort_cont, cnames) = get_preproc lthy config ctxt' fixes spec
   3.113  
   3.114 -      val defname = mk_defname fixes
   3.115 -      val FunctionConfig {partials, ...} = config
   3.116 +    val defname = mk_defname fixes
   3.117 +    val FunctionConfig {partials, ...} = config
   3.118  
   3.119 -      val ((goalstate, cont), lthy) =
   3.120 -          Function_Mutual.prepare_function_mutual config defname fixes eqs lthy
   3.121 +    val ((goalstate, cont), lthy) =
   3.122 +      Function_Mutual.prepare_function_mutual config defname fixes eqs lthy
   3.123  
   3.124 -      fun afterqed [[proof]] lthy =
   3.125 -        let
   3.126 -          val FunctionResult {fs, R, psimps, trsimps,  simple_pinducts, termination,
   3.127 -                            domintros, cases, ...} =
   3.128 +    fun afterqed [[proof]] lthy =
   3.129 +      let
   3.130 +        val FunctionResult {fs, R, psimps, trsimps,  simple_pinducts,
   3.131 +          termination, domintros, cases, ...} =
   3.132            cont (Thm.close_derivation proof)
   3.133  
   3.134 -          val fnames = map (fst o fst) fixes
   3.135 -          fun qualify n = Binding.name n
   3.136 -            |> Binding.qualify true defname
   3.137 -          val conceal_partial = if partials then I else Binding.conceal
   3.138 +        val fnames = map (fst o fst) fixes
   3.139 +        fun qualify n = Binding.name n
   3.140 +          |> Binding.qualify true defname
   3.141 +        val conceal_partial = if partials then I else Binding.conceal
   3.142  
   3.143 -          val addsmps = add_simps fnames post sort_cont
   3.144 +        val addsmps = add_simps fnames post sort_cont
   3.145  
   3.146 -          val (((psimps', pinducts'), (_, [termination'])), lthy) =
   3.147 -            lthy
   3.148 -            |> addsmps (conceal_partial o Binding.qualify false "partial")
   3.149 -                 "psimps" conceal_partial psimp_attribs psimps
   3.150 -            ||> fold_option (snd oo addsmps I "simps" I simp_attribs) trsimps
   3.151 -            ||>> Local_Theory.note ((conceal_partial (qualify "pinduct"),
   3.152 -                   [Attrib.internal (K (Rule_Cases.case_names cnames)),
   3.153 -                    Attrib.internal (K (Rule_Cases.consumes 1)),
   3.154 -                    Attrib.internal (K (Induct.induct_pred ""))]), simple_pinducts)
   3.155 -            ||>> Local_Theory.note ((Binding.conceal (qualify "termination"), []), [termination])
   3.156 -            ||> (snd o Local_Theory.note ((qualify "cases",
   3.157 -                   [Attrib.internal (K (Rule_Cases.case_names cnames))]), [cases]))
   3.158 -            ||> fold_option (snd oo curry Local_Theory.note (qualify "domintros", [])) domintros
   3.159 +        val (((psimps', pinducts'), (_, [termination'])), lthy) =
   3.160 +          lthy
   3.161 +          |> addsmps (conceal_partial o Binding.qualify false "partial")
   3.162 +               "psimps" conceal_partial psimp_attribs psimps
   3.163 +          ||> fold_option (snd oo addsmps I "simps" I simp_attribs) trsimps
   3.164 +          ||>> Local_Theory.note ((conceal_partial (qualify "pinduct"),
   3.165 +                 [Attrib.internal (K (Rule_Cases.case_names cnames)),
   3.166 +                  Attrib.internal (K (Rule_Cases.consumes 1)),
   3.167 +                  Attrib.internal (K (Induct.induct_pred ""))]), simple_pinducts)
   3.168 +          ||>> Local_Theory.note ((Binding.conceal (qualify "termination"), []), [termination])
   3.169 +          ||> (snd o Local_Theory.note ((qualify "cases",
   3.170 +                 [Attrib.internal (K (Rule_Cases.case_names cnames))]), [cases]))
   3.171 +          ||> fold_option (snd oo curry Local_Theory.note (qualify "domintros", [])) domintros
   3.172  
   3.173 -          val info = { add_simps=addsmps, case_names=cnames, psimps=psimps',
   3.174 -            pinducts=snd pinducts', simps=NONE, inducts=NONE, termination=termination',
   3.175 -            fs=fs, R=R, defname=defname, is_partial=true }
   3.176 +        val info = { add_simps=addsmps, case_names=cnames, psimps=psimps',
   3.177 +          pinducts=snd pinducts', simps=NONE, inducts=NONE, termination=termination',
   3.178 +          fs=fs, R=R, defname=defname, is_partial=true }
   3.179  
   3.180 -          val _ =
   3.181 -            if not is_external then ()
   3.182 -            else Specification.print_consts lthy (K false) (map fst fixes)
   3.183 -        in
   3.184 -          lthy
   3.185 -          |> Local_Theory.declaration false (add_function_data o morph_function_data info)
   3.186 -        end
   3.187 -    in
   3.188 -      lthy
   3.189 -        |> Proof.theorem_i NONE afterqed [[(Logic.unprotect (concl_of goalstate), [])]]
   3.190 -        |> Proof.refine (Method.primitive_text (fn _ => goalstate)) |> Seq.hd
   3.191 -    end
   3.192 +        val _ =
   3.193 +          if not is_external then ()
   3.194 +          else Specification.print_consts lthy (K false) (map fst fixes)
   3.195 +      in
   3.196 +        lthy
   3.197 +        |> Local_Theory.declaration false (add_function_data o morph_function_data info)
   3.198 +      end
   3.199 +  in
   3.200 +    lthy
   3.201 +    |> Proof.theorem_i NONE afterqed [[(Logic.unprotect (concl_of goalstate), [])]]
   3.202 +    |> Proof.refine (Method.primitive_text (fn _ => goalstate)) |> Seq.hd
   3.203 +  end
   3.204  
   3.205 -val add_function = gen_add_function false Specification.check_spec (TypeInfer.anyT HOLogic.typeS)
   3.206 +val add_function =
   3.207 +  gen_add_function false Specification.check_spec (TypeInfer.anyT HOLogic.typeS)
   3.208  val add_function_cmd = gen_add_function true Specification.read_spec "_::type"
   3.209  
   3.210  fun gen_termination_proof prep_term raw_term_opt lthy =
   3.211 -    let
   3.212 -      val term_opt = Option.map (prep_term lthy) raw_term_opt
   3.213 -      val info = the (case term_opt of
   3.214 -                        SOME t => (import_function_data t lthy
   3.215 -                          handle Option.Option =>
   3.216 -                            error ("Not a function: " ^ quote (Syntax.string_of_term lthy t)))
   3.217 -                      | NONE => (import_last_function lthy handle Option.Option => error "Not a function"))
   3.218 +  let
   3.219 +    val term_opt = Option.map (prep_term lthy) raw_term_opt
   3.220 +    val info = the (case term_opt of
   3.221 +                      SOME t => (import_function_data t lthy
   3.222 +                        handle Option.Option =>
   3.223 +                          error ("Not a function: " ^ quote (Syntax.string_of_term lthy t)))
   3.224 +                    | NONE => (import_last_function lthy handle Option.Option => error "Not a function"))
   3.225  
   3.226 -        val { termination, fs, R, add_simps, case_names, psimps,
   3.227 -          pinducts, defname, ...} = info
   3.228 -        val domT = domain_type (fastype_of R)
   3.229 -        val goal = HOLogic.mk_Trueprop
   3.230 -                     (HOLogic.mk_all ("x", domT, mk_acc domT R $ Free ("x", domT)))
   3.231 -        fun afterqed [[totality]] lthy =
   3.232 -          let
   3.233 -            val totality = Thm.close_derivation totality
   3.234 -            val remove_domain_condition =
   3.235 -              full_simplify (HOL_basic_ss addsimps [totality, True_implies_equals])
   3.236 -            val tsimps = map remove_domain_condition psimps
   3.237 -            val tinduct = map remove_domain_condition pinducts
   3.238 +      val { termination, fs, R, add_simps, case_names, psimps,
   3.239 +        pinducts, defname, ...} = info
   3.240 +      val domT = domain_type (fastype_of R)
   3.241 +      val goal = HOLogic.mk_Trueprop
   3.242 +                   (HOLogic.mk_all ("x", domT, mk_acc domT R $ Free ("x", domT)))
   3.243 +      fun afterqed [[totality]] lthy =
   3.244 +        let
   3.245 +          val totality = Thm.close_derivation totality
   3.246 +          val remove_domain_condition =
   3.247 +            full_simplify (HOL_basic_ss addsimps [totality, True_implies_equals])
   3.248 +          val tsimps = map remove_domain_condition psimps
   3.249 +          val tinduct = map remove_domain_condition pinducts
   3.250  
   3.251 -            fun qualify n = Binding.name n
   3.252 -              |> Binding.qualify true defname
   3.253 -          in
   3.254 -            lthy
   3.255 -            |> add_simps I "simps" I simp_attribs tsimps
   3.256 -            ||>> Local_Theory.note
   3.257 -               ((qualify "induct",
   3.258 -                 [Attrib.internal (K (Rule_Cases.case_names case_names))]),
   3.259 -                tinduct)
   3.260 -            |-> (fn (simps, (_, inducts)) =>
   3.261 -              let val info' = { is_partial=false, defname=defname, add_simps=add_simps,
   3.262 -                case_names=case_names, fs=fs, R=R, psimps=psimps, pinducts=pinducts,
   3.263 -                simps=SOME simps, inducts=SOME inducts, termination=termination }
   3.264 -              in
   3.265 -                Local_Theory.declaration false (add_function_data o morph_function_data info')
   3.266 -              end)
   3.267 -          end
   3.268 -    in
   3.269 -      lthy
   3.270 -      |> ProofContext.note_thmss ""
   3.271 -         [((Binding.empty, [Context_Rules.rule_del]), [([allI], [])])] |> snd
   3.272 -      |> ProofContext.note_thmss ""
   3.273 -         [((Binding.empty, [Context_Rules.intro_bang (SOME 1)]), [([allI], [])])] |> snd
   3.274 -      |> ProofContext.note_thmss ""
   3.275 -         [((Binding.name "termination", [Context_Rules.intro_bang (SOME 0)]),
   3.276 -           [([Goal.norm_result termination], [])])] |> snd
   3.277 -      |> Proof.theorem_i NONE afterqed [[(goal, [])]]
   3.278 -    end
   3.279 +          fun qualify n = Binding.name n
   3.280 +            |> Binding.qualify true defname
   3.281 +        in
   3.282 +          lthy
   3.283 +          |> add_simps I "simps" I simp_attribs tsimps
   3.284 +          ||>> Local_Theory.note
   3.285 +             ((qualify "induct",
   3.286 +               [Attrib.internal (K (Rule_Cases.case_names case_names))]),
   3.287 +              tinduct)
   3.288 +          |-> (fn (simps, (_, inducts)) =>
   3.289 +            let val info' = { is_partial=false, defname=defname, add_simps=add_simps,
   3.290 +              case_names=case_names, fs=fs, R=R, psimps=psimps, pinducts=pinducts,
   3.291 +              simps=SOME simps, inducts=SOME inducts, termination=termination }
   3.292 +            in
   3.293 +              Local_Theory.declaration false (add_function_data o morph_function_data info')
   3.294 +            end)
   3.295 +        end
   3.296 +  in
   3.297 +    lthy
   3.298 +    |> ProofContext.note_thmss ""
   3.299 +       [((Binding.empty, [Context_Rules.rule_del]), [([allI], [])])] |> snd
   3.300 +    |> ProofContext.note_thmss ""
   3.301 +       [((Binding.empty, [Context_Rules.intro_bang (SOME 1)]), [([allI], [])])] |> snd
   3.302 +    |> ProofContext.note_thmss ""
   3.303 +       [((Binding.name "termination", [Context_Rules.intro_bang (SOME 0)]),
   3.304 +         [([Goal.norm_result termination], [])])] |> snd
   3.305 +    |> Proof.theorem_i NONE afterqed [[(goal, [])]]
   3.306 +  end
   3.307  
   3.308  val termination_proof = gen_termination_proof Syntax.check_term
   3.309  val termination_proof_cmd = gen_termination_proof Syntax.read_term
   3.310 @@ -188,11 +186,13 @@
   3.311  
   3.312  
   3.313  fun add_case_cong n thy =
   3.314 -    Context.theory_map (Function_Ctx_Tree.map_function_congs (Thm.add_thm
   3.315 -                          (Datatype.the_info thy n
   3.316 -                           |> #case_cong
   3.317 -                           |> safe_mk_meta_eq)))
   3.318 -                       thy
   3.319 +  let
   3.320 +    val cong = #case_cong (Datatype.the_info thy n)
   3.321 +      |> safe_mk_meta_eq
   3.322 +  in
   3.323 +    Context.theory_map
   3.324 +      (Function_Ctx_Tree.map_function_congs (Thm.add_thm cong)) thy
   3.325 +  end
   3.326  
   3.327  val setup_case_cong = Datatype.interpretation (K (fold add_case_cong))
   3.328  
     4.1 --- a/src/HOL/Tools/Function/function_common.ML	Sat Jan 02 23:18:58 2010 +0100
     4.2 +++ b/src/HOL/Tools/Function/function_common.ML	Sat Jan 02 23:18:58 2010 +0100
     4.3 @@ -1,7 +1,7 @@
     4.4 -(*  Title:      HOL/Tools/Function/fundef_common.ML
     4.5 +(*  Title:      HOL/Tools/Function/function_common.ML
     4.6      Author:     Alexander Krauss, TU Muenchen
     4.7  
     4.8 -A package for general recursive function definitions. 
     4.9 +A package for general recursive function definitions.
    4.10  Common definitions and other infrastructure.
    4.11  *)
    4.12  
    4.13 @@ -21,8 +21,7 @@
    4.14    pinducts: thm list,
    4.15    simps : thm list option,
    4.16    inducts : thm list option,
    4.17 -  termination: thm
    4.18 - }  
    4.19 +  termination: thm}
    4.20  
    4.21  end
    4.22  
    4.23 @@ -42,8 +41,7 @@
    4.24    pinducts: thm list,
    4.25    simps : thm list option,
    4.26    inducts : thm list option,
    4.27 -  termination: thm
    4.28 - }  
    4.29 +  termination: thm}
    4.30  
    4.31  end
    4.32  
    4.33 @@ -62,7 +60,7 @@
    4.34  
    4.35  val acc_const_name = @{const_name accp}
    4.36  fun mk_acc domT R =
    4.37 -    Const (acc_const_name, (domT --> domT --> HOLogic.boolT) --> domT --> HOLogic.boolT) $ R 
    4.38 +  Const (acc_const_name, (domT --> domT --> HOLogic.boolT) --> domT --> HOLogic.boolT) $ R 
    4.39  
    4.40  val function_name = suffix "C"
    4.41  val graph_name = suffix "_graph"
    4.42 @@ -86,21 +84,18 @@
    4.43  
    4.44  (* Function definition result data *)
    4.45  
    4.46 -datatype function_result =
    4.47 -  FunctionResult of
    4.48 -     {
    4.49 -      fs: term list,
    4.50 -      G: term,
    4.51 -      R: term,
    4.52 +datatype function_result = FunctionResult of
    4.53 + {fs: term list,
    4.54 +  G: term,
    4.55 +  R: term,
    4.56  
    4.57 -      psimps : thm list, 
    4.58 -      trsimps : thm list option, 
    4.59 +  psimps : thm list,
    4.60 +  trsimps : thm list option,
    4.61  
    4.62 -      simple_pinducts : thm list, 
    4.63 -      cases : thm,
    4.64 -      termination : thm,
    4.65 -      domintros : thm list option
    4.66 -     }
    4.67 +  simple_pinducts : thm list,
    4.68 +  cases : thm,
    4.69 +  termination : thm,
    4.70 +  domintros : thm list option}
    4.71  
    4.72  fun morph_function_data ({add_simps, case_names, fs, R, psimps, pinducts,
    4.73    simps, inducts, termination, defname, is_partial} : info) phi =
    4.74 @@ -109,7 +104,7 @@
    4.75        val name = Binding.name_of o Morphism.binding phi o Binding.name
    4.76      in
    4.77        { add_simps = add_simps, case_names = case_names,
    4.78 -        fs = map term fs, R = term R, psimps = fact psimps, 
    4.79 +        fs = map term fs, R = term R, psimps = fact psimps,
    4.80          pinducts = fact pinducts, simps = Option.map fact simps,
    4.81          inducts = Option.map fact inducts, termination = thm termination,
    4.82          defname = name defname, is_partial=is_partial }
    4.83 @@ -121,57 +116,56 @@
    4.84    val empty : T = Item_Net.init (op aconv o pairself fst) (single o fst);
    4.85    val extend = I;
    4.86    fun merge tabs : T = Item_Net.merge tabs;
    4.87 -);
    4.88 +)
    4.89  
    4.90  val get_function = FunctionData.get o Context.Proof;
    4.91  
    4.92  
    4.93 -(* Generally useful?? *)
    4.94 -fun lift_morphism thy f = 
    4.95 -    let 
    4.96 -      val term = Drule.term_rule thy f
    4.97 -    in
    4.98 -      Morphism.thm_morphism f $> Morphism.term_morphism term 
    4.99 -       $> Morphism.typ_morphism (Logic.type_map term)
   4.100 -    end
   4.101 +fun lift_morphism thy f =
   4.102 +  let
   4.103 +    val term = Drule.term_rule thy f
   4.104 +  in
   4.105 +    Morphism.thm_morphism f $> Morphism.term_morphism term
   4.106 +    $> Morphism.typ_morphism (Logic.type_map term)
   4.107 +  end
   4.108  
   4.109  fun import_function_data t ctxt =
   4.110 -    let
   4.111 -      val thy = ProofContext.theory_of ctxt
   4.112 -      val ct = cterm_of thy t
   4.113 -      val inst_morph = lift_morphism thy o Thm.instantiate 
   4.114 +  let
   4.115 +    val thy = ProofContext.theory_of ctxt
   4.116 +    val ct = cterm_of thy t
   4.117 +    val inst_morph = lift_morphism thy o Thm.instantiate
   4.118  
   4.119 -      fun match (trm, data) = 
   4.120 -          SOME (morph_function_data data (inst_morph (Thm.match (cterm_of thy trm, ct))))
   4.121 -          handle Pattern.MATCH => NONE
   4.122 -    in 
   4.123 -      get_first match (Item_Net.retrieve (get_function ctxt) t)
   4.124 -    end
   4.125 +    fun match (trm, data) =
   4.126 +      SOME (morph_function_data data (inst_morph (Thm.match (cterm_of thy trm, ct))))
   4.127 +      handle Pattern.MATCH => NONE
   4.128 +  in
   4.129 +    get_first match (Item_Net.retrieve (get_function ctxt) t)
   4.130 +  end
   4.131  
   4.132  fun import_last_function ctxt =
   4.133 -    case Item_Net.content (get_function ctxt) of
   4.134 -      [] => NONE
   4.135 -    | (t, data) :: _ =>
   4.136 -      let 
   4.137 -        val ([t'], ctxt') = Variable.import_terms true [t] ctxt
   4.138 -      in
   4.139 -        import_function_data t' ctxt'
   4.140 -      end
   4.141 +  case Item_Net.content (get_function ctxt) of
   4.142 +    [] => NONE
   4.143 +  | (t, data) :: _ =>
   4.144 +    let
   4.145 +      val ([t'], ctxt') = Variable.import_terms true [t] ctxt
   4.146 +    in
   4.147 +      import_function_data t' ctxt'
   4.148 +    end
   4.149  
   4.150  val all_function_data = Item_Net.content o get_function
   4.151  
   4.152  fun add_function_data (data : info as {fs, termination, ...}) =
   4.153 -    FunctionData.map (fold (fn f => Item_Net.update (f, data)) fs)
   4.154 -    #> store_termination_rule termination
   4.155 +  FunctionData.map (fold (fn f => Item_Net.update (f, data)) fs)
   4.156 +  #> store_termination_rule termination
   4.157  
   4.158  
   4.159  (* Simp rules for termination proofs *)
   4.160  
   4.161  structure Termination_Simps = Named_Thms
   4.162  (
   4.163 -  val name = "termination_simp" 
   4.164 +  val name = "termination_simp"
   4.165    val description = "Simplification rule for termination proofs"
   4.166 -);
   4.167 +)
   4.168  
   4.169  
   4.170  (* Default Termination Prover *)
   4.171 @@ -182,29 +176,26 @@
   4.172    val empty = (fn _ => error "Termination prover not configured")
   4.173    val extend = I
   4.174    fun merge (a, b) = b  (* FIXME ? *)
   4.175 -);
   4.176 +)
   4.177  
   4.178  val set_termination_prover = TerminationProver.put
   4.179  val get_termination_prover = TerminationProver.get o Context.Proof
   4.180  
   4.181  
   4.182  (* Configuration management *)
   4.183 -datatype function_opt 
   4.184 +datatype function_opt
   4.185    = Sequential
   4.186    | Default of string
   4.187    | DomIntros
   4.188    | No_Partials
   4.189    | Tailrec
   4.190  
   4.191 -datatype function_config
   4.192 -  = FunctionConfig of
   4.193 -   {
   4.194 -    sequential: bool,
   4.195 -    default: string,
   4.196 -    domintros: bool,
   4.197 -    partials: bool,
   4.198 -    tailrec: bool
   4.199 -   }
   4.200 +datatype function_config = FunctionConfig of
   4.201 + {sequential: bool,
   4.202 +  default: string,
   4.203 +  domintros: bool,
   4.204 +  partials: bool,
   4.205 +  tailrec: bool}
   4.206  
   4.207  fun apply_opt Sequential (FunctionConfig {sequential, default, domintros, partials, tailrec}) =
   4.208      FunctionConfig {sequential=true, default=default, domintros=domintros, partials=partials, tailrec=tailrec}
   4.209 @@ -225,97 +216,94 @@
   4.210  (* Analyzing function equations *)
   4.211  
   4.212  fun split_def ctxt geq =
   4.213 -    let
   4.214 -      fun input_error msg = cat_lines [msg, Syntax.string_of_term ctxt geq]
   4.215 -      val qs = Term.strip_qnt_vars "all" geq
   4.216 -      val imp = Term.strip_qnt_body "all" geq
   4.217 -      val (gs, eq) = Logic.strip_horn imp
   4.218 +  let
   4.219 +    fun input_error msg = cat_lines [msg, Syntax.string_of_term ctxt geq]
   4.220 +    val qs = Term.strip_qnt_vars "all" geq
   4.221 +    val imp = Term.strip_qnt_body "all" geq
   4.222 +    val (gs, eq) = Logic.strip_horn imp
   4.223  
   4.224 -      val (f_args, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq)
   4.225 -          handle TERM _ => error (input_error "Not an equation")
   4.226 +    val (f_args, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq)
   4.227 +      handle TERM _ => error (input_error "Not an equation")
   4.228  
   4.229 -      val (head, args) = strip_comb f_args
   4.230 +    val (head, args) = strip_comb f_args
   4.231  
   4.232 -      val fname = fst (dest_Free head)
   4.233 -          handle TERM _ => error (input_error "Head symbol must not be a bound variable")
   4.234 -    in
   4.235 -      (fname, qs, gs, args, rhs)
   4.236 -    end
   4.237 +    val fname = fst (dest_Free head)
   4.238 +      handle TERM _ => error (input_error "Head symbol must not be a bound variable")
   4.239 +  in
   4.240 +    (fname, qs, gs, args, rhs)
   4.241 +  end
   4.242  
   4.243  (* Check for all sorts of errors in the input *)
   4.244  fun check_defs ctxt fixes eqs =
   4.245 -    let
   4.246 -      val fnames = map (fst o fst) fixes
   4.247 -                                
   4.248 -      fun check geq = 
   4.249 -          let
   4.250 -            fun input_error msg = error (cat_lines [msg, Syntax.string_of_term ctxt geq])
   4.251 -                                  
   4.252 -            val fqgar as (fname, qs, gs, args, rhs) = split_def ctxt geq
   4.253 -                                 
   4.254 -            val _ = fname mem fnames 
   4.255 -                    orelse input_error 
   4.256 -                             ("Head symbol of left hand side must be " 
   4.257 -                              ^ plural "" "one out of " fnames ^ commas_quote fnames)
   4.258 -                                            
   4.259 -            val _ = length args > 0 orelse input_error "Function has no arguments:"
   4.260 +  let
   4.261 +    val fnames = map (fst o fst) fixes
   4.262 +
   4.263 +    fun check geq =
   4.264 +      let
   4.265 +        fun input_error msg = error (cat_lines [msg, Syntax.string_of_term ctxt geq])
   4.266  
   4.267 -            fun add_bvs t is = add_loose_bnos (t, 0, is)
   4.268 +        val fqgar as (fname, qs, gs, args, rhs) = split_def ctxt geq
   4.269 +
   4.270 +        val _ = fname mem fnames
   4.271 +          orelse input_error ("Head symbol of left hand side must be " ^
   4.272 +            plural "" "one out of " fnames ^ commas_quote fnames)
   4.273 +
   4.274 +        val _ = length args > 0 orelse input_error "Function has no arguments:"
   4.275 +
   4.276 +        fun add_bvs t is = add_loose_bnos (t, 0, is)
   4.277              val rvs = (subtract (op =) (fold add_bvs args []) (add_bvs rhs []))
   4.278                          |> map (fst o nth (rev qs))
   4.279 -                      
   4.280 -            val _ = null rvs orelse input_error 
   4.281 -                        ("Variable" ^ plural " " "s " rvs ^ commas_quote rvs
   4.282 -                         ^ " occur" ^ plural "s" "" rvs ^ " on right hand side only:")
   4.283 -                                    
   4.284 -            val _ = forall (not o Term.exists_subterm 
   4.285 -                             (fn Free (n, _) => n mem fnames | _ => false)) (gs @ args)
   4.286 -                    orelse input_error "Defined function may not occur in premises or arguments"
   4.287 +
   4.288 +        val _ = null rvs orelse input_error
   4.289 +          ("Variable" ^ plural " " "s " rvs ^ commas_quote rvs ^
   4.290 +           " occur" ^ plural "s" "" rvs ^ " on right hand side only:")
   4.291 +
   4.292 +        val _ = forall (not o Term.exists_subterm
   4.293 +          (fn Free (n, _) => n mem fnames | _ => false)) (gs @ args)
   4.294 +          orelse input_error "Defined function may not occur in premises or arguments"
   4.295  
   4.296 -            val freeargs = map (fn t => subst_bounds (rev (map Free qs), t)) args
   4.297 -            val funvars = filter (fn q => exists (exists_subterm (fn (Free q') $ _ => q = q' | _ => false)) freeargs) qs
   4.298 -            val _ = null funvars
   4.299 -                    orelse (warning (cat_lines 
   4.300 -                    ["Bound variable" ^ plural " " "s " funvars 
   4.301 -                     ^ commas_quote (map fst funvars) ^  
   4.302 -                     " occur" ^ plural "s" "" funvars ^ " in function position.",  
   4.303 -                     "Misspelled constructor???"]); true)
   4.304 -          in
   4.305 -            (fname, length args)
   4.306 -          end
   4.307 +        val freeargs = map (fn t => subst_bounds (rev (map Free qs), t)) args
   4.308 +        val funvars = filter (fn q => exists (exists_subterm (fn (Free q') $ _ => q = q' | _ => false)) freeargs) qs
   4.309 +        val _ = null funvars orelse (warning (cat_lines
   4.310 +          ["Bound variable" ^ plural " " "s " funvars ^
   4.311 +          commas_quote (map fst funvars) ^ " occur" ^ plural "s" "" funvars ^
   4.312 +          " in function position.", "Misspelled constructor???"]); true)
   4.313 +      in
   4.314 +        (fname, length args)
   4.315 +      end
   4.316  
   4.317 -      val grouped_args = AList.group (op =) (map check eqs)
   4.318 -      val _ = grouped_args
   4.319 -        |> map (fn (fname, ars) =>
   4.320 -             length (distinct (op =) ars) = 1
   4.321 -             orelse error ("Function " ^ quote fname ^
   4.322 -                           " has different numbers of arguments in different equations"))
   4.323 +    val grouped_args = AList.group (op =) (map check eqs)
   4.324 +    val _ = grouped_args
   4.325 +      |> map (fn (fname, ars) =>
   4.326 +        length (distinct (op =) ars) = 1
   4.327 +        orelse error ("Function " ^ quote fname ^
   4.328 +          " has different numbers of arguments in different equations"))
   4.329  
   4.330 -      val not_defined = subtract (op =) (map fst grouped_args) fnames
   4.331 -      val _ = null not_defined
   4.332 -        orelse error ("No defining equations for function" ^
   4.333 -          plural " " "s " not_defined ^ commas_quote not_defined)
   4.334 +    val not_defined = subtract (op =) (map fst grouped_args) fnames
   4.335 +    val _ = null not_defined
   4.336 +      orelse error ("No defining equations for function" ^
   4.337 +        plural " " "s " not_defined ^ commas_quote not_defined)
   4.338  
   4.339 -      fun check_sorts ((fname, fT), _) =
   4.340 -          Sorts.of_sort (Sign.classes_of (ProofContext.theory_of ctxt)) (fT, HOLogic.typeS)
   4.341 -          orelse error (cat_lines 
   4.342 -          ["Type of " ^ quote fname ^ " is not of sort " ^ quote "type" ^ ":",
   4.343 -           setmp_CRITICAL show_sorts true (Syntax.string_of_typ ctxt) fT])
   4.344 +    fun check_sorts ((fname, fT), _) =
   4.345 +      Sorts.of_sort (Sign.classes_of (ProofContext.theory_of ctxt)) (fT, HOLogic.typeS)
   4.346 +      orelse error (cat_lines
   4.347 +      ["Type of " ^ quote fname ^ " is not of sort " ^ quote "type" ^ ":",
   4.348 +       setmp_CRITICAL show_sorts true (Syntax.string_of_typ ctxt) fT])
   4.349  
   4.350 -      val _ = map check_sorts fixes
   4.351 -    in
   4.352 -      ()
   4.353 -    end
   4.354 +    val _ = map check_sorts fixes
   4.355 +  in
   4.356 +    ()
   4.357 +  end
   4.358  
   4.359  (* Preprocessors *)
   4.360  
   4.361  type fixes = ((string * typ) * mixfix) list
   4.362  type 'a spec = (Attrib.binding * 'a list) list
   4.363 -type preproc = function_config -> Proof.context -> fixes -> term spec 
   4.364 -               -> (term list * (thm list -> thm spec) * (thm list -> thm list list) * string list)
   4.365 +type preproc = function_config -> Proof.context -> fixes -> term spec ->
   4.366 +  (term list * (thm list -> thm spec) * (thm list -> thm list list) * string list)
   4.367  
   4.368 -val fname_of = fst o dest_Free o fst o strip_comb o fst 
   4.369 - o HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl o snd o dest_all_all
   4.370 +val fname_of = fst o dest_Free o fst o strip_comb o fst o HOLogic.dest_eq o
   4.371 +  HOLogic.dest_Trueprop o Logic.strip_imp_concl o snd o dest_all_all
   4.372  
   4.373  fun mk_case_names i "" k = mk_case_names i (string_of_int (i + 1)) k
   4.374    | mk_case_names _ n 0 = []
   4.375 @@ -323,22 +311,21 @@
   4.376    | mk_case_names _ n k = map (fn i => n ^ "_" ^ string_of_int i) (1 upto k)
   4.377  
   4.378  fun empty_preproc check _ ctxt fixes spec =
   4.379 -    let 
   4.380 -      val (bnds, tss) = split_list spec
   4.381 -      val ts = flat tss
   4.382 -      val _ = check ctxt fixes ts
   4.383 -      val fnames = map (fst o fst) fixes
   4.384 -      val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) ts
   4.385 +  let
   4.386 +    val (bnds, tss) = split_list spec
   4.387 +    val ts = flat tss
   4.388 +    val _ = check ctxt fixes ts
   4.389 +    val fnames = map (fst o fst) fixes
   4.390 +    val indices = map (fn eq => find_index (curry op = (fname_of eq)) fnames) ts
   4.391  
   4.392 -      fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1) 
   4.393 -                                   (indices ~~ xs)
   4.394 -                        |> map (map snd)
   4.395 +    fun sort xs = partition_list (fn i => fn (j,_) => i = j) 0 (length fnames - 1) 
   4.396 +      (indices ~~ xs) |> map (map snd)
   4.397  
   4.398 -      (* using theorem names for case name currently disabled *)
   4.399 -      val cnames = map_index (fn (i, _) => mk_case_names i "" 1) bnds |> flat
   4.400 -    in
   4.401 -      (ts, curry op ~~ bnds o Library.unflat tss, sort, cnames)
   4.402 -    end
   4.403 +    (* using theorem names for case name currently disabled *)
   4.404 +    val cnames = map_index (fn (i, _) => mk_case_names i "" 1) bnds |> flat
   4.405 +  in
   4.406 +    (ts, curry op ~~ bnds o Library.unflat tss, sort, cnames)
   4.407 +  end
   4.408  
   4.409  structure Preprocessor = Generic_Data
   4.410  (
   4.411 @@ -346,32 +333,31 @@
   4.412    val empty : T = empty_preproc check_defs
   4.413    val extend = I
   4.414    fun merge (a, _) = a
   4.415 -);
   4.416 +)
   4.417  
   4.418  val get_preproc = Preprocessor.get o Context.Proof
   4.419  val set_preproc = Preprocessor.map o K
   4.420  
   4.421  
   4.422  
   4.423 -local 
   4.424 +local
   4.425    structure P = OuterParse and K = OuterKeyword
   4.426  
   4.427 -  val option_parser = 
   4.428 -      P.group "option" ((P.reserved "sequential" >> K Sequential)
   4.429 -                    || ((P.reserved "default" |-- P.term) >> Default)
   4.430 -                    || (P.reserved "domintros" >> K DomIntros)
   4.431 -                    || (P.reserved "no_partials" >> K No_Partials)
   4.432 -                    || (P.reserved "tailrec" >> K Tailrec))
   4.433 +  val option_parser = P.group "option"
   4.434 +    ((P.reserved "sequential" >> K Sequential)
   4.435 +     || ((P.reserved "default" |-- P.term) >> Default)
   4.436 +     || (P.reserved "domintros" >> K DomIntros)
   4.437 +     || (P.reserved "no_partials" >> K No_Partials)
   4.438 +     || (P.reserved "tailrec" >> K Tailrec))
   4.439  
   4.440 -  fun config_parser default = 
   4.441 -      (Scan.optional (P.$$$ "(" |-- P.!!! (P.list1 option_parser) --| P.$$$ ")") [])
   4.442 -        >> (fn opts => fold apply_opt opts default)
   4.443 +  fun config_parser default =
   4.444 +    (Scan.optional (P.$$$ "(" |-- P.!!! (P.list1 option_parser) --| P.$$$ ")") [])
   4.445 +     >> (fn opts => fold apply_opt opts default)
   4.446  in
   4.447 -  fun function_parser default_cfg = 
   4.448 +  fun function_parser default_cfg =
   4.449        config_parser default_cfg -- P.fixes -- SpecParse.where_alt_specs
   4.450  end
   4.451  
   4.452  
   4.453  end
   4.454  end
   4.455 -
     5.1 --- a/src/HOL/Tools/Function/function_core.ML	Sat Jan 02 23:18:58 2010 +0100
     5.2 +++ b/src/HOL/Tools/Function/function_core.ML	Sat Jan 02 23:18:58 2010 +0100
     5.3 @@ -7,26 +7,25 @@
     5.4  
     5.5  signature FUNCTION_CORE =
     5.6  sig
     5.7 -    val trace: bool Unsynchronized.ref
     5.8 +  val trace: bool Unsynchronized.ref
     5.9  
    5.10 -    val prepare_function : Function_Common.function_config
    5.11 -                         -> string (* defname *)
    5.12 -                         -> ((bstring * typ) * mixfix) list (* defined symbol *)
    5.13 -                         -> ((bstring * typ) list * term list * term * term) list (* specification *)
    5.14 -                         -> local_theory
    5.15 -
    5.16 -                         -> (term   (* f *)
    5.17 -                             * thm  (* goalstate *)
    5.18 -                             * (thm -> Function_Common.function_result) (* continuation *)
    5.19 -                            ) * local_theory
    5.20 +  val prepare_function : Function_Common.function_config
    5.21 +    -> string (* defname *)
    5.22 +    -> ((bstring * typ) * mixfix) list (* defined symbol *)
    5.23 +    -> ((bstring * typ) list * term list * term * term) list (* specification *)
    5.24 +    -> local_theory
    5.25 +    -> (term   (* f *)
    5.26 +        * thm  (* goalstate *)
    5.27 +        * (thm -> Function_Common.function_result) (* continuation *)
    5.28 +       ) * local_theory
    5.29  
    5.30  end
    5.31  
    5.32  structure Function_Core : FUNCTION_CORE =
    5.33  struct
    5.34  
    5.35 -val trace = Unsynchronized.ref false;
    5.36 -fun trace_msg msg = if ! trace then tracing (msg ()) else ();
    5.37 +val trace = Unsynchronized.ref false
    5.38 +fun trace_msg msg = if ! trace then tracing (msg ()) else ()
    5.39  
    5.40  val boolT = HOLogic.boolT
    5.41  val mk_eq = HOLogic.mk_eq
    5.42 @@ -34,149 +33,134 @@
    5.43  open Function_Lib
    5.44  open Function_Common
    5.45  
    5.46 -datatype globals =
    5.47 -   Globals of {
    5.48 -         fvar: term,
    5.49 -         domT: typ,
    5.50 -         ranT: typ,
    5.51 -         h: term,
    5.52 -         y: term,
    5.53 -         x: term,
    5.54 -         z: term,
    5.55 -         a: term,
    5.56 -         P: term,
    5.57 -         D: term,
    5.58 -         Pbool:term
    5.59 -}
    5.60 +datatype globals = Globals of
    5.61 + {fvar: term,
    5.62 +  domT: typ,
    5.63 +  ranT: typ,
    5.64 +  h: term,
    5.65 +  y: term,
    5.66 +  x: term,
    5.67 +  z: term,
    5.68 +  a: term,
    5.69 +  P: term,
    5.70 +  D: term,
    5.71 +  Pbool:term}
    5.72 +
    5.73 +datatype rec_call_info = RCInfo of
    5.74 + {RIvs: (string * typ) list,  (* Call context: fixes and assumes *)
    5.75 +  CCas: thm list,
    5.76 +  rcarg: term,                 (* The recursive argument *)
    5.77 +  llRI: thm,
    5.78 +  h_assum: term}
    5.79  
    5.80  
    5.81 -datatype rec_call_info =
    5.82 -  RCInfo of
    5.83 -  {
    5.84 -   RIvs: (string * typ) list,  (* Call context: fixes and assumes *)
    5.85 -   CCas: thm list,
    5.86 -   rcarg: term,                 (* The recursive argument *)
    5.87 -
    5.88 -   llRI: thm,
    5.89 -   h_assum: term
    5.90 -  }
    5.91 -
    5.92 -
    5.93 -datatype clause_context =
    5.94 -  ClauseContext of
    5.95 -  {
    5.96 -    ctxt : Proof.context,
    5.97 -
    5.98 -    qs : term list,
    5.99 -    gs : term list,
   5.100 -    lhs: term,
   5.101 -    rhs: term,
   5.102 -
   5.103 -    cqs: cterm list,
   5.104 -    ags: thm list,
   5.105 -    case_hyp : thm
   5.106 -  }
   5.107 +datatype clause_context = ClauseContext of
   5.108 + {ctxt : Proof.context,
   5.109 +  qs : term list,
   5.110 +  gs : term list,
   5.111 +  lhs: term,
   5.112 +  rhs: term,
   5.113 +  cqs: cterm list,
   5.114 +  ags: thm list,
   5.115 +  case_hyp : thm}
   5.116  
   5.117  
   5.118  fun transfer_clause_ctx thy (ClauseContext { ctxt, qs, gs, lhs, rhs, cqs, ags, case_hyp }) =
   5.119 -    ClauseContext { ctxt = ProofContext.transfer thy ctxt,
   5.120 -                    qs = qs, gs = gs, lhs = lhs, rhs = rhs, cqs = cqs, ags = ags, case_hyp = case_hyp }
   5.121 +  ClauseContext { ctxt = ProofContext.transfer thy ctxt,
   5.122 +    qs = qs, gs = gs, lhs = lhs, rhs = rhs, cqs = cqs, ags = ags, case_hyp = case_hyp }
   5.123  
   5.124  
   5.125 -datatype clause_info =
   5.126 -  ClauseInfo of
   5.127 -     {
   5.128 -      no: int,
   5.129 -      qglr : ((string * typ) list * term list * term * term),
   5.130 -      cdata : clause_context,
   5.131 -
   5.132 -      tree: Function_Ctx_Tree.ctx_tree,
   5.133 -      lGI: thm,
   5.134 -      RCs: rec_call_info list
   5.135 -     }
   5.136 +datatype clause_info = ClauseInfo of
   5.137 + {no: int,
   5.138 +  qglr : ((string * typ) list * term list * term * term),
   5.139 +  cdata : clause_context,
   5.140 +  tree: Function_Ctx_Tree.ctx_tree,
   5.141 +  lGI: thm,
   5.142 +  RCs: rec_call_info list}
   5.143  
   5.144  
   5.145  (* Theory dependencies. *)
   5.146 -val acc_induct_rule = @{thm accp_induct_rule};
   5.147 +val acc_induct_rule = @{thm accp_induct_rule}
   5.148  
   5.149 -val ex1_implies_ex = @{thm FunDef.fundef_ex1_existence};
   5.150 -val ex1_implies_un = @{thm FunDef.fundef_ex1_uniqueness};
   5.151 -val ex1_implies_iff = @{thm FunDef.fundef_ex1_iff};
   5.152 +val ex1_implies_ex = @{thm FunDef.fundef_ex1_existence}
   5.153 +val ex1_implies_un = @{thm FunDef.fundef_ex1_uniqueness}
   5.154 +val ex1_implies_iff = @{thm FunDef.fundef_ex1_iff}
   5.155  
   5.156 -val acc_downward = @{thm accp_downward};
   5.157 -val accI = @{thm accp.accI};
   5.158 -val case_split = @{thm HOL.case_split};
   5.159 -val fundef_default_value = @{thm FunDef.fundef_default_value};
   5.160 -val not_acc_down = @{thm not_accp_down};
   5.161 +val acc_downward = @{thm accp_downward}
   5.162 +val accI = @{thm accp.accI}
   5.163 +val case_split = @{thm HOL.case_split}
   5.164 +val fundef_default_value = @{thm FunDef.fundef_default_value}
   5.165 +val not_acc_down = @{thm not_accp_down}
   5.166  
   5.167  
   5.168  
   5.169  fun find_calls tree =
   5.170 -    let
   5.171 -      fun add_Ri (fixes,assumes) (_ $ arg) _ (_, xs) = ([], (fixes, assumes, arg) :: xs)
   5.172 -        | add_Ri _ _ _ _ = raise Match
   5.173 -    in
   5.174 -      rev (Function_Ctx_Tree.traverse_tree add_Ri tree [])
   5.175 -    end
   5.176 +  let
   5.177 +    fun add_Ri (fixes,assumes) (_ $ arg) _ (_, xs) =
   5.178 +      ([], (fixes, assumes, arg) :: xs)
   5.179 +      | add_Ri _ _ _ _ = raise Match
   5.180 +  in
   5.181 +    rev (Function_Ctx_Tree.traverse_tree add_Ri tree [])
   5.182 +  end
   5.183  
   5.184  
   5.185  (** building proof obligations *)
   5.186  
   5.187  fun mk_compat_proof_obligations domT ranT fvar f glrs =
   5.188 -    let
   5.189 -      fun mk_impl ((qs, gs, lhs, rhs),(qs', gs', lhs', rhs')) =
   5.190 -          let
   5.191 -            val shift = incr_boundvars (length qs')
   5.192 -          in
   5.193 -            Logic.mk_implies
   5.194 -              (HOLogic.mk_Trueprop (HOLogic.eq_const domT $ shift lhs $ lhs'),
   5.195 -                HOLogic.mk_Trueprop (HOLogic.eq_const ranT $ shift rhs $ rhs'))
   5.196 -              |> fold_rev (curry Logic.mk_implies) (map shift gs @ gs')
   5.197 -              |> fold_rev (fn (n,T) => fn b => Term.all T $ Abs(n,T,b)) (qs @ qs')
   5.198 -              |> curry abstract_over fvar
   5.199 -              |> curry subst_bound f
   5.200 -          end
   5.201 -    in
   5.202 -      map mk_impl (unordered_pairs glrs)
   5.203 -    end
   5.204 +  let
   5.205 +    fun mk_impl ((qs, gs, lhs, rhs),(qs', gs', lhs', rhs')) =
   5.206 +      let
   5.207 +        val shift = incr_boundvars (length qs')
   5.208 +      in
   5.209 +        Logic.mk_implies
   5.210 +          (HOLogic.mk_Trueprop (HOLogic.eq_const domT $ shift lhs $ lhs'),
   5.211 +            HOLogic.mk_Trueprop (HOLogic.eq_const ranT $ shift rhs $ rhs'))
   5.212 +        |> fold_rev (curry Logic.mk_implies) (map shift gs @ gs')
   5.213 +        |> fold_rev (fn (n,T) => fn b => Term.all T $ Abs(n,T,b)) (qs @ qs')
   5.214 +        |> curry abstract_over fvar
   5.215 +        |> curry subst_bound f
   5.216 +      end
   5.217 +  in
   5.218 +    map mk_impl (unordered_pairs glrs)
   5.219 +  end
   5.220  
   5.221  
   5.222  fun mk_completeness (Globals {x, Pbool, ...}) clauses qglrs =
   5.223 -    let
   5.224 -        fun mk_case (ClauseContext {qs, gs, lhs, ...}, (oqs, _, _, _)) =
   5.225 -            HOLogic.mk_Trueprop Pbool
   5.226 -                     |> curry Logic.mk_implies (HOLogic.mk_Trueprop (mk_eq (x, lhs)))
   5.227 -                     |> fold_rev (curry Logic.mk_implies) gs
   5.228 -                     |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
   5.229 -    in
   5.230 -        HOLogic.mk_Trueprop Pbool
   5.231 -                 |> fold_rev (curry Logic.mk_implies o mk_case) (clauses ~~ qglrs)
   5.232 -                 |> mk_forall_rename ("x", x)
   5.233 -                 |> mk_forall_rename ("P", Pbool)
   5.234 -    end
   5.235 +  let
   5.236 +    fun mk_case (ClauseContext {qs, gs, lhs, ...}, (oqs, _, _, _)) =
   5.237 +      HOLogic.mk_Trueprop Pbool
   5.238 +      |> curry Logic.mk_implies (HOLogic.mk_Trueprop (mk_eq (x, lhs)))
   5.239 +      |> fold_rev (curry Logic.mk_implies) gs
   5.240 +      |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
   5.241 +  in
   5.242 +    HOLogic.mk_Trueprop Pbool
   5.243 +    |> fold_rev (curry Logic.mk_implies o mk_case) (clauses ~~ qglrs)
   5.244 +    |> mk_forall_rename ("x", x)
   5.245 +    |> mk_forall_rename ("P", Pbool)
   5.246 +  end
   5.247  
   5.248  (** making a context with it's own local bindings **)
   5.249  
   5.250  fun mk_clause_context x ctxt (pre_qs,pre_gs,pre_lhs,pre_rhs) =
   5.251 -    let
   5.252 -      val (qs, ctxt') = Variable.variant_fixes (map fst pre_qs) ctxt
   5.253 -                                           |>> map2 (fn (_, T) => fn n => Free (n, T)) pre_qs
   5.254 +  let
   5.255 +    val (qs, ctxt') = Variable.variant_fixes (map fst pre_qs) ctxt
   5.256 +      |>> map2 (fn (_, T) => fn n => Free (n, T)) pre_qs
   5.257  
   5.258 -      val thy = ProofContext.theory_of ctxt'
   5.259 +    val thy = ProofContext.theory_of ctxt'
   5.260  
   5.261 -      fun inst t = subst_bounds (rev qs, t)
   5.262 -      val gs = map inst pre_gs
   5.263 -      val lhs = inst pre_lhs
   5.264 -      val rhs = inst pre_rhs
   5.265 +    fun inst t = subst_bounds (rev qs, t)
   5.266 +    val gs = map inst pre_gs
   5.267 +    val lhs = inst pre_lhs
   5.268 +    val rhs = inst pre_rhs
   5.269  
   5.270 -      val cqs = map (cterm_of thy) qs
   5.271 -      val ags = map (assume o cterm_of thy) gs
   5.272 +    val cqs = map (cterm_of thy) qs
   5.273 +    val ags = map (assume o cterm_of thy) gs
   5.274  
   5.275 -      val case_hyp = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (x, lhs))))
   5.276 -    in
   5.277 -      ClauseContext { ctxt = ctxt', qs = qs, gs = gs, lhs = lhs, rhs = rhs,
   5.278 -                      cqs = cqs, ags = ags, case_hyp = case_hyp }
   5.279 -    end
   5.280 +    val case_hyp = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (x, lhs))))
   5.281 +  in
   5.282 +    ClauseContext { ctxt = ctxt', qs = qs, gs = gs, lhs = lhs, rhs = rhs,
   5.283 +      cqs = cqs, ags = ags, case_hyp = case_hyp }
   5.284 +  end
   5.285  
   5.286  
   5.287  (* lowlevel term function. FIXME: remove *)
   5.288 @@ -188,7 +172,7 @@
   5.289          (case tm of
   5.290            Abs (a, T, t) => Abs (a, T, abs (lev + 1) v t)
   5.291          | t $ u => abs lev v t $ abs lev v u
   5.292 -        | t => t);
   5.293 +        | t => t)
   5.294    in
   5.295      fold_index (fn (i, v) => fn t => abs i v t) vs body
   5.296    end
   5.297 @@ -196,258 +180,249 @@
   5.298  
   5.299  
   5.300  fun mk_clause_info globals G f no cdata qglr tree RCs GIntro_thm RIntro_thms =
   5.301 -    let
   5.302 -        val Globals {h, ...} = globals
   5.303 +  let
   5.304 +    val Globals {h, ...} = globals
   5.305  
   5.306 -        val ClauseContext { ctxt, qs, cqs, ags, ... } = cdata
   5.307 -        val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
   5.308 +    val ClauseContext { ctxt, qs, cqs, ags, ... } = cdata
   5.309 +    val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
   5.310  
   5.311 -        (* Instantiate the GIntro thm with "f" and import into the clause context. *)
   5.312 -        val lGI = GIntro_thm
   5.313 -                    |> forall_elim (cert f)
   5.314 -                    |> fold forall_elim cqs
   5.315 -                    |> fold Thm.elim_implies ags
   5.316 -
   5.317 -        fun mk_call_info (rcfix, rcassm, rcarg) RI =
   5.318 -            let
   5.319 -                val llRI = RI
   5.320 -                             |> fold forall_elim cqs
   5.321 -                             |> fold (forall_elim o cert o Free) rcfix
   5.322 -                             |> fold Thm.elim_implies ags
   5.323 -                             |> fold Thm.elim_implies rcassm
   5.324 +    (* Instantiate the GIntro thm with "f" and import into the clause context. *)
   5.325 +    val lGI = GIntro_thm
   5.326 +      |> forall_elim (cert f)
   5.327 +      |> fold forall_elim cqs
   5.328 +      |> fold Thm.elim_implies ags
   5.329  
   5.330 -                val h_assum =
   5.331 -                    HOLogic.mk_Trueprop (G $ rcarg $ (h $ rcarg))
   5.332 -                              |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
   5.333 -                              |> fold_rev (Logic.all o Free) rcfix
   5.334 -                              |> Pattern.rewrite_term (ProofContext.theory_of ctxt) [(f, h)] []
   5.335 -                              |> abstract_over_list (rev qs)
   5.336 -            in
   5.337 -                RCInfo {RIvs=rcfix, rcarg=rcarg, CCas=rcassm, llRI=llRI, h_assum=h_assum}
   5.338 -            end
   5.339 +    fun mk_call_info (rcfix, rcassm, rcarg) RI =
   5.340 +      let
   5.341 +        val llRI = RI
   5.342 +          |> fold forall_elim cqs
   5.343 +          |> fold (forall_elim o cert o Free) rcfix
   5.344 +          |> fold Thm.elim_implies ags
   5.345 +          |> fold Thm.elim_implies rcassm
   5.346  
   5.347 -        val RC_infos = map2 mk_call_info RCs RIntro_thms
   5.348 -    in
   5.349 -        ClauseInfo
   5.350 -            {
   5.351 -             no=no,
   5.352 -             cdata=cdata,
   5.353 -             qglr=qglr,
   5.354 +        val h_assum =
   5.355 +          HOLogic.mk_Trueprop (G $ rcarg $ (h $ rcarg))
   5.356 +          |> fold_rev (curry Logic.mk_implies o prop_of) rcassm
   5.357 +          |> fold_rev (Logic.all o Free) rcfix
   5.358 +          |> Pattern.rewrite_term (ProofContext.theory_of ctxt) [(f, h)] []
   5.359 +          |> abstract_over_list (rev qs)
   5.360 +      in
   5.361 +        RCInfo {RIvs=rcfix, rcarg=rcarg, CCas=rcassm, llRI=llRI, h_assum=h_assum}
   5.362 +      end
   5.363  
   5.364 -             lGI=lGI,
   5.365 -             RCs=RC_infos,
   5.366 -             tree=tree
   5.367 -            }
   5.368 -    end
   5.369 +    val RC_infos = map2 mk_call_info RCs RIntro_thms
   5.370 +  in
   5.371 +    ClauseInfo {no=no, cdata=cdata, qglr=qglr, lGI=lGI, RCs=RC_infos,
   5.372 +      tree=tree}
   5.373 +  end
   5.374  
   5.375  
   5.376 -
   5.377 -
   5.378 -
   5.379 -
   5.380 -
   5.381 -(* replace this by a table later*)
   5.382  fun store_compat_thms 0 thms = []
   5.383    | store_compat_thms n thms =
   5.384 -    let
   5.385 -        val (thms1, thms2) = chop n thms
   5.386 -    in
   5.387 -        (thms1 :: store_compat_thms (n - 1) thms2)
   5.388 -    end
   5.389 +  let
   5.390 +    val (thms1, thms2) = chop n thms
   5.391 +  in
   5.392 +    (thms1 :: store_compat_thms (n - 1) thms2)
   5.393 +  end
   5.394  
   5.395  (* expects i <= j *)
   5.396  fun lookup_compat_thm i j cts =
   5.397 -    nth (nth cts (i - 1)) (j - i)
   5.398 +  nth (nth cts (i - 1)) (j - i)
   5.399  
   5.400  (* Returns "Gsi, Gsj, lhs_i = lhs_j |-- rhs_j_f = rhs_i_f" *)
   5.401  (* if j < i, then turn around *)
   5.402  fun get_compat_thm thy cts i j ctxi ctxj =
   5.403 -    let
   5.404 -      val ClauseContext {cqs=cqsi,ags=agsi,lhs=lhsi,...} = ctxi
   5.405 -      val ClauseContext {cqs=cqsj,ags=agsj,lhs=lhsj,...} = ctxj
   5.406 +  let
   5.407 +    val ClauseContext {cqs=cqsi,ags=agsi,lhs=lhsi,...} = ctxi
   5.408 +    val ClauseContext {cqs=cqsj,ags=agsj,lhs=lhsj,...} = ctxj
   5.409  
   5.410 -      val lhsi_eq_lhsj = cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj)))
   5.411 -    in if j < i then
   5.412 -         let
   5.413 -           val compat = lookup_compat_thm j i cts
   5.414 -         in
   5.415 -           compat         (* "!!qj qi. Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
   5.416 -                |> fold forall_elim (cqsj @ cqsi) (* "Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
   5.417 -                |> fold Thm.elim_implies agsj
   5.418 -                |> fold Thm.elim_implies agsi
   5.419 -                |> Thm.elim_implies ((assume lhsi_eq_lhsj) RS sym) (* "Gsj, Gsi, lhsi = lhsj |-- rhsj = rhsi" *)
   5.420 -         end
   5.421 -       else
   5.422 -         let
   5.423 -           val compat = lookup_compat_thm i j cts
   5.424 -         in
   5.425 -               compat        (* "!!qi qj. Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
   5.426 -                 |> fold forall_elim (cqsi @ cqsj) (* "Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
   5.427 -                 |> fold Thm.elim_implies agsi
   5.428 -                 |> fold Thm.elim_implies agsj
   5.429 -                 |> Thm.elim_implies (assume lhsi_eq_lhsj)
   5.430 -                 |> (fn thm => thm RS sym) (* "Gsi, Gsj, lhsi = lhsj |-- rhsj = rhsi" *)
   5.431 -         end
   5.432 +    val lhsi_eq_lhsj = cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj)))
   5.433 +  in if j < i then
   5.434 +    let
   5.435 +      val compat = lookup_compat_thm j i cts
   5.436 +    in
   5.437 +      compat         (* "!!qj qi. Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
   5.438 +      |> fold forall_elim (cqsj @ cqsi) (* "Gsj => Gsi => lhsj = lhsi ==> rhsj = rhsi" *)
   5.439 +      |> fold Thm.elim_implies agsj
   5.440 +      |> fold Thm.elim_implies agsi
   5.441 +      |> Thm.elim_implies ((assume lhsi_eq_lhsj) RS sym) (* "Gsj, Gsi, lhsi = lhsj |-- rhsj = rhsi" *)
   5.442      end
   5.443 -
   5.444 -
   5.445 -
   5.446 +    else
   5.447 +    let
   5.448 +      val compat = lookup_compat_thm i j cts
   5.449 +    in
   5.450 +      compat        (* "!!qi qj. Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
   5.451 +      |> fold forall_elim (cqsi @ cqsj) (* "Gsi => Gsj => lhsi = lhsj ==> rhsi = rhsj" *)
   5.452 +      |> fold Thm.elim_implies agsi
   5.453 +      |> fold Thm.elim_implies agsj
   5.454 +      |> Thm.elim_implies (assume lhsi_eq_lhsj)
   5.455 +      |> (fn thm => thm RS sym) (* "Gsi, Gsj, lhsi = lhsj |-- rhsj = rhsi" *)
   5.456 +    end
   5.457 +  end
   5.458  
   5.459  (* Generates the replacement lemma in fully quantified form. *)
   5.460  fun mk_replacement_lemma thy h ih_elim clause =
   5.461 -    let
   5.462 -        val ClauseInfo {cdata=ClauseContext {qs, lhs, cqs, ags, case_hyp, ...}, RCs, tree, ...} = clause
   5.463 -        local open Conv in
   5.464 -        val ih_conv = arg1_conv o arg_conv o arg_conv
   5.465 -        end
   5.466 +  let
   5.467 +    val ClauseInfo {cdata=ClauseContext {qs, lhs, cqs, ags, case_hyp, ...},
   5.468 +      RCs, tree, ...} = clause
   5.469 +    local open Conv in
   5.470 +      val ih_conv = arg1_conv o arg_conv o arg_conv
   5.471 +    end
   5.472  
   5.473 -        val ih_elim_case = Conv.fconv_rule (ih_conv (K (case_hyp RS eq_reflection))) ih_elim
   5.474 -
   5.475 -        val Ris = map (fn RCInfo {llRI, ...} => llRI) RCs
   5.476 -        val h_assums = map (fn RCInfo {h_assum, ...} => assume (cterm_of thy (subst_bounds (rev qs, h_assum)))) RCs
   5.477 +    val ih_elim_case =
   5.478 +      Conv.fconv_rule (ih_conv (K (case_hyp RS eq_reflection))) ih_elim
   5.479  
   5.480 -        val (eql, _) = Function_Ctx_Tree.rewrite_by_tree thy h ih_elim_case (Ris ~~ h_assums) tree
   5.481 +    val Ris = map (fn RCInfo {llRI, ...} => llRI) RCs
   5.482 +    val h_assums = map (fn RCInfo {h_assum, ...} =>
   5.483 +      assume (cterm_of thy (subst_bounds (rev qs, h_assum)))) RCs
   5.484 +
   5.485 +    val (eql, _) =
   5.486 +      Function_Ctx_Tree.rewrite_by_tree thy h ih_elim_case (Ris ~~ h_assums) tree
   5.487  
   5.488 -        val replace_lemma = (eql RS meta_eq_to_obj_eq)
   5.489 -                                |> implies_intr (cprop_of case_hyp)
   5.490 -                                |> fold_rev (implies_intr o cprop_of) h_assums
   5.491 -                                |> fold_rev (implies_intr o cprop_of) ags
   5.492 -                                |> fold_rev forall_intr cqs
   5.493 -                                |> Thm.close_derivation
   5.494 -    in
   5.495 -      replace_lemma
   5.496 -    end
   5.497 +    val replace_lemma = (eql RS meta_eq_to_obj_eq)
   5.498 +      |> implies_intr (cprop_of case_hyp)
   5.499 +      |> fold_rev (implies_intr o cprop_of) h_assums
   5.500 +      |> fold_rev (implies_intr o cprop_of) ags
   5.501 +      |> fold_rev forall_intr cqs
   5.502 +      |> Thm.close_derivation
   5.503 +  in
   5.504 +    replace_lemma
   5.505 +  end
   5.506  
   5.507  
   5.508  fun mk_uniqueness_clause thy globals compat_store clausei clausej RLj =
   5.509 -    let
   5.510 -        val Globals {h, y, x, fvar, ...} = globals
   5.511 -        val ClauseInfo {no=i, cdata=cctxi as ClauseContext {ctxt=ctxti, lhs=lhsi, case_hyp, ...}, ...} = clausei
   5.512 -        val ClauseInfo {no=j, qglr=cdescj, RCs=RCsj, ...} = clausej
   5.513 +  let
   5.514 +    val Globals {h, y, x, fvar, ...} = globals
   5.515 +    val ClauseInfo {no=i, cdata=cctxi as ClauseContext {ctxt=ctxti, lhs=lhsi, case_hyp, ...}, ...} = clausei
   5.516 +    val ClauseInfo {no=j, qglr=cdescj, RCs=RCsj, ...} = clausej
   5.517 +
   5.518 +    val cctxj as ClauseContext {ags = agsj', lhs = lhsj', rhs = rhsj', qs = qsj', cqs = cqsj', ...} =
   5.519 +      mk_clause_context x ctxti cdescj
   5.520  
   5.521 -        val cctxj as ClauseContext {ags = agsj', lhs = lhsj', rhs = rhsj', qs = qsj', cqs = cqsj', ...}
   5.522 -            = mk_clause_context x ctxti cdescj
   5.523 +    val rhsj'h = Pattern.rewrite_term thy [(fvar,h)] [] rhsj'
   5.524 +    val compat = get_compat_thm thy compat_store i j cctxi cctxj
   5.525 +    val Ghsj' = map (fn RCInfo {h_assum, ...} => assume (cterm_of thy (subst_bounds (rev qsj', h_assum)))) RCsj
   5.526  
   5.527 -        val rhsj'h = Pattern.rewrite_term thy [(fvar,h)] [] rhsj'
   5.528 -        val compat = get_compat_thm thy compat_store i j cctxi cctxj
   5.529 -        val Ghsj' = map (fn RCInfo {h_assum, ...} => assume (cterm_of thy (subst_bounds (rev qsj', h_assum)))) RCsj
   5.530 +    val RLj_import = RLj
   5.531 +      |> fold forall_elim cqsj'
   5.532 +      |> fold Thm.elim_implies agsj'
   5.533 +      |> fold Thm.elim_implies Ghsj'
   5.534  
   5.535 -        val RLj_import =
   5.536 -            RLj |> fold forall_elim cqsj'
   5.537 -                |> fold Thm.elim_implies agsj'
   5.538 -                |> fold Thm.elim_implies Ghsj'
   5.539 -
   5.540 -        val y_eq_rhsj'h = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (y, rhsj'h))))
   5.541 -        val lhsi_eq_lhsj' = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj')))) (* lhs_i = lhs_j' |-- lhs_i = lhs_j' *)
   5.542 -    in
   5.543 -        (trans OF [case_hyp, lhsi_eq_lhsj']) (* lhs_i = lhs_j' |-- x = lhs_j' *)
   5.544 -        |> implies_elim RLj_import (* Rj1' ... Rjk', lhs_i = lhs_j' |-- rhs_j'_h = rhs_j'_f *)
   5.545 -        |> (fn it => trans OF [it, compat]) (* lhs_i = lhs_j', Gj', Rj1' ... Rjk' |-- rhs_j'_h = rhs_i_f *)
   5.546 -        |> (fn it => trans OF [y_eq_rhsj'h, it]) (* lhs_i = lhs_j', Gj', Rj1' ... Rjk', y = rhs_j_h' |-- y = rhs_i_f *)
   5.547 -        |> fold_rev (implies_intr o cprop_of) Ghsj'
   5.548 -        |> fold_rev (implies_intr o cprop_of) agsj' (* lhs_i = lhs_j' , y = rhs_j_h' |-- Gj', Rj1'...Rjk' ==> y = rhs_i_f *)
   5.549 -        |> implies_intr (cprop_of y_eq_rhsj'h)
   5.550 -        |> implies_intr (cprop_of lhsi_eq_lhsj')
   5.551 -        |> fold_rev forall_intr (cterm_of thy h :: cqsj')
   5.552 -    end
   5.553 +    val y_eq_rhsj'h = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (y, rhsj'h))))
   5.554 +    val lhsi_eq_lhsj' = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (lhsi, lhsj'))))
   5.555 +       (* lhs_i = lhs_j' |-- lhs_i = lhs_j' *)
   5.556 +  in
   5.557 +    (trans OF [case_hyp, lhsi_eq_lhsj']) (* lhs_i = lhs_j' |-- x = lhs_j' *)
   5.558 +    |> implies_elim RLj_import
   5.559 +      (* Rj1' ... Rjk', lhs_i = lhs_j' |-- rhs_j'_h = rhs_j'_f *)
   5.560 +    |> (fn it => trans OF [it, compat])
   5.561 +      (* lhs_i = lhs_j', Gj', Rj1' ... Rjk' |-- rhs_j'_h = rhs_i_f *)
   5.562 +    |> (fn it => trans OF [y_eq_rhsj'h, it])
   5.563 +      (* lhs_i = lhs_j', Gj', Rj1' ... Rjk', y = rhs_j_h' |-- y = rhs_i_f *)
   5.564 +    |> fold_rev (implies_intr o cprop_of) Ghsj'
   5.565 +    |> fold_rev (implies_intr o cprop_of) agsj'
   5.566 +      (* lhs_i = lhs_j' , y = rhs_j_h' |-- Gj', Rj1'...Rjk' ==> y = rhs_i_f *)
   5.567 +    |> implies_intr (cprop_of y_eq_rhsj'h)
   5.568 +    |> implies_intr (cprop_of lhsi_eq_lhsj')
   5.569 +    |> fold_rev forall_intr (cterm_of thy h :: cqsj')
   5.570 +  end
   5.571  
   5.572  
   5.573  
   5.574  fun mk_uniqueness_case thy globals G f ihyp ih_intro G_cases compat_store clauses rep_lemmas clausei =
   5.575 -    let
   5.576 -        val Globals {x, y, ranT, fvar, ...} = globals
   5.577 -        val ClauseInfo {cdata = ClauseContext {lhs, rhs, cqs, ags, case_hyp, ...}, lGI, RCs, ...} = clausei
   5.578 -        val rhsC = Pattern.rewrite_term thy [(fvar, f)] [] rhs
   5.579 +  let
   5.580 +    val Globals {x, y, ranT, fvar, ...} = globals
   5.581 +    val ClauseInfo {cdata = ClauseContext {lhs, rhs, cqs, ags, case_hyp, ...}, lGI, RCs, ...} = clausei
   5.582 +    val rhsC = Pattern.rewrite_term thy [(fvar, f)] [] rhs
   5.583  
   5.584 -        val ih_intro_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ih_intro
   5.585 +    val ih_intro_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ih_intro
   5.586  
   5.587 -        fun prep_RC (RCInfo {llRI, RIvs, CCas, ...}) = (llRI RS ih_intro_case)
   5.588 -                                                            |> fold_rev (implies_intr o cprop_of) CCas
   5.589 -                                                            |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
   5.590 +    fun prep_RC (RCInfo {llRI, RIvs, CCas, ...}) = (llRI RS ih_intro_case)
   5.591 +      |> fold_rev (implies_intr o cprop_of) CCas
   5.592 +      |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
   5.593 +
   5.594 +    val existence = fold (curry op COMP o prep_RC) RCs lGI
   5.595  
   5.596 -        val existence = fold (curry op COMP o prep_RC) RCs lGI
   5.597 +    val P = cterm_of thy (mk_eq (y, rhsC))
   5.598 +    val G_lhs_y = assume (cterm_of thy (HOLogic.mk_Trueprop (G $ lhs $ y)))
   5.599  
   5.600 -        val P = cterm_of thy (mk_eq (y, rhsC))
   5.601 -        val G_lhs_y = assume (cterm_of thy (HOLogic.mk_Trueprop (G $ lhs $ y)))
   5.602 -
   5.603 -        val unique_clauses = map2 (mk_uniqueness_clause thy globals compat_store clausei) clauses rep_lemmas
   5.604 +    val unique_clauses =
   5.605 +      map2 (mk_uniqueness_clause thy globals compat_store clausei) clauses rep_lemmas
   5.606  
   5.607 -        val uniqueness = G_cases
   5.608 -                           |> forall_elim (cterm_of thy lhs)
   5.609 -                           |> forall_elim (cterm_of thy y)
   5.610 -                           |> forall_elim P
   5.611 -                           |> Thm.elim_implies G_lhs_y
   5.612 -                           |> fold Thm.elim_implies unique_clauses
   5.613 -                           |> implies_intr (cprop_of G_lhs_y)
   5.614 -                           |> forall_intr (cterm_of thy y)
   5.615 +    val uniqueness = G_cases
   5.616 +      |> forall_elim (cterm_of thy lhs)
   5.617 +      |> forall_elim (cterm_of thy y)
   5.618 +      |> forall_elim P
   5.619 +      |> Thm.elim_implies G_lhs_y
   5.620 +      |> fold Thm.elim_implies unique_clauses
   5.621 +      |> implies_intr (cprop_of G_lhs_y)
   5.622 +      |> forall_intr (cterm_of thy y)
   5.623  
   5.624 -        val P2 = cterm_of thy (lambda y (G $ lhs $ y)) (* P2 y := (lhs, y): G *)
   5.625 +    val P2 = cterm_of thy (lambda y (G $ lhs $ y)) (* P2 y := (lhs, y): G *)
   5.626  
   5.627 -        val exactly_one =
   5.628 -            ex1I |> instantiate' [SOME (ctyp_of thy ranT)] [SOME P2, SOME (cterm_of thy rhsC)]
   5.629 -                 |> curry (op COMP) existence
   5.630 -                 |> curry (op COMP) uniqueness
   5.631 -                 |> simplify (HOL_basic_ss addsimps [case_hyp RS sym])
   5.632 -                 |> implies_intr (cprop_of case_hyp)
   5.633 -                 |> fold_rev (implies_intr o cprop_of) ags
   5.634 -                 |> fold_rev forall_intr cqs
   5.635 +    val exactly_one =
   5.636 +      ex1I |> instantiate' [SOME (ctyp_of thy ranT)] [SOME P2, SOME (cterm_of thy rhsC)]
   5.637 +      |> curry (op COMP) existence
   5.638 +      |> curry (op COMP) uniqueness
   5.639 +      |> simplify (HOL_basic_ss addsimps [case_hyp RS sym])
   5.640 +      |> implies_intr (cprop_of case_hyp)
   5.641 +      |> fold_rev (implies_intr o cprop_of) ags
   5.642 +      |> fold_rev forall_intr cqs
   5.643  
   5.644 -        val function_value =
   5.645 -            existence
   5.646 -              |> implies_intr ihyp
   5.647 -              |> implies_intr (cprop_of case_hyp)
   5.648 -              |> forall_intr (cterm_of thy x)
   5.649 -              |> forall_elim (cterm_of thy lhs)
   5.650 -              |> curry (op RS) refl
   5.651 -    in
   5.652 -        (exactly_one, function_value)
   5.653 -    end
   5.654 -
   5.655 -
   5.656 +    val function_value =
   5.657 +      existence
   5.658 +      |> implies_intr ihyp
   5.659 +      |> implies_intr (cprop_of case_hyp)
   5.660 +      |> forall_intr (cterm_of thy x)
   5.661 +      |> forall_elim (cterm_of thy lhs)
   5.662 +      |> curry (op RS) refl
   5.663 +  in
   5.664 +    (exactly_one, function_value)
   5.665 +  end
   5.666  
   5.667  
   5.668  fun prove_stuff ctxt globals G f R clauses complete compat compat_store G_elim f_def =
   5.669 -    let
   5.670 -        val Globals {h, domT, ranT, x, ...} = globals
   5.671 -        val thy = ProofContext.theory_of ctxt
   5.672 +  let
   5.673 +    val Globals {h, domT, ranT, x, ...} = globals
   5.674 +    val thy = ProofContext.theory_of ctxt
   5.675  
   5.676 -        (* Inductive Hypothesis: !!z. (z,x):R ==> EX!y. (z,y):G *)
   5.677 -        val ihyp = Term.all domT $ Abs ("z", domT,
   5.678 -                                   Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
   5.679 -                                     HOLogic.mk_Trueprop (Const ("Ex1", (ranT --> boolT) --> boolT) $
   5.680 -                                                             Abs ("y", ranT, G $ Bound 1 $ Bound 0))))
   5.681 -                       |> cterm_of thy
   5.682 +    (* Inductive Hypothesis: !!z. (z,x):R ==> EX!y. (z,y):G *)
   5.683 +    val ihyp = Term.all domT $ Abs ("z", domT,
   5.684 +      Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
   5.685 +        HOLogic.mk_Trueprop (Const ("Ex1", (ranT --> boolT) --> boolT) $
   5.686 +          Abs ("y", ranT, G $ Bound 1 $ Bound 0))))
   5.687 +      |> cterm_of thy
   5.688  
   5.689 -        val ihyp_thm = assume ihyp |> Thm.forall_elim_vars 0
   5.690 -        val ih_intro = ihyp_thm RS (f_def RS ex1_implies_ex)
   5.691 -        val ih_elim = ihyp_thm RS (f_def RS ex1_implies_un)
   5.692 -                        |> instantiate' [] [NONE, SOME (cterm_of thy h)]
   5.693 +    val ihyp_thm = assume ihyp |> Thm.forall_elim_vars 0
   5.694 +    val ih_intro = ihyp_thm RS (f_def RS ex1_implies_ex)
   5.695 +    val ih_elim = ihyp_thm RS (f_def RS ex1_implies_un)
   5.696 +      |> instantiate' [] [NONE, SOME (cterm_of thy h)]
   5.697  
   5.698 -        val _ = trace_msg (K "Proving Replacement lemmas...")
   5.699 -        val repLemmas = map (mk_replacement_lemma thy h ih_elim) clauses
   5.700 +    val _ = trace_msg (K "Proving Replacement lemmas...")
   5.701 +    val repLemmas = map (mk_replacement_lemma thy h ih_elim) clauses
   5.702  
   5.703 -        val _ = trace_msg (K "Proving cases for unique existence...")
   5.704 -        val (ex1s, values) =
   5.705 -            split_list (map (mk_uniqueness_case thy globals G f ihyp ih_intro G_elim compat_store clauses repLemmas) clauses)
   5.706 +    val _ = trace_msg (K "Proving cases for unique existence...")
   5.707 +    val (ex1s, values) =
   5.708 +      split_list (map (mk_uniqueness_case thy globals G f ihyp ih_intro G_elim compat_store clauses repLemmas) clauses)
   5.709  
   5.710 -        val _ = trace_msg (K "Proving: Graph is a function")
   5.711 -        val graph_is_function = complete
   5.712 -                                  |> Thm.forall_elim_vars 0
   5.713 -                                  |> fold (curry op COMP) ex1s
   5.714 -                                  |> implies_intr (ihyp)
   5.715 -                                  |> implies_intr (cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ x)))
   5.716 -                                  |> forall_intr (cterm_of thy x)
   5.717 -                                  |> (fn it => Drule.compose_single (it, 2, acc_induct_rule)) (* "EX! y. (?x,y):G" *)
   5.718 -                                  |> (fn it => fold (forall_intr o cterm_of thy o Var) (Term.add_vars (prop_of it) []) it)
   5.719 +    val _ = trace_msg (K "Proving: Graph is a function")
   5.720 +    val graph_is_function = complete
   5.721 +      |> Thm.forall_elim_vars 0
   5.722 +      |> fold (curry op COMP) ex1s
   5.723 +      |> implies_intr (ihyp)
   5.724 +      |> implies_intr (cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ x)))
   5.725 +      |> forall_intr (cterm_of thy x)
   5.726 +      |> (fn it => Drule.compose_single (it, 2, acc_induct_rule)) (* "EX! y. (?x,y):G" *)
   5.727 +      |> (fn it => fold (forall_intr o cterm_of thy o Var) (Term.add_vars (prop_of it) []) it)
   5.728  
   5.729 -        val goalstate =  Conjunction.intr graph_is_function complete
   5.730 -                          |> Thm.close_derivation
   5.731 -                          |> Goal.protect
   5.732 -                          |> fold_rev (implies_intr o cprop_of) compat
   5.733 -                          |> implies_intr (cprop_of complete)
   5.734 -    in
   5.735 -      (goalstate, values)
   5.736 -    end
   5.737 +    val goalstate =  Conjunction.intr graph_is_function complete
   5.738 +      |> Thm.close_derivation
   5.739 +      |> Goal.protect
   5.740 +      |> fold_rev (implies_intr o cprop_of) compat
   5.741 +      |> implies_intr (cprop_of complete)
   5.742 +  in
   5.743 +    (goalstate, values)
   5.744 +  end
   5.745  
   5.746  (* wrapper -- restores quantifiers in rule specifications *)
   5.747  fun inductive_def (binding as ((R, T), _)) intrs lthy =
   5.748 @@ -483,7 +458,7 @@
   5.749            forall_intr_rename (n, cert (Var (varmap (n, T), T)))) qs thm
   5.750        end
   5.751    in
   5.752 -      ((Rdef, map2 requantify intrs intrs_gen, forall_intr_vars elim_gen, induct), lthy)
   5.753 +    ((Rdef, map2 requantify intrs intrs_gen, forall_intr_vars elim_gen, induct), lthy)
   5.754    end
   5.755  
   5.756  fun define_graph Gname fvar domT ranT clauses RCss lthy =
   5.757 @@ -544,33 +519,30 @@
   5.758  
   5.759  
   5.760  fun fix_globals domT ranT fvar ctxt =
   5.761 -    let
   5.762 -      val ([h, y, x, z, a, D, P, Pbool],ctxt') =
   5.763 -          Variable.variant_fixes ["h_fd", "y_fd", "x_fd", "z_fd", "a_fd", "D_fd", "P_fd", "Pb_fd"] ctxt
   5.764 -    in
   5.765 -      (Globals {h = Free (h, domT --> ranT),
   5.766 -                y = Free (y, ranT),
   5.767 -                x = Free (x, domT),
   5.768 -                z = Free (z, domT),
   5.769 -                a = Free (a, domT),
   5.770 -                D = Free (D, domT --> boolT),
   5.771 -                P = Free (P, domT --> boolT),
   5.772 -                Pbool = Free (Pbool, boolT),
   5.773 -                fvar = fvar,
   5.774 -                domT = domT,
   5.775 -                ranT = ranT
   5.776 -               },
   5.777 -       ctxt')
   5.778 -    end
   5.779 -
   5.780 -
   5.781 +  let
   5.782 +    val ([h, y, x, z, a, D, P, Pbool],ctxt') = Variable.variant_fixes
   5.783 +      ["h_fd", "y_fd", "x_fd", "z_fd", "a_fd", "D_fd", "P_fd", "Pb_fd"] ctxt
   5.784 +  in
   5.785 +    (Globals {h = Free (h, domT --> ranT),
   5.786 +      y = Free (y, ranT),
   5.787 +      x = Free (x, domT),
   5.788 +      z = Free (z, domT),
   5.789 +      a = Free (a, domT),
   5.790 +      D = Free (D, domT --> boolT),
   5.791 +      P = Free (P, domT --> boolT),
   5.792 +      Pbool = Free (Pbool, boolT),
   5.793 +      fvar = fvar,
   5.794 +      domT = domT,
   5.795 +      ranT = ranT},
   5.796 +    ctxt')
   5.797 +  end
   5.798  
   5.799  fun inst_RC thy fvar f (rcfix, rcassm, rcarg) =
   5.800 -    let
   5.801 -      fun inst_term t = subst_bound(f, abstract_over (fvar, t))
   5.802 -    in
   5.803 -      (rcfix, map (assume o cterm_of thy o inst_term o prop_of) rcassm, inst_term rcarg)
   5.804 -    end
   5.805 +  let
   5.806 +    fun inst_term t = subst_bound(f, abstract_over (fvar, t))
   5.807 +  in
   5.808 +    (rcfix, map (assume o cterm_of thy o inst_term o prop_of) rcassm, inst_term rcarg)
   5.809 +  end
   5.810  
   5.811  
   5.812  
   5.813 @@ -579,27 +551,27 @@
   5.814   **********************************************************)
   5.815  
   5.816  fun mk_psimps thy globals R clauses valthms f_iff graph_is_function =
   5.817 -    let
   5.818 -      val Globals {domT, z, ...} = globals
   5.819 +  let
   5.820 +    val Globals {domT, z, ...} = globals
   5.821  
   5.822 -      fun mk_psimp (ClauseInfo {qglr = (oqs, _, _, _), cdata = ClauseContext {cqs, lhs, ags, ...}, ...}) valthm =
   5.823 -          let
   5.824 -            val lhs_acc = cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ lhs)) (* "acc R lhs" *)
   5.825 -            val z_smaller = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ lhs)) (* "R z lhs" *)
   5.826 -          in
   5.827 -            ((assume z_smaller) RS ((assume lhs_acc) RS acc_downward))
   5.828 -              |> (fn it => it COMP graph_is_function)
   5.829 -              |> implies_intr z_smaller
   5.830 -              |> forall_intr (cterm_of thy z)
   5.831 -              |> (fn it => it COMP valthm)
   5.832 -              |> implies_intr lhs_acc
   5.833 -              |> asm_simplify (HOL_basic_ss addsimps [f_iff])
   5.834 -              |> fold_rev (implies_intr o cprop_of) ags
   5.835 -              |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
   5.836 -          end
   5.837 -    in
   5.838 -      map2 mk_psimp clauses valthms
   5.839 -    end
   5.840 +    fun mk_psimp (ClauseInfo {qglr = (oqs, _, _, _), cdata = ClauseContext {cqs, lhs, ags, ...}, ...}) valthm =
   5.841 +      let
   5.842 +        val lhs_acc = cterm_of thy (HOLogic.mk_Trueprop (mk_acc domT R $ lhs)) (* "acc R lhs" *)
   5.843 +        val z_smaller = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ lhs)) (* "R z lhs" *)
   5.844 +      in
   5.845 +        ((assume z_smaller) RS ((assume lhs_acc) RS acc_downward))
   5.846 +        |> (fn it => it COMP graph_is_function)
   5.847 +        |> implies_intr z_smaller
   5.848 +        |> forall_intr (cterm_of thy z)
   5.849 +        |> (fn it => it COMP valthm)
   5.850 +        |> implies_intr lhs_acc
   5.851 +        |> asm_simplify (HOL_basic_ss addsimps [f_iff])
   5.852 +        |> fold_rev (implies_intr o cprop_of) ags
   5.853 +        |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
   5.854 +      end
   5.855 +  in
   5.856 +    map2 mk_psimp clauses valthms
   5.857 +  end
   5.858  
   5.859  
   5.860  (** Induction rule **)
   5.861 @@ -609,232 +581,236 @@
   5.862  
   5.863  
   5.864  fun mk_partial_induct_rule thy globals R complete_thm clauses =
   5.865 -    let
   5.866 -      val Globals {domT, x, z, a, P, D, ...} = globals
   5.867 -      val acc_R = mk_acc domT R
   5.868 +  let
   5.869 +    val Globals {domT, x, z, a, P, D, ...} = globals
   5.870 +    val acc_R = mk_acc domT R
   5.871  
   5.872 -      val x_D = assume (cterm_of thy (HOLogic.mk_Trueprop (D $ x)))
   5.873 -      val a_D = cterm_of thy (HOLogic.mk_Trueprop (D $ a))
   5.874 +    val x_D = assume (cterm_of thy (HOLogic.mk_Trueprop (D $ x)))
   5.875 +    val a_D = cterm_of thy (HOLogic.mk_Trueprop (D $ a))
   5.876  
   5.877 -      val D_subset = cterm_of thy (Logic.all x
   5.878 -        (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x), HOLogic.mk_Trueprop (acc_R $ x))))
   5.879 +    val D_subset = cterm_of thy (Logic.all x
   5.880 +      (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x), HOLogic.mk_Trueprop (acc_R $ x))))
   5.881  
   5.882 -      val D_dcl = (* "!!x z. [| x: D; (z,x):R |] ==> z:D" *)
   5.883 -                    Logic.all x
   5.884 -                    (Logic.all z (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x),
   5.885 -                                                    Logic.mk_implies (HOLogic.mk_Trueprop (R $ z $ x),
   5.886 -                                                                      HOLogic.mk_Trueprop (D $ z)))))
   5.887 -                    |> cterm_of thy
   5.888 -
   5.889 +    val D_dcl = (* "!!x z. [| x: D; (z,x):R |] ==> z:D" *)
   5.890 +      Logic.all x (Logic.all z (Logic.mk_implies (HOLogic.mk_Trueprop (D $ x),
   5.891 +        Logic.mk_implies (HOLogic.mk_Trueprop (R $ z $ x),
   5.892 +          HOLogic.mk_Trueprop (D $ z)))))
   5.893 +      |> cterm_of thy
   5.894  
   5.895 -  (* Inductive Hypothesis: !!z. (z,x):R ==> P z *)
   5.896 -      val ihyp = Term.all domT $ Abs ("z", domT,
   5.897 -               Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
   5.898 -                 HOLogic.mk_Trueprop (P $ Bound 0)))
   5.899 -           |> cterm_of thy
   5.900 +    (* Inductive Hypothesis: !!z. (z,x):R ==> P z *)
   5.901 +    val ihyp = Term.all domT $ Abs ("z", domT,
   5.902 +      Logic.mk_implies (HOLogic.mk_Trueprop (R $ Bound 0 $ x),
   5.903 +        HOLogic.mk_Trueprop (P $ Bound 0)))
   5.904 +      |> cterm_of thy
   5.905  
   5.906 -      val aihyp = assume ihyp
   5.907 +    val aihyp = assume ihyp
   5.908  
   5.909 -  fun prove_case clause =
   5.910 +    fun prove_case clause =
   5.911        let
   5.912 -    val ClauseInfo {cdata = ClauseContext {ctxt, qs, cqs, ags, gs, lhs, case_hyp, ...}, RCs,
   5.913 -                    qglr = (oqs, _, _, _), ...} = clause
   5.914 +        val ClauseInfo {cdata = ClauseContext {ctxt, qs, cqs, ags, gs, lhs, case_hyp, ...},
   5.915 +          RCs, qglr = (oqs, _, _, _), ...} = clause
   5.916  
   5.917 -    val case_hyp_conv = K (case_hyp RS eq_reflection)
   5.918 -    local open Conv in
   5.919 -    val lhs_D = fconv_rule (arg_conv (arg_conv (case_hyp_conv))) x_D
   5.920 -    val sih = fconv_rule (More_Conv.binder_conv (K (arg1_conv (arg_conv (arg_conv case_hyp_conv)))) ctxt) aihyp
   5.921 -    end
   5.922 +        val case_hyp_conv = K (case_hyp RS eq_reflection)
   5.923 +        local open Conv in
   5.924 +          val lhs_D = fconv_rule (arg_conv (arg_conv (case_hyp_conv))) x_D
   5.925 +          val sih =
   5.926 +            fconv_rule (More_Conv.binder_conv
   5.927 +              (K (arg1_conv (arg_conv (arg_conv case_hyp_conv)))) ctxt) aihyp
   5.928 +        end
   5.929  
   5.930 -    fun mk_Prec (RCInfo {llRI, RIvs, CCas, rcarg, ...}) =
   5.931 -        sih |> forall_elim (cterm_of thy rcarg)
   5.932 -            |> Thm.elim_implies llRI
   5.933 -            |> fold_rev (implies_intr o cprop_of) CCas
   5.934 -            |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
   5.935 +        fun mk_Prec (RCInfo {llRI, RIvs, CCas, rcarg, ...}) = sih
   5.936 +          |> forall_elim (cterm_of thy rcarg)
   5.937 +          |> Thm.elim_implies llRI
   5.938 +          |> fold_rev (implies_intr o cprop_of) CCas
   5.939 +          |> fold_rev (forall_intr o cterm_of thy o Free) RIvs
   5.940  
   5.941 -    val P_recs = map mk_Prec RCs   (*  [P rec1, P rec2, ... ]  *)
   5.942 +        val P_recs = map mk_Prec RCs   (*  [P rec1, P rec2, ... ]  *)
   5.943  
   5.944 -    val step = HOLogic.mk_Trueprop (P $ lhs)
   5.945 -            |> fold_rev (curry Logic.mk_implies o prop_of) P_recs
   5.946 -            |> fold_rev (curry Logic.mk_implies) gs
   5.947 -            |> curry Logic.mk_implies (HOLogic.mk_Trueprop (D $ lhs))
   5.948 -            |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
   5.949 -            |> cterm_of thy
   5.950 +        val step = HOLogic.mk_Trueprop (P $ lhs)
   5.951 +          |> fold_rev (curry Logic.mk_implies o prop_of) P_recs
   5.952 +          |> fold_rev (curry Logic.mk_implies) gs
   5.953 +          |> curry Logic.mk_implies (HOLogic.mk_Trueprop (D $ lhs))
   5.954 +          |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
   5.955 +          |> cterm_of thy
   5.956  
   5.957 -    val P_lhs = assume step
   5.958 -           |> fold forall_elim cqs
   5.959 -           |> Thm.elim_implies lhs_D
   5.960 -           |> fold Thm.elim_implies ags
   5.961 -           |> fold Thm.elim_implies P_recs
   5.962 +        val P_lhs = assume step
   5.963 +          |> fold forall_elim cqs
   5.964 +          |> Thm.elim_implies lhs_D
   5.965 +          |> fold Thm.elim_implies ags
   5.966 +          |> fold Thm.elim_implies P_recs
   5.967  
   5.968 -    val res = cterm_of thy (HOLogic.mk_Trueprop (P $ x))
   5.969 -           |> Conv.arg_conv (Conv.arg_conv case_hyp_conv)
   5.970 -           |> symmetric (* P lhs == P x *)
   5.971 -           |> (fn eql => equal_elim eql P_lhs) (* "P x" *)
   5.972 -           |> implies_intr (cprop_of case_hyp)
   5.973 -           |> fold_rev (implies_intr o cprop_of) ags
   5.974 -           |> fold_rev forall_intr cqs
   5.975 +        val res = cterm_of thy (HOLogic.mk_Trueprop (P $ x))
   5.976 +          |> Conv.arg_conv (Conv.arg_conv case_hyp_conv)
   5.977 +          |> symmetric (* P lhs == P x *)
   5.978 +          |> (fn eql => equal_elim eql P_lhs) (* "P x" *)
   5.979 +          |> implies_intr (cprop_of case_hyp)
   5.980 +          |> fold_rev (implies_intr o cprop_of) ags
   5.981 +          |> fold_rev forall_intr cqs
   5.982        in
   5.983          (res, step)
   5.984        end
   5.985  
   5.986 -  val (cases, steps) = split_list (map prove_case clauses)
   5.987 +    val (cases, steps) = split_list (map prove_case clauses)
   5.988  
   5.989 -  val istep = complete_thm
   5.990 -                |> Thm.forall_elim_vars 0
   5.991 -                |> fold (curry op COMP) cases (*  P x  *)
   5.992 -                |> implies_intr ihyp
   5.993 -                |> implies_intr (cprop_of x_D)
   5.994 -                |> forall_intr (cterm_of thy x)
   5.995 +    val istep = complete_thm
   5.996 +      |> Thm.forall_elim_vars 0
   5.997 +      |> fold (curry op COMP) cases (*  P x  *)
   5.998 +      |> implies_intr ihyp
   5.999 +      |> implies_intr (cprop_of x_D)
  5.1000 +      |> forall_intr (cterm_of thy x)
  5.1001  
  5.1002 -  val subset_induct_rule =
  5.1003 +    val subset_induct_rule =
  5.1004        acc_subset_induct
  5.1005 -        |> (curry op COMP) (assume D_subset)
  5.1006 -        |> (curry op COMP) (assume D_dcl)
  5.1007 -        |> (curry op COMP) (assume a_D)
  5.1008 -        |> (curry op COMP) istep
  5.1009 -        |> fold_rev implies_intr steps
  5.1010 -        |> implies_intr a_D
  5.1011 -        |> implies_intr D_dcl
  5.1012 -        |> implies_intr D_subset
  5.1013 +      |> (curry op COMP) (assume D_subset)
  5.1014 +      |> (curry op COMP) (assume D_dcl)
  5.1015 +      |> (curry op COMP) (assume a_D)
  5.1016 +      |> (curry op COMP) istep
  5.1017 +      |> fold_rev implies_intr steps
  5.1018 +      |> implies_intr a_D
  5.1019 +      |> implies_intr D_dcl
  5.1020 +      |> implies_intr D_subset
  5.1021  
  5.1022 -  val simple_induct_rule =
  5.1023 +    val simple_induct_rule =
  5.1024        subset_induct_rule
  5.1025 -        |> forall_intr (cterm_of thy D)
  5.1026 -        |> forall_elim (cterm_of thy acc_R)
  5.1027 -        |> assume_tac 1 |> Seq.hd
  5.1028 -        |> (curry op COMP) (acc_downward
  5.1029 -                              |> (instantiate' [SOME (ctyp_of thy domT)]
  5.1030 -                                               (map (SOME o cterm_of thy) [R, x, z]))
  5.1031 -                              |> forall_intr (cterm_of thy z)
  5.1032 -                              |> forall_intr (cterm_of thy x))
  5.1033 -        |> forall_intr (cterm_of thy a)
  5.1034 -        |> forall_intr (cterm_of thy P)
  5.1035 -    in
  5.1036 -      simple_induct_rule
  5.1037 -    end
  5.1038 +      |> forall_intr (cterm_of thy D)
  5.1039 +      |> forall_elim (cterm_of thy acc_R)
  5.1040 +      |> assume_tac 1 |> Seq.hd
  5.1041 +      |> (curry op COMP) (acc_downward
  5.1042 +        |> (instantiate' [SOME (ctyp_of thy domT)]
  5.1043 +             (map (SOME o cterm_of thy) [R, x, z]))
  5.1044 +        |> forall_intr (cterm_of thy z)
  5.1045 +        |> forall_intr (cterm_of thy x))
  5.1046 +      |> forall_intr (cterm_of thy a)
  5.1047 +      |> forall_intr (cterm_of thy P)
  5.1048 +  in
  5.1049 +    simple_induct_rule
  5.1050 +  end
  5.1051  
  5.1052  
  5.1053 -
  5.1054 -(* FIXME: This should probably use fixed goals, to be more reliable and faster *)
  5.1055 +(* FIXME: broken by design *)
  5.1056  fun mk_domain_intro ctxt (Globals {domT, ...}) R R_cases clause =
  5.1057 -    let
  5.1058 -      val thy = ProofContext.theory_of ctxt
  5.1059 -      val ClauseInfo {cdata = ClauseContext {gs, lhs, cqs, ...},
  5.1060 -                      qglr = (oqs, _, _, _), ...} = clause
  5.1061 -      val goal = HOLogic.mk_Trueprop (mk_acc domT R $ lhs)
  5.1062 -                          |> fold_rev (curry Logic.mk_implies) gs
  5.1063 -                          |> cterm_of thy
  5.1064 -    in
  5.1065 -      Goal.init goal
  5.1066 -      |> (SINGLE (resolve_tac [accI] 1)) |> the
  5.1067 -      |> (SINGLE (eresolve_tac [Thm.forall_elim_vars 0 R_cases] 1))  |> the
  5.1068 -      |> (SINGLE (auto_tac (clasimpset_of ctxt))) |> the
  5.1069 -      |> Goal.conclude
  5.1070 -      |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  5.1071 -    end
  5.1072 +  let
  5.1073 +    val thy = ProofContext.theory_of ctxt
  5.1074 +    val ClauseInfo {cdata = ClauseContext {gs, lhs, cqs, ...},
  5.1075 +      qglr = (oqs, _, _, _), ...} = clause
  5.1076 +    val goal = HOLogic.mk_Trueprop (mk_acc domT R $ lhs)
  5.1077 +      |> fold_rev (curry Logic.mk_implies) gs
  5.1078 +      |> cterm_of thy
  5.1079 +  in
  5.1080 +    Goal.init goal
  5.1081 +    |> (SINGLE (resolve_tac [accI] 1)) |> the
  5.1082 +    |> (SINGLE (eresolve_tac [Thm.forall_elim_vars 0 R_cases] 1))  |> the
  5.1083 +    |> (SINGLE (auto_tac (clasimpset_of ctxt))) |> the
  5.1084 +    |> Goal.conclude
  5.1085 +    |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  5.1086 +  end
  5.1087  
  5.1088  
  5.1089  
  5.1090  (** Termination rule **)
  5.1091  
  5.1092 -val wf_induct_rule = @{thm Wellfounded.wfP_induct_rule};
  5.1093 -val wf_in_rel = @{thm FunDef.wf_in_rel};
  5.1094 -val in_rel_def = @{thm FunDef.in_rel_def};
  5.1095 +val wf_induct_rule = @{thm Wellfounded.wfP_induct_rule}
  5.1096 +val wf_in_rel = @{thm FunDef.wf_in_rel}
  5.1097 +val in_rel_def = @{thm FunDef.in_rel_def}
  5.1098  
  5.1099  fun mk_nest_term_case thy globals R' ihyp clause =
  5.1100 -    let
  5.1101 -      val Globals {z, ...} = globals
  5.1102 -      val ClauseInfo {cdata = ClauseContext {qs, cqs, ags, lhs, case_hyp, ...},tree,
  5.1103 -                      qglr=(oqs, _, _, _), ...} = clause
  5.1104 +  let
  5.1105 +    val Globals {z, ...} = globals
  5.1106 +    val ClauseInfo {cdata = ClauseContext {qs, cqs, ags, lhs, case_hyp, ...}, tree,
  5.1107 +      qglr=(oqs, _, _, _), ...} = clause
  5.1108  
  5.1109 -      val ih_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ihyp
  5.1110 +    val ih_case = full_simplify (HOL_basic_ss addsimps [case_hyp]) ihyp
  5.1111  
  5.1112 -      fun step (fixes, assumes) (_ $ arg) u (sub,(hyps,thms)) =
  5.1113 -          let
  5.1114 -            val used = map (fn (ctx,thm) => Function_Ctx_Tree.export_thm thy ctx thm) (u @ sub)
  5.1115 +    fun step (fixes, assumes) (_ $ arg) u (sub,(hyps,thms)) =
  5.1116 +      let
  5.1117 +        val used = (u @ sub)
  5.1118 +          |> map (fn (ctx,thm) => Function_Ctx_Tree.export_thm thy ctx thm)
  5.1119  
  5.1120 -            val hyp = HOLogic.mk_Trueprop (R' $ arg $ lhs)
  5.1121 -                      |> fold_rev (curry Logic.mk_implies o prop_of) used (* additional hyps *)
  5.1122 -                      |> Function_Ctx_Tree.export_term (fixes, assumes)
  5.1123 -                      |> fold_rev (curry Logic.mk_implies o prop_of) ags
  5.1124 -                      |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
  5.1125 -                      |> cterm_of thy
  5.1126 +        val hyp = HOLogic.mk_Trueprop (R' $ arg $ lhs)
  5.1127 +          |> fold_rev (curry Logic.mk_implies o prop_of) used (* additional hyps *)
  5.1128 +          |> Function_Ctx_Tree.export_term (fixes, assumes)
  5.1129 +          |> fold_rev (curry Logic.mk_implies o prop_of) ags
  5.1130 +          |> fold_rev mk_forall_rename (map fst oqs ~~ qs)
  5.1131 +          |> cterm_of thy
  5.1132  
  5.1133 -            val thm = assume hyp
  5.1134 -                      |> fold forall_elim cqs
  5.1135 -                      |> fold Thm.elim_implies ags
  5.1136 -                      |> Function_Ctx_Tree.import_thm thy (fixes, assumes)
  5.1137 -                      |> fold Thm.elim_implies used (*  "(arg, lhs) : R'"  *)
  5.1138 +        val thm = assume hyp
  5.1139 +          |> fold forall_elim cqs
  5.1140 +          |> fold Thm.elim_implies ags
  5.1141 +          |> Function_Ctx_Tree.import_thm thy (fixes, assumes)
  5.1142 +          |> fold Thm.elim_implies used (*  "(arg, lhs) : R'"  *)
  5.1143  
  5.1144 -            val z_eq_arg = assume (cterm_of thy (HOLogic.mk_Trueprop (mk_eq (z, arg))))
  5.1145 +        val z_eq_arg = HOLogic.mk_Trueprop (mk_eq (z, arg))
  5.1146 +          |> cterm_of thy |> assume
  5.1147  
  5.1148 -            val acc = thm COMP ih_case
  5.1149 -            val z_acc_local = acc
  5.1150 -            |> Conv.fconv_rule (Conv.arg_conv (Conv.arg_conv (K (symmetric (z_eq_arg RS eq_reflection)))))
  5.1151 +        val acc = thm COMP ih_case
  5.1152 +        val z_acc_local = acc
  5.1153 +          |> Conv.fconv_rule (Conv.arg_conv (Conv.arg_conv (K (symmetric (z_eq_arg RS eq_reflection)))))
  5.1154  
  5.1155 -            val ethm = z_acc_local
  5.1156 -                         |> Function_Ctx_Tree.export_thm thy (fixes,
  5.1157 -                                                          z_eq_arg :: case_hyp :: ags @ assumes)
  5.1158 -                         |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  5.1159 +        val ethm = z_acc_local
  5.1160 +          |> Function_Ctx_Tree.export_thm thy (fixes,
  5.1161 +               z_eq_arg :: case_hyp :: ags @ assumes)
  5.1162 +          |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  5.1163  
  5.1164 -            val sub' = sub @ [(([],[]), acc)]
  5.1165 -          in
  5.1166 -            (sub', (hyp :: hyps, ethm :: thms))
  5.1167 -          end
  5.1168 -        | step _ _ _ _ = raise Match
  5.1169 -    in
  5.1170 -      Function_Ctx_Tree.traverse_tree step tree
  5.1171 -    end
  5.1172 +        val sub' = sub @ [(([],[]), acc)]
  5.1173 +      in
  5.1174 +        (sub', (hyp :: hyps, ethm :: thms))
  5.1175 +      end
  5.1176 +      | step _ _ _ _ = raise Match
  5.1177 +  in
  5.1178 +    Function_Ctx_Tree.traverse_tree step tree
  5.1179 +  end
  5.1180  
  5.1181  
  5.1182  fun mk_nest_term_rule thy globals R R_cases clauses =
  5.1183 -    let
  5.1184 -      val Globals { domT, x, z, ... } = globals
  5.1185 -      val acc_R = mk_acc domT R
  5.1186 +  let
  5.1187 +    val Globals { domT, x, z, ... } = globals
  5.1188 +    val acc_R = mk_acc domT R
  5.1189  
  5.1190 -      val R' = Free ("R", fastype_of R)
  5.1191 +    val R' = Free ("R", fastype_of R)
  5.1192  
  5.1193 -      val Rrel = Free ("R", HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)))
  5.1194 -      val inrel_R = Const (@{const_name FunDef.in_rel}, HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)) --> fastype_of R) $ Rrel
  5.1195 +    val Rrel = Free ("R", HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)))
  5.1196 +    val inrel_R = Const (@{const_name FunDef.in_rel},
  5.1197 +      HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)) --> fastype_of R) $ Rrel
  5.1198  
  5.1199 -      val wfR' = cterm_of thy (HOLogic.mk_Trueprop (Const (@{const_name Wellfounded.wfP}, (domT --> domT --> boolT) --> boolT) $ R')) (* "wf R'" *)
  5.1200 +    val wfR' = HOLogic.mk_Trueprop (Const (@{const_name Wellfounded.wfP},
  5.1201 +      (domT --> domT --> boolT) --> boolT) $ R')
  5.1202 +      |> cterm_of thy (* "wf R'" *)
  5.1203  
  5.1204 -      (* Inductive Hypothesis: !!z. (z,x):R' ==> z : acc R *)
  5.1205 -      val ihyp = Term.all domT $ Abs ("z", domT,
  5.1206 -                                 Logic.mk_implies (HOLogic.mk_Trueprop (R' $ Bound 0 $ x),
  5.1207 -                                   HOLogic.mk_Trueprop (acc_R $ Bound 0)))
  5.1208 -                     |> cterm_of thy
  5.1209 +    (* Inductive Hypothesis: !!z. (z,x):R' ==> z : acc R *)
  5.1210 +    val ihyp = Term.all domT $ Abs ("z", domT,
  5.1211 +      Logic.mk_implies (HOLogic.mk_Trueprop (R' $ Bound 0 $ x),
  5.1212 +        HOLogic.mk_Trueprop (acc_R $ Bound 0)))
  5.1213 +      |> cterm_of thy
  5.1214  
  5.1215 -      val ihyp_a = assume ihyp |> Thm.forall_elim_vars 0
  5.1216 +    val ihyp_a = assume ihyp |> Thm.forall_elim_vars 0
  5.1217  
  5.1218 -      val R_z_x = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ x))
  5.1219 +    val R_z_x = cterm_of thy (HOLogic.mk_Trueprop (R $ z $ x))
  5.1220  
  5.1221 -      val (hyps,cases) = fold (mk_nest_term_case thy globals R' ihyp_a) clauses ([],[])
  5.1222 -    in
  5.1223 -      R_cases
  5.1224 -        |> forall_elim (cterm_of thy z)
  5.1225 -        |> forall_elim (cterm_of thy x)
  5.1226 -        |> forall_elim (cterm_of thy (acc_R $ z))
  5.1227 -        |> curry op COMP (assume R_z_x)
  5.1228 -        |> fold_rev (curry op COMP) cases
  5.1229 -        |> implies_intr R_z_x
  5.1230 -        |> forall_intr (cterm_of thy z)
  5.1231 -        |> (fn it => it COMP accI)
  5.1232 -        |> implies_intr ihyp
  5.1233 -        |> forall_intr (cterm_of thy x)
  5.1234 -        |> (fn it => Drule.compose_single(it,2,wf_induct_rule))
  5.1235 -        |> curry op RS (assume wfR')
  5.1236 -        |> forall_intr_vars
  5.1237 -        |> (fn it => it COMP allI)
  5.1238 -        |> fold implies_intr hyps
  5.1239 -        |> implies_intr wfR'
  5.1240 -        |> forall_intr (cterm_of thy R')
  5.1241 -        |> forall_elim (cterm_of thy (inrel_R))
  5.1242 -        |> curry op RS wf_in_rel
  5.1243 -        |> full_simplify (HOL_basic_ss addsimps [in_rel_def])
  5.1244 -        |> forall_intr (cterm_of thy Rrel)
  5.1245 -    end
  5.1246 +    val (hyps, cases) = fold (mk_nest_term_case thy globals R' ihyp_a) clauses ([], [])
  5.1247 +  in
  5.1248 +    R_cases
  5.1249 +    |> forall_elim (cterm_of thy z)
  5.1250 +    |> forall_elim (cterm_of thy x)
  5.1251 +    |> forall_elim (cterm_of thy (acc_R $ z))
  5.1252 +    |> curry op COMP (assume R_z_x)
  5.1253 +    |> fold_rev (curry op COMP) cases
  5.1254 +    |> implies_intr R_z_x
  5.1255 +    |> forall_intr (cterm_of thy z)
  5.1256 +    |> (fn it => it COMP accI)
  5.1257 +    |> implies_intr ihyp
  5.1258 +    |> forall_intr (cterm_of thy x)
  5.1259 +    |> (fn it => Drule.compose_single(it,2,wf_induct_rule))
  5.1260 +    |> curry op RS (assume wfR')
  5.1261 +    |> forall_intr_vars
  5.1262 +    |> (fn it => it COMP allI)
  5.1263 +    |> fold implies_intr hyps
  5.1264 +    |> implies_intr wfR'
  5.1265 +    |> forall_intr (cterm_of thy R')
  5.1266 +    |> forall_elim (cterm_of thy (inrel_R))
  5.1267 +    |> curry op RS wf_in_rel
  5.1268 +    |> full_simplify (HOL_basic_ss addsimps [in_rel_def])
  5.1269 +    |> forall_intr (cterm_of thy Rrel)
  5.1270 +  end
  5.1271  
  5.1272  
  5.1273  
  5.1274 @@ -846,135 +822,150 @@
  5.1275   * - Splitting is not configured automatically: Problems with case?
  5.1276   *)
  5.1277  fun mk_trsimps octxt globals f G R f_def R_cases G_induct clauses psimps =
  5.1278 -    let
  5.1279 -      val Globals {domT, ranT, fvar, ...} = globals
  5.1280 +  let
  5.1281 +    val Globals {domT, ranT, fvar, ...} = globals
  5.1282  
  5.1283 -      val R_cases = Thm.forall_elim_vars 0 R_cases (* FIXME: Should be already in standard form. *)
  5.1284 +    val R_cases = Thm.forall_elim_vars 0 R_cases (* FIXME: Should be already in standard form. *)
  5.1285  
  5.1286 -      val graph_implies_dom = (* "G ?x ?y ==> dom ?x"  *)
  5.1287 -          Goal.prove octxt ["x", "y"] [HOLogic.mk_Trueprop (G $ Free ("x", domT) $ Free ("y", ranT))]
  5.1288 -                     (HOLogic.mk_Trueprop (mk_acc domT R $ Free ("x", domT)))
  5.1289 -                     (fn {prems=[a], ...} =>
  5.1290 -                         ((rtac (G_induct OF [a]))
  5.1291 -                            THEN_ALL_NEW (rtac accI)
  5.1292 -                            THEN_ALL_NEW (etac R_cases)
  5.1293 -                            THEN_ALL_NEW (asm_full_simp_tac (simpset_of octxt))) 1)
  5.1294 +    val graph_implies_dom = (* "G ?x ?y ==> dom ?x"  *)
  5.1295 +      Goal.prove octxt ["x", "y"] [HOLogic.mk_Trueprop (G $ Free ("x", domT) $ Free ("y", ranT))]
  5.1296 +        (HOLogic.mk_Trueprop (mk_acc domT R $ Free ("x", domT)))
  5.1297 +        (fn {prems=[a], ...} =>
  5.1298 +          ((rtac (G_induct OF [a]))
  5.1299 +          THEN_ALL_NEW rtac accI
  5.1300 +          THEN_ALL_NEW etac R_cases
  5.1301 +          THEN_ALL_NEW asm_full_simp_tac (simpset_of octxt)) 1)
  5.1302  
  5.1303 -      val default_thm = (forall_intr_vars graph_implies_dom) COMP (f_def COMP fundef_default_value)
  5.1304 +    val default_thm =
  5.1305 +      forall_intr_vars graph_implies_dom COMP (f_def COMP fundef_default_value)
  5.1306  
  5.1307 -      fun mk_trsimp clause psimp =
  5.1308 -          let
  5.1309 -            val ClauseInfo {qglr = (oqs, _, _, _), cdata = ClauseContext {ctxt, cqs, gs, lhs, rhs, ...}, ...} = clause
  5.1310 -            val thy = ProofContext.theory_of ctxt
  5.1311 -            val rhs_f = Pattern.rewrite_term thy [(fvar, f)] [] rhs
  5.1312 +    fun mk_trsimp clause psimp =
  5.1313 +      let
  5.1314 +        val ClauseInfo {qglr = (oqs, _, _, _), cdata =
  5.1315 +          ClauseContext {ctxt, cqs, gs, lhs, rhs, ...}, ...} = clause
  5.1316 +        val thy = ProofContext.theory_of ctxt
  5.1317 +        val rhs_f = Pattern.rewrite_term thy [(fvar, f)] [] rhs
  5.1318  
  5.1319 -            val trsimp = Logic.list_implies(gs, HOLogic.mk_Trueprop (HOLogic.mk_eq(f $ lhs, rhs_f))) (* "f lhs = rhs" *)
  5.1320 -            val lhs_acc = (mk_acc domT R $ lhs) (* "acc R lhs" *)
  5.1321 -            fun simp_default_tac ss = asm_full_simp_tac (ss addsimps [default_thm, Let_def])
  5.1322 -          in
  5.1323 -            Goal.prove ctxt [] [] trsimp
  5.1324 -                       (fn _ =>
  5.1325 -                           rtac (instantiate' [] [SOME (cterm_of thy lhs_acc)] case_split) 1
  5.1326 -                                THEN (rtac (Thm.forall_elim_vars 0 psimp) THEN_ALL_NEW assume_tac) 1
  5.1327 -                                THEN (simp_default_tac (simpset_of ctxt) 1)
  5.1328 -                                THEN (etac not_acc_down 1)
  5.1329 -                                THEN ((etac R_cases) THEN_ALL_NEW (simp_default_tac (simpset_of ctxt))) 1)
  5.1330 -              |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  5.1331 -          end
  5.1332 -    in
  5.1333 -      map2 mk_trsimp clauses psimps
  5.1334 -    end
  5.1335 +        val trsimp = Logic.list_implies(gs,
  5.1336 +          HOLogic.mk_Trueprop (HOLogic.mk_eq(f $ lhs, rhs_f))) (* "f lhs = rhs" *)
  5.1337 +        val lhs_acc = (mk_acc domT R $ lhs) (* "acc R lhs" *)
  5.1338 +        fun simp_default_tac ss =
  5.1339 +          asm_full_simp_tac (ss addsimps [default_thm, Let_def])
  5.1340 +      in
  5.1341 +        Goal.prove ctxt [] [] trsimp (fn _ =>
  5.1342 +          rtac (instantiate' [] [SOME (cterm_of thy lhs_acc)] case_split) 1
  5.1343 +          THEN (rtac (Thm.forall_elim_vars 0 psimp) THEN_ALL_NEW assume_tac) 1
  5.1344 +          THEN (simp_default_tac (simpset_of ctxt) 1)
  5.1345 +          THEN (etac not_acc_down 1)
  5.1346 +          THEN ((etac R_cases)
  5.1347 +            THEN_ALL_NEW (simp_default_tac (simpset_of ctxt))) 1)
  5.1348 +        |> fold_rev forall_intr_rename (map fst oqs ~~ cqs)
  5.1349 +      end
  5.1350 +  in
  5.1351 +    map2 mk_trsimp clauses psimps
  5.1352 +  end
  5.1353  
  5.1354  
  5.1355  fun prepare_function config defname [((fname, fT), mixfix)] abstract_qglrs lthy =
  5.1356 -    let
  5.1357 -      val FunctionConfig {domintros, tailrec, default=default_str, ...} = config
  5.1358 +  let
  5.1359 +    val FunctionConfig {domintros, tailrec, default=default_str, ...} = config
  5.1360  
  5.1361 -      val fvar = Free (fname, fT)
  5.1362 -      val domT = domain_type fT
  5.1363 -      val ranT = range_type fT
  5.1364 +    val fvar = Free (fname, fT)
  5.1365 +    val domT = domain_type fT
  5.1366 +    val ranT = range_type fT
  5.1367  
  5.1368 -      val default = Syntax.parse_term lthy default_str
  5.1369 -        |> TypeInfer.constrain fT |> Syntax.check_term lthy
  5.1370 +    val default = Syntax.parse_term lthy default_str
  5.1371 +      |> TypeInfer.constrain fT |> Syntax.check_term lthy
  5.1372 +
  5.1373 +    val (globals, ctxt') = fix_globals domT ranT fvar lthy
  5.1374  
  5.1375 -      val (globals, ctxt') = fix_globals domT ranT fvar lthy
  5.1376 +    val Globals { x, h, ... } = globals
  5.1377  
  5.1378 -      val Globals { x, h, ... } = globals
  5.1379 +    val clauses = map (mk_clause_context x ctxt') abstract_qglrs
  5.1380 +
  5.1381 +    val n = length abstract_qglrs
  5.1382  
  5.1383 -      val clauses = map (mk_clause_context x ctxt') abstract_qglrs
  5.1384 +    fun build_tree (ClauseContext { ctxt, rhs, ...}) =
  5.1385 +       Function_Ctx_Tree.mk_tree (fname, fT) h ctxt rhs
  5.1386  
  5.1387 -      val n = length abstract_qglrs
  5.1388 -
  5.1389 -      fun build_tree (ClauseContext { ctxt, rhs, ...}) =
  5.1390 -            Function_Ctx_Tree.mk_tree (fname, fT) h ctxt rhs
  5.1391 +    val trees = map build_tree clauses
  5.1392 +    val RCss = map find_calls trees
  5.1393  
  5.1394 -      val trees = map build_tree clauses
  5.1395 -      val RCss = map find_calls trees
  5.1396 +    val ((G, GIntro_thms, G_elim, G_induct), lthy) =
  5.1397 +      PROFILE "def_graph" (define_graph (graph_name defname) fvar domT ranT clauses RCss) lthy
  5.1398 +
  5.1399 +    val ((f, (_, f_defthm)), lthy) =
  5.1400 +      PROFILE "def_fun" (define_function (defname ^ "_sumC_def") (fname, mixfix) domT ranT G default) lthy
  5.1401  
  5.1402 -      val ((G, GIntro_thms, G_elim, G_induct), lthy) =
  5.1403 -          PROFILE "def_graph" (define_graph (graph_name defname) fvar domT ranT clauses RCss) lthy
  5.1404 +    val RCss = map (map (inst_RC (ProofContext.theory_of lthy) fvar f)) RCss
  5.1405 +    val trees = map (Function_Ctx_Tree.inst_tree (ProofContext.theory_of lthy) fvar f) trees
  5.1406  
  5.1407 -      val ((f, (_, f_defthm)), lthy) =
  5.1408 -          PROFILE "def_fun" (define_function (defname ^ "_sumC_def") (fname, mixfix) domT ranT G default) lthy
  5.1409 +    val ((R, RIntro_thmss, R_elim), lthy) =
  5.1410 +      PROFILE "def_rel" (define_recursion_relation (rel_name defname) domT abstract_qglrs clauses RCss) lthy
  5.1411  
  5.1412 -      val RCss = map (map (inst_RC (ProofContext.theory_of lthy) fvar f)) RCss
  5.1413 -      val trees = map (Function_Ctx_Tree.inst_tree (ProofContext.theory_of lthy) fvar f) trees
  5.1414 +    val (_, lthy) =
  5.1415 +      Local_Theory.abbrev Syntax.mode_default ((Binding.name (dom_name defname), NoSyn), mk_acc domT R) lthy
  5.1416  
  5.1417 -      val ((R, RIntro_thmss, R_elim), lthy) =
  5.1418 -          PROFILE "def_rel" (define_recursion_relation (rel_name defname) domT abstract_qglrs clauses RCss) lthy
  5.1419 +    val newthy = ProofContext.theory_of lthy
  5.1420 +    val clauses = map (transfer_clause_ctx newthy) clauses
  5.1421  
  5.1422 -      val (_, lthy) =
  5.1423 -          Local_Theory.abbrev Syntax.mode_default ((Binding.name (dom_name defname), NoSyn), mk_acc domT R) lthy
  5.1424 +    val cert = cterm_of (ProofContext.theory_of lthy)
  5.1425  
  5.1426 -      val newthy = ProofContext.theory_of lthy
  5.1427 -      val clauses = map (transfer_clause_ctx newthy) clauses
  5.1428 -
  5.1429 -      val cert = cterm_of (ProofContext.theory_of lthy)
  5.1430 +    val xclauses = PROFILE "xclauses"
  5.1431 +      (map7 (mk_clause_info globals G f) (1 upto n) clauses abstract_qglrs trees
  5.1432 +        RCss GIntro_thms) RIntro_thmss
  5.1433  
  5.1434 -      val xclauses = PROFILE "xclauses" (map7 (mk_clause_info globals G f) (1 upto n) clauses abstract_qglrs trees RCss GIntro_thms) RIntro_thmss
  5.1435 -
  5.1436 -      val complete = mk_completeness globals clauses abstract_qglrs |> cert |> assume
  5.1437 -      val compat = mk_compat_proof_obligations domT ranT fvar f abstract_qglrs |> map (cert #> assume)
  5.1438 +    val complete =
  5.1439 +      mk_completeness globals clauses abstract_qglrs |> cert |> assume
  5.1440  
  5.1441 -      val compat_store = store_compat_thms n compat
  5.1442 +    val compat =
  5.1443 +      mk_compat_proof_obligations domT ranT fvar f abstract_qglrs
  5.1444 +      |> map (cert #> assume)
  5.1445  
  5.1446 -      val (goalstate, values) = PROFILE "prove_stuff" (prove_stuff lthy globals G f R xclauses complete compat compat_store G_elim) f_defthm
  5.1447 -
  5.1448 -      val mk_trsimps = mk_trsimps lthy globals f G R f_defthm R_elim G_induct xclauses
  5.1449 +    val compat_store = store_compat_thms n compat
  5.1450  
  5.1451 -      fun mk_partial_rules provedgoal =
  5.1452 -          let
  5.1453 -            val newthy = theory_of_thm provedgoal (*FIXME*)
  5.1454 +    val (goalstate, values) = PROFILE "prove_stuff"
  5.1455 +      (prove_stuff lthy globals G f R xclauses complete compat
  5.1456 +         compat_store G_elim) f_defthm
  5.1457 +
  5.1458 +    val mk_trsimps =
  5.1459 +      mk_trsimps lthy globals f G R f_defthm R_elim G_induct xclauses
  5.1460  
  5.1461 -            val (graph_is_function, complete_thm) =
  5.1462 -                provedgoal
  5.1463 -                  |> Conjunction.elim
  5.1464 -                  |> apfst (Thm.forall_elim_vars 0)
  5.1465 +    fun mk_partial_rules provedgoal =
  5.1466 +      let
  5.1467 +        val newthy = theory_of_thm provedgoal (*FIXME*)
  5.1468  
  5.1469 -            val f_iff = graph_is_function RS (f_defthm RS ex1_implies_iff)
  5.1470 +        val (graph_is_function, complete_thm) =
  5.1471 +          provedgoal
  5.1472 +          |> Conjunction.elim
  5.1473 +          |> apfst (Thm.forall_elim_vars 0)
  5.1474  
  5.1475 -            val psimps = PROFILE "Proving simplification rules" (mk_psimps newthy globals R xclauses values f_iff) graph_is_function
  5.1476 +        val f_iff = graph_is_function RS (f_defthm RS ex1_implies_iff)
  5.1477 +
  5.1478 +        val psimps = PROFILE "Proving simplification rules"
  5.1479 +          (mk_psimps newthy globals R xclauses values f_iff) graph_is_function
  5.1480  
  5.1481 -            val simple_pinduct = PROFILE "Proving partial induction rule"
  5.1482 -                                                           (mk_partial_induct_rule newthy globals R complete_thm) xclauses
  5.1483 +        val simple_pinduct = PROFILE "Proving partial induction rule"
  5.1484 +          (mk_partial_induct_rule newthy globals R complete_thm) xclauses
  5.1485  
  5.1486 -
  5.1487 -            val total_intro = PROFILE "Proving nested termination rule" (mk_nest_term_rule newthy globals R R_elim) xclauses
  5.1488 +        val total_intro = PROFILE "Proving nested termination rule"
  5.1489 +          (mk_nest_term_rule newthy globals R R_elim) xclauses
  5.1490  
  5.1491 -            val dom_intros = if domintros
  5.1492 -                             then SOME (PROFILE "Proving domain introduction rules" (map (mk_domain_intro lthy globals R R_elim)) xclauses)
  5.1493 -                             else NONE
  5.1494 -            val trsimps = if tailrec then SOME (mk_trsimps psimps) else NONE
  5.1495 +        val dom_intros =
  5.1496 +          if domintros then SOME (PROFILE "Proving domain introduction rules"
  5.1497 +             (map (mk_domain_intro lthy globals R R_elim)) xclauses)
  5.1498 +           else NONE
  5.1499 +        val trsimps = if tailrec then SOME (mk_trsimps psimps) else NONE
  5.1500  
  5.1501 -          in
  5.1502 -            FunctionResult {fs=[f], G=G, R=R, cases=complete_thm,
  5.1503 -                          psimps=psimps, simple_pinducts=[simple_pinduct],
  5.1504 -                          termination=total_intro, trsimps=trsimps,
  5.1505 -                          domintros=dom_intros}
  5.1506 -          end
  5.1507 -    in
  5.1508 -      ((f, goalstate, mk_partial_rules), lthy)
  5.1509 -    end
  5.1510 +      in
  5.1511 +        FunctionResult {fs=[f], G=G, R=R, cases=complete_thm,
  5.1512 +          psimps=psimps, simple_pinducts=[simple_pinduct],
  5.1513 +          termination=total_intro, trsimps=trsimps,
  5.1514 +          domintros=dom_intros}
  5.1515 +      end
  5.1516 +  in
  5.1517 +    ((f, goalstate, mk_partial_rules), lthy)
  5.1518 +  end
  5.1519  
  5.1520  
  5.1521  end
     6.1 --- a/src/HOL/Tools/Function/function_lib.ML	Sat Jan 02 23:18:58 2010 +0100
     6.2 +++ b/src/HOL/Tools/Function/function_lib.ML	Sat Jan 02 23:18:58 2010 +0100
     6.3 @@ -1,14 +1,14 @@
     6.4  (*  Title:      HOL/Tools/Function/fundef_lib.ML
     6.5      Author:     Alexander Krauss, TU Muenchen
     6.6  
     6.7 -A package for general recursive function definitions. 
     6.8 -Some fairly general functions that should probably go somewhere else... 
     6.9 +A package for general recursive function definitions.
    6.10 +Some fairly general functions that should probably go somewhere else...
    6.11  *)
    6.12  
    6.13  structure Function_Lib =
    6.14  struct
    6.15  
    6.16 -fun map_option f NONE = NONE 
    6.17 +fun map_option f NONE = NONE
    6.18    | map_option f (SOME x) = SOME (f x);
    6.19  
    6.20  fun fold_option f NONE y = y
    6.21 @@ -21,50 +21,50 @@
    6.22  (* lambda-abstracts over an arbitrarily nested tuple
    6.23    ==> hologic.ML? *)
    6.24  fun tupled_lambda vars t =
    6.25 -    case vars of
    6.26 -      (Free v) => lambda (Free v) t
    6.27 -    | (Var v) => lambda (Var v) t
    6.28 -    | (Const ("Pair", Type ("fun", [Ta, Type ("fun", [Tb, _])]))) $ us $ vs =>  
    6.29 +  case vars of
    6.30 +    (Free v) => lambda (Free v) t
    6.31 +  | (Var v) => lambda (Var v) t
    6.32 +  | (Const ("Pair", Type ("fun", [Ta, Type ("fun", [Tb, _])]))) $ us $ vs =>
    6.33        (HOLogic.split_const (Ta,Tb, fastype_of t)) $ (tupled_lambda us (tupled_lambda vs t))
    6.34 -    | _ => raise Match
    6.35 +  | _ => raise Match
    6.36  
    6.37  
    6.38  fun dest_all (Const ("all", _) $ Abs (a as (_,T,_))) =
    6.39 -    let
    6.40 -      val (n, body) = Term.dest_abs a
    6.41 -    in
    6.42 -      (Free (n, T), body)
    6.43 -    end
    6.44 +  let
    6.45 +    val (n, body) = Term.dest_abs a
    6.46 +  in
    6.47 +    (Free (n, T), body)
    6.48 +  end
    6.49    | dest_all _ = raise Match
    6.50  
    6.51  
    6.52  (* Removes all quantifiers from a term, replacing bound variables by frees. *)
    6.53 -fun dest_all_all (t as (Const ("all",_) $ _)) = 
    6.54 -    let
    6.55 -      val (v,b) = dest_all t
    6.56 -      val (vs, b') = dest_all_all b
    6.57 -    in
    6.58 -      (v :: vs, b')
    6.59 -    end
    6.60 +fun dest_all_all (t as (Const ("all",_) $ _)) =
    6.61 +  let
    6.62 +    val (v,b) = dest_all t
    6.63 +    val (vs, b') = dest_all_all b
    6.64 +  in
    6.65 +    (v :: vs, b')
    6.66 +  end
    6.67    | dest_all_all t = ([],t)
    6.68  
    6.69  
    6.70  (* FIXME: similar to Variable.focus *)
    6.71  fun dest_all_all_ctx ctx (Const ("all", _) $ Abs (n,T,b)) =
    6.72 -    let
    6.73 -      val [(n', _)] = Variable.variant_frees ctx [] [(n,T)]
    6.74 -      val (_, ctx') = ProofContext.add_fixes [(Binding.name n', SOME T, NoSyn)] ctx
    6.75 +  let
    6.76 +    val [(n', _)] = Variable.variant_frees ctx [] [(n,T)]
    6.77 +    val (_, ctx') = ProofContext.add_fixes [(Binding.name n', SOME T, NoSyn)] ctx
    6.78  
    6.79 -      val (n'', body) = Term.dest_abs (n', T, b) 
    6.80 -      val _ = (n' = n'') orelse error "dest_all_ctx"
    6.81 +    val (n'', body) = Term.dest_abs (n', T, b)
    6.82 +    val _ = (n' = n'') orelse error "dest_all_ctx"
    6.83        (* Note: We assume that n' does not occur in the body. Otherwise it would be fixed. *)
    6.84  
    6.85 -      val (ctx'', vs, bd) = dest_all_all_ctx ctx' body
    6.86 -    in
    6.87 -      (ctx'', (n', T) :: vs, bd)
    6.88 -    end
    6.89 -  | dest_all_all_ctx ctx t = 
    6.90 -    (ctx, [], t)
    6.91 +    val (ctx'', vs, bd) = dest_all_all_ctx ctx' body
    6.92 +  in
    6.93 +    (ctx'', (n', T) :: vs, bd)
    6.94 +  end
    6.95 +  | dest_all_all_ctx ctx t =
    6.96 +  (ctx, [], t)
    6.97  
    6.98  
    6.99  fun map3 _ [] [] [] = []
   6.100 @@ -86,52 +86,51 @@
   6.101  
   6.102  
   6.103  (* forms all "unordered pairs": [1, 2, 3] ==> [(1, 1), (1, 2), (1, 3), (2, 2), (2, 3), (3, 3)] *)
   6.104 -(* ==> library *)
   6.105  fun unordered_pairs [] = []
   6.106    | unordered_pairs (x::xs) = map (pair x) (x::xs) @ unordered_pairs xs
   6.107  
   6.108  
   6.109  (* Replaces Frees by name. Works with loose Bounds. *)
   6.110  fun replace_frees assoc =
   6.111 -    map_aterms (fn c as Free (n, _) => the_default c (AList.lookup (op =) assoc n)
   6.112 -                 | t => t)
   6.113 +  map_aterms (fn c as Free (n, _) => the_default c (AList.lookup (op =) assoc n)
   6.114 +    | t => t)
   6.115  
   6.116  
   6.117 -fun rename_bound n (Q $ Abs(_, T, b)) = (Q $ Abs(n, T, b))
   6.118 +fun rename_bound n (Q $ Abs (_, T, b)) = (Q $ Abs (n, T, b))
   6.119    | rename_bound n _ = raise Match
   6.120  
   6.121  fun mk_forall_rename (n, v) =
   6.122 -    rename_bound n o Logic.all v 
   6.123 +  rename_bound n o Logic.all v
   6.124  
   6.125  fun forall_intr_rename (n, cv) thm =
   6.126 -    let
   6.127 -      val allthm = forall_intr cv thm
   6.128 -      val (_ $ abs) = prop_of allthm
   6.129 -    in
   6.130 -      Thm.rename_boundvars abs (Abs (n, dummyT, Term.dummy_pattern dummyT)) allthm
   6.131 -    end
   6.132 +  let
   6.133 +    val allthm = forall_intr cv thm
   6.134 +    val (_ $ abs) = prop_of allthm
   6.135 +  in
   6.136 +    Thm.rename_boundvars abs (Abs (n, dummyT, Term.dummy_pattern dummyT)) allthm
   6.137 +  end
   6.138  
   6.139  
   6.140  (* Returns the frees in a term in canonical order, excluding the fixes from the context *)
   6.141  fun frees_in_term ctxt t =
   6.142 -    Term.add_frees t []
   6.143 -    |> filter_out (Variable.is_fixed ctxt o fst)
   6.144 -    |> rev
   6.145 +  Term.add_frees t []
   6.146 +  |> filter_out (Variable.is_fixed ctxt o fst)
   6.147 +  |> rev
   6.148  
   6.149  
   6.150  datatype proof_attempt = Solved of thm | Stuck of thm | Fail
   6.151  
   6.152 -fun try_proof cgoal tac = 
   6.153 -    case SINGLE tac (Goal.init cgoal) of
   6.154 -      NONE => Fail
   6.155 -    | SOME st =>
   6.156 -        if Thm.no_prems st
   6.157 -        then Solved (Goal.finish (Syntax.init_pretty_global (Thm.theory_of_cterm cgoal)) st)
   6.158 -        else Stuck st
   6.159 +fun try_proof cgoal tac =
   6.160 +  case SINGLE tac (Goal.init cgoal) of
   6.161 +    NONE => Fail
   6.162 +  | SOME st =>
   6.163 +    if Thm.no_prems st
   6.164 +    then Solved (Goal.finish (Syntax.init_pretty_global (Thm.theory_of_cterm cgoal)) st)
   6.165 +    else Stuck st
   6.166  
   6.167  
   6.168 -fun dest_binop_list cn (t as (Const (n, _) $ a $ b)) = 
   6.169 -    if cn = n then dest_binop_list cn a @ dest_binop_list cn b else [ t ]
   6.170 +fun dest_binop_list cn (t as (Const (n, _) $ a $ b)) =
   6.171 +  if cn = n then dest_binop_list cn a @ dest_binop_list cn b else [ t ]
   6.172    | dest_binop_list _ t = [ t ]
   6.173  
   6.174  
   6.175 @@ -168,10 +167,10 @@
   6.176   end
   6.177  
   6.178  (* instance for unions *)
   6.179 -fun regroup_union_conv t = regroup_conv @{const_name Set.empty} @{const_name Lattices.sup}
   6.180 -  (map (fn t => t RS eq_reflection) (@{thms Un_ac} @
   6.181 -                                     @{thms Un_empty_right} @
   6.182 -                                     @{thms Un_empty_left})) t
   6.183 +val regroup_union_conv =
   6.184 +  regroup_conv @{const_name Set.empty} @{const_name Lattices.sup}
   6.185 +    (map (fn t => t RS eq_reflection)
   6.186 +      (@{thms Un_ac} @ @{thms Un_empty_right} @ @{thms Un_empty_left}))
   6.187  
   6.188  
   6.189  end
     7.1 --- a/src/HOL/Tools/Function/induction_schema.ML	Sat Jan 02 23:18:58 2010 +0100
     7.2 +++ b/src/HOL/Tools/Function/induction_schema.ML	Sat Jan 02 23:18:58 2010 +0100
     7.3 @@ -18,370 +18,367 @@
     7.4  
     7.5  open Function_Lib
     7.6  
     7.7 -
     7.8  type rec_call_info = int * (string * typ) list * term list * term list
     7.9  
    7.10 -datatype scheme_case =
    7.11 -  SchemeCase of
    7.12 -  {
    7.13 -   bidx : int,
    7.14 -   qs: (string * typ) list,
    7.15 -   oqnames: string list,
    7.16 -   gs: term list,
    7.17 -   lhs: term list,
    7.18 -   rs: rec_call_info list
    7.19 -  }
    7.20 +datatype scheme_case = SchemeCase of
    7.21 + {bidx : int,
    7.22 +  qs: (string * typ) list,
    7.23 +  oqnames: string list,
    7.24 +  gs: term list,
    7.25 +  lhs: term list,
    7.26 +  rs: rec_call_info list}
    7.27  
    7.28 -datatype scheme_branch = 
    7.29 -  SchemeBranch of
    7.30 -  {
    7.31 -   P : term,
    7.32 -   xs: (string * typ) list,
    7.33 -   ws: (string * typ) list,
    7.34 -   Cs: term list
    7.35 -  }
    7.36 +datatype scheme_branch = SchemeBranch of
    7.37 + {P : term,
    7.38 +  xs: (string * typ) list,
    7.39 +  ws: (string * typ) list,
    7.40 +  Cs: term list}
    7.41  
    7.42 -datatype ind_scheme =
    7.43 -  IndScheme of
    7.44 -  {
    7.45 -   T: typ, (* sum of products *)
    7.46 -   branches: scheme_branch list,
    7.47 -   cases: scheme_case list
    7.48 -  }
    7.49 +datatype ind_scheme = IndScheme of
    7.50 + {T: typ, (* sum of products *)
    7.51 +  branches: scheme_branch list,
    7.52 +  cases: scheme_case list}
    7.53  
    7.54  val ind_atomize = MetaSimplifier.rewrite true @{thms induct_atomize}
    7.55  val ind_rulify = MetaSimplifier.rewrite true @{thms induct_rulify}
    7.56  
    7.57  fun meta thm = thm RS eq_reflection
    7.58  
    7.59 -val sum_prod_conv = MetaSimplifier.rewrite true 
    7.60 -                    (map meta (@{thm split_conv} :: @{thms sum.cases}))
    7.61 +val sum_prod_conv = MetaSimplifier.rewrite true
    7.62 +  (map meta (@{thm split_conv} :: @{thms sum.cases}))
    7.63  
    7.64 -fun term_conv thy cv t = 
    7.65 -    cv (cterm_of thy t)
    7.66 -    |> prop_of |> Logic.dest_equals |> snd
    7.67 +fun term_conv thy cv t =
    7.68 +  cv (cterm_of thy t)
    7.69 +  |> prop_of |> Logic.dest_equals |> snd
    7.70  
    7.71  fun mk_relT T = HOLogic.mk_setT (HOLogic.mk_prodT (T, T))
    7.72  
    7.73 -fun dest_hhf ctxt t = 
    7.74 -    let 
    7.75 -      val (ctxt', vars, imp) = dest_all_all_ctx ctxt t
    7.76 -    in
    7.77 -      (ctxt', vars, Logic.strip_imp_prems imp, Logic.strip_imp_concl imp)
    7.78 -    end
    7.79 -
    7.80 +fun dest_hhf ctxt t =
    7.81 +  let
    7.82 +    val (ctxt', vars, imp) = dest_all_all_ctx ctxt t
    7.83 +  in
    7.84 +    (ctxt', vars, Logic.strip_imp_prems imp, Logic.strip_imp_concl imp)
    7.85 +  end
    7.86  
    7.87  fun mk_scheme' ctxt cases concl =
    7.88 -    let
    7.89 -      fun mk_branch concl =
    7.90 +  let
    7.91 +    fun mk_branch concl =
    7.92 +      let
    7.93 +        val (_, ws, Cs, _ $ Pxs) = dest_hhf ctxt concl
    7.94 +        val (P, xs) = strip_comb Pxs
    7.95 +      in
    7.96 +        SchemeBranch { P=P, xs=map dest_Free xs, ws=ws, Cs=Cs }
    7.97 +      end
    7.98 +
    7.99 +    val (branches, cases') = (* correction *)
   7.100 +      case Logic.dest_conjunction_list concl of
   7.101 +        [conc] =>
   7.102 +        let
   7.103 +          val _ $ Pxs = Logic.strip_assums_concl conc
   7.104 +          val (P, _) = strip_comb Pxs
   7.105 +          val (cases', conds) =
   7.106 +            take_prefix (Term.exists_subterm (curry op aconv P)) cases
   7.107 +          val concl' = fold_rev (curry Logic.mk_implies) conds conc
   7.108 +        in
   7.109 +          ([mk_branch concl'], cases')
   7.110 +        end
   7.111 +      | concls => (map mk_branch concls, cases)
   7.112 +
   7.113 +    fun mk_case premise =
   7.114 +      let
   7.115 +        val (ctxt', qs, prems, _ $ Plhs) = dest_hhf ctxt premise
   7.116 +        val (P, lhs) = strip_comb Plhs
   7.117 +
   7.118 +        fun bidx Q =
   7.119 +          find_index (fn SchemeBranch {P=P',...} => Q aconv P') branches
   7.120 +
   7.121 +        fun mk_rcinfo pr =
   7.122            let
   7.123 -            val (_, ws, Cs, _ $ Pxs) = dest_hhf ctxt concl
   7.124 -            val (P, xs) = strip_comb Pxs
   7.125 +            val (_, Gvs, Gas, _ $ Phyp) = dest_hhf ctxt' pr
   7.126 +            val (P', rcs) = strip_comb Phyp
   7.127            in
   7.128 -            SchemeBranch { P=P, xs=map dest_Free xs, ws=ws, Cs=Cs }
   7.129 +            (bidx P', Gvs, Gas, rcs)
   7.130            end
   7.131  
   7.132 -      val (branches, cases') = (* correction *)
   7.133 -          case Logic.dest_conjunction_list concl of
   7.134 -            [conc] => 
   7.135 -            let 
   7.136 -              val _ $ Pxs = Logic.strip_assums_concl conc
   7.137 -              val (P, _) = strip_comb Pxs
   7.138 -              val (cases', conds) = take_prefix (Term.exists_subterm (curry op aconv P)) cases
   7.139 -              val concl' = fold_rev (curry Logic.mk_implies) conds conc
   7.140 -            in
   7.141 -              ([mk_branch concl'], cases')
   7.142 -            end
   7.143 -          | concls => (map mk_branch concls, cases)
   7.144 -
   7.145 -      fun mk_case premise =
   7.146 -          let
   7.147 -            val (ctxt', qs, prems, _ $ Plhs) = dest_hhf ctxt premise
   7.148 -            val (P, lhs) = strip_comb Plhs
   7.149 -                                
   7.150 -            fun bidx Q = find_index (fn SchemeBranch {P=P',...} => Q aconv P') branches
   7.151 +        fun is_pred v = exists (fn SchemeBranch {P,...} => v aconv P) branches
   7.152  
   7.153 -            fun mk_rcinfo pr =
   7.154 -                let
   7.155 -                  val (_, Gvs, Gas, _ $ Phyp) = dest_hhf ctxt' pr
   7.156 -                  val (P', rcs) = strip_comb Phyp
   7.157 -                in
   7.158 -                  (bidx P', Gvs, Gas, rcs)
   7.159 -                end
   7.160 -                
   7.161 -            fun is_pred v = exists (fn SchemeBranch {P,...} => v aconv P) branches
   7.162 +        val (gs, rcprs) =
   7.163 +          take_prefix (not o Term.exists_subterm is_pred) prems
   7.164 +      in
   7.165 +        SchemeCase {bidx=bidx P, qs=qs, oqnames=map fst qs(*FIXME*),
   7.166 +          gs=gs, lhs=lhs, rs=map mk_rcinfo rcprs}
   7.167 +      end
   7.168  
   7.169 -            val (gs, rcprs) = 
   7.170 -                take_prefix (not o Term.exists_subterm is_pred) prems
   7.171 -          in
   7.172 -            SchemeCase {bidx=bidx P, qs=qs, oqnames=map fst qs(*FIXME*), gs=gs, lhs=lhs, rs=map mk_rcinfo rcprs}
   7.173 -          end
   7.174 +    fun PT_of (SchemeBranch { xs, ...}) =
   7.175 +      foldr1 HOLogic.mk_prodT (map snd xs)
   7.176  
   7.177 -      fun PT_of (SchemeBranch { xs, ...}) =
   7.178 -            foldr1 HOLogic.mk_prodT (map snd xs)
   7.179 -
   7.180 -      val ST = Balanced_Tree.make (uncurry SumTree.mk_sumT) (map PT_of branches)
   7.181 -    in
   7.182 -      IndScheme {T=ST, cases=map mk_case cases', branches=branches }
   7.183 -    end
   7.184 -
   7.185 -
   7.186 +    val ST = Balanced_Tree.make (uncurry SumTree.mk_sumT) (map PT_of branches)
   7.187 +  in
   7.188 +    IndScheme {T=ST, cases=map mk_case cases', branches=branches }
   7.189 +  end
   7.190  
   7.191  fun mk_completeness ctxt (IndScheme {cases, branches, ...}) bidx =
   7.192 -    let
   7.193 -      val SchemeBranch { xs, ws, Cs, ... } = nth branches bidx
   7.194 -      val relevant_cases = filter (fn SchemeCase {bidx=bidx', ...} => bidx' = bidx) cases
   7.195 +  let
   7.196 +    val SchemeBranch { xs, ws, Cs, ... } = nth branches bidx
   7.197 +    val relevant_cases = filter (fn SchemeCase {bidx=bidx', ...} => bidx' = bidx) cases
   7.198 +
   7.199 +    val allqnames = fold (fn SchemeCase {qs, ...} => fold (insert (op =) o Free) qs) relevant_cases []
   7.200 +    val (Pbool :: xs') = map Free (Variable.variant_frees ctxt allqnames (("P", HOLogic.boolT) :: xs))
   7.201 +    val Cs' = map (Pattern.rewrite_term (ProofContext.theory_of ctxt) (filter_out (op aconv) (map Free xs ~~ xs')) []) Cs
   7.202  
   7.203 -      val allqnames = fold (fn SchemeCase {qs, ...} => fold (insert (op =) o Free) qs) relevant_cases []
   7.204 -      val (Pbool :: xs') = map Free (Variable.variant_frees ctxt allqnames (("P", HOLogic.boolT) :: xs))
   7.205 -      val Cs' = map (Pattern.rewrite_term (ProofContext.theory_of ctxt) (filter_out (op aconv) (map Free xs ~~ xs')) []) Cs
   7.206 -                       
   7.207 -      fun mk_case (SchemeCase {qs, oqnames, gs, lhs, ...}) =
   7.208 -          HOLogic.mk_Trueprop Pbool
   7.209 -                     |> fold_rev (fn x_l => curry Logic.mk_implies (HOLogic.mk_Trueprop(HOLogic.mk_eq x_l)))
   7.210 -                                 (xs' ~~ lhs)
   7.211 -                     |> fold_rev (curry Logic.mk_implies) gs
   7.212 -                     |> fold_rev mk_forall_rename (oqnames ~~ map Free qs)
   7.213 -    in
   7.214 +    fun mk_case (SchemeCase {qs, oqnames, gs, lhs, ...}) =
   7.215        HOLogic.mk_Trueprop Pbool
   7.216 -       |> fold_rev (curry Logic.mk_implies o mk_case) relevant_cases
   7.217 -       |> fold_rev (curry Logic.mk_implies) Cs'
   7.218 -       |> fold_rev (Logic.all o Free) ws
   7.219 -       |> fold_rev mk_forall_rename (map fst xs ~~ xs')
   7.220 -       |> mk_forall_rename ("P", Pbool)
   7.221 -    end
   7.222 +      |> fold_rev (fn x_l => curry Logic.mk_implies (HOLogic.mk_Trueprop(HOLogic.mk_eq x_l)))
   7.223 +           (xs' ~~ lhs)
   7.224 +      |> fold_rev (curry Logic.mk_implies) gs
   7.225 +      |> fold_rev mk_forall_rename (oqnames ~~ map Free qs)
   7.226 +  in
   7.227 +    HOLogic.mk_Trueprop Pbool
   7.228 +    |> fold_rev (curry Logic.mk_implies o mk_case) relevant_cases
   7.229 +    |> fold_rev (curry Logic.mk_implies) Cs'
   7.230 +    |> fold_rev (Logic.all o Free) ws
   7.231 +    |> fold_rev mk_forall_rename (map fst xs ~~ xs')
   7.232 +    |> mk_forall_rename ("P", Pbool)
   7.233 +  end
   7.234  
   7.235  fun mk_wf R (IndScheme {T, ...}) =
   7.236 -    HOLogic.Trueprop $ (Const (@{const_name wf}, mk_relT T --> HOLogic.boolT) $ R)
   7.237 +  HOLogic.Trueprop $ (Const (@{const_name wf}, mk_relT T --> HOLogic.boolT) $ R)
   7.238  
   7.239  fun mk_ineqs R (IndScheme {T, cases, branches}) =
   7.240 -    let
   7.241 -      fun inject i ts =
   7.242 -          SumTree.mk_inj T (length branches) (i + 1) (foldr1 HOLogic.mk_prod ts)
   7.243 +  let
   7.244 +    fun inject i ts =
   7.245 +       SumTree.mk_inj T (length branches) (i + 1) (foldr1 HOLogic.mk_prod ts)
   7.246  
   7.247 -      val thesis = Free ("thesis", HOLogic.boolT) (* FIXME *)
   7.248 +    val thesis = Free ("thesis", HOLogic.boolT) (* FIXME *)
   7.249  
   7.250 -      fun mk_pres bdx args = 
   7.251 -          let
   7.252 -            val SchemeBranch { xs, ws, Cs, ... } = nth branches bdx
   7.253 -            fun replace (x, v) t = betapply (lambda (Free x) t, v)
   7.254 -            val Cs' = map (fold replace (xs ~~ args)) Cs
   7.255 -            val cse = 
   7.256 -                HOLogic.mk_Trueprop thesis
   7.257 -                |> fold_rev (curry Logic.mk_implies) Cs'
   7.258 -                |> fold_rev (Logic.all o Free) ws
   7.259 -          in
   7.260 -            Logic.mk_implies (cse, HOLogic.mk_Trueprop thesis)
   7.261 -          end
   7.262 +    fun mk_pres bdx args =
   7.263 +      let
   7.264 +        val SchemeBranch { xs, ws, Cs, ... } = nth branches bdx
   7.265 +        fun replace (x, v) t = betapply (lambda (Free x) t, v)
   7.266 +        val Cs' = map (fold replace (xs ~~ args)) Cs
   7.267 +        val cse =
   7.268 +          HOLogic.mk_Trueprop thesis
   7.269 +          |> fold_rev (curry Logic.mk_implies) Cs'
   7.270 +          |> fold_rev (Logic.all o Free) ws
   7.271 +      in
   7.272 +        Logic.mk_implies (cse, HOLogic.mk_Trueprop thesis)
   7.273 +      end
   7.274  
   7.275 -      fun f (SchemeCase {bidx, qs, oqnames, gs, lhs, rs, ...}) = 
   7.276 -          let
   7.277 -            fun g (bidx', Gvs, Gas, rcarg) =
   7.278 -                let val export = 
   7.279 -                         fold_rev (curry Logic.mk_implies) Gas
   7.280 -                         #> fold_rev (curry Logic.mk_implies) gs
   7.281 -                         #> fold_rev (Logic.all o Free) Gvs
   7.282 -                         #> fold_rev mk_forall_rename (oqnames ~~ map Free qs)
   7.283 -                in
   7.284 -                (HOLogic.mk_mem (HOLogic.mk_prod (inject bidx' rcarg, inject bidx lhs), R)
   7.285 -                 |> HOLogic.mk_Trueprop
   7.286 -                 |> export,
   7.287 -                 mk_pres bidx' rcarg
   7.288 -                 |> export
   7.289 -                 |> Logic.all thesis)
   7.290 -                end
   7.291 +    fun f (SchemeCase {bidx, qs, oqnames, gs, lhs, rs, ...}) =
   7.292 +      let
   7.293 +        fun g (bidx', Gvs, Gas, rcarg) =
   7.294 +          let val export =
   7.295 +            fold_rev (curry Logic.mk_implies) Gas
   7.296 +            #> fold_rev (curry Logic.mk_implies) gs
   7.297 +            #> fold_rev (Logic.all o Free) Gvs
   7.298 +            #> fold_rev mk_forall_rename (oqnames ~~ map Free qs)
   7.299            in
   7.300 -            map g rs
   7.301 +            (HOLogic.mk_mem (HOLogic.mk_prod (inject bidx' rcarg, inject bidx lhs), R)
   7.302 +             |> HOLogic.mk_Trueprop
   7.303 +             |> export,
   7.304 +             mk_pres bidx' rcarg
   7.305 +             |> export
   7.306 +             |> Logic.all thesis)
   7.307            end
   7.308 -    in
   7.309 -      map f cases
   7.310 -    end
   7.311 +      in
   7.312 +        map g rs
   7.313 +      end
   7.314 +  in
   7.315 +    map f cases
   7.316 +  end
   7.317  
   7.318  
   7.319  fun mk_ind_goal thy branches =
   7.320 -    let
   7.321 -      fun brnch (SchemeBranch { P, xs, ws, Cs, ... }) =
   7.322 -          HOLogic.mk_Trueprop (list_comb (P, map Free xs))
   7.323 -          |> fold_rev (curry Logic.mk_implies) Cs
   7.324 -          |> fold_rev (Logic.all o Free) ws
   7.325 -          |> term_conv thy ind_atomize
   7.326 -          |> ObjectLogic.drop_judgment thy
   7.327 -          |> tupled_lambda (foldr1 HOLogic.mk_prod (map Free xs))
   7.328 -    in
   7.329 -      SumTree.mk_sumcases HOLogic.boolT (map brnch branches)
   7.330 -    end
   7.331 +  let
   7.332 +    fun brnch (SchemeBranch { P, xs, ws, Cs, ... }) =
   7.333 +      HOLogic.mk_Trueprop (list_comb (P, map Free xs))
   7.334 +      |> fold_rev (curry Logic.mk_implies) Cs
   7.335 +      |> fold_rev (Logic.all o Free) ws
   7.336 +      |> term_conv thy ind_atomize
   7.337 +      |> ObjectLogic.drop_judgment thy
   7.338 +      |> tupled_lambda (foldr1 HOLogic.mk_prod (map Free xs))
   7.339 +  in
   7.340 +    SumTree.mk_sumcases HOLogic.boolT (map brnch branches)
   7.341 +  end
   7.342 +
   7.343 +fun mk_induct_rule ctxt R x complete_thms wf_thm ineqss
   7.344 +  (IndScheme {T, cases=scases, branches}) =
   7.345 +  let
   7.346 +    val n = length branches
   7.347 +    val scases_idx = map_index I scases
   7.348 +
   7.349 +    fun inject i ts =
   7.350 +      SumTree.mk_inj T n (i + 1) (foldr1 HOLogic.mk_prod ts)
   7.351 +    val P_of = nth (map (fn (SchemeBranch { P, ... }) => P) branches)
   7.352 +
   7.353 +    val thy = ProofContext.theory_of ctxt
   7.354 +    val cert = cterm_of thy
   7.355 +
   7.356 +    val P_comp = mk_ind_goal thy branches
   7.357 +
   7.358 +    (* Inductive Hypothesis: !!z. (z,x):R ==> P z *)
   7.359 +    val ihyp = Term.all T $ Abs ("z", T,
   7.360 +      Logic.mk_implies
   7.361 +        (HOLogic.mk_Trueprop (
   7.362 +          Const ("op :", HOLogic.mk_prodT (T, T) --> mk_relT T --> HOLogic.boolT) 
   7.363 +          $ (HOLogic.pair_const T T $ Bound 0 $ x)
   7.364 +          $ R),
   7.365 +         HOLogic.mk_Trueprop (P_comp $ Bound 0)))
   7.366 +      |> cert
   7.367 +
   7.368 +    val aihyp = assume ihyp
   7.369 +
   7.370 +    (* Rule for case splitting along the sum types *)
   7.371 +    val xss = map (fn (SchemeBranch { xs, ... }) => map Free xs) branches
   7.372 +    val pats = map_index (uncurry inject) xss
   7.373 +    val sum_split_rule =
   7.374 +      Pat_Completeness.prove_completeness thy [x] (P_comp $ x) xss (map single pats)
   7.375 +
   7.376 +    fun prove_branch (bidx, (SchemeBranch { P, xs, ws, Cs, ... }, (complete_thm, pat))) =
   7.377 +      let
   7.378 +        val fxs = map Free xs
   7.379 +        val branch_hyp = assume (cert (HOLogic.mk_Trueprop (HOLogic.mk_eq (x, pat))))
   7.380 +
   7.381 +        val C_hyps = map (cert #> assume) Cs
   7.382 +
   7.383 +        val (relevant_cases, ineqss') =
   7.384 +          (scases_idx ~~ ineqss)
   7.385 +          |> filter (fn ((_, SchemeCase {bidx=bidx', ...}), _) => bidx' = bidx)
   7.386 +          |> split_list
   7.387 +
   7.388 +        fun prove_case (cidx, SchemeCase {qs, gs, lhs, rs, ...}) ineq_press =
   7.389 +          let
   7.390 +            val case_hyps = map (assume o cert o HOLogic.mk_Trueprop o HOLogic.mk_eq) (fxs ~~ lhs)
   7.391 +
   7.392 +            val cqs = map (cert o Free) qs
   7.393 +            val ags = map (assume o cert) gs
   7.394 +
   7.395 +            val replace_x_ss = HOL_basic_ss addsimps (branch_hyp :: case_hyps)
   7.396 +            val sih = full_simplify replace_x_ss aihyp
   7.397 +
   7.398 +            fun mk_Prec (idx, Gvs, Gas, rcargs) (ineq, pres) =
   7.399 +              let
   7.400 +                val cGas = map (assume o cert) Gas
   7.401 +                val cGvs = map (cert o Free) Gvs
   7.402 +                val import = fold forall_elim (cqs @ cGvs)
   7.403 +                  #> fold Thm.elim_implies (ags @ cGas)
   7.404 +                val ipres = pres
   7.405 +                  |> forall_elim (cert (list_comb (P_of idx, rcargs)))
   7.406 +                  |> import
   7.407 +              in
   7.408 +                sih
   7.409 +                |> forall_elim (cert (inject idx rcargs))
   7.410 +                |> Thm.elim_implies (import ineq) (* Psum rcargs *)
   7.411 +                |> Conv.fconv_rule sum_prod_conv
   7.412 +                |> Conv.fconv_rule ind_rulify
   7.413 +                |> (fn th => th COMP ipres) (* P rs *)
   7.414 +                |> fold_rev (implies_intr o cprop_of) cGas
   7.415 +                |> fold_rev forall_intr cGvs
   7.416 +              end
   7.417 +
   7.418 +            val P_recs = map2 mk_Prec rs ineq_press   (*  [P rec1, P rec2, ... ]  *)
   7.419 +
   7.420 +            val step = HOLogic.mk_Trueprop (list_comb (P, lhs))
   7.421 +              |> fold_rev (curry Logic.mk_implies o prop_of) P_recs
   7.422 +              |> fold_rev (curry Logic.mk_implies) gs
   7.423 +              |> fold_rev (Logic.all o Free) qs
   7.424 +              |> cert
   7.425 +
   7.426 +            val Plhs_to_Pxs_conv =
   7.427 +              foldl1 (uncurry Conv.combination_conv)
   7.428 +                (Conv.all_conv :: map (fn ch => K (Thm.symmetric (ch RS eq_reflection))) case_hyps)
   7.429 +
   7.430 +            val res = assume step
   7.431 +              |> fold forall_elim cqs
   7.432 +              |> fold Thm.elim_implies ags
   7.433 +              |> fold Thm.elim_implies P_recs (* P lhs *)
   7.434 +              |> Conv.fconv_rule (Conv.arg_conv Plhs_to_Pxs_conv) (* P xs *)
   7.435 +              |> fold_rev (implies_intr o cprop_of) (ags @ case_hyps)
   7.436 +              |> fold_rev forall_intr cqs (* !!qs. Gas ==> xs = lhss ==> P xs *)
   7.437 +          in
   7.438 +            (res, (cidx, step))
   7.439 +          end
   7.440 +
   7.441 +        val (cases, steps) = split_list (map2 prove_case relevant_cases ineqss')
   7.442 +
   7.443 +        val bstep = complete_thm
   7.444 +          |> forall_elim (cert (list_comb (P, fxs)))
   7.445 +          |> fold (forall_elim o cert) (fxs @ map Free ws)
   7.446 +          |> fold Thm.elim_implies C_hyps
   7.447 +          |> fold Thm.elim_implies cases (* P xs *)
   7.448 +          |> fold_rev (implies_intr o cprop_of) C_hyps
   7.449 +          |> fold_rev (forall_intr o cert o Free) ws
   7.450 +
   7.451 +        val Pxs = cert (HOLogic.mk_Trueprop (P_comp $ x))
   7.452 +          |> Goal.init
   7.453 +          |> (MetaSimplifier.rewrite_goals_tac (map meta (branch_hyp :: @{thm split_conv} :: @{thms sum.cases}))
   7.454 +              THEN CONVERSION ind_rulify 1)
   7.455 +          |> Seq.hd
   7.456 +          |> Thm.elim_implies (Conv.fconv_rule Drule.beta_eta_conversion bstep)
   7.457 +          |> Goal.finish ctxt
   7.458 +          |> implies_intr (cprop_of branch_hyp)
   7.459 +          |> fold_rev (forall_intr o cert) fxs
   7.460 +      in
   7.461 +        (Pxs, steps)
   7.462 +      end
   7.463 +
   7.464 +    val (branches, steps) =
   7.465 +      map_index prove_branch (branches ~~ (complete_thms ~~ pats))
   7.466 +      |> split_list |> apsnd flat
   7.467 +
   7.468 +    val istep = sum_split_rule
   7.469 +      |> fold (fn b => fn th => Drule.compose_single (b, 1, th)) branches
   7.470 +      |> implies_intr ihyp
   7.471 +      |> forall_intr (cert x) (* "!!x. (!!y<x. P y) ==> P x" *)
   7.472 +
   7.473 +    val induct_rule =
   7.474 +      @{thm "wf_induct_rule"}
   7.475 +      |> (curry op COMP) wf_thm
   7.476 +      |> (curry op COMP) istep
   7.477 +
   7.478 +    val steps_sorted = map snd (sort (int_ord o pairself fst) steps)
   7.479 +  in
   7.480 +    (steps_sorted, induct_rule)
   7.481 +  end
   7.482  
   7.483  
   7.484 -fun mk_induct_rule ctxt R x complete_thms wf_thm ineqss (IndScheme {T, cases=scases, branches}) =
   7.485 -    let
   7.486 -      val n = length branches
   7.487 -
   7.488 -      val scases_idx = map_index I scases
   7.489 -
   7.490 -      fun inject i ts =
   7.491 -          SumTree.mk_inj T n (i + 1) (foldr1 HOLogic.mk_prod ts)
   7.492 -      val P_of = nth (map (fn (SchemeBranch { P, ... }) => P) branches)
   7.493 -
   7.494 -      val thy = ProofContext.theory_of ctxt
   7.495 -      val cert = cterm_of thy 
   7.496 -
   7.497 -      val P_comp = mk_ind_goal thy branches
   7.498 -
   7.499 -      (* Inductive Hypothesis: !!z. (z,x):R ==> P z *)
   7.500 -      val ihyp = Term.all T $ Abs ("z", T, 
   7.501 -               Logic.mk_implies
   7.502 -                 (HOLogic.mk_Trueprop (
   7.503 -                  Const ("op :", HOLogic.mk_prodT (T, T) --> mk_relT T --> HOLogic.boolT) 
   7.504 -                    $ (HOLogic.pair_const T T $ Bound 0 $ x) 
   7.505 -                    $ R),
   7.506 -                   HOLogic.mk_Trueprop (P_comp $ Bound 0)))
   7.507 -           |> cert
   7.508 -
   7.509 -      val aihyp = assume ihyp
   7.510 -
   7.511 -     (* Rule for case splitting along the sum types *)
   7.512 -      val xss = map (fn (SchemeBranch { xs, ... }) => map Free xs) branches
   7.513 -      val pats = map_index (uncurry inject) xss
   7.514 -      val sum_split_rule = Pat_Completeness.prove_completeness thy [x] (P_comp $ x) xss (map single pats)
   7.515 -
   7.516 -      fun prove_branch (bidx, (SchemeBranch { P, xs, ws, Cs, ... }, (complete_thm, pat))) =
   7.517 -          let
   7.518 -            val fxs = map Free xs
   7.519 -            val branch_hyp = assume (cert (HOLogic.mk_Trueprop (HOLogic.mk_eq (x, pat))))
   7.520 -                             
   7.521 -            val C_hyps = map (cert #> assume) Cs
   7.522 -
   7.523 -            val (relevant_cases, ineqss') = filter (fn ((_, SchemeCase {bidx=bidx', ...}), _) => bidx' = bidx) (scases_idx ~~ ineqss)
   7.524 -                                            |> split_list
   7.525 -                           
   7.526 -            fun prove_case (cidx, SchemeCase {qs, gs, lhs, rs, ...}) ineq_press =
   7.527 -                let
   7.528 -                  val case_hyps = map (assume o cert o HOLogic.mk_Trueprop o HOLogic.mk_eq) (fxs ~~ lhs)
   7.529 -                           
   7.530 -                  val cqs = map (cert o Free) qs
   7.531 -                  val ags = map (assume o cert) gs
   7.532 -                            
   7.533 -                  val replace_x_ss = HOL_basic_ss addsimps (branch_hyp :: case_hyps)
   7.534 -                  val sih = full_simplify replace_x_ss aihyp
   7.535 -                            
   7.536 -                  fun mk_Prec (idx, Gvs, Gas, rcargs) (ineq, pres) =
   7.537 -                      let
   7.538 -                        val cGas = map (assume o cert) Gas
   7.539 -                        val cGvs = map (cert o Free) Gvs
   7.540 -                        val import = fold forall_elim (cqs @ cGvs)
   7.541 -                                     #> fold Thm.elim_implies (ags @ cGas)
   7.542 -                        val ipres = pres
   7.543 -                                     |> forall_elim (cert (list_comb (P_of idx, rcargs)))
   7.544 -                                     |> import
   7.545 -                      in
   7.546 -                        sih |> forall_elim (cert (inject idx rcargs))
   7.547 -                            |> Thm.elim_implies (import ineq) (* Psum rcargs *)
   7.548 -                            |> Conv.fconv_rule sum_prod_conv
   7.549 -                            |> Conv.fconv_rule ind_rulify
   7.550 -                            |> (fn th => th COMP ipres) (* P rs *)
   7.551 -                            |> fold_rev (implies_intr o cprop_of) cGas
   7.552 -                            |> fold_rev forall_intr cGvs
   7.553 -                      end
   7.554 -                      
   7.555 -                  val P_recs = map2 mk_Prec rs ineq_press   (*  [P rec1, P rec2, ... ]  *)
   7.556 -                               
   7.557 -                  val step = HOLogic.mk_Trueprop (list_comb (P, lhs))
   7.558 -                             |> fold_rev (curry Logic.mk_implies o prop_of) P_recs
   7.559 -                             |> fold_rev (curry Logic.mk_implies) gs
   7.560 -                             |> fold_rev (Logic.all o Free) qs
   7.561 -                             |> cert
   7.562 -                             
   7.563 -                  val Plhs_to_Pxs_conv = 
   7.564 -                      foldl1 (uncurry Conv.combination_conv) 
   7.565 -                      (Conv.all_conv :: map (fn ch => K (Thm.symmetric (ch RS eq_reflection))) case_hyps)
   7.566 -
   7.567 -                  val res = assume step
   7.568 -                                   |> fold forall_elim cqs
   7.569 -                                   |> fold Thm.elim_implies ags
   7.570 -                                   |> fold Thm.elim_implies P_recs (* P lhs *) 
   7.571 -                                   |> Conv.fconv_rule (Conv.arg_conv Plhs_to_Pxs_conv) (* P xs *)
   7.572 -                                   |> fold_rev (implies_intr o cprop_of) (ags @ case_hyps)
   7.573 -                                   |> fold_rev forall_intr cqs (* !!qs. Gas ==> xs = lhss ==> P xs *)
   7.574 -                in
   7.575 -                  (res, (cidx, step))
   7.576 -                end
   7.577 -
   7.578 -            val (cases, steps) = split_list (map2 prove_case relevant_cases ineqss')
   7.579 -
   7.580 -            val bstep = complete_thm
   7.581 -                |> forall_elim (cert (list_comb (P, fxs)))
   7.582 -                |> fold (forall_elim o cert) (fxs @ map Free ws)
   7.583 -                |> fold Thm.elim_implies C_hyps             (* FIXME: optimization using rotate_prems *)
   7.584 -                |> fold Thm.elim_implies cases (* P xs *)
   7.585 -                |> fold_rev (implies_intr o cprop_of) C_hyps
   7.586 -                |> fold_rev (forall_intr o cert o Free) ws
   7.587 -
   7.588 -            val Pxs = cert (HOLogic.mk_Trueprop (P_comp $ x))
   7.589 -                     |> Goal.init
   7.590 -                     |> (MetaSimplifier.rewrite_goals_tac (map meta (branch_hyp :: @{thm split_conv} :: @{thms sum.cases}))
   7.591 -                         THEN CONVERSION ind_rulify 1)
   7.592 -                     |> Seq.hd
   7.593 -                     |> Thm.elim_implies (Conv.fconv_rule Drule.beta_eta_conversion bstep)
   7.594 -                     |> Goal.finish ctxt
   7.595 -                     |> implies_intr (cprop_of branch_hyp)
   7.596 -                     |> fold_rev (forall_intr o cert) fxs
   7.597 -          in
   7.598 -            (Pxs, steps)
   7.599 -          end
   7.600 -
   7.601 -      val (branches, steps) = split_list (map_index prove_branch (branches ~~ (complete_thms ~~ pats)))
   7.602 -                              |> apsnd flat
   7.603 -                           
   7.604 -      val istep = sum_split_rule
   7.605 -                |> fold (fn b => fn th => Drule.compose_single (b, 1, th)) branches
   7.606 -                |> implies_intr ihyp
   7.607 -                |> forall_intr (cert x) (* "!!x. (!!y<x. P y) ==> P x" *)
   7.608 -         
   7.609 -      val induct_rule =
   7.610 -          @{thm "wf_induct_rule"}
   7.611 -            |> (curry op COMP) wf_thm 
   7.612 -            |> (curry op COMP) istep
   7.613 -
   7.614 -      val steps_sorted = map snd (sort (int_ord o pairself fst) steps)
   7.615 -    in
   7.616 -      (steps_sorted, induct_rule)
   7.617 -    end
   7.618 -
   7.619 -
   7.620 -fun mk_ind_tac comp_tac pres_tac term_tac ctxt facts = (ALLGOALS (Method.insert_tac facts)) THEN HEADGOAL 
   7.621 -(SUBGOAL (fn (t, i) =>
   7.622 +fun mk_ind_tac comp_tac pres_tac term_tac ctxt facts =
   7.623 +  (ALLGOALS (Method.insert_tac facts)) THEN HEADGOAL (SUBGOAL (fn (t, i) =>
   7.624    let
   7.625      val (ctxt', _, cases, concl) = dest_hhf ctxt t
   7.626      val scheme as IndScheme {T=ST, branches, ...} = mk_scheme' ctxt' cases concl
   7.627 -(*     val _ = tracing (makestring scheme)*)
   7.628      val ([Rn,xn], ctxt'') = Variable.variant_fixes ["R","x"] ctxt'
   7.629      val R = Free (Rn, mk_relT ST)
   7.630      val x = Free (xn, ST)
   7.631      val cert = cterm_of (ProofContext.theory_of ctxt)
   7.632  
   7.633      val ineqss = mk_ineqs R scheme
   7.634 -                   |> map (map (pairself (assume o cert)))
   7.635 -    val complete = map_range (mk_completeness ctxt scheme #> cert #> assume) (length branches)
   7.636 +      |> map (map (pairself (assume o cert)))
   7.637 +    val complete =
   7.638 +      map_range (mk_completeness ctxt scheme #> cert #> assume) (length branches)
   7.639      val wf_thm = mk_wf R scheme |> cert |> assume
   7.640  
   7.641      val (descent, pres) = split_list (flat ineqss)
   7.642 -    val newgoals = complete @ pres @ wf_thm :: descent 
   7.643 +    val newgoals = complete @ pres @ wf_thm :: descent
   7.644  
   7.645 -    val (steps, indthm) = mk_induct_rule ctxt'' R x complete wf_thm ineqss scheme
   7.646 +    val (steps, indthm) =
   7.647 +      mk_induct_rule ctxt'' R x complete wf_thm ineqss scheme
   7.648  
   7.649      fun project (i, SchemeBranch {xs, ...}) =
   7.650 -        let
   7.651 -          val inst = cert (SumTree.mk_inj ST (length branches) (i + 1) (foldr1 HOLogic.mk_prod (map Free xs)))
   7.652 -        in
   7.653 -          indthm |> Drule.instantiate' [] [SOME inst]
   7.654 -                 |> simplify SumTree.sumcase_split_ss
   7.655 -                 |> Conv.fconv_rule ind_rulify
   7.656 -(*                 |> (fn thm => (tracing (makestring thm); thm))*)
   7.657 -        end                  
   7.658 +      let
   7.659 +        val inst = (foldr1 HOLogic.mk_prod (map Free xs))
   7.660 +          |> SumTree.mk_inj ST (length branches) (i + 1)
   7.661 +          |> cert
   7.662 +      in
   7.663 +        indthm
   7.664 +        |> Drule.instantiate' [] [SOME inst]
   7.665 +        |> simplify SumTree.sumcase_split_ss
   7.666 +        |> Conv.fconv_rule ind_rulify
   7.667 +      end
   7.668  
   7.669      val res = Conjunction.intr_balanced (map_index project branches)
   7.670 -                 |> fold_rev implies_intr (map cprop_of newgoals @ steps)
   7.671 -                 |> Drule.generalize ([], [Rn])
   7.672 +      |> fold_rev implies_intr (map cprop_of newgoals @ steps)
   7.673 +      |> Drule.generalize ([], [Rn])
   7.674  
   7.675      val nbranches = length branches
   7.676      val npres = length pres
     8.1 --- a/src/HOL/Tools/Function/lexicographic_order.ML	Sat Jan 02 23:18:58 2010 +0100
     8.2 +++ b/src/HOL/Tools/Function/lexicographic_order.ML	Sat Jan 02 23:18:58 2010 +0100
     8.3 @@ -21,26 +21,27 @@
     8.4  (** General stuff **)
     8.5  
     8.6  fun mk_measures domT mfuns =
     8.7 -    let 
     8.8 -        val relT = HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT))
     8.9 -        val mlexT = (domT --> HOLogic.natT) --> relT --> relT
    8.10 -        fun mk_ms [] = Const (@{const_name Set.empty}, relT)
    8.11 -          | mk_ms (f::fs) = 
    8.12 -            Const (@{const_name mlex_prod}, mlexT) $ f $ mk_ms fs
    8.13 -    in
    8.14 -        mk_ms mfuns
    8.15 -    end
    8.16 +  let
    8.17 +    val relT = HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT))
    8.18 +    val mlexT = (domT --> HOLogic.natT) --> relT --> relT
    8.19 +    fun mk_ms [] = Const (@{const_name Set.empty}, relT)
    8.20 +      | mk_ms (f::fs) =
    8.21 +        Const (@{const_name mlex_prod}, mlexT) $ f $ mk_ms fs
    8.22 +  in
    8.23 +    mk_ms mfuns
    8.24 +  end
    8.25  
    8.26  fun del_index n [] = []
    8.27    | del_index n (x :: xs) =
    8.28 -    if n > 0 then x :: del_index (n - 1) xs else xs
    8.29 +  if n > 0 then x :: del_index (n - 1) xs else xs
    8.30  
    8.31  fun transpose ([]::_) = []
    8.32    | transpose xss = map hd xss :: transpose (map tl xss)
    8.33  
    8.34  (** Matrix cell datatype **)
    8.35  
    8.36 -datatype cell = Less of thm| LessEq of (thm * thm) | None of (thm * thm) | False of thm;
    8.37 +datatype cell =
    8.38 +  Less of thm| LessEq of (thm * thm) | None of (thm * thm) | False of thm;
    8.39  
    8.40  fun is_Less (Less _) = true
    8.41    | is_Less _ = false
    8.42 @@ -57,39 +58,39 @@
    8.43  (** Proof attempts to build the matrix **)
    8.44  
    8.45  fun dest_term (t : term) =
    8.46 -    let
    8.47 -      val (vars, prop) = Function_Lib.dest_all_all t
    8.48 -      val (prems, concl) = Logic.strip_horn prop
    8.49 -      val (lhs, rhs) = concl
    8.50 -                         |> HOLogic.dest_Trueprop
    8.51 -                         |> HOLogic.dest_mem |> fst
    8.52 -                         |> HOLogic.dest_prod
    8.53 -    in
    8.54 -      (vars, prems, lhs, rhs)
    8.55 -    end
    8.56 +  let
    8.57 +    val (vars, prop) = Function_Lib.dest_all_all t
    8.58 +    val (prems, concl) = Logic.strip_horn prop
    8.59 +    val (lhs, rhs) = concl
    8.60 +      |> HOLogic.dest_Trueprop
    8.61 +      |> HOLogic.dest_mem |> fst
    8.62 +      |> HOLogic.dest_prod
    8.63 +  in
    8.64 +    (vars, prems, lhs, rhs)
    8.65 +  end
    8.66  
    8.67  fun mk_goal (vars, prems, lhs, rhs) rel =
    8.68 -    let
    8.69 -      val concl = HOLogic.mk_binrel rel (lhs, rhs) |> HOLogic.mk_Trueprop
    8.70 -    in
    8.71 -      fold_rev Logic.all vars (Logic.list_implies (prems, concl))
    8.72 -    end
    8.73 +  let
    8.74 +    val concl = HOLogic.mk_binrel rel (lhs, rhs) |> HOLogic.mk_Trueprop
    8.75 +  in
    8.76 +    fold_rev Logic.all vars (Logic.list_implies (prems, concl))
    8.77 +  end
    8.78  
    8.79  fun mk_cell (thy : theory) solve_tac (vars, prems, lhs, rhs) mfun =
    8.80 -    let
    8.81 -      val goals = cterm_of thy o mk_goal (vars, prems, mfun $ lhs, mfun $ rhs)
    8.82 -    in
    8.83 -      case try_proof (goals @{const_name HOL.less}) solve_tac of
    8.84 -        Solved thm => Less thm
    8.85 -      | Stuck thm => 
    8.86 -        (case try_proof (goals @{const_name HOL.less_eq}) solve_tac of
    8.87 -           Solved thm2 => LessEq (thm2, thm)
    8.88 -         | Stuck thm2 => 
    8.89 -           if prems_of thm2 = [HOLogic.Trueprop $ HOLogic.false_const] then False thm2
    8.90 -           else None (thm2, thm)
    8.91 -         | _ => raise Match) (* FIXME *)
    8.92 -      | _ => raise Match
    8.93 -    end
    8.94 +  let
    8.95 +    val goals = cterm_of thy o mk_goal (vars, prems, mfun $ lhs, mfun $ rhs)
    8.96 +  in
    8.97 +    case try_proof (goals @{const_name HOL.less}) solve_tac of
    8.98 +      Solved thm => Less thm
    8.99 +    | Stuck thm =>
   8.100 +      (case try_proof (goals @{const_name HOL.less_eq}) solve_tac of
   8.101 +         Solved thm2 => LessEq (thm2, thm)
   8.102 +       | Stuck thm2 =>
   8.103 +         if prems_of thm2 = [HOLogic.Trueprop $ HOLogic.false_const] then False thm2
   8.104 +         else None (thm2, thm)
   8.105 +       | _ => raise Match) (* FIXME *)
   8.106 +    | _ => raise Match
   8.107 +  end
   8.108  
   8.109  
   8.110  (** Search algorithms **)
   8.111 @@ -102,21 +103,21 @@
   8.112  
   8.113  (* simple depth-first search algorithm for the table *)
   8.114  fun search_table table =
   8.115 -    case table of
   8.116 -      [] => SOME []
   8.117 -    | _ =>
   8.118 -      let
   8.119 -        val col = find_index (check_col) (transpose table)
   8.120 -      in case col of
   8.121 -           ~1 => NONE
   8.122 -         | _ =>
   8.123 -           let
   8.124 -             val order_opt = (table, col) |-> transform_table |> search_table
   8.125 -           in case order_opt of
   8.126 -                NONE => NONE
   8.127 -              | SOME order =>SOME (col :: transform_order col order)
   8.128 -           end
   8.129 -      end
   8.130 +  case table of
   8.131 +    [] => SOME []
   8.132 +  | _ =>
   8.133 +    let
   8.134 +      val col = find_index (check_col) (transpose table)
   8.135 +    in case col of
   8.136 +         ~1 => NONE
   8.137 +       | _ =>
   8.138 +         let
   8.139 +           val order_opt = (table, col) |-> transform_table |> search_table
   8.140 +         in case order_opt of
   8.141 +              NONE => NONE
   8.142 +            | SOME order =>SOME (col :: transform_order col order)
   8.143 +         end
   8.144 +    end
   8.145  
   8.146  (** Proof Reconstruction **)
   8.147  
   8.148 @@ -134,9 +135,9 @@
   8.149  (** Error reporting **)
   8.150  
   8.151  fun pr_goals ctxt st =
   8.152 -    Goal_Display.pretty_goals ctxt {total = true, main = false, maxgoals = Thm.nprems_of st} st
   8.153 -     |> Pretty.chunks
   8.154 -     |> Pretty.string_of
   8.155 +  Goal_Display.pretty_goals ctxt {total = true, main = false, maxgoals = Thm.nprems_of st} st
   8.156 +  |> Pretty.chunks
   8.157 +  |> Pretty.string_of
   8.158  
   8.159  fun row_index i = chr (i + 97)
   8.160  fun col_index j = string_of_int (j + 1)
   8.161 @@ -151,65 +152,67 @@
   8.162        "(" ^ row_index i ^ ", " ^ col_index j ^ ", <):\n" ^ pr_goals ctxt st
   8.163  
   8.164  fun pr_unprovable_subgoals ctxt table =
   8.165 -    table
   8.166 -     |> map_index (fn (i,cs) => map_index (fn (j,x) => ((i,j), x)) cs)
   8.167 -     |> flat
   8.168 -     |> map (pr_unprovable_cell ctxt)
   8.169 +  table
   8.170 +  |> map_index (fn (i,cs) => map_index (fn (j,x) => ((i,j), x)) cs)
   8.171 +  |> flat
   8.172 +  |> map (pr_unprovable_cell ctxt)
   8.173  
   8.174  fun no_order_msg ctxt table tl measure_funs =
   8.175 -    let
   8.176 -      val prterm = Syntax.string_of_term ctxt
   8.177 -      fun pr_fun t i = string_of_int i ^ ") " ^ prterm t
   8.178 +  let
   8.179 +    val prterm = Syntax.string_of_term ctxt
   8.180 +    fun pr_fun t i = string_of_int i ^ ") " ^ prterm t
   8.181  
   8.182 -      fun pr_goal t i =
   8.183 -          let
   8.184 -            val (_, _, lhs, rhs) = dest_term t
   8.185 -          in (* also show prems? *)
   8.186 -               i ^ ") " ^ prterm rhs ^ " ~> " ^ prterm lhs
   8.187 -          end
   8.188 +    fun pr_goal t i =
   8.189 +      let
   8.190 +        val (_, _, lhs, rhs) = dest_term t
   8.191 +      in (* also show prems? *)
   8.192 +           i ^ ") " ^ prterm rhs ^ " ~> " ^ prterm lhs
   8.193 +      end
   8.194  
   8.195 -      val gc = map (fn i => chr (i + 96)) (1 upto length table)
   8.196 -      val mc = 1 upto length measure_funs
   8.197 -      val tstr = "Result matrix:" ::  ("   " ^ implode (map (enclose " " " " o string_of_int) mc))
   8.198 -                 :: map2 (fn r => fn i => i ^ ": " ^ implode (map pr_cell r)) table gc
   8.199 -      val gstr = "Calls:" :: map2 (prefix "  " oo pr_goal) tl gc
   8.200 -      val mstr = "Measures:" :: map2 (prefix "  " oo pr_fun) measure_funs mc
   8.201 -      val ustr = "Unfinished subgoals:" :: pr_unprovable_subgoals ctxt table
   8.202 -    in
   8.203 -      cat_lines (ustr @ gstr @ mstr @ tstr @ ["", "Could not find lexicographic termination order."])
   8.204 -    end
   8.205 +    val gc = map (fn i => chr (i + 96)) (1 upto length table)
   8.206 +    val mc = 1 upto length measure_funs
   8.207 +    val tstr = "Result matrix:" ::  ("   " ^ implode (map (enclose " " " " o string_of_int) mc))
   8.208 +      :: map2 (fn r => fn i => i ^ ": " ^ implode (map pr_cell r)) table gc
   8.209 +    val gstr = "Calls:" :: map2 (prefix "  " oo pr_goal) tl gc
   8.210 +    val mstr = "Measures:" :: map2 (prefix "  " oo pr_fun) measure_funs mc
   8.211 +    val ustr = "Unfinished subgoals:" :: pr_unprovable_subgoals ctxt table
   8.212 +  in
   8.213 +    cat_lines (ustr @ gstr @ mstr @ tstr @
   8.214 +    ["", "Could not find lexicographic termination order."])
   8.215 +  end
   8.216  
   8.217  (** The Main Function **)
   8.218  
   8.219  fun lex_order_tac quiet ctxt solve_tac (st: thm) =
   8.220 -    let
   8.221 -      val thy = ProofContext.theory_of ctxt
   8.222 -      val ((_ $ (_ $ rel)) :: tl) = prems_of st
   8.223 +  let
   8.224 +    val thy = ProofContext.theory_of ctxt
   8.225 +    val ((_ $ (_ $ rel)) :: tl) = prems_of st
   8.226  
   8.227 -      val (domT, _) = HOLogic.dest_prodT (HOLogic.dest_setT (fastype_of rel))
   8.228 +    val (domT, _) = HOLogic.dest_prodT (HOLogic.dest_setT (fastype_of rel))
   8.229  
   8.230 -      val measure_funs = MeasureFunctions.get_measure_functions ctxt domT (* 1: generate measures *)
   8.231 +    val measure_funs = (* 1: generate measures *)
   8.232 +      MeasureFunctions.get_measure_functions ctxt domT
   8.233  
   8.234 -      (* 2: create table *)
   8.235 -      val table = Par_List.map (fn t => Par_List.map (mk_cell thy solve_tac (dest_term t)) measure_funs) tl
   8.236 -    in
   8.237 -      case search_table table of
   8.238 -        NONE => if quiet then no_tac st else error (no_order_msg ctxt table tl measure_funs)
   8.239 -      | SOME order =>
   8.240 -          let 
   8.241 -            val clean_table = map (fn x => map (nth x) order) table
   8.242 -            val relation = mk_measures domT (map (nth measure_funs) order)
   8.243 -            val _ = if not quiet
   8.244 -              then writeln ("Found termination order: " ^ quote (Syntax.string_of_term ctxt relation))
   8.245 -              else ()
   8.246 +    val table = (* 2: create table *)
   8.247 +      Par_List.map (fn t => Par_List.map (mk_cell thy solve_tac (dest_term t)) measure_funs) tl
   8.248 +  in
   8.249 +    case search_table table of
   8.250 +      NONE => if quiet then no_tac st else error (no_order_msg ctxt table tl measure_funs)
   8.251 +    | SOME order =>
   8.252 +      let
   8.253 +        val clean_table = map (fn x => map (nth x) order) table
   8.254 +        val relation = mk_measures domT (map (nth measure_funs) order)
   8.255 +        val _ = if not quiet
   8.256 +          then writeln ("Found termination order: " ^ quote (Syntax.string_of_term ctxt relation))
   8.257 +          else ()
   8.258  
   8.259 -          in (* 4: proof reconstruction *)
   8.260 -            st |> (PRIMITIVE (cterm_instantiate [(cterm_of thy rel, cterm_of thy relation)])
   8.261 -            THEN (REPEAT (rtac @{thm "wf_mlex"} 1))
   8.262 -            THEN (rtac @{thm "wf_empty"} 1)
   8.263 -            THEN EVERY (map prove_row clean_table))
   8.264 -          end
   8.265 -    end
   8.266 +      in (* 4: proof reconstruction *)
   8.267 +        st |> (PRIMITIVE (cterm_instantiate [(cterm_of thy rel, cterm_of thy relation)])
   8.268 +        THEN (REPEAT (rtac @{thm "wf_mlex"} 1))
   8.269 +        THEN (rtac @{thm "wf_empty"} 1)
   8.270 +        THEN EVERY (map prove_row clean_table))
   8.271 +      end
   8.272 +  end
   8.273  
   8.274  fun lexicographic_order_tac quiet ctxt =
   8.275    TRY (Function_Common.apply_termination_rule ctxt 1)
   8.276 @@ -225,4 +228,3 @@
   8.277    #> Context.theory_map (Function_Common.set_termination_prover lexicographic_order)
   8.278  
   8.279  end;
   8.280 -
     9.1 --- a/src/HOL/Tools/Function/measure_functions.ML	Sat Jan 02 23:18:58 2010 +0100
     9.2 +++ b/src/HOL/Tools/Function/measure_functions.ML	Sat Jan 02 23:18:58 2010 +0100
     9.3 @@ -8,26 +8,28 @@
     9.4  sig
     9.5  
     9.6    val get_measure_functions : Proof.context -> typ -> term list
     9.7 -  val setup : theory -> theory                                                      
     9.8 +  val setup : theory -> theory
     9.9  
    9.10  end
    9.11  
    9.12 -structure MeasureFunctions : MEASURE_FUNCTIONS = 
    9.13 -struct 
    9.14 +structure MeasureFunctions : MEASURE_FUNCTIONS =
    9.15 +struct
    9.16  
    9.17  (** User-declared size functions **)
    9.18  structure Measure_Heuristic_Rules = Named_Thms
    9.19  (
    9.20 -  val name = "measure_function" 
    9.21 -  val description = "Rules that guide the heuristic generation of measure functions"
    9.22 +  val name = "measure_function"
    9.23 +  val description =
    9.24 +    "Rules that guide the heuristic generation of measure functions"
    9.25  );
    9.26  
    9.27 -fun mk_is_measures t = Const (@{const_name is_measure}, fastype_of t --> HOLogic.boolT) $ t
    9.28 +fun mk_is_measure t =
    9.29 +  Const (@{const_name is_measure}, fastype_of t --> HOLogic.boolT) $ t
    9.30  
    9.31  fun find_measures ctxt T =
    9.32 -  DEPTH_SOLVE (resolve_tac (Measure_Heuristic_Rules.get ctxt) 1) 
    9.33 -    (HOLogic.mk_Trueprop (mk_is_measures (Var (("f",0), T --> HOLogic.natT)))
    9.34 -      |> cterm_of (ProofContext.theory_of ctxt) |> Goal.init)
    9.35 +  DEPTH_SOLVE (resolve_tac (Measure_Heuristic_Rules.get ctxt) 1)
    9.36 +    (HOLogic.mk_Trueprop (mk_is_measure (Var (("f",0), T --> HOLogic.natT)))
    9.37 +     |> cterm_of (ProofContext.theory_of ctxt) |> Goal.init)
    9.38    |> Seq.map (prop_of #> (fn _ $ (_ $ (_ $ f)) => f))
    9.39    |> Seq.list_of
    9.40  
    9.41 @@ -38,13 +40,13 @@
    9.42  fun constant_1 T = Abs ("x", T, HOLogic.Suc_zero)
    9.43  
    9.44  fun mk_funorder_funs (Type ("+", [fT, sT])) =
    9.45 -      map (fn m => SumTree.mk_sumcase fT sT HOLogic.natT m (constant_0 sT)) (mk_funorder_funs fT)
    9.46 -    @ map (fn m => SumTree.mk_sumcase fT sT HOLogic.natT (constant_0 fT) m) (mk_funorder_funs sT)
    9.47 +  map (fn m => SumTree.mk_sumcase fT sT HOLogic.natT m (constant_0 sT)) (mk_funorder_funs fT)
    9.48 +  @ map (fn m => SumTree.mk_sumcase fT sT HOLogic.natT (constant_0 fT) m) (mk_funorder_funs sT)
    9.49    | mk_funorder_funs T = [ constant_1 T ]
    9.50  
    9.51  fun mk_ext_base_funs ctxt (Type ("+", [fT, sT])) =
    9.52 -      map_product (SumTree.mk_sumcase fT sT HOLogic.natT)
    9.53 -                  (mk_ext_base_funs ctxt fT) (mk_ext_base_funs ctxt sT)
    9.54 +    map_product (SumTree.mk_sumcase fT sT HOLogic.natT)
    9.55 +      (mk_ext_base_funs ctxt fT) (mk_ext_base_funs ctxt sT)
    9.56    | mk_ext_base_funs ctxt T = find_measures ctxt T
    9.57  
    9.58  fun mk_all_measure_funs ctxt (T as Type ("+", _)) =
    9.59 @@ -56,4 +58,3 @@
    9.60  val setup = Measure_Heuristic_Rules.setup
    9.61  
    9.62  end
    9.63 -
    10.1 --- a/src/HOL/Tools/Function/mutual.ML	Sat Jan 02 23:18:58 2010 +0100
    10.2 +++ b/src/HOL/Tools/Function/mutual.ML	Sat Jan 02 23:18:58 2010 +0100
    10.3 @@ -9,13 +9,13 @@
    10.4  sig
    10.5  
    10.6    val prepare_function_mutual : Function_Common.function_config
    10.7 -                              -> string (* defname *)
    10.8 -                              -> ((string * typ) * mixfix) list
    10.9 -                              -> term list
   10.10 -                              -> local_theory
   10.11 -                              -> ((thm (* goalstate *)
   10.12 -                                   * (thm -> Function_Common.function_result) (* proof continuation *)
   10.13 -                                  ) * local_theory)
   10.14 +    -> string (* defname *)
   10.15 +    -> ((string * typ) * mixfix) list
   10.16 +    -> term list
   10.17 +    -> local_theory
   10.18 +    -> ((thm (* goalstate *)
   10.19 +        * (thm -> Function_Common.function_result) (* proof continuation *)
   10.20 +       ) * local_theory)
   10.21  
   10.22  end
   10.23  
   10.24 @@ -28,282 +28,269 @@
   10.25  
   10.26  type qgar = string * (string * typ) list * term list * term list * term
   10.27  
   10.28 -datatype mutual_part =
   10.29 -  MutualPart of 
   10.30 -   {
   10.31 -    i : int,
   10.32 -    i' : int,
   10.33 -    fvar : string * typ,
   10.34 -    cargTs: typ list,
   10.35 -    f_def: term,
   10.36 +datatype mutual_part = MutualPart of
   10.37 + {i : int,
   10.38 +  i' : int,
   10.39 +  fvar : string * typ,
   10.40 +  cargTs: typ list,
   10.41 +  f_def: term,
   10.42  
   10.43 -    f: term option,
   10.44 -    f_defthm : thm option
   10.45 -   }
   10.46 -   
   10.47 +  f: term option,
   10.48 +  f_defthm : thm option}
   10.49  
   10.50 -datatype mutual_info =
   10.51 -  Mutual of 
   10.52 -   { 
   10.53 -    n : int,
   10.54 -    n' : int,
   10.55 -    fsum_var : string * typ,
   10.56 +datatype mutual_info = Mutual of
   10.57 + {n : int,
   10.58 +  n' : int,
   10.59 +  fsum_var : string * typ,
   10.60  
   10.61 -    ST: typ,
   10.62 -    RST: typ,
   10.63 +  ST: typ,
   10.64 +  RST: typ,
   10.65  
   10.66 -    parts: mutual_part list,
   10.67 -    fqgars: qgar list,
   10.68 -    qglrs: ((string * typ) list * term list * term * term) list,
   10.69 +  parts: mutual_part list,
   10.70 +  fqgars: qgar list,
   10.71 +  qglrs: ((string * typ) list * term list * term * term) list,
   10.72  
   10.73 -    fsum : term option
   10.74 -   }
   10.75 +  fsum : term option}
   10.76  
   10.77  fun mutual_induct_Pnames n =
   10.78 -    if n < 5 then fst (chop n ["P","Q","R","S"])
   10.79 -    else map (fn i => "P" ^ string_of_int i) (1 upto n)
   10.80 +  if n < 5 then fst (chop n ["P","Q","R","S"])
   10.81 +  else map (fn i => "P" ^ string_of_int i) (1 upto n)
   10.82  
   10.83  fun get_part fname =
   10.84 -    the o find_first (fn (MutualPart {fvar=(n,_), ...}) => n = fname)
   10.85 -                     
   10.86 +  the o find_first (fn (MutualPart {fvar=(n,_), ...}) => n = fname)
   10.87 +
   10.88  (* FIXME *)
   10.89  fun mk_prod_abs e (t1, t2) =
   10.90 -    let
   10.91 -      val bTs = rev (map snd e)
   10.92 -      val T1 = fastype_of1 (bTs, t1)
   10.93 -      val T2 = fastype_of1 (bTs, t2)
   10.94 -    in
   10.95 -      HOLogic.pair_const T1 T2 $ t1 $ t2
   10.96 -    end;
   10.97 -
   10.98 +  let
   10.99 +    val bTs = rev (map snd e)
  10.100 +    val T1 = fastype_of1 (bTs, t1)
  10.101 +    val T2 = fastype_of1 (bTs, t2)
  10.102 +  in
  10.103 +    HOLogic.pair_const T1 T2 $ t1 $ t2
  10.104 +  end
  10.105  
  10.106  fun analyze_eqs ctxt defname fs eqs =
  10.107 -    let
  10.108 -      val num = length fs
  10.109 -        val fqgars = map (split_def ctxt) eqs
  10.110 -        val arity_of = map (fn (fname,_,_,args,_) => (fname, length args)) fqgars
  10.111 -                       |> AList.lookup (op =) #> the
  10.112 +  let
  10.113 +    val num = length fs
  10.114 +    val fqgars = map (split_def ctxt) eqs
  10.115 +    val arity_of = map (fn (fname,_,_,args,_) => (fname, length args)) fqgars
  10.116 +      |> AList.lookup (op =) #> the
  10.117  
  10.118 -        fun curried_types (fname, fT) =
  10.119 -            let
  10.120 -              val (caTs, uaTs) = chop (arity_of fname) (binder_types fT)
  10.121 -            in
  10.122 -                (caTs, uaTs ---> body_type fT)
  10.123 -            end
  10.124 +    fun curried_types (fname, fT) =
  10.125 +      let
  10.126 +        val (caTs, uaTs) = chop (arity_of fname) (binder_types fT)
  10.127 +      in
  10.128 +        (caTs, uaTs ---> body_type fT)
  10.129 +      end
  10.130  
  10.131 -        val (caTss, resultTs) = split_list (map curried_types fs)
  10.132 -        val argTs = map (foldr1 HOLogic.mk_prodT) caTss
  10.133 +    val (caTss, resultTs) = split_list (map curried_types fs)
  10.134 +    val argTs = map (foldr1 HOLogic.mk_prodT) caTss
  10.135  
  10.136 -        val dresultTs = distinct (op =) resultTs
  10.137 -        val n' = length dresultTs
  10.138 +    val dresultTs = distinct (op =) resultTs
  10.139 +    val n' = length dresultTs
  10.140  
  10.141 -        val RST = Balanced_Tree.make (uncurry SumTree.mk_sumT) dresultTs
  10.142 -        val ST = Balanced_Tree.make (uncurry SumTree.mk_sumT) argTs
  10.143 +    val RST = Balanced_Tree.make (uncurry SumTree.mk_sumT) dresultTs
  10.144 +    val ST = Balanced_Tree.make (uncurry SumTree.mk_sumT) argTs
  10.145  
  10.146 -        val fsum_type = ST --> RST
  10.147 +    val fsum_type = ST --> RST
  10.148  
  10.149 -        val ([fsum_var_name], _) = Variable.add_fixes [ defname ^ "_sum" ] ctxt
  10.150 -        val fsum_var = (fsum_var_name, fsum_type)
  10.151 +    val ([fsum_var_name], _) = Variable.add_fixes [ defname ^ "_sum" ] ctxt
  10.152 +    val fsum_var = (fsum_var_name, fsum_type)
  10.153  
  10.154 -        fun define (fvar as (n, _)) caTs resultT i =
  10.155 -            let
  10.156 -                val vars = map_index (fn (j,T) => Free ("x" ^ string_of_int j, T)) caTs (* FIXME: Bind xs properly *)
  10.157 -                val i' = find_index (fn Ta => Ta = resultT) dresultTs + 1 
  10.158 +    fun define (fvar as (n, _)) caTs resultT i =
  10.159 +      let
  10.160 +        val vars = map_index (fn (j,T) => Free ("x" ^ string_of_int j, T)) caTs (* FIXME: Bind xs properly *)
  10.161 +        val i' = find_index (fn Ta => Ta = resultT) dresultTs + 1
  10.162  
  10.163 -                val f_exp = SumTree.mk_proj RST n' i' (Free fsum_var $ SumTree.mk_inj ST num i (foldr1 HOLogic.mk_prod vars))
  10.164 -                val def = Term.abstract_over (Free fsum_var, fold_rev lambda vars f_exp)
  10.165 +        val f_exp = SumTree.mk_proj RST n' i' (Free fsum_var $ SumTree.mk_inj ST num i (foldr1 HOLogic.mk_prod vars))
  10.166 +        val def = Term.abstract_over (Free fsum_var, fold_rev lambda vars f_exp)
  10.167  
  10.168 -                val rew = (n, fold_rev lambda vars f_exp)
  10.169 -            in
  10.170 -                (MutualPart {i=i, i'=i', fvar=fvar,cargTs=caTs,f_def=def,f=NONE,f_defthm=NONE}, rew)
  10.171 -            end
  10.172 -            
  10.173 -        val (parts, rews) = split_list (map4 define fs caTss resultTs (1 upto num))
  10.174 +        val rew = (n, fold_rev lambda vars f_exp)
  10.175 +      in
  10.176 +        (MutualPart {i=i, i'=i', fvar=fvar,cargTs=caTs,f_def=def,f=NONE,f_defthm=NONE}, rew)
  10.177 +      end
  10.178 +
  10.179 +    val (parts, rews) = split_list (map4 define fs caTss resultTs (1 upto num))
  10.180  
  10.181 -        fun convert_eqs (f, qs, gs, args, rhs) =
  10.182 -            let
  10.183 -              val MutualPart {i, i', ...} = get_part f parts
  10.184 -            in
  10.185 -              (qs, gs, SumTree.mk_inj ST num i (foldr1 (mk_prod_abs qs) args),
  10.186 -               SumTree.mk_inj RST n' i' (replace_frees rews rhs)
  10.187 -                               |> Envir.beta_norm)
  10.188 -            end
  10.189 +    fun convert_eqs (f, qs, gs, args, rhs) =
  10.190 +      let
  10.191 +        val MutualPart {i, i', ...} = get_part f parts
  10.192 +      in
  10.193 +        (qs, gs, SumTree.mk_inj ST num i (foldr1 (mk_prod_abs qs) args),
  10.194 +         SumTree.mk_inj RST n' i' (replace_frees rews rhs)
  10.195 +         |> Envir.beta_norm)
  10.196 +      end
  10.197  
  10.198 -        val qglrs = map convert_eqs fqgars
  10.199 -    in
  10.200 -        Mutual {n=num, n'=n', fsum_var=fsum_var, ST=ST, RST=RST, 
  10.201 -                parts=parts, fqgars=fqgars, qglrs=qglrs, fsum=NONE}
  10.202 -    end
  10.203 -
  10.204 -
  10.205 -
  10.206 +    val qglrs = map convert_eqs fqgars
  10.207 +  in
  10.208 +    Mutual {n=num, n'=n', fsum_var=fsum_var, ST=ST, RST=RST,
  10.209 +      parts=parts, fqgars=fqgars, qglrs=qglrs, fsum=NONE}
  10.210 +  end
  10.211  
  10.212  fun define_projections fixes mutual fsum lthy =
  10.213 -    let
  10.214 -      fun def ((MutualPart {i=i, i'=i', fvar=(fname, fT), cargTs, f_def, ...}), (_, mixfix)) lthy =
  10.215 -          let
  10.216 -            val ((f, (_, f_defthm)), lthy') =
  10.217 -              Local_Theory.define
  10.218 -                ((Binding.name fname, mixfix),
  10.219 -                  ((Binding.conceal (Binding.name (fname ^ "_def")), []),
  10.220 -                  Term.subst_bound (fsum, f_def))) lthy
  10.221 -          in
  10.222 -            (MutualPart {i=i, i'=i', fvar=(fname, fT), cargTs=cargTs, f_def=f_def,
  10.223 -                         f=SOME f, f_defthm=SOME f_defthm },
  10.224 -             lthy')
  10.225 -          end
  10.226 -          
  10.227 -      val Mutual { n, n', fsum_var, ST, RST, parts, fqgars, qglrs, ... } = mutual
  10.228 -      val (parts', lthy') = fold_map def (parts ~~ fixes) lthy
  10.229 -    in
  10.230 -      (Mutual { n=n, n'=n', fsum_var=fsum_var, ST=ST, RST=RST, parts=parts',
  10.231 -                fqgars=fqgars, qglrs=qglrs, fsum=SOME fsum },
  10.232 -       lthy')
  10.233 -    end
  10.234 +  let
  10.235 +    fun def ((MutualPart {i=i, i'=i', fvar=(fname, fT), cargTs, f_def, ...}), (_, mixfix)) lthy =
  10.236 +      let
  10.237 +        val ((f, (_, f_defthm)), lthy') =
  10.238 +          Local_Theory.define
  10.239 +            ((Binding.name fname, mixfix),
  10.240 +              ((Binding.conceal (Binding.name (fname ^ "_def")), []),
  10.241 +              Term.subst_bound (fsum, f_def))) lthy
  10.242 +      in
  10.243 +        (MutualPart {i=i, i'=i', fvar=(fname, fT), cargTs=cargTs, f_def=f_def,
  10.244 +           f=SOME f, f_defthm=SOME f_defthm },
  10.245 +         lthy')
  10.246 +      end
  10.247  
  10.248 +    val Mutual { n, n', fsum_var, ST, RST, parts, fqgars, qglrs, ... } = mutual
  10.249 +    val (parts', lthy') = fold_map def (parts ~~ fixes) lthy
  10.250 +  in
  10.251 +    (Mutual { n=n, n'=n', fsum_var=fsum_var, ST=ST, RST=RST, parts=parts',
  10.252 +       fqgars=fqgars, qglrs=qglrs, fsum=SOME fsum },
  10.253 +     lthy')
  10.254 +  end
  10.255  
  10.256  fun in_context ctxt (f, pre_qs, pre_gs, pre_args, pre_rhs) F =
  10.257 -    let
  10.258 -      val thy = ProofContext.theory_of ctxt
  10.259 -                
  10.260 -      val oqnames = map fst pre_qs
  10.261 -      val (qs, _) = Variable.variant_fixes oqnames ctxt
  10.262 -        |>> map2 (fn (_, T) => fn n => Free (n, T)) pre_qs
  10.263 -                        
  10.264 -      fun inst t = subst_bounds (rev qs, t)
  10.265 -      val gs = map inst pre_gs
  10.266 -      val args = map inst pre_args
  10.267 -      val rhs = inst pre_rhs
  10.268 +  let
  10.269 +    val thy = ProofContext.theory_of ctxt
  10.270 +
  10.271 +    val oqnames = map fst pre_qs
  10.272 +    val (qs, _) = Variable.variant_fixes oqnames ctxt
  10.273 +      |>> map2 (fn (_, T) => fn n => Free (n, T)) pre_qs
  10.274 +
  10.275 +    fun inst t = subst_bounds (rev qs, t)
  10.276 +    val gs = map inst pre_gs
  10.277 +    val args = map inst pre_args
  10.278 +    val rhs = inst pre_rhs
  10.279  
  10.280 -      val cqs = map (cterm_of thy) qs
  10.281 -      val ags = map (assume o cterm_of thy) gs
  10.282 +    val cqs = map (cterm_of thy) qs
  10.283 +    val ags = map (assume o cterm_of thy) gs
  10.284  
  10.285 -      val import = fold forall_elim cqs
  10.286 -                   #> fold Thm.elim_implies ags
  10.287 +    val import = fold forall_elim cqs
  10.288 +      #> fold Thm.elim_implies ags
  10.289  
  10.290 -      val export = fold_rev (implies_intr o cprop_of) ags
  10.291 -                   #> fold_rev forall_intr_rename (oqnames ~~ cqs)
  10.292 -    in
  10.293 -      F ctxt (f, qs, gs, args, rhs) import export
  10.294 -    end
  10.295 -
  10.296 -fun recover_mutual_psimp all_orig_fdefs parts ctxt (fname, _, _, args, rhs) import (export : thm -> thm) sum_psimp_eq =
  10.297 -    let
  10.298 -      val (MutualPart {f=SOME f, ...}) = get_part fname parts
  10.299 +    val export = fold_rev (implies_intr o cprop_of) ags
  10.300 +      #> fold_rev forall_intr_rename (oqnames ~~ cqs)
  10.301 +  in
  10.302 +    F ctxt (f, qs, gs, args, rhs) import export
  10.303 +  end
  10.304  
  10.305 -      val psimp = import sum_psimp_eq
  10.306 -      val (simp, restore_cond) = case cprems_of psimp of
  10.307 -                                   [] => (psimp, I)
  10.308 -                                 | [cond] => (implies_elim psimp (assume cond), implies_intr cond)
  10.309 -                                 | _ => sys_error "Too many conditions"
  10.310 -    in
  10.311 -      Goal.prove ctxt [] [] 
  10.312 -                 (HOLogic.Trueprop $ HOLogic.mk_eq (list_comb (f, args), rhs))
  10.313 -                 (fn _ => (LocalDefs.unfold_tac ctxt all_orig_fdefs)
  10.314 -                          THEN EqSubst.eqsubst_tac ctxt [0] [simp] 1
  10.315 -                          THEN (simp_tac (simpset_of ctxt addsimps SumTree.proj_in_rules)) 1)
  10.316 -        |> restore_cond 
  10.317 -        |> export
  10.318 -    end
  10.319 +fun recover_mutual_psimp all_orig_fdefs parts ctxt (fname, _, _, args, rhs)
  10.320 +  import (export : thm -> thm) sum_psimp_eq =
  10.321 +  let
  10.322 +    val (MutualPart {f=SOME f, ...}) = get_part fname parts
  10.323 +
  10.324 +    val psimp = import sum_psimp_eq
  10.325 +    val (simp, restore_cond) =
  10.326 +      case cprems_of psimp of
  10.327 +        [] => (psimp, I)
  10.328 +      | [cond] => (implies_elim psimp (assume cond), implies_intr cond)
  10.329 +      | _ => sys_error "Too many conditions"
  10.330  
  10.331 +  in
  10.332 +    Goal.prove ctxt [] []
  10.333 +      (HOLogic.Trueprop $ HOLogic.mk_eq (list_comb (f, args), rhs))
  10.334 +      (fn _ => (LocalDefs.unfold_tac ctxt all_orig_fdefs)
  10.335 +         THEN EqSubst.eqsubst_tac ctxt [0] [simp] 1
  10.336 +         THEN (simp_tac (simpset_of ctxt addsimps SumTree.proj_in_rules)) 1)
  10.337 +    |> restore_cond
  10.338 +    |> export
  10.339 +  end
  10.340  
  10.341 -(* FIXME HACK *)
  10.342  fun mk_applied_form ctxt caTs thm =
  10.343 -    let
  10.344 -      val thy = ProofContext.theory_of ctxt
  10.345 -      val xs = map_index (fn (i,T) => cterm_of thy (Free ("x" ^ string_of_int i, T))) caTs (* FIXME: Bind xs properly *)
  10.346 -    in
  10.347 -      fold (fn x => fn thm => combination thm (reflexive x)) xs thm
  10.348 -           |> Conv.fconv_rule (Thm.beta_conversion true)
  10.349 -           |> fold_rev forall_intr xs
  10.350 -           |> Thm.forall_elim_vars 0
  10.351 -    end
  10.352 -
  10.353 +  let
  10.354 +    val thy = ProofContext.theory_of ctxt
  10.355 +    val xs = map_index (fn (i,T) => cterm_of thy (Free ("x" ^ string_of_int i, T))) caTs (* FIXME: Bind xs properly *)
  10.356 +  in
  10.357 +    fold (fn x => fn thm => combination thm (reflexive x)) xs thm
  10.358 +    |> Conv.fconv_rule (Thm.beta_conversion true)
  10.359 +    |> fold_rev forall_intr xs
  10.360 +    |> Thm.forall_elim_vars 0
  10.361 +  end
  10.362  
  10.363  fun mutual_induct_rules lthy induct all_f_defs (Mutual {n, ST, parts, ...}) =
  10.364 -    let
  10.365 -      val cert = cterm_of (ProofContext.theory_of lthy)
  10.366 -      val newPs = map2 (fn Pname => fn MutualPart {cargTs, ...} => 
  10.367 -                                       Free (Pname, cargTs ---> HOLogic.boolT))
  10.368 -                       (mutual_induct_Pnames (length parts))
  10.369 -                       parts
  10.370 -                       
  10.371 -      fun mk_P (MutualPart {cargTs, ...}) P =
  10.372 -          let
  10.373 -            val avars = map_index (fn (i,T) => Var (("a", i), T)) cargTs
  10.374 -            val atup = foldr1 HOLogic.mk_prod avars
  10.375 -          in
  10.376 -            tupled_lambda atup (list_comb (P, avars))
  10.377 -          end
  10.378 -          
  10.379 -      val Ps = map2 mk_P parts newPs
  10.380 -      val case_exp = SumTree.mk_sumcases HOLogic.boolT Ps
  10.381 -                     
  10.382 -      val induct_inst =
  10.383 -          forall_elim (cert case_exp) induct
  10.384 -                      |> full_simplify SumTree.sumcase_split_ss
  10.385 -                      |> full_simplify (HOL_basic_ss addsimps all_f_defs)
  10.386 -          
  10.387 -      fun project rule (MutualPart {cargTs, i, ...}) k =
  10.388 -          let
  10.389 -            val afs = map_index (fn (j,T) => Free ("a" ^ string_of_int (j + k), T)) cargTs (* FIXME! *)
  10.390 -            val inj = SumTree.mk_inj ST n i (foldr1 HOLogic.mk_prod afs)
  10.391 -          in
  10.392 -            (rule
  10.393 -              |> forall_elim (cert inj)
  10.394 -              |> full_simplify SumTree.sumcase_split_ss
  10.395 -              |> fold_rev (forall_intr o cert) (afs @ newPs),
  10.396 -             k + length cargTs)
  10.397 -          end
  10.398 -    in
  10.399 -      fst (fold_map (project induct_inst) parts 0)
  10.400 -    end
  10.401 -    
  10.402 +  let
  10.403 +    val cert = cterm_of (ProofContext.theory_of lthy)
  10.404 +    val newPs =
  10.405 +      map2 (fn Pname => fn MutualPart {cargTs, ...} =>
  10.406 +          Free (Pname, cargTs ---> HOLogic.boolT))
  10.407 +        (mutual_induct_Pnames (length parts)) parts
  10.408 +
  10.409 +    fun mk_P (MutualPart {cargTs, ...}) P =
  10.410 +      let
  10.411 +        val avars = map_index (fn (i,T) => Var (("a", i), T)) cargTs
  10.412 +        val atup = foldr1 HOLogic.mk_prod avars
  10.413 +      in
  10.414 +        tupled_lambda atup (list_comb (P, avars))
  10.415 +      end
  10.416 +
  10.417 +    val Ps = map2 mk_P parts newPs
  10.418 +    val case_exp = SumTree.mk_sumcases HOLogic.boolT Ps
  10.419 +
  10.420 +    val induct_inst =
  10.421 +      forall_elim (cert case_exp) induct
  10.422 +      |> full_simplify SumTree.sumcase_split_ss
  10.423 +      |> full_simplify (HOL_basic_ss addsimps all_f_defs)
  10.424 +
  10.425 +    fun project rule (MutualPart {cargTs, i, ...}) k =
  10.426 +      let
  10.427 +        val afs = map_index (fn (j,T) => Free ("a" ^ string_of_int (j + k), T)) cargTs (* FIXME! *)
  10.428 +        val inj = SumTree.mk_inj ST n i (foldr1 HOLogic.mk_prod afs)
  10.429 +      in
  10.430 +        (rule
  10.431 +         |> forall_elim (cert inj)
  10.432 +         |> full_simplify SumTree.sumcase_split_ss
  10.433 +         |> fold_rev (forall_intr o cert) (afs @ newPs),
  10.434 +         k + length cargTs)
  10.435 +      end
  10.436 +  in
  10.437 +    fst (fold_map (project induct_inst) parts 0)
  10.438 +  end
  10.439  
  10.440  fun mk_partial_rules_mutual lthy inner_cont (m as Mutual {parts, fqgars, ...}) proof =
  10.441 -    let
  10.442 -      val result = inner_cont proof
  10.443 -      val FunctionResult {G, R, cases, psimps, trsimps, simple_pinducts=[simple_pinduct],
  10.444 -        termination, domintros, ...} = result
  10.445 -                                                                                                               
  10.446 -      val (all_f_defs, fs) = map (fn MutualPart {f_defthm = SOME f_def, f = SOME f, cargTs, ...} =>
  10.447 -                                     (mk_applied_form lthy cargTs (symmetric f_def), f))
  10.448 -                                 parts
  10.449 -                             |> split_list
  10.450 +  let
  10.451 +    val result = inner_cont proof
  10.452 +    val FunctionResult {G, R, cases, psimps, trsimps, simple_pinducts=[simple_pinduct],
  10.453 +      termination, domintros, ...} = result
  10.454 +
  10.455 +    val (all_f_defs, fs) =
  10.456 +      map (fn MutualPart {f_defthm = SOME f_def, f = SOME f, cargTs, ...} =>
  10.457 +        (mk_applied_form lthy cargTs (symmetric f_def), f))
  10.458 +      parts
  10.459 +      |> split_list
  10.460 +
  10.461 +    val all_orig_fdefs =
  10.462 +      map (fn MutualPart {f_defthm = SOME f_def, ...} => f_def) parts
  10.463 +
  10.464 +    fun mk_mpsimp fqgar sum_psimp =
  10.465 +      in_context lthy fqgar (recover_mutual_psimp all_orig_fdefs parts) sum_psimp
  10.466  
  10.467 -      val all_orig_fdefs = map (fn MutualPart {f_defthm = SOME f_def, ...} => f_def) parts
  10.468 -                           
  10.469 -      fun mk_mpsimp fqgar sum_psimp =
  10.470 -          in_context lthy fqgar (recover_mutual_psimp all_orig_fdefs parts) sum_psimp
  10.471 -          
  10.472 -      val rew_ss = HOL_basic_ss addsimps all_f_defs
  10.473 -      val mpsimps = map2 mk_mpsimp fqgars psimps
  10.474 -      val mtrsimps = map_option (map2 mk_mpsimp fqgars) trsimps
  10.475 -      val minducts = mutual_induct_rules lthy simple_pinduct all_f_defs m
  10.476 -      val mtermination = full_simplify rew_ss termination
  10.477 -      val mdomintros = map_option (map (full_simplify rew_ss)) domintros
  10.478 -    in
  10.479 -      FunctionResult { fs=fs, G=G, R=R,
  10.480 -                     psimps=mpsimps, simple_pinducts=minducts,
  10.481 -                     cases=cases, termination=mtermination,
  10.482 -                     domintros=mdomintros,
  10.483 -                     trsimps=mtrsimps}
  10.484 -    end
  10.485 -      
  10.486 +    val rew_ss = HOL_basic_ss addsimps all_f_defs
  10.487 +    val mpsimps = map2 mk_mpsimp fqgars psimps
  10.488 +    val mtrsimps = map_option (map2 mk_mpsimp fqgars) trsimps
  10.489 +    val minducts = mutual_induct_rules lthy simple_pinduct all_f_defs m
  10.490 +    val mtermination = full_simplify rew_ss termination
  10.491 +    val mdomintros = map_option (map (full_simplify rew_ss)) domintros
  10.492 +  in
  10.493 +    FunctionResult { fs=fs, G=G, R=R,
  10.494 +      psimps=mpsimps, simple_pinducts=minducts,
  10.495 +      cases=cases, termination=mtermination,
  10.496 +      domintros=mdomintros, trsimps=mtrsimps}
  10.497 +  end
  10.498 +
  10.499  fun prepare_function_mutual config defname fixes eqss lthy =
  10.500 -    let
  10.501 -      val mutual = analyze_eqs lthy defname (map fst fixes) (map Envir.beta_eta_contract eqss)
  10.502 -      val Mutual {fsum_var=(n, T), qglrs, ...} = mutual
  10.503 -          
  10.504 -      val ((fsum, goalstate, cont), lthy') =
  10.505 -          Function_Core.prepare_function config defname [((n, T), NoSyn)] qglrs lthy
  10.506 -          
  10.507 -      val (mutual', lthy'') = define_projections fixes mutual fsum lthy'
  10.508 +  let
  10.509 +    val mutual as Mutual {fsum_var=(n, T), qglrs, ...} =
  10.510 +      analyze_eqs lthy defname (map fst fixes) (map Envir.beta_eta_contract eqss)
  10.511 +
  10.512 +    val ((fsum, goalstate, cont), lthy') =
  10.513 +      Function_Core.prepare_function config defname [((n, T), NoSyn)] qglrs lthy
  10.514  
  10.515 -      val mutual_cont = mk_partial_rules_mutual lthy'' cont mutual'
  10.516 -    in
  10.517 -      ((goalstate, mutual_cont), lthy'')
  10.518 -    end
  10.519 +    val (mutual', lthy'') = define_projections fixes mutual fsum lthy'
  10.520  
  10.521 -    
  10.522 +    val mutual_cont = mk_partial_rules_mutual lthy'' cont mutual'
  10.523 +  in
  10.524 +    ((goalstate, mutual_cont), lthy'')
  10.525 +  end
  10.526 +
  10.527  end
    11.1 --- a/src/HOL/Tools/Function/pattern_split.ML	Sat Jan 02 23:18:58 2010 +0100
    11.2 +++ b/src/HOL/Tools/Function/pattern_split.ML	Sat Jan 02 23:18:58 2010 +0100
    11.3 @@ -1,10 +1,7 @@
    11.4  (*  Title:      HOL/Tools/Function/pattern_split.ML
    11.5      Author:     Alexander Krauss, TU Muenchen
    11.6  
    11.7 -A package for general recursive function definitions.
    11.8 -
    11.9 -Automatic splitting of overlapping constructor patterns. This is a preprocessing step which
   11.10 -turns a specification with overlaps into an overlap-free specification.
   11.11 +Fairly ad-hoc pattern splitting.
   11.12  
   11.13  *)
   11.14  
   11.15 @@ -22,114 +19,102 @@
   11.16  
   11.17  open Function_Lib
   11.18  
   11.19 -(* We use proof context for the variable management *)
   11.20 -(* FIXME: no __ *)
   11.21 -
   11.22  fun new_var ctx vs T =
   11.23 -    let
   11.24 -      val [v] = Variable.variant_frees ctx vs [("v", T)]
   11.25 -    in
   11.26 -      (Free v :: vs, Free v)
   11.27 -    end
   11.28 +  let
   11.29 +    val [v] = Variable.variant_frees ctx vs [("v", T)]
   11.30 +  in
   11.31 +    (Free v :: vs, Free v)
   11.32 +  end
   11.33  
   11.34  fun saturate ctx vs t =
   11.35 -    fold (fn T => fn (vs, t) => new_var ctx vs T |> apsnd (curry op $ t))
   11.36 -         (binder_types (fastype_of t)) (vs, t)
   11.37 -         
   11.38 -         
   11.39 -(* This is copied from "fundef_datatype.ML" *)
   11.40 +  fold (fn T => fn (vs, t) => new_var ctx vs T |> apsnd (curry op $ t))
   11.41 +    (binder_types (fastype_of t)) (vs, t)
   11.42 +
   11.43 +
   11.44 +(* This is copied from "pat_completeness.ML" *)
   11.45  fun inst_constrs_of thy (T as Type (name, _)) =
   11.46 -    map (fn (Cn,CT) =>
   11.47 -          Envir.subst_term_types (Sign.typ_match thy (body_type CT, T) Vartab.empty) (Const (Cn, CT)))
   11.48 -        (the (Datatype.get_constrs thy name))
   11.49 +  map (fn (Cn,CT) =>
   11.50 +    Envir.subst_term_types (Sign.typ_match thy (body_type CT, T) Vartab.empty) (Const (Cn, CT)))
   11.51 +    (the (Datatype.get_constrs thy name))
   11.52    | inst_constrs_of thy T = raise TYPE ("inst_constrs_of", [T], [])
   11.53 -                            
   11.54 -                            
   11.55 -                            
   11.56 +
   11.57  
   11.58  fun join ((vs1,sub1), (vs2,sub2)) = (merge (op aconv) (vs1,vs2), sub1 @ sub2)
   11.59  fun join_product (xs, ys) = map_product (curry join) xs ys
   11.60  
   11.61 -
   11.62  exception DISJ
   11.63  
   11.64  fun pattern_subtract_subst ctx vs t t' =
   11.65 -    let
   11.66 -      exception DISJ
   11.67 -      fun pattern_subtract_subst_aux vs _ (Free v2) = []
   11.68 -        | pattern_subtract_subst_aux vs (v as (Free (_, T))) t' =
   11.69 +  let
   11.70 +    exception DISJ
   11.71 +    fun pattern_subtract_subst_aux vs _ (Free v2) = []
   11.72 +      | pattern_subtract_subst_aux vs (v as (Free (_, T))) t' =
   11.73 +      let
   11.74 +        fun foo constr =
   11.75            let
   11.76 -            fun foo constr =
   11.77 -                let
   11.78 -                  val (vs', t) = saturate ctx vs constr
   11.79 -                  val substs = pattern_subtract_subst ctx vs' t t'
   11.80 -                in
   11.81 -                  map (fn (vs, subst) => (vs, (v,t)::subst)) substs
   11.82 -                end
   11.83 +            val (vs', t) = saturate ctx vs constr
   11.84 +            val substs = pattern_subtract_subst ctx vs' t t'
   11.85            in
   11.86 -            maps foo (inst_constrs_of (ProofContext.theory_of ctx) T)
   11.87 +            map (fn (vs, subst) => (vs, (v,t)::subst)) substs
   11.88            end
   11.89 -        | pattern_subtract_subst_aux vs t t' =
   11.90 -          let
   11.91 -            val (C, ps) = strip_comb t
   11.92 -            val (C', qs) = strip_comb t'
   11.93 -          in
   11.94 -            if C = C'
   11.95 -            then flat (map2 (pattern_subtract_subst_aux vs) ps qs)
   11.96 -            else raise DISJ
   11.97 -          end
   11.98 -    in
   11.99 -      pattern_subtract_subst_aux vs t t'
  11.100 -      handle DISJ => [(vs, [])]
  11.101 -    end
  11.102 -
  11.103 +      in
  11.104 +        maps foo (inst_constrs_of (ProofContext.theory_of ctx) T)
  11.105 +      end
  11.106 +     | pattern_subtract_subst_aux vs t t' =
  11.107 +     let
  11.108 +       val (C, ps) = strip_comb t
  11.109 +       val (C', qs) = strip_comb t'
  11.110 +     in
  11.111 +       if C = C'
  11.112 +       then flat (map2 (pattern_subtract_subst_aux vs) ps qs)
  11.113 +       else raise DISJ
  11.114 +     end
  11.115 +  in
  11.116 +    pattern_subtract_subst_aux vs t t'
  11.117 +    handle DISJ => [(vs, [])]
  11.118 +  end
  11.119  
  11.120  (* p - q *)
  11.121  fun pattern_subtract ctx eq2 eq1 =
  11.122 -    let
  11.123 -      val thy = ProofContext.theory_of ctx
  11.124 -                
  11.125 -      val (vs, feq1 as (_ $ (_ $ lhs1 $ _))) = dest_all_all eq1
  11.126 -      val (_,  _ $ (_ $ lhs2 $ _)) = dest_all_all eq2
  11.127 -                                     
  11.128 -      val substs = pattern_subtract_subst ctx vs lhs1 lhs2
  11.129 -                   
  11.130 -      fun instantiate (vs', sigma) =
  11.131 -          let
  11.132 -            val t = Pattern.rewrite_term thy sigma [] feq1
  11.133 -          in
  11.134 -            fold_rev Logic.all (inter (op =) vs' (map Free (frees_in_term ctx t))) t
  11.135 -          end
  11.136 -    in
  11.137 -      map instantiate substs
  11.138 -    end
  11.139 -      
  11.140 +  let
  11.141 +    val thy = ProofContext.theory_of ctx
  11.142 +
  11.143 +    val (vs, feq1 as (_ $ (_ $ lhs1 $ _))) = dest_all_all eq1
  11.144 +    val (_,  _ $ (_ $ lhs2 $ _)) = dest_all_all eq2
  11.145 +
  11.146 +    val substs = pattern_subtract_subst ctx vs lhs1 lhs2
  11.147 +
  11.148 +    fun instantiate (vs', sigma) =
  11.149 +      let
  11.150 +        val t = Pattern.rewrite_term thy sigma [] feq1
  11.151 +      in
  11.152 +        fold_rev Logic.all (inter (op =) vs' (map Free (frees_in_term ctx t))) t
  11.153 +      end
  11.154 +  in
  11.155 +    map instantiate substs
  11.156 +  end
  11.157  
  11.158  (* ps - p' *)
  11.159  fun pattern_subtract_from_many ctx p'=
  11.160 -    maps (pattern_subtract ctx p')
  11.161 +  maps (pattern_subtract ctx p')
  11.162  
  11.163  (* in reverse order *)
  11.164  fun pattern_subtract_many ctx ps' =
  11.165 -    fold_rev (pattern_subtract_from_many ctx) ps'
  11.166 -
  11.167 -
  11.168 +  fold_rev (pattern_subtract_from_many ctx) ps'
  11.169  
  11.170  fun split_some_equations ctx eqns =
  11.171 -    let
  11.172 -      fun split_aux prev [] = []
  11.173 -        | split_aux prev ((true, eq) :: es) = pattern_subtract_many ctx prev [eq]
  11.174 -                                              :: split_aux (eq :: prev) es
  11.175 -        | split_aux prev ((false, eq) :: es) = [eq]
  11.176 -                                               :: split_aux (eq :: prev) es
  11.177 -    in
  11.178 -      split_aux [] eqns
  11.179 -    end
  11.180 -    
  11.181 +  let
  11.182 +    fun split_aux prev [] = []
  11.183 +      | split_aux prev ((true, eq) :: es) =
  11.184 +        pattern_subtract_many ctx prev [eq] :: split_aux (eq :: prev) es
  11.185 +      | split_aux prev ((false, eq) :: es) =
  11.186 +        [eq] :: split_aux (eq :: prev) es
  11.187 +  in
  11.188 +    split_aux [] eqns
  11.189 +  end
  11.190 +
  11.191  fun split_all_equations ctx =
  11.192 -    split_some_equations ctx o map (pair true)
  11.193 -
  11.194 -
  11.195 +  split_some_equations ctx o map (pair true)
  11.196  
  11.197  
  11.198  end
    12.1 --- a/src/HOL/Tools/Function/relation.ML	Sat Jan 02 23:18:58 2010 +0100
    12.2 +++ b/src/HOL/Tools/Function/relation.ML	Sat Jan 02 23:18:58 2010 +0100
    12.3 @@ -15,18 +15,18 @@
    12.4  struct
    12.5  
    12.6  fun inst_thm ctxt rel st =
    12.7 -    let
    12.8 -      val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
    12.9 -      val rel' = cert (singleton (Variable.polymorphic ctxt) rel)
   12.10 -      val st' = Thm.incr_indexes (#maxidx (Thm.rep_cterm rel') + 1) st
   12.11 -      val Rvar = cert (Var (the_single (Term.add_vars (prop_of st') [])))
   12.12 -    in 
   12.13 -      Drule.cterm_instantiate [(Rvar, rel')] st' 
   12.14 -    end
   12.15 +  let
   12.16 +    val cert = Thm.cterm_of (ProofContext.theory_of ctxt)
   12.17 +    val rel' = cert (singleton (Variable.polymorphic ctxt) rel)
   12.18 +    val st' = Thm.incr_indexes (#maxidx (Thm.rep_cterm rel') + 1) st
   12.19 +    val Rvar = cert (Var (the_single (Term.add_vars (prop_of st') [])))
   12.20 +  in
   12.21 +    Drule.cterm_instantiate [(Rvar, rel')] st'
   12.22 +  end
   12.23  
   12.24 -fun relation_tac ctxt rel i = 
   12.25 -    TRY (Function_Common.apply_termination_rule ctxt i)
   12.26 -    THEN PRIMITIVE (inst_thm ctxt rel)
   12.27 +fun relation_tac ctxt rel i =
   12.28 +  TRY (Function_Common.apply_termination_rule ctxt i)
   12.29 +  THEN PRIMITIVE (inst_thm ctxt rel)
   12.30  
   12.31  val setup =
   12.32    Method.setup @{binding relation}
    13.1 --- a/src/HOL/Tools/Function/sum_tree.ML	Sat Jan 02 23:18:58 2010 +0100
    13.2 +++ b/src/HOL/Tools/Function/sum_tree.ML	Sat Jan 02 23:18:58 2010 +0100
    13.3 @@ -9,35 +9,43 @@
    13.4  
    13.5  (* Theory dependencies *)
    13.6  val proj_in_rules = [@{thm Projl_Inl}, @{thm Projr_Inr}]
    13.7 -val sumcase_split_ss = HOL_basic_ss addsimps (@{thm Product_Type.split} :: @{thms sum.cases})
    13.8 +val sumcase_split_ss =
    13.9 +  HOL_basic_ss addsimps (@{thm Product_Type.split} :: @{thms sum.cases})
   13.10  
   13.11  (* top-down access in balanced tree *)
   13.12  fun access_top_down {left, right, init} len i =
   13.13 -    Balanced_Tree.access {left = (fn f => f o left), right = (fn f => f o right), init = I} len i init
   13.14 +  Balanced_Tree.access
   13.15 +    {left = (fn f => f o left), right = (fn f => f o right), init = I} len i init
   13.16  
   13.17  (* Sum types *)
   13.18  fun mk_sumT LT RT = Type ("+", [LT, RT])
   13.19 -fun mk_sumcase TL TR T l r = Const (@{const_name sum.sum_case}, (TL --> T) --> (TR --> T) --> mk_sumT TL TR --> T) $ l $ r
   13.20 +fun mk_sumcase TL TR T l r =
   13.21 +  Const (@{const_name sum.sum_case},
   13.22 +    (TL --> T) --> (TR --> T) --> mk_sumT TL TR --> T) $ l $ r
   13.23  
   13.24  val App = curry op $
   13.25  
   13.26 -fun mk_inj ST n i = 
   13.27 -    access_top_down 
   13.28 -    { init = (ST, I : term -> term),
   13.29 -      left = (fn (T as Type ("+", [LT, RT]), inj) => (LT, inj o App (Const (@{const_name Inl}, LT --> T)))),
   13.30 -      right =(fn (T as Type ("+", [LT, RT]), inj) => (RT, inj o App (Const (@{const_name Inr}, RT --> T))))} n i 
   13.31 -    |> snd
   13.32 +fun mk_inj ST n i =
   13.33 +  access_top_down
   13.34 +  { init = (ST, I : term -> term),
   13.35 +    left = (fn (T as Type ("+", [LT, RT]), inj) =>
   13.36 +      (LT, inj o App (Const (@{const_name Inl}, LT --> T)))),
   13.37 +    right =(fn (T as Type ("+", [LT, RT]), inj) =>
   13.38 +      (RT, inj o App (Const (@{const_name Inr}, RT --> T))))} n i
   13.39 +  |> snd
   13.40  
   13.41 -fun mk_proj ST n i = 
   13.42 -    access_top_down 
   13.43 -    { init = (ST, I : term -> term),
   13.44 -      left = (fn (T as Type ("+", [LT, RT]), proj) => (LT, App (Const (@{const_name Sum_Type.Projl}, T --> LT)) o proj)),
   13.45 -      right =(fn (T as Type ("+", [LT, RT]), proj) => (RT, App (Const (@{const_name Sum_Type.Projr}, T --> RT)) o proj))} n i
   13.46 -    |> snd
   13.47 +fun mk_proj ST n i =
   13.48 +  access_top_down
   13.49 +  { init = (ST, I : term -> term),
   13.50 +    left = (fn (T as Type ("+", [LT, RT]), proj) =>
   13.51 +      (LT, App (Const (@{const_name Sum_Type.Projl}, T --> LT)) o proj)),
   13.52 +    right =(fn (T as Type ("+", [LT, RT]), proj) =>
   13.53 +      (RT, App (Const (@{const_name Sum_Type.Projr}, T --> RT)) o proj))} n i
   13.54 +  |> snd
   13.55  
   13.56  fun mk_sumcases T fs =
   13.57 -      Balanced_Tree.make (fn ((f, fT), (g, gT)) => (mk_sumcase fT gT T f g, mk_sumT fT gT)) 
   13.58 -                        (map (fn f => (f, domain_type (fastype_of f))) fs)
   13.59 -      |> fst
   13.60 +  Balanced_Tree.make (fn ((f, fT), (g, gT)) => (mk_sumcase fT gT T f g, mk_sumT fT gT)) 
   13.61 +    (map (fn f => (f, domain_type (fastype_of f))) fs)
   13.62 +  |> fst
   13.63  
   13.64  end
    14.1 --- a/src/HOL/Tools/Function/termination.ML	Sat Jan 02 23:18:58 2010 +0100
    14.2 +++ b/src/HOL/Tools/Function/termination.ML	Sat Jan 02 23:18:58 2010 +0100
    14.3 @@ -245,66 +245,65 @@
    14.4  (* A tactic to convert open to closed termination goals *)
    14.5  local
    14.6  fun dest_term (t : term) = (* FIXME, cf. Lexicographic order *)
    14.7 -    let
    14.8 -      val (vars, prop) = Function_Lib.dest_all_all t
    14.9 -      val (prems, concl) = Logic.strip_horn prop
   14.10 -      val (lhs, rhs) = concl
   14.11 -                         |> HOLogic.dest_Trueprop
   14.12 -                         |> HOLogic.dest_mem |> fst
   14.13 -                         |> HOLogic.dest_prod
   14.14 -    in
   14.15 -      (vars, prems, lhs, rhs)
   14.16 -    end
   14.17 +  let
   14.18 +    val (vars, prop) = Function_Lib.dest_all_all t
   14.19 +    val (prems, concl) = Logic.strip_horn prop
   14.20 +    val (lhs, rhs) = concl
   14.21 +      |> HOLogic.dest_Trueprop
   14.22 +      |> HOLogic.dest_mem |> fst
   14.23 +      |> HOLogic.dest_prod
   14.24 +  in
   14.25 +    (vars, prems, lhs, rhs)
   14.26 +  end
   14.27  
   14.28  fun mk_pair_compr (T, qs, l, r, conds) =
   14.29 -    let
   14.30 -      val pT = HOLogic.mk_prodT (T, T)
   14.31 -      val n = length qs
   14.32 -      val peq = HOLogic.eq_const pT $ Bound n $ (HOLogic.pair_const T T $ l $ r)
   14.33 -      val conds' = if null conds then [HOLogic.true_const] else conds
   14.34 -    in
   14.35 -      HOLogic.Collect_const pT $
   14.36 -      Abs ("uu_", pT,
   14.37 -           (foldr1 HOLogic.mk_conj (peq :: conds')
   14.38 -            |> fold_rev (fn v => fn t => HOLogic.exists_const (fastype_of v) $ lambda v t) qs))
   14.39 -    end
   14.40 +  let
   14.41 +    val pT = HOLogic.mk_prodT (T, T)
   14.42 +    val n = length qs
   14.43 +    val peq = HOLogic.eq_const pT $ Bound n $ (HOLogic.pair_const T T $ l $ r)
   14.44 +    val conds' = if null conds then [HOLogic.true_const] else conds
   14.45 +  in
   14.46 +    HOLogic.Collect_const pT $
   14.47 +    Abs ("uu_", pT,
   14.48 +      (foldr1 HOLogic.mk_conj (peq :: conds')
   14.49 +      |> fold_rev (fn v => fn t => HOLogic.exists_const (fastype_of v) $ lambda v t) qs))
   14.50 +  end
   14.51  
   14.52  in
   14.53  
   14.54  fun wf_union_tac ctxt st =
   14.55 -    let
   14.56 -      val thy = ProofContext.theory_of ctxt
   14.57 -      val cert = cterm_of (theory_of_thm st)
   14.58 -      val ((_ $ (_ $ rel)) :: ineqs) = prems_of st
   14.59 +  let
   14.60 +    val thy = ProofContext.theory_of ctxt
   14.61 +    val cert = cterm_of (theory_of_thm st)
   14.62 +    val ((_ $ (_ $ rel)) :: ineqs) = prems_of st
   14.63  
   14.64 -      fun mk_compr ineq =
   14.65 -          let
   14.66 -            val (vars, prems, lhs, rhs) = dest_term ineq
   14.67 -          in
   14.68 -            mk_pair_compr (fastype_of lhs, vars, lhs, rhs, map (ObjectLogic.atomize_term thy) prems)
   14.69 -          end
   14.70 +    fun mk_compr ineq =
   14.71 +      let
   14.72 +        val (vars, prems, lhs, rhs) = dest_term ineq
   14.73 +      in
   14.74 +        mk_pair_compr (fastype_of lhs, vars, lhs, rhs, map (ObjectLogic.atomize_term thy) prems)
   14.75 +      end
   14.76  
   14.77 -      val relation =
   14.78 -          if null ineqs then
   14.79 -              Const (@{const_name Set.empty}, fastype_of rel)
   14.80 -          else
   14.81 -              foldr1 (HOLogic.mk_binop @{const_name Lattices.sup}) (map mk_compr ineqs)
   14.82 +    val relation =
   14.83 +      if null ineqs
   14.84 +      then Const (@{const_name Set.empty}, fastype_of rel)
   14.85 +      else map mk_compr ineqs
   14.86 +        |> foldr1 (HOLogic.mk_binop @{const_name Lattices.sup})
   14.87  
   14.88 -      fun solve_membership_tac i =
   14.89 -          (EVERY' (replicate (i - 2) (rtac @{thm UnI2}))  (* pick the right component of the union *)
   14.90 -          THEN' (fn j => TRY (rtac @{thm UnI1} j))
   14.91 -          THEN' (rtac @{thm CollectI})                    (* unfold comprehension *)
   14.92 -          THEN' (fn i => REPEAT (rtac @{thm exI} i))      (* Turn existentials into schematic Vars *)
   14.93 -          THEN' ((rtac @{thm refl})                       (* unification instantiates all Vars *)
   14.94 -                 ORELSE' ((rtac @{thm conjI})
   14.95 -                          THEN' (rtac @{thm refl})
   14.96 -                          THEN' (blast_tac (claset_of ctxt))))  (* Solve rest of context... not very elegant *)
   14.97 -          ) i
   14.98 -    in
   14.99 -      ((PRIMITIVE (Drule.cterm_instantiate [(cert rel, cert relation)])
  14.100 -      THEN ALLGOALS (fn i => if i = 1 then all_tac else solve_membership_tac i))) st
  14.101 -    end
  14.102 -
  14.103 +    fun solve_membership_tac i =
  14.104 +      (EVERY' (replicate (i - 2) (rtac @{thm UnI2}))  (* pick the right component of the union *)
  14.105 +      THEN' (fn j => TRY (rtac @{thm UnI1} j))
  14.106 +      THEN' (rtac @{thm CollectI})                    (* unfold comprehension *)
  14.107 +      THEN' (fn i => REPEAT (rtac @{thm exI} i))      (* Turn existentials into schematic Vars *)
  14.108 +      THEN' ((rtac @{thm refl})                       (* unification instantiates all Vars *)
  14.109 +        ORELSE' ((rtac @{thm conjI})
  14.110 +          THEN' (rtac @{thm refl})
  14.111 +          THEN' (blast_tac (claset_of ctxt))))  (* Solve rest of context... not very elegant *)
  14.112 +      ) i
  14.113 +  in
  14.114 +    ((PRIMITIVE (Drule.cterm_instantiate [(cert rel, cert relation)])
  14.115 +     THEN ALLGOALS (fn i => if i = 1 then all_tac else solve_membership_tac i))) st
  14.116 +  end
  14.117  
  14.118  end
  14.119  
  14.120 @@ -332,67 +331,65 @@
  14.121  
  14.122  fun derive_chains ctxt chain_tac cont D = CALLS (fn (cs, i) =>
  14.123    let
  14.124 -      val thy = ProofContext.theory_of ctxt
  14.125 +    val thy = ProofContext.theory_of ctxt
  14.126  
  14.127 -      fun derive_chain c1 c2 D =
  14.128 -        if is_some (get_chain D c1 c2) then D else
  14.129 -        note_chain c1 c2 (prove_chain thy chain_tac c1 c2) D
  14.130 +    fun derive_chain c1 c2 D =
  14.131 +      if is_some (get_chain D c1 c2) then D else
  14.132 +      note_chain c1 c2 (prove_chain thy chain_tac c1 c2) D
  14.133    in
  14.134      cont (fold_product derive_chain cs cs D) i
  14.135    end)
  14.136  
  14.137  
  14.138  fun mk_dgraph D cs =
  14.139 -    TermGraph.empty
  14.140 -    |> fold (fn c => TermGraph.new_node (c,())) cs
  14.141 -    |> fold_product (fn c1 => fn c2 =>
  14.142 -         if is_none (get_chain D c1 c2 |> the_default NONE)
  14.143 -         then TermGraph.add_edge (c1, c2) else I)
  14.144 -       cs cs
  14.145 -
  14.146 +  TermGraph.empty
  14.147 +  |> fold (fn c => TermGraph.new_node (c,())) cs
  14.148 +  |> fold_product (fn c1 => fn c2 =>
  14.149 +     if is_none (get_chain D c1 c2 |> the_default NONE)
  14.150 +     then TermGraph.add_edge (c1, c2) else I)
  14.151 +     cs cs
  14.152  
  14.153  fun ucomp_empty_tac T =
  14.154 -    REPEAT_ALL_NEW (rtac @{thm union_comp_emptyR}
  14.155 -                    ORELSE' rtac @{thm union_comp_emptyL}
  14.156 -                    ORELSE' SUBGOAL (fn (_ $ (_ $ (_ $ c1 $ c2) $ _), i) => rtac (T c1 c2) i))
  14.157 +  REPEAT_ALL_NEW (rtac @{thm union_comp_emptyR}
  14.158 +    ORELSE' rtac @{thm union_comp_emptyL}
  14.159 +    ORELSE' SUBGOAL (fn (_ $ (_ $ (_ $ c1 $ c2) $ _), i) => rtac (T c1 c2) i))
  14.160  
  14.161  fun regroup_calls_tac cs = CALLS (fn (cs', i) =>
  14.162 -   let
  14.163 -     val is = map (fn c => find_index (curry op aconv c) cs') cs
  14.164 -   in
  14.165 -     CONVERSION (Conv.arg_conv (Conv.arg_conv (Function_Lib.regroup_union_conv is))) i
  14.166 -   end)
  14.167 + let
  14.168 +   val is = map (fn c => find_index (curry op aconv c) cs') cs
  14.169 + in
  14.170 +   CONVERSION (Conv.arg_conv (Conv.arg_conv
  14.171 +     (Function_Lib.regroup_union_conv is))) i
  14.172 + end)
  14.173  
  14.174  
  14.175 -fun solve_trivial_tac D = CALLS
  14.176 -(fn ([c], i) =>
  14.177 -    (case get_chain D c c of
  14.178 -       SOME (SOME thm) => rtac @{thm wf_no_loop} i
  14.179 -                          THEN rtac thm i
  14.180 -     | _ => no_tac)
  14.181 +fun solve_trivial_tac D = CALLS (fn ([c], i) =>
  14.182 +  (case get_chain D c c of
  14.183 +     SOME (SOME thm) => rtac @{thm wf_no_loop} i
  14.184 +                        THEN rtac thm i
  14.185 +   | _ => no_tac)
  14.186    | _ => no_tac)
  14.187  
  14.188  fun decompose_tac' cont err_cont D = CALLS (fn (cs, i) =>
  14.189 -    let
  14.190 -      val G = mk_dgraph D cs
  14.191 -      val sccs = TermGraph.strong_conn G
  14.192 +  let
  14.193 +    val G = mk_dgraph D cs
  14.194 +    val sccs = TermGraph.strong_conn G
  14.195  
  14.196 -      fun split [SCC] i = (solve_trivial_tac D i ORELSE cont D i)
  14.197 -        | split (SCC::rest) i =
  14.198 -            regroup_calls_tac SCC i
  14.199 -            THEN rtac @{thm wf_union_compatible} i
  14.200 -            THEN rtac @{thm less_by_empty} (i + 2)
  14.201 -            THEN ucomp_empty_tac (the o the oo get_chain D) (i + 2)
  14.202 -            THEN split rest (i + 1)
  14.203 -            THEN (solve_trivial_tac D i ORELSE cont D i)
  14.204 -    in
  14.205 -      if length sccs > 1 then split sccs i
  14.206 -      else solve_trivial_tac D i ORELSE err_cont D i
  14.207 -    end)
  14.208 +    fun split [SCC] i = (solve_trivial_tac D i ORELSE cont D i)
  14.209 +      | split (SCC::rest) i =
  14.210 +        regroup_calls_tac SCC i
  14.211 +        THEN rtac @{thm wf_union_compatible} i
  14.212 +        THEN rtac @{thm less_by_empty} (i + 2)
  14.213 +        THEN ucomp_empty_tac (the o the oo get_chain D) (i + 2)
  14.214 +        THEN split rest (i + 1)
  14.215 +        THEN (solve_trivial_tac D i ORELSE cont D i)
  14.216 +  in
  14.217 +    if length sccs > 1 then split sccs i
  14.218 +    else solve_trivial_tac D i ORELSE err_cont D i
  14.219 +  end)
  14.220  
  14.221  fun decompose_tac ctxt chain_tac cont err_cont =
  14.222 -    derive_chains ctxt chain_tac
  14.223 -    (decompose_tac' cont err_cont)
  14.224 +  derive_chains ctxt chain_tac (decompose_tac' cont err_cont)
  14.225  
  14.226  
  14.227  (*** Local Descent Proofs ***)