moved sources;
authorwenzelm
Fri Jun 19 19:13:15 2015 +0200 (2015-06-19)
changeset 6052009fc5eaa21ce
parent 60519 84b8e5c2580e
child 60521 52e956416fbf
moved sources;
src/HOL/Library/Old_Recdef.thy
src/HOL/Library/old_recdef.ML
src/HOL/Tools/TFL/casesplit.ML
src/HOL/Tools/TFL/dcterm.ML
src/HOL/Tools/TFL/post.ML
src/HOL/Tools/TFL/rules.ML
src/HOL/Tools/TFL/tfl.ML
src/HOL/Tools/TFL/thms.ML
src/HOL/Tools/TFL/thry.ML
src/HOL/Tools/TFL/usyntax.ML
src/HOL/Tools/TFL/utils.ML
src/HOL/Tools/recdef.ML
     1.1 --- a/src/HOL/Library/Old_Recdef.thy	Fri Jun 19 18:41:21 2015 +0200
     1.2 +++ b/src/HOL/Library/Old_Recdef.thy	Fri Jun 19 19:13:15 2015 +0200
     1.3 @@ -14,7 +14,7 @@
     1.4  
     1.5  subsection \<open>Lemmas for TFL\<close>
     1.6  
     1.7 -lemma tfl_wf_induct: "ALL R. wf R -->  
     1.8 +lemma tfl_wf_induct: "ALL R. wf R -->
     1.9         (ALL P. (ALL x. (ALL y. (y,x):R --> P y) --> P x) --> (ALL x. P x))"
    1.10  apply clarify
    1.11  apply (rule_tac r = R and P = P and a = x in wf_induct, assumption, blast)
    1.12 @@ -58,16 +58,7 @@
    1.13  lemma tfl_exE: "\<exists>x. P x ==> \<forall>x. P x --> Q ==> Q"
    1.14    by blast
    1.15  
    1.16 -ML_file "~~/src/HOL/Tools/TFL/casesplit.ML"
    1.17 -ML_file "~~/src/HOL/Tools/TFL/utils.ML"
    1.18 -ML_file "~~/src/HOL/Tools/TFL/usyntax.ML"
    1.19 -ML_file "~~/src/HOL/Tools/TFL/dcterm.ML"
    1.20 -ML_file "~~/src/HOL/Tools/TFL/thms.ML"
    1.21 -ML_file "~~/src/HOL/Tools/TFL/rules.ML"
    1.22 -ML_file "~~/src/HOL/Tools/TFL/thry.ML"
    1.23 -ML_file "~~/src/HOL/Tools/TFL/tfl.ML"
    1.24 -ML_file "~~/src/HOL/Tools/TFL/post.ML"
    1.25 -ML_file "~~/src/HOL/Tools/recdef.ML"
    1.26 +ML_file "old_recdef.ML"
    1.27  
    1.28  
    1.29  subsection \<open>Rule setup\<close>
    1.30 @@ -81,7 +72,7 @@
    1.31  
    1.32  lemmas [recdef_cong] =
    1.33    if_cong let_cong image_cong INF_cong SUP_cong bex_cong ball_cong imp_cong
    1.34 -  map_cong filter_cong takeWhile_cong dropWhile_cong foldl_cong foldr_cong 
    1.35 +  map_cong filter_cong takeWhile_cong dropWhile_cong foldl_cong foldr_cong
    1.36  
    1.37  lemmas [recdef_wf] =
    1.38    wf_trancl
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/Library/old_recdef.ML	Fri Jun 19 19:13:15 2015 +0200
     2.3 @@ -0,0 +1,3213 @@
     2.4 +(*  Title:      HOL/Tools/old_recdef.ML
     2.5 +    Author:     Konrad Slind, Cambridge University Computer Laboratory
     2.6 +    Author:     Lucas Dixon, University of Edinburgh
     2.7 +
     2.8 +Old TFL/recdef package.
     2.9 +*)
    2.10 +
    2.11 +signature CASE_SPLIT =
    2.12 +sig
    2.13 +  (* try to recursively split conjectured thm to given list of thms *)
    2.14 +  val splitto : Proof.context -> thm list -> thm -> thm
    2.15 +end;
    2.16 +
    2.17 +signature UTILS =
    2.18 +sig
    2.19 +  exception ERR of {module: string, func: string, mesg: string}
    2.20 +  val end_itlist: ('a -> 'a -> 'a) -> 'a list -> 'a
    2.21 +  val itlist2: ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
    2.22 +  val pluck: ('a -> bool) -> 'a list -> 'a * 'a list
    2.23 +  val zip3: 'a list -> 'b list -> 'c list -> ('a*'b*'c) list
    2.24 +  val take: ('a -> 'b) -> int * 'a list -> 'b list
    2.25 +end;
    2.26 +
    2.27 +signature USYNTAX =
    2.28 +sig
    2.29 +  datatype lambda = VAR   of {Name : string, Ty : typ}
    2.30 +                  | CONST of {Name : string, Ty : typ}
    2.31 +                  | COMB  of {Rator: term, Rand : term}
    2.32 +                  | LAMB  of {Bvar : term, Body : term}
    2.33 +
    2.34 +  val alpha : typ
    2.35 +
    2.36 +  (* Types *)
    2.37 +  val type_vars  : typ -> typ list
    2.38 +  val type_varsl : typ list -> typ list
    2.39 +  val mk_vartype : string -> typ
    2.40 +  val is_vartype : typ -> bool
    2.41 +  val strip_prod_type : typ -> typ list
    2.42 +
    2.43 +  (* Terms *)
    2.44 +  val free_vars_lr : term -> term list
    2.45 +  val type_vars_in_term : term -> typ list
    2.46 +  val dest_term  : term -> lambda
    2.47 +
    2.48 +  (* Prelogic *)
    2.49 +  val inst      : (typ*typ) list -> term -> term
    2.50 +
    2.51 +  (* Construction routines *)
    2.52 +  val mk_abs    :{Bvar  : term, Body : term} -> term
    2.53 +
    2.54 +  val mk_imp    :{ant : term, conseq :  term} -> term
    2.55 +  val mk_select :{Bvar : term, Body : term} -> term
    2.56 +  val mk_forall :{Bvar : term, Body : term} -> term
    2.57 +  val mk_exists :{Bvar : term, Body : term} -> term
    2.58 +  val mk_conj   :{conj1 : term, conj2 : term} -> term
    2.59 +  val mk_disj   :{disj1 : term, disj2 : term} -> term
    2.60 +  val mk_pabs   :{varstruct : term, body : term} -> term
    2.61 +
    2.62 +  (* Destruction routines *)
    2.63 +  val dest_const: term -> {Name : string, Ty : typ}
    2.64 +  val dest_comb : term -> {Rator : term, Rand : term}
    2.65 +  val dest_abs  : string list -> term -> {Bvar : term, Body : term} * string list
    2.66 +  val dest_eq     : term -> {lhs : term, rhs : term}
    2.67 +  val dest_imp    : term -> {ant : term, conseq : term}
    2.68 +  val dest_forall : term -> {Bvar : term, Body : term}
    2.69 +  val dest_exists : term -> {Bvar : term, Body : term}
    2.70 +  val dest_neg    : term -> term
    2.71 +  val dest_conj   : term -> {conj1 : term, conj2 : term}
    2.72 +  val dest_disj   : term -> {disj1 : term, disj2 : term}
    2.73 +  val dest_pair   : term -> {fst : term, snd : term}
    2.74 +  val dest_pabs   : string list -> term -> {varstruct : term, body : term, used : string list}
    2.75 +
    2.76 +  val lhs   : term -> term
    2.77 +  val rhs   : term -> term
    2.78 +  val rand  : term -> term
    2.79 +
    2.80 +  (* Query routines *)
    2.81 +  val is_imp    : term -> bool
    2.82 +  val is_forall : term -> bool
    2.83 +  val is_exists : term -> bool
    2.84 +  val is_neg    : term -> bool
    2.85 +  val is_conj   : term -> bool
    2.86 +  val is_disj   : term -> bool
    2.87 +  val is_pair   : term -> bool
    2.88 +  val is_pabs   : term -> bool
    2.89 +
    2.90 +  (* Construction of a term from a list of Preterms *)
    2.91 +  val list_mk_abs    : (term list * term) -> term
    2.92 +  val list_mk_imp    : (term list * term) -> term
    2.93 +  val list_mk_forall : (term list * term) -> term
    2.94 +  val list_mk_conj   : term list -> term
    2.95 +
    2.96 +  (* Destructing a term to a list of Preterms *)
    2.97 +  val strip_comb     : term -> (term * term list)
    2.98 +  val strip_abs      : term -> (term list * term)
    2.99 +  val strip_imp      : term -> (term list * term)
   2.100 +  val strip_forall   : term -> (term list * term)
   2.101 +  val strip_exists   : term -> (term list * term)
   2.102 +  val strip_disj     : term -> term list
   2.103 +
   2.104 +  (* Miscellaneous *)
   2.105 +  val mk_vstruct : typ -> term list -> term
   2.106 +  val gen_all    : term -> term
   2.107 +  val find_term  : (term -> bool) -> term -> term option
   2.108 +  val dest_relation : term -> term * term * term
   2.109 +  val is_WFR : term -> bool
   2.110 +  val ARB : typ -> term
   2.111 +end;
   2.112 +
   2.113 +signature DCTERM =
   2.114 +sig
   2.115 +  val dest_comb: cterm -> cterm * cterm
   2.116 +  val dest_abs: string option -> cterm -> cterm * cterm
   2.117 +  val capply: cterm -> cterm -> cterm
   2.118 +  val cabs: cterm -> cterm -> cterm
   2.119 +  val mk_conj: cterm * cterm -> cterm
   2.120 +  val mk_disj: cterm * cterm -> cterm
   2.121 +  val mk_exists: cterm * cterm -> cterm
   2.122 +  val dest_conj: cterm -> cterm * cterm
   2.123 +  val dest_const: cterm -> {Name: string, Ty: typ}
   2.124 +  val dest_disj: cterm -> cterm * cterm
   2.125 +  val dest_eq: cterm -> cterm * cterm
   2.126 +  val dest_exists: cterm -> cterm * cterm
   2.127 +  val dest_forall: cterm -> cterm * cterm
   2.128 +  val dest_imp: cterm -> cterm * cterm
   2.129 +  val dest_neg: cterm -> cterm
   2.130 +  val dest_pair: cterm -> cterm * cterm
   2.131 +  val dest_var: cterm -> {Name:string, Ty:typ}
   2.132 +  val is_conj: cterm -> bool
   2.133 +  val is_disj: cterm -> bool
   2.134 +  val is_eq: cterm -> bool
   2.135 +  val is_exists: cterm -> bool
   2.136 +  val is_forall: cterm -> bool
   2.137 +  val is_imp: cterm -> bool
   2.138 +  val is_neg: cterm -> bool
   2.139 +  val is_pair: cterm -> bool
   2.140 +  val list_mk_disj: cterm list -> cterm
   2.141 +  val strip_abs: cterm -> cterm list * cterm
   2.142 +  val strip_comb: cterm -> cterm * cterm list
   2.143 +  val strip_disj: cterm -> cterm list
   2.144 +  val strip_exists: cterm -> cterm list * cterm
   2.145 +  val strip_forall: cterm -> cterm list * cterm
   2.146 +  val strip_imp: cterm -> cterm list * cterm
   2.147 +  val drop_prop: cterm -> cterm
   2.148 +  val mk_prop: cterm -> cterm
   2.149 +end;
   2.150 +
   2.151 +signature RULES =
   2.152 +sig
   2.153 +  val dest_thm: thm -> term list * term
   2.154 +
   2.155 +  (* Inference rules *)
   2.156 +  val REFL: cterm -> thm
   2.157 +  val ASSUME: cterm -> thm
   2.158 +  val MP: thm -> thm -> thm
   2.159 +  val MATCH_MP: thm -> thm -> thm
   2.160 +  val CONJUNCT1: thm -> thm
   2.161 +  val CONJUNCT2: thm -> thm
   2.162 +  val CONJUNCTS: thm -> thm list
   2.163 +  val DISCH: cterm -> thm -> thm
   2.164 +  val UNDISCH: thm  -> thm
   2.165 +  val SPEC: cterm -> thm -> thm
   2.166 +  val ISPEC: cterm -> thm -> thm
   2.167 +  val ISPECL: cterm list -> thm -> thm
   2.168 +  val GEN: Proof.context -> cterm -> thm -> thm
   2.169 +  val GENL: Proof.context -> cterm list -> thm -> thm
   2.170 +  val LIST_CONJ: thm list -> thm
   2.171 +
   2.172 +  val SYM: thm -> thm
   2.173 +  val DISCH_ALL: thm -> thm
   2.174 +  val FILTER_DISCH_ALL: (term -> bool) -> thm -> thm
   2.175 +  val SPEC_ALL: thm -> thm
   2.176 +  val GEN_ALL: Proof.context -> thm -> thm
   2.177 +  val IMP_TRANS: thm -> thm -> thm
   2.178 +  val PROVE_HYP: thm -> thm -> thm
   2.179 +
   2.180 +  val CHOOSE: Proof.context -> cterm * thm -> thm -> thm
   2.181 +  val EXISTS: cterm * cterm -> thm -> thm
   2.182 +  val EXISTL: cterm list -> thm -> thm
   2.183 +  val IT_EXISTS: Proof.context -> (cterm * cterm) list -> thm -> thm
   2.184 +
   2.185 +  val EVEN_ORS: thm list -> thm list
   2.186 +  val DISJ_CASESL: thm -> thm list -> thm
   2.187 +
   2.188 +  val list_beta_conv: cterm -> cterm list -> thm
   2.189 +  val SUBS: Proof.context -> thm list -> thm -> thm
   2.190 +  val simpl_conv: Proof.context -> thm list -> cterm -> thm
   2.191 +
   2.192 +  val rbeta: thm -> thm
   2.193 +  val tracing: bool Unsynchronized.ref
   2.194 +  val CONTEXT_REWRITE_RULE: Proof.context ->
   2.195 +    term * term list * thm * thm list -> thm -> thm * term list
   2.196 +  val RIGHT_ASSOC: Proof.context -> thm -> thm
   2.197 +
   2.198 +  val prove: Proof.context -> bool -> term * tactic -> thm
   2.199 +end;
   2.200 +
   2.201 +signature THRY =
   2.202 +sig
   2.203 +  val match_term: theory -> term -> term -> (term * term) list * (typ * typ) list
   2.204 +  val match_type: theory -> typ -> typ -> (typ * typ) list
   2.205 +  val typecheck: theory -> term -> cterm
   2.206 +  (*datatype facts of various flavours*)
   2.207 +  val match_info: theory -> string -> {constructors: term list, case_const: term} option
   2.208 +  val induct_info: theory -> string -> {constructors: term list, nchotomy: thm} option
   2.209 +  val extract_info: theory -> {case_congs: thm list, case_rewrites: thm list}
   2.210 +end;
   2.211 +
   2.212 +signature PRIM =
   2.213 +sig
   2.214 +  val trace: bool Unsynchronized.ref
   2.215 +  val trace_thms: Proof.context -> string -> thm list -> unit
   2.216 +  val trace_cterm: Proof.context -> string -> cterm -> unit
   2.217 +  type pattern
   2.218 +  val mk_functional: theory -> term list -> {functional: term, pats: pattern list}
   2.219 +  val wfrec_definition0: string -> term -> term -> theory -> thm * theory
   2.220 +  val post_definition: Proof.context -> thm list -> thm * pattern list ->
   2.221 +   {rules: thm,
   2.222 +    rows: int list,
   2.223 +    TCs: term list list,
   2.224 +    full_pats_TCs: (term * term list) list}
   2.225 +  val wfrec_eqns: theory -> xstring -> thm list -> term list ->
   2.226 +   {WFR: term,
   2.227 +    SV: term list,
   2.228 +    proto_def: term,
   2.229 +    extracta: (thm * term list) list,
   2.230 +    pats: pattern list}
   2.231 +  val lazyR_def: theory -> xstring -> thm list -> term list ->
   2.232 +   {theory: theory,
   2.233 +    rules: thm,
   2.234 +    R: term,
   2.235 +    SV: term list,
   2.236 +    full_pats_TCs: (term * term list) list,
   2.237 +    patterns : pattern list}
   2.238 +  val mk_induction: theory ->
   2.239 +    {fconst: term, R: term, SV: term list, pat_TCs_list: (term * term list) list} -> thm
   2.240 +  val postprocess: Proof.context -> bool ->
   2.241 +    {wf_tac: tactic, terminator: tactic, simplifier: cterm -> thm} ->
   2.242 +    {rules: thm, induction: thm, TCs: term list list} ->
   2.243 +    {rules: thm, induction: thm, nested_tcs: thm list}
   2.244 +end;
   2.245 +
   2.246 +signature TFL =
   2.247 +sig
   2.248 +  val define_i: bool -> thm list -> thm list -> xstring -> term -> term list -> Proof.context ->
   2.249 +    {lhs: term, rules: (thm * int) list, induct: thm, tcs: term list} * Proof.context
   2.250 +  val define: bool -> thm list -> thm list -> xstring -> string -> string list -> Proof.context ->
   2.251 +    {lhs: term, rules: (thm * int) list, induct: thm, tcs: term list} * Proof.context
   2.252 +  val defer_i: thm list -> xstring -> term list -> theory -> thm * theory
   2.253 +  val defer: thm list -> xstring -> string list -> theory -> thm * theory
   2.254 +end;
   2.255 +
   2.256 +signature OLD_RECDEF =
   2.257 +sig
   2.258 +  val get_recdef: theory -> string
   2.259 +    -> {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list} option
   2.260 +  val get_hints: Proof.context -> {simps: thm list, congs: (string * thm) list, wfs: thm list}
   2.261 +  val simp_add: attribute
   2.262 +  val simp_del: attribute
   2.263 +  val cong_add: attribute
   2.264 +  val cong_del: attribute
   2.265 +  val wf_add: attribute
   2.266 +  val wf_del: attribute
   2.267 +  val add_recdef: bool -> xstring -> string -> ((binding * string) * Token.src list) list ->
   2.268 +    Token.src option -> theory -> theory
   2.269 +      * {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list}
   2.270 +  val add_recdef_i: bool -> xstring -> term -> ((binding * term) * attribute list) list ->
   2.271 +    theory -> theory * {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list}
   2.272 +  val defer_recdef: xstring -> string list -> (Facts.ref * Token.src list) list
   2.273 +    -> theory -> theory * {induct_rules: thm}
   2.274 +  val defer_recdef_i: xstring -> term list -> thm list -> theory -> theory * {induct_rules: thm}
   2.275 +  val recdef_tc: bstring * Token.src list -> xstring -> int option -> bool ->
   2.276 +    local_theory -> Proof.state
   2.277 +  val recdef_tc_i: bstring * Token.src list -> string -> int option -> bool ->
   2.278 +    local_theory -> Proof.state
   2.279 +end;
   2.280 +
   2.281 +structure Old_Recdef: OLD_RECDEF =
   2.282 +struct
   2.283 +
   2.284 +(*** extra case splitting for TFL ***)
   2.285 +
   2.286 +structure CaseSplit: CASE_SPLIT =
   2.287 +struct
   2.288 +
   2.289 +(* make a casethm from an induction thm *)
   2.290 +val cases_thm_of_induct_thm =
   2.291 +     Seq.hd o (ALLGOALS (fn i => REPEAT (etac Drule.thin_rl i)));
   2.292 +
   2.293 +(* get the case_thm (my version) from a type *)
   2.294 +fun case_thm_of_ty thy ty  =
   2.295 +    let
   2.296 +      val ty_str = case ty of
   2.297 +                     Type(ty_str, _) => ty_str
   2.298 +                   | TFree(s,_)  => error ("Free type: " ^ s)
   2.299 +                   | TVar((s,i),_) => error ("Free variable: " ^ s)
   2.300 +      val {induct, ...} = BNF_LFP_Compat.the_info thy [BNF_LFP_Compat.Keep_Nesting] ty_str
   2.301 +    in
   2.302 +      cases_thm_of_induct_thm induct
   2.303 +    end;
   2.304 +
   2.305 +
   2.306 +(* for use when there are no prems to the subgoal *)
   2.307 +(* does a case split on the given variable *)
   2.308 +fun mk_casesplit_goal_thm ctxt (vstr,ty) gt =
   2.309 +    let
   2.310 +      val thy = Proof_Context.theory_of ctxt;
   2.311 +
   2.312 +      val x = Free(vstr,ty);
   2.313 +      val abst = Abs(vstr, ty, Term.abstract_over (x, gt));
   2.314 +
   2.315 +      val case_thm = case_thm_of_ty thy ty;
   2.316 +
   2.317 +      val abs_ct = Thm.cterm_of ctxt abst;
   2.318 +      val free_ct = Thm.cterm_of ctxt x;
   2.319 +
   2.320 +      val (Pv, Dv, type_insts) =
   2.321 +          case (Thm.concl_of case_thm) of
   2.322 +            (_ $ (Pv $ (Dv as Var(D, Dty)))) =>
   2.323 +            (Pv, Dv,
   2.324 +             Sign.typ_match thy (Dty, ty) Vartab.empty)
   2.325 +          | _ => error "not a valid case thm";
   2.326 +      val type_cinsts = map (fn (ixn, (S, T)) => apply2 (Thm.ctyp_of ctxt) (TVar (ixn, S), T))
   2.327 +        (Vartab.dest type_insts);
   2.328 +      val cPv = Thm.cterm_of ctxt (Envir.subst_term_types type_insts Pv);
   2.329 +      val cDv = Thm.cterm_of ctxt (Envir.subst_term_types type_insts Dv);
   2.330 +    in
   2.331 +      Conv.fconv_rule Drule.beta_eta_conversion
   2.332 +         (case_thm
   2.333 +            |> Thm.instantiate (type_cinsts, [])
   2.334 +            |> Thm.instantiate ([], [(cPv, abs_ct), (cDv, free_ct)]))
   2.335 +    end;
   2.336 +
   2.337 +
   2.338 +(* the find_XXX_split functions are simply doing a lightwieght (I
   2.339 +think) term matching equivalent to find where to do the next split *)
   2.340 +
   2.341 +(* assuming two twems are identical except for a free in one at a
   2.342 +subterm, or constant in another, ie assume that one term is a plit of
   2.343 +another, then gives back the free variable that has been split. *)
   2.344 +exception find_split_exp of string
   2.345 +fun find_term_split (Free v, _ $ _) = SOME v
   2.346 +  | find_term_split (Free v, Const _) = SOME v
   2.347 +  | find_term_split (Free v, Abs _) = SOME v (* do we really want this case? *)
   2.348 +  | find_term_split (Free v, Var _) = NONE (* keep searching *)
   2.349 +  | find_term_split (a $ b, a2 $ b2) =
   2.350 +    (case find_term_split (a, a2) of
   2.351 +       NONE => find_term_split (b,b2)
   2.352 +     | vopt => vopt)
   2.353 +  | find_term_split (Abs(_,ty,t1), Abs(_,ty2,t2)) =
   2.354 +    find_term_split (t1, t2)
   2.355 +  | find_term_split (Const (x,ty), Const(x2,ty2)) =
   2.356 +    if x = x2 then NONE else (* keep searching *)
   2.357 +    raise find_split_exp (* stop now *)
   2.358 +            "Terms are not identical upto a free varaible! (Consts)"
   2.359 +  | find_term_split (Bound i, Bound j) =
   2.360 +    if i = j then NONE else (* keep searching *)
   2.361 +    raise find_split_exp (* stop now *)
   2.362 +            "Terms are not identical upto a free varaible! (Bound)"
   2.363 +  | find_term_split _ =
   2.364 +    raise find_split_exp (* stop now *)
   2.365 +            "Terms are not identical upto a free varaible! (Other)";
   2.366 +
   2.367 +(* assume that "splitth" is a case split form of subgoal i of "genth",
   2.368 +then look for a free variable to split, breaking the subgoal closer to
   2.369 +splitth. *)
   2.370 +fun find_thm_split splitth i genth =
   2.371 +    find_term_split (Logic.get_goal (Thm.prop_of genth) i,
   2.372 +                     Thm.concl_of splitth) handle find_split_exp _ => NONE;
   2.373 +
   2.374 +(* as above but searches "splitths" for a theorem that suggest a case split *)
   2.375 +fun find_thms_split splitths i genth =
   2.376 +    Library.get_first (fn sth => find_thm_split sth i genth) splitths;
   2.377 +
   2.378 +
   2.379 +(* split the subgoal i of "genth" until we get to a member of
   2.380 +splitths. Assumes that genth will be a general form of splitths, that
   2.381 +can be case-split, as needed. Otherwise fails. Note: We assume that
   2.382 +all of "splitths" are split to the same level, and thus it doesn't
   2.383 +matter which one we choose to look for the next split. Simply add
   2.384 +search on splitthms and split variable, to change this.  *)
   2.385 +(* Note: possible efficiency measure: when a case theorem is no longer
   2.386 +useful, drop it? *)
   2.387 +(* Note: This should not be a separate tactic but integrated into the
   2.388 +case split done during recdef's case analysis, this would avoid us
   2.389 +having to (re)search for variables to split. *)
   2.390 +fun splitto ctxt splitths genth =
   2.391 +    let
   2.392 +      val _ = not (null splitths) orelse error "splitto: no given splitths";
   2.393 +
   2.394 +      (* check if we are a member of splitths - FIXME: quicker and
   2.395 +      more flexible with discrim net. *)
   2.396 +      fun solve_by_splitth th split =
   2.397 +        Thm.biresolution (SOME ctxt) false [(false,split)] 1 th;
   2.398 +
   2.399 +      fun split th =
   2.400 +        (case find_thms_split splitths 1 th of
   2.401 +          NONE =>
   2.402 +           (writeln (cat_lines
   2.403 +            (["th:", Display.string_of_thm ctxt th, "split ths:"] @
   2.404 +              map (Display.string_of_thm ctxt) splitths @ ["\n--"]));
   2.405 +            error "splitto: cannot find variable to split on")
   2.406 +        | SOME v =>
   2.407 +            let
   2.408 +              val gt = HOLogic.dest_Trueprop (#1 (Logic.dest_implies (Thm.prop_of th)));
   2.409 +              val split_thm = mk_casesplit_goal_thm ctxt v gt;
   2.410 +              val (subthms, expf) = IsaND.fixed_subgoal_thms ctxt split_thm;
   2.411 +            in
   2.412 +              expf (map recsplitf subthms)
   2.413 +            end)
   2.414 +
   2.415 +      and recsplitf th =
   2.416 +        (* note: multiple unifiers! we only take the first element,
   2.417 +           probably fine -- there is probably only one anyway. *)
   2.418 +        (case get_first (Seq.pull o solve_by_splitth th) splitths of
   2.419 +          NONE => split th
   2.420 +        | SOME (solved_th, _) => solved_th);
   2.421 +    in
   2.422 +      recsplitf genth
   2.423 +    end;
   2.424 +
   2.425 +end;
   2.426 +
   2.427 +
   2.428 +(*** basic utilities ***)
   2.429 +
   2.430 +structure Utils: UTILS =
   2.431 +struct
   2.432 +
   2.433 +(*standard exception for TFL*)
   2.434 +exception ERR of {module: string, func: string, mesg: string};
   2.435 +
   2.436 +fun UTILS_ERR func mesg = ERR {module = "Utils", func = func, mesg = mesg};
   2.437 +
   2.438 +
   2.439 +fun end_itlist f [] = raise (UTILS_ERR "end_itlist" "list too short")
   2.440 +  | end_itlist f [x] = x
   2.441 +  | end_itlist f (x :: xs) = f x (end_itlist f xs);
   2.442 +
   2.443 +fun itlist2 f L1 L2 base_value =
   2.444 + let fun it ([],[]) = base_value
   2.445 +       | it ((a::rst1),(b::rst2)) = f a b (it (rst1,rst2))
   2.446 +       | it _ = raise UTILS_ERR "itlist2" "different length lists"
   2.447 + in  it (L1,L2)
   2.448 + end;
   2.449 +
   2.450 +fun pluck p  =
   2.451 +  let fun remv ([],_) = raise UTILS_ERR "pluck" "item not found"
   2.452 +        | remv (h::t, A) = if p h then (h, rev A @ t) else remv (t,h::A)
   2.453 +  in fn L => remv(L,[])
   2.454 +  end;
   2.455 +
   2.456 +fun take f =
   2.457 +  let fun grab(0,L) = []
   2.458 +        | grab(n, x::rst) = f x::grab(n-1,rst)
   2.459 +  in grab
   2.460 +  end;
   2.461 +
   2.462 +fun zip3 [][][] = []
   2.463 +  | zip3 (x::l1) (y::l2) (z::l3) = (x,y,z)::zip3 l1 l2 l3
   2.464 +  | zip3 _ _ _ = raise UTILS_ERR "zip3" "different lengths";
   2.465 +
   2.466 +
   2.467 +end;
   2.468 +
   2.469 +
   2.470 +(*** emulation of HOL's abstract syntax functions ***)
   2.471 +
   2.472 +structure USyntax: USYNTAX =
   2.473 +struct
   2.474 +
   2.475 +infix 4 ##;
   2.476 +
   2.477 +fun USYN_ERR func mesg = Utils.ERR {module = "USyntax", func = func, mesg = mesg};
   2.478 +
   2.479 +
   2.480 +(*---------------------------------------------------------------------------
   2.481 + *
   2.482 + *                            Types
   2.483 + *
   2.484 + *---------------------------------------------------------------------------*)
   2.485 +val mk_prim_vartype = TVar;
   2.486 +fun mk_vartype s = mk_prim_vartype ((s, 0), @{sort type});
   2.487 +
   2.488 +(* But internally, it's useful *)
   2.489 +fun dest_vtype (TVar x) = x
   2.490 +  | dest_vtype _ = raise USYN_ERR "dest_vtype" "not a flexible type variable";
   2.491 +
   2.492 +val is_vartype = can dest_vtype;
   2.493 +
   2.494 +val type_vars  = map mk_prim_vartype o Misc_Legacy.typ_tvars
   2.495 +fun type_varsl L = distinct (op =) (fold (curry op @ o type_vars) L []);
   2.496 +
   2.497 +val alpha  = mk_vartype "'a"
   2.498 +val beta   = mk_vartype "'b"
   2.499 +
   2.500 +val strip_prod_type = HOLogic.flatten_tupleT;
   2.501 +
   2.502 +
   2.503 +
   2.504 +(*---------------------------------------------------------------------------
   2.505 + *
   2.506 + *                              Terms
   2.507 + *
   2.508 + *---------------------------------------------------------------------------*)
   2.509 +
   2.510 +(* Free variables, in order of occurrence, from left to right in the
   2.511 + * syntax tree. *)
   2.512 +fun free_vars_lr tm =
   2.513 +  let fun memb x = let fun m[] = false | m(y::rst) = (x=y)orelse m rst in m end
   2.514 +      fun add (t, frees) = case t of
   2.515 +            Free   _ => if (memb t frees) then frees else t::frees
   2.516 +          | Abs (_,_,body) => add(body,frees)
   2.517 +          | f$t =>  add(t, add(f, frees))
   2.518 +          | _ => frees
   2.519 +  in rev(add(tm,[]))
   2.520 +  end;
   2.521 +
   2.522 +
   2.523 +
   2.524 +val type_vars_in_term = map mk_prim_vartype o Misc_Legacy.term_tvars;
   2.525 +
   2.526 +
   2.527 +
   2.528 +(* Prelogic *)
   2.529 +fun dest_tybinding (v,ty) = (#1(dest_vtype v),ty)
   2.530 +fun inst theta = subst_vars (map dest_tybinding theta,[])
   2.531 +
   2.532 +
   2.533 +(* Construction routines *)
   2.534 +
   2.535 +fun mk_abs{Bvar as Var((s,_),ty),Body}  = Abs(s,ty,abstract_over(Bvar,Body))
   2.536 +  | mk_abs{Bvar as Free(s,ty),Body}  = Abs(s,ty,abstract_over(Bvar,Body))
   2.537 +  | mk_abs _ = raise USYN_ERR "mk_abs" "Bvar is not a variable";
   2.538 +
   2.539 +
   2.540 +fun mk_imp{ant,conseq} =
   2.541 +   let val c = Const(@{const_name HOL.implies},HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
   2.542 +   in list_comb(c,[ant,conseq])
   2.543 +   end;
   2.544 +
   2.545 +fun mk_select (r as {Bvar,Body}) =
   2.546 +  let val ty = type_of Bvar
   2.547 +      val c = Const(@{const_name Eps},(ty --> HOLogic.boolT) --> ty)
   2.548 +  in list_comb(c,[mk_abs r])
   2.549 +  end;
   2.550 +
   2.551 +fun mk_forall (r as {Bvar,Body}) =
   2.552 +  let val ty = type_of Bvar
   2.553 +      val c = Const(@{const_name All},(ty --> HOLogic.boolT) --> HOLogic.boolT)
   2.554 +  in list_comb(c,[mk_abs r])
   2.555 +  end;
   2.556 +
   2.557 +fun mk_exists (r as {Bvar,Body}) =
   2.558 +  let val ty = type_of Bvar
   2.559 +      val c = Const(@{const_name Ex},(ty --> HOLogic.boolT) --> HOLogic.boolT)
   2.560 +  in list_comb(c,[mk_abs r])
   2.561 +  end;
   2.562 +
   2.563 +
   2.564 +fun mk_conj{conj1,conj2} =
   2.565 +   let val c = Const(@{const_name HOL.conj},HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
   2.566 +   in list_comb(c,[conj1,conj2])
   2.567 +   end;
   2.568 +
   2.569 +fun mk_disj{disj1,disj2} =
   2.570 +   let val c = Const(@{const_name HOL.disj},HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
   2.571 +   in list_comb(c,[disj1,disj2])
   2.572 +   end;
   2.573 +
   2.574 +fun prod_ty ty1 ty2 = HOLogic.mk_prodT (ty1,ty2);
   2.575 +
   2.576 +local
   2.577 +fun mk_uncurry (xt, yt, zt) =
   2.578 +    Const(@{const_name case_prod}, (xt --> yt --> zt) --> prod_ty xt yt --> zt)
   2.579 +fun dest_pair(Const(@{const_name Pair},_) $ M $ N) = {fst=M, snd=N}
   2.580 +  | dest_pair _ = raise USYN_ERR "dest_pair" "not a pair"
   2.581 +fun is_var (Var _) = true | is_var (Free _) = true | is_var _ = false
   2.582 +in
   2.583 +fun mk_pabs{varstruct,body} =
   2.584 + let fun mpa (varstruct, body) =
   2.585 +       if is_var varstruct
   2.586 +       then mk_abs {Bvar = varstruct, Body = body}
   2.587 +       else let val {fst, snd} = dest_pair varstruct
   2.588 +            in mk_uncurry (type_of fst, type_of snd, type_of body) $
   2.589 +               mpa (fst, mpa (snd, body))
   2.590 +            end
   2.591 + in mpa (varstruct, body) end
   2.592 + handle TYPE _ => raise USYN_ERR "mk_pabs" "";
   2.593 +end;
   2.594 +
   2.595 +(* Destruction routines *)
   2.596 +
   2.597 +datatype lambda = VAR   of {Name : string, Ty : typ}
   2.598 +                | CONST of {Name : string, Ty : typ}
   2.599 +                | COMB  of {Rator: term, Rand : term}
   2.600 +                | LAMB  of {Bvar : term, Body : term};
   2.601 +
   2.602 +
   2.603 +fun dest_term(Var((s,i),ty)) = VAR{Name = s, Ty = ty}
   2.604 +  | dest_term(Free(s,ty))    = VAR{Name = s, Ty = ty}
   2.605 +  | dest_term(Const(s,ty))   = CONST{Name = s, Ty = ty}
   2.606 +  | dest_term(M$N)           = COMB{Rator=M,Rand=N}
   2.607 +  | dest_term(Abs(s,ty,M))   = let  val v = Free(s,ty)
   2.608 +                               in LAMB{Bvar = v, Body = Term.betapply (M,v)}
   2.609 +                               end
   2.610 +  | dest_term(Bound _)       = raise USYN_ERR "dest_term" "Bound";
   2.611 +
   2.612 +fun dest_const(Const(s,ty)) = {Name = s, Ty = ty}
   2.613 +  | dest_const _ = raise USYN_ERR "dest_const" "not a constant";
   2.614 +
   2.615 +fun dest_comb(t1 $ t2) = {Rator = t1, Rand = t2}
   2.616 +  | dest_comb _ =  raise USYN_ERR "dest_comb" "not a comb";
   2.617 +
   2.618 +fun dest_abs used (a as Abs(s, ty, M)) =
   2.619 +     let
   2.620 +       val s' = singleton (Name.variant_list used) s;
   2.621 +       val v = Free(s', ty);
   2.622 +     in ({Bvar = v, Body = Term.betapply (a,v)}, s'::used)
   2.623 +     end
   2.624 +  | dest_abs _ _ =  raise USYN_ERR "dest_abs" "not an abstraction";
   2.625 +
   2.626 +fun dest_eq(Const(@{const_name HOL.eq},_) $ M $ N) = {lhs=M, rhs=N}
   2.627 +  | dest_eq _ = raise USYN_ERR "dest_eq" "not an equality";
   2.628 +
   2.629 +fun dest_imp(Const(@{const_name HOL.implies},_) $ M $ N) = {ant=M, conseq=N}
   2.630 +  | dest_imp _ = raise USYN_ERR "dest_imp" "not an implication";
   2.631 +
   2.632 +fun dest_forall(Const(@{const_name All},_) $ (a as Abs _)) = fst (dest_abs [] a)
   2.633 +  | dest_forall _ = raise USYN_ERR "dest_forall" "not a forall";
   2.634 +
   2.635 +fun dest_exists(Const(@{const_name Ex},_) $ (a as Abs _)) = fst (dest_abs [] a)
   2.636 +  | dest_exists _ = raise USYN_ERR "dest_exists" "not an existential";
   2.637 +
   2.638 +fun dest_neg(Const(@{const_name Not},_) $ M) = M
   2.639 +  | dest_neg _ = raise USYN_ERR "dest_neg" "not a negation";
   2.640 +
   2.641 +fun dest_conj(Const(@{const_name HOL.conj},_) $ M $ N) = {conj1=M, conj2=N}
   2.642 +  | dest_conj _ = raise USYN_ERR "dest_conj" "not a conjunction";
   2.643 +
   2.644 +fun dest_disj(Const(@{const_name HOL.disj},_) $ M $ N) = {disj1=M, disj2=N}
   2.645 +  | dest_disj _ = raise USYN_ERR "dest_disj" "not a disjunction";
   2.646 +
   2.647 +fun mk_pair{fst,snd} =
   2.648 +   let val ty1 = type_of fst
   2.649 +       val ty2 = type_of snd
   2.650 +       val c = Const(@{const_name Pair},ty1 --> ty2 --> prod_ty ty1 ty2)
   2.651 +   in list_comb(c,[fst,snd])
   2.652 +   end;
   2.653 +
   2.654 +fun dest_pair(Const(@{const_name Pair},_) $ M $ N) = {fst=M, snd=N}
   2.655 +  | dest_pair _ = raise USYN_ERR "dest_pair" "not a pair";
   2.656 +
   2.657 +
   2.658 +local  fun ucheck t = (if #Name (dest_const t) = @{const_name case_prod} then t
   2.659 +                       else raise Match)
   2.660 +in
   2.661 +fun dest_pabs used tm =
   2.662 +   let val ({Bvar,Body}, used') = dest_abs used tm
   2.663 +   in {varstruct = Bvar, body = Body, used = used'}
   2.664 +   end handle Utils.ERR _ =>
   2.665 +          let val {Rator,Rand} = dest_comb tm
   2.666 +              val _ = ucheck Rator
   2.667 +              val {varstruct = lv, body, used = used'} = dest_pabs used Rand
   2.668 +              val {varstruct = rv, body, used = used''} = dest_pabs used' body
   2.669 +          in {varstruct = mk_pair {fst = lv, snd = rv}, body = body, used = used''}
   2.670 +          end
   2.671 +end;
   2.672 +
   2.673 +
   2.674 +val lhs   = #lhs o dest_eq
   2.675 +val rhs   = #rhs o dest_eq
   2.676 +val rand  = #Rand o dest_comb
   2.677 +
   2.678 +
   2.679 +(* Query routines *)
   2.680 +val is_imp    = can dest_imp
   2.681 +val is_forall = can dest_forall
   2.682 +val is_exists = can dest_exists
   2.683 +val is_neg    = can dest_neg
   2.684 +val is_conj   = can dest_conj
   2.685 +val is_disj   = can dest_disj
   2.686 +val is_pair   = can dest_pair
   2.687 +val is_pabs   = can (dest_pabs [])
   2.688 +
   2.689 +
   2.690 +(* Construction of a cterm from a list of Terms *)
   2.691 +
   2.692 +fun list_mk_abs(L,tm) = fold_rev (fn v => fn M => mk_abs{Bvar=v, Body=M}) L tm;
   2.693 +
   2.694 +(* These others are almost never used *)
   2.695 +fun list_mk_imp(A,c) = fold_rev (fn a => fn tm => mk_imp{ant=a,conseq=tm}) A c;
   2.696 +fun list_mk_forall(V,t) = fold_rev (fn v => fn b => mk_forall{Bvar=v, Body=b})V t;
   2.697 +val list_mk_conj = Utils.end_itlist(fn c1 => fn tm => mk_conj{conj1=c1, conj2=tm})
   2.698 +
   2.699 +
   2.700 +(* Need to reverse? *)
   2.701 +fun gen_all tm = list_mk_forall(Misc_Legacy.term_frees tm, tm);
   2.702 +
   2.703 +(* Destructing a cterm to a list of Terms *)
   2.704 +fun strip_comb tm =
   2.705 +   let fun dest(M$N, A) = dest(M, N::A)
   2.706 +         | dest x = x
   2.707 +   in dest(tm,[])
   2.708 +   end;
   2.709 +
   2.710 +fun strip_abs(tm as Abs _) =
   2.711 +       let val ({Bvar,Body}, _) = dest_abs [] tm
   2.712 +           val (bvs, core) = strip_abs Body
   2.713 +       in (Bvar::bvs, core)
   2.714 +       end
   2.715 +  | strip_abs M = ([],M);
   2.716 +
   2.717 +
   2.718 +fun strip_imp fm =
   2.719 +   if (is_imp fm)
   2.720 +   then let val {ant,conseq} = dest_imp fm
   2.721 +            val (was,wb) = strip_imp conseq
   2.722 +        in ((ant::was), wb)
   2.723 +        end
   2.724 +   else ([],fm);
   2.725 +
   2.726 +fun strip_forall fm =
   2.727 +   if (is_forall fm)
   2.728 +   then let val {Bvar,Body} = dest_forall fm
   2.729 +            val (bvs,core) = strip_forall Body
   2.730 +        in ((Bvar::bvs), core)
   2.731 +        end
   2.732 +   else ([],fm);
   2.733 +
   2.734 +
   2.735 +fun strip_exists fm =
   2.736 +   if (is_exists fm)
   2.737 +   then let val {Bvar, Body} = dest_exists fm
   2.738 +            val (bvs,core) = strip_exists Body
   2.739 +        in (Bvar::bvs, core)
   2.740 +        end
   2.741 +   else ([],fm);
   2.742 +
   2.743 +fun strip_disj w =
   2.744 +   if (is_disj w)
   2.745 +   then let val {disj1,disj2} = dest_disj w
   2.746 +        in (strip_disj disj1@strip_disj disj2)
   2.747 +        end
   2.748 +   else [w];
   2.749 +
   2.750 +
   2.751 +(* Miscellaneous *)
   2.752 +
   2.753 +fun mk_vstruct ty V =
   2.754 +  let fun follow_prod_type (Type(@{type_name Product_Type.prod},[ty1,ty2])) vs =
   2.755 +              let val (ltm,vs1) = follow_prod_type ty1 vs
   2.756 +                  val (rtm,vs2) = follow_prod_type ty2 vs1
   2.757 +              in (mk_pair{fst=ltm, snd=rtm}, vs2) end
   2.758 +        | follow_prod_type _ (v::vs) = (v,vs)
   2.759 +  in #1 (follow_prod_type ty V)  end;
   2.760 +
   2.761 +
   2.762 +(* Search a term for a sub-term satisfying the predicate p. *)
   2.763 +fun find_term p =
   2.764 +   let fun find tm =
   2.765 +      if (p tm) then SOME tm
   2.766 +      else case tm of
   2.767 +          Abs(_,_,body) => find body
   2.768 +        | (t$u)         => (case find t of NONE => find u | some => some)
   2.769 +        | _             => NONE
   2.770 +   in find
   2.771 +   end;
   2.772 +
   2.773 +fun dest_relation tm =
   2.774 +   if (type_of tm = HOLogic.boolT)
   2.775 +   then let val (Const(@{const_name Set.member},_) $ (Const(@{const_name Pair},_)$y$x) $ R) = tm
   2.776 +        in (R,y,x)
   2.777 +        end handle Bind => raise USYN_ERR "dest_relation" "unexpected term structure"
   2.778 +   else raise USYN_ERR "dest_relation" "not a boolean term";
   2.779 +
   2.780 +fun is_WFR (Const(@{const_name Wellfounded.wf},_)$_) = true
   2.781 +  | is_WFR _                 = false;
   2.782 +
   2.783 +fun ARB ty = mk_select{Bvar=Free("v",ty),
   2.784 +                       Body=Const(@{const_name True},HOLogic.boolT)};
   2.785 +
   2.786 +end;
   2.787 +
   2.788 +
   2.789 +(*** derived cterm destructors ***)
   2.790 +
   2.791 +structure Dcterm: DCTERM =
   2.792 +struct
   2.793 +
   2.794 +fun ERR func mesg = Utils.ERR {module = "Dcterm", func = func, mesg = mesg};
   2.795 +
   2.796 +
   2.797 +fun dest_comb t = Thm.dest_comb t
   2.798 +  handle CTERM (msg, _) => raise ERR "dest_comb" msg;
   2.799 +
   2.800 +fun dest_abs a t = Thm.dest_abs a t
   2.801 +  handle CTERM (msg, _) => raise ERR "dest_abs" msg;
   2.802 +
   2.803 +fun capply t u = Thm.apply t u
   2.804 +  handle CTERM (msg, _) => raise ERR "capply" msg;
   2.805 +
   2.806 +fun cabs a t = Thm.lambda a t
   2.807 +  handle CTERM (msg, _) => raise ERR "cabs" msg;
   2.808 +
   2.809 +
   2.810 +(*---------------------------------------------------------------------------
   2.811 + * Some simple constructor functions.
   2.812 + *---------------------------------------------------------------------------*)
   2.813 +
   2.814 +val mk_hol_const = Thm.cterm_of @{theory_context HOL} o Const;
   2.815 +
   2.816 +fun mk_exists (r as (Bvar, Body)) =
   2.817 +  let val ty = Thm.typ_of_cterm Bvar
   2.818 +      val c = mk_hol_const(@{const_name Ex}, (ty --> HOLogic.boolT) --> HOLogic.boolT)
   2.819 +  in capply c (uncurry cabs r) end;
   2.820 +
   2.821 +
   2.822 +local val c = mk_hol_const(@{const_name HOL.conj}, HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
   2.823 +in fun mk_conj(conj1,conj2) = capply (capply c conj1) conj2
   2.824 +end;
   2.825 +
   2.826 +local val c = mk_hol_const(@{const_name HOL.disj}, HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
   2.827 +in fun mk_disj(disj1,disj2) = capply (capply c disj1) disj2
   2.828 +end;
   2.829 +
   2.830 +
   2.831 +(*---------------------------------------------------------------------------
   2.832 + * The primitives.
   2.833 + *---------------------------------------------------------------------------*)
   2.834 +fun dest_const ctm =
   2.835 +   (case Thm.term_of ctm
   2.836 +      of Const(s,ty) => {Name = s, Ty = ty}
   2.837 +       | _ => raise ERR "dest_const" "not a constant");
   2.838 +
   2.839 +fun dest_var ctm =
   2.840 +   (case Thm.term_of ctm
   2.841 +      of Var((s,i),ty) => {Name=s, Ty=ty}
   2.842 +       | Free(s,ty)    => {Name=s, Ty=ty}
   2.843 +       |             _ => raise ERR "dest_var" "not a variable");
   2.844 +
   2.845 +
   2.846 +(*---------------------------------------------------------------------------
   2.847 + * Derived destructor operations.
   2.848 + *---------------------------------------------------------------------------*)
   2.849 +
   2.850 +fun dest_monop expected tm =
   2.851 + let
   2.852 +   fun err () = raise ERR "dest_monop" ("Not a(n) " ^ quote expected);
   2.853 +   val (c, N) = dest_comb tm handle Utils.ERR _ => err ();
   2.854 +   val name = #Name (dest_const c handle Utils.ERR _ => err ());
   2.855 + in if name = expected then N else err () end;
   2.856 +
   2.857 +fun dest_binop expected tm =
   2.858 + let
   2.859 +   fun err () = raise ERR "dest_binop" ("Not a(n) " ^ quote expected);
   2.860 +   val (M, N) = dest_comb tm handle Utils.ERR _ => err ()
   2.861 + in (dest_monop expected M, N) handle Utils.ERR _ => err () end;
   2.862 +
   2.863 +fun dest_binder expected tm =
   2.864 +  dest_abs NONE (dest_monop expected tm)
   2.865 +  handle Utils.ERR _ => raise ERR "dest_binder" ("Not a(n) " ^ quote expected);
   2.866 +
   2.867 +
   2.868 +val dest_neg    = dest_monop @{const_name Not}
   2.869 +val dest_pair   = dest_binop @{const_name Pair}
   2.870 +val dest_eq     = dest_binop @{const_name HOL.eq}
   2.871 +val dest_imp    = dest_binop @{const_name HOL.implies}
   2.872 +val dest_conj   = dest_binop @{const_name HOL.conj}
   2.873 +val dest_disj   = dest_binop @{const_name HOL.disj}
   2.874 +val dest_select = dest_binder @{const_name Eps}
   2.875 +val dest_exists = dest_binder @{const_name Ex}
   2.876 +val dest_forall = dest_binder @{const_name All}
   2.877 +
   2.878 +(* Query routines *)
   2.879 +
   2.880 +val is_eq     = can dest_eq
   2.881 +val is_imp    = can dest_imp
   2.882 +val is_select = can dest_select
   2.883 +val is_forall = can dest_forall
   2.884 +val is_exists = can dest_exists
   2.885 +val is_neg    = can dest_neg
   2.886 +val is_conj   = can dest_conj
   2.887 +val is_disj   = can dest_disj
   2.888 +val is_pair   = can dest_pair
   2.889 +
   2.890 +
   2.891 +(*---------------------------------------------------------------------------
   2.892 + * Iterated creation.
   2.893 + *---------------------------------------------------------------------------*)
   2.894 +val list_mk_disj = Utils.end_itlist (fn d1 => fn tm => mk_disj (d1, tm));
   2.895 +
   2.896 +(*---------------------------------------------------------------------------
   2.897 + * Iterated destruction. (To the "right" in a term.)
   2.898 + *---------------------------------------------------------------------------*)
   2.899 +fun strip break tm =
   2.900 +  let fun dest (p as (ctm,accum)) =
   2.901 +        let val (M,N) = break ctm
   2.902 +        in dest (N, M::accum)
   2.903 +        end handle Utils.ERR _ => p
   2.904 +  in dest (tm,[])
   2.905 +  end;
   2.906 +
   2.907 +fun rev2swap (x,l) = (rev l, x);
   2.908 +
   2.909 +val strip_comb   = strip (Library.swap o dest_comb)  (* Goes to the "left" *)
   2.910 +val strip_imp    = rev2swap o strip dest_imp
   2.911 +val strip_abs    = rev2swap o strip (dest_abs NONE)
   2.912 +val strip_forall = rev2swap o strip dest_forall
   2.913 +val strip_exists = rev2swap o strip dest_exists
   2.914 +
   2.915 +val strip_disj   = rev o (op::) o strip dest_disj
   2.916 +
   2.917 +
   2.918 +(*---------------------------------------------------------------------------
   2.919 + * Going into and out of prop
   2.920 + *---------------------------------------------------------------------------*)
   2.921 +
   2.922 +fun is_Trueprop ct =
   2.923 +  (case Thm.term_of ct of
   2.924 +    Const (@{const_name Trueprop}, _) $ _ => true
   2.925 +  | _ => false);
   2.926 +
   2.927 +fun mk_prop ct = if is_Trueprop ct then ct else Thm.apply @{cterm Trueprop} ct;
   2.928 +fun drop_prop ct = if is_Trueprop ct then Thm.dest_arg ct else ct;
   2.929 +
   2.930 +end;
   2.931 +
   2.932 +
   2.933 +(*** notable theorems ***)
   2.934 +
   2.935 +structure Thms =
   2.936 +struct
   2.937 +  val WFREC_COROLLARY = @{thm tfl_wfrec};
   2.938 +  val WF_INDUCTION_THM = @{thm tfl_wf_induct};
   2.939 +  val CUT_DEF = @{thm tfl_cut_def};
   2.940 +  val eqT = @{thm tfl_eq_True};
   2.941 +  val rev_eq_mp = @{thm tfl_rev_eq_mp};
   2.942 +  val simp_thm = @{thm tfl_simp_thm};
   2.943 +  val P_imp_P_iff_True = @{thm tfl_P_imp_P_iff_True};
   2.944 +  val imp_trans = @{thm tfl_imp_trans};
   2.945 +  val disj_assoc = @{thm tfl_disj_assoc};
   2.946 +  val tfl_disjE = @{thm tfl_disjE};
   2.947 +  val choose_thm = @{thm tfl_exE};
   2.948 +end;
   2.949 +
   2.950 +
   2.951 +(*** emulation of HOL inference rules for TFL ***)
   2.952 +
   2.953 +structure Rules: RULES =
   2.954 +struct
   2.955 +
   2.956 +fun RULES_ERR func mesg = Utils.ERR {module = "Rules", func = func, mesg = mesg};
   2.957 +
   2.958 +
   2.959 +fun cconcl thm = Dcterm.drop_prop (#prop (Thm.crep_thm thm));
   2.960 +fun chyps thm = map Dcterm.drop_prop (#hyps (Thm.crep_thm thm));
   2.961 +
   2.962 +fun dest_thm thm =
   2.963 +  let val {prop,hyps,...} = Thm.rep_thm thm
   2.964 +  in (map HOLogic.dest_Trueprop hyps, HOLogic.dest_Trueprop prop) end
   2.965 +  handle TERM _ => raise RULES_ERR "dest_thm" "missing Trueprop";
   2.966 +
   2.967 +
   2.968 +(* Inference rules *)
   2.969 +
   2.970 +(*---------------------------------------------------------------------------
   2.971 + *        Equality (one step)
   2.972 + *---------------------------------------------------------------------------*)
   2.973 +
   2.974 +fun REFL tm = Thm.reflexive tm RS meta_eq_to_obj_eq
   2.975 +  handle THM (msg, _, _) => raise RULES_ERR "REFL" msg;
   2.976 +
   2.977 +fun SYM thm = thm RS sym
   2.978 +  handle THM (msg, _, _) => raise RULES_ERR "SYM" msg;
   2.979 +
   2.980 +fun ALPHA thm ctm1 =
   2.981 +  let
   2.982 +    val ctm2 = Thm.cprop_of thm;
   2.983 +    val ctm2_eq = Thm.reflexive ctm2;
   2.984 +    val ctm1_eq = Thm.reflexive ctm1;
   2.985 +  in Thm.equal_elim (Thm.transitive ctm2_eq ctm1_eq) thm end
   2.986 +  handle THM (msg, _, _) => raise RULES_ERR "ALPHA" msg;
   2.987 +
   2.988 +fun rbeta th =
   2.989 +  (case Dcterm.strip_comb (cconcl th) of
   2.990 +    (_, [l, r]) => Thm.transitive th (Thm.beta_conversion false r)
   2.991 +  | _ => raise RULES_ERR "rbeta" "");
   2.992 +
   2.993 +
   2.994 +(*----------------------------------------------------------------------------
   2.995 + *        Implication and the assumption list
   2.996 + *
   2.997 + * Assumptions get stuck on the meta-language assumption list. Implications
   2.998 + * are in the object language, so discharging an assumption "A" from theorem
   2.999 + * "B" results in something that looks like "A --> B".
  2.1000 + *---------------------------------------------------------------------------*)
  2.1001 +
  2.1002 +fun ASSUME ctm = Thm.assume (Dcterm.mk_prop ctm);
  2.1003 +
  2.1004 +
  2.1005 +(*---------------------------------------------------------------------------
  2.1006 + * Implication in TFL is -->. Meta-language implication (==>) is only used
  2.1007 + * in the implementation of some of the inference rules below.
  2.1008 + *---------------------------------------------------------------------------*)
  2.1009 +fun MP th1 th2 = th2 RS (th1 RS mp)
  2.1010 +  handle THM (msg, _, _) => raise RULES_ERR "MP" msg;
  2.1011 +
  2.1012 +(*forces the first argument to be a proposition if necessary*)
  2.1013 +fun DISCH tm thm = Thm.implies_intr (Dcterm.mk_prop tm) thm COMP impI
  2.1014 +  handle THM (msg, _, _) => raise RULES_ERR "DISCH" msg;
  2.1015 +
  2.1016 +fun DISCH_ALL thm = fold_rev DISCH (#hyps (Thm.crep_thm thm)) thm;
  2.1017 +
  2.1018 +
  2.1019 +fun FILTER_DISCH_ALL P thm =
  2.1020 + let fun check tm = P (Thm.term_of tm)
  2.1021 + in  fold_rev (fn tm => fn th => if check tm then DISCH tm th else th) (chyps thm) thm
  2.1022 + end;
  2.1023 +
  2.1024 +fun UNDISCH thm =
  2.1025 +   let val tm = Dcterm.mk_prop (#1 (Dcterm.dest_imp (cconcl thm)))
  2.1026 +   in Thm.implies_elim (thm RS mp) (ASSUME tm) end
  2.1027 +   handle Utils.ERR _ => raise RULES_ERR "UNDISCH" ""
  2.1028 +     | THM _ => raise RULES_ERR "UNDISCH" "";
  2.1029 +
  2.1030 +fun PROVE_HYP ath bth = MP (DISCH (cconcl ath) bth) ath;
  2.1031 +
  2.1032 +fun IMP_TRANS th1 th2 = th2 RS (th1 RS Thms.imp_trans)
  2.1033 +  handle THM (msg, _, _) => raise RULES_ERR "IMP_TRANS" msg;
  2.1034 +
  2.1035 +
  2.1036 +(*----------------------------------------------------------------------------
  2.1037 + *        Conjunction
  2.1038 + *---------------------------------------------------------------------------*)
  2.1039 +
  2.1040 +fun CONJUNCT1 thm = thm RS conjunct1
  2.1041 +  handle THM (msg, _, _) => raise RULES_ERR "CONJUNCT1" msg;
  2.1042 +
  2.1043 +fun CONJUNCT2 thm = thm RS conjunct2
  2.1044 +  handle THM (msg, _, _) => raise RULES_ERR "CONJUNCT2" msg;
  2.1045 +
  2.1046 +fun CONJUNCTS th = CONJUNCTS (CONJUNCT1 th) @ CONJUNCTS (CONJUNCT2 th) handle Utils.ERR _ => [th];
  2.1047 +
  2.1048 +fun LIST_CONJ [] = raise RULES_ERR "LIST_CONJ" "empty list"
  2.1049 +  | LIST_CONJ [th] = th
  2.1050 +  | LIST_CONJ (th :: rst) = MP (MP (conjI COMP (impI RS impI)) th) (LIST_CONJ rst)
  2.1051 +      handle THM (msg, _, _) => raise RULES_ERR "LIST_CONJ" msg;
  2.1052 +
  2.1053 +
  2.1054 +(*----------------------------------------------------------------------------
  2.1055 + *        Disjunction
  2.1056 + *---------------------------------------------------------------------------*)
  2.1057 +local
  2.1058 +  val prop = Thm.prop_of disjI1
  2.1059 +  val [P,Q] = Misc_Legacy.term_vars prop
  2.1060 +  val disj1 = Thm.forall_intr (Thm.cterm_of @{context} Q) disjI1
  2.1061 +in
  2.1062 +fun DISJ1 thm tm = thm RS (Thm.forall_elim (Dcterm.drop_prop tm) disj1)
  2.1063 +  handle THM (msg, _, _) => raise RULES_ERR "DISJ1" msg;
  2.1064 +end;
  2.1065 +
  2.1066 +local
  2.1067 +  val prop = Thm.prop_of disjI2
  2.1068 +  val [P,Q] = Misc_Legacy.term_vars prop
  2.1069 +  val disj2 = Thm.forall_intr (Thm.cterm_of @{context} P) disjI2
  2.1070 +in
  2.1071 +fun DISJ2 tm thm = thm RS (Thm.forall_elim (Dcterm.drop_prop tm) disj2)
  2.1072 +  handle THM (msg, _, _) => raise RULES_ERR "DISJ2" msg;
  2.1073 +end;
  2.1074 +
  2.1075 +
  2.1076 +(*----------------------------------------------------------------------------
  2.1077 + *
  2.1078 + *                   A1 |- M1, ..., An |- Mn
  2.1079 + *     ---------------------------------------------------
  2.1080 + *     [A1 |- M1 \/ ... \/ Mn, ..., An |- M1 \/ ... \/ Mn]
  2.1081 + *
  2.1082 + *---------------------------------------------------------------------------*)
  2.1083 +
  2.1084 +
  2.1085 +fun EVEN_ORS thms =
  2.1086 +  let fun blue ldisjs [] _ = []
  2.1087 +        | blue ldisjs (th::rst) rdisjs =
  2.1088 +            let val tail = tl rdisjs
  2.1089 +                val rdisj_tl = Dcterm.list_mk_disj tail
  2.1090 +            in fold_rev DISJ2 ldisjs (DISJ1 th rdisj_tl)
  2.1091 +               :: blue (ldisjs @ [cconcl th]) rst tail
  2.1092 +            end handle Utils.ERR _ => [fold_rev DISJ2 ldisjs th]
  2.1093 +   in blue [] thms (map cconcl thms) end;
  2.1094 +
  2.1095 +
  2.1096 +(*----------------------------------------------------------------------------
  2.1097 + *
  2.1098 + *         A |- P \/ Q   B,P |- R    C,Q |- R
  2.1099 + *     ---------------------------------------------------
  2.1100 + *                     A U B U C |- R
  2.1101 + *
  2.1102 + *---------------------------------------------------------------------------*)
  2.1103 +
  2.1104 +fun DISJ_CASES th1 th2 th3 =
  2.1105 +  let
  2.1106 +    val c = Dcterm.drop_prop (cconcl th1);
  2.1107 +    val (disj1, disj2) = Dcterm.dest_disj c;
  2.1108 +    val th2' = DISCH disj1 th2;
  2.1109 +    val th3' = DISCH disj2 th3;
  2.1110 +  in
  2.1111 +    th3' RS (th2' RS (th1 RS Thms.tfl_disjE))
  2.1112 +      handle THM (msg, _, _) => raise RULES_ERR "DISJ_CASES" msg
  2.1113 +  end;
  2.1114 +
  2.1115 +
  2.1116 +(*-----------------------------------------------------------------------------
  2.1117 + *
  2.1118 + *       |- A1 \/ ... \/ An     [A1 |- M, ..., An |- M]
  2.1119 + *     ---------------------------------------------------
  2.1120 + *                           |- M
  2.1121 + *
  2.1122 + * Note. The list of theorems may be all jumbled up, so we have to
  2.1123 + * first organize it to align with the first argument (the disjunctive
  2.1124 + * theorem).
  2.1125 + *---------------------------------------------------------------------------*)
  2.1126 +
  2.1127 +fun organize eq =    (* a bit slow - analogous to insertion sort *)
  2.1128 + let fun extract a alist =
  2.1129 +     let fun ex (_,[]) = raise RULES_ERR "organize" "not a permutation.1"
  2.1130 +           | ex(left,h::t) = if (eq h a) then (h,rev left@t) else ex(h::left,t)
  2.1131 +     in ex ([],alist)
  2.1132 +     end
  2.1133 +     fun place [] [] = []
  2.1134 +       | place (a::rst) alist =
  2.1135 +           let val (item,next) = extract a alist
  2.1136 +           in item::place rst next
  2.1137 +           end
  2.1138 +       | place _ _ = raise RULES_ERR "organize" "not a permutation.2"
  2.1139 + in place
  2.1140 + end;
  2.1141 +
  2.1142 +fun DISJ_CASESL disjth thl =
  2.1143 +   let val c = cconcl disjth
  2.1144 +       fun eq th atm =
  2.1145 +        exists (fn t => HOLogic.dest_Trueprop t aconv Thm.term_of atm) (Thm.hyps_of th)
  2.1146 +       val tml = Dcterm.strip_disj c
  2.1147 +       fun DL th [] = raise RULES_ERR "DISJ_CASESL" "no cases"
  2.1148 +         | DL th [th1] = PROVE_HYP th th1
  2.1149 +         | DL th [th1,th2] = DISJ_CASES th th1 th2
  2.1150 +         | DL th (th1::rst) =
  2.1151 +            let val tm = #2 (Dcterm.dest_disj (Dcterm.drop_prop(cconcl th)))
  2.1152 +             in DISJ_CASES th th1 (DL (ASSUME tm) rst) end
  2.1153 +   in DL disjth (organize eq tml thl)
  2.1154 +   end;
  2.1155 +
  2.1156 +
  2.1157 +(*----------------------------------------------------------------------------
  2.1158 + *        Universals
  2.1159 + *---------------------------------------------------------------------------*)
  2.1160 +local (* this is fragile *)
  2.1161 +  val prop = Thm.prop_of spec
  2.1162 +  val x = hd (tl (Misc_Legacy.term_vars prop))
  2.1163 +  val cTV = Thm.ctyp_of @{context} (type_of x)
  2.1164 +  val gspec = Thm.forall_intr (Thm.cterm_of @{context} x) spec
  2.1165 +in
  2.1166 +fun SPEC tm thm =
  2.1167 +   let val gspec' = Drule.instantiate_normalize ([(cTV, Thm.ctyp_of_cterm tm)], []) gspec
  2.1168 +   in thm RS (Thm.forall_elim tm gspec') end
  2.1169 +end;
  2.1170 +
  2.1171 +fun SPEC_ALL thm = fold SPEC (#1 (Dcterm.strip_forall(cconcl thm))) thm;
  2.1172 +
  2.1173 +val ISPEC = SPEC
  2.1174 +val ISPECL = fold ISPEC;
  2.1175 +
  2.1176 +(* Not optimized! Too complicated. *)
  2.1177 +local
  2.1178 +  val prop = Thm.prop_of allI
  2.1179 +  val [P] = Misc_Legacy.add_term_vars (prop, [])
  2.1180 +  fun cty_theta ctxt = map (fn (i, (S, ty)) => apply2 (Thm.ctyp_of ctxt) (TVar (i, S), ty))
  2.1181 +  fun ctm_theta ctxt =
  2.1182 +    map (fn (i, (_, tm2)) =>
  2.1183 +      let val ctm2 = Thm.cterm_of ctxt tm2
  2.1184 +      in (Thm.cterm_of ctxt (Var (i, Thm.typ_of_cterm ctm2)), ctm2) end)
  2.1185 +  fun certify ctxt (ty_theta,tm_theta) =
  2.1186 +    (cty_theta ctxt (Vartab.dest ty_theta),
  2.1187 +     ctm_theta ctxt (Vartab.dest tm_theta))
  2.1188 +in
  2.1189 +fun GEN ctxt v th =
  2.1190 +   let val gth = Thm.forall_intr v th
  2.1191 +       val thy = Proof_Context.theory_of ctxt
  2.1192 +       val Const(@{const_name Pure.all},_)$Abs(x,ty,rst) = Thm.prop_of gth
  2.1193 +       val P' = Abs(x,ty, HOLogic.dest_Trueprop rst)  (* get rid of trueprop *)
  2.1194 +       val theta = Pattern.match thy (P,P') (Vartab.empty, Vartab.empty);
  2.1195 +       val allI2 = Drule.instantiate_normalize (certify ctxt theta) allI
  2.1196 +       val thm = Thm.implies_elim allI2 gth
  2.1197 +       val tp $ (A $ Abs(_,_,M)) = Thm.prop_of thm
  2.1198 +       val prop' = tp $ (A $ Abs(x,ty,M))
  2.1199 +   in ALPHA thm (Thm.cterm_of ctxt prop') end
  2.1200 +end;
  2.1201 +
  2.1202 +fun GENL ctxt = fold_rev (GEN ctxt);
  2.1203 +
  2.1204 +fun GEN_ALL ctxt thm =
  2.1205 +  let
  2.1206 +    val prop = Thm.prop_of thm
  2.1207 +    val vlist = map (Thm.cterm_of ctxt) (Misc_Legacy.add_term_vars (prop, []))
  2.1208 +  in GENL ctxt vlist thm end;
  2.1209 +
  2.1210 +
  2.1211 +fun MATCH_MP th1 th2 =
  2.1212 +   if (Dcterm.is_forall (Dcterm.drop_prop(cconcl th1)))
  2.1213 +   then MATCH_MP (th1 RS spec) th2
  2.1214 +   else MP th1 th2;
  2.1215 +
  2.1216 +
  2.1217 +(*----------------------------------------------------------------------------
  2.1218 + *        Existentials
  2.1219 + *---------------------------------------------------------------------------*)
  2.1220 +
  2.1221 +
  2.1222 +
  2.1223 +(*---------------------------------------------------------------------------
  2.1224 + * Existential elimination
  2.1225 + *
  2.1226 + *      A1 |- ?x.t[x]   ,   A2, "t[v]" |- t'
  2.1227 + *      ------------------------------------     (variable v occurs nowhere)
  2.1228 + *                A1 u A2 |- t'
  2.1229 + *
  2.1230 + *---------------------------------------------------------------------------*)
  2.1231 +
  2.1232 +fun CHOOSE ctxt (fvar, exth) fact =
  2.1233 +  let
  2.1234 +    val lam = #2 (Dcterm.dest_comb (Dcterm.drop_prop (cconcl exth)))
  2.1235 +    val redex = Dcterm.capply lam fvar
  2.1236 +    val t$u = Thm.term_of redex
  2.1237 +    val residue = Thm.cterm_of ctxt (Term.betapply (t, u))
  2.1238 +  in
  2.1239 +    GEN ctxt fvar (DISCH residue fact) RS (exth RS Thms.choose_thm)
  2.1240 +      handle THM (msg, _, _) => raise RULES_ERR "CHOOSE" msg
  2.1241 +  end;
  2.1242 +
  2.1243 +local
  2.1244 +  val prop = Thm.prop_of exI
  2.1245 +  val [P, x] = map (Thm.cterm_of @{context}) (Misc_Legacy.term_vars prop)
  2.1246 +in
  2.1247 +fun EXISTS (template,witness) thm =
  2.1248 +  let val abstr = #2 (Dcterm.dest_comb template) in
  2.1249 +    thm RS (cterm_instantiate [(P, abstr), (x, witness)] exI)
  2.1250 +      handle THM (msg, _, _) => raise RULES_ERR "EXISTS" msg
  2.1251 +  end
  2.1252 +end;
  2.1253 +
  2.1254 +(*----------------------------------------------------------------------------
  2.1255 + *
  2.1256 + *         A |- M
  2.1257 + *   -------------------   [v_1,...,v_n]
  2.1258 + *    A |- ?v1...v_n. M
  2.1259 + *
  2.1260 + *---------------------------------------------------------------------------*)
  2.1261 +
  2.1262 +fun EXISTL vlist th =
  2.1263 +  fold_rev (fn v => fn thm => EXISTS(Dcterm.mk_exists(v,cconcl thm), v) thm)
  2.1264 +           vlist th;
  2.1265 +
  2.1266 +
  2.1267 +(*----------------------------------------------------------------------------
  2.1268 + *
  2.1269 + *       A |- M[x_1,...,x_n]
  2.1270 + *   ----------------------------   [(x |-> y)_1,...,(x |-> y)_n]
  2.1271 + *       A |- ?y_1...y_n. M
  2.1272 + *
  2.1273 + *---------------------------------------------------------------------------*)
  2.1274 +(* Could be improved, but needs "subst_free" for certified terms *)
  2.1275 +
  2.1276 +fun IT_EXISTS ctxt blist th =
  2.1277 +  let
  2.1278 +    val blist' = map (apply2 Thm.term_of) blist
  2.1279 +    fun ex v M = Thm.cterm_of ctxt (USyntax.mk_exists{Bvar=v,Body = M})
  2.1280 +  in
  2.1281 +    fold_rev (fn (b as (r1,r2)) => fn thm =>
  2.1282 +        EXISTS(ex r2 (subst_free [b]
  2.1283 +                   (HOLogic.dest_Trueprop(Thm.prop_of thm))), Thm.cterm_of ctxt r1)
  2.1284 +              thm)
  2.1285 +       blist' th
  2.1286 +  end;
  2.1287 +
  2.1288 +(*---------------------------------------------------------------------------
  2.1289 + *  Faster version, that fails for some as yet unknown reason
  2.1290 + * fun IT_EXISTS blist th =
  2.1291 + *    let val {thy,...} = rep_thm th
  2.1292 + *        val tych = cterm_of thy
  2.1293 + *        fun detype (x,y) = ((#t o rep_cterm) x, (#t o rep_cterm) y)
  2.1294 + *   in
  2.1295 + *  fold (fn (b as (r1,r2), thm) =>
  2.1296 + *  EXISTS(D.mk_exists(r2, tych(subst_free[detype b](#t(rep_cterm(cconcl thm))))),
  2.1297 + *           r1) thm)  blist th
  2.1298 + *   end;
  2.1299 + *---------------------------------------------------------------------------*)
  2.1300 +
  2.1301 +(*----------------------------------------------------------------------------
  2.1302 + *        Rewriting
  2.1303 + *---------------------------------------------------------------------------*)
  2.1304 +
  2.1305 +fun SUBS ctxt thl =
  2.1306 +  rewrite_rule ctxt (map (fn th => th RS eq_reflection handle THM _ => th) thl);
  2.1307 +
  2.1308 +val rew_conv = Raw_Simplifier.rewrite_cterm (true, false, false) (K (K NONE));
  2.1309 +
  2.1310 +fun simpl_conv ctxt thl ctm =
  2.1311 + rew_conv (ctxt addsimps thl) ctm RS meta_eq_to_obj_eq;
  2.1312 +
  2.1313 +
  2.1314 +fun RIGHT_ASSOC ctxt = rewrite_rule ctxt [Thms.disj_assoc];
  2.1315 +
  2.1316 +
  2.1317 +
  2.1318 +(*---------------------------------------------------------------------------
  2.1319 + *                  TERMINATION CONDITION EXTRACTION
  2.1320 + *---------------------------------------------------------------------------*)
  2.1321 +
  2.1322 +
  2.1323 +(* Object language quantifier, i.e., "!" *)
  2.1324 +fun Forall v M = USyntax.mk_forall{Bvar=v, Body=M};
  2.1325 +
  2.1326 +
  2.1327 +(* Fragile: it's a cong if it is not "R y x ==> cut f R x y = f y" *)
  2.1328 +fun is_cong thm =
  2.1329 +  case (Thm.prop_of thm) of
  2.1330 +    (Const(@{const_name Pure.imp},_)$(Const(@{const_name Trueprop},_)$ _) $
  2.1331 +      (Const(@{const_name Pure.eq},_) $ (Const (@{const_name Wfrec.cut},_) $ f $ R $ a $ x) $ _)) =>
  2.1332 +        false
  2.1333 +  | _ => true;
  2.1334 +
  2.1335 +
  2.1336 +fun dest_equal(Const (@{const_name Pure.eq},_) $
  2.1337 +               (Const (@{const_name Trueprop},_) $ lhs)
  2.1338 +               $ (Const (@{const_name Trueprop},_) $ rhs)) = {lhs=lhs, rhs=rhs}
  2.1339 +  | dest_equal(Const (@{const_name Pure.eq},_) $ lhs $ rhs) = {lhs=lhs, rhs=rhs}
  2.1340 +  | dest_equal tm = USyntax.dest_eq tm;
  2.1341 +
  2.1342 +fun get_lhs tm = #lhs(dest_equal (HOLogic.dest_Trueprop tm));
  2.1343 +
  2.1344 +fun dest_all used (Const(@{const_name Pure.all},_) $ (a as Abs _)) = USyntax.dest_abs used a
  2.1345 +  | dest_all _ _ = raise RULES_ERR "dest_all" "not a !!";
  2.1346 +
  2.1347 +val is_all = can (dest_all []);
  2.1348 +
  2.1349 +fun strip_all used fm =
  2.1350 +   if (is_all fm)
  2.1351 +   then let val ({Bvar, Body}, used') = dest_all used fm
  2.1352 +            val (bvs, core, used'') = strip_all used' Body
  2.1353 +        in ((Bvar::bvs), core, used'')
  2.1354 +        end
  2.1355 +   else ([], fm, used);
  2.1356 +
  2.1357 +fun break_all(Const(@{const_name Pure.all},_) $ Abs (_,_,body)) = body
  2.1358 +  | break_all _ = raise RULES_ERR "break_all" "not a !!";
  2.1359 +
  2.1360 +fun list_break_all(Const(@{const_name Pure.all},_) $ Abs (s,ty,body)) =
  2.1361 +     let val (L,core) = list_break_all body
  2.1362 +     in ((s,ty)::L, core)
  2.1363 +     end
  2.1364 +  | list_break_all tm = ([],tm);
  2.1365 +
  2.1366 +(*---------------------------------------------------------------------------
  2.1367 + * Rename a term of the form
  2.1368 + *
  2.1369 + *      !!x1 ...xn. x1=M1 ==> ... ==> xn=Mn
  2.1370 + *                  ==> ((%v1...vn. Q) x1 ... xn = g x1 ... xn.
  2.1371 + * to one of
  2.1372 + *
  2.1373 + *      !!v1 ... vn. v1=M1 ==> ... ==> vn=Mn
  2.1374 + *      ==> ((%v1...vn. Q) v1 ... vn = g v1 ... vn.
  2.1375 + *
  2.1376 + * This prevents name problems in extraction, and helps the result to read
  2.1377 + * better. There is a problem with varstructs, since they can introduce more
  2.1378 + * than n variables, and some extra reasoning needs to be done.
  2.1379 + *---------------------------------------------------------------------------*)
  2.1380 +
  2.1381 +fun get ([],_,L) = rev L
  2.1382 +  | get (ant::rst,n,L) =
  2.1383 +      case (list_break_all ant)
  2.1384 +        of ([],_) => get (rst, n+1,L)
  2.1385 +         | (vlist,body) =>
  2.1386 +            let val eq = Logic.strip_imp_concl body
  2.1387 +                val (f,args) = USyntax.strip_comb (get_lhs eq)
  2.1388 +                val (vstrl,_) = USyntax.strip_abs f
  2.1389 +                val names  =
  2.1390 +                  Name.variant_list (Misc_Legacy.add_term_names(body, [])) (map (#1 o dest_Free) vstrl)
  2.1391 +            in get (rst, n+1, (names,n)::L) end
  2.1392 +            handle TERM _ => get (rst, n+1, L)
  2.1393 +              | Utils.ERR _ => get (rst, n+1, L);
  2.1394 +
  2.1395 +(* Note: Thm.rename_params_rule counts from 1, not 0 *)
  2.1396 +fun rename thm =
  2.1397 +  let
  2.1398 +    val ants = Logic.strip_imp_prems (Thm.prop_of thm)
  2.1399 +    val news = get (ants,1,[])
  2.1400 +  in fold Thm.rename_params_rule news thm end;
  2.1401 +
  2.1402 +
  2.1403 +(*---------------------------------------------------------------------------
  2.1404 + * Beta-conversion to the rhs of an equation (taken from hol90/drule.sml)
  2.1405 + *---------------------------------------------------------------------------*)
  2.1406 +
  2.1407 +fun list_beta_conv tm =
  2.1408 +  let fun rbeta th = Thm.transitive th (Thm.beta_conversion false (#2(Dcterm.dest_eq(cconcl th))))
  2.1409 +      fun iter [] = Thm.reflexive tm
  2.1410 +        | iter (v::rst) = rbeta (Thm.combination(iter rst) (Thm.reflexive v))
  2.1411 +  in iter  end;
  2.1412 +
  2.1413 +
  2.1414 +(*---------------------------------------------------------------------------
  2.1415 + * Trace information for the rewriter
  2.1416 + *---------------------------------------------------------------------------*)
  2.1417 +val tracing = Unsynchronized.ref false;
  2.1418 +
  2.1419 +fun say s = if !tracing then writeln s else ();
  2.1420 +
  2.1421 +fun print_thms ctxt s L =
  2.1422 +  say (cat_lines (s :: map (Display.string_of_thm ctxt) L));
  2.1423 +
  2.1424 +fun print_term ctxt s t =
  2.1425 +  say (cat_lines [s, Syntax.string_of_term ctxt t]);
  2.1426 +
  2.1427 +
  2.1428 +(*---------------------------------------------------------------------------
  2.1429 + * General abstraction handlers, should probably go in USyntax.
  2.1430 + *---------------------------------------------------------------------------*)
  2.1431 +fun mk_aabs (vstr, body) =
  2.1432 +  USyntax.mk_abs {Bvar = vstr, Body = body}
  2.1433 +  handle Utils.ERR _ => USyntax.mk_pabs {varstruct = vstr, body = body};
  2.1434 +
  2.1435 +fun list_mk_aabs (vstrl,tm) =
  2.1436 +    fold_rev (fn vstr => fn tm => mk_aabs(vstr,tm)) vstrl tm;
  2.1437 +
  2.1438 +fun dest_aabs used tm =
  2.1439 +   let val ({Bvar,Body}, used') = USyntax.dest_abs used tm
  2.1440 +   in (Bvar, Body, used') end
  2.1441 +   handle Utils.ERR _ =>
  2.1442 +     let val {varstruct, body, used} = USyntax.dest_pabs used tm
  2.1443 +     in (varstruct, body, used) end;
  2.1444 +
  2.1445 +fun strip_aabs used tm =
  2.1446 +   let val (vstr, body, used') = dest_aabs used tm
  2.1447 +       val (bvs, core, used'') = strip_aabs used' body
  2.1448 +   in (vstr::bvs, core, used'') end
  2.1449 +   handle Utils.ERR _ => ([], tm, used);
  2.1450 +
  2.1451 +fun dest_combn tm 0 = (tm,[])
  2.1452 +  | dest_combn tm n =
  2.1453 +     let val {Rator,Rand} = USyntax.dest_comb tm
  2.1454 +         val (f,rands) = dest_combn Rator (n-1)
  2.1455 +     in (f,Rand::rands)
  2.1456 +     end;
  2.1457 +
  2.1458 +
  2.1459 +
  2.1460 +
  2.1461 +local fun dest_pair M = let val {fst,snd} = USyntax.dest_pair M in (fst,snd) end
  2.1462 +      fun mk_fst tm =
  2.1463 +          let val ty as Type(@{type_name Product_Type.prod}, [fty,sty]) = type_of tm
  2.1464 +          in  Const (@{const_name Product_Type.fst}, ty --> fty) $ tm  end
  2.1465 +      fun mk_snd tm =
  2.1466 +          let val ty as Type(@{type_name Product_Type.prod}, [fty,sty]) = type_of tm
  2.1467 +          in  Const (@{const_name Product_Type.snd}, ty --> sty) $ tm  end
  2.1468 +in
  2.1469 +fun XFILL tych x vstruct =
  2.1470 +  let fun traverse p xocc L =
  2.1471 +        if (is_Free p)
  2.1472 +        then tych xocc::L
  2.1473 +        else let val (p1,p2) = dest_pair p
  2.1474 +             in traverse p1 (mk_fst xocc) (traverse p2  (mk_snd xocc) L)
  2.1475 +             end
  2.1476 +  in
  2.1477 +  traverse vstruct x []
  2.1478 +end end;
  2.1479 +
  2.1480 +(*---------------------------------------------------------------------------
  2.1481 + * Replace a free tuple (vstr) by a universally quantified variable (a).
  2.1482 + * Note that the notion of "freeness" for a tuple is different than for a
  2.1483 + * variable: if variables in the tuple also occur in any other place than
  2.1484 + * an occurrences of the tuple, they aren't "free" (which is thus probably
  2.1485 + *  the wrong word to use).
  2.1486 + *---------------------------------------------------------------------------*)
  2.1487 +
  2.1488 +fun VSTRUCT_ELIM ctxt tych a vstr th =
  2.1489 +  let val L = USyntax.free_vars_lr vstr
  2.1490 +      val bind1 = tych (HOLogic.mk_Trueprop (HOLogic.mk_eq(a,vstr)))
  2.1491 +      val thm1 = Thm.implies_intr bind1 (SUBS ctxt [SYM(Thm.assume bind1)] th)
  2.1492 +      val thm2 = forall_intr_list (map tych L) thm1
  2.1493 +      val thm3 = forall_elim_list (XFILL tych a vstr) thm2
  2.1494 +  in refl RS
  2.1495 +     rewrite_rule ctxt [Thm.symmetric (@{thm surjective_pairing} RS eq_reflection)] thm3
  2.1496 +  end;
  2.1497 +
  2.1498 +fun PGEN ctxt tych a vstr th =
  2.1499 +  let val a1 = tych a
  2.1500 +      val vstr1 = tych vstr
  2.1501 +  in
  2.1502 +  Thm.forall_intr a1
  2.1503 +     (if (is_Free vstr)
  2.1504 +      then cterm_instantiate [(vstr1,a1)] th
  2.1505 +      else VSTRUCT_ELIM ctxt tych a vstr th)
  2.1506 +  end;
  2.1507 +
  2.1508 +
  2.1509 +(*---------------------------------------------------------------------------
  2.1510 + * Takes apart a paired beta-redex, looking like "(\(x,y).N) vstr", into
  2.1511 + *
  2.1512 + *     (([x,y],N),vstr)
  2.1513 + *---------------------------------------------------------------------------*)
  2.1514 +fun dest_pbeta_redex used M n =
  2.1515 +  let val (f,args) = dest_combn M n
  2.1516 +      val dummy = dest_aabs used f
  2.1517 +  in (strip_aabs used f,args)
  2.1518 +  end;
  2.1519 +
  2.1520 +fun pbeta_redex M n = can (fn t => dest_pbeta_redex [] t n) M;
  2.1521 +
  2.1522 +fun dest_impl tm =
  2.1523 +  let val ants = Logic.strip_imp_prems tm
  2.1524 +      val eq = Logic.strip_imp_concl tm
  2.1525 +  in (ants,get_lhs eq)
  2.1526 +  end;
  2.1527 +
  2.1528 +fun restricted t = is_some (USyntax.find_term
  2.1529 +                            (fn (Const(@{const_name Wfrec.cut},_)) =>true | _ => false)
  2.1530 +                            t)
  2.1531 +
  2.1532 +fun CONTEXT_REWRITE_RULE main_ctxt (func, G, cut_lemma, congs) th =
  2.1533 + let val globals = func::G
  2.1534 +     val ctxt0 = empty_simpset main_ctxt
  2.1535 +     val pbeta_reduce = simpl_conv ctxt0 [@{thm split_conv} RS eq_reflection];
  2.1536 +     val tc_list = Unsynchronized.ref []: term list Unsynchronized.ref
  2.1537 +     val cut_lemma' = cut_lemma RS eq_reflection
  2.1538 +     fun prover used ctxt thm =
  2.1539 +     let fun cong_prover ctxt thm =
  2.1540 +         let val dummy = say "cong_prover:"
  2.1541 +             val cntxt = Simplifier.prems_of ctxt
  2.1542 +             val dummy = print_thms ctxt "cntxt:" cntxt
  2.1543 +             val dummy = say "cong rule:"
  2.1544 +             val dummy = say (Display.string_of_thm ctxt thm)
  2.1545 +             (* Unquantified eliminate *)
  2.1546 +             fun uq_eliminate (thm,imp) =
  2.1547 +                 let val tych = Thm.cterm_of ctxt
  2.1548 +                     val _ = print_term ctxt "To eliminate:" imp
  2.1549 +                     val ants = map tych (Logic.strip_imp_prems imp)
  2.1550 +                     val eq = Logic.strip_imp_concl imp
  2.1551 +                     val lhs = tych(get_lhs eq)
  2.1552 +                     val ctxt' = Simplifier.add_prems (map ASSUME ants) ctxt
  2.1553 +                     val lhs_eq_lhs1 = Raw_Simplifier.rewrite_cterm (false,true,false) (prover used) ctxt' lhs
  2.1554 +                       handle Utils.ERR _ => Thm.reflexive lhs
  2.1555 +                     val _ = print_thms ctxt' "proven:" [lhs_eq_lhs1]
  2.1556 +                     val lhs_eq_lhs2 = implies_intr_list ants lhs_eq_lhs1
  2.1557 +                     val lhs_eeq_lhs2 = lhs_eq_lhs2 RS meta_eq_to_obj_eq
  2.1558 +                  in
  2.1559 +                  lhs_eeq_lhs2 COMP thm
  2.1560 +                  end
  2.1561 +             fun pq_eliminate (thm, vlist, imp_body, lhs_eq) =
  2.1562 +              let val ((vstrl, _, used'), args) = dest_pbeta_redex used lhs_eq (length vlist)
  2.1563 +                  val dummy = forall (op aconv) (ListPair.zip (vlist, args))
  2.1564 +                    orelse error "assertion failed in CONTEXT_REWRITE_RULE"
  2.1565 +                  val imp_body1 = subst_free (ListPair.zip (args, vstrl))
  2.1566 +                                             imp_body
  2.1567 +                  val tych = Thm.cterm_of ctxt
  2.1568 +                  val ants1 = map tych (Logic.strip_imp_prems imp_body1)
  2.1569 +                  val eq1 = Logic.strip_imp_concl imp_body1
  2.1570 +                  val Q = get_lhs eq1
  2.1571 +                  val QeqQ1 = pbeta_reduce (tych Q)
  2.1572 +                  val Q1 = #2(Dcterm.dest_eq(cconcl QeqQ1))
  2.1573 +                  val ctxt' = Simplifier.add_prems (map ASSUME ants1) ctxt
  2.1574 +                  val Q1eeqQ2 = Raw_Simplifier.rewrite_cterm (false,true,false) (prover used') ctxt' Q1
  2.1575 +                                handle Utils.ERR _ => Thm.reflexive Q1
  2.1576 +                  val Q2 = #2 (Logic.dest_equals (Thm.prop_of Q1eeqQ2))
  2.1577 +                  val Q3 = tych(list_comb(list_mk_aabs(vstrl,Q2),vstrl))
  2.1578 +                  val Q2eeqQ3 = Thm.symmetric(pbeta_reduce Q3 RS eq_reflection)
  2.1579 +                  val thA = Thm.transitive(QeqQ1 RS eq_reflection) Q1eeqQ2
  2.1580 +                  val QeeqQ3 = Thm.transitive thA Q2eeqQ3 handle THM _ =>
  2.1581 +                               ((Q2eeqQ3 RS meta_eq_to_obj_eq)
  2.1582 +                                RS ((thA RS meta_eq_to_obj_eq) RS trans))
  2.1583 +                                RS eq_reflection
  2.1584 +                  val impth = implies_intr_list ants1 QeeqQ3
  2.1585 +                  val impth1 = impth RS meta_eq_to_obj_eq
  2.1586 +                  (* Need to abstract *)
  2.1587 +                  val ant_th = Utils.itlist2 (PGEN ctxt' tych) args vstrl impth1
  2.1588 +              in ant_th COMP thm
  2.1589 +              end
  2.1590 +             fun q_eliminate (thm, imp) =
  2.1591 +              let val (vlist, imp_body, used') = strip_all used imp
  2.1592 +                  val (ants,Q) = dest_impl imp_body
  2.1593 +              in if (pbeta_redex Q) (length vlist)
  2.1594 +                 then pq_eliminate (thm, vlist, imp_body, Q)
  2.1595 +                 else
  2.1596 +                 let val tych = Thm.cterm_of ctxt
  2.1597 +                     val ants1 = map tych ants
  2.1598 +                     val ctxt' = Simplifier.add_prems (map ASSUME ants1) ctxt
  2.1599 +                     val Q_eeq_Q1 = Raw_Simplifier.rewrite_cterm
  2.1600 +                        (false,true,false) (prover used') ctxt' (tych Q)
  2.1601 +                      handle Utils.ERR _ => Thm.reflexive (tych Q)
  2.1602 +                     val lhs_eeq_lhs2 = implies_intr_list ants1 Q_eeq_Q1
  2.1603 +                     val lhs_eq_lhs2 = lhs_eeq_lhs2 RS meta_eq_to_obj_eq
  2.1604 +                     val ant_th = forall_intr_list(map tych vlist)lhs_eq_lhs2
  2.1605 +                 in
  2.1606 +                 ant_th COMP thm
  2.1607 +              end end
  2.1608 +
  2.1609 +             fun eliminate thm =
  2.1610 +               case Thm.prop_of thm of
  2.1611 +                 Const(@{const_name Pure.imp},_) $ imp $ _ =>
  2.1612 +                   eliminate
  2.1613 +                    (if not(is_all imp)
  2.1614 +                     then uq_eliminate (thm, imp)
  2.1615 +                     else q_eliminate (thm, imp))
  2.1616 +                            (* Assume that the leading constant is ==,   *)
  2.1617 +                | _ => thm  (* if it is not a ==>                        *)
  2.1618 +         in SOME(eliminate (rename thm)) end
  2.1619 +         handle Utils.ERR _ => NONE    (* FIXME handle THM as well?? *)
  2.1620 +
  2.1621 +        fun restrict_prover ctxt thm =
  2.1622 +          let val _ = say "restrict_prover:"
  2.1623 +              val cntxt = rev (Simplifier.prems_of ctxt)
  2.1624 +              val _ = print_thms ctxt "cntxt:" cntxt
  2.1625 +              val Const(@{const_name Pure.imp},_) $ (Const(@{const_name Trueprop},_) $ A) $ _ =
  2.1626 +                Thm.prop_of thm
  2.1627 +              fun genl tm = let val vlist = subtract (op aconv) globals
  2.1628 +                                           (Misc_Legacy.add_term_frees(tm,[]))
  2.1629 +                            in fold_rev Forall vlist tm
  2.1630 +                            end
  2.1631 +              (*--------------------------------------------------------------
  2.1632 +               * This actually isn't quite right, since it will think that
  2.1633 +               * not-fully applied occs. of "f" in the context mean that the
  2.1634 +               * current call is nested. The real solution is to pass in a
  2.1635 +               * term "f v1..vn" which is a pattern that any full application
  2.1636 +               * of "f" will match.
  2.1637 +               *-------------------------------------------------------------*)
  2.1638 +              val func_name = #1(dest_Const func)
  2.1639 +              fun is_func (Const (name,_)) = (name = func_name)
  2.1640 +                | is_func _                = false
  2.1641 +              val rcontext = rev cntxt
  2.1642 +              val cncl = HOLogic.dest_Trueprop o Thm.prop_of
  2.1643 +              val antl = case rcontext of [] => []
  2.1644 +                         | _   => [USyntax.list_mk_conj(map cncl rcontext)]
  2.1645 +              val TC = genl(USyntax.list_mk_imp(antl, A))
  2.1646 +              val _ = print_term ctxt "func:" func
  2.1647 +              val _ = print_term ctxt "TC:" (HOLogic.mk_Trueprop TC)
  2.1648 +              val _ = tc_list := (TC :: !tc_list)
  2.1649 +              val nestedp = is_some (USyntax.find_term is_func TC)
  2.1650 +              val _ = if nestedp then say "nested" else say "not_nested"
  2.1651 +              val th' = if nestedp then raise RULES_ERR "solver" "nested function"
  2.1652 +                        else let val cTC = Thm.cterm_of ctxt (HOLogic.mk_Trueprop TC)
  2.1653 +                             in case rcontext of
  2.1654 +                                [] => SPEC_ALL(ASSUME cTC)
  2.1655 +                               | _ => MP (SPEC_ALL (ASSUME cTC))
  2.1656 +                                         (LIST_CONJ rcontext)
  2.1657 +                             end
  2.1658 +              val th'' = th' RS thm
  2.1659 +          in SOME (th'')
  2.1660 +          end handle Utils.ERR _ => NONE    (* FIXME handle THM as well?? *)
  2.1661 +    in
  2.1662 +    (if (is_cong thm) then cong_prover else restrict_prover) ctxt thm
  2.1663 +    end
  2.1664 +    val ctm = Thm.cprop_of th
  2.1665 +    val names = Misc_Legacy.add_term_names (Thm.term_of ctm, [])
  2.1666 +    val th1 =
  2.1667 +      Raw_Simplifier.rewrite_cterm (false, true, false)
  2.1668 +        (prover names) (ctxt0 addsimps [cut_lemma'] |> fold Simplifier.add_eqcong congs) ctm
  2.1669 +    val th2 = Thm.equal_elim th1 th
  2.1670 + in
  2.1671 + (th2, filter_out restricted (!tc_list))
  2.1672 + end;
  2.1673 +
  2.1674 +
  2.1675 +fun prove ctxt strict (t, tac) =
  2.1676 +  let
  2.1677 +    val ctxt' = Variable.auto_fixes t ctxt;
  2.1678 +  in
  2.1679 +    if strict
  2.1680 +    then Goal.prove ctxt' [] [] t (K tac)
  2.1681 +    else Goal.prove ctxt' [] [] t (K tac)
  2.1682 +      handle ERROR msg => (warning msg; raise RULES_ERR "prove" msg)
  2.1683 +  end;
  2.1684 +
  2.1685 +end;
  2.1686 +
  2.1687 +
  2.1688 +(*** theory operations ***)
  2.1689 +
  2.1690 +structure Thry: THRY =
  2.1691 +struct
  2.1692 +
  2.1693 +
  2.1694 +fun THRY_ERR func mesg = Utils.ERR {module = "Thry", func = func, mesg = mesg};
  2.1695 +
  2.1696 +
  2.1697 +(*---------------------------------------------------------------------------
  2.1698 + *    Matching
  2.1699 + *---------------------------------------------------------------------------*)
  2.1700 +
  2.1701 +local
  2.1702 +
  2.1703 +fun tybind (ixn, (S, T)) = (TVar (ixn, S), T);
  2.1704 +
  2.1705 +in
  2.1706 +
  2.1707 +fun match_term thry pat ob =
  2.1708 +  let
  2.1709 +    val (ty_theta, tm_theta) = Pattern.match thry (pat,ob) (Vartab.empty, Vartab.empty);
  2.1710 +    fun tmbind (ixn, (T, t)) = (Var (ixn, Envir.subst_type ty_theta T), t)
  2.1711 +  in (map tmbind (Vartab.dest tm_theta), map tybind (Vartab.dest ty_theta))
  2.1712 +  end;
  2.1713 +
  2.1714 +fun match_type thry pat ob =
  2.1715 +  map tybind (Vartab.dest (Sign.typ_match thry (pat, ob) Vartab.empty));
  2.1716 +
  2.1717 +end;
  2.1718 +
  2.1719 +
  2.1720 +(*---------------------------------------------------------------------------
  2.1721 + * Typing
  2.1722 + *---------------------------------------------------------------------------*)
  2.1723 +
  2.1724 +fun typecheck thy t =
  2.1725 +  Thm.global_cterm_of thy t
  2.1726 +    handle TYPE (msg, _, _) => raise THRY_ERR "typecheck" msg
  2.1727 +      | TERM (msg, _) => raise THRY_ERR "typecheck" msg;
  2.1728 +
  2.1729 +
  2.1730 +(*---------------------------------------------------------------------------
  2.1731 + * Get information about datatypes
  2.1732 + *---------------------------------------------------------------------------*)
  2.1733 +
  2.1734 +fun match_info thy dtco =
  2.1735 +  case (BNF_LFP_Compat.get_info thy [BNF_LFP_Compat.Keep_Nesting] dtco,
  2.1736 +         BNF_LFP_Compat.get_constrs thy dtco) of
  2.1737 +      (SOME {case_name, ... }, SOME constructors) =>
  2.1738 +        SOME {case_const = Const (case_name, Sign.the_const_type thy case_name), constructors = map Const constructors}
  2.1739 +    | _ => NONE;
  2.1740 +
  2.1741 +fun induct_info thy dtco = case BNF_LFP_Compat.get_info thy [BNF_LFP_Compat.Keep_Nesting] dtco of
  2.1742 +        NONE => NONE
  2.1743 +      | SOME {nchotomy, ...} =>
  2.1744 +          SOME {nchotomy = nchotomy,
  2.1745 +                constructors = (map Const o the o BNF_LFP_Compat.get_constrs thy) dtco};
  2.1746 +
  2.1747 +fun extract_info thy =
  2.1748 + let val infos = map snd (Symtab.dest (BNF_LFP_Compat.get_all thy [BNF_LFP_Compat.Keep_Nesting]))
  2.1749 + in {case_congs = map (mk_meta_eq o #case_cong) infos,
  2.1750 +     case_rewrites = maps (map mk_meta_eq o #case_rewrites) infos}
  2.1751 + end;
  2.1752 +
  2.1753 +
  2.1754 +end;
  2.1755 +
  2.1756 +
  2.1757 +(*** first part of main module ***)
  2.1758 +
  2.1759 +structure Prim: PRIM =
  2.1760 +struct
  2.1761 +
  2.1762 +val trace = Unsynchronized.ref false;
  2.1763 +
  2.1764 +
  2.1765 +fun TFL_ERR func mesg = Utils.ERR {module = "Tfl", func = func, mesg = mesg};
  2.1766 +
  2.1767 +val concl = #2 o Rules.dest_thm;
  2.1768 +val hyp = #1 o Rules.dest_thm;
  2.1769 +
  2.1770 +val list_mk_type = Utils.end_itlist (curry (op -->));
  2.1771 +
  2.1772 +fun front_last [] = raise TFL_ERR "front_last" "empty list"
  2.1773 +  | front_last [x] = ([],x)
  2.1774 +  | front_last (h::t) =
  2.1775 +     let val (pref,x) = front_last t
  2.1776 +     in
  2.1777 +        (h::pref,x)
  2.1778 +     end;
  2.1779 +
  2.1780 +
  2.1781 +(*---------------------------------------------------------------------------
  2.1782 + * The next function is common to pattern-match translation and
  2.1783 + * proof of completeness of cases for the induction theorem.
  2.1784 + *
  2.1785 + * The curried function "gvvariant" returns a function to generate distinct
  2.1786 + * variables that are guaranteed not to be in names.  The names of
  2.1787 + * the variables go u, v, ..., z, aa, ..., az, ...  The returned
  2.1788 + * function contains embedded refs!
  2.1789 + *---------------------------------------------------------------------------*)
  2.1790 +fun gvvariant names =
  2.1791 +  let val slist = Unsynchronized.ref names
  2.1792 +      val vname = Unsynchronized.ref "u"
  2.1793 +      fun new() =
  2.1794 +         if member (op =) (!slist) (!vname)
  2.1795 +         then (vname := Symbol.bump_string (!vname);  new())
  2.1796 +         else (slist := !vname :: !slist;  !vname)
  2.1797 +  in
  2.1798 +  fn ty => Free(new(), ty)
  2.1799 +  end;
  2.1800 +
  2.1801 +
  2.1802 +(*---------------------------------------------------------------------------
  2.1803 + * Used in induction theorem production. This is the simple case of
  2.1804 + * partitioning up pattern rows by the leading constructor.
  2.1805 + *---------------------------------------------------------------------------*)
  2.1806 +fun ipartition gv (constructors,rows) =
  2.1807 +  let fun pfail s = raise TFL_ERR "partition.part" s
  2.1808 +      fun part {constrs = [],   rows = [],   A} = rev A
  2.1809 +        | part {constrs = [],   rows = _::_, A} = pfail"extra cases in defn"
  2.1810 +        | part {constrs = _::_, rows = [],   A} = pfail"cases missing in defn"
  2.1811 +        | part {constrs = c::crst, rows,     A} =
  2.1812 +          let val (c, T) = dest_Const c
  2.1813 +              val L = binder_types T
  2.1814 +              val (in_group, not_in_group) =
  2.1815 +               fold_rev (fn (row as (p::rst, rhs)) =>
  2.1816 +                         fn (in_group,not_in_group) =>
  2.1817 +                  let val (pc,args) = USyntax.strip_comb p
  2.1818 +                  in if (#1(dest_Const pc) = c)
  2.1819 +                     then ((args@rst, rhs)::in_group, not_in_group)
  2.1820 +                     else (in_group, row::not_in_group)
  2.1821 +                  end)      rows ([],[])
  2.1822 +              val col_types = Utils.take type_of (length L, #1(hd in_group))
  2.1823 +          in
  2.1824 +          part{constrs = crst, rows = not_in_group,
  2.1825 +               A = {constructor = c,
  2.1826 +                    new_formals = map gv col_types,
  2.1827 +                    group = in_group}::A}
  2.1828 +          end
  2.1829 +  in part{constrs = constructors, rows = rows, A = []}
  2.1830 +  end;
  2.1831 +
  2.1832 +
  2.1833 +
  2.1834 +(*---------------------------------------------------------------------------
  2.1835 + * Each pattern carries with it a tag (i,b) where
  2.1836 + * i is the clause it came from and
  2.1837 + * b=true indicates that clause was given by the user
  2.1838 + * (or is an instantiation of a user supplied pattern)
  2.1839 + * b=false --> i = ~1
  2.1840 + *---------------------------------------------------------------------------*)
  2.1841 +
  2.1842 +type pattern = term * (int * bool)
  2.1843 +
  2.1844 +fun pattern_map f (tm,x) = (f tm, x);
  2.1845 +
  2.1846 +fun pattern_subst theta = pattern_map (subst_free theta);
  2.1847 +
  2.1848 +val pat_of = fst;
  2.1849 +fun row_of_pat x = fst (snd x);
  2.1850 +fun given x = snd (snd x);
  2.1851 +
  2.1852 +(*---------------------------------------------------------------------------
  2.1853 + * Produce an instance of a constructor, plus genvars for its arguments.
  2.1854 + *---------------------------------------------------------------------------*)
  2.1855 +fun fresh_constr ty_match colty gv c =
  2.1856 +  let val (_,Ty) = dest_Const c
  2.1857 +      val L = binder_types Ty
  2.1858 +      and ty = body_type Ty
  2.1859 +      val ty_theta = ty_match ty colty
  2.1860 +      val c' = USyntax.inst ty_theta c
  2.1861 +      val gvars = map (USyntax.inst ty_theta o gv) L
  2.1862 +  in (c', gvars)
  2.1863 +  end;
  2.1864 +
  2.1865 +
  2.1866 +(*---------------------------------------------------------------------------
  2.1867 + * Goes through a list of rows and picks out the ones beginning with a
  2.1868 + * pattern with constructor = name.
  2.1869 + *---------------------------------------------------------------------------*)
  2.1870 +fun mk_group name rows =
  2.1871 +  fold_rev (fn (row as ((prfx, p::rst), rhs)) =>
  2.1872 +            fn (in_group,not_in_group) =>
  2.1873 +               let val (pc,args) = USyntax.strip_comb p
  2.1874 +               in if ((#1 (Term.dest_Const pc) = name) handle TERM _ => false)
  2.1875 +                  then (((prfx,args@rst), rhs)::in_group, not_in_group)
  2.1876 +                  else (in_group, row::not_in_group) end)
  2.1877 +      rows ([],[]);
  2.1878 +
  2.1879 +(*---------------------------------------------------------------------------
  2.1880 + * Partition the rows. Not efficient: we should use hashing.
  2.1881 + *---------------------------------------------------------------------------*)
  2.1882 +fun partition _ _ (_,_,_,[]) = raise TFL_ERR "partition" "no rows"
  2.1883 +  | partition gv ty_match
  2.1884 +              (constructors, colty, res_ty, rows as (((prfx,_),_)::_)) =
  2.1885 +let val fresh = fresh_constr ty_match colty gv
  2.1886 +     fun part {constrs = [],      rows, A} = rev A
  2.1887 +       | part {constrs = c::crst, rows, A} =
  2.1888 +         let val (c',gvars) = fresh c
  2.1889 +             val (in_group, not_in_group) = mk_group (#1 (dest_Const c')) rows
  2.1890 +             val in_group' =
  2.1891 +                 if (null in_group)  (* Constructor not given *)
  2.1892 +                 then [((prfx, #2(fresh c)), (USyntax.ARB res_ty, (~1,false)))]
  2.1893 +                 else in_group
  2.1894 +         in
  2.1895 +         part{constrs = crst,
  2.1896 +              rows = not_in_group,
  2.1897 +              A = {constructor = c',
  2.1898 +                   new_formals = gvars,
  2.1899 +                   group = in_group'}::A}
  2.1900 +         end
  2.1901 +in part{constrs=constructors, rows=rows, A=[]}
  2.1902 +end;
  2.1903 +
  2.1904 +(*---------------------------------------------------------------------------
  2.1905 + * Misc. routines used in mk_case
  2.1906 + *---------------------------------------------------------------------------*)
  2.1907 +
  2.1908 +fun mk_pat (c,l) =
  2.1909 +  let val L = length (binder_types (type_of c))
  2.1910 +      fun build (prfx,tag,plist) =
  2.1911 +          let val (args, plist') = chop L plist
  2.1912 +          in (prfx,tag,list_comb(c,args)::plist') end
  2.1913 +  in map build l end;
  2.1914 +
  2.1915 +fun v_to_prfx (prfx, v::pats) = (v::prfx,pats)
  2.1916 +  | v_to_prfx _ = raise TFL_ERR "mk_case" "v_to_prfx";
  2.1917 +
  2.1918 +fun v_to_pats (v::prfx,tag, pats) = (prfx, tag, v::pats)
  2.1919 +  | v_to_pats _ = raise TFL_ERR "mk_case" "v_to_pats";
  2.1920 +
  2.1921 +
  2.1922 +(*----------------------------------------------------------------------------
  2.1923 + * Translation of pattern terms into nested case expressions.
  2.1924 + *
  2.1925 + * This performs the translation and also builds the full set of patterns.
  2.1926 + * Thus it supports the construction of induction theorems even when an
  2.1927 + * incomplete set of patterns is given.
  2.1928 + *---------------------------------------------------------------------------*)
  2.1929 +
  2.1930 +fun mk_case ty_info ty_match usednames range_ty =
  2.1931 + let
  2.1932 + fun mk_case_fail s = raise TFL_ERR "mk_case" s
  2.1933 + val fresh_var = gvvariant usednames
  2.1934 + val divide = partition fresh_var ty_match
  2.1935 + fun expand constructors ty ((_,[]), _) = mk_case_fail"expand_var_row"
  2.1936 +   | expand constructors ty (row as ((prfx, p::rst), rhs)) =
  2.1937 +       if (is_Free p)
  2.1938 +       then let val fresh = fresh_constr ty_match ty fresh_var
  2.1939 +                fun expnd (c,gvs) =
  2.1940 +                  let val capp = list_comb(c,gvs)
  2.1941 +                  in ((prfx, capp::rst), pattern_subst[(p,capp)] rhs)
  2.1942 +                  end
  2.1943 +            in map expnd (map fresh constructors)  end
  2.1944 +       else [row]
  2.1945 + fun mk{rows=[],...} = mk_case_fail"no rows"
  2.1946 +   | mk{path=[], rows = ((prfx, []), (tm,tag))::_} =  (* Done *)
  2.1947 +        ([(prfx,tag,[])], tm)
  2.1948 +   | mk{path=[], rows = _::_} = mk_case_fail"blunder"
  2.1949 +   | mk{path as u::rstp, rows as ((prfx, []), rhs)::rst} =
  2.1950 +        mk{path = path,
  2.1951 +           rows = ((prfx, [fresh_var(type_of u)]), rhs)::rst}
  2.1952 +   | mk{path = u::rstp, rows as ((_, p::_), _)::_} =
  2.1953 +     let val (pat_rectangle,rights) = ListPair.unzip rows
  2.1954 +         val col0 = map(hd o #2) pat_rectangle
  2.1955 +     in
  2.1956 +     if (forall is_Free col0)
  2.1957 +     then let val rights' = map (fn(v,e) => pattern_subst[(v,u)] e)
  2.1958 +                                (ListPair.zip (col0, rights))
  2.1959 +              val pat_rectangle' = map v_to_prfx pat_rectangle
  2.1960 +              val (pref_patl,tm) = mk{path = rstp,
  2.1961 +                                      rows = ListPair.zip (pat_rectangle',
  2.1962 +                                                           rights')}
  2.1963 +          in (map v_to_pats pref_patl, tm)
  2.1964 +          end
  2.1965 +     else
  2.1966 +     let val pty as Type (ty_name,_) = type_of p
  2.1967 +     in
  2.1968 +     case (ty_info ty_name)
  2.1969 +     of NONE => mk_case_fail("Not a known datatype: "^ty_name)
  2.1970 +      | SOME{case_const,constructors} =>
  2.1971 +        let
  2.1972 +            val case_const_name = #1(dest_Const case_const)
  2.1973 +            val nrows = maps (expand constructors pty) rows
  2.1974 +            val subproblems = divide(constructors, pty, range_ty, nrows)
  2.1975 +            val groups      = map #group subproblems
  2.1976 +            and new_formals = map #new_formals subproblems
  2.1977 +            and constructors' = map #constructor subproblems
  2.1978 +            val news = map (fn (nf,rows) => {path = nf@rstp, rows=rows})
  2.1979 +                           (ListPair.zip (new_formals, groups))
  2.1980 +            val rec_calls = map mk news
  2.1981 +            val (pat_rect,dtrees) = ListPair.unzip rec_calls
  2.1982 +            val case_functions = map USyntax.list_mk_abs
  2.1983 +                                  (ListPair.zip (new_formals, dtrees))
  2.1984 +            val types = map type_of (case_functions@[u]) @ [range_ty]
  2.1985 +            val case_const' = Const(case_const_name, list_mk_type types)
  2.1986 +            val tree = list_comb(case_const', case_functions@[u])
  2.1987 +            val pat_rect1 = flat (ListPair.map mk_pat (constructors', pat_rect))
  2.1988 +        in (pat_rect1,tree)
  2.1989 +        end
  2.1990 +     end end
  2.1991 + in mk
  2.1992 + end;
  2.1993 +
  2.1994 +
  2.1995 +(* Repeated variable occurrences in a pattern are not allowed. *)
  2.1996 +fun FV_multiset tm =
  2.1997 +   case (USyntax.dest_term tm)
  2.1998 +     of USyntax.VAR{Name = c, Ty = T} => [Free(c, T)]
  2.1999 +      | USyntax.CONST _ => []
  2.2000 +      | USyntax.COMB{Rator, Rand} => FV_multiset Rator @ FV_multiset Rand
  2.2001 +      | USyntax.LAMB _ => raise TFL_ERR "FV_multiset" "lambda";
  2.2002 +
  2.2003 +fun no_repeat_vars thy pat =
  2.2004 + let fun check [] = true
  2.2005 +       | check (v::rst) =
  2.2006 +         if member (op aconv) rst v then
  2.2007 +            raise TFL_ERR "no_repeat_vars"
  2.2008 +                          (quote (#1 (dest_Free v)) ^
  2.2009 +                          " occurs repeatedly in the pattern " ^
  2.2010 +                          quote (Syntax.string_of_term_global thy pat))
  2.2011 +         else check rst
  2.2012 + in check (FV_multiset pat)
  2.2013 + end;
  2.2014 +
  2.2015 +fun dest_atom (Free p) = p
  2.2016 +  | dest_atom (Const p) = p
  2.2017 +  | dest_atom  _ = raise TFL_ERR "dest_atom" "function name not an identifier";
  2.2018 +
  2.2019 +fun same_name (p,q) = #1(dest_atom p) = #1(dest_atom q);
  2.2020 +
  2.2021 +local fun mk_functional_err s = raise TFL_ERR "mk_functional" s
  2.2022 +      fun single [_$_] =
  2.2023 +              mk_functional_err "recdef does not allow currying"
  2.2024 +        | single [f] = f
  2.2025 +        | single fs  =
  2.2026 +              (*multiple function names?*)
  2.2027 +              if length (distinct same_name fs) < length fs
  2.2028 +              then mk_functional_err
  2.2029 +                   "The function being declared appears with multiple types"
  2.2030 +              else mk_functional_err
  2.2031 +                   (string_of_int (length fs) ^
  2.2032 +                    " distinct function names being declared")
  2.2033 +in
  2.2034 +fun mk_functional thy clauses =
  2.2035 + let val (L,R) = ListPair.unzip (map HOLogic.dest_eq clauses
  2.2036 +                   handle TERM _ => raise TFL_ERR "mk_functional"
  2.2037 +                        "recursion equations must use the = relation")
  2.2038 +     val (funcs,pats) = ListPair.unzip (map (fn (t$u) =>(t,u)) L)
  2.2039 +     val atom = single (distinct (op aconv) funcs)
  2.2040 +     val (fname,ftype) = dest_atom atom
  2.2041 +     val dummy = map (no_repeat_vars thy) pats
  2.2042 +     val rows = ListPair.zip (map (fn x => ([]:term list,[x])) pats,
  2.2043 +                              map_index (fn (i, t) => (t,(i,true))) R)
  2.2044 +     val names = List.foldr Misc_Legacy.add_term_names [] R
  2.2045 +     val atype = type_of(hd pats)
  2.2046 +     and aname = singleton (Name.variant_list names) "a"
  2.2047 +     val a = Free(aname,atype)
  2.2048 +     val ty_info = Thry.match_info thy
  2.2049 +     val ty_match = Thry.match_type thy
  2.2050 +     val range_ty = type_of (hd R)
  2.2051 +     val (patts, case_tm) = mk_case ty_info ty_match (aname::names) range_ty
  2.2052 +                                    {path=[a], rows=rows}
  2.2053 +     val patts1 = map (fn (_,tag,[pat]) => (pat,tag)) patts
  2.2054 +          handle Match => mk_functional_err "error in pattern-match translation"
  2.2055 +     val patts2 = Library.sort (Library.int_ord o apply2 row_of_pat) patts1
  2.2056 +     val finals = map row_of_pat patts2
  2.2057 +     val originals = map (row_of_pat o #2) rows
  2.2058 +     val dummy = case (subtract (op =) finals originals)
  2.2059 +             of [] => ()
  2.2060 +          | L => mk_functional_err
  2.2061 + ("The following clauses are redundant (covered by preceding clauses): " ^
  2.2062 +                   commas (map (fn i => string_of_int (i + 1)) L))
  2.2063 + in {functional = Abs(Long_Name.base_name fname, ftype,
  2.2064 +                      abstract_over (atom, absfree (aname,atype) case_tm)),
  2.2065 +     pats = patts2}
  2.2066 +end end;
  2.2067 +
  2.2068 +
  2.2069 +(*----------------------------------------------------------------------------
  2.2070 + *
  2.2071 + *                    PRINCIPLES OF DEFINITION
  2.2072 + *
  2.2073 + *---------------------------------------------------------------------------*)
  2.2074 +
  2.2075 +
  2.2076 +(*For Isabelle, the lhs of a definition must be a constant.*)
  2.2077 +fun const_def sign (c, Ty, rhs) =
  2.2078 +  singleton (Syntax.check_terms (Proof_Context.init_global sign))
  2.2079 +    (Const(@{const_name Pure.eq},dummyT) $ Const(c,Ty) $ rhs);
  2.2080 +
  2.2081 +(*Make all TVars available for instantiation by adding a ? to the front*)
  2.2082 +fun poly_tvars (Type(a,Ts)) = Type(a, map (poly_tvars) Ts)
  2.2083 +  | poly_tvars (TFree (a,sort)) = TVar (("?" ^ a, 0), sort)
  2.2084 +  | poly_tvars (TVar ((a,i),sort)) = TVar (("?" ^ a, i+1), sort);
  2.2085 +
  2.2086 +local
  2.2087 +  val f_eq_wfrec_R_M =
  2.2088 +    #ant(USyntax.dest_imp(#2(USyntax.strip_forall (concl Thms.WFREC_COROLLARY))))
  2.2089 +  val {lhs=f, rhs} = USyntax.dest_eq f_eq_wfrec_R_M
  2.2090 +  val (fname,_) = dest_Free f
  2.2091 +  val (wfrec,_) = USyntax.strip_comb rhs
  2.2092 +in
  2.2093 +
  2.2094 +fun wfrec_definition0 fid R (functional as Abs(x, Ty, _)) thy =
  2.2095 +  let
  2.2096 +    val def_name = Thm.def_name (Long_Name.base_name fid)
  2.2097 +    val wfrec_R_M = map_types poly_tvars (wfrec $ map_types poly_tvars R) $ functional
  2.2098 +    val def_term = const_def thy (fid, Ty, wfrec_R_M)
  2.2099 +    val ([def], thy') =
  2.2100 +      Global_Theory.add_defs false [Thm.no_attributes (Binding.name def_name, def_term)] thy
  2.2101 +  in (def, thy') end;
  2.2102 +
  2.2103 +end;
  2.2104 +
  2.2105 +
  2.2106 +
  2.2107 +(*---------------------------------------------------------------------------
  2.2108 + * This structure keeps track of congruence rules that aren't derived
  2.2109 + * from a datatype definition.
  2.2110 + *---------------------------------------------------------------------------*)
  2.2111 +fun extraction_thms thy =
  2.2112 + let val {case_rewrites,case_congs} = Thry.extract_info thy
  2.2113 + in (case_rewrites, case_congs)
  2.2114 + end;
  2.2115 +
  2.2116 +
  2.2117 +(*---------------------------------------------------------------------------
  2.2118 + * Pair patterns with termination conditions. The full list of patterns for
  2.2119 + * a definition is merged with the TCs arising from the user-given clauses.
  2.2120 + * There can be fewer clauses than the full list, if the user omitted some
  2.2121 + * cases. This routine is used to prepare input for mk_induction.
  2.2122 + *---------------------------------------------------------------------------*)
  2.2123 +fun merge full_pats TCs =
  2.2124 +let fun insert (p,TCs) =
  2.2125 +      let fun insrt ((x as (h,[]))::rst) =
  2.2126 +                 if (p aconv h) then (p,TCs)::rst else x::insrt rst
  2.2127 +            | insrt (x::rst) = x::insrt rst
  2.2128 +            | insrt[] = raise TFL_ERR "merge.insert" "pattern not found"
  2.2129 +      in insrt end
  2.2130 +    fun pass ([],ptcl_final) = ptcl_final
  2.2131 +      | pass (ptcs::tcl, ptcl) = pass(tcl, insert ptcs ptcl)
  2.2132 +in
  2.2133 +  pass (TCs, map (fn p => (p,[])) full_pats)
  2.2134 +end;
  2.2135 +
  2.2136 +
  2.2137 +fun givens pats = map pat_of (filter given pats);
  2.2138 +
  2.2139 +fun post_definition ctxt meta_tflCongs (def, pats) =
  2.2140 + let val thy = Proof_Context.theory_of ctxt
  2.2141 +     val tych = Thry.typecheck thy
  2.2142 +     val f = #lhs(USyntax.dest_eq(concl def))
  2.2143 +     val corollary = Rules.MATCH_MP Thms.WFREC_COROLLARY def
  2.2144 +     val pats' = filter given pats
  2.2145 +     val given_pats = map pat_of pats'
  2.2146 +     val rows = map row_of_pat pats'
  2.2147 +     val WFR = #ant(USyntax.dest_imp(concl corollary))
  2.2148 +     val R = #Rand(USyntax.dest_comb WFR)
  2.2149 +     val corollary' = Rules.UNDISCH corollary  (* put WF R on assums *)
  2.2150 +     val corollaries = map (fn pat => Rules.SPEC (tych pat) corollary') given_pats
  2.2151 +     val (case_rewrites,context_congs) = extraction_thms thy
  2.2152 +     (*case_ss causes minimal simplification: bodies of case expressions are
  2.2153 +       not simplified. Otherwise large examples (Red-Black trees) are too
  2.2154 +       slow.*)
  2.2155 +     val case_simpset =
  2.2156 +       put_simpset HOL_basic_ss ctxt
  2.2157 +          addsimps case_rewrites
  2.2158 +          |> fold (Simplifier.add_cong o #case_cong_weak o snd)
  2.2159 +              (Symtab.dest (BNF_LFP_Compat.get_all thy [BNF_LFP_Compat.Keep_Nesting]))
  2.2160 +     val corollaries' = map (Simplifier.simplify case_simpset) corollaries
  2.2161 +     val extract =
  2.2162 +      Rules.CONTEXT_REWRITE_RULE ctxt (f, [R], @{thm cut_apply}, meta_tflCongs @ context_congs)
  2.2163 +     val (rules, TCs) = ListPair.unzip (map extract corollaries')
  2.2164 +     val rules0 = map (rewrite_rule ctxt [Thms.CUT_DEF]) rules
  2.2165 +     val mk_cond_rule = Rules.FILTER_DISCH_ALL(not o curry (op aconv) WFR)
  2.2166 +     val rules1 = Rules.LIST_CONJ(map mk_cond_rule rules0)
  2.2167 + in
  2.2168 + {rules = rules1,
  2.2169 +  rows = rows,
  2.2170 +  full_pats_TCs = merge (map pat_of pats) (ListPair.zip (given_pats, TCs)),
  2.2171 +  TCs = TCs}
  2.2172 + end;
  2.2173 +
  2.2174 +
  2.2175 +(*---------------------------------------------------------------------------
  2.2176 + * Perform the extraction without making the definition. Definition and
  2.2177 + * extraction commute for the non-nested case.  (Deferred recdefs)
  2.2178 + *
  2.2179 + * The purpose of wfrec_eqns is merely to instantiate the recursion theorem
  2.2180 + * and extract termination conditions: no definition is made.
  2.2181 + *---------------------------------------------------------------------------*)
  2.2182 +
  2.2183 +fun wfrec_eqns thy fid tflCongs eqns =
  2.2184 + let val ctxt = Proof_Context.init_global thy
  2.2185 +     val {lhs,rhs} = USyntax.dest_eq (hd eqns)
  2.2186 +     val (f,args) = USyntax.strip_comb lhs
  2.2187 +     val (fname,fty) = dest_atom f
  2.2188 +     val (SV,a) = front_last args    (* SV = schematic variables *)
  2.2189 +     val g = list_comb(f,SV)
  2.2190 +     val h = Free(fname,type_of g)
  2.2191 +     val eqns1 = map (subst_free[(g,h)]) eqns
  2.2192 +     val {functional as Abs(x, Ty, _),  pats} = mk_functional thy eqns1
  2.2193 +     val given_pats = givens pats
  2.2194 +     (* val f = Free(x,Ty) *)
  2.2195 +     val Type("fun", [f_dty, f_rty]) = Ty
  2.2196 +     val dummy = if x<>fid then
  2.2197 +                        raise TFL_ERR "wfrec_eqns"
  2.2198 +                                      ("Expected a definition of " ^
  2.2199 +                                      quote fid ^ " but found one of " ^
  2.2200 +                                      quote x)
  2.2201 +                 else ()
  2.2202 +     val (case_rewrites,context_congs) = extraction_thms thy
  2.2203 +     val tych = Thry.typecheck thy
  2.2204 +     val WFREC_THM0 = Rules.ISPEC (tych functional) Thms.WFREC_COROLLARY
  2.2205 +     val Const(@{const_name All},_) $ Abs(Rname,Rtype,_) = concl WFREC_THM0
  2.2206 +     val R = Free (singleton (Name.variant_list (List.foldr Misc_Legacy.add_term_names [] eqns)) Rname,
  2.2207 +                   Rtype)
  2.2208 +     val WFREC_THM = Rules.ISPECL [tych R, tych g] WFREC_THM0
  2.2209 +     val ([proto_def, WFR],_) = USyntax.strip_imp(concl WFREC_THM)
  2.2210 +     val dummy =
  2.2211 +           if !trace then
  2.2212 +               writeln ("ORIGINAL PROTO_DEF: " ^
  2.2213 +                          Syntax.string_of_term_global thy proto_def)
  2.2214 +           else ()
  2.2215 +     val R1 = USyntax.rand WFR
  2.2216 +     val corollary' = Rules.UNDISCH (Rules.UNDISCH WFREC_THM)
  2.2217 +     val corollaries = map (fn pat => Rules.SPEC (tych pat) corollary') given_pats
  2.2218 +     val corollaries' = map (rewrite_rule ctxt case_rewrites) corollaries
  2.2219 +     val extract =
  2.2220 +      Rules.CONTEXT_REWRITE_RULE ctxt (f, R1::SV, @{thm cut_apply}, tflCongs @ context_congs)
  2.2221 + in {proto_def = proto_def,
  2.2222 +     SV=SV,
  2.2223 +     WFR=WFR,
  2.2224 +     pats=pats,
  2.2225 +     extracta = map extract corollaries'}
  2.2226 + end;
  2.2227 +
  2.2228 +
  2.2229 +(*---------------------------------------------------------------------------
  2.2230 + * Define the constant after extracting the termination conditions. The
  2.2231 + * wellfounded relation used in the definition is computed by using the
  2.2232 + * choice operator on the extracted conditions (plus the condition that
  2.2233 + * such a relation must be wellfounded).
  2.2234 + *---------------------------------------------------------------------------*)
  2.2235 +
  2.2236 +fun lazyR_def thy fid tflCongs eqns =
  2.2237 + let val {proto_def,WFR,pats,extracta,SV} =
  2.2238 +           wfrec_eqns thy fid tflCongs eqns
  2.2239 +     val R1 = USyntax.rand WFR
  2.2240 +     val f = #lhs(USyntax.dest_eq proto_def)
  2.2241 +     val (extractants,TCl) = ListPair.unzip extracta
  2.2242 +     val dummy = if !trace
  2.2243 +                 then writeln (cat_lines ("Extractants =" ::
  2.2244 +                  map (Display.string_of_thm_global thy) extractants))
  2.2245 +                 else ()
  2.2246 +     val TCs = fold_rev (union (op aconv)) TCl []
  2.2247 +     val full_rqt = WFR::TCs
  2.2248 +     val R' = USyntax.mk_select{Bvar=R1, Body=USyntax.list_mk_conj full_rqt}
  2.2249 +     val R'abs = USyntax.rand R'
  2.2250 +     val proto_def' = subst_free[(R1,R')] proto_def
  2.2251 +     val dummy = if !trace then writeln ("proto_def' = " ^
  2.2252 +                                         Syntax.string_of_term_global
  2.2253 +                                         thy proto_def')
  2.2254 +                           else ()
  2.2255 +     val {lhs,rhs} = USyntax.dest_eq proto_def'
  2.2256 +     val (c,args) = USyntax.strip_comb lhs
  2.2257 +     val (name,Ty) = dest_atom c
  2.2258 +     val defn = const_def thy (name, Ty, USyntax.list_mk_abs (args,rhs))
  2.2259 +     val ([def0], thy') =
  2.2260 +       thy
  2.2261 +       |> Global_Theory.add_defs false
  2.2262 +            [Thm.no_attributes (Binding.name (Thm.def_name fid), defn)]
  2.2263 +     val def = Thm.unvarify_global def0;
  2.2264 +     val ctxt' = Syntax.init_pretty_global thy';
  2.2265 +     val dummy =
  2.2266 +       if !trace then writeln ("DEF = " ^ Display.string_of_thm ctxt' def)
  2.2267 +       else ()
  2.2268 +     (* val fconst = #lhs(USyntax.dest_eq(concl def))  *)
  2.2269 +     val tych = Thry.typecheck thy'
  2.2270 +     val full_rqt_prop = map (Dcterm.mk_prop o tych) full_rqt
  2.2271 +         (*lcp: a lot of object-logic inference to remove*)
  2.2272 +     val baz = Rules.DISCH_ALL
  2.2273 +                 (fold_rev Rules.DISCH full_rqt_prop
  2.2274 +                  (Rules.LIST_CONJ extractants))
  2.2275 +     val dum = if !trace then writeln ("baz = " ^ Display.string_of_thm ctxt' baz) else ()
  2.2276 +     val f_free = Free (fid, fastype_of f)  (*'cos f is a Const*)
  2.2277 +     val SV' = map tych SV;
  2.2278 +     val SVrefls = map Thm.reflexive SV'
  2.2279 +     val def0 = (fold (fn x => fn th => Rules.rbeta(Thm.combination th x))
  2.2280 +                   SVrefls def)
  2.2281 +                RS meta_eq_to_obj_eq
  2.2282 +     val def' = Rules.MP (Rules.SPEC (tych R') (Rules.GEN ctxt' (tych R1) baz)) def0
  2.2283 +     val body_th = Rules.LIST_CONJ (map Rules.ASSUME full_rqt_prop)
  2.2284 +     val SELECT_AX = (*in this way we hope to avoid a STATIC dependence upon
  2.2285 +                       theory Hilbert_Choice*)
  2.2286 +         ML_Context.thm "Hilbert_Choice.tfl_some"
  2.2287 +         handle ERROR msg => cat_error msg
  2.2288 +    "defer_recdef requires theory Main or at least Hilbert_Choice as parent"
  2.2289 +     val bar = Rules.MP (Rules.ISPECL[tych R'abs, tych R1] SELECT_AX) body_th
  2.2290 + in {theory = thy', R=R1, SV=SV,
  2.2291 +     rules = fold (fn a => fn b => Rules.MP b a) (Rules.CONJUNCTS bar) def',
  2.2292 +     full_pats_TCs = merge (map pat_of pats) (ListPair.zip (givens pats, TCl)),
  2.2293 +     patterns = pats}
  2.2294 + end;
  2.2295 +
  2.2296 +
  2.2297 +
  2.2298 +(*----------------------------------------------------------------------------
  2.2299 + *
  2.2300 + *                           INDUCTION THEOREM
  2.2301 + *
  2.2302 + *---------------------------------------------------------------------------*)
  2.2303 +
  2.2304 +
  2.2305 +(*------------------------  Miscellaneous function  --------------------------
  2.2306 + *
  2.2307 + *           [x_1,...,x_n]     ?v_1...v_n. M[v_1,...,v_n]
  2.2308 + *     -----------------------------------------------------------
  2.2309 + *     ( M[x_1,...,x_n], [(x_i,?v_1...v_n. M[v_1,...,v_n]),
  2.2310 + *                        ...
  2.2311 + *                        (x_j,?v_n. M[x_1,...,x_(n-1),v_n])] )
  2.2312 + *
  2.2313 + * This function is totally ad hoc. Used in the production of the induction
  2.2314 + * theorem. The nchotomy theorem can have clauses that look like
  2.2315 + *
  2.2316 + *     ?v1..vn. z = C vn..v1
  2.2317 + *
  2.2318 + * in which the order of quantification is not the order of occurrence of the
  2.2319 + * quantified variables as arguments to C. Since we have no control over this
  2.2320 + * aspect of the nchotomy theorem, we make the correspondence explicit by
  2.2321 + * pairing the incoming new variable with the term it gets beta-reduced into.
  2.2322 + *---------------------------------------------------------------------------*)
  2.2323 +
  2.2324 +fun alpha_ex_unroll (xlist, tm) =
  2.2325 +  let val (qvars,body) = USyntax.strip_exists tm
  2.2326 +      val vlist = #2 (USyntax.strip_comb (USyntax.rhs body))
  2.2327 +      val plist = ListPair.zip (vlist, xlist)
  2.2328 +      val args = map (the o AList.lookup (op aconv) plist) qvars
  2.2329 +                   handle Option.Option => raise Fail "TFL.alpha_ex_unroll: no correspondence"
  2.2330 +      fun build ex      []   = []
  2.2331 +        | build (_$rex) (v::rst) =
  2.2332 +           let val ex1 = Term.betapply(rex, v)
  2.2333 +           in  ex1 :: build ex1 rst
  2.2334 +           end
  2.2335 +     val (nex::exl) = rev (tm::build tm args)
  2.2336 +  in
  2.2337 +  (nex, ListPair.zip (args, rev exl))
  2.2338 +  end;
  2.2339 +
  2.2340 +
  2.2341 +
  2.2342 +(*----------------------------------------------------------------------------
  2.2343 + *
  2.2344 + *             PROVING COMPLETENESS OF PATTERNS
  2.2345 + *
  2.2346 + *---------------------------------------------------------------------------*)
  2.2347 +
  2.2348 +fun mk_case ty_info usednames thy =
  2.2349 + let
  2.2350 + val ctxt = Proof_Context.init_global thy
  2.2351 + val divide = ipartition (gvvariant usednames)
  2.2352 + val tych = Thry.typecheck thy
  2.2353 + fun tych_binding(x,y) = (tych x, tych y)
  2.2354 + fun fail s = raise TFL_ERR "mk_case" s
  2.2355 + fun mk{rows=[],...} = fail"no rows"
  2.2356 +   | mk{path=[], rows = [([], (thm, bindings))]} =
  2.2357 +                         Rules.IT_EXISTS ctxt (map tych_binding bindings) thm
  2.2358 +   | mk{path = u::rstp, rows as (p::_, _)::_} =
  2.2359 +     let val (pat_rectangle,rights) = ListPair.unzip rows
  2.2360 +         val col0 = map hd pat_rectangle
  2.2361 +         val pat_rectangle' = map tl pat_rectangle
  2.2362 +     in
  2.2363 +     if (forall is_Free col0) (* column 0 is all variables *)
  2.2364 +     then let val rights' = map (fn ((thm,theta),v) => (thm,theta@[(u,v)]))
  2.2365 +                                (ListPair.zip (rights, col0))
  2.2366 +          in mk{path = rstp, rows = ListPair.zip (pat_rectangle', rights')}
  2.2367 +          end
  2.2368 +     else                     (* column 0 is all constructors *)
  2.2369 +     let val Type (ty_name,_) = type_of p
  2.2370 +     in
  2.2371 +     case (ty_info ty_name)
  2.2372 +     of NONE => fail("Not a known datatype: "^ty_name)
  2.2373 +      | SOME{constructors,nchotomy} =>
  2.2374 +        let val thm' = Rules.ISPEC (tych u) nchotomy
  2.2375 +            val disjuncts = USyntax.strip_disj (concl thm')
  2.2376 +            val subproblems = divide(constructors, rows)
  2.2377 +            val groups      = map #group subproblems
  2.2378 +            and new_formals = map #new_formals subproblems
  2.2379 +            val existentials = ListPair.map alpha_ex_unroll
  2.2380 +                                   (new_formals, disjuncts)
  2.2381 +            val constraints = map #1 existentials
  2.2382 +            val vexl = map #2 existentials
  2.2383 +            fun expnd tm (pats,(th,b)) = (pats, (Rules.SUBS ctxt [Rules.ASSUME (tych tm)] th, b))
  2.2384 +            val news = map (fn (nf,rows,c) => {path = nf@rstp,
  2.2385 +                                               rows = map (expnd c) rows})
  2.2386 +                           (Utils.zip3 new_formals groups constraints)
  2.2387 +            val recursive_thms = map mk news
  2.2388 +            val build_exists = Library.foldr
  2.2389 +                                (fn((x,t), th) =>
  2.2390 +                                 Rules.CHOOSE ctxt (tych x, Rules.ASSUME (tych t)) th)
  2.2391 +            val thms' = ListPair.map build_exists (vexl, recursive_thms)
  2.2392 +            val same_concls = Rules.EVEN_ORS thms'
  2.2393 +        in Rules.DISJ_CASESL thm' same_concls
  2.2394 +        end
  2.2395 +     end end
  2.2396 + in mk
  2.2397 + end;
  2.2398 +
  2.2399 +
  2.2400 +fun complete_cases thy =
  2.2401 + let val ctxt = Proof_Context.init_global thy
  2.2402 +     val tych = Thry.typecheck thy
  2.2403 +     val ty_info = Thry.induct_info thy
  2.2404 + in fn pats =>
  2.2405 + let val names = List.foldr Misc_Legacy.add_term_names [] pats
  2.2406 +     val T = type_of (hd pats)
  2.2407 +     val aname = singleton (Name.variant_list names) "a"
  2.2408 +     val vname = singleton (Name.variant_list (aname::names)) "v"
  2.2409 +     val a = Free (aname, T)
  2.2410 +     val v = Free (vname, T)
  2.2411 +     val a_eq_v = HOLogic.mk_eq(a,v)
  2.2412 +     val ex_th0 = Rules.EXISTS (tych (USyntax.mk_exists{Bvar=v,Body=a_eq_v}), tych a)
  2.2413 +                           (Rules.REFL (tych a))
  2.2414 +     val th0 = Rules.ASSUME (tych a_eq_v)
  2.2415 +     val rows = map (fn x => ([x], (th0,[]))) pats
  2.2416 + in
  2.2417 + Rules.GEN ctxt (tych a)
  2.2418 +       (Rules.RIGHT_ASSOC ctxt
  2.2419 +          (Rules.CHOOSE ctxt (tych v, ex_th0)
  2.2420 +                (mk_case ty_info (vname::aname::names)
  2.2421 +                 thy {path=[v], rows=rows})))
  2.2422 + end end;
  2.2423 +
  2.2424 +
  2.2425 +(*---------------------------------------------------------------------------
  2.2426 + * Constructing induction hypotheses: one for each recursive call.
  2.2427 + *
  2.2428 + * Note. R will never occur as a variable in the ind_clause, because
  2.2429 + * to do so, it would have to be from a nested definition, and we don't
  2.2430 + * allow nested defns to have R variable.
  2.2431 + *
  2.2432 + * Note. When the context is empty, there can be no local variables.
  2.2433 + *---------------------------------------------------------------------------*)
  2.2434 +(*
  2.2435 +local infix 5 ==>
  2.2436 +      fun (tm1 ==> tm2) = USyntax.mk_imp{ant = tm1, conseq = tm2}
  2.2437 +in
  2.2438 +fun build_ih f P (pat,TCs) =
  2.2439 + let val globals = USyntax.free_vars_lr pat
  2.2440 +     fun nested tm = is_some (USyntax.find_term (curry (op aconv) f) tm)
  2.2441 +     fun dest_TC tm =
  2.2442 +         let val (cntxt,R_y_pat) = USyntax.strip_imp(#2(USyntax.strip_forall tm))
  2.2443 +             val (R,y,_) = USyntax.dest_relation R_y_pat
  2.2444 +             val P_y = if (nested tm) then R_y_pat ==> P$y else P$y
  2.2445 +         in case cntxt
  2.2446 +              of [] => (P_y, (tm,[]))
  2.2447 +               | _  => let
  2.2448 +                    val imp = USyntax.list_mk_conj cntxt ==> P_y
  2.2449 +                    val lvs = gen_rems (op aconv) (USyntax.free_vars_lr imp, globals)
  2.2450 +                    val locals = #2(Utils.pluck (curry (op aconv) P) lvs) handle Utils.ERR _ => lvs
  2.2451 +                    in (USyntax.list_mk_forall(locals,imp), (tm,locals)) end
  2.2452 +         end
  2.2453 + in case TCs
  2.2454 +    of [] => (USyntax.list_mk_forall(globals, P$pat), [])
  2.2455 +     |  _ => let val (ihs, TCs_locals) = ListPair.unzip(map dest_TC TCs)
  2.2456 +                 val ind_clause = USyntax.list_mk_conj ihs ==> P$pat
  2.2457 +             in (USyntax.list_mk_forall(globals,ind_clause), TCs_locals)
  2.2458 +             end
  2.2459 + end
  2.2460 +end;
  2.2461 +*)
  2.2462 +
  2.2463 +local infix 5 ==>
  2.2464 +      fun (tm1 ==> tm2) = USyntax.mk_imp{ant = tm1, conseq = tm2}
  2.2465 +in
  2.2466 +fun build_ih f (P,SV) (pat,TCs) =
  2.2467 + let val pat_vars = USyntax.free_vars_lr pat
  2.2468 +     val globals = pat_vars@SV
  2.2469 +     fun nested tm = is_some (USyntax.find_term (curry (op aconv) f) tm)
  2.2470 +     fun dest_TC tm =
  2.2471 +         let val (cntxt,R_y_pat) = USyntax.strip_imp(#2(USyntax.strip_forall tm))
  2.2472 +             val (R,y,_) = USyntax.dest_relation R_y_pat
  2.2473 +             val P_y = if (nested tm) then R_y_pat ==> P$y else P$y
  2.2474 +         in case cntxt
  2.2475 +              of [] => (P_y, (tm,[]))
  2.2476 +               | _  => let
  2.2477 +                    val imp = USyntax.list_mk_conj cntxt ==> P_y
  2.2478 +                    val lvs = subtract (op aconv) globals (USyntax.free_vars_lr imp)
  2.2479 +                    val locals = #2(Utils.pluck (curry (op aconv) P) lvs) handle Utils.ERR _ => lvs
  2.2480 +                    in (USyntax.list_mk_forall(locals,imp), (tm,locals)) end
  2.2481 +         end
  2.2482 + in case TCs
  2.2483 +    of [] => (USyntax.list_mk_forall(pat_vars, P$pat), [])
  2.2484 +     |  _ => let val (ihs, TCs_locals) = ListPair.unzip(map dest_TC TCs)
  2.2485 +                 val ind_clause = USyntax.list_mk_conj ihs ==> P$pat
  2.2486 +             in (USyntax.list_mk_forall(pat_vars,ind_clause), TCs_locals)
  2.2487 +             end
  2.2488 + end
  2.2489 +end;
  2.2490 +
  2.2491 +(*---------------------------------------------------------------------------
  2.2492 + * This function makes good on the promise made in "build_ih".
  2.2493 + *
  2.2494 + * Input  is tm = "(!y. R y pat ==> P y) ==> P pat",
  2.2495 + *           TCs = TC_1[pat] ... TC_n[pat]
  2.2496 + *           thm = ih1 /\ ... /\ ih_n |- ih[pat]
  2.2497 + *---------------------------------------------------------------------------*)
  2.2498 +fun prove_case ctxt f (tm,TCs_locals,thm) =
  2.2499 + let val tych = Thry.typecheck (Proof_Context.theory_of ctxt)
  2.2500 +     val antc = tych(#ant(USyntax.dest_imp tm))
  2.2501 +     val thm' = Rules.SPEC_ALL thm
  2.2502 +     fun nested tm = is_some (USyntax.find_term (curry (op aconv) f) tm)
  2.2503 +     fun get_cntxt TC = tych(#ant(USyntax.dest_imp(#2(USyntax.strip_forall(concl TC)))))
  2.2504 +     fun mk_ih ((TC,locals),th2,nested) =
  2.2505 +         Rules.GENL ctxt (map tych locals)
  2.2506 +            (if nested then Rules.DISCH (get_cntxt TC) th2 handle Utils.ERR _ => th2
  2.2507 +             else if USyntax.is_imp (concl TC) then Rules.IMP_TRANS TC th2
  2.2508 +             else Rules.MP th2 TC)
  2.2509 + in
  2.2510 + Rules.DISCH antc
  2.2511 + (if USyntax.is_imp(concl thm') (* recursive calls in this clause *)
  2.2512 +  then let val th1 = Rules.ASSUME antc
  2.2513 +           val TCs = map #1 TCs_locals
  2.2514 +           val ylist = map (#2 o USyntax.dest_relation o #2 o USyntax.strip_imp o
  2.2515 +                            #2 o USyntax.strip_forall) TCs
  2.2516 +           val TClist = map (fn(TC,lvs) => (Rules.SPEC_ALL(Rules.ASSUME(tych TC)),lvs))
  2.2517 +                            TCs_locals
  2.2518 +           val th2list = map (fn t => Rules.SPEC (tych t) th1) ylist
  2.2519 +           val nlist = map nested TCs
  2.2520 +           val triples = Utils.zip3 TClist th2list nlist
  2.2521 +           val Pylist = map mk_ih triples
  2.2522 +       in Rules.MP thm' (Rules.LIST_CONJ Pylist) end
  2.2523 +  else thm')
  2.2524 + end;
  2.2525 +
  2.2526 +
  2.2527 +(*---------------------------------------------------------------------------
  2.2528 + *
  2.2529 + *         x = (v1,...,vn)  |- M[x]
  2.2530 + *    ---------------------------------------------
  2.2531 + *      ?v1 ... vn. x = (v1,...,vn) |- M[x]
  2.2532 + *
  2.2533 + *---------------------------------------------------------------------------*)
  2.2534 +fun LEFT_ABS_VSTRUCT ctxt tych thm =
  2.2535 +  let fun CHOOSER v (tm,thm) =
  2.2536 +        let val ex_tm = USyntax.mk_exists{Bvar=v,Body=tm}
  2.2537 +        in (ex_tm, Rules.CHOOSE ctxt (tych v, Rules.ASSUME (tych ex_tm)) thm)
  2.2538 +        end
  2.2539 +      val [veq] = filter (can USyntax.dest_eq) (#1 (Rules.dest_thm thm))
  2.2540 +      val {lhs,rhs} = USyntax.dest_eq veq
  2.2541 +      val L = USyntax.free_vars_lr rhs
  2.2542 +  in  #2 (fold_rev CHOOSER L (veq,thm))  end;
  2.2543 +
  2.2544 +
  2.2545 +(*----------------------------------------------------------------------------
  2.2546 + * Input : f, R,  and  [(pat1,TCs1),..., (patn,TCsn)]
  2.2547 + *
  2.2548 + * Instantiates WF_INDUCTION_THM, getting Sinduct and then tries to prove
  2.2549 + * recursion induction (Rinduct) by proving the antecedent of Sinduct from
  2.2550 + * the antecedent of Rinduct.
  2.2551 + *---------------------------------------------------------------------------*)
  2.2552 +fun mk_induction thy {fconst, R, SV, pat_TCs_list} =
  2.2553 +let val ctxt = Proof_Context.init_global thy
  2.2554 +    val tych = Thry.typecheck thy
  2.2555 +    val Sinduction = Rules.UNDISCH (Rules.ISPEC (tych R) Thms.WF_INDUCTION_THM)
  2.2556 +    val (pats,TCsl) = ListPair.unzip pat_TCs_list
  2.2557 +    val case_thm = complete_cases thy pats
  2.2558 +    val domain = (type_of o hd) pats
  2.2559 +    val Pname = singleton (Name.variant_list (List.foldr (Library.foldr Misc_Legacy.add_term_names)
  2.2560 +                              [] (pats::TCsl))) "P"
  2.2561 +    val P = Free(Pname, domain --> HOLogic.boolT)
  2.2562 +    val Sinduct = Rules.SPEC (tych P) Sinduction
  2.2563 +    val Sinduct_assumf = USyntax.rand ((#ant o USyntax.dest_imp o concl) Sinduct)
  2.2564 +    val Rassums_TCl' = map (build_ih fconst (P,SV)) pat_TCs_list
  2.2565 +    val (Rassums,TCl') = ListPair.unzip Rassums_TCl'
  2.2566 +    val Rinduct_assum = Rules.ASSUME (tych (USyntax.list_mk_conj Rassums))
  2.2567 +    val cases = map (fn pat => Term.betapply (Sinduct_assumf, pat)) pats
  2.2568 +    val tasks = Utils.zip3 cases TCl' (Rules.CONJUNCTS Rinduct_assum)
  2.2569 +    val proved_cases = map (prove_case ctxt fconst) tasks
  2.2570 +    val v =
  2.2571 +      Free (singleton
  2.2572 +        (Name.variant_list (List.foldr Misc_Legacy.add_term_names [] (map concl proved_cases))) "v",
  2.2573 +          domain)
  2.2574 +    val vtyped = tych v
  2.2575 +    val substs = map (Rules.SYM o Rules.ASSUME o tych o (curry HOLogic.mk_eq v)) pats
  2.2576 +    val proved_cases1 = ListPair.map (fn (th,th') => Rules.SUBS ctxt [th]th')
  2.2577 +                          (substs, proved_cases)
  2.2578 +    val abs_cases = map (LEFT_ABS_VSTRUCT ctxt tych) proved_cases1
  2.2579 +    val dant = Rules.GEN ctxt vtyped (Rules.DISJ_CASESL (Rules.ISPEC vtyped case_thm) abs_cases)
  2.2580 +    val dc = Rules.MP Sinduct dant
  2.2581 +    val Parg_ty = type_of(#Bvar(USyntax.dest_forall(concl dc)))
  2.2582 +    val vars = map (gvvariant[Pname]) (USyntax.strip_prod_type Parg_ty)
  2.2583 +    val dc' = fold_rev (Rules.GEN ctxt o tych) vars
  2.2584 +                       (Rules.SPEC (tych(USyntax.mk_vstruct Parg_ty vars)) dc)
  2.2585 +in
  2.2586 +   Rules.GEN ctxt (tych P) (Rules.DISCH (tych(concl Rinduct_assum)) dc')
  2.2587 +end
  2.2588 +handle Utils.ERR _ => raise TFL_ERR "mk_induction" "failed derivation";
  2.2589 +
  2.2590 +
  2.2591 +
  2.2592 +
  2.2593 +(*---------------------------------------------------------------------------
  2.2594 + *
  2.2595 + *                        POST PROCESSING
  2.2596 + *
  2.2597 + *---------------------------------------------------------------------------*)
  2.2598 +
  2.2599 +
  2.2600 +fun simplify_induction thy hth ind =
  2.2601 +  let val tych = Thry.typecheck thy
  2.2602 +      val (asl,_) = Rules.dest_thm ind
  2.2603 +      val (_,tc_eq_tc') = Rules.dest_thm hth
  2.2604 +      val tc = USyntax.lhs tc_eq_tc'
  2.2605 +      fun loop [] = ind
  2.2606 +        | loop (asm::rst) =
  2.2607 +          if (can (Thry.match_term thy asm) tc)
  2.2608 +          then Rules.UNDISCH
  2.2609 +                 (Rules.MATCH_MP
  2.2610 +                     (Rules.MATCH_MP Thms.simp_thm (Rules.DISCH (tych asm) ind))
  2.2611 +                     hth)
  2.2612 +         else loop rst
  2.2613 +  in loop asl
  2.2614 +end;
  2.2615 +
  2.2616 +
  2.2617 +(*---------------------------------------------------------------------------
  2.2618 + * The termination condition is an antecedent to the rule, and an
  2.2619 + * assumption to the theorem.
  2.2620 + *---------------------------------------------------------------------------*)
  2.2621 +fun elim_tc tcthm (rule,induction) =
  2.2622 +   (Rules.MP rule tcthm, Rules.PROVE_HYP tcthm induction)
  2.2623 +
  2.2624 +
  2.2625 +fun trace_thms ctxt s L =
  2.2626 +  if !trace then writeln (cat_lines (s :: map (Display.string_of_thm ctxt) L))
  2.2627 +  else ();
  2.2628 +
  2.2629 +fun trace_cterm ctxt s ct =
  2.2630 +  if !trace then
  2.2631 +    writeln (cat_lines [s, Syntax.string_of_term ctxt (Thm.term_of ct)])
  2.2632 +  else ();
  2.2633 +
  2.2634 +
  2.2635 +fun postprocess ctxt strict {wf_tac, terminator, simplifier} {rules,induction,TCs} =
  2.2636 +  let
  2.2637 +    val thy = Proof_Context.theory_of ctxt;
  2.2638 +    val tych = Thry.typecheck thy;
  2.2639 +
  2.2640 +   (*---------------------------------------------------------------------
  2.2641 +    * Attempt to eliminate WF condition. It's the only assumption of rules
  2.2642 +    *---------------------------------------------------------------------*)
  2.2643 +    val (rules1,induction1)  =
  2.2644 +       let val thm =
  2.2645 +        Rules.prove ctxt strict (HOLogic.mk_Trueprop (hd(#1(Rules.dest_thm rules))), wf_tac)
  2.2646 +       in (Rules.PROVE_HYP thm rules, Rules.PROVE_HYP thm induction)
  2.2647 +       end handle Utils.ERR _ => (rules,induction);
  2.2648 +
  2.2649 +   (*----------------------------------------------------------------------
  2.2650 +    * The termination condition (tc) is simplified to |- tc = tc' (there
  2.2651 +    * might not be a change!) and then 3 attempts are made:
  2.2652 +    *
  2.2653 +    *   1. if |- tc = T, then eliminate it with eqT; otherwise,
  2.2654 +    *   2. apply the terminator to tc'. If |- tc' = T then eliminate; else
  2.2655 +    *   3. replace tc by tc' in both the rules and the induction theorem.
  2.2656 +    *---------------------------------------------------------------------*)
  2.2657 +
  2.2658 +   fun simplify_tc tc (r,ind) =
  2.2659 +       let val tc1 = tych tc
  2.2660 +           val _ = trace_cterm ctxt "TC before simplification: " tc1
  2.2661 +           val tc_eq = simplifier tc1
  2.2662 +           val _ = trace_thms ctxt "result: " [tc_eq]
  2.2663 +       in
  2.2664 +       elim_tc (Rules.MATCH_MP Thms.eqT tc_eq) (r,ind)
  2.2665 +       handle Utils.ERR _ =>
  2.2666 +        (elim_tc (Rules.MATCH_MP(Rules.MATCH_MP Thms.rev_eq_mp tc_eq)
  2.2667 +                  (Rules.prove ctxt strict (HOLogic.mk_Trueprop(USyntax.rhs(concl tc_eq)),
  2.2668 +                           terminator)))
  2.2669 +                 (r,ind)
  2.2670 +         handle Utils.ERR _ =>
  2.2671 +          (Rules.UNDISCH(Rules.MATCH_MP (Rules.MATCH_MP Thms.simp_thm r) tc_eq),
  2.2672 +           simplify_induction thy tc_eq ind))
  2.2673 +       end
  2.2674 +
  2.2675 +   (*----------------------------------------------------------------------
  2.2676 +    * Nested termination conditions are harder to get at, since they are
  2.2677 +    * left embedded in the body of the function (and in induction
  2.2678 +    * theorem hypotheses). Our "solution" is to simplify them, and try to
  2.2679 +    * prove termination, but leave the application of the resulting theorem
  2.2680 +    * to a higher level. So things go much as in "simplify_tc": the
  2.2681 +    * termination condition (tc) is simplified to |- tc = tc' (there might
  2.2682 +    * not be a change) and then 2 attempts are made:
  2.2683 +    *
  2.2684 +    *   1. if |- tc = T, then return |- tc; otherwise,
  2.2685 +    *   2. apply the terminator to tc'. If |- tc' = T then return |- tc; else
  2.2686 +    *   3. return |- tc = tc'
  2.2687 +    *---------------------------------------------------------------------*)
  2.2688 +   fun simplify_nested_tc tc =
  2.2689 +      let val tc_eq = simplifier (tych (#2 (USyntax.strip_forall tc)))
  2.2690 +      in
  2.2691 +      Rules.GEN_ALL ctxt
  2.2692 +       (Rules.MATCH_MP Thms.eqT tc_eq
  2.2693 +        handle Utils.ERR _ =>
  2.2694 +          (Rules.MATCH_MP(Rules.MATCH_MP Thms.rev_eq_mp tc_eq)
  2.2695 +                      (Rules.prove ctxt strict (HOLogic.mk_Trueprop (USyntax.rhs(concl tc_eq)),
  2.2696 +                               terminator))
  2.2697 +            handle Utils.ERR _ => tc_eq))
  2.2698 +      end
  2.2699 +
  2.2700 +   (*-------------------------------------------------------------------
  2.2701 +    * Attempt to simplify the termination conditions in each rule and
  2.2702 +    * in the induction theorem.
  2.2703 +    *-------------------------------------------------------------------*)
  2.2704 +   fun strip_imp tm = if USyntax.is_neg tm then ([],tm) else USyntax.strip_imp tm
  2.2705 +   fun loop ([],extras,R,ind) = (rev R, ind, extras)
  2.2706 +     | loop ((r,ftcs)::rst, nthms, R, ind) =
  2.2707 +        let val tcs = #1(strip_imp (concl r))
  2.2708 +            val extra_tcs = subtract (op aconv) tcs ftcs
  2.2709 +            val extra_tc_thms = map simplify_nested_tc extra_tcs
  2.2710 +            val (r1,ind1) = fold simplify_tc tcs (r,ind)
  2.2711 +            val r2 = Rules.FILTER_DISCH_ALL(not o USyntax.is_WFR) r1
  2.2712 +        in loop(rst, nthms@extra_tc_thms, r2::R, ind1)
  2.2713 +        end
  2.2714 +   val rules_tcs = ListPair.zip (Rules.CONJUNCTS rules1, TCs)
  2.2715 +   val (rules2,ind2,extras) = loop(rules_tcs,[],[],induction1)
  2.2716 +in
  2.2717 +  {induction = ind2, rules = Rules.LIST_CONJ rules2, nested_tcs = extras}
  2.2718 +end;
  2.2719 +
  2.2720 +end;
  2.2721 +
  2.2722 +
  2.2723 +(*** second part of main module (postprocessing of TFL definitions) ***)
  2.2724 +
  2.2725 +structure Tfl: TFL =
  2.2726 +struct
  2.2727 +
  2.2728 +(* misc *)
  2.2729 +
  2.2730 +(*---------------------------------------------------------------------------
  2.2731 + * Extract termination goals so that they can be put it into a goalstack, or
  2.2732 + * have a tactic directly applied to them.
  2.2733 + *--------------------------------------------------------------------------*)
  2.2734 +fun termination_goals rules =
  2.2735 +    map (Type.legacy_freeze o HOLogic.dest_Trueprop)
  2.2736 +      (fold_rev (union (op aconv) o Thm.prems_of) rules []);
  2.2737 +
  2.2738 +(*---------------------------------------------------------------------------
  2.2739 + * Three postprocessors are applied to the definition.  It
  2.2740 + * attempts to prove wellfoundedness of the given relation, simplifies the
  2.2741 + * non-proved termination conditions, and finally attempts to prove the
  2.2742 + * simplified termination conditions.
  2.2743 + *--------------------------------------------------------------------------*)
  2.2744 +fun std_postprocessor ctxt strict wfs =
  2.2745 +  Prim.postprocess ctxt strict
  2.2746 +   {wf_tac = REPEAT (ares_tac wfs 1),
  2.2747 +    terminator =
  2.2748 +      asm_simp_tac ctxt 1
  2.2749 +      THEN TRY (Arith_Data.arith_tac ctxt 1 ORELSE
  2.2750 +        fast_force_tac (ctxt addSDs @{thms not0_implies_Suc}) 1),
  2.2751 +    simplifier = Rules.simpl_conv ctxt []};
  2.2752 +
  2.2753 +
  2.2754 +
  2.2755 +val concl = #2 o Rules.dest_thm;
  2.2756 +
  2.2757 +(*---------------------------------------------------------------------------
  2.2758 + * Postprocess a definition made by "define". This is a separate stage of
  2.2759 + * processing from the definition stage.
  2.2760 + *---------------------------------------------------------------------------*)
  2.2761 +local
  2.2762 +
  2.2763 +(* The rest of these local definitions are for the tricky nested case *)
  2.2764 +val solved = not o can USyntax.dest_eq o #2 o USyntax.strip_forall o concl
  2.2765 +
  2.2766 +fun id_thm th =
  2.2767 +   let val {lhs,rhs} = USyntax.dest_eq (#2 (USyntax.strip_forall (#2 (Rules.dest_thm th))));
  2.2768 +   in lhs aconv rhs end
  2.2769 +   handle Utils.ERR _ => false;
  2.2770 +
  2.2771 +val P_imp_P_eq_True = @{thm eqTrueI} RS eq_reflection;
  2.2772 +fun mk_meta_eq r =
  2.2773 +  (case Thm.concl_of r of
  2.2774 +     Const(@{const_name Pure.eq},_)$_$_ => r
  2.2775 +  |   _ $(Const(@{const_name HOL.eq},_)$_$_) => r RS eq_reflection
  2.2776 +  |   _ => r RS P_imp_P_eq_True)
  2.2777 +
  2.2778 +(*Is this the best way to invoke the simplifier??*)
  2.2779 +fun rewrite ctxt L = rewrite_rule ctxt (map mk_meta_eq (filter_out id_thm L))
  2.2780 +
  2.2781 +fun join_assums ctxt th =
  2.2782 +  let val tych = Thm.cterm_of ctxt
  2.2783 +      val {lhs,rhs} = USyntax.dest_eq(#2 (USyntax.strip_forall (concl th)))
  2.2784 +      val cntxtl = (#1 o USyntax.strip_imp) lhs  (* cntxtl should = cntxtr *)
  2.2785 +      val cntxtr = (#1 o USyntax.strip_imp) rhs  (* but union is solider *)
  2.2786 +      val cntxt = union (op aconv) cntxtl cntxtr
  2.2787 +  in
  2.2788 +    Rules.GEN_ALL ctxt
  2.2789 +      (Rules.DISCH_ALL
  2.2790 +         (rewrite ctxt (map (Rules.ASSUME o tych) cntxt) (Rules.SPEC_ALL th)))
  2.2791 +  end
  2.2792 +  val gen_all = USyntax.gen_all
  2.2793 +in
  2.2794 +fun proof_stage ctxt strict wfs {f, R, rules, full_pats_TCs, TCs} =
  2.2795 +  let
  2.2796 +    val _ = writeln "Proving induction theorem ..."
  2.2797 +    val ind =
  2.2798 +      Prim.mk_induction (Proof_Context.theory_of ctxt)
  2.2799 +        {fconst=f, R=R, SV=[], pat_TCs_list=full_pats_TCs}
  2.2800 +    val _ = writeln "Postprocessing ...";
  2.2801 +    val {rules, induction, nested_tcs} =
  2.2802 +      std_postprocessor ctxt strict wfs {rules=rules, induction=ind, TCs=TCs}
  2.2803 +  in
  2.2804 +  case nested_tcs
  2.2805 +  of [] => {induction=induction, rules=rules,tcs=[]}
  2.2806 +  | L  => let val dummy = writeln "Simplifying nested TCs ..."
  2.2807 +              val (solved,simplified,stubborn) =
  2.2808 +               fold_rev (fn th => fn (So,Si,St) =>
  2.2809 +                     if (id_thm th) then (So, Si, th::St) else
  2.2810 +                     if (solved th) then (th::So, Si, St)
  2.2811 +                     else (So, th::Si, St)) nested_tcs ([],[],[])
  2.2812 +              val simplified' = map (join_assums ctxt) simplified
  2.2813 +              val dummy = (Prim.trace_thms ctxt "solved =" solved;
  2.2814 +                           Prim.trace_thms ctxt "simplified' =" simplified')
  2.2815 +              val rewr = full_simplify (ctxt addsimps (solved @ simplified'));
  2.2816 +              val dummy = Prim.trace_thms ctxt "Simplifying the induction rule..." [induction]
  2.2817 +              val induction' = rewr induction
  2.2818 +              val dummy = Prim.trace_thms ctxt "Simplifying the recursion rules..." [rules]
  2.2819 +              val rules'     = rewr rules
  2.2820 +              val _ = writeln "... Postprocessing finished";
  2.2821 +          in
  2.2822 +          {induction = induction',
  2.2823 +               rules = rules',
  2.2824 +                 tcs = map (gen_all o USyntax.rhs o #2 o USyntax.strip_forall o concl)
  2.2825 +                           (simplified@stubborn)}
  2.2826 +          end
  2.2827 +  end;
  2.2828 +
  2.2829 +
  2.2830 +(*lcp: curry the predicate of the induction rule*)
  2.2831 +fun curry_rule ctxt rl =
  2.2832 +  Split_Rule.split_rule_var ctxt (Term.head_of (HOLogic.dest_Trueprop (Thm.concl_of rl))) rl;
  2.2833 +
  2.2834 +(*lcp: put a theorem into Isabelle form, using meta-level connectives*)
  2.2835 +fun meta_outer ctxt =
  2.2836 +  curry_rule ctxt o Drule.export_without_context o
  2.2837 +  rule_by_tactic ctxt (REPEAT (FIRSTGOAL (resolve_tac ctxt [allI, impI, conjI] ORELSE' etac conjE)));
  2.2838 +
  2.2839 +(*Strip off the outer !P*)
  2.2840 +val spec'=
  2.2841 +  Rule_Insts.read_instantiate @{context} [((("x", 0), Position.none), "P::'b=>bool")] [] spec;
  2.2842 +
  2.2843 +fun tracing true _ = ()
  2.2844 +  | tracing false msg = writeln msg;
  2.2845 +
  2.2846 +fun simplify_defn ctxt strict congs wfs id pats def0 =
  2.2847 +  let
  2.2848 +    val def = Thm.unvarify_global def0 RS meta_eq_to_obj_eq
  2.2849 +    val {rules, rows, TCs, full_pats_TCs} = Prim.post_definition ctxt congs (def, pats)
  2.2850 +    val {lhs=f,rhs} = USyntax.dest_eq (concl def)
  2.2851 +    val (_,[R,_]) = USyntax.strip_comb rhs
  2.2852 +    val dummy = Prim.trace_thms ctxt "congs =" congs
  2.2853 +    (*the next step has caused simplifier looping in some cases*)
  2.2854 +    val {induction, rules, tcs} =
  2.2855 +      proof_stage ctxt strict wfs
  2.2856 +       {f = f, R = R, rules = rules,
  2.2857 +        full_pats_TCs = full_pats_TCs,
  2.2858 +        TCs = TCs}
  2.2859 +    val rules' = map (Drule.export_without_context o Object_Logic.rulify_no_asm ctxt)
  2.2860 +                      (Rules.CONJUNCTS rules)
  2.2861 +  in
  2.2862 +    {induct = meta_outer ctxt (Object_Logic.rulify_no_asm ctxt (induction RS spec')),
  2.2863 +     rules = ListPair.zip(rules', rows),
  2.2864 +     tcs = (termination_goals rules') @ tcs}
  2.2865 +  end
  2.2866 +  handle Utils.ERR {mesg,func,module} =>
  2.2867 +    error (mesg ^ "\n    (In TFL function " ^ module ^ "." ^ func ^ ")");
  2.2868 +
  2.2869 +
  2.2870 +(* Derive the initial equations from the case-split rules to meet the
  2.2871 +users specification of the recursive function. *)
  2.2872 +local
  2.2873 +  fun get_related_thms i =
  2.2874 +      map_filter ((fn (r,x) => if x = i then SOME r else NONE));
  2.2875 +
  2.2876 +  fun solve_eq _ (th, [], i) =  error "derive_init_eqs: missing rules"
  2.2877 +    | solve_eq _ (th, [a], i) = [(a, i)]
  2.2878 +    | solve_eq ctxt (th, splitths, i) =
  2.2879 +      (writeln "Proving unsplit equation...";
  2.2880 +      [((Drule.export_without_context o Object_Logic.rulify_no_asm ctxt)
  2.2881 +          (CaseSplit.splitto ctxt splitths th), i)])
  2.2882 +      handle ERROR s =>
  2.2883 +             (warning ("recdef (solve_eq): " ^ s); map (fn x => (x,i)) splitths);
  2.2884 +in
  2.2885 +fun derive_init_eqs ctxt rules eqs =
  2.2886 +  map (Thm.trivial o Thm.cterm_of ctxt o HOLogic.mk_Trueprop) eqs
  2.2887 +  |> map_index (fn (i, e) => solve_eq ctxt (e, (get_related_thms i rules), i))
  2.2888 +  |> flat;
  2.2889 +end;
  2.2890 +
  2.2891 +
  2.2892 +(*---------------------------------------------------------------------------
  2.2893 + * Defining a function with an associated termination relation.
  2.2894 + *---------------------------------------------------------------------------*)
  2.2895 +fun define_i strict congs wfs fid R eqs ctxt =
  2.2896 +  let
  2.2897 +    val thy = Proof_Context.theory_of ctxt
  2.2898 +    val {functional, pats} = Prim.mk_functional thy eqs
  2.2899 +    val (def, thy') = Prim.wfrec_definition0 fid R functional thy
  2.2900 +    val ctxt' = Proof_Context.transfer thy' ctxt
  2.2901 +    val (lhs, _) = Logic.dest_equals (Thm.prop_of def)
  2.2902 +    val {induct, rules, tcs} = simplify_defn ctxt' strict congs wfs fid pats def
  2.2903 +    val rules' = if strict then derive_init_eqs ctxt' rules eqs else rules
  2.2904 +  in ({lhs = lhs, rules = rules', induct = induct, tcs = tcs}, ctxt') end;
  2.2905 +
  2.2906 +fun define strict congs wfs fid R seqs ctxt =
  2.2907 +  define_i strict congs wfs fid
  2.2908 +    (Syntax.read_term ctxt R) (map (Syntax.read_term ctxt) seqs) ctxt
  2.2909 +      handle Utils.ERR {mesg,...} => error mesg;
  2.2910 +
  2.2911 +
  2.2912 +(*---------------------------------------------------------------------------
  2.2913 + *
  2.2914 + *     Definitions with synthesized termination relation
  2.2915 + *
  2.2916 + *---------------------------------------------------------------------------*)
  2.2917 +
  2.2918 +fun func_of_cond_eqn tm =
  2.2919 +  #1 (USyntax.strip_comb (#lhs (USyntax.dest_eq (#2 (USyntax.strip_forall (#2 (USyntax.strip_imp tm)))))));
  2.2920 +
  2.2921 +fun defer_i congs fid eqs thy =
  2.2922 + let
  2.2923 +     val {rules,R,theory,full_pats_TCs,SV,...} = Prim.lazyR_def thy fid congs eqs
  2.2924 +     val f = func_of_cond_eqn (concl (Rules.CONJUNCT1 rules handle Utils.ERR _ => rules));
  2.2925 +     val dummy = writeln "Proving induction theorem ...";
  2.2926 +     val induction = Prim.mk_induction theory
  2.2927 +                        {fconst=f, R=R, SV=SV, pat_TCs_list=full_pats_TCs}
  2.2928 + in
  2.2929 +   (*return the conjoined induction rule and recursion equations,
  2.2930 +     with assumptions remaining to discharge*)
  2.2931 +   (Drule.export_without_context (induction RS (rules RS conjI)), theory)
  2.2932 + end
  2.2933 +
  2.2934 +fun defer congs fid seqs thy =
  2.2935 +  defer_i congs fid (map (Syntax.read_term_global thy) seqs) thy
  2.2936 +    handle Utils.ERR {mesg,...} => error mesg;
  2.2937 +end;
  2.2938 +
  2.2939 +end;
  2.2940 +
  2.2941 +
  2.2942 +(*** wrappers for Isar ***)
  2.2943 +
  2.2944 +(** recdef hints **)
  2.2945 +
  2.2946 +(* type hints *)
  2.2947 +
  2.2948 +type hints = {simps: thm list, congs: (string * thm) list, wfs: thm list};
  2.2949 +
  2.2950 +fun mk_hints (simps, congs, wfs) = {simps = simps, congs = congs, wfs = wfs}: hints;
  2.2951 +fun map_hints f ({simps, congs, wfs}: hints) = mk_hints (f (simps, congs, wfs));
  2.2952 +
  2.2953 +fun map_simps f = map_hints (fn (simps, congs, wfs) => (f simps, congs, wfs));
  2.2954 +fun map_congs f = map_hints (fn (simps, congs, wfs) => (simps, f congs, wfs));
  2.2955 +fun map_wfs f = map_hints (fn (simps, congs, wfs) => (simps, congs, f wfs));
  2.2956 +
  2.2957 +
  2.2958 +(* congruence rules *)
  2.2959 +
  2.2960 +local
  2.2961 +
  2.2962 +val cong_head =
  2.2963 +  fst o Term.dest_Const o Term.head_of o fst o Logic.dest_equals o Thm.concl_of;
  2.2964 +
  2.2965 +fun prep_cong raw_thm =
  2.2966 +  let val thm = safe_mk_meta_eq raw_thm in (cong_head thm, thm) end;
  2.2967 +
  2.2968 +in
  2.2969 +
  2.2970 +fun add_cong raw_thm congs =
  2.2971 +  let
  2.2972 +    val (c, thm) = prep_cong raw_thm;
  2.2973 +    val _ = if AList.defined (op =) congs c
  2.2974 +      then warning ("Overwriting recdef congruence rule for " ^ quote c)
  2.2975 +      else ();
  2.2976 +  in AList.update (op =) (c, thm) congs end;
  2.2977 +
  2.2978 +fun del_cong raw_thm congs =
  2.2979 +  let
  2.2980 +    val (c, thm) = prep_cong raw_thm;
  2.2981 +    val _ = if AList.defined (op =) congs c
  2.2982 +      then ()
  2.2983 +      else warning ("No recdef congruence rule for " ^ quote c);
  2.2984 +  in AList.delete (op =) c congs end;
  2.2985 +
  2.2986 +end;
  2.2987 +
  2.2988 +
  2.2989 +
  2.2990 +(** global and local recdef data **)
  2.2991 +
  2.2992 +(* theory data *)
  2.2993 +
  2.2994 +type recdef_info = {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list};
  2.2995 +
  2.2996 +structure Data = Generic_Data
  2.2997 +(
  2.2998 +  type T = recdef_info Symtab.table * hints;
  2.2999 +  val empty = (Symtab.empty, mk_hints ([], [], [])): T;
  2.3000 +  val extend = I;
  2.3001 +  fun merge
  2.3002 +   ((tab1, {simps = simps1, congs = congs1, wfs = wfs1}),
  2.3003 +    (tab2, {simps = simps2, congs = congs2, wfs = wfs2})) : T =
  2.3004 +      (Symtab.merge (K true) (tab1, tab2),
  2.3005 +        mk_hints (Thm.merge_thms (simps1, simps2),
  2.3006 +          AList.merge (op =) (K true) (congs1, congs2),
  2.3007 +          Thm.merge_thms (wfs1, wfs2)));
  2.3008 +);
  2.3009 +
  2.3010 +val get_recdef = Symtab.lookup o #1 o Data.get o Context.Theory;
  2.3011 +
  2.3012 +fun put_recdef name info =
  2.3013 +  (Context.theory_map o Data.map o apfst) (fn tab =>
  2.3014 +    Symtab.update_new (name, info) tab
  2.3015 +      handle Symtab.DUP _ => error ("Duplicate recursive function definition " ^ quote name));
  2.3016 +
  2.3017 +val get_hints = #2 o Data.get o Context.Proof;
  2.3018 +val map_hints = Data.map o apsnd;
  2.3019 +
  2.3020 +
  2.3021 +(* attributes *)
  2.3022 +
  2.3023 +fun attrib f = Thm.declaration_attribute (map_hints o f);
  2.3024 +
  2.3025 +val simp_add = attrib (map_simps o Thm.add_thm);
  2.3026 +val simp_del = attrib (map_simps o Thm.del_thm);
  2.3027 +val cong_add = attrib (map_congs o add_cong);
  2.3028 +val cong_del = attrib (map_congs o del_cong);
  2.3029 +val wf_add = attrib (map_wfs o Thm.add_thm);
  2.3030 +val wf_del = attrib (map_wfs o Thm.del_thm);
  2.3031 +
  2.3032 +
  2.3033 +(* modifiers *)
  2.3034 +
  2.3035 +val recdef_simpN = "recdef_simp";
  2.3036 +val recdef_congN = "recdef_cong";
  2.3037 +val recdef_wfN = "recdef_wf";
  2.3038 +
  2.3039 +val recdef_modifiers =
  2.3040 + [Args.$$$ recdef_simpN -- Args.colon >> K (Method.modifier simp_add @{here}),
  2.3041 +  Args.$$$ recdef_simpN -- Args.add -- Args.colon >> K (Method.modifier simp_add @{here}),
  2.3042 +  Args.$$$ recdef_simpN -- Args.del -- Args.colon >> K (Method.modifier simp_del @{here}),
  2.3043 +  Args.$$$ recdef_congN -- Args.colon >> K (Method.modifier cong_add @{here}),
  2.3044 +  Args.$$$ recdef_congN -- Args.add -- Args.colon >> K (Method.modifier cong_add @{here}),
  2.3045 +  Args.$$$ recdef_congN -- Args.del -- Args.colon >> K (Method.modifier cong_del @{here}),
  2.3046 +  Args.$$$ recdef_wfN -- Args.colon >> K (Method.modifier wf_add @{here}),
  2.3047 +  Args.$$$ recdef_wfN -- Args.add -- Args.colon >> K (Method.modifier wf_add @{here}),
  2.3048 +  Args.$$$ recdef_wfN -- Args.del -- Args.colon >> K (Method.modifier wf_del @{here})] @
  2.3049 +  Clasimp.clasimp_modifiers;
  2.3050 +
  2.3051 +
  2.3052 +
  2.3053 +(** prepare hints **)
  2.3054 +
  2.3055 +fun prepare_hints opt_src ctxt =
  2.3056 +  let
  2.3057 +    val ctxt' =
  2.3058 +      (case opt_src of
  2.3059 +        NONE => ctxt
  2.3060 +      | SOME src => #2 (Token.syntax (Method.sections recdef_modifiers) src ctxt));
  2.3061 +    val {simps, congs, wfs} = get_hints ctxt';
  2.3062 +    val ctxt'' = ctxt' addsimps simps |> Simplifier.del_cong @{thm imp_cong};
  2.3063 +  in ((rev (map snd congs), wfs), ctxt'') end;
  2.3064 +
  2.3065 +fun prepare_hints_i () ctxt =
  2.3066 +  let
  2.3067 +    val {simps, congs, wfs} = get_hints ctxt;
  2.3068 +    val ctxt' = ctxt addsimps simps |> Simplifier.del_cong @{thm imp_cong};
  2.3069 +  in ((rev (map snd congs), wfs), ctxt') end;
  2.3070 +
  2.3071 +
  2.3072 +
  2.3073 +(** add_recdef(_i) **)
  2.3074 +
  2.3075 +fun gen_add_recdef tfl_fn prep_att prep_hints not_permissive raw_name R eq_srcs hints thy =
  2.3076 +  let
  2.3077 +    val _ = legacy_feature "Old 'recdef' command -- use 'fun' or 'function' instead";
  2.3078 +
  2.3079 +    val name = Sign.intern_const thy raw_name;
  2.3080 +    val bname = Long_Name.base_name name;
  2.3081 +    val _ = writeln ("Defining recursive function " ^ quote name ^ " ...");
  2.3082 +
  2.3083 +    val ((eq_names, eqs), raw_eq_atts) = apfst split_list (split_list eq_srcs);
  2.3084 +    val eq_atts = map (map (prep_att thy)) raw_eq_atts;
  2.3085 +
  2.3086 +    val ((congs, wfs), ctxt) = prep_hints hints (Proof_Context.init_global thy);
  2.3087 +    (*We must remove imp_cong to prevent looping when the induction rule
  2.3088 +      is simplified. Many induction rules have nested implications that would
  2.3089 +      give rise to looping conditional rewriting.*)
  2.3090 +    val ({lhs, rules = rules_idx, induct, tcs}, ctxt1) =
  2.3091 +      tfl_fn not_permissive congs wfs name R eqs ctxt;
  2.3092 +    val rules = (map o map) fst (partition_eq (eq_snd (op = : int * int -> bool)) rules_idx);
  2.3093 +    val simp_att =
  2.3094 +      if null tcs then [Simplifier.simp_add,
  2.3095 +        Named_Theorems.add @{named_theorems nitpick_simp}, Code.add_default_eqn_attribute]
  2.3096 +      else [];
  2.3097 +    val ((simps' :: rules', [induct']), thy2) =
  2.3098 +      Proof_Context.theory_of ctxt1
  2.3099 +      |> Sign.add_path bname
  2.3100 +      |> Global_Theory.add_thmss
  2.3101 +        (((Binding.name "simps", flat rules), simp_att) :: ((eq_names ~~ rules) ~~ eq_atts))
  2.3102 +      ||>> Global_Theory.add_thms [((Binding.name "induct", induct), [])]
  2.3103 +      ||> Spec_Rules.add_global Spec_Rules.Equational ([lhs], flat rules);
  2.3104 +    val result = {lhs = lhs, simps = simps', rules = rules', induct = induct', tcs = tcs};
  2.3105 +    val thy3 =
  2.3106 +      thy2
  2.3107 +      |> put_recdef name result
  2.3108 +      |> Sign.parent_path;
  2.3109 +  in (thy3, result) end;
  2.3110 +
  2.3111 +val add_recdef = gen_add_recdef Tfl.define Attrib.attribute_cmd_global prepare_hints;
  2.3112 +fun add_recdef_i x y z w = gen_add_recdef Tfl.define_i (K I) prepare_hints_i x y z w ();
  2.3113 +
  2.3114 +
  2.3115 +
  2.3116 +(** defer_recdef(_i) **)
  2.3117 +
  2.3118 +fun gen_defer_recdef tfl_fn eval_thms raw_name eqs raw_congs thy =
  2.3119 +  let
  2.3120 +    val name = Sign.intern_const thy raw_name;
  2.3121 +    val bname = Long_Name.base_name name;
  2.3122 +
  2.3123 +    val _ = writeln ("Deferred recursive function " ^ quote name ^ " ...");
  2.3124 +
  2.3125 +    val congs = eval_thms (Proof_Context.init_global thy) raw_congs;
  2.3126 +    val (induct_rules, thy2) = tfl_fn congs name eqs thy;
  2.3127 +    val ([induct_rules'], thy3) =
  2.3128 +      thy2
  2.3129 +      |> Sign.add_path bname
  2.3130 +      |> Global_Theory.add_thms [((Binding.name "induct_rules", induct_rules), [])]
  2.3131 +      ||> Sign.parent_path;
  2.3132 +  in (thy3, {induct_rules = induct_rules'}) end;
  2.3133 +
  2.3134 +val defer_recdef = gen_defer_recdef Tfl.defer Attrib.eval_thms;
  2.3135 +val defer_recdef_i = gen_defer_recdef Tfl.defer_i (K I);
  2.3136 +
  2.3137 +
  2.3138 +
  2.3139 +(** recdef_tc(_i) **)
  2.3140 +
  2.3141 +fun gen_recdef_tc prep_att prep_name (bname, raw_atts) raw_name opt_i int lthy =
  2.3142 +  let
  2.3143 +    val thy = Proof_Context.theory_of lthy;
  2.3144 +    val name = prep_name thy raw_name;
  2.3145 +    val atts = map (prep_att lthy) raw_atts;
  2.3146 +    val tcs =
  2.3147 +      (case get_recdef thy name of
  2.3148 +        NONE => error ("No recdef definition of constant: " ^ quote name)
  2.3149 +      | SOME {tcs, ...} => tcs);
  2.3150 +    val i = the_default 1 opt_i;
  2.3151 +    val tc = nth tcs (i - 1) handle General.Subscript =>
  2.3152 +      error ("No termination condition #" ^ string_of_int i ^
  2.3153 +        " in recdef definition of " ^ quote name);
  2.3154 +  in
  2.3155 +    Specification.theorem "" NONE (K I)
  2.3156 +      (Binding.concealed (Binding.name bname), atts) [] []
  2.3157 +      (Element.Shows [(Attrib.empty_binding, [(HOLogic.mk_Trueprop tc, [])])]) int lthy
  2.3158 +  end;
  2.3159 +
  2.3160 +val recdef_tc = gen_recdef_tc Attrib.check_src Sign.intern_const;
  2.3161 +val recdef_tc_i = gen_recdef_tc (K I) (K I);
  2.3162 +
  2.3163 +
  2.3164 +
  2.3165 +(** package setup **)
  2.3166 +
  2.3167 +(* setup theory *)
  2.3168 +
  2.3169 +val _ =
  2.3170 +  Theory.setup
  2.3171 +   (Attrib.setup @{binding recdef_simp} (Attrib.add_del simp_add simp_del)
  2.3172 +      "declaration of recdef simp rule" #>
  2.3173 +    Attrib.setup @{binding recdef_cong} (Attrib.add_del cong_add cong_del)
  2.3174 +      "declaration of recdef cong rule" #>
  2.3175 +    Attrib.setup @{binding recdef_wf} (Attrib.add_del wf_add wf_del)
  2.3176 +      "declaration of recdef wf rule");
  2.3177 +
  2.3178 +
  2.3179 +(* outer syntax *)
  2.3180 +
  2.3181 +val hints =
  2.3182 +  @{keyword "("} |--
  2.3183 +    Parse.!!! (Parse.position @{keyword "hints"} -- Parse.args --| @{keyword ")"})
  2.3184 +  >> uncurry Token.src;
  2.3185 +
  2.3186 +val recdef_decl =
  2.3187 +  Scan.optional
  2.3188 +    (@{keyword "("} -- Parse.!!! (@{keyword "permissive"} -- @{keyword ")"}) >> K false) true --
  2.3189 +  Parse.name -- Parse.term -- Scan.repeat1 (Parse_Spec.opt_thm_name ":" -- Parse.prop)
  2.3190 +    -- Scan.option hints
  2.3191 +  >> (fn ((((p, f), R), eqs), src) => #1 o add_recdef p f R (map Parse.triple_swap eqs) src);
  2.3192 +
  2.3193 +val _ =
  2.3194 +  Outer_Syntax.command @{command_keyword recdef} "define general recursive functions (obsolete TFL)"
  2.3195 +    (recdef_decl >> Toplevel.theory);
  2.3196 +
  2.3197 +
  2.3198 +val defer_recdef_decl =
  2.3199 +  Parse.name -- Scan.repeat1 Parse.prop --
  2.3200 +  Scan.optional
  2.3201 +    (@{keyword "("} |-- @{keyword "congs"} |-- Parse.!!! (Parse.xthms1 --| @{keyword ")"})) []
  2.3202 +  >> (fn ((f, eqs), congs) => #1 o defer_recdef f eqs congs);
  2.3203 +
  2.3204 +val _ =
  2.3205 +  Outer_Syntax.command @{command_keyword defer_recdef}
  2.3206 +    "defer general recursive functions (obsolete TFL)"
  2.3207 +    (defer_recdef_decl >> Toplevel.theory);
  2.3208 +
  2.3209 +val _ =
  2.3210 +  Outer_Syntax.local_theory_to_proof' @{command_keyword recdef_tc}
  2.3211 +    "recommence proof of termination condition (obsolete TFL)"
  2.3212 +    ((Parse_Spec.opt_thm_name ":" >> apfst Binding.name_of) -- Parse.xname --
  2.3213 +        Scan.option (@{keyword "("} |-- Parse.nat --| @{keyword ")"})
  2.3214 +      >> (fn ((thm_name, name), i) => recdef_tc thm_name name i));
  2.3215 +
  2.3216 +end;
     3.1 --- a/src/HOL/Tools/TFL/casesplit.ML	Fri Jun 19 18:41:21 2015 +0200
     3.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3 @@ -1,152 +0,0 @@
     3.4 -(*  Title:      HOL/Tools/TFL/casesplit.ML
     3.5 -    Author:     Lucas Dixon, University of Edinburgh
     3.6 -
     3.7 -Extra case splitting for TFL.
     3.8 -*)
     3.9 -
    3.10 -signature CASE_SPLIT =
    3.11 -sig
    3.12 -  (* try to recursively split conjectured thm to given list of thms *)
    3.13 -  val splitto : Proof.context -> thm list -> thm -> thm
    3.14 -end;
    3.15 -
    3.16 -structure CaseSplit: CASE_SPLIT =
    3.17 -struct
    3.18 -
    3.19 -(* make a casethm from an induction thm *)
    3.20 -val cases_thm_of_induct_thm =
    3.21 -     Seq.hd o (ALLGOALS (fn i => REPEAT (etac Drule.thin_rl i)));
    3.22 -
    3.23 -(* get the case_thm (my version) from a type *)
    3.24 -fun case_thm_of_ty thy ty  =
    3.25 -    let
    3.26 -      val ty_str = case ty of
    3.27 -                     Type(ty_str, _) => ty_str
    3.28 -                   | TFree(s,_)  => error ("Free type: " ^ s)
    3.29 -                   | TVar((s,i),_) => error ("Free variable: " ^ s)
    3.30 -      val {induct, ...} = BNF_LFP_Compat.the_info thy [BNF_LFP_Compat.Keep_Nesting] ty_str
    3.31 -    in
    3.32 -      cases_thm_of_induct_thm induct
    3.33 -    end;
    3.34 -
    3.35 -
    3.36 -(* for use when there are no prems to the subgoal *)
    3.37 -(* does a case split on the given variable *)
    3.38 -fun mk_casesplit_goal_thm ctxt (vstr,ty) gt =
    3.39 -    let
    3.40 -      val thy = Proof_Context.theory_of ctxt;
    3.41 -
    3.42 -      val x = Free(vstr,ty);
    3.43 -      val abst = Abs(vstr, ty, Term.abstract_over (x, gt));
    3.44 -
    3.45 -      val case_thm = case_thm_of_ty thy ty;
    3.46 -
    3.47 -      val abs_ct = Thm.cterm_of ctxt abst;
    3.48 -      val free_ct = Thm.cterm_of ctxt x;
    3.49 -
    3.50 -      val (Pv, Dv, type_insts) =
    3.51 -          case (Thm.concl_of case_thm) of
    3.52 -            (_ $ (Pv $ (Dv as Var(D, Dty)))) =>
    3.53 -            (Pv, Dv,
    3.54 -             Sign.typ_match thy (Dty, ty) Vartab.empty)
    3.55 -          | _ => error "not a valid case thm";
    3.56 -      val type_cinsts = map (fn (ixn, (S, T)) => apply2 (Thm.ctyp_of ctxt) (TVar (ixn, S), T))
    3.57 -        (Vartab.dest type_insts);
    3.58 -      val cPv = Thm.cterm_of ctxt (Envir.subst_term_types type_insts Pv);
    3.59 -      val cDv = Thm.cterm_of ctxt (Envir.subst_term_types type_insts Dv);
    3.60 -    in
    3.61 -      Conv.fconv_rule Drule.beta_eta_conversion
    3.62 -         (case_thm
    3.63 -            |> Thm.instantiate (type_cinsts, [])
    3.64 -            |> Thm.instantiate ([], [(cPv, abs_ct), (cDv, free_ct)]))
    3.65 -    end;
    3.66 -
    3.67 -
    3.68 -(* the find_XXX_split functions are simply doing a lightwieght (I
    3.69 -think) term matching equivalent to find where to do the next split *)
    3.70 -
    3.71 -(* assuming two twems are identical except for a free in one at a
    3.72 -subterm, or constant in another, ie assume that one term is a plit of
    3.73 -another, then gives back the free variable that has been split. *)
    3.74 -exception find_split_exp of string
    3.75 -fun find_term_split (Free v, _ $ _) = SOME v
    3.76 -  | find_term_split (Free v, Const _) = SOME v
    3.77 -  | find_term_split (Free v, Abs _) = SOME v (* do we really want this case? *)
    3.78 -  | find_term_split (Free v, Var _) = NONE (* keep searching *)
    3.79 -  | find_term_split (a $ b, a2 $ b2) =
    3.80 -    (case find_term_split (a, a2) of
    3.81 -       NONE => find_term_split (b,b2)
    3.82 -     | vopt => vopt)
    3.83 -  | find_term_split (Abs(_,ty,t1), Abs(_,ty2,t2)) =
    3.84 -    find_term_split (t1, t2)
    3.85 -  | find_term_split (Const (x,ty), Const(x2,ty2)) =
    3.86 -    if x = x2 then NONE else (* keep searching *)
    3.87 -    raise find_split_exp (* stop now *)
    3.88 -            "Terms are not identical upto a free varaible! (Consts)"
    3.89 -  | find_term_split (Bound i, Bound j) =
    3.90 -    if i = j then NONE else (* keep searching *)
    3.91 -    raise find_split_exp (* stop now *)
    3.92 -            "Terms are not identical upto a free varaible! (Bound)"
    3.93 -  | find_term_split _ =
    3.94 -    raise find_split_exp (* stop now *)
    3.95 -            "Terms are not identical upto a free varaible! (Other)";
    3.96 -
    3.97 -(* assume that "splitth" is a case split form of subgoal i of "genth",
    3.98 -then look for a free variable to split, breaking the subgoal closer to
    3.99 -splitth. *)
   3.100 -fun find_thm_split splitth i genth =
   3.101 -    find_term_split (Logic.get_goal (Thm.prop_of genth) i,
   3.102 -                     Thm.concl_of splitth) handle find_split_exp _ => NONE;
   3.103 -
   3.104 -(* as above but searches "splitths" for a theorem that suggest a case split *)
   3.105 -fun find_thms_split splitths i genth =
   3.106 -    Library.get_first (fn sth => find_thm_split sth i genth) splitths;
   3.107 -
   3.108 -
   3.109 -(* split the subgoal i of "genth" until we get to a member of
   3.110 -splitths. Assumes that genth will be a general form of splitths, that
   3.111 -can be case-split, as needed. Otherwise fails. Note: We assume that
   3.112 -all of "splitths" are split to the same level, and thus it doesn't
   3.113 -matter which one we choose to look for the next split. Simply add
   3.114 -search on splitthms and split variable, to change this.  *)
   3.115 -(* Note: possible efficiency measure: when a case theorem is no longer
   3.116 -useful, drop it? *)
   3.117 -(* Note: This should not be a separate tactic but integrated into the
   3.118 -case split done during recdef's case analysis, this would avoid us
   3.119 -having to (re)search for variables to split. *)
   3.120 -fun splitto ctxt splitths genth =
   3.121 -    let
   3.122 -      val _ = not (null splitths) orelse error "splitto: no given splitths";
   3.123 -
   3.124 -      (* check if we are a member of splitths - FIXME: quicker and
   3.125 -      more flexible with discrim net. *)
   3.126 -      fun solve_by_splitth th split =
   3.127 -        Thm.biresolution (SOME ctxt) false [(false,split)] 1 th;
   3.128 -
   3.129 -      fun split th =
   3.130 -        (case find_thms_split splitths 1 th of
   3.131 -          NONE =>
   3.132 -           (writeln (cat_lines
   3.133 -            (["th:", Display.string_of_thm ctxt th, "split ths:"] @
   3.134 -              map (Display.string_of_thm ctxt) splitths @ ["\n--"]));
   3.135 -            error "splitto: cannot find variable to split on")
   3.136 -        | SOME v =>
   3.137 -            let
   3.138 -              val gt = HOLogic.dest_Trueprop (#1 (Logic.dest_implies (Thm.prop_of th)));
   3.139 -              val split_thm = mk_casesplit_goal_thm ctxt v gt;
   3.140 -              val (subthms, expf) = IsaND.fixed_subgoal_thms ctxt split_thm;
   3.141 -            in
   3.142 -              expf (map recsplitf subthms)
   3.143 -            end)
   3.144 -
   3.145 -      and recsplitf th =
   3.146 -        (* note: multiple unifiers! we only take the first element,
   3.147 -           probably fine -- there is probably only one anyway. *)
   3.148 -        (case get_first (Seq.pull o solve_by_splitth th) splitths of
   3.149 -          NONE => split th
   3.150 -        | SOME (solved_th, _) => solved_th);
   3.151 -    in
   3.152 -      recsplitf genth
   3.153 -    end;
   3.154 -
   3.155 -end;
     4.1 --- a/src/HOL/Tools/TFL/dcterm.ML	Fri Jun 19 18:41:21 2015 +0200
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,186 +0,0 @@
     4.4 -(*  Title:      HOL/Tools/TFL/dcterm.ML
     4.5 -    Author:     Konrad Slind, Cambridge University Computer Laboratory
     4.6 -*)
     4.7 -
     4.8 -(*---------------------------------------------------------------------------
     4.9 - * Derived efficient cterm destructors.
    4.10 - *---------------------------------------------------------------------------*)
    4.11 -
    4.12 -signature DCTERM =
    4.13 -sig
    4.14 -  val dest_comb: cterm -> cterm * cterm
    4.15 -  val dest_abs: string option -> cterm -> cterm * cterm
    4.16 -  val capply: cterm -> cterm -> cterm
    4.17 -  val cabs: cterm -> cterm -> cterm
    4.18 -  val mk_conj: cterm * cterm -> cterm
    4.19 -  val mk_disj: cterm * cterm -> cterm
    4.20 -  val mk_exists: cterm * cterm -> cterm
    4.21 -  val dest_conj: cterm -> cterm * cterm
    4.22 -  val dest_const: cterm -> {Name: string, Ty: typ}
    4.23 -  val dest_disj: cterm -> cterm * cterm
    4.24 -  val dest_eq: cterm -> cterm * cterm
    4.25 -  val dest_exists: cterm -> cterm * cterm
    4.26 -  val dest_forall: cterm -> cterm * cterm
    4.27 -  val dest_imp: cterm -> cterm * cterm
    4.28 -  val dest_neg: cterm -> cterm
    4.29 -  val dest_pair: cterm -> cterm * cterm
    4.30 -  val dest_var: cterm -> {Name:string, Ty:typ}
    4.31 -  val is_conj: cterm -> bool
    4.32 -  val is_disj: cterm -> bool
    4.33 -  val is_eq: cterm -> bool
    4.34 -  val is_exists: cterm -> bool
    4.35 -  val is_forall: cterm -> bool
    4.36 -  val is_imp: cterm -> bool
    4.37 -  val is_neg: cterm -> bool
    4.38 -  val is_pair: cterm -> bool
    4.39 -  val list_mk_disj: cterm list -> cterm
    4.40 -  val strip_abs: cterm -> cterm list * cterm
    4.41 -  val strip_comb: cterm -> cterm * cterm list
    4.42 -  val strip_disj: cterm -> cterm list
    4.43 -  val strip_exists: cterm -> cterm list * cterm
    4.44 -  val strip_forall: cterm -> cterm list * cterm
    4.45 -  val strip_imp: cterm -> cterm list * cterm
    4.46 -  val drop_prop: cterm -> cterm
    4.47 -  val mk_prop: cterm -> cterm
    4.48 -end;
    4.49 -
    4.50 -structure Dcterm: DCTERM =
    4.51 -struct
    4.52 -
    4.53 -fun ERR func mesg = Utils.ERR {module = "Dcterm", func = func, mesg = mesg};
    4.54 -
    4.55 -
    4.56 -fun dest_comb t = Thm.dest_comb t
    4.57 -  handle CTERM (msg, _) => raise ERR "dest_comb" msg;
    4.58 -
    4.59 -fun dest_abs a t = Thm.dest_abs a t
    4.60 -  handle CTERM (msg, _) => raise ERR "dest_abs" msg;
    4.61 -
    4.62 -fun capply t u = Thm.apply t u
    4.63 -  handle CTERM (msg, _) => raise ERR "capply" msg;
    4.64 -
    4.65 -fun cabs a t = Thm.lambda a t
    4.66 -  handle CTERM (msg, _) => raise ERR "cabs" msg;
    4.67 -
    4.68 -
    4.69 -(*---------------------------------------------------------------------------
    4.70 - * Some simple constructor functions.
    4.71 - *---------------------------------------------------------------------------*)
    4.72 -
    4.73 -val mk_hol_const = Thm.cterm_of @{theory_context HOL} o Const;
    4.74 -
    4.75 -fun mk_exists (r as (Bvar, Body)) =
    4.76 -  let val ty = Thm.typ_of_cterm Bvar
    4.77 -      val c = mk_hol_const(@{const_name Ex}, (ty --> HOLogic.boolT) --> HOLogic.boolT)
    4.78 -  in capply c (uncurry cabs r) end;
    4.79 -
    4.80 -
    4.81 -local val c = mk_hol_const(@{const_name HOL.conj}, HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
    4.82 -in fun mk_conj(conj1,conj2) = capply (capply c conj1) conj2
    4.83 -end;
    4.84 -
    4.85 -local val c = mk_hol_const(@{const_name HOL.disj}, HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
    4.86 -in fun mk_disj(disj1,disj2) = capply (capply c disj1) disj2
    4.87 -end;
    4.88 -
    4.89 -
    4.90 -(*---------------------------------------------------------------------------
    4.91 - * The primitives.
    4.92 - *---------------------------------------------------------------------------*)
    4.93 -fun dest_const ctm =
    4.94 -   (case Thm.term_of ctm
    4.95 -      of Const(s,ty) => {Name = s, Ty = ty}
    4.96 -       | _ => raise ERR "dest_const" "not a constant");
    4.97 -
    4.98 -fun dest_var ctm =
    4.99 -   (case Thm.term_of ctm
   4.100 -      of Var((s,i),ty) => {Name=s, Ty=ty}
   4.101 -       | Free(s,ty)    => {Name=s, Ty=ty}
   4.102 -       |             _ => raise ERR "dest_var" "not a variable");
   4.103 -
   4.104 -
   4.105 -(*---------------------------------------------------------------------------
   4.106 - * Derived destructor operations.
   4.107 - *---------------------------------------------------------------------------*)
   4.108 -
   4.109 -fun dest_monop expected tm =
   4.110 - let
   4.111 -   fun err () = raise ERR "dest_monop" ("Not a(n) " ^ quote expected);
   4.112 -   val (c, N) = dest_comb tm handle Utils.ERR _ => err ();
   4.113 -   val name = #Name (dest_const c handle Utils.ERR _ => err ());
   4.114 - in if name = expected then N else err () end;
   4.115 -
   4.116 -fun dest_binop expected tm =
   4.117 - let
   4.118 -   fun err () = raise ERR "dest_binop" ("Not a(n) " ^ quote expected);
   4.119 -   val (M, N) = dest_comb tm handle Utils.ERR _ => err ()
   4.120 - in (dest_monop expected M, N) handle Utils.ERR _ => err () end;
   4.121 -
   4.122 -fun dest_binder expected tm =
   4.123 -  dest_abs NONE (dest_monop expected tm)
   4.124 -  handle Utils.ERR _ => raise ERR "dest_binder" ("Not a(n) " ^ quote expected);
   4.125 -
   4.126 -
   4.127 -val dest_neg    = dest_monop @{const_name Not}
   4.128 -val dest_pair   = dest_binop @{const_name Pair}
   4.129 -val dest_eq     = dest_binop @{const_name HOL.eq}
   4.130 -val dest_imp    = dest_binop @{const_name HOL.implies}
   4.131 -val dest_conj   = dest_binop @{const_name HOL.conj}
   4.132 -val dest_disj   = dest_binop @{const_name HOL.disj}
   4.133 -val dest_select = dest_binder @{const_name Eps}
   4.134 -val dest_exists = dest_binder @{const_name Ex}
   4.135 -val dest_forall = dest_binder @{const_name All}
   4.136 -
   4.137 -(* Query routines *)
   4.138 -
   4.139 -val is_eq     = can dest_eq
   4.140 -val is_imp    = can dest_imp
   4.141 -val is_select = can dest_select
   4.142 -val is_forall = can dest_forall
   4.143 -val is_exists = can dest_exists
   4.144 -val is_neg    = can dest_neg
   4.145 -val is_conj   = can dest_conj
   4.146 -val is_disj   = can dest_disj
   4.147 -val is_pair   = can dest_pair
   4.148 -
   4.149 -
   4.150 -(*---------------------------------------------------------------------------
   4.151 - * Iterated creation.
   4.152 - *---------------------------------------------------------------------------*)
   4.153 -val list_mk_disj = Utils.end_itlist (fn d1 => fn tm => mk_disj (d1, tm));
   4.154 -
   4.155 -(*---------------------------------------------------------------------------
   4.156 - * Iterated destruction. (To the "right" in a term.)
   4.157 - *---------------------------------------------------------------------------*)
   4.158 -fun strip break tm =
   4.159 -  let fun dest (p as (ctm,accum)) =
   4.160 -        let val (M,N) = break ctm
   4.161 -        in dest (N, M::accum)
   4.162 -        end handle Utils.ERR _ => p
   4.163 -  in dest (tm,[])
   4.164 -  end;
   4.165 -
   4.166 -fun rev2swap (x,l) = (rev l, x);
   4.167 -
   4.168 -val strip_comb   = strip (Library.swap o dest_comb)  (* Goes to the "left" *)
   4.169 -val strip_imp    = rev2swap o strip dest_imp
   4.170 -val strip_abs    = rev2swap o strip (dest_abs NONE)
   4.171 -val strip_forall = rev2swap o strip dest_forall
   4.172 -val strip_exists = rev2swap o strip dest_exists
   4.173 -
   4.174 -val strip_disj   = rev o (op::) o strip dest_disj
   4.175 -
   4.176 -
   4.177 -(*---------------------------------------------------------------------------
   4.178 - * Going into and out of prop
   4.179 - *---------------------------------------------------------------------------*)
   4.180 -
   4.181 -fun is_Trueprop ct =
   4.182 -  (case Thm.term_of ct of
   4.183 -    Const (@{const_name Trueprop}, _) $ _ => true
   4.184 -  | _ => false);
   4.185 -
   4.186 -fun mk_prop ct = if is_Trueprop ct then ct else Thm.apply @{cterm Trueprop} ct;
   4.187 -fun drop_prop ct = if is_Trueprop ct then Thm.dest_arg ct else ct;
   4.188 -
   4.189 -end;
     5.1 --- a/src/HOL/Tools/TFL/post.ML	Fri Jun 19 18:41:21 2015 +0200
     5.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3 @@ -1,232 +0,0 @@
     5.4 -(*  Title:      HOL/Tools/TFL/post.ML
     5.5 -    Author:     Konrad Slind, Cambridge University Computer Laboratory
     5.6 -    Copyright   1997  University of Cambridge
     5.7 -
     5.8 -Second part of main module (postprocessing of TFL definitions).
     5.9 -*)
    5.10 -
    5.11 -signature TFL =
    5.12 -sig
    5.13 -  val define_i: bool -> thm list -> thm list -> xstring -> term -> term list -> Proof.context ->
    5.14 -    {lhs: term, rules: (thm * int) list, induct: thm, tcs: term list} * Proof.context
    5.15 -  val define: bool -> thm list -> thm list -> xstring -> string -> string list -> Proof.context ->
    5.16 -    {lhs: term, rules: (thm * int) list, induct: thm, tcs: term list} * Proof.context
    5.17 -  val defer_i: thm list -> xstring -> term list -> theory -> thm * theory
    5.18 -  val defer: thm list -> xstring -> string list -> theory -> thm * theory
    5.19 -end;
    5.20 -
    5.21 -structure Tfl: TFL =
    5.22 -struct
    5.23 -
    5.24 -(* misc *)
    5.25 -
    5.26 -(*---------------------------------------------------------------------------
    5.27 - * Extract termination goals so that they can be put it into a goalstack, or
    5.28 - * have a tactic directly applied to them.
    5.29 - *--------------------------------------------------------------------------*)
    5.30 -fun termination_goals rules =
    5.31 -    map (Type.legacy_freeze o HOLogic.dest_Trueprop)
    5.32 -      (fold_rev (union (op aconv) o Thm.prems_of) rules []);
    5.33 -
    5.34 -(*---------------------------------------------------------------------------
    5.35 - * Three postprocessors are applied to the definition.  It
    5.36 - * attempts to prove wellfoundedness of the given relation, simplifies the
    5.37 - * non-proved termination conditions, and finally attempts to prove the
    5.38 - * simplified termination conditions.
    5.39 - *--------------------------------------------------------------------------*)
    5.40 -fun std_postprocessor ctxt strict wfs =
    5.41 -  Prim.postprocess ctxt strict
    5.42 -   {wf_tac = REPEAT (ares_tac wfs 1),
    5.43 -    terminator =
    5.44 -      asm_simp_tac ctxt 1
    5.45 -      THEN TRY (Arith_Data.arith_tac ctxt 1 ORELSE
    5.46 -        fast_force_tac (ctxt addSDs @{thms not0_implies_Suc}) 1),
    5.47 -    simplifier = Rules.simpl_conv ctxt []};
    5.48 -
    5.49 -
    5.50 -
    5.51 -val concl = #2 o Rules.dest_thm;
    5.52 -
    5.53 -(*---------------------------------------------------------------------------
    5.54 - * Postprocess a definition made by "define". This is a separate stage of
    5.55 - * processing from the definition stage.
    5.56 - *---------------------------------------------------------------------------*)
    5.57 -local
    5.58 -
    5.59 -(* The rest of these local definitions are for the tricky nested case *)
    5.60 -val solved = not o can USyntax.dest_eq o #2 o USyntax.strip_forall o concl
    5.61 -
    5.62 -fun id_thm th =
    5.63 -   let val {lhs,rhs} = USyntax.dest_eq (#2 (USyntax.strip_forall (#2 (Rules.dest_thm th))));
    5.64 -   in lhs aconv rhs end
    5.65 -   handle Utils.ERR _ => false;
    5.66 -   
    5.67 -val P_imp_P_eq_True = @{thm eqTrueI} RS eq_reflection;
    5.68 -fun mk_meta_eq r =
    5.69 -  (case Thm.concl_of r of
    5.70 -     Const(@{const_name Pure.eq},_)$_$_ => r
    5.71 -  |   _ $(Const(@{const_name HOL.eq},_)$_$_) => r RS eq_reflection
    5.72 -  |   _ => r RS P_imp_P_eq_True)
    5.73 -
    5.74 -(*Is this the best way to invoke the simplifier??*)
    5.75 -fun rewrite ctxt L = rewrite_rule ctxt (map mk_meta_eq (filter_out id_thm L))
    5.76 -
    5.77 -fun join_assums ctxt th =
    5.78 -  let val tych = Thm.cterm_of ctxt
    5.79 -      val {lhs,rhs} = USyntax.dest_eq(#2 (USyntax.strip_forall (concl th)))
    5.80 -      val cntxtl = (#1 o USyntax.strip_imp) lhs  (* cntxtl should = cntxtr *)
    5.81 -      val cntxtr = (#1 o USyntax.strip_imp) rhs  (* but union is solider *)
    5.82 -      val cntxt = union (op aconv) cntxtl cntxtr
    5.83 -  in
    5.84 -    Rules.GEN_ALL ctxt
    5.85 -      (Rules.DISCH_ALL
    5.86 -         (rewrite ctxt (map (Rules.ASSUME o tych) cntxt) (Rules.SPEC_ALL th)))
    5.87 -  end
    5.88 -  val gen_all = USyntax.gen_all
    5.89 -in
    5.90 -fun proof_stage ctxt strict wfs {f, R, rules, full_pats_TCs, TCs} =
    5.91 -  let
    5.92 -    val _ = writeln "Proving induction theorem ..."
    5.93 -    val ind =
    5.94 -      Prim.mk_induction (Proof_Context.theory_of ctxt)
    5.95 -        {fconst=f, R=R, SV=[], pat_TCs_list=full_pats_TCs}
    5.96 -    val _ = writeln "Postprocessing ...";
    5.97 -    val {rules, induction, nested_tcs} =
    5.98 -      std_postprocessor ctxt strict wfs {rules=rules, induction=ind, TCs=TCs}
    5.99 -  in
   5.100 -  case nested_tcs
   5.101 -  of [] => {induction=induction, rules=rules,tcs=[]}
   5.102 -  | L  => let val dummy = writeln "Simplifying nested TCs ..."
   5.103 -              val (solved,simplified,stubborn) =
   5.104 -               fold_rev (fn th => fn (So,Si,St) =>
   5.105 -                     if (id_thm th) then (So, Si, th::St) else
   5.106 -                     if (solved th) then (th::So, Si, St)
   5.107 -                     else (So, th::Si, St)) nested_tcs ([],[],[])
   5.108 -              val simplified' = map (join_assums ctxt) simplified
   5.109 -              val dummy = (Prim.trace_thms ctxt "solved =" solved;
   5.110 -                           Prim.trace_thms ctxt "simplified' =" simplified')
   5.111 -              val rewr = full_simplify (ctxt addsimps (solved @ simplified'));
   5.112 -              val dummy = Prim.trace_thms ctxt "Simplifying the induction rule..." [induction]
   5.113 -              val induction' = rewr induction
   5.114 -              val dummy = Prim.trace_thms ctxt "Simplifying the recursion rules..." [rules]
   5.115 -              val rules'     = rewr rules
   5.116 -              val _ = writeln "... Postprocessing finished";
   5.117 -          in
   5.118 -          {induction = induction',
   5.119 -               rules = rules',
   5.120 -                 tcs = map (gen_all o USyntax.rhs o #2 o USyntax.strip_forall o concl)
   5.121 -                           (simplified@stubborn)}
   5.122 -          end
   5.123 -  end;
   5.124 -
   5.125 -
   5.126 -(*lcp: curry the predicate of the induction rule*)
   5.127 -fun curry_rule ctxt rl =
   5.128 -  Split_Rule.split_rule_var ctxt (Term.head_of (HOLogic.dest_Trueprop (Thm.concl_of rl))) rl;
   5.129 -
   5.130 -(*lcp: put a theorem into Isabelle form, using meta-level connectives*)
   5.131 -fun meta_outer ctxt =
   5.132 -  curry_rule ctxt o Drule.export_without_context o
   5.133 -  rule_by_tactic ctxt (REPEAT (FIRSTGOAL (resolve_tac ctxt [allI, impI, conjI] ORELSE' etac conjE)));
   5.134 -
   5.135 -(*Strip off the outer !P*)
   5.136 -val spec'=
   5.137 -  Rule_Insts.read_instantiate @{context} [((("x", 0), Position.none), "P::'b=>bool")] [] spec;
   5.138 -
   5.139 -fun tracing true _ = ()
   5.140 -  | tracing false msg = writeln msg;
   5.141 -
   5.142 -fun simplify_defn ctxt strict congs wfs id pats def0 =
   5.143 -  let
   5.144 -    val def = Thm.unvarify_global def0 RS meta_eq_to_obj_eq
   5.145 -    val {rules, rows, TCs, full_pats_TCs} = Prim.post_definition ctxt congs (def, pats)
   5.146 -    val {lhs=f,rhs} = USyntax.dest_eq (concl def)
   5.147 -    val (_,[R,_]) = USyntax.strip_comb rhs
   5.148 -    val dummy = Prim.trace_thms ctxt "congs =" congs
   5.149 -    (*the next step has caused simplifier looping in some cases*)
   5.150 -    val {induction, rules, tcs} =
   5.151 -      proof_stage ctxt strict wfs
   5.152 -       {f = f, R = R, rules = rules,
   5.153 -        full_pats_TCs = full_pats_TCs,
   5.154 -        TCs = TCs}
   5.155 -    val rules' = map (Drule.export_without_context o Object_Logic.rulify_no_asm ctxt)
   5.156 -                      (Rules.CONJUNCTS rules)
   5.157 -  in
   5.158 -    {induct = meta_outer ctxt (Object_Logic.rulify_no_asm ctxt (induction RS spec')),
   5.159 -     rules = ListPair.zip(rules', rows),
   5.160 -     tcs = (termination_goals rules') @ tcs}
   5.161 -  end
   5.162 -  handle Utils.ERR {mesg,func,module} =>
   5.163 -    error (mesg ^ "\n    (In TFL function " ^ module ^ "." ^ func ^ ")");
   5.164 -
   5.165 -
   5.166 -(* Derive the initial equations from the case-split rules to meet the
   5.167 -users specification of the recursive function. *)
   5.168 -local
   5.169 -  fun get_related_thms i = 
   5.170 -      map_filter ((fn (r,x) => if x = i then SOME r else NONE));
   5.171 -
   5.172 -  fun solve_eq _ (th, [], i) =  error "derive_init_eqs: missing rules"
   5.173 -    | solve_eq _ (th, [a], i) = [(a, i)]
   5.174 -    | solve_eq ctxt (th, splitths, i) =
   5.175 -      (writeln "Proving unsplit equation...";
   5.176 -      [((Drule.export_without_context o Object_Logic.rulify_no_asm ctxt)
   5.177 -          (CaseSplit.splitto ctxt splitths th), i)])
   5.178 -      handle ERROR s => 
   5.179 -             (warning ("recdef (solve_eq): " ^ s); map (fn x => (x,i)) splitths);
   5.180 -in
   5.181 -fun derive_init_eqs ctxt rules eqs =
   5.182 -  map (Thm.trivial o Thm.cterm_of ctxt o HOLogic.mk_Trueprop) eqs
   5.183 -  |> map_index (fn (i, e) => solve_eq ctxt (e, (get_related_thms i rules), i))
   5.184 -  |> flat;
   5.185 -end;
   5.186 -
   5.187 -
   5.188 -(*---------------------------------------------------------------------------
   5.189 - * Defining a function with an associated termination relation.
   5.190 - *---------------------------------------------------------------------------*)
   5.191 -fun define_i strict congs wfs fid R eqs ctxt =
   5.192 -  let
   5.193 -    val thy = Proof_Context.theory_of ctxt
   5.194 -    val {functional, pats} = Prim.mk_functional thy eqs
   5.195 -    val (def, thy') = Prim.wfrec_definition0 fid R functional thy
   5.196 -    val ctxt' = Proof_Context.transfer thy' ctxt
   5.197 -    val (lhs, _) = Logic.dest_equals (Thm.prop_of def)
   5.198 -    val {induct, rules, tcs} = simplify_defn ctxt' strict congs wfs fid pats def
   5.199 -    val rules' = if strict then derive_init_eqs ctxt' rules eqs else rules
   5.200 -  in ({lhs = lhs, rules = rules', induct = induct, tcs = tcs}, ctxt') end;
   5.201 -
   5.202 -fun define strict congs wfs fid R seqs ctxt =
   5.203 -  define_i strict congs wfs fid
   5.204 -    (Syntax.read_term ctxt R) (map (Syntax.read_term ctxt) seqs) ctxt
   5.205 -      handle Utils.ERR {mesg,...} => error mesg;
   5.206 -
   5.207 -
   5.208 -(*---------------------------------------------------------------------------
   5.209 - *
   5.210 - *     Definitions with synthesized termination relation
   5.211 - *
   5.212 - *---------------------------------------------------------------------------*)
   5.213 -
   5.214 -fun func_of_cond_eqn tm =
   5.215 -  #1 (USyntax.strip_comb (#lhs (USyntax.dest_eq (#2 (USyntax.strip_forall (#2 (USyntax.strip_imp tm)))))));
   5.216 -
   5.217 -fun defer_i congs fid eqs thy =
   5.218 - let
   5.219 -     val {rules,R,theory,full_pats_TCs,SV,...} = Prim.lazyR_def thy fid congs eqs
   5.220 -     val f = func_of_cond_eqn (concl (Rules.CONJUNCT1 rules handle Utils.ERR _ => rules));
   5.221 -     val dummy = writeln "Proving induction theorem ...";
   5.222 -     val induction = Prim.mk_induction theory
   5.223 -                        {fconst=f, R=R, SV=SV, pat_TCs_list=full_pats_TCs}
   5.224 - in
   5.225 -   (*return the conjoined induction rule and recursion equations,
   5.226 -     with assumptions remaining to discharge*)
   5.227 -   (Drule.export_without_context (induction RS (rules RS conjI)), theory)
   5.228 - end
   5.229 -
   5.230 -fun defer congs fid seqs thy =
   5.231 -  defer_i congs fid (map (Syntax.read_term_global thy) seqs) thy
   5.232 -    handle Utils.ERR {mesg,...} => error mesg;
   5.233 -end;
   5.234 -
   5.235 -end;
     6.1 --- a/src/HOL/Tools/TFL/rules.ML	Fri Jun 19 18:41:21 2015 +0200
     6.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.3 @@ -1,789 +0,0 @@
     6.4 -(*  Title:      HOL/Tools/TFL/rules.ML
     6.5 -    Author:     Konrad Slind, Cambridge University Computer Laboratory
     6.6 -
     6.7 -Emulation of HOL inference rules for TFL.
     6.8 -*)
     6.9 -
    6.10 -signature RULES =
    6.11 -sig
    6.12 -  val dest_thm: thm -> term list * term
    6.13 -
    6.14 -  (* Inference rules *)
    6.15 -  val REFL: cterm -> thm
    6.16 -  val ASSUME: cterm -> thm
    6.17 -  val MP: thm -> thm -> thm
    6.18 -  val MATCH_MP: thm -> thm -> thm
    6.19 -  val CONJUNCT1: thm -> thm
    6.20 -  val CONJUNCT2: thm -> thm
    6.21 -  val CONJUNCTS: thm -> thm list
    6.22 -  val DISCH: cterm -> thm -> thm
    6.23 -  val UNDISCH: thm  -> thm
    6.24 -  val SPEC: cterm -> thm -> thm
    6.25 -  val ISPEC: cterm -> thm -> thm
    6.26 -  val ISPECL: cterm list -> thm -> thm
    6.27 -  val GEN: Proof.context -> cterm -> thm -> thm
    6.28 -  val GENL: Proof.context -> cterm list -> thm -> thm
    6.29 -  val LIST_CONJ: thm list -> thm
    6.30 -
    6.31 -  val SYM: thm -> thm
    6.32 -  val DISCH_ALL: thm -> thm
    6.33 -  val FILTER_DISCH_ALL: (term -> bool) -> thm -> thm
    6.34 -  val SPEC_ALL: thm -> thm
    6.35 -  val GEN_ALL: Proof.context -> thm -> thm
    6.36 -  val IMP_TRANS: thm -> thm -> thm
    6.37 -  val PROVE_HYP: thm -> thm -> thm
    6.38 -
    6.39 -  val CHOOSE: Proof.context -> cterm * thm -> thm -> thm
    6.40 -  val EXISTS: cterm * cterm -> thm -> thm
    6.41 -  val EXISTL: cterm list -> thm -> thm
    6.42 -  val IT_EXISTS: Proof.context -> (cterm * cterm) list -> thm -> thm
    6.43 -
    6.44 -  val EVEN_ORS: thm list -> thm list
    6.45 -  val DISJ_CASESL: thm -> thm list -> thm
    6.46 -
    6.47 -  val list_beta_conv: cterm -> cterm list -> thm
    6.48 -  val SUBS: Proof.context -> thm list -> thm -> thm
    6.49 -  val simpl_conv: Proof.context -> thm list -> cterm -> thm
    6.50 -
    6.51 -  val rbeta: thm -> thm
    6.52 -  val tracing: bool Unsynchronized.ref
    6.53 -  val CONTEXT_REWRITE_RULE: Proof.context ->
    6.54 -    term * term list * thm * thm list -> thm -> thm * term list
    6.55 -  val RIGHT_ASSOC: Proof.context -> thm -> thm
    6.56 -
    6.57 -  val prove: Proof.context -> bool -> term * tactic -> thm
    6.58 -end;
    6.59 -
    6.60 -structure Rules: RULES =
    6.61 -struct
    6.62 -
    6.63 -fun RULES_ERR func mesg = Utils.ERR {module = "Rules", func = func, mesg = mesg};
    6.64 -
    6.65 -
    6.66 -fun cconcl thm = Dcterm.drop_prop (#prop (Thm.crep_thm thm));
    6.67 -fun chyps thm = map Dcterm.drop_prop (#hyps (Thm.crep_thm thm));
    6.68 -
    6.69 -fun dest_thm thm =
    6.70 -  let val {prop,hyps,...} = Thm.rep_thm thm
    6.71 -  in (map HOLogic.dest_Trueprop hyps, HOLogic.dest_Trueprop prop) end
    6.72 -  handle TERM _ => raise RULES_ERR "dest_thm" "missing Trueprop";
    6.73 -
    6.74 -
    6.75 -(* Inference rules *)
    6.76 -
    6.77 -(*---------------------------------------------------------------------------
    6.78 - *        Equality (one step)
    6.79 - *---------------------------------------------------------------------------*)
    6.80 -
    6.81 -fun REFL tm = Thm.reflexive tm RS meta_eq_to_obj_eq
    6.82 -  handle THM (msg, _, _) => raise RULES_ERR "REFL" msg;
    6.83 -
    6.84 -fun SYM thm = thm RS sym
    6.85 -  handle THM (msg, _, _) => raise RULES_ERR "SYM" msg;
    6.86 -
    6.87 -fun ALPHA thm ctm1 =
    6.88 -  let
    6.89 -    val ctm2 = Thm.cprop_of thm;
    6.90 -    val ctm2_eq = Thm.reflexive ctm2;
    6.91 -    val ctm1_eq = Thm.reflexive ctm1;
    6.92 -  in Thm.equal_elim (Thm.transitive ctm2_eq ctm1_eq) thm end
    6.93 -  handle THM (msg, _, _) => raise RULES_ERR "ALPHA" msg;
    6.94 -
    6.95 -fun rbeta th =
    6.96 -  (case Dcterm.strip_comb (cconcl th) of
    6.97 -    (_, [l, r]) => Thm.transitive th (Thm.beta_conversion false r)
    6.98 -  | _ => raise RULES_ERR "rbeta" "");
    6.99 -
   6.100 -
   6.101 -(*----------------------------------------------------------------------------
   6.102 - *        Implication and the assumption list
   6.103 - *
   6.104 - * Assumptions get stuck on the meta-language assumption list. Implications
   6.105 - * are in the object language, so discharging an assumption "A" from theorem
   6.106 - * "B" results in something that looks like "A --> B".
   6.107 - *---------------------------------------------------------------------------*)
   6.108 -
   6.109 -fun ASSUME ctm = Thm.assume (Dcterm.mk_prop ctm);
   6.110 -
   6.111 -
   6.112 -(*---------------------------------------------------------------------------
   6.113 - * Implication in TFL is -->. Meta-language implication (==>) is only used
   6.114 - * in the implementation of some of the inference rules below.
   6.115 - *---------------------------------------------------------------------------*)
   6.116 -fun MP th1 th2 = th2 RS (th1 RS mp)
   6.117 -  handle THM (msg, _, _) => raise RULES_ERR "MP" msg;
   6.118 -
   6.119 -(*forces the first argument to be a proposition if necessary*)
   6.120 -fun DISCH tm thm = Thm.implies_intr (Dcterm.mk_prop tm) thm COMP impI
   6.121 -  handle THM (msg, _, _) => raise RULES_ERR "DISCH" msg;
   6.122 -
   6.123 -fun DISCH_ALL thm = fold_rev DISCH (#hyps (Thm.crep_thm thm)) thm;
   6.124 -
   6.125 -
   6.126 -fun FILTER_DISCH_ALL P thm =
   6.127 - let fun check tm = P (Thm.term_of tm)
   6.128 - in  fold_rev (fn tm => fn th => if check tm then DISCH tm th else th) (chyps thm) thm
   6.129 - end;
   6.130 -
   6.131 -fun UNDISCH thm =
   6.132 -   let val tm = Dcterm.mk_prop (#1 (Dcterm.dest_imp (cconcl thm)))
   6.133 -   in Thm.implies_elim (thm RS mp) (ASSUME tm) end
   6.134 -   handle Utils.ERR _ => raise RULES_ERR "UNDISCH" ""
   6.135 -     | THM _ => raise RULES_ERR "UNDISCH" "";
   6.136 -
   6.137 -fun PROVE_HYP ath bth = MP (DISCH (cconcl ath) bth) ath;
   6.138 -
   6.139 -fun IMP_TRANS th1 th2 = th2 RS (th1 RS Thms.imp_trans)
   6.140 -  handle THM (msg, _, _) => raise RULES_ERR "IMP_TRANS" msg;
   6.141 -
   6.142 -
   6.143 -(*----------------------------------------------------------------------------
   6.144 - *        Conjunction
   6.145 - *---------------------------------------------------------------------------*)
   6.146 -
   6.147 -fun CONJUNCT1 thm = thm RS conjunct1
   6.148 -  handle THM (msg, _, _) => raise RULES_ERR "CONJUNCT1" msg;
   6.149 -
   6.150 -fun CONJUNCT2 thm = thm RS conjunct2
   6.151 -  handle THM (msg, _, _) => raise RULES_ERR "CONJUNCT2" msg;
   6.152 -
   6.153 -fun CONJUNCTS th = CONJUNCTS (CONJUNCT1 th) @ CONJUNCTS (CONJUNCT2 th) handle Utils.ERR _ => [th];
   6.154 -
   6.155 -fun LIST_CONJ [] = raise RULES_ERR "LIST_CONJ" "empty list"
   6.156 -  | LIST_CONJ [th] = th
   6.157 -  | LIST_CONJ (th :: rst) = MP (MP (conjI COMP (impI RS impI)) th) (LIST_CONJ rst)
   6.158 -      handle THM (msg, _, _) => raise RULES_ERR "LIST_CONJ" msg;
   6.159 -
   6.160 -
   6.161 -(*----------------------------------------------------------------------------
   6.162 - *        Disjunction
   6.163 - *---------------------------------------------------------------------------*)
   6.164 -local
   6.165 -  val prop = Thm.prop_of disjI1
   6.166 -  val [P,Q] = Misc_Legacy.term_vars prop
   6.167 -  val disj1 = Thm.forall_intr (Thm.cterm_of @{context} Q) disjI1
   6.168 -in
   6.169 -fun DISJ1 thm tm = thm RS (Thm.forall_elim (Dcterm.drop_prop tm) disj1)
   6.170 -  handle THM (msg, _, _) => raise RULES_ERR "DISJ1" msg;
   6.171 -end;
   6.172 -
   6.173 -local
   6.174 -  val prop = Thm.prop_of disjI2
   6.175 -  val [P,Q] = Misc_Legacy.term_vars prop
   6.176 -  val disj2 = Thm.forall_intr (Thm.cterm_of @{context} P) disjI2
   6.177 -in
   6.178 -fun DISJ2 tm thm = thm RS (Thm.forall_elim (Dcterm.drop_prop tm) disj2)
   6.179 -  handle THM (msg, _, _) => raise RULES_ERR "DISJ2" msg;
   6.180 -end;
   6.181 -
   6.182 -
   6.183 -(*----------------------------------------------------------------------------
   6.184 - *
   6.185 - *                   A1 |- M1, ..., An |- Mn
   6.186 - *     ---------------------------------------------------
   6.187 - *     [A1 |- M1 \/ ... \/ Mn, ..., An |- M1 \/ ... \/ Mn]
   6.188 - *
   6.189 - *---------------------------------------------------------------------------*)
   6.190 -
   6.191 -
   6.192 -fun EVEN_ORS thms =
   6.193 -  let fun blue ldisjs [] _ = []
   6.194 -        | blue ldisjs (th::rst) rdisjs =
   6.195 -            let val tail = tl rdisjs
   6.196 -                val rdisj_tl = Dcterm.list_mk_disj tail
   6.197 -            in fold_rev DISJ2 ldisjs (DISJ1 th rdisj_tl)
   6.198 -               :: blue (ldisjs @ [cconcl th]) rst tail
   6.199 -            end handle Utils.ERR _ => [fold_rev DISJ2 ldisjs th]
   6.200 -   in blue [] thms (map cconcl thms) end;
   6.201 -
   6.202 -
   6.203 -(*----------------------------------------------------------------------------
   6.204 - *
   6.205 - *         A |- P \/ Q   B,P |- R    C,Q |- R
   6.206 - *     ---------------------------------------------------
   6.207 - *                     A U B U C |- R
   6.208 - *
   6.209 - *---------------------------------------------------------------------------*)
   6.210 -
   6.211 -fun DISJ_CASES th1 th2 th3 =
   6.212 -  let
   6.213 -    val c = Dcterm.drop_prop (cconcl th1);
   6.214 -    val (disj1, disj2) = Dcterm.dest_disj c;
   6.215 -    val th2' = DISCH disj1 th2;
   6.216 -    val th3' = DISCH disj2 th3;
   6.217 -  in
   6.218 -    th3' RS (th2' RS (th1 RS Thms.tfl_disjE))
   6.219 -      handle THM (msg, _, _) => raise RULES_ERR "DISJ_CASES" msg
   6.220 -  end;
   6.221 -
   6.222 -
   6.223 -(*-----------------------------------------------------------------------------
   6.224 - *
   6.225 - *       |- A1 \/ ... \/ An     [A1 |- M, ..., An |- M]
   6.226 - *     ---------------------------------------------------
   6.227 - *                           |- M
   6.228 - *
   6.229 - * Note. The list of theorems may be all jumbled up, so we have to
   6.230 - * first organize it to align with the first argument (the disjunctive
   6.231 - * theorem).
   6.232 - *---------------------------------------------------------------------------*)
   6.233 -
   6.234 -fun organize eq =    (* a bit slow - analogous to insertion sort *)
   6.235 - let fun extract a alist =
   6.236 -     let fun ex (_,[]) = raise RULES_ERR "organize" "not a permutation.1"
   6.237 -           | ex(left,h::t) = if (eq h a) then (h,rev left@t) else ex(h::left,t)
   6.238 -     in ex ([],alist)
   6.239 -     end
   6.240 -     fun place [] [] = []
   6.241 -       | place (a::rst) alist =
   6.242 -           let val (item,next) = extract a alist
   6.243 -           in item::place rst next
   6.244 -           end
   6.245 -       | place _ _ = raise RULES_ERR "organize" "not a permutation.2"
   6.246 - in place
   6.247 - end;
   6.248 -
   6.249 -fun DISJ_CASESL disjth thl =
   6.250 -   let val c = cconcl disjth
   6.251 -       fun eq th atm =
   6.252 -        exists (fn t => HOLogic.dest_Trueprop t aconv Thm.term_of atm) (Thm.hyps_of th)
   6.253 -       val tml = Dcterm.strip_disj c
   6.254 -       fun DL th [] = raise RULES_ERR "DISJ_CASESL" "no cases"
   6.255 -         | DL th [th1] = PROVE_HYP th th1
   6.256 -         | DL th [th1,th2] = DISJ_CASES th th1 th2
   6.257 -         | DL th (th1::rst) =
   6.258 -            let val tm = #2 (Dcterm.dest_disj (Dcterm.drop_prop(cconcl th)))
   6.259 -             in DISJ_CASES th th1 (DL (ASSUME tm) rst) end
   6.260 -   in DL disjth (organize eq tml thl)
   6.261 -   end;
   6.262 -
   6.263 -
   6.264 -(*----------------------------------------------------------------------------
   6.265 - *        Universals
   6.266 - *---------------------------------------------------------------------------*)
   6.267 -local (* this is fragile *)
   6.268 -  val prop = Thm.prop_of spec
   6.269 -  val x = hd (tl (Misc_Legacy.term_vars prop))
   6.270 -  val cTV = Thm.ctyp_of @{context} (type_of x)
   6.271 -  val gspec = Thm.forall_intr (Thm.cterm_of @{context} x) spec
   6.272 -in
   6.273 -fun SPEC tm thm =
   6.274 -   let val gspec' = Drule.instantiate_normalize ([(cTV, Thm.ctyp_of_cterm tm)], []) gspec
   6.275 -   in thm RS (Thm.forall_elim tm gspec') end
   6.276 -end;
   6.277 -
   6.278 -fun SPEC_ALL thm = fold SPEC (#1 (Dcterm.strip_forall(cconcl thm))) thm;
   6.279 -
   6.280 -val ISPEC = SPEC
   6.281 -val ISPECL = fold ISPEC;
   6.282 -
   6.283 -(* Not optimized! Too complicated. *)
   6.284 -local
   6.285 -  val prop = Thm.prop_of allI
   6.286 -  val [P] = Misc_Legacy.add_term_vars (prop, [])
   6.287 -  fun cty_theta ctxt = map (fn (i, (S, ty)) => apply2 (Thm.ctyp_of ctxt) (TVar (i, S), ty))
   6.288 -  fun ctm_theta ctxt =
   6.289 -    map (fn (i, (_, tm2)) =>
   6.290 -      let val ctm2 = Thm.cterm_of ctxt tm2
   6.291 -      in (Thm.cterm_of ctxt (Var (i, Thm.typ_of_cterm ctm2)), ctm2) end)
   6.292 -  fun certify ctxt (ty_theta,tm_theta) =
   6.293 -    (cty_theta ctxt (Vartab.dest ty_theta),
   6.294 -     ctm_theta ctxt (Vartab.dest tm_theta))
   6.295 -in
   6.296 -fun GEN ctxt v th =
   6.297 -   let val gth = Thm.forall_intr v th
   6.298 -       val thy = Proof_Context.theory_of ctxt
   6.299 -       val Const(@{const_name Pure.all},_)$Abs(x,ty,rst) = Thm.prop_of gth
   6.300 -       val P' = Abs(x,ty, HOLogic.dest_Trueprop rst)  (* get rid of trueprop *)
   6.301 -       val theta = Pattern.match thy (P,P') (Vartab.empty, Vartab.empty);
   6.302 -       val allI2 = Drule.instantiate_normalize (certify ctxt theta) allI
   6.303 -       val thm = Thm.implies_elim allI2 gth
   6.304 -       val tp $ (A $ Abs(_,_,M)) = Thm.prop_of thm
   6.305 -       val prop' = tp $ (A $ Abs(x,ty,M))
   6.306 -   in ALPHA thm (Thm.cterm_of ctxt prop') end
   6.307 -end;
   6.308 -
   6.309 -fun GENL ctxt = fold_rev (GEN ctxt);
   6.310 -
   6.311 -fun GEN_ALL ctxt thm =
   6.312 -  let
   6.313 -    val prop = Thm.prop_of thm
   6.314 -    val vlist = map (Thm.cterm_of ctxt) (Misc_Legacy.add_term_vars (prop, []))
   6.315 -  in GENL ctxt vlist thm end;
   6.316 -
   6.317 -
   6.318 -fun MATCH_MP th1 th2 =
   6.319 -   if (Dcterm.is_forall (Dcterm.drop_prop(cconcl th1)))
   6.320 -   then MATCH_MP (th1 RS spec) th2
   6.321 -   else MP th1 th2;
   6.322 -
   6.323 -
   6.324 -(*----------------------------------------------------------------------------
   6.325 - *        Existentials
   6.326 - *---------------------------------------------------------------------------*)
   6.327 -
   6.328 -
   6.329 -
   6.330 -(*---------------------------------------------------------------------------
   6.331 - * Existential elimination
   6.332 - *
   6.333 - *      A1 |- ?x.t[x]   ,   A2, "t[v]" |- t'
   6.334 - *      ------------------------------------     (variable v occurs nowhere)
   6.335 - *                A1 u A2 |- t'
   6.336 - *
   6.337 - *---------------------------------------------------------------------------*)
   6.338 -
   6.339 -fun CHOOSE ctxt (fvar, exth) fact =
   6.340 -  let
   6.341 -    val lam = #2 (Dcterm.dest_comb (Dcterm.drop_prop (cconcl exth)))
   6.342 -    val redex = Dcterm.capply lam fvar
   6.343 -    val t$u = Thm.term_of redex
   6.344 -    val residue = Thm.cterm_of ctxt (Term.betapply (t, u))
   6.345 -  in
   6.346 -    GEN ctxt fvar (DISCH residue fact) RS (exth RS Thms.choose_thm)
   6.347 -      handle THM (msg, _, _) => raise RULES_ERR "CHOOSE" msg
   6.348 -  end;
   6.349 -
   6.350 -local
   6.351 -  val prop = Thm.prop_of exI
   6.352 -  val [P, x] = map (Thm.cterm_of @{context}) (Misc_Legacy.term_vars prop)
   6.353 -in
   6.354 -fun EXISTS (template,witness) thm =
   6.355 -  let val abstr = #2 (Dcterm.dest_comb template) in
   6.356 -    thm RS (cterm_instantiate [(P, abstr), (x, witness)] exI)
   6.357 -      handle THM (msg, _, _) => raise RULES_ERR "EXISTS" msg
   6.358 -  end
   6.359 -end;
   6.360 -
   6.361 -(*----------------------------------------------------------------------------
   6.362 - *
   6.363 - *         A |- M
   6.364 - *   -------------------   [v_1,...,v_n]
   6.365 - *    A |- ?v1...v_n. M
   6.366 - *
   6.367 - *---------------------------------------------------------------------------*)
   6.368 -
   6.369 -fun EXISTL vlist th =
   6.370 -  fold_rev (fn v => fn thm => EXISTS(Dcterm.mk_exists(v,cconcl thm), v) thm)
   6.371 -           vlist th;
   6.372 -
   6.373 -
   6.374 -(*----------------------------------------------------------------------------
   6.375 - *
   6.376 - *       A |- M[x_1,...,x_n]
   6.377 - *   ----------------------------   [(x |-> y)_1,...,(x |-> y)_n]
   6.378 - *       A |- ?y_1...y_n. M
   6.379 - *
   6.380 - *---------------------------------------------------------------------------*)
   6.381 -(* Could be improved, but needs "subst_free" for certified terms *)
   6.382 -
   6.383 -fun IT_EXISTS ctxt blist th =
   6.384 -  let
   6.385 -    val blist' = map (apply2 Thm.term_of) blist
   6.386 -    fun ex v M = Thm.cterm_of ctxt (USyntax.mk_exists{Bvar=v,Body = M})
   6.387 -  in
   6.388 -    fold_rev (fn (b as (r1,r2)) => fn thm =>
   6.389 -        EXISTS(ex r2 (subst_free [b]
   6.390 -                   (HOLogic.dest_Trueprop(Thm.prop_of thm))), Thm.cterm_of ctxt r1)
   6.391 -              thm)
   6.392 -       blist' th
   6.393 -  end;
   6.394 -
   6.395 -(*---------------------------------------------------------------------------
   6.396 - *  Faster version, that fails for some as yet unknown reason
   6.397 - * fun IT_EXISTS blist th =
   6.398 - *    let val {thy,...} = rep_thm th
   6.399 - *        val tych = cterm_of thy
   6.400 - *        fun detype (x,y) = ((#t o rep_cterm) x, (#t o rep_cterm) y)
   6.401 - *   in
   6.402 - *  fold (fn (b as (r1,r2), thm) =>
   6.403 - *  EXISTS(D.mk_exists(r2, tych(subst_free[detype b](#t(rep_cterm(cconcl thm))))),
   6.404 - *           r1) thm)  blist th
   6.405 - *   end;
   6.406 - *---------------------------------------------------------------------------*)
   6.407 -
   6.408 -(*----------------------------------------------------------------------------
   6.409 - *        Rewriting
   6.410 - *---------------------------------------------------------------------------*)
   6.411 -
   6.412 -fun SUBS ctxt thl =
   6.413 -  rewrite_rule ctxt (map (fn th => th RS eq_reflection handle THM _ => th) thl);
   6.414 -
   6.415 -val rew_conv = Raw_Simplifier.rewrite_cterm (true, false, false) (K (K NONE));
   6.416 -
   6.417 -fun simpl_conv ctxt thl ctm =
   6.418 - rew_conv (ctxt addsimps thl) ctm RS meta_eq_to_obj_eq;
   6.419 -
   6.420 -
   6.421 -fun RIGHT_ASSOC ctxt = rewrite_rule ctxt [Thms.disj_assoc];
   6.422 -
   6.423 -
   6.424 -
   6.425 -(*---------------------------------------------------------------------------
   6.426 - *                  TERMINATION CONDITION EXTRACTION
   6.427 - *---------------------------------------------------------------------------*)
   6.428 -
   6.429 -
   6.430 -(* Object language quantifier, i.e., "!" *)
   6.431 -fun Forall v M = USyntax.mk_forall{Bvar=v, Body=M};
   6.432 -
   6.433 -
   6.434 -(* Fragile: it's a cong if it is not "R y x ==> cut f R x y = f y" *)
   6.435 -fun is_cong thm =
   6.436 -  case (Thm.prop_of thm) of
   6.437 -    (Const(@{const_name Pure.imp},_)$(Const(@{const_name Trueprop},_)$ _) $
   6.438 -      (Const(@{const_name Pure.eq},_) $ (Const (@{const_name Wfrec.cut},_) $ f $ R $ a $ x) $ _)) =>
   6.439 -        false
   6.440 -  | _ => true;
   6.441 -
   6.442 -
   6.443 -fun dest_equal(Const (@{const_name Pure.eq},_) $
   6.444 -               (Const (@{const_name Trueprop},_) $ lhs)
   6.445 -               $ (Const (@{const_name Trueprop},_) $ rhs)) = {lhs=lhs, rhs=rhs}
   6.446 -  | dest_equal(Const (@{const_name Pure.eq},_) $ lhs $ rhs) = {lhs=lhs, rhs=rhs}
   6.447 -  | dest_equal tm = USyntax.dest_eq tm;
   6.448 -
   6.449 -fun get_lhs tm = #lhs(dest_equal (HOLogic.dest_Trueprop tm));
   6.450 -
   6.451 -fun dest_all used (Const(@{const_name Pure.all},_) $ (a as Abs _)) = USyntax.dest_abs used a
   6.452 -  | dest_all _ _ = raise RULES_ERR "dest_all" "not a !!";
   6.453 -
   6.454 -val is_all = can (dest_all []);
   6.455 -
   6.456 -fun strip_all used fm =
   6.457 -   if (is_all fm)
   6.458 -   then let val ({Bvar, Body}, used') = dest_all used fm
   6.459 -            val (bvs, core, used'') = strip_all used' Body
   6.460 -        in ((Bvar::bvs), core, used'')
   6.461 -        end
   6.462 -   else ([], fm, used);
   6.463 -
   6.464 -fun break_all(Const(@{const_name Pure.all},_) $ Abs (_,_,body)) = body
   6.465 -  | break_all _ = raise RULES_ERR "break_all" "not a !!";
   6.466 -
   6.467 -fun list_break_all(Const(@{const_name Pure.all},_) $ Abs (s,ty,body)) =
   6.468 -     let val (L,core) = list_break_all body
   6.469 -     in ((s,ty)::L, core)
   6.470 -     end
   6.471 -  | list_break_all tm = ([],tm);
   6.472 -
   6.473 -(*---------------------------------------------------------------------------
   6.474 - * Rename a term of the form
   6.475 - *
   6.476 - *      !!x1 ...xn. x1=M1 ==> ... ==> xn=Mn
   6.477 - *                  ==> ((%v1...vn. Q) x1 ... xn = g x1 ... xn.
   6.478 - * to one of
   6.479 - *
   6.480 - *      !!v1 ... vn. v1=M1 ==> ... ==> vn=Mn
   6.481 - *      ==> ((%v1...vn. Q) v1 ... vn = g v1 ... vn.
   6.482 - *
   6.483 - * This prevents name problems in extraction, and helps the result to read
   6.484 - * better. There is a problem with varstructs, since they can introduce more
   6.485 - * than n variables, and some extra reasoning needs to be done.
   6.486 - *---------------------------------------------------------------------------*)
   6.487 -
   6.488 -fun get ([],_,L) = rev L
   6.489 -  | get (ant::rst,n,L) =
   6.490 -      case (list_break_all ant)
   6.491 -        of ([],_) => get (rst, n+1,L)
   6.492 -         | (vlist,body) =>
   6.493 -            let val eq = Logic.strip_imp_concl body
   6.494 -                val (f,args) = USyntax.strip_comb (get_lhs eq)
   6.495 -                val (vstrl,_) = USyntax.strip_abs f
   6.496 -                val names  =
   6.497 -                  Name.variant_list (Misc_Legacy.add_term_names(body, [])) (map (#1 o dest_Free) vstrl)
   6.498 -            in get (rst, n+1, (names,n)::L) end
   6.499 -            handle TERM _ => get (rst, n+1, L)
   6.500 -              | Utils.ERR _ => get (rst, n+1, L);
   6.501 -
   6.502 -(* Note: Thm.rename_params_rule counts from 1, not 0 *)
   6.503 -fun rename thm =
   6.504 -  let
   6.505 -    val ants = Logic.strip_imp_prems (Thm.prop_of thm)
   6.506 -    val news = get (ants,1,[])
   6.507 -  in fold Thm.rename_params_rule news thm end;
   6.508 -
   6.509 -
   6.510 -(*---------------------------------------------------------------------------
   6.511 - * Beta-conversion to the rhs of an equation (taken from hol90/drule.sml)
   6.512 - *---------------------------------------------------------------------------*)
   6.513 -
   6.514 -fun list_beta_conv tm =
   6.515 -  let fun rbeta th = Thm.transitive th (Thm.beta_conversion false (#2(Dcterm.dest_eq(cconcl th))))
   6.516 -      fun iter [] = Thm.reflexive tm
   6.517 -        | iter (v::rst) = rbeta (Thm.combination(iter rst) (Thm.reflexive v))
   6.518 -  in iter  end;
   6.519 -
   6.520 -
   6.521 -(*---------------------------------------------------------------------------
   6.522 - * Trace information for the rewriter
   6.523 - *---------------------------------------------------------------------------*)
   6.524 -val tracing = Unsynchronized.ref false;
   6.525 -
   6.526 -fun say s = if !tracing then writeln s else ();
   6.527 -
   6.528 -fun print_thms ctxt s L =
   6.529 -  say (cat_lines (s :: map (Display.string_of_thm ctxt) L));
   6.530 -
   6.531 -fun print_term ctxt s t =
   6.532 -  say (cat_lines [s, Syntax.string_of_term ctxt t]);
   6.533 -
   6.534 -
   6.535 -(*---------------------------------------------------------------------------
   6.536 - * General abstraction handlers, should probably go in USyntax.
   6.537 - *---------------------------------------------------------------------------*)
   6.538 -fun mk_aabs (vstr, body) =
   6.539 -  USyntax.mk_abs {Bvar = vstr, Body = body}
   6.540 -  handle Utils.ERR _ => USyntax.mk_pabs {varstruct = vstr, body = body};
   6.541 -
   6.542 -fun list_mk_aabs (vstrl,tm) =
   6.543 -    fold_rev (fn vstr => fn tm => mk_aabs(vstr,tm)) vstrl tm;
   6.544 -
   6.545 -fun dest_aabs used tm =
   6.546 -   let val ({Bvar,Body}, used') = USyntax.dest_abs used tm
   6.547 -   in (Bvar, Body, used') end
   6.548 -   handle Utils.ERR _ =>
   6.549 -     let val {varstruct, body, used} = USyntax.dest_pabs used tm
   6.550 -     in (varstruct, body, used) end;
   6.551 -
   6.552 -fun strip_aabs used tm =
   6.553 -   let val (vstr, body, used') = dest_aabs used tm
   6.554 -       val (bvs, core, used'') = strip_aabs used' body
   6.555 -   in (vstr::bvs, core, used'') end
   6.556 -   handle Utils.ERR _ => ([], tm, used);
   6.557 -
   6.558 -fun dest_combn tm 0 = (tm,[])
   6.559 -  | dest_combn tm n =
   6.560 -     let val {Rator,Rand} = USyntax.dest_comb tm
   6.561 -         val (f,rands) = dest_combn Rator (n-1)
   6.562 -     in (f,Rand::rands)
   6.563 -     end;
   6.564 -
   6.565 -
   6.566 -
   6.567 -
   6.568 -local fun dest_pair M = let val {fst,snd} = USyntax.dest_pair M in (fst,snd) end
   6.569 -      fun mk_fst tm =
   6.570 -          let val ty as Type(@{type_name Product_Type.prod}, [fty,sty]) = type_of tm
   6.571 -          in  Const (@{const_name Product_Type.fst}, ty --> fty) $ tm  end
   6.572 -      fun mk_snd tm =
   6.573 -          let val ty as Type(@{type_name Product_Type.prod}, [fty,sty]) = type_of tm
   6.574 -          in  Const (@{const_name Product_Type.snd}, ty --> sty) $ tm  end
   6.575 -in
   6.576 -fun XFILL tych x vstruct =
   6.577 -  let fun traverse p xocc L =
   6.578 -        if (is_Free p)
   6.579 -        then tych xocc::L
   6.580 -        else let val (p1,p2) = dest_pair p
   6.581 -             in traverse p1 (mk_fst xocc) (traverse p2  (mk_snd xocc) L)
   6.582 -             end
   6.583 -  in
   6.584 -  traverse vstruct x []
   6.585 -end end;
   6.586 -
   6.587 -(*---------------------------------------------------------------------------
   6.588 - * Replace a free tuple (vstr) by a universally quantified variable (a).
   6.589 - * Note that the notion of "freeness" for a tuple is different than for a
   6.590 - * variable: if variables in the tuple also occur in any other place than
   6.591 - * an occurrences of the tuple, they aren't "free" (which is thus probably
   6.592 - *  the wrong word to use).
   6.593 - *---------------------------------------------------------------------------*)
   6.594 -
   6.595 -fun VSTRUCT_ELIM ctxt tych a vstr th =
   6.596 -  let val L = USyntax.free_vars_lr vstr
   6.597 -      val bind1 = tych (HOLogic.mk_Trueprop (HOLogic.mk_eq(a,vstr)))
   6.598 -      val thm1 = Thm.implies_intr bind1 (SUBS ctxt [SYM(Thm.assume bind1)] th)
   6.599 -      val thm2 = forall_intr_list (map tych L) thm1
   6.600 -      val thm3 = forall_elim_list (XFILL tych a vstr) thm2
   6.601 -  in refl RS
   6.602 -     rewrite_rule ctxt [Thm.symmetric (@{thm surjective_pairing} RS eq_reflection)] thm3
   6.603 -  end;
   6.604 -
   6.605 -fun PGEN ctxt tych a vstr th =
   6.606 -  let val a1 = tych a
   6.607 -      val vstr1 = tych vstr
   6.608 -  in
   6.609 -  Thm.forall_intr a1
   6.610 -     (if (is_Free vstr)
   6.611 -      then cterm_instantiate [(vstr1,a1)] th
   6.612 -      else VSTRUCT_ELIM ctxt tych a vstr th)
   6.613 -  end;
   6.614 -
   6.615 -
   6.616 -(*---------------------------------------------------------------------------
   6.617 - * Takes apart a paired beta-redex, looking like "(\(x,y).N) vstr", into
   6.618 - *
   6.619 - *     (([x,y],N),vstr)
   6.620 - *---------------------------------------------------------------------------*)
   6.621 -fun dest_pbeta_redex used M n =
   6.622 -  let val (f,args) = dest_combn M n
   6.623 -      val dummy = dest_aabs used f
   6.624 -  in (strip_aabs used f,args)
   6.625 -  end;
   6.626 -
   6.627 -fun pbeta_redex M n = can (fn t => dest_pbeta_redex [] t n) M;
   6.628 -
   6.629 -fun dest_impl tm =
   6.630 -  let val ants = Logic.strip_imp_prems tm
   6.631 -      val eq = Logic.strip_imp_concl tm
   6.632 -  in (ants,get_lhs eq)
   6.633 -  end;
   6.634 -
   6.635 -fun restricted t = is_some (USyntax.find_term
   6.636 -                            (fn (Const(@{const_name Wfrec.cut},_)) =>true | _ => false)
   6.637 -                            t)
   6.638 -
   6.639 -fun CONTEXT_REWRITE_RULE main_ctxt (func, G, cut_lemma, congs) th =
   6.640 - let val globals = func::G
   6.641 -     val ctxt0 = empty_simpset main_ctxt
   6.642 -     val pbeta_reduce = simpl_conv ctxt0 [@{thm split_conv} RS eq_reflection];
   6.643 -     val tc_list = Unsynchronized.ref []: term list Unsynchronized.ref
   6.644 -     val cut_lemma' = cut_lemma RS eq_reflection
   6.645 -     fun prover used ctxt thm =
   6.646 -     let fun cong_prover ctxt thm =
   6.647 -         let val dummy = say "cong_prover:"
   6.648 -             val cntxt = Simplifier.prems_of ctxt
   6.649 -             val dummy = print_thms ctxt "cntxt:" cntxt
   6.650 -             val dummy = say "cong rule:"
   6.651 -             val dummy = say (Display.string_of_thm ctxt thm)
   6.652 -             (* Unquantified eliminate *)
   6.653 -             fun uq_eliminate (thm,imp) =
   6.654 -                 let val tych = Thm.cterm_of ctxt
   6.655 -                     val _ = print_term ctxt "To eliminate:" imp
   6.656 -                     val ants = map tych (Logic.strip_imp_prems imp)
   6.657 -                     val eq = Logic.strip_imp_concl imp
   6.658 -                     val lhs = tych(get_lhs eq)
   6.659 -                     val ctxt' = Simplifier.add_prems (map ASSUME ants) ctxt
   6.660 -                     val lhs_eq_lhs1 = Raw_Simplifier.rewrite_cterm (false,true,false) (prover used) ctxt' lhs
   6.661 -                       handle Utils.ERR _ => Thm.reflexive lhs
   6.662 -                     val _ = print_thms ctxt' "proven:" [lhs_eq_lhs1]
   6.663 -                     val lhs_eq_lhs2 = implies_intr_list ants lhs_eq_lhs1
   6.664 -                     val lhs_eeq_lhs2 = lhs_eq_lhs2 RS meta_eq_to_obj_eq
   6.665 -                  in
   6.666 -                  lhs_eeq_lhs2 COMP thm
   6.667 -                  end
   6.668 -             fun pq_eliminate (thm, vlist, imp_body, lhs_eq) =
   6.669 -              let val ((vstrl, _, used'), args) = dest_pbeta_redex used lhs_eq (length vlist)
   6.670 -                  val dummy = forall (op aconv) (ListPair.zip (vlist, args))
   6.671 -                    orelse error "assertion failed in CONTEXT_REWRITE_RULE"
   6.672 -                  val imp_body1 = subst_free (ListPair.zip (args, vstrl))
   6.673 -                                             imp_body
   6.674 -                  val tych = Thm.cterm_of ctxt
   6.675 -                  val ants1 = map tych (Logic.strip_imp_prems imp_body1)
   6.676 -                  val eq1 = Logic.strip_imp_concl imp_body1
   6.677 -                  val Q = get_lhs eq1
   6.678 -                  val QeqQ1 = pbeta_reduce (tych Q)
   6.679 -                  val Q1 = #2(Dcterm.dest_eq(cconcl QeqQ1))
   6.680 -                  val ctxt' = Simplifier.add_prems (map ASSUME ants1) ctxt
   6.681 -                  val Q1eeqQ2 = Raw_Simplifier.rewrite_cterm (false,true,false) (prover used') ctxt' Q1
   6.682 -                                handle Utils.ERR _ => Thm.reflexive Q1
   6.683 -                  val Q2 = #2 (Logic.dest_equals (Thm.prop_of Q1eeqQ2))
   6.684 -                  val Q3 = tych(list_comb(list_mk_aabs(vstrl,Q2),vstrl))
   6.685 -                  val Q2eeqQ3 = Thm.symmetric(pbeta_reduce Q3 RS eq_reflection)
   6.686 -                  val thA = Thm.transitive(QeqQ1 RS eq_reflection) Q1eeqQ2
   6.687 -                  val QeeqQ3 = Thm.transitive thA Q2eeqQ3 handle THM _ =>
   6.688 -                               ((Q2eeqQ3 RS meta_eq_to_obj_eq)
   6.689 -                                RS ((thA RS meta_eq_to_obj_eq) RS trans))
   6.690 -                                RS eq_reflection
   6.691 -                  val impth = implies_intr_list ants1 QeeqQ3
   6.692 -                  val impth1 = impth RS meta_eq_to_obj_eq
   6.693 -                  (* Need to abstract *)
   6.694 -                  val ant_th = Utils.itlist2 (PGEN ctxt' tych) args vstrl impth1
   6.695 -              in ant_th COMP thm
   6.696 -              end
   6.697 -             fun q_eliminate (thm, imp) =
   6.698 -              let val (vlist, imp_body, used') = strip_all used imp
   6.699 -                  val (ants,Q) = dest_impl imp_body
   6.700 -              in if (pbeta_redex Q) (length vlist)
   6.701 -                 then pq_eliminate (thm, vlist, imp_body, Q)
   6.702 -                 else
   6.703 -                 let val tych = Thm.cterm_of ctxt
   6.704 -                     val ants1 = map tych ants
   6.705 -                     val ctxt' = Simplifier.add_prems (map ASSUME ants1) ctxt
   6.706 -                     val Q_eeq_Q1 = Raw_Simplifier.rewrite_cterm
   6.707 -                        (false,true,false) (prover used') ctxt' (tych Q)
   6.708 -                      handle Utils.ERR _ => Thm.reflexive (tych Q)
   6.709 -                     val lhs_eeq_lhs2 = implies_intr_list ants1 Q_eeq_Q1
   6.710 -                     val lhs_eq_lhs2 = lhs_eeq_lhs2 RS meta_eq_to_obj_eq
   6.711 -                     val ant_th = forall_intr_list(map tych vlist)lhs_eq_lhs2
   6.712 -                 in
   6.713 -                 ant_th COMP thm
   6.714 -              end end
   6.715 -
   6.716 -             fun eliminate thm =
   6.717 -               case Thm.prop_of thm of
   6.718 -                 Const(@{const_name Pure.imp},_) $ imp $ _ =>
   6.719 -                   eliminate
   6.720 -                    (if not(is_all imp)
   6.721 -                     then uq_eliminate (thm, imp)
   6.722 -                     else q_eliminate (thm, imp))
   6.723 -                            (* Assume that the leading constant is ==,   *)
   6.724 -                | _ => thm  (* if it is not a ==>                        *)
   6.725 -         in SOME(eliminate (rename thm)) end
   6.726 -         handle Utils.ERR _ => NONE    (* FIXME handle THM as well?? *)
   6.727 -
   6.728 -        fun restrict_prover ctxt thm =
   6.729 -          let val _ = say "restrict_prover:"
   6.730 -              val cntxt = rev (Simplifier.prems_of ctxt)
   6.731 -              val _ = print_thms ctxt "cntxt:" cntxt
   6.732 -              val Const(@{const_name Pure.imp},_) $ (Const(@{const_name Trueprop},_) $ A) $ _ =
   6.733 -                Thm.prop_of thm
   6.734 -              fun genl tm = let val vlist = subtract (op aconv) globals
   6.735 -                                           (Misc_Legacy.add_term_frees(tm,[]))
   6.736 -                            in fold_rev Forall vlist tm
   6.737 -                            end
   6.738 -              (*--------------------------------------------------------------
   6.739 -               * This actually isn't quite right, since it will think that
   6.740 -               * not-fully applied occs. of "f" in the context mean that the
   6.741 -               * current call is nested. The real solution is to pass in a
   6.742 -               * term "f v1..vn" which is a pattern that any full application
   6.743 -               * of "f" will match.
   6.744 -               *-------------------------------------------------------------*)
   6.745 -              val func_name = #1(dest_Const func)
   6.746 -              fun is_func (Const (name,_)) = (name = func_name)
   6.747 -                | is_func _                = false
   6.748 -              val rcontext = rev cntxt
   6.749 -              val cncl = HOLogic.dest_Trueprop o Thm.prop_of
   6.750 -              val antl = case rcontext of [] => []
   6.751 -                         | _   => [USyntax.list_mk_conj(map cncl rcontext)]
   6.752 -              val TC = genl(USyntax.list_mk_imp(antl, A))
   6.753 -              val _ = print_term ctxt "func:" func
   6.754 -              val _ = print_term ctxt "TC:" (HOLogic.mk_Trueprop TC)
   6.755 -              val _ = tc_list := (TC :: !tc_list)
   6.756 -              val nestedp = is_some (USyntax.find_term is_func TC)
   6.757 -              val _ = if nestedp then say "nested" else say "not_nested"
   6.758 -              val th' = if nestedp then raise RULES_ERR "solver" "nested function"
   6.759 -                        else let val cTC = Thm.cterm_of ctxt (HOLogic.mk_Trueprop TC)
   6.760 -                             in case rcontext of
   6.761 -                                [] => SPEC_ALL(ASSUME cTC)
   6.762 -                               | _ => MP (SPEC_ALL (ASSUME cTC))
   6.763 -                                         (LIST_CONJ rcontext)
   6.764 -                             end
   6.765 -              val th'' = th' RS thm
   6.766 -          in SOME (th'')
   6.767 -          end handle Utils.ERR _ => NONE    (* FIXME handle THM as well?? *)
   6.768 -    in
   6.769 -    (if (is_cong thm) then cong_prover else restrict_prover) ctxt thm
   6.770 -    end
   6.771 -    val ctm = Thm.cprop_of th
   6.772 -    val names = Misc_Legacy.add_term_names (Thm.term_of ctm, [])
   6.773 -    val th1 =
   6.774 -      Raw_Simplifier.rewrite_cterm (false, true, false)
   6.775 -        (prover names) (ctxt0 addsimps [cut_lemma'] |> fold Simplifier.add_eqcong congs) ctm
   6.776 -    val th2 = Thm.equal_elim th1 th
   6.777 - in
   6.778 - (th2, filter_out restricted (!tc_list))
   6.779 - end;
   6.780 -
   6.781 -
   6.782 -fun prove ctxt strict (t, tac) =
   6.783 -  let
   6.784 -    val ctxt' = Variable.auto_fixes t ctxt;
   6.785 -  in
   6.786 -    if strict
   6.787 -    then Goal.prove ctxt' [] [] t (K tac)
   6.788 -    else Goal.prove ctxt' [] [] t (K tac)
   6.789 -      handle ERROR msg => (warning msg; raise RULES_ERR "prove" msg)
   6.790 -  end;
   6.791 -
   6.792 -end;
     7.1 --- a/src/HOL/Tools/TFL/tfl.ML	Fri Jun 19 18:41:21 2015 +0200
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,1003 +0,0 @@
     7.4 -(*  Title:      HOL/Tools/TFL/tfl.ML
     7.5 -    Author:     Konrad Slind, Cambridge University Computer Laboratory
     7.6 -
     7.7 -First part of main module.
     7.8 -*)
     7.9 -
    7.10 -signature PRIM =
    7.11 -sig
    7.12 -  val trace: bool Unsynchronized.ref
    7.13 -  val trace_thms: Proof.context -> string -> thm list -> unit
    7.14 -  val trace_cterm: Proof.context -> string -> cterm -> unit
    7.15 -  type pattern
    7.16 -  val mk_functional: theory -> term list -> {functional: term, pats: pattern list}
    7.17 -  val wfrec_definition0: string -> term -> term -> theory -> thm * theory
    7.18 -  val post_definition: Proof.context -> thm list -> thm * pattern list ->
    7.19 -   {rules: thm,
    7.20 -    rows: int list,
    7.21 -    TCs: term list list,
    7.22 -    full_pats_TCs: (term * term list) list}
    7.23 -  val wfrec_eqns: theory -> xstring -> thm list -> term list ->
    7.24 -   {WFR: term,
    7.25 -    SV: term list,
    7.26 -    proto_def: term,
    7.27 -    extracta: (thm * term list) list,
    7.28 -    pats: pattern list}
    7.29 -  val lazyR_def: theory -> xstring -> thm list -> term list ->
    7.30 -   {theory: theory,
    7.31 -    rules: thm,
    7.32 -    R: term,
    7.33 -    SV: term list,
    7.34 -    full_pats_TCs: (term * term list) list,
    7.35 -    patterns : pattern list}
    7.36 -  val mk_induction: theory ->
    7.37 -    {fconst: term, R: term, SV: term list, pat_TCs_list: (term * term list) list} -> thm
    7.38 -  val postprocess: Proof.context -> bool ->
    7.39 -    {wf_tac: tactic, terminator: tactic, simplifier: cterm -> thm} ->
    7.40 -    {rules: thm, induction: thm, TCs: term list list} ->
    7.41 -    {rules: thm, induction: thm, nested_tcs: thm list}
    7.42 -end;
    7.43 -
    7.44 -structure Prim: PRIM =
    7.45 -struct
    7.46 -
    7.47 -val trace = Unsynchronized.ref false;
    7.48 -
    7.49 -
    7.50 -fun TFL_ERR func mesg = Utils.ERR {module = "Tfl", func = func, mesg = mesg};
    7.51 -
    7.52 -val concl = #2 o Rules.dest_thm;
    7.53 -val hyp = #1 o Rules.dest_thm;
    7.54 -
    7.55 -val list_mk_type = Utils.end_itlist (curry (op -->));
    7.56 -
    7.57 -fun front_last [] = raise TFL_ERR "front_last" "empty list"
    7.58 -  | front_last [x] = ([],x)
    7.59 -  | front_last (h::t) =
    7.60 -     let val (pref,x) = front_last t
    7.61 -     in
    7.62 -        (h::pref,x)
    7.63 -     end;
    7.64 -
    7.65 -
    7.66 -(*---------------------------------------------------------------------------
    7.67 - * The next function is common to pattern-match translation and
    7.68 - * proof of completeness of cases for the induction theorem.
    7.69 - *
    7.70 - * The curried function "gvvariant" returns a function to generate distinct
    7.71 - * variables that are guaranteed not to be in names.  The names of
    7.72 - * the variables go u, v, ..., z, aa, ..., az, ...  The returned
    7.73 - * function contains embedded refs!
    7.74 - *---------------------------------------------------------------------------*)
    7.75 -fun gvvariant names =
    7.76 -  let val slist = Unsynchronized.ref names
    7.77 -      val vname = Unsynchronized.ref "u"
    7.78 -      fun new() =
    7.79 -         if member (op =) (!slist) (!vname)
    7.80 -         then (vname := Symbol.bump_string (!vname);  new())
    7.81 -         else (slist := !vname :: !slist;  !vname)
    7.82 -  in
    7.83 -  fn ty => Free(new(), ty)
    7.84 -  end;
    7.85 -
    7.86 -
    7.87 -(*---------------------------------------------------------------------------
    7.88 - * Used in induction theorem production. This is the simple case of
    7.89 - * partitioning up pattern rows by the leading constructor.
    7.90 - *---------------------------------------------------------------------------*)
    7.91 -fun ipartition gv (constructors,rows) =
    7.92 -  let fun pfail s = raise TFL_ERR "partition.part" s
    7.93 -      fun part {constrs = [],   rows = [],   A} = rev A
    7.94 -        | part {constrs = [],   rows = _::_, A} = pfail"extra cases in defn"
    7.95 -        | part {constrs = _::_, rows = [],   A} = pfail"cases missing in defn"
    7.96 -        | part {constrs = c::crst, rows,     A} =
    7.97 -          let val (c, T) = dest_Const c
    7.98 -              val L = binder_types T
    7.99 -              val (in_group, not_in_group) =
   7.100 -               fold_rev (fn (row as (p::rst, rhs)) =>
   7.101 -                         fn (in_group,not_in_group) =>
   7.102 -                  let val (pc,args) = USyntax.strip_comb p
   7.103 -                  in if (#1(dest_Const pc) = c)
   7.104 -                     then ((args@rst, rhs)::in_group, not_in_group)
   7.105 -                     else (in_group, row::not_in_group)
   7.106 -                  end)      rows ([],[])
   7.107 -              val col_types = Utils.take type_of (length L, #1(hd in_group))
   7.108 -          in
   7.109 -          part{constrs = crst, rows = not_in_group,
   7.110 -               A = {constructor = c,
   7.111 -                    new_formals = map gv col_types,
   7.112 -                    group = in_group}::A}
   7.113 -          end
   7.114 -  in part{constrs = constructors, rows = rows, A = []}
   7.115 -  end;
   7.116 -
   7.117 -
   7.118 -
   7.119 -(*---------------------------------------------------------------------------
   7.120 - * Each pattern carries with it a tag (i,b) where
   7.121 - * i is the clause it came from and
   7.122 - * b=true indicates that clause was given by the user
   7.123 - * (or is an instantiation of a user supplied pattern)
   7.124 - * b=false --> i = ~1
   7.125 - *---------------------------------------------------------------------------*)
   7.126 -
   7.127 -type pattern = term * (int * bool)
   7.128 -
   7.129 -fun pattern_map f (tm,x) = (f tm, x);
   7.130 -
   7.131 -fun pattern_subst theta = pattern_map (subst_free theta);
   7.132 -
   7.133 -val pat_of = fst;
   7.134 -fun row_of_pat x = fst (snd x);
   7.135 -fun given x = snd (snd x);
   7.136 -
   7.137 -(*---------------------------------------------------------------------------
   7.138 - * Produce an instance of a constructor, plus genvars for its arguments.
   7.139 - *---------------------------------------------------------------------------*)
   7.140 -fun fresh_constr ty_match colty gv c =
   7.141 -  let val (_,Ty) = dest_Const c
   7.142 -      val L = binder_types Ty
   7.143 -      and ty = body_type Ty
   7.144 -      val ty_theta = ty_match ty colty
   7.145 -      val c' = USyntax.inst ty_theta c
   7.146 -      val gvars = map (USyntax.inst ty_theta o gv) L
   7.147 -  in (c', gvars)
   7.148 -  end;
   7.149 -
   7.150 -
   7.151 -(*---------------------------------------------------------------------------
   7.152 - * Goes through a list of rows and picks out the ones beginning with a
   7.153 - * pattern with constructor = name.
   7.154 - *---------------------------------------------------------------------------*)
   7.155 -fun mk_group name rows =
   7.156 -  fold_rev (fn (row as ((prfx, p::rst), rhs)) =>
   7.157 -            fn (in_group,not_in_group) =>
   7.158 -               let val (pc,args) = USyntax.strip_comb p
   7.159 -               in if ((#1 (Term.dest_Const pc) = name) handle TERM _ => false)
   7.160 -                  then (((prfx,args@rst), rhs)::in_group, not_in_group)
   7.161 -                  else (in_group, row::not_in_group) end)
   7.162 -      rows ([],[]);
   7.163 -
   7.164 -(*---------------------------------------------------------------------------
   7.165 - * Partition the rows. Not efficient: we should use hashing.
   7.166 - *---------------------------------------------------------------------------*)
   7.167 -fun partition _ _ (_,_,_,[]) = raise TFL_ERR "partition" "no rows"
   7.168 -  | partition gv ty_match
   7.169 -              (constructors, colty, res_ty, rows as (((prfx,_),_)::_)) =
   7.170 -let val fresh = fresh_constr ty_match colty gv
   7.171 -     fun part {constrs = [],      rows, A} = rev A
   7.172 -       | part {constrs = c::crst, rows, A} =
   7.173 -         let val (c',gvars) = fresh c
   7.174 -             val (in_group, not_in_group) = mk_group (#1 (dest_Const c')) rows
   7.175 -             val in_group' =
   7.176 -                 if (null in_group)  (* Constructor not given *)
   7.177 -                 then [((prfx, #2(fresh c)), (USyntax.ARB res_ty, (~1,false)))]
   7.178 -                 else in_group
   7.179 -         in
   7.180 -         part{constrs = crst,
   7.181 -              rows = not_in_group,
   7.182 -              A = {constructor = c',
   7.183 -                   new_formals = gvars,
   7.184 -                   group = in_group'}::A}
   7.185 -         end
   7.186 -in part{constrs=constructors, rows=rows, A=[]}
   7.187 -end;
   7.188 -
   7.189 -(*---------------------------------------------------------------------------
   7.190 - * Misc. routines used in mk_case
   7.191 - *---------------------------------------------------------------------------*)
   7.192 -
   7.193 -fun mk_pat (c,l) =
   7.194 -  let val L = length (binder_types (type_of c))
   7.195 -      fun build (prfx,tag,plist) =
   7.196 -          let val (args, plist') = chop L plist
   7.197 -          in (prfx,tag,list_comb(c,args)::plist') end
   7.198 -  in map build l end;
   7.199 -
   7.200 -fun v_to_prfx (prfx, v::pats) = (v::prfx,pats)
   7.201 -  | v_to_prfx _ = raise TFL_ERR "mk_case" "v_to_prfx";
   7.202 -
   7.203 -fun v_to_pats (v::prfx,tag, pats) = (prfx, tag, v::pats)
   7.204 -  | v_to_pats _ = raise TFL_ERR "mk_case" "v_to_pats";
   7.205 -
   7.206 -
   7.207 -(*----------------------------------------------------------------------------
   7.208 - * Translation of pattern terms into nested case expressions.
   7.209 - *
   7.210 - * This performs the translation and also builds the full set of patterns.
   7.211 - * Thus it supports the construction of induction theorems even when an
   7.212 - * incomplete set of patterns is given.
   7.213 - *---------------------------------------------------------------------------*)
   7.214 -
   7.215 -fun mk_case ty_info ty_match usednames range_ty =
   7.216 - let
   7.217 - fun mk_case_fail s = raise TFL_ERR "mk_case" s
   7.218 - val fresh_var = gvvariant usednames
   7.219 - val divide = partition fresh_var ty_match
   7.220 - fun expand constructors ty ((_,[]), _) = mk_case_fail"expand_var_row"
   7.221 -   | expand constructors ty (row as ((prfx, p::rst), rhs)) =
   7.222 -       if (is_Free p)
   7.223 -       then let val fresh = fresh_constr ty_match ty fresh_var
   7.224 -                fun expnd (c,gvs) =
   7.225 -                  let val capp = list_comb(c,gvs)
   7.226 -                  in ((prfx, capp::rst), pattern_subst[(p,capp)] rhs)
   7.227 -                  end
   7.228 -            in map expnd (map fresh constructors)  end
   7.229 -       else [row]
   7.230 - fun mk{rows=[],...} = mk_case_fail"no rows"
   7.231 -   | mk{path=[], rows = ((prfx, []), (tm,tag))::_} =  (* Done *)
   7.232 -        ([(prfx,tag,[])], tm)
   7.233 -   | mk{path=[], rows = _::_} = mk_case_fail"blunder"
   7.234 -   | mk{path as u::rstp, rows as ((prfx, []), rhs)::rst} =
   7.235 -        mk{path = path,
   7.236 -           rows = ((prfx, [fresh_var(type_of u)]), rhs)::rst}
   7.237 -   | mk{path = u::rstp, rows as ((_, p::_), _)::_} =
   7.238 -     let val (pat_rectangle,rights) = ListPair.unzip rows
   7.239 -         val col0 = map(hd o #2) pat_rectangle
   7.240 -     in
   7.241 -     if (forall is_Free col0)
   7.242 -     then let val rights' = map (fn(v,e) => pattern_subst[(v,u)] e)
   7.243 -                                (ListPair.zip (col0, rights))
   7.244 -              val pat_rectangle' = map v_to_prfx pat_rectangle
   7.245 -              val (pref_patl,tm) = mk{path = rstp,
   7.246 -                                      rows = ListPair.zip (pat_rectangle',
   7.247 -                                                           rights')}
   7.248 -          in (map v_to_pats pref_patl, tm)
   7.249 -          end
   7.250 -     else
   7.251 -     let val pty as Type (ty_name,_) = type_of p
   7.252 -     in
   7.253 -     case (ty_info ty_name)
   7.254 -     of NONE => mk_case_fail("Not a known datatype: "^ty_name)
   7.255 -      | SOME{case_const,constructors} =>
   7.256 -        let
   7.257 -            val case_const_name = #1(dest_Const case_const)
   7.258 -            val nrows = maps (expand constructors pty) rows
   7.259 -            val subproblems = divide(constructors, pty, range_ty, nrows)
   7.260 -            val groups      = map #group subproblems
   7.261 -            and new_formals = map #new_formals subproblems
   7.262 -            and constructors' = map #constructor subproblems
   7.263 -            val news = map (fn (nf,rows) => {path = nf@rstp, rows=rows})
   7.264 -                           (ListPair.zip (new_formals, groups))
   7.265 -            val rec_calls = map mk news
   7.266 -            val (pat_rect,dtrees) = ListPair.unzip rec_calls
   7.267 -            val case_functions = map USyntax.list_mk_abs
   7.268 -                                  (ListPair.zip (new_formals, dtrees))
   7.269 -            val types = map type_of (case_functions@[u]) @ [range_ty]
   7.270 -            val case_const' = Const(case_const_name, list_mk_type types)
   7.271 -            val tree = list_comb(case_const', case_functions@[u])
   7.272 -            val pat_rect1 = flat (ListPair.map mk_pat (constructors', pat_rect))
   7.273 -        in (pat_rect1,tree)
   7.274 -        end
   7.275 -     end end
   7.276 - in mk
   7.277 - end;
   7.278 -
   7.279 -
   7.280 -(* Repeated variable occurrences in a pattern are not allowed. *)
   7.281 -fun FV_multiset tm =
   7.282 -   case (USyntax.dest_term tm)
   7.283 -     of USyntax.VAR{Name = c, Ty = T} => [Free(c, T)]
   7.284 -      | USyntax.CONST _ => []
   7.285 -      | USyntax.COMB{Rator, Rand} => FV_multiset Rator @ FV_multiset Rand
   7.286 -      | USyntax.LAMB _ => raise TFL_ERR "FV_multiset" "lambda";
   7.287 -
   7.288 -fun no_repeat_vars thy pat =
   7.289 - let fun check [] = true
   7.290 -       | check (v::rst) =
   7.291 -         if member (op aconv) rst v then
   7.292 -            raise TFL_ERR "no_repeat_vars"
   7.293 -                          (quote (#1 (dest_Free v)) ^
   7.294 -                          " occurs repeatedly in the pattern " ^
   7.295 -                          quote (Syntax.string_of_term_global thy pat))
   7.296 -         else check rst
   7.297 - in check (FV_multiset pat)
   7.298 - end;
   7.299 -
   7.300 -fun dest_atom (Free p) = p
   7.301 -  | dest_atom (Const p) = p
   7.302 -  | dest_atom  _ = raise TFL_ERR "dest_atom" "function name not an identifier";
   7.303 -
   7.304 -fun same_name (p,q) = #1(dest_atom p) = #1(dest_atom q);
   7.305 -
   7.306 -local fun mk_functional_err s = raise TFL_ERR "mk_functional" s
   7.307 -      fun single [_$_] =
   7.308 -              mk_functional_err "recdef does not allow currying"
   7.309 -        | single [f] = f
   7.310 -        | single fs  =
   7.311 -              (*multiple function names?*)
   7.312 -              if length (distinct same_name fs) < length fs
   7.313 -              then mk_functional_err
   7.314 -                   "The function being declared appears with multiple types"
   7.315 -              else mk_functional_err
   7.316 -                   (string_of_int (length fs) ^
   7.317 -                    " distinct function names being declared")
   7.318 -in
   7.319 -fun mk_functional thy clauses =
   7.320 - let val (L,R) = ListPair.unzip (map HOLogic.dest_eq clauses
   7.321 -                   handle TERM _ => raise TFL_ERR "mk_functional"
   7.322 -                        "recursion equations must use the = relation")
   7.323 -     val (funcs,pats) = ListPair.unzip (map (fn (t$u) =>(t,u)) L)
   7.324 -     val atom = single (distinct (op aconv) funcs)
   7.325 -     val (fname,ftype) = dest_atom atom
   7.326 -     val dummy = map (no_repeat_vars thy) pats
   7.327 -     val rows = ListPair.zip (map (fn x => ([]:term list,[x])) pats,
   7.328 -                              map_index (fn (i, t) => (t,(i,true))) R)
   7.329 -     val names = List.foldr Misc_Legacy.add_term_names [] R
   7.330 -     val atype = type_of(hd pats)
   7.331 -     and aname = singleton (Name.variant_list names) "a"
   7.332 -     val a = Free(aname,atype)
   7.333 -     val ty_info = Thry.match_info thy
   7.334 -     val ty_match = Thry.match_type thy
   7.335 -     val range_ty = type_of (hd R)
   7.336 -     val (patts, case_tm) = mk_case ty_info ty_match (aname::names) range_ty
   7.337 -                                    {path=[a], rows=rows}
   7.338 -     val patts1 = map (fn (_,tag,[pat]) => (pat,tag)) patts
   7.339 -          handle Match => mk_functional_err "error in pattern-match translation"
   7.340 -     val patts2 = Library.sort (Library.int_ord o apply2 row_of_pat) patts1
   7.341 -     val finals = map row_of_pat patts2
   7.342 -     val originals = map (row_of_pat o #2) rows
   7.343 -     val dummy = case (subtract (op =) finals originals)
   7.344 -             of [] => ()
   7.345 -          | L => mk_functional_err
   7.346 - ("The following clauses are redundant (covered by preceding clauses): " ^
   7.347 -                   commas (map (fn i => string_of_int (i + 1)) L))
   7.348 - in {functional = Abs(Long_Name.base_name fname, ftype,
   7.349 -                      abstract_over (atom, absfree (aname,atype) case_tm)),
   7.350 -     pats = patts2}
   7.351 -end end;
   7.352 -
   7.353 -
   7.354 -(*----------------------------------------------------------------------------
   7.355 - *
   7.356 - *                    PRINCIPLES OF DEFINITION
   7.357 - *
   7.358 - *---------------------------------------------------------------------------*)
   7.359 -
   7.360 -
   7.361 -(*For Isabelle, the lhs of a definition must be a constant.*)
   7.362 -fun const_def sign (c, Ty, rhs) =
   7.363 -  singleton (Syntax.check_terms (Proof_Context.init_global sign))
   7.364 -    (Const(@{const_name Pure.eq},dummyT) $ Const(c,Ty) $ rhs);
   7.365 -
   7.366 -(*Make all TVars available for instantiation by adding a ? to the front*)
   7.367 -fun poly_tvars (Type(a,Ts)) = Type(a, map (poly_tvars) Ts)
   7.368 -  | poly_tvars (TFree (a,sort)) = TVar (("?" ^ a, 0), sort)
   7.369 -  | poly_tvars (TVar ((a,i),sort)) = TVar (("?" ^ a, i+1), sort);
   7.370 -
   7.371 -local
   7.372 -  val f_eq_wfrec_R_M =
   7.373 -    #ant(USyntax.dest_imp(#2(USyntax.strip_forall (concl Thms.WFREC_COROLLARY))))
   7.374 -  val {lhs=f, rhs} = USyntax.dest_eq f_eq_wfrec_R_M
   7.375 -  val (fname,_) = dest_Free f
   7.376 -  val (wfrec,_) = USyntax.strip_comb rhs
   7.377 -in
   7.378 -
   7.379 -fun wfrec_definition0 fid R (functional as Abs(x, Ty, _)) thy =
   7.380 -  let
   7.381 -    val def_name = Thm.def_name (Long_Name.base_name fid)
   7.382 -    val wfrec_R_M = map_types poly_tvars (wfrec $ map_types poly_tvars R) $ functional
   7.383 -    val def_term = const_def thy (fid, Ty, wfrec_R_M)
   7.384 -    val ([def], thy') =
   7.385 -      Global_Theory.add_defs false [Thm.no_attributes (Binding.name def_name, def_term)] thy
   7.386 -  in (def, thy') end;
   7.387 -
   7.388 -end;
   7.389 -
   7.390 -
   7.391 -
   7.392 -(*---------------------------------------------------------------------------
   7.393 - * This structure keeps track of congruence rules that aren't derived
   7.394 - * from a datatype definition.
   7.395 - *---------------------------------------------------------------------------*)
   7.396 -fun extraction_thms thy =
   7.397 - let val {case_rewrites,case_congs} = Thry.extract_info thy
   7.398 - in (case_rewrites, case_congs)
   7.399 - end;
   7.400 -
   7.401 -
   7.402 -(*---------------------------------------------------------------------------
   7.403 - * Pair patterns with termination conditions. The full list of patterns for
   7.404 - * a definition is merged with the TCs arising from the user-given clauses.
   7.405 - * There can be fewer clauses than the full list, if the user omitted some
   7.406 - * cases. This routine is used to prepare input for mk_induction.
   7.407 - *---------------------------------------------------------------------------*)
   7.408 -fun merge full_pats TCs =
   7.409 -let fun insert (p,TCs) =
   7.410 -      let fun insrt ((x as (h,[]))::rst) =
   7.411 -                 if (p aconv h) then (p,TCs)::rst else x::insrt rst
   7.412 -            | insrt (x::rst) = x::insrt rst
   7.413 -            | insrt[] = raise TFL_ERR "merge.insert" "pattern not found"
   7.414 -      in insrt end
   7.415 -    fun pass ([],ptcl_final) = ptcl_final
   7.416 -      | pass (ptcs::tcl, ptcl) = pass(tcl, insert ptcs ptcl)
   7.417 -in
   7.418 -  pass (TCs, map (fn p => (p,[])) full_pats)
   7.419 -end;
   7.420 -
   7.421 -
   7.422 -fun givens pats = map pat_of (filter given pats);
   7.423 -
   7.424 -fun post_definition ctxt meta_tflCongs (def, pats) =
   7.425 - let val thy = Proof_Context.theory_of ctxt
   7.426 -     val tych = Thry.typecheck thy
   7.427 -     val f = #lhs(USyntax.dest_eq(concl def))
   7.428 -     val corollary = Rules.MATCH_MP Thms.WFREC_COROLLARY def
   7.429 -     val pats' = filter given pats
   7.430 -     val given_pats = map pat_of pats'
   7.431 -     val rows = map row_of_pat pats'
   7.432 -     val WFR = #ant(USyntax.dest_imp(concl corollary))
   7.433 -     val R = #Rand(USyntax.dest_comb WFR)
   7.434 -     val corollary' = Rules.UNDISCH corollary  (* put WF R on assums *)
   7.435 -     val corollaries = map (fn pat => Rules.SPEC (tych pat) corollary') given_pats
   7.436 -     val (case_rewrites,context_congs) = extraction_thms thy
   7.437 -     (*case_ss causes minimal simplification: bodies of case expressions are
   7.438 -       not simplified. Otherwise large examples (Red-Black trees) are too
   7.439 -       slow.*)
   7.440 -     val case_simpset =
   7.441 -       put_simpset HOL_basic_ss ctxt
   7.442 -          addsimps case_rewrites
   7.443 -          |> fold (Simplifier.add_cong o #case_cong_weak o snd)
   7.444 -              (Symtab.dest (BNF_LFP_Compat.get_all thy [BNF_LFP_Compat.Keep_Nesting]))
   7.445 -     val corollaries' = map (Simplifier.simplify case_simpset) corollaries
   7.446 -     val extract =
   7.447 -      Rules.CONTEXT_REWRITE_RULE ctxt (f, [R], @{thm cut_apply}, meta_tflCongs @ context_congs)
   7.448 -     val (rules, TCs) = ListPair.unzip (map extract corollaries')
   7.449 -     val rules0 = map (rewrite_rule ctxt [Thms.CUT_DEF]) rules
   7.450 -     val mk_cond_rule = Rules.FILTER_DISCH_ALL(not o curry (op aconv) WFR)
   7.451 -     val rules1 = Rules.LIST_CONJ(map mk_cond_rule rules0)
   7.452 - in
   7.453 - {rules = rules1,
   7.454 -  rows = rows,
   7.455 -  full_pats_TCs = merge (map pat_of pats) (ListPair.zip (given_pats, TCs)),
   7.456 -  TCs = TCs}
   7.457 - end;
   7.458 -
   7.459 -
   7.460 -(*---------------------------------------------------------------------------
   7.461 - * Perform the extraction without making the definition. Definition and
   7.462 - * extraction commute for the non-nested case.  (Deferred recdefs)
   7.463 - *
   7.464 - * The purpose of wfrec_eqns is merely to instantiate the recursion theorem
   7.465 - * and extract termination conditions: no definition is made.
   7.466 - *---------------------------------------------------------------------------*)
   7.467 -
   7.468 -fun wfrec_eqns thy fid tflCongs eqns =
   7.469 - let val ctxt = Proof_Context.init_global thy
   7.470 -     val {lhs,rhs} = USyntax.dest_eq (hd eqns)
   7.471 -     val (f,args) = USyntax.strip_comb lhs
   7.472 -     val (fname,fty) = dest_atom f
   7.473 -     val (SV,a) = front_last args    (* SV = schematic variables *)
   7.474 -     val g = list_comb(f,SV)
   7.475 -     val h = Free(fname,type_of g)
   7.476 -     val eqns1 = map (subst_free[(g,h)]) eqns
   7.477 -     val {functional as Abs(x, Ty, _),  pats} = mk_functional thy eqns1
   7.478 -     val given_pats = givens pats
   7.479 -     (* val f = Free(x,Ty) *)
   7.480 -     val Type("fun", [f_dty, f_rty]) = Ty
   7.481 -     val dummy = if x<>fid then
   7.482 -                        raise TFL_ERR "wfrec_eqns"
   7.483 -                                      ("Expected a definition of " ^
   7.484 -                                      quote fid ^ " but found one of " ^
   7.485 -                                      quote x)
   7.486 -                 else ()
   7.487 -     val (case_rewrites,context_congs) = extraction_thms thy
   7.488 -     val tych = Thry.typecheck thy
   7.489 -     val WFREC_THM0 = Rules.ISPEC (tych functional) Thms.WFREC_COROLLARY
   7.490 -     val Const(@{const_name All},_) $ Abs(Rname,Rtype,_) = concl WFREC_THM0
   7.491 -     val R = Free (singleton (Name.variant_list (List.foldr Misc_Legacy.add_term_names [] eqns)) Rname,
   7.492 -                   Rtype)
   7.493 -     val WFREC_THM = Rules.ISPECL [tych R, tych g] WFREC_THM0
   7.494 -     val ([proto_def, WFR],_) = USyntax.strip_imp(concl WFREC_THM)
   7.495 -     val dummy =
   7.496 -           if !trace then
   7.497 -               writeln ("ORIGINAL PROTO_DEF: " ^
   7.498 -                          Syntax.string_of_term_global thy proto_def)
   7.499 -           else ()
   7.500 -     val R1 = USyntax.rand WFR
   7.501 -     val corollary' = Rules.UNDISCH (Rules.UNDISCH WFREC_THM)
   7.502 -     val corollaries = map (fn pat => Rules.SPEC (tych pat) corollary') given_pats
   7.503 -     val corollaries' = map (rewrite_rule ctxt case_rewrites) corollaries
   7.504 -     val extract =
   7.505 -      Rules.CONTEXT_REWRITE_RULE ctxt (f, R1::SV, @{thm cut_apply}, tflCongs @ context_congs)
   7.506 - in {proto_def = proto_def,
   7.507 -     SV=SV,
   7.508 -     WFR=WFR,
   7.509 -     pats=pats,
   7.510 -     extracta = map extract corollaries'}
   7.511 - end;
   7.512 -
   7.513 -
   7.514 -(*---------------------------------------------------------------------------
   7.515 - * Define the constant after extracting the termination conditions. The
   7.516 - * wellfounded relation used in the definition is computed by using the
   7.517 - * choice operator on the extracted conditions (plus the condition that
   7.518 - * such a relation must be wellfounded).
   7.519 - *---------------------------------------------------------------------------*)
   7.520 -
   7.521 -fun lazyR_def thy fid tflCongs eqns =
   7.522 - let val {proto_def,WFR,pats,extracta,SV} =
   7.523 -           wfrec_eqns thy fid tflCongs eqns
   7.524 -     val R1 = USyntax.rand WFR
   7.525 -     val f = #lhs(USyntax.dest_eq proto_def)
   7.526 -     val (extractants,TCl) = ListPair.unzip extracta
   7.527 -     val dummy = if !trace
   7.528 -                 then writeln (cat_lines ("Extractants =" ::
   7.529 -                  map (Display.string_of_thm_global thy) extractants))
   7.530 -                 else ()
   7.531 -     val TCs = fold_rev (union (op aconv)) TCl []
   7.532 -     val full_rqt = WFR::TCs
   7.533 -     val R' = USyntax.mk_select{Bvar=R1, Body=USyntax.list_mk_conj full_rqt}
   7.534 -     val R'abs = USyntax.rand R'
   7.535 -     val proto_def' = subst_free[(R1,R')] proto_def
   7.536 -     val dummy = if !trace then writeln ("proto_def' = " ^
   7.537 -                                         Syntax.string_of_term_global
   7.538 -                                         thy proto_def')
   7.539 -                           else ()
   7.540 -     val {lhs,rhs} = USyntax.dest_eq proto_def'
   7.541 -     val (c,args) = USyntax.strip_comb lhs
   7.542 -     val (name,Ty) = dest_atom c
   7.543 -     val defn = const_def thy (name, Ty, USyntax.list_mk_abs (args,rhs))
   7.544 -     val ([def0], thy') =
   7.545 -       thy
   7.546 -       |> Global_Theory.add_defs false
   7.547 -            [Thm.no_attributes (Binding.name (Thm.def_name fid), defn)]
   7.548 -     val def = Thm.unvarify_global def0;
   7.549 -     val ctxt' = Syntax.init_pretty_global thy';
   7.550 -     val dummy =
   7.551 -       if !trace then writeln ("DEF = " ^ Display.string_of_thm ctxt' def)
   7.552 -       else ()
   7.553 -     (* val fconst = #lhs(USyntax.dest_eq(concl def))  *)
   7.554 -     val tych = Thry.typecheck thy'
   7.555 -     val full_rqt_prop = map (Dcterm.mk_prop o tych) full_rqt
   7.556 -         (*lcp: a lot of object-logic inference to remove*)
   7.557 -     val baz = Rules.DISCH_ALL
   7.558 -                 (fold_rev Rules.DISCH full_rqt_prop
   7.559 -                  (Rules.LIST_CONJ extractants))
   7.560 -     val dum = if !trace then writeln ("baz = " ^ Display.string_of_thm ctxt' baz) else ()
   7.561 -     val f_free = Free (fid, fastype_of f)  (*'cos f is a Const*)
   7.562 -     val SV' = map tych SV;
   7.563 -     val SVrefls = map Thm.reflexive SV'
   7.564 -     val def0 = (fold (fn x => fn th => Rules.rbeta(Thm.combination th x))
   7.565 -                   SVrefls def)
   7.566 -                RS meta_eq_to_obj_eq
   7.567 -     val def' = Rules.MP (Rules.SPEC (tych R') (Rules.GEN ctxt' (tych R1) baz)) def0
   7.568 -     val body_th = Rules.LIST_CONJ (map Rules.ASSUME full_rqt_prop)
   7.569 -     val SELECT_AX = (*in this way we hope to avoid a STATIC dependence upon
   7.570 -                       theory Hilbert_Choice*)
   7.571 -         ML_Context.thm "Hilbert_Choice.tfl_some"
   7.572 -         handle ERROR msg => cat_error msg
   7.573 -    "defer_recdef requires theory Main or at least Hilbert_Choice as parent"
   7.574 -     val bar = Rules.MP (Rules.ISPECL[tych R'abs, tych R1] SELECT_AX) body_th
   7.575 - in {theory = thy', R=R1, SV=SV,
   7.576 -     rules = fold (fn a => fn b => Rules.MP b a) (Rules.CONJUNCTS bar) def',
   7.577 -     full_pats_TCs = merge (map pat_of pats) (ListPair.zip (givens pats, TCl)),
   7.578 -     patterns = pats}
   7.579 - end;
   7.580 -
   7.581 -
   7.582 -
   7.583 -(*----------------------------------------------------------------------------
   7.584 - *
   7.585 - *                           INDUCTION THEOREM
   7.586 - *
   7.587 - *---------------------------------------------------------------------------*)
   7.588 -
   7.589 -
   7.590 -(*------------------------  Miscellaneous function  --------------------------
   7.591 - *
   7.592 - *           [x_1,...,x_n]     ?v_1...v_n. M[v_1,...,v_n]
   7.593 - *     -----------------------------------------------------------
   7.594 - *     ( M[x_1,...,x_n], [(x_i,?v_1...v_n. M[v_1,...,v_n]),
   7.595 - *                        ...
   7.596 - *                        (x_j,?v_n. M[x_1,...,x_(n-1),v_n])] )
   7.597 - *
   7.598 - * This function is totally ad hoc. Used in the production of the induction
   7.599 - * theorem. The nchotomy theorem can have clauses that look like
   7.600 - *
   7.601 - *     ?v1..vn. z = C vn..v1
   7.602 - *
   7.603 - * in which the order of quantification is not the order of occurrence of the
   7.604 - * quantified variables as arguments to C. Since we have no control over this
   7.605 - * aspect of the nchotomy theorem, we make the correspondence explicit by
   7.606 - * pairing the incoming new variable with the term it gets beta-reduced into.
   7.607 - *---------------------------------------------------------------------------*)
   7.608 -
   7.609 -fun alpha_ex_unroll (xlist, tm) =
   7.610 -  let val (qvars,body) = USyntax.strip_exists tm
   7.611 -      val vlist = #2 (USyntax.strip_comb (USyntax.rhs body))
   7.612 -      val plist = ListPair.zip (vlist, xlist)
   7.613 -      val args = map (the o AList.lookup (op aconv) plist) qvars
   7.614 -                   handle Option.Option => raise Fail "TFL.alpha_ex_unroll: no correspondence"
   7.615 -      fun build ex      []   = []
   7.616 -        | build (_$rex) (v::rst) =
   7.617 -           let val ex1 = Term.betapply(rex, v)
   7.618 -           in  ex1 :: build ex1 rst
   7.619 -           end
   7.620 -     val (nex::exl) = rev (tm::build tm args)
   7.621 -  in
   7.622 -  (nex, ListPair.zip (args, rev exl))
   7.623 -  end;
   7.624 -
   7.625 -
   7.626 -
   7.627 -(*----------------------------------------------------------------------------
   7.628 - *
   7.629 - *             PROVING COMPLETENESS OF PATTERNS
   7.630 - *
   7.631 - *---------------------------------------------------------------------------*)
   7.632 -
   7.633 -fun mk_case ty_info usednames thy =
   7.634 - let
   7.635 - val ctxt = Proof_Context.init_global thy
   7.636 - val divide = ipartition (gvvariant usednames)
   7.637 - val tych = Thry.typecheck thy
   7.638 - fun tych_binding(x,y) = (tych x, tych y)
   7.639 - fun fail s = raise TFL_ERR "mk_case" s
   7.640 - fun mk{rows=[],...} = fail"no rows"
   7.641 -   | mk{path=[], rows = [([], (thm, bindings))]} =
   7.642 -                         Rules.IT_EXISTS ctxt (map tych_binding bindings) thm
   7.643 -   | mk{path = u::rstp, rows as (p::_, _)::_} =
   7.644 -     let val (pat_rectangle,rights) = ListPair.unzip rows
   7.645 -         val col0 = map hd pat_rectangle
   7.646 -         val pat_rectangle' = map tl pat_rectangle
   7.647 -     in
   7.648 -     if (forall is_Free col0) (* column 0 is all variables *)
   7.649 -     then let val rights' = map (fn ((thm,theta),v) => (thm,theta@[(u,v)]))
   7.650 -                                (ListPair.zip (rights, col0))
   7.651 -          in mk{path = rstp, rows = ListPair.zip (pat_rectangle', rights')}
   7.652 -          end
   7.653 -     else                     (* column 0 is all constructors *)
   7.654 -     let val Type (ty_name,_) = type_of p
   7.655 -     in
   7.656 -     case (ty_info ty_name)
   7.657 -     of NONE => fail("Not a known datatype: "^ty_name)
   7.658 -      | SOME{constructors,nchotomy} =>
   7.659 -        let val thm' = Rules.ISPEC (tych u) nchotomy
   7.660 -            val disjuncts = USyntax.strip_disj (concl thm')
   7.661 -            val subproblems = divide(constructors, rows)
   7.662 -            val groups      = map #group subproblems
   7.663 -            and new_formals = map #new_formals subproblems
   7.664 -            val existentials = ListPair.map alpha_ex_unroll
   7.665 -                                   (new_formals, disjuncts)
   7.666 -            val constraints = map #1 existentials
   7.667 -            val vexl = map #2 existentials
   7.668 -            fun expnd tm (pats,(th,b)) = (pats, (Rules.SUBS ctxt [Rules.ASSUME (tych tm)] th, b))
   7.669 -            val news = map (fn (nf,rows,c) => {path = nf@rstp,
   7.670 -                                               rows = map (expnd c) rows})
   7.671 -                           (Utils.zip3 new_formals groups constraints)
   7.672 -            val recursive_thms = map mk news
   7.673 -            val build_exists = Library.foldr
   7.674 -                                (fn((x,t), th) =>
   7.675 -                                 Rules.CHOOSE ctxt (tych x, Rules.ASSUME (tych t)) th)
   7.676 -            val thms' = ListPair.map build_exists (vexl, recursive_thms)
   7.677 -            val same_concls = Rules.EVEN_ORS thms'
   7.678 -        in Rules.DISJ_CASESL thm' same_concls
   7.679 -        end
   7.680 -     end end
   7.681 - in mk
   7.682 - end;
   7.683 -
   7.684 -
   7.685 -fun complete_cases thy =
   7.686 - let val ctxt = Proof_Context.init_global thy
   7.687 -     val tych = Thry.typecheck thy
   7.688 -     val ty_info = Thry.induct_info thy
   7.689 - in fn pats =>
   7.690 - let val names = List.foldr Misc_Legacy.add_term_names [] pats
   7.691 -     val T = type_of (hd pats)
   7.692 -     val aname = singleton (Name.variant_list names) "a"
   7.693 -     val vname = singleton (Name.variant_list (aname::names)) "v"
   7.694 -     val a = Free (aname, T)
   7.695 -     val v = Free (vname, T)
   7.696 -     val a_eq_v = HOLogic.mk_eq(a,v)
   7.697 -     val ex_th0 = Rules.EXISTS (tych (USyntax.mk_exists{Bvar=v,Body=a_eq_v}), tych a)
   7.698 -                           (Rules.REFL (tych a))
   7.699 -     val th0 = Rules.ASSUME (tych a_eq_v)
   7.700 -     val rows = map (fn x => ([x], (th0,[]))) pats
   7.701 - in
   7.702 - Rules.GEN ctxt (tych a)
   7.703 -       (Rules.RIGHT_ASSOC ctxt
   7.704 -          (Rules.CHOOSE ctxt (tych v, ex_th0)
   7.705 -                (mk_case ty_info (vname::aname::names)
   7.706 -                 thy {path=[v], rows=rows})))
   7.707 - end end;
   7.708 -
   7.709 -
   7.710 -(*---------------------------------------------------------------------------
   7.711 - * Constructing induction hypotheses: one for each recursive call.
   7.712 - *
   7.713 - * Note. R will never occur as a variable in the ind_clause, because
   7.714 - * to do so, it would have to be from a nested definition, and we don't
   7.715 - * allow nested defns to have R variable.
   7.716 - *
   7.717 - * Note. When the context is empty, there can be no local variables.
   7.718 - *---------------------------------------------------------------------------*)
   7.719 -(*
   7.720 -local infix 5 ==>
   7.721 -      fun (tm1 ==> tm2) = USyntax.mk_imp{ant = tm1, conseq = tm2}
   7.722 -in
   7.723 -fun build_ih f P (pat,TCs) =
   7.724 - let val globals = USyntax.free_vars_lr pat
   7.725 -     fun nested tm = is_some (USyntax.find_term (curry (op aconv) f) tm)
   7.726 -     fun dest_TC tm =
   7.727 -         let val (cntxt,R_y_pat) = USyntax.strip_imp(#2(USyntax.strip_forall tm))
   7.728 -             val (R,y,_) = USyntax.dest_relation R_y_pat
   7.729 -             val P_y = if (nested tm) then R_y_pat ==> P$y else P$y
   7.730 -         in case cntxt
   7.731 -              of [] => (P_y, (tm,[]))
   7.732 -               | _  => let
   7.733 -                    val imp = USyntax.list_mk_conj cntxt ==> P_y
   7.734 -                    val lvs = gen_rems (op aconv) (USyntax.free_vars_lr imp, globals)
   7.735 -                    val locals = #2(Utils.pluck (curry (op aconv) P) lvs) handle Utils.ERR _ => lvs
   7.736 -                    in (USyntax.list_mk_forall(locals,imp), (tm,locals)) end
   7.737 -         end
   7.738 - in case TCs
   7.739 -    of [] => (USyntax.list_mk_forall(globals, P$pat), [])
   7.740 -     |  _ => let val (ihs, TCs_locals) = ListPair.unzip(map dest_TC TCs)
   7.741 -                 val ind_clause = USyntax.list_mk_conj ihs ==> P$pat
   7.742 -             in (USyntax.list_mk_forall(globals,ind_clause), TCs_locals)
   7.743 -             end
   7.744 - end
   7.745 -end;
   7.746 -*)
   7.747 -
   7.748 -local infix 5 ==>
   7.749 -      fun (tm1 ==> tm2) = USyntax.mk_imp{ant = tm1, conseq = tm2}
   7.750 -in
   7.751 -fun build_ih f (P,SV) (pat,TCs) =
   7.752 - let val pat_vars = USyntax.free_vars_lr pat
   7.753 -     val globals = pat_vars@SV
   7.754 -     fun nested tm = is_some (USyntax.find_term (curry (op aconv) f) tm)
   7.755 -     fun dest_TC tm =
   7.756 -         let val (cntxt,R_y_pat) = USyntax.strip_imp(#2(USyntax.strip_forall tm))
   7.757 -             val (R,y,_) = USyntax.dest_relation R_y_pat
   7.758 -             val P_y = if (nested tm) then R_y_pat ==> P$y else P$y
   7.759 -         in case cntxt
   7.760 -              of [] => (P_y, (tm,[]))
   7.761 -               | _  => let
   7.762 -                    val imp = USyntax.list_mk_conj cntxt ==> P_y
   7.763 -                    val lvs = subtract (op aconv) globals (USyntax.free_vars_lr imp)
   7.764 -                    val locals = #2(Utils.pluck (curry (op aconv) P) lvs) handle Utils.ERR _ => lvs
   7.765 -                    in (USyntax.list_mk_forall(locals,imp), (tm,locals)) end
   7.766 -         end
   7.767 - in case TCs
   7.768 -    of [] => (USyntax.list_mk_forall(pat_vars, P$pat), [])
   7.769 -     |  _ => let val (ihs, TCs_locals) = ListPair.unzip(map dest_TC TCs)
   7.770 -                 val ind_clause = USyntax.list_mk_conj ihs ==> P$pat
   7.771 -             in (USyntax.list_mk_forall(pat_vars,ind_clause), TCs_locals)
   7.772 -             end
   7.773 - end
   7.774 -end;
   7.775 -
   7.776 -(*---------------------------------------------------------------------------
   7.777 - * This function makes good on the promise made in "build_ih".
   7.778 - *
   7.779 - * Input  is tm = "(!y. R y pat ==> P y) ==> P pat",
   7.780 - *           TCs = TC_1[pat] ... TC_n[pat]
   7.781 - *           thm = ih1 /\ ... /\ ih_n |- ih[pat]
   7.782 - *---------------------------------------------------------------------------*)
   7.783 -fun prove_case ctxt f (tm,TCs_locals,thm) =
   7.784 - let val tych = Thry.typecheck (Proof_Context.theory_of ctxt)
   7.785 -     val antc = tych(#ant(USyntax.dest_imp tm))
   7.786 -     val thm' = Rules.SPEC_ALL thm
   7.787 -     fun nested tm = is_some (USyntax.find_term (curry (op aconv) f) tm)
   7.788 -     fun get_cntxt TC = tych(#ant(USyntax.dest_imp(#2(USyntax.strip_forall(concl TC)))))
   7.789 -     fun mk_ih ((TC,locals),th2,nested) =
   7.790 -         Rules.GENL ctxt (map tych locals)
   7.791 -            (if nested then Rules.DISCH (get_cntxt TC) th2 handle Utils.ERR _ => th2
   7.792 -             else if USyntax.is_imp (concl TC) then Rules.IMP_TRANS TC th2
   7.793 -             else Rules.MP th2 TC)
   7.794 - in
   7.795 - Rules.DISCH antc
   7.796 - (if USyntax.is_imp(concl thm') (* recursive calls in this clause *)
   7.797 -  then let val th1 = Rules.ASSUME antc
   7.798 -           val TCs = map #1 TCs_locals
   7.799 -           val ylist = map (#2 o USyntax.dest_relation o #2 o USyntax.strip_imp o
   7.800 -                            #2 o USyntax.strip_forall) TCs
   7.801 -           val TClist = map (fn(TC,lvs) => (Rules.SPEC_ALL(Rules.ASSUME(tych TC)),lvs))
   7.802 -                            TCs_locals
   7.803 -           val th2list = map (fn t => Rules.SPEC (tych t) th1) ylist
   7.804 -           val nlist = map nested TCs
   7.805 -           val triples = Utils.zip3 TClist th2list nlist
   7.806 -           val Pylist = map mk_ih triples
   7.807 -       in Rules.MP thm' (Rules.LIST_CONJ Pylist) end
   7.808 -  else thm')
   7.809 - end;
   7.810 -
   7.811 -
   7.812 -(*---------------------------------------------------------------------------
   7.813 - *
   7.814 - *         x = (v1,...,vn)  |- M[x]
   7.815 - *    ---------------------------------------------
   7.816 - *      ?v1 ... vn. x = (v1,...,vn) |- M[x]
   7.817 - *
   7.818 - *---------------------------------------------------------------------------*)
   7.819 -fun LEFT_ABS_VSTRUCT ctxt tych thm =
   7.820 -  let fun CHOOSER v (tm,thm) =
   7.821 -        let val ex_tm = USyntax.mk_exists{Bvar=v,Body=tm}
   7.822 -        in (ex_tm, Rules.CHOOSE ctxt (tych v, Rules.ASSUME (tych ex_tm)) thm)
   7.823 -        end
   7.824 -      val [veq] = filter (can USyntax.dest_eq) (#1 (Rules.dest_thm thm))
   7.825 -      val {lhs,rhs} = USyntax.dest_eq veq
   7.826 -      val L = USyntax.free_vars_lr rhs
   7.827 -  in  #2 (fold_rev CHOOSER L (veq,thm))  end;
   7.828 -
   7.829 -
   7.830 -(*----------------------------------------------------------------------------
   7.831 - * Input : f, R,  and  [(pat1,TCs1),..., (patn,TCsn)]
   7.832 - *
   7.833 - * Instantiates WF_INDUCTION_THM, getting Sinduct and then tries to prove
   7.834 - * recursion induction (Rinduct) by proving the antecedent of Sinduct from
   7.835 - * the antecedent of Rinduct.
   7.836 - *---------------------------------------------------------------------------*)
   7.837 -fun mk_induction thy {fconst, R, SV, pat_TCs_list} =
   7.838 -let val ctxt = Proof_Context.init_global thy
   7.839 -    val tych = Thry.typecheck thy
   7.840 -    val Sinduction = Rules.UNDISCH (Rules.ISPEC (tych R) Thms.WF_INDUCTION_THM)
   7.841 -    val (pats,TCsl) = ListPair.unzip pat_TCs_list
   7.842 -    val case_thm = complete_cases thy pats
   7.843 -    val domain = (type_of o hd) pats
   7.844 -    val Pname = singleton (Name.variant_list (List.foldr (Library.foldr Misc_Legacy.add_term_names)
   7.845 -                              [] (pats::TCsl))) "P"
   7.846 -    val P = Free(Pname, domain --> HOLogic.boolT)
   7.847 -    val Sinduct = Rules.SPEC (tych P) Sinduction
   7.848 -    val Sinduct_assumf = USyntax.rand ((#ant o USyntax.dest_imp o concl) Sinduct)
   7.849 -    val Rassums_TCl' = map (build_ih fconst (P,SV)) pat_TCs_list
   7.850 -    val (Rassums,TCl') = ListPair.unzip Rassums_TCl'
   7.851 -    val Rinduct_assum = Rules.ASSUME (tych (USyntax.list_mk_conj Rassums))
   7.852 -    val cases = map (fn pat => Term.betapply (Sinduct_assumf, pat)) pats
   7.853 -    val tasks = Utils.zip3 cases TCl' (Rules.CONJUNCTS Rinduct_assum)
   7.854 -    val proved_cases = map (prove_case ctxt fconst) tasks
   7.855 -    val v =
   7.856 -      Free (singleton
   7.857 -        (Name.variant_list (List.foldr Misc_Legacy.add_term_names [] (map concl proved_cases))) "v",
   7.858 -          domain)
   7.859 -    val vtyped = tych v
   7.860 -    val substs = map (Rules.SYM o Rules.ASSUME o tych o (curry HOLogic.mk_eq v)) pats
   7.861 -    val proved_cases1 = ListPair.map (fn (th,th') => Rules.SUBS ctxt [th]th')
   7.862 -                          (substs, proved_cases)
   7.863 -    val abs_cases = map (LEFT_ABS_VSTRUCT ctxt tych) proved_cases1
   7.864 -    val dant = Rules.GEN ctxt vtyped (Rules.DISJ_CASESL (Rules.ISPEC vtyped case_thm) abs_cases)
   7.865 -    val dc = Rules.MP Sinduct dant
   7.866 -    val Parg_ty = type_of(#Bvar(USyntax.dest_forall(concl dc)))
   7.867 -    val vars = map (gvvariant[Pname]) (USyntax.strip_prod_type Parg_ty)
   7.868 -    val dc' = fold_rev (Rules.GEN ctxt o tych) vars
   7.869 -                       (Rules.SPEC (tych(USyntax.mk_vstruct Parg_ty vars)) dc)
   7.870 -in
   7.871 -   Rules.GEN ctxt (tych P) (Rules.DISCH (tych(concl Rinduct_assum)) dc')
   7.872 -end
   7.873 -handle Utils.ERR _ => raise TFL_ERR "mk_induction" "failed derivation";
   7.874 -
   7.875 -
   7.876 -
   7.877 -
   7.878 -(*---------------------------------------------------------------------------
   7.879 - *
   7.880 - *                        POST PROCESSING
   7.881 - *
   7.882 - *---------------------------------------------------------------------------*)
   7.883 -
   7.884 -
   7.885 -fun simplify_induction thy hth ind =
   7.886 -  let val tych = Thry.typecheck thy
   7.887 -      val (asl,_) = Rules.dest_thm ind
   7.888 -      val (_,tc_eq_tc') = Rules.dest_thm hth
   7.889 -      val tc = USyntax.lhs tc_eq_tc'
   7.890 -      fun loop [] = ind
   7.891 -        | loop (asm::rst) =
   7.892 -          if (can (Thry.match_term thy asm) tc)
   7.893 -          then Rules.UNDISCH
   7.894 -                 (Rules.MATCH_MP
   7.895 -                     (Rules.MATCH_MP Thms.simp_thm (Rules.DISCH (tych asm) ind))
   7.896 -                     hth)
   7.897 -         else loop rst
   7.898 -  in loop asl
   7.899 -end;
   7.900 -
   7.901 -
   7.902 -(*---------------------------------------------------------------------------
   7.903 - * The termination condition is an antecedent to the rule, and an
   7.904 - * assumption to the theorem.
   7.905 - *---------------------------------------------------------------------------*)
   7.906 -fun elim_tc tcthm (rule,induction) =
   7.907 -   (Rules.MP rule tcthm, Rules.PROVE_HYP tcthm induction)
   7.908 -
   7.909 -
   7.910 -fun trace_thms ctxt s L =
   7.911 -  if !trace then writeln (cat_lines (s :: map (Display.string_of_thm ctxt) L))
   7.912 -  else ();
   7.913 -
   7.914 -fun trace_cterm ctxt s ct =
   7.915 -  if !trace then
   7.916 -    writeln (cat_lines [s, Syntax.string_of_term ctxt (Thm.term_of ct)])
   7.917 -  else ();
   7.918 -
   7.919 -
   7.920 -fun postprocess ctxt strict {wf_tac, terminator, simplifier} {rules,induction,TCs} =
   7.921 -  let
   7.922 -    val thy = Proof_Context.theory_of ctxt;
   7.923 -    val tych = Thry.typecheck thy;
   7.924 -
   7.925 -   (*---------------------------------------------------------------------
   7.926 -    * Attempt to eliminate WF condition. It's the only assumption of rules
   7.927 -    *---------------------------------------------------------------------*)
   7.928 -    val (rules1,induction1)  =
   7.929 -       let val thm =
   7.930 -        Rules.prove ctxt strict (HOLogic.mk_Trueprop (hd(#1(Rules.dest_thm rules))), wf_tac)
   7.931 -       in (Rules.PROVE_HYP thm rules, Rules.PROVE_HYP thm induction)
   7.932 -       end handle Utils.ERR _ => (rules,induction);
   7.933 -
   7.934 -   (*----------------------------------------------------------------------
   7.935 -    * The termination condition (tc) is simplified to |- tc = tc' (there
   7.936 -    * might not be a change!) and then 3 attempts are made:
   7.937 -    *
   7.938 -    *   1. if |- tc = T, then eliminate it with eqT; otherwise,
   7.939 -    *   2. apply the terminator to tc'. If |- tc' = T then eliminate; else
   7.940 -    *   3. replace tc by tc' in both the rules and the induction theorem.
   7.941 -    *---------------------------------------------------------------------*)
   7.942 -
   7.943 -   fun simplify_tc tc (r,ind) =
   7.944 -       let val tc1 = tych tc
   7.945 -           val _ = trace_cterm ctxt "TC before simplification: " tc1
   7.946 -           val tc_eq = simplifier tc1
   7.947 -           val _ = trace_thms ctxt "result: " [tc_eq]
   7.948 -       in
   7.949 -       elim_tc (Rules.MATCH_MP Thms.eqT tc_eq) (r,ind)
   7.950 -       handle Utils.ERR _ =>
   7.951 -        (elim_tc (Rules.MATCH_MP(Rules.MATCH_MP Thms.rev_eq_mp tc_eq)
   7.952 -                  (Rules.prove ctxt strict (HOLogic.mk_Trueprop(USyntax.rhs(concl tc_eq)),
   7.953 -                           terminator)))
   7.954 -                 (r,ind)
   7.955 -         handle Utils.ERR _ =>
   7.956 -          (Rules.UNDISCH(Rules.MATCH_MP (Rules.MATCH_MP Thms.simp_thm r) tc_eq),
   7.957 -           simplify_induction thy tc_eq ind))
   7.958 -       end
   7.959 -
   7.960 -   (*----------------------------------------------------------------------
   7.961 -    * Nested termination conditions are harder to get at, since they are
   7.962 -    * left embedded in the body of the function (and in induction
   7.963 -    * theorem hypotheses). Our "solution" is to simplify them, and try to
   7.964 -    * prove termination, but leave the application of the resulting theorem
   7.965 -    * to a higher level. So things go much as in "simplify_tc": the
   7.966 -    * termination condition (tc) is simplified to |- tc = tc' (there might
   7.967 -    * not be a change) and then 2 attempts are made:
   7.968 -    *
   7.969 -    *   1. if |- tc = T, then return |- tc; otherwise,
   7.970 -    *   2. apply the terminator to tc'. If |- tc' = T then return |- tc; else
   7.971 -    *   3. return |- tc = tc'
   7.972 -    *---------------------------------------------------------------------*)
   7.973 -   fun simplify_nested_tc tc =
   7.974 -      let val tc_eq = simplifier (tych (#2 (USyntax.strip_forall tc)))
   7.975 -      in
   7.976 -      Rules.GEN_ALL ctxt
   7.977 -       (Rules.MATCH_MP Thms.eqT tc_eq
   7.978 -        handle Utils.ERR _ =>
   7.979 -          (Rules.MATCH_MP(Rules.MATCH_MP Thms.rev_eq_mp tc_eq)
   7.980 -                      (Rules.prove ctxt strict (HOLogic.mk_Trueprop (USyntax.rhs(concl tc_eq)),
   7.981 -                               terminator))
   7.982 -            handle Utils.ERR _ => tc_eq))
   7.983 -      end
   7.984 -
   7.985 -   (*-------------------------------------------------------------------
   7.986 -    * Attempt to simplify the termination conditions in each rule and
   7.987 -    * in the induction theorem.
   7.988 -    *-------------------------------------------------------------------*)
   7.989 -   fun strip_imp tm = if USyntax.is_neg tm then ([],tm) else USyntax.strip_imp tm
   7.990 -   fun loop ([],extras,R,ind) = (rev R, ind, extras)
   7.991 -     | loop ((r,ftcs)::rst, nthms, R, ind) =
   7.992 -        let val tcs = #1(strip_imp (concl r))
   7.993 -            val extra_tcs = subtract (op aconv) tcs ftcs
   7.994 -            val extra_tc_thms = map simplify_nested_tc extra_tcs
   7.995 -            val (r1,ind1) = fold simplify_tc tcs (r,ind)
   7.996 -            val r2 = Rules.FILTER_DISCH_ALL(not o USyntax.is_WFR) r1
   7.997 -        in loop(rst, nthms@extra_tc_thms, r2::R, ind1)
   7.998 -        end
   7.999 -   val rules_tcs = ListPair.zip (Rules.CONJUNCTS rules1, TCs)
  7.1000 -   val (rules2,ind2,extras) = loop(rules_tcs,[],[],induction1)
  7.1001 -in
  7.1002 -  {induction = ind2, rules = Rules.LIST_CONJ rules2, nested_tcs = extras}
  7.1003 -end;
  7.1004 -
  7.1005 -
  7.1006 -end;
     8.1 --- a/src/HOL/Tools/TFL/thms.ML	Fri Jun 19 18:41:21 2015 +0200
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,19 +0,0 @@
     8.4 -(*  Title:      HOL/Tools/TFL/thms.ML
     8.5 -    Author:     Konrad Slind, Cambridge University Computer Laboratory
     8.6 -    Copyright   1997  University of Cambridge
     8.7 -*)
     8.8 -
     8.9 -structure Thms =
    8.10 -struct
    8.11 -  val WFREC_COROLLARY = @{thm tfl_wfrec};
    8.12 -  val WF_INDUCTION_THM = @{thm tfl_wf_induct};
    8.13 -  val CUT_DEF = @{thm tfl_cut_def};
    8.14 -  val eqT = @{thm tfl_eq_True};
    8.15 -  val rev_eq_mp = @{thm tfl_rev_eq_mp};
    8.16 -  val simp_thm = @{thm tfl_simp_thm};
    8.17 -  val P_imp_P_iff_True = @{thm tfl_P_imp_P_iff_True};
    8.18 -  val imp_trans = @{thm tfl_imp_trans};
    8.19 -  val disj_assoc = @{thm tfl_disj_assoc};
    8.20 -  val tfl_disjE = @{thm tfl_disjE};
    8.21 -  val choose_thm = @{thm tfl_exE};
    8.22 -end;
     9.1 --- a/src/HOL/Tools/TFL/thry.ML	Fri Jun 19 18:41:21 2015 +0200
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,80 +0,0 @@
     9.4 -(*  Title:      HOL/Tools/TFL/thry.ML
     9.5 -    Author:     Konrad Slind, Cambridge University Computer Laboratory
     9.6 -*)
     9.7 -
     9.8 -signature THRY =
     9.9 -sig
    9.10 -  val match_term: theory -> term -> term -> (term * term) list * (typ * typ) list
    9.11 -  val match_type: theory -> typ -> typ -> (typ * typ) list
    9.12 -  val typecheck: theory -> term -> cterm
    9.13 -  (*datatype facts of various flavours*)
    9.14 -  val match_info: theory -> string -> {constructors: term list, case_const: term} option
    9.15 -  val induct_info: theory -> string -> {constructors: term list, nchotomy: thm} option
    9.16 -  val extract_info: theory -> {case_congs: thm list, case_rewrites: thm list}
    9.17 -end;
    9.18 -
    9.19 -structure Thry: THRY =
    9.20 -struct
    9.21 -
    9.22 -
    9.23 -fun THRY_ERR func mesg = Utils.ERR {module = "Thry", func = func, mesg = mesg};
    9.24 -
    9.25 -
    9.26 -(*---------------------------------------------------------------------------
    9.27 - *    Matching
    9.28 - *---------------------------------------------------------------------------*)
    9.29 -
    9.30 -local
    9.31 -
    9.32 -fun tybind (ixn, (S, T)) = (TVar (ixn, S), T);
    9.33 -
    9.34 -in
    9.35 -
    9.36 -fun match_term thry pat ob =
    9.37 -  let
    9.38 -    val (ty_theta, tm_theta) = Pattern.match thry (pat,ob) (Vartab.empty, Vartab.empty);
    9.39 -    fun tmbind (ixn, (T, t)) = (Var (ixn, Envir.subst_type ty_theta T), t)
    9.40 -  in (map tmbind (Vartab.dest tm_theta), map tybind (Vartab.dest ty_theta))
    9.41 -  end;
    9.42 -
    9.43 -fun match_type thry pat ob =
    9.44 -  map tybind (Vartab.dest (Sign.typ_match thry (pat, ob) Vartab.empty));
    9.45 -
    9.46 -end;
    9.47 -
    9.48 -
    9.49 -(*---------------------------------------------------------------------------
    9.50 - * Typing
    9.51 - *---------------------------------------------------------------------------*)
    9.52 -
    9.53 -fun typecheck thy t =
    9.54 -  Thm.global_cterm_of thy t
    9.55 -    handle TYPE (msg, _, _) => raise THRY_ERR "typecheck" msg
    9.56 -      | TERM (msg, _) => raise THRY_ERR "typecheck" msg;
    9.57 -
    9.58 -
    9.59 -(*---------------------------------------------------------------------------
    9.60 - * Get information about datatypes
    9.61 - *---------------------------------------------------------------------------*)
    9.62 -
    9.63 -fun match_info thy dtco =
    9.64 -  case (BNF_LFP_Compat.get_info thy [BNF_LFP_Compat.Keep_Nesting] dtco,
    9.65 -         BNF_LFP_Compat.get_constrs thy dtco) of
    9.66 -      (SOME {case_name, ... }, SOME constructors) =>
    9.67 -        SOME {case_const = Const (case_name, Sign.the_const_type thy case_name), constructors = map Const constructors}
    9.68 -    | _ => NONE;
    9.69 -
    9.70 -fun induct_info thy dtco = case BNF_LFP_Compat.get_info thy [BNF_LFP_Compat.Keep_Nesting] dtco of
    9.71 -        NONE => NONE
    9.72 -      | SOME {nchotomy, ...} =>
    9.73 -          SOME {nchotomy = nchotomy,
    9.74 -                constructors = (map Const o the o BNF_LFP_Compat.get_constrs thy) dtco};
    9.75 -
    9.76 -fun extract_info thy =
    9.77 - let val infos = map snd (Symtab.dest (BNF_LFP_Compat.get_all thy [BNF_LFP_Compat.Keep_Nesting]))
    9.78 - in {case_congs = map (mk_meta_eq o #case_cong) infos,
    9.79 -     case_rewrites = maps (map mk_meta_eq o #case_rewrites) infos}
    9.80 - end;
    9.81 -
    9.82 -
    9.83 -end;
    10.1 --- a/src/HOL/Tools/TFL/usyntax.ML	Fri Jun 19 18:41:21 2015 +0200
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,407 +0,0 @@
    10.4 -(*  Title:      HOL/Tools/TFL/usyntax.ML
    10.5 -    Author:     Konrad Slind, Cambridge University Computer Laboratory
    10.6 -
    10.7 -Emulation of HOL's abstract syntax functions.
    10.8 -*)
    10.9 -
   10.10 -signature USYNTAX =
   10.11 -sig
   10.12 -  datatype lambda = VAR   of {Name : string, Ty : typ}
   10.13 -                  | CONST of {Name : string, Ty : typ}
   10.14 -                  | COMB  of {Rator: term, Rand : term}
   10.15 -                  | LAMB  of {Bvar : term, Body : term}
   10.16 -
   10.17 -  val alpha : typ
   10.18 -
   10.19 -  (* Types *)
   10.20 -  val type_vars  : typ -> typ list
   10.21 -  val type_varsl : typ list -> typ list
   10.22 -  val mk_vartype : string -> typ
   10.23 -  val is_vartype : typ -> bool
   10.24 -  val strip_prod_type : typ -> typ list
   10.25 -
   10.26 -  (* Terms *)
   10.27 -  val free_vars_lr : term -> term list
   10.28 -  val type_vars_in_term : term -> typ list
   10.29 -  val dest_term  : term -> lambda
   10.30 -
   10.31 -  (* Prelogic *)
   10.32 -  val inst      : (typ*typ) list -> term -> term
   10.33 -
   10.34 -  (* Construction routines *)
   10.35 -  val mk_abs    :{Bvar  : term, Body : term} -> term
   10.36 -
   10.37 -  val mk_imp    :{ant : term, conseq :  term} -> term
   10.38 -  val mk_select :{Bvar : term, Body : term} -> term
   10.39 -  val mk_forall :{Bvar : term, Body : term} -> term
   10.40 -  val mk_exists :{Bvar : term, Body : term} -> term
   10.41 -  val mk_conj   :{conj1 : term, conj2 : term} -> term
   10.42 -  val mk_disj   :{disj1 : term, disj2 : term} -> term
   10.43 -  val mk_pabs   :{varstruct : term, body : term} -> term
   10.44 -
   10.45 -  (* Destruction routines *)
   10.46 -  val dest_const: term -> {Name : string, Ty : typ}
   10.47 -  val dest_comb : term -> {Rator : term, Rand : term}
   10.48 -  val dest_abs  : string list -> term -> {Bvar : term, Body : term} * string list
   10.49 -  val dest_eq     : term -> {lhs : term, rhs : term}
   10.50 -  val dest_imp    : term -> {ant : term, conseq : term}
   10.51 -  val dest_forall : term -> {Bvar : term, Body : term}
   10.52 -  val dest_exists : term -> {Bvar : term, Body : term}
   10.53 -  val dest_neg    : term -> term
   10.54 -  val dest_conj   : term -> {conj1 : term, conj2 : term}
   10.55 -  val dest_disj   : term -> {disj1 : term, disj2 : term}
   10.56 -  val dest_pair   : term -> {fst : term, snd : term}
   10.57 -  val dest_pabs   : string list -> term -> {varstruct : term, body : term, used : string list}
   10.58 -
   10.59 -  val lhs   : term -> term
   10.60 -  val rhs   : term -> term
   10.61 -  val rand  : term -> term
   10.62 -
   10.63 -  (* Query routines *)
   10.64 -  val is_imp    : term -> bool
   10.65 -  val is_forall : term -> bool
   10.66 -  val is_exists : term -> bool
   10.67 -  val is_neg    : term -> bool
   10.68 -  val is_conj   : term -> bool
   10.69 -  val is_disj   : term -> bool
   10.70 -  val is_pair   : term -> bool
   10.71 -  val is_pabs   : term -> bool
   10.72 -
   10.73 -  (* Construction of a term from a list of Preterms *)
   10.74 -  val list_mk_abs    : (term list * term) -> term
   10.75 -  val list_mk_imp    : (term list * term) -> term
   10.76 -  val list_mk_forall : (term list * term) -> term
   10.77 -  val list_mk_conj   : term list -> term
   10.78 -
   10.79 -  (* Destructing a term to a list of Preterms *)
   10.80 -  val strip_comb     : term -> (term * term list)
   10.81 -  val strip_abs      : term -> (term list * term)
   10.82 -  val strip_imp      : term -> (term list * term)
   10.83 -  val strip_forall   : term -> (term list * term)
   10.84 -  val strip_exists   : term -> (term list * term)
   10.85 -  val strip_disj     : term -> term list
   10.86 -
   10.87 -  (* Miscellaneous *)
   10.88 -  val mk_vstruct : typ -> term list -> term
   10.89 -  val gen_all    : term -> term
   10.90 -  val find_term  : (term -> bool) -> term -> term option
   10.91 -  val dest_relation : term -> term * term * term
   10.92 -  val is_WFR : term -> bool
   10.93 -  val ARB : typ -> term
   10.94 -end;
   10.95 -
   10.96 -structure USyntax: USYNTAX =
   10.97 -struct
   10.98 -
   10.99 -infix 4 ##;
  10.100 -
  10.101 -fun USYN_ERR func mesg = Utils.ERR {module = "USyntax", func = func, mesg = mesg};
  10.102 -
  10.103 -
  10.104 -(*---------------------------------------------------------------------------
  10.105 - *
  10.106 - *                            Types
  10.107 - *
  10.108 - *---------------------------------------------------------------------------*)
  10.109 -val mk_prim_vartype = TVar;
  10.110 -fun mk_vartype s = mk_prim_vartype ((s, 0), @{sort type});
  10.111 -
  10.112 -(* But internally, it's useful *)
  10.113 -fun dest_vtype (TVar x) = x
  10.114 -  | dest_vtype _ = raise USYN_ERR "dest_vtype" "not a flexible type variable";
  10.115 -
  10.116 -val is_vartype = can dest_vtype;
  10.117 -
  10.118 -val type_vars  = map mk_prim_vartype o Misc_Legacy.typ_tvars
  10.119 -fun type_varsl L = distinct (op =) (fold (curry op @ o type_vars) L []);
  10.120 -
  10.121 -val alpha  = mk_vartype "'a"
  10.122 -val beta   = mk_vartype "'b"
  10.123 -
  10.124 -val strip_prod_type = HOLogic.flatten_tupleT;
  10.125 -
  10.126 -
  10.127 -
  10.128 -(*---------------------------------------------------------------------------
  10.129 - *
  10.130 - *                              Terms
  10.131 - *
  10.132 - *---------------------------------------------------------------------------*)
  10.133 -
  10.134 -(* Free variables, in order of occurrence, from left to right in the
  10.135 - * syntax tree. *)
  10.136 -fun free_vars_lr tm =
  10.137 -  let fun memb x = let fun m[] = false | m(y::rst) = (x=y)orelse m rst in m end
  10.138 -      fun add (t, frees) = case t of
  10.139 -            Free   _ => if (memb t frees) then frees else t::frees
  10.140 -          | Abs (_,_,body) => add(body,frees)
  10.141 -          | f$t =>  add(t, add(f, frees))
  10.142 -          | _ => frees
  10.143 -  in rev(add(tm,[]))
  10.144 -  end;
  10.145 -
  10.146 -
  10.147 -
  10.148 -val type_vars_in_term = map mk_prim_vartype o Misc_Legacy.term_tvars;
  10.149 -
  10.150 -
  10.151 -
  10.152 -(* Prelogic *)
  10.153 -fun dest_tybinding (v,ty) = (#1(dest_vtype v),ty)
  10.154 -fun inst theta = subst_vars (map dest_tybinding theta,[])
  10.155 -
  10.156 -
  10.157 -(* Construction routines *)
  10.158 -
  10.159 -fun mk_abs{Bvar as Var((s,_),ty),Body}  = Abs(s,ty,abstract_over(Bvar,Body))
  10.160 -  | mk_abs{Bvar as Free(s,ty),Body}  = Abs(s,ty,abstract_over(Bvar,Body))
  10.161 -  | mk_abs _ = raise USYN_ERR "mk_abs" "Bvar is not a variable";
  10.162 -
  10.163 -
  10.164 -fun mk_imp{ant,conseq} =
  10.165 -   let val c = Const(@{const_name HOL.implies},HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
  10.166 -   in list_comb(c,[ant,conseq])
  10.167 -   end;
  10.168 -
  10.169 -fun mk_select (r as {Bvar,Body}) =
  10.170 -  let val ty = type_of Bvar
  10.171 -      val c = Const(@{const_name Eps},(ty --> HOLogic.boolT) --> ty)
  10.172 -  in list_comb(c,[mk_abs r])
  10.173 -  end;
  10.174 -
  10.175 -fun mk_forall (r as {Bvar,Body}) =
  10.176 -  let val ty = type_of Bvar
  10.177 -      val c = Const(@{const_name All},(ty --> HOLogic.boolT) --> HOLogic.boolT)
  10.178 -  in list_comb(c,[mk_abs r])
  10.179 -  end;
  10.180 -
  10.181 -fun mk_exists (r as {Bvar,Body}) =
  10.182 -  let val ty = type_of Bvar
  10.183 -      val c = Const(@{const_name Ex},(ty --> HOLogic.boolT) --> HOLogic.boolT)
  10.184 -  in list_comb(c,[mk_abs r])
  10.185 -  end;
  10.186 -
  10.187 -
  10.188 -fun mk_conj{conj1,conj2} =
  10.189 -   let val c = Const(@{const_name HOL.conj},HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
  10.190 -   in list_comb(c,[conj1,conj2])
  10.191 -   end;
  10.192 -
  10.193 -fun mk_disj{disj1,disj2} =
  10.194 -   let val c = Const(@{const_name HOL.disj},HOLogic.boolT --> HOLogic.boolT --> HOLogic.boolT)
  10.195 -   in list_comb(c,[disj1,disj2])
  10.196 -   end;
  10.197 -
  10.198 -fun prod_ty ty1 ty2 = HOLogic.mk_prodT (ty1,ty2);
  10.199 -
  10.200 -local
  10.201 -fun mk_uncurry (xt, yt, zt) =
  10.202 -    Const(@{const_name case_prod}, (xt --> yt --> zt) --> prod_ty xt yt --> zt)
  10.203 -fun dest_pair(Const(@{const_name Pair},_) $ M $ N) = {fst=M, snd=N}
  10.204 -  | dest_pair _ = raise USYN_ERR "dest_pair" "not a pair"
  10.205 -fun is_var (Var _) = true | is_var (Free _) = true | is_var _ = false
  10.206 -in
  10.207 -fun mk_pabs{varstruct,body} =
  10.208 - let fun mpa (varstruct, body) =
  10.209 -       if is_var varstruct
  10.210 -       then mk_abs {Bvar = varstruct, Body = body}
  10.211 -       else let val {fst, snd} = dest_pair varstruct
  10.212 -            in mk_uncurry (type_of fst, type_of snd, type_of body) $
  10.213 -               mpa (fst, mpa (snd, body))
  10.214 -            end
  10.215 - in mpa (varstruct, body) end
  10.216 - handle TYPE _ => raise USYN_ERR "mk_pabs" "";
  10.217 -end;
  10.218 -
  10.219 -(* Destruction routines *)
  10.220 -
  10.221 -datatype lambda = VAR   of {Name : string, Ty : typ}
  10.222 -                | CONST of {Name : string, Ty : typ}
  10.223 -                | COMB  of {Rator: term, Rand : term}
  10.224 -                | LAMB  of {Bvar : term, Body : term};
  10.225 -
  10.226 -
  10.227 -fun dest_term(Var((s,i),ty)) = VAR{Name = s, Ty = ty}
  10.228 -  | dest_term(Free(s,ty))    = VAR{Name = s, Ty = ty}
  10.229 -  | dest_term(Const(s,ty))   = CONST{Name = s, Ty = ty}
  10.230 -  | dest_term(M$N)           = COMB{Rator=M,Rand=N}
  10.231 -  | dest_term(Abs(s,ty,M))   = let  val v = Free(s,ty)
  10.232 -                               in LAMB{Bvar = v, Body = Term.betapply (M,v)}
  10.233 -                               end
  10.234 -  | dest_term(Bound _)       = raise USYN_ERR "dest_term" "Bound";
  10.235 -
  10.236 -fun dest_const(Const(s,ty)) = {Name = s, Ty = ty}
  10.237 -  | dest_const _ = raise USYN_ERR "dest_const" "not a constant";
  10.238 -
  10.239 -fun dest_comb(t1 $ t2) = {Rator = t1, Rand = t2}
  10.240 -  | dest_comb _ =  raise USYN_ERR "dest_comb" "not a comb";
  10.241 -
  10.242 -fun dest_abs used (a as Abs(s, ty, M)) =
  10.243 -     let
  10.244 -       val s' = singleton (Name.variant_list used) s;
  10.245 -       val v = Free(s', ty);
  10.246 -     in ({Bvar = v, Body = Term.betapply (a,v)}, s'::used)
  10.247 -     end
  10.248 -  | dest_abs _ _ =  raise USYN_ERR "dest_abs" "not an abstraction";
  10.249 -
  10.250 -fun dest_eq(Const(@{const_name HOL.eq},_) $ M $ N) = {lhs=M, rhs=N}
  10.251 -  | dest_eq _ = raise USYN_ERR "dest_eq" "not an equality";
  10.252 -
  10.253 -fun dest_imp(Const(@{const_name HOL.implies},_) $ M $ N) = {ant=M, conseq=N}
  10.254 -  | dest_imp _ = raise USYN_ERR "dest_imp" "not an implication";
  10.255 -
  10.256 -fun dest_forall(Const(@{const_name All},_) $ (a as Abs _)) = fst (dest_abs [] a)
  10.257 -  | dest_forall _ = raise USYN_ERR "dest_forall" "not a forall";
  10.258 -
  10.259 -fun dest_exists(Const(@{const_name Ex},_) $ (a as Abs _)) = fst (dest_abs [] a)
  10.260 -  | dest_exists _ = raise USYN_ERR "dest_exists" "not an existential";
  10.261 -
  10.262 -fun dest_neg(Const(@{const_name Not},_) $ M) = M
  10.263 -  | dest_neg _ = raise USYN_ERR "dest_neg" "not a negation";
  10.264 -
  10.265 -fun dest_conj(Const(@{const_name HOL.conj},_) $ M $ N) = {conj1=M, conj2=N}
  10.266 -  | dest_conj _ = raise USYN_ERR "dest_conj" "not a conjunction";
  10.267 -
  10.268 -fun dest_disj(Const(@{const_name HOL.disj},_) $ M $ N) = {disj1=M, disj2=N}
  10.269 -  | dest_disj _ = raise USYN_ERR "dest_disj" "not a disjunction";
  10.270 -
  10.271 -fun mk_pair{fst,snd} =
  10.272 -   let val ty1 = type_of fst
  10.273 -       val ty2 = type_of snd
  10.274 -       val c = Const(@{const_name Pair},ty1 --> ty2 --> prod_ty ty1 ty2)
  10.275 -   in list_comb(c,[fst,snd])
  10.276 -   end;
  10.277 -
  10.278 -fun dest_pair(Const(@{const_name Pair},_) $ M $ N) = {fst=M, snd=N}
  10.279 -  | dest_pair _ = raise USYN_ERR "dest_pair" "not a pair";
  10.280 -
  10.281 -
  10.282 -local  fun ucheck t = (if #Name (dest_const t) = @{const_name case_prod} then t
  10.283 -                       else raise Match)
  10.284 -in
  10.285 -fun dest_pabs used tm =
  10.286 -   let val ({Bvar,Body}, used') = dest_abs used tm
  10.287 -   in {varstruct = Bvar, body = Body, used = used'}
  10.288 -   end handle Utils.ERR _ =>
  10.289 -          let val {Rator,Rand} = dest_comb tm
  10.290 -              val _ = ucheck Rator
  10.291 -              val {varstruct = lv, body, used = used'} = dest_pabs used Rand
  10.292 -              val {varstruct = rv, body, used = used''} = dest_pabs used' body
  10.293 -          in {varstruct = mk_pair {fst = lv, snd = rv}, body = body, used = used''}
  10.294 -          end
  10.295 -end;
  10.296 -
  10.297 -
  10.298 -val lhs   = #lhs o dest_eq
  10.299 -val rhs   = #rhs o dest_eq
  10.300 -val rand  = #Rand o dest_comb
  10.301 -
  10.302 -
  10.303 -(* Query routines *)
  10.304 -val is_imp    = can dest_imp
  10.305 -val is_forall = can dest_forall
  10.306 -val is_exists = can dest_exists
  10.307 -val is_neg    = can dest_neg
  10.308 -val is_conj   = can dest_conj
  10.309 -val is_disj   = can dest_disj
  10.310 -val is_pair   = can dest_pair
  10.311 -val is_pabs   = can (dest_pabs [])
  10.312 -
  10.313 -
  10.314 -(* Construction of a cterm from a list of Terms *)
  10.315 -
  10.316 -fun list_mk_abs(L,tm) = fold_rev (fn v => fn M => mk_abs{Bvar=v, Body=M}) L tm;
  10.317 -
  10.318 -(* These others are almost never used *)
  10.319 -fun list_mk_imp(A,c) = fold_rev (fn a => fn tm => mk_imp{ant=a,conseq=tm}) A c;
  10.320 -fun list_mk_forall(V,t) = fold_rev (fn v => fn b => mk_forall{Bvar=v, Body=b})V t;
  10.321 -val list_mk_conj = Utils.end_itlist(fn c1 => fn tm => mk_conj{conj1=c1, conj2=tm})
  10.322 -
  10.323 -
  10.324 -(* Need to reverse? *)
  10.325 -fun gen_all tm = list_mk_forall(Misc_Legacy.term_frees tm, tm);
  10.326 -
  10.327 -(* Destructing a cterm to a list of Terms *)
  10.328 -fun strip_comb tm =
  10.329 -   let fun dest(M$N, A) = dest(M, N::A)
  10.330 -         | dest x = x
  10.331 -   in dest(tm,[])
  10.332 -   end;
  10.333 -
  10.334 -fun strip_abs(tm as Abs _) =
  10.335 -       let val ({Bvar,Body}, _) = dest_abs [] tm
  10.336 -           val (bvs, core) = strip_abs Body
  10.337 -       in (Bvar::bvs, core)
  10.338 -       end
  10.339 -  | strip_abs M = ([],M);
  10.340 -
  10.341 -
  10.342 -fun strip_imp fm =
  10.343 -   if (is_imp fm)
  10.344 -   then let val {ant,conseq} = dest_imp fm
  10.345 -            val (was,wb) = strip_imp conseq
  10.346 -        in ((ant::was), wb)
  10.347 -        end
  10.348 -   else ([],fm);
  10.349 -
  10.350 -fun strip_forall fm =
  10.351 -   if (is_forall fm)
  10.352 -   then let val {Bvar,Body} = dest_forall fm
  10.353 -            val (bvs,core) = strip_forall Body
  10.354 -        in ((Bvar::bvs), core)
  10.355 -        end
  10.356 -   else ([],fm);
  10.357 -
  10.358 -
  10.359 -fun strip_exists fm =
  10.360 -   if (is_exists fm)
  10.361 -   then let val {Bvar, Body} = dest_exists fm
  10.362 -            val (bvs,core) = strip_exists Body
  10.363 -        in (Bvar::bvs, core)
  10.364 -        end
  10.365 -   else ([],fm);
  10.366 -
  10.367 -fun strip_disj w =
  10.368 -   if (is_disj w)
  10.369 -   then let val {disj1,disj2} = dest_disj w
  10.370 -        in (strip_disj disj1@strip_disj disj2)
  10.371 -        end
  10.372 -   else [w];
  10.373 -
  10.374 -
  10.375 -(* Miscellaneous *)
  10.376 -
  10.377 -fun mk_vstruct ty V =
  10.378 -  let fun follow_prod_type (Type(@{type_name Product_Type.prod},[ty1,ty2])) vs =
  10.379 -              let val (ltm,vs1) = follow_prod_type ty1 vs
  10.380 -                  val (rtm,vs2) = follow_prod_type ty2 vs1
  10.381 -              in (mk_pair{fst=ltm, snd=rtm}, vs2) end
  10.382 -        | follow_prod_type _ (v::vs) = (v,vs)
  10.383 -  in #1 (follow_prod_type ty V)  end;
  10.384 -
  10.385 -
  10.386 -(* Search a term for a sub-term satisfying the predicate p. *)
  10.387 -fun find_term p =
  10.388 -   let fun find tm =
  10.389 -      if (p tm) then SOME tm
  10.390 -      else case tm of
  10.391 -          Abs(_,_,body) => find body
  10.392 -        | (t$u)         => (case find t of NONE => find u | some => some)
  10.393 -        | _             => NONE
  10.394 -   in find
  10.395 -   end;
  10.396 -
  10.397 -fun dest_relation tm =
  10.398 -   if (type_of tm = HOLogic.boolT)
  10.399 -   then let val (Const(@{const_name Set.member},_) $ (Const(@{const_name Pair},_)$y$x) $ R) = tm
  10.400 -        in (R,y,x)
  10.401 -        end handle Bind => raise USYN_ERR "dest_relation" "unexpected term structure"
  10.402 -   else raise USYN_ERR "dest_relation" "not a boolean term";
  10.403 -
  10.404 -fun is_WFR (Const(@{const_name Wellfounded.wf},_)$_) = true
  10.405 -  | is_WFR _                 = false;
  10.406 -
  10.407 -fun ARB ty = mk_select{Bvar=Free("v",ty),
  10.408 -                       Body=Const(@{const_name True},HOLogic.boolT)};
  10.409 -
  10.410 -end;
    11.1 --- a/src/HOL/Tools/TFL/utils.ML	Fri Jun 19 18:41:21 2015 +0200
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,54 +0,0 @@
    11.4 -(*  Title:      HOL/Tools/TFL/utils.ML
    11.5 -    Author:     Konrad Slind, Cambridge University Computer Laboratory
    11.6 -
    11.7 -Basic utilities.
    11.8 -*)
    11.9 -
   11.10 -signature UTILS =
   11.11 -sig
   11.12 -  exception ERR of {module: string, func: string, mesg: string}
   11.13 -  val end_itlist: ('a -> 'a -> 'a) -> 'a list -> 'a
   11.14 -  val itlist2: ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
   11.15 -  val pluck: ('a -> bool) -> 'a list -> 'a * 'a list
   11.16 -  val zip3: 'a list -> 'b list -> 'c list -> ('a*'b*'c) list
   11.17 -  val take: ('a -> 'b) -> int * 'a list -> 'b list
   11.18 -end;
   11.19 -
   11.20 -structure Utils: UTILS =
   11.21 -struct
   11.22 -
   11.23 -(*standard exception for TFL*)
   11.24 -exception ERR of {module: string, func: string, mesg: string};
   11.25 -
   11.26 -fun UTILS_ERR func mesg = ERR {module = "Utils", func = func, mesg = mesg};
   11.27 -
   11.28 -
   11.29 -fun end_itlist f [] = raise (UTILS_ERR "end_itlist" "list too short")
   11.30 -  | end_itlist f [x] = x 
   11.31 -  | end_itlist f (x :: xs) = f x (end_itlist f xs);
   11.32 -
   11.33 -fun itlist2 f L1 L2 base_value =
   11.34 - let fun it ([],[]) = base_value
   11.35 -       | it ((a::rst1),(b::rst2)) = f a b (it (rst1,rst2))
   11.36 -       | it _ = raise UTILS_ERR "itlist2" "different length lists"
   11.37 - in  it (L1,L2)
   11.38 - end;
   11.39 -
   11.40 -fun pluck p  =
   11.41 -  let fun remv ([],_) = raise UTILS_ERR "pluck" "item not found"
   11.42 -        | remv (h::t, A) = if p h then (h, rev A @ t) else remv (t,h::A)
   11.43 -  in fn L => remv(L,[])
   11.44 -  end;
   11.45 -
   11.46 -fun take f =
   11.47 -  let fun grab(0,L) = []
   11.48 -        | grab(n, x::rst) = f x::grab(n-1,rst)
   11.49 -  in grab
   11.50 -  end;
   11.51 -
   11.52 -fun zip3 [][][] = []
   11.53 -  | zip3 (x::l1) (y::l2) (z::l3) = (x,y,z)::zip3 l1 l2 l3
   11.54 -  | zip3 _ _ _ = raise UTILS_ERR "zip3" "different lengths";
   11.55 -
   11.56 -
   11.57 -end;
    12.1 --- a/src/HOL/Tools/recdef.ML	Fri Jun 19 18:41:21 2015 +0200
    12.2 +++ b/src/HOL/Tools/recdef.ML	Fri Jun 19 19:13:15 2015 +0200
    12.3 @@ -4,305 +4,3 @@
    12.4  Wrapper module for Konrad Slind's TFL package.
    12.5  *)
    12.6  
    12.7 -signature RECDEF =
    12.8 -sig
    12.9 -  val get_recdef: theory -> string
   12.10 -    -> {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list} option
   12.11 -  val get_hints: Proof.context -> {simps: thm list, congs: (string * thm) list, wfs: thm list}
   12.12 -  val simp_add: attribute
   12.13 -  val simp_del: attribute
   12.14 -  val cong_add: attribute
   12.15 -  val cong_del: attribute
   12.16 -  val wf_add: attribute
   12.17 -  val wf_del: attribute
   12.18 -  val add_recdef: bool -> xstring -> string -> ((binding * string) * Token.src list) list ->
   12.19 -    Token.src option -> theory -> theory
   12.20 -      * {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list}
   12.21 -  val add_recdef_i: bool -> xstring -> term -> ((binding * term) * attribute list) list ->
   12.22 -    theory -> theory * {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list}
   12.23 -  val defer_recdef: xstring -> string list -> (Facts.ref * Token.src list) list
   12.24 -    -> theory -> theory * {induct_rules: thm}
   12.25 -  val defer_recdef_i: xstring -> term list -> thm list -> theory -> theory * {induct_rules: thm}
   12.26 -  val recdef_tc: bstring * Token.src list -> xstring -> int option -> bool ->
   12.27 -    local_theory -> Proof.state
   12.28 -  val recdef_tc_i: bstring * Token.src list -> string -> int option -> bool ->
   12.29 -    local_theory -> Proof.state
   12.30 -end;
   12.31 -
   12.32 -structure Recdef: RECDEF =
   12.33 -struct
   12.34 -
   12.35 -
   12.36 -(** recdef hints **)
   12.37 -
   12.38 -(* type hints *)
   12.39 -
   12.40 -type hints = {simps: thm list, congs: (string * thm) list, wfs: thm list};
   12.41 -
   12.42 -fun mk_hints (simps, congs, wfs) = {simps = simps, congs = congs, wfs = wfs}: hints;
   12.43 -fun map_hints f ({simps, congs, wfs}: hints) = mk_hints (f (simps, congs, wfs));
   12.44 -
   12.45 -fun map_simps f = map_hints (fn (simps, congs, wfs) => (f simps, congs, wfs));
   12.46 -fun map_congs f = map_hints (fn (simps, congs, wfs) => (simps, f congs, wfs));
   12.47 -fun map_wfs f = map_hints (fn (simps, congs, wfs) => (simps, congs, f wfs));
   12.48 -
   12.49 -
   12.50 -(* congruence rules *)
   12.51 -
   12.52 -local
   12.53 -
   12.54 -val cong_head =
   12.55 -  fst o Term.dest_Const o Term.head_of o fst o Logic.dest_equals o Thm.concl_of;
   12.56 -
   12.57 -fun prep_cong raw_thm =
   12.58 -  let val thm = safe_mk_meta_eq raw_thm in (cong_head thm, thm) end;
   12.59 -
   12.60 -in
   12.61 -
   12.62 -fun add_cong raw_thm congs =
   12.63 -  let
   12.64 -    val (c, thm) = prep_cong raw_thm;
   12.65 -    val _ = if AList.defined (op =) congs c
   12.66 -      then warning ("Overwriting recdef congruence rule for " ^ quote c)
   12.67 -      else ();
   12.68 -  in AList.update (op =) (c, thm) congs end;
   12.69 -
   12.70 -fun del_cong raw_thm congs =
   12.71 -  let
   12.72 -    val (c, thm) = prep_cong raw_thm;
   12.73 -    val _ = if AList.defined (op =) congs c
   12.74 -      then ()
   12.75 -      else warning ("No recdef congruence rule for " ^ quote c);
   12.76 -  in AList.delete (op =) c congs end;
   12.77 -
   12.78 -end;
   12.79 -
   12.80 -
   12.81 -
   12.82 -(** global and local recdef data **)
   12.83 -
   12.84 -(* theory data *)
   12.85 -
   12.86 -type recdef_info = {lhs: term, simps: thm list, rules: thm list list, induct: thm, tcs: term list};
   12.87 -
   12.88 -structure Data = Generic_Data
   12.89 -(
   12.90 -  type T = recdef_info Symtab.table * hints;
   12.91 -  val empty = (Symtab.empty, mk_hints ([], [], [])): T;
   12.92 -  val extend = I;
   12.93 -  fun merge
   12.94 -   ((tab1, {simps = simps1, congs = congs1, wfs = wfs1}),
   12.95 -    (tab2, {simps = simps2, congs = congs2, wfs = wfs2})) : T =
   12.96 -      (Symtab.merge (K true) (tab1, tab2),
   12.97 -        mk_hints (Thm.merge_thms (simps1, simps2),
   12.98 -          AList.merge (op =) (K true) (congs1, congs2),
   12.99 -          Thm.merge_thms (wfs1, wfs2)));
  12.100 -);
  12.101 -
  12.102 -val get_recdef = Symtab.lookup o #1 o Data.get o Context.Theory;
  12.103 -
  12.104 -fun put_recdef name info =
  12.105 -  (Context.theory_map o Data.map o apfst) (fn tab =>
  12.106 -    Symtab.update_new (name, info) tab
  12.107 -      handle Symtab.DUP _ => error ("Duplicate recursive function definition " ^ quote name));
  12.108 -
  12.109 -val get_hints = #2 o Data.get o Context.Proof;
  12.110 -val map_hints = Data.map o apsnd;
  12.111 -
  12.112 -
  12.113 -(* attributes *)
  12.114 -
  12.115 -fun attrib f = Thm.declaration_attribute (map_hints o f);
  12.116 -
  12.117 -val simp_add = attrib (map_simps o Thm.add_thm);
  12.118 -val simp_del = attrib (map_simps o Thm.del_thm);
  12.119 -val cong_add = attrib (map_congs o add_cong);
  12.120 -val cong_del = attrib (map_congs o del_cong);
  12.121 -val wf_add = attrib (map_wfs o Thm.add_thm);
  12.122 -val wf_del = attrib (map_wfs o Thm.del_thm);
  12.123 -
  12.124 -
  12.125 -(* modifiers *)
  12.126 -
  12.127 -val recdef_simpN = "recdef_simp";
  12.128 -val recdef_congN = "recdef_cong";
  12.129 -val recdef_wfN = "recdef_wf";
  12.130 -
  12.131 -val recdef_modifiers =
  12.132 - [Args.$$$ recdef_simpN -- Args.colon >> K (Method.modifier simp_add @{here}),
  12.133 -  Args.$$$ recdef_simpN -- Args.add -- Args.colon >> K (Method.modifier simp_add @{here}),
  12.134 -  Args.$$$ recdef_simpN -- Args.del -- Args.colon >> K (Method.modifier simp_del @{here}),
  12.135 -  Args.$$$ recdef_congN -- Args.colon >> K (Method.modifier cong_add @{here}),
  12.136 -  Args.$$$ recdef_congN -- Args.add -- Args.colon >> K (Method.modifier cong_add @{here}),
  12.137 -  Args.$$$ recdef_congN -- Args.del -- Args.colon >> K (Method.modifier cong_del @{here}),
  12.138 -  Args.$$$ recdef_wfN -- Args.colon >> K (Method.modifier wf_add @{here}),
  12.139 -  Args.$$$ recdef_wfN -- Args.add -- Args.colon >> K (Method.modifier wf_add @{here}),
  12.140 -  Args.$$$ recdef_wfN -- Args.del -- Args.colon >> K (Method.modifier wf_del @{here})] @
  12.141 -  Clasimp.clasimp_modifiers;
  12.142 -
  12.143 -
  12.144 -
  12.145 -(** prepare hints **)
  12.146 -
  12.147 -fun prepare_hints opt_src ctxt =
  12.148 -  let
  12.149 -    val ctxt' =
  12.150 -      (case opt_src of
  12.151 -        NONE => ctxt
  12.152 -      | SOME src => #2 (Token.syntax (Method.sections recdef_modifiers) src ctxt));
  12.153 -    val {simps, congs, wfs} = get_hints ctxt';
  12.154 -    val ctxt'' = ctxt' addsimps simps |> Simplifier.del_cong @{thm imp_cong};
  12.155 -  in ((rev (map snd congs), wfs), ctxt'') end;
  12.156 -
  12.157 -fun prepare_hints_i () ctxt =
  12.158 -  let
  12.159 -    val {simps, congs, wfs} = get_hints ctxt;
  12.160 -    val ctxt' = ctxt addsimps simps |> Simplifier.del_cong @{thm imp_cong};
  12.161 -  in ((rev (map snd congs), wfs), ctxt') end;
  12.162 -
  12.163 -
  12.164 -
  12.165 -(** add_recdef(_i) **)
  12.166 -
  12.167 -fun gen_add_recdef tfl_fn prep_att prep_hints not_permissive raw_name R eq_srcs hints thy =
  12.168 -  let
  12.169 -    val _ = legacy_feature "Old 'recdef' command -- use 'fun' or 'function' instead";
  12.170 -
  12.171 -    val name = Sign.intern_const thy raw_name;
  12.172 -    val bname = Long_Name.base_name name;
  12.173 -    val _ = writeln ("Defining recursive function " ^ quote name ^ " ...");
  12.174 -
  12.175 -    val ((eq_names, eqs), raw_eq_atts) = apfst split_list (split_list eq_srcs);
  12.176 -    val eq_atts = map (map (prep_att thy)) raw_eq_atts;
  12.177 -
  12.178 -    val ((congs, wfs), ctxt) = prep_hints hints (Proof_Context.init_global thy);
  12.179 -    (*We must remove imp_cong to prevent looping when the induction rule
  12.180 -      is simplified. Many induction rules have nested implications that would
  12.181 -      give rise to looping conditional rewriting.*)
  12.182 -    val ({lhs, rules = rules_idx, induct, tcs}, ctxt1) =
  12.183 -      tfl_fn not_permissive congs wfs name R eqs ctxt;
  12.184 -    val rules = (map o map) fst (partition_eq (eq_snd (op = : int * int -> bool)) rules_idx);
  12.185 -    val simp_att =
  12.186 -      if null tcs then [Simplifier.simp_add,
  12.187 -        Named_Theorems.add @{named_theorems nitpick_simp}, Code.add_default_eqn_attribute]
  12.188 -      else [];
  12.189 -    val ((simps' :: rules', [induct']), thy2) =
  12.190 -      Proof_Context.theory_of ctxt1
  12.191 -      |> Sign.add_path bname
  12.192 -      |> Global_Theory.add_thmss
  12.193 -        (((Binding.name "simps", flat rules), simp_att) :: ((eq_names ~~ rules) ~~ eq_atts))
  12.194 -      ||>> Global_Theory.add_thms [((Binding.name "induct", induct), [])]
  12.195 -      ||> Spec_Rules.add_global Spec_Rules.Equational ([lhs], flat rules);
  12.196 -    val result = {lhs = lhs, simps = simps', rules = rules', induct = induct', tcs = tcs};
  12.197 -    val thy3 =
  12.198 -      thy2
  12.199 -      |> put_recdef name result
  12.200 -      |> Sign.parent_path;
  12.201 -  in (thy3, result) end;
  12.202 -
  12.203 -val add_recdef = gen_add_recdef Tfl.define Attrib.attribute_cmd_global prepare_hints;
  12.204 -fun add_recdef_i x y z w = gen_add_recdef Tfl.define_i (K I) prepare_hints_i x y z w ();
  12.205 -
  12.206 -
  12.207 -
  12.208 -(** defer_recdef(_i) **)
  12.209 -
  12.210 -fun gen_defer_recdef tfl_fn eval_thms raw_name eqs raw_congs thy =
  12.211 -  let
  12.212 -    val name = Sign.intern_const thy raw_name;
  12.213 -    val bname = Long_Name.base_name name;
  12.214 -
  12.215 -    val _ = writeln ("Deferred recursive function " ^ quote name ^ " ...");
  12.216 -
  12.217 -    val congs = eval_thms (Proof_Context.init_global thy) raw_congs;
  12.218 -    val (induct_rules, thy2) = tfl_fn congs name eqs thy;
  12.219 -    val ([induct_rules'], thy3) =
  12.220 -      thy2
  12.221 -      |> Sign.add_path bname
  12.222 -      |> Global_Theory.add_thms [((Binding.name "induct_rules", induct_rules), [])]
  12.223 -      ||> Sign.parent_path;
  12.224 -  in (thy3, {induct_rules = induct_rules'}) end;
  12.225 -
  12.226 -val defer_recdef = gen_defer_recdef Tfl.defer Attrib.eval_thms;
  12.227 -val defer_recdef_i = gen_defer_recdef Tfl.defer_i (K I);
  12.228 -
  12.229 -
  12.230 -
  12.231 -(** recdef_tc(_i) **)
  12.232 -
  12.233 -fun gen_recdef_tc prep_att prep_name (bname, raw_atts) raw_name opt_i int lthy =
  12.234 -  let
  12.235 -    val thy = Proof_Context.theory_of lthy;
  12.236 -    val name = prep_name thy raw_name;
  12.237 -    val atts = map (prep_att lthy) raw_atts;
  12.238 -    val tcs =
  12.239 -      (case get_recdef thy name of
  12.240 -        NONE => error ("No recdef definition of constant: " ^ quote name)
  12.241 -      | SOME {tcs, ...} => tcs);
  12.242 -    val i = the_default 1 opt_i;
  12.243 -    val tc = nth tcs (i - 1) handle General.Subscript =>
  12.244 -      error ("No termination condition #" ^ string_of_int i ^
  12.245 -        " in recdef definition of " ^ quote name);
  12.246 -  in
  12.247 -    Specification.theorem "" NONE (K I)
  12.248 -      (Binding.concealed (Binding.name bname), atts) [] []
  12.249 -      (Element.Shows [(Attrib.empty_binding, [(HOLogic.mk_Trueprop tc, [])])]) int lthy
  12.250 -  end;
  12.251 -
  12.252 -val recdef_tc = gen_recdef_tc Attrib.check_src Sign.intern_const;
  12.253 -val recdef_tc_i = gen_recdef_tc (K I) (K I);
  12.254 -
  12.255 -
  12.256 -
  12.257 -(** package setup **)
  12.258 -
  12.259 -(* setup theory *)
  12.260 -
  12.261 -val _ =
  12.262 -  Theory.setup
  12.263 -   (Attrib.setup @{binding recdef_simp} (Attrib.add_del simp_add simp_del)
  12.264 -      "declaration of recdef simp rule" #>
  12.265 -    Attrib.setup @{binding recdef_cong} (Attrib.add_del cong_add cong_del)
  12.266 -      "declaration of recdef cong rule" #>
  12.267 -    Attrib.setup @{binding recdef_wf} (Attrib.add_del wf_add wf_del)
  12.268 -      "declaration of recdef wf rule");
  12.269 -
  12.270 -
  12.271 -(* outer syntax *)
  12.272 -
  12.273 -val hints =
  12.274 -  @{keyword "("} |--
  12.275 -    Parse.!!! (Parse.position @{keyword "hints"} -- Parse.args --| @{keyword ")"})
  12.276 -  >> uncurry Token.src;
  12.277 -
  12.278 -val recdef_decl =
  12.279 -  Scan.optional
  12.280 -    (@{keyword "("} -- Parse.!!! (@{keyword "permissive"} -- @{keyword ")"}) >> K false) true --
  12.281 -  Parse.name -- Parse.term -- Scan.repeat1 (Parse_Spec.opt_thm_name ":" -- Parse.prop)
  12.282 -    -- Scan.option hints
  12.283 -  >> (fn ((((p, f), R), eqs), src) => #1 o add_recdef p f R (map Parse.triple_swap eqs) src);
  12.284 -
  12.285 -val _ =
  12.286 -  Outer_Syntax.command @{command_keyword recdef} "define general recursive functions (obsolete TFL)"
  12.287 -    (recdef_decl >> Toplevel.theory);
  12.288 -
  12.289 -
  12.290 -val defer_recdef_decl =
  12.291 -  Parse.name -- Scan.repeat1 Parse.prop --
  12.292 -  Scan.optional
  12.293 -    (@{keyword "("} |-- @{keyword "congs"} |-- Parse.!!! (Parse.xthms1 --| @{keyword ")"})) []
  12.294 -  >> (fn ((f, eqs), congs) => #1 o defer_recdef f eqs congs);
  12.295 -
  12.296 -val _ =
  12.297 -  Outer_Syntax.command @{command_keyword defer_recdef}
  12.298 -    "defer general recursive functions (obsolete TFL)"
  12.299 -    (defer_recdef_decl >> Toplevel.theory);
  12.300 -
  12.301 -val _ =
  12.302 -  Outer_Syntax.local_theory_to_proof' @{command_keyword recdef_tc}
  12.303 -    "recommence proof of termination condition (obsolete TFL)"
  12.304 -    ((Parse_Spec.opt_thm_name ":" >> apfst Binding.name_of) -- Parse.xname --
  12.305 -        Scan.option (@{keyword "("} |-- Parse.nat --| @{keyword ")"})
  12.306 -      >> (fn ((thm_name, name), i) => recdef_tc thm_name name i));
  12.307 -
  12.308 -end;